1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ P R A G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- This unit contains the semantic processing for all pragmas, both language 27-- and implementation defined. For most pragmas, the parser only does the 28-- most basic job of checking the syntax, so Sem_Prag also contains the code 29-- to complete the syntax checks. Certain pragmas are handled partially or 30-- completely by the parser (see Par.Prag for further details). 31 32with Aspects; use Aspects; 33with Atree; use Atree; 34with Casing; use Casing; 35with Checks; use Checks; 36with Contracts; use Contracts; 37with Csets; use Csets; 38with Debug; use Debug; 39with Einfo; use Einfo; 40with Elists; use Elists; 41with Errout; use Errout; 42with Exp_Dist; use Exp_Dist; 43with Exp_Util; use Exp_Util; 44with Freeze; use Freeze; 45with Ghost; use Ghost; 46with Lib; use Lib; 47with Lib.Writ; use Lib.Writ; 48with Lib.Xref; use Lib.Xref; 49with Namet.Sp; use Namet.Sp; 50with Nlists; use Nlists; 51with Nmake; use Nmake; 52with Output; use Output; 53with Par_SCO; use Par_SCO; 54with Restrict; use Restrict; 55with Rident; use Rident; 56with Rtsfind; use Rtsfind; 57with Sem; use Sem; 58with Sem_Aux; use Sem_Aux; 59with Sem_Ch3; use Sem_Ch3; 60with Sem_Ch6; use Sem_Ch6; 61with Sem_Ch8; use Sem_Ch8; 62with Sem_Ch12; use Sem_Ch12; 63with Sem_Ch13; use Sem_Ch13; 64with Sem_Disp; use Sem_Disp; 65with Sem_Dist; use Sem_Dist; 66with Sem_Elim; use Sem_Elim; 67with Sem_Eval; use Sem_Eval; 68with Sem_Intr; use Sem_Intr; 69with Sem_Mech; use Sem_Mech; 70with Sem_Res; use Sem_Res; 71with Sem_Type; use Sem_Type; 72with Sem_Util; use Sem_Util; 73with Sem_Warn; use Sem_Warn; 74with Stand; use Stand; 75with Sinfo; use Sinfo; 76with Sinfo.CN; use Sinfo.CN; 77with Sinput; use Sinput; 78with Stringt; use Stringt; 79with Stylesw; use Stylesw; 80with Table; 81with Targparm; use Targparm; 82with Tbuild; use Tbuild; 83with Ttypes; 84with Uintp; use Uintp; 85with Uname; use Uname; 86with Urealp; use Urealp; 87with Validsw; use Validsw; 88with Warnsw; use Warnsw; 89 90package body Sem_Prag is 91 92 ---------------------------------------------- 93 -- Common Handling of Import-Export Pragmas -- 94 ---------------------------------------------- 95 96 -- In the following section, a number of Import_xxx and Export_xxx pragmas 97 -- are defined by GNAT. These are compatible with the DEC pragmas of the 98 -- same name, and all have the following common form and processing: 99 100 -- pragma Export_xxx 101 -- [Internal =>] LOCAL_NAME 102 -- [, [External =>] EXTERNAL_SYMBOL] 103 -- [, other optional parameters ]); 104 105 -- pragma Import_xxx 106 -- [Internal =>] LOCAL_NAME 107 -- [, [External =>] EXTERNAL_SYMBOL] 108 -- [, other optional parameters ]); 109 110 -- EXTERNAL_SYMBOL ::= 111 -- IDENTIFIER 112 -- | static_string_EXPRESSION 113 114 -- The internal LOCAL_NAME designates the entity that is imported or 115 -- exported, and must refer to an entity in the current declarative 116 -- part (as required by the rules for LOCAL_NAME). 117 118 -- The external linker name is designated by the External parameter if 119 -- given, or the Internal parameter if not (if there is no External 120 -- parameter, the External parameter is a copy of the Internal name). 121 122 -- If the External parameter is given as a string, then this string is 123 -- treated as an external name (exactly as though it had been given as an 124 -- External_Name parameter for a normal Import pragma). 125 126 -- If the External parameter is given as an identifier (or there is no 127 -- External parameter, so that the Internal identifier is used), then 128 -- the external name is the characters of the identifier, translated 129 -- to all lower case letters. 130 131 -- Note: the external name specified or implied by any of these special 132 -- Import_xxx or Export_xxx pragmas override an external or link name 133 -- specified in a previous Import or Export pragma. 134 135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of 136 -- named notation, following the standard rules for subprogram calls, i.e. 137 -- parameters can be given in any order if named notation is used, and 138 -- positional and named notation can be mixed, subject to the rule that all 139 -- positional parameters must appear first. 140 141 -- Note: All these pragmas are implemented exactly following the DEC design 142 -- and implementation and are intended to be fully compatible with the use 143 -- of these pragmas in the DEC Ada compiler. 144 145 -------------------------------------------- 146 -- Checking for Duplicated External Names -- 147 -------------------------------------------- 148 149 -- It is suspicious if two separate Export pragmas use the same external 150 -- name. The following table is used to diagnose this situation so that 151 -- an appropriate warning can be issued. 152 153 -- The Node_Id stored is for the N_String_Literal node created to hold 154 -- the value of the external name. The Sloc of this node is used to 155 -- cross-reference the location of the duplication. 156 157 package Externals is new Table.Table ( 158 Table_Component_Type => Node_Id, 159 Table_Index_Type => Int, 160 Table_Low_Bound => 0, 161 Table_Initial => 100, 162 Table_Increment => 100, 163 Table_Name => "Name_Externals"); 164 165 ------------------------------------- 166 -- Local Subprograms and Variables -- 167 ------------------------------------- 168 169 function Adjust_External_Name_Case (N : Node_Id) return Node_Id; 170 -- This routine is used for possible casing adjustment of an explicit 171 -- external name supplied as a string literal (the node N), according to 172 -- the casing requirement of Opt.External_Name_Casing. If this is set to 173 -- As_Is, then the string literal is returned unchanged, but if it is set 174 -- to Uppercase or Lowercase, then a new string literal with appropriate 175 -- casing is constructed. 176 177 procedure Analyze_Part_Of 178 (Indic : Node_Id; 179 Item_Id : Entity_Id; 180 Encap : Node_Id; 181 Encap_Id : out Entity_Id; 182 Legal : out Boolean); 183 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and 184 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the 185 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or 186 -- package instantiation. Encap denotes the encapsulating state or single 187 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when 188 -- the indicator is legal. 189 190 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean; 191 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends. 192 -- Query whether a particular item appears in a mixed list of nodes and 193 -- entities. It is assumed that all nodes in the list have entities. 194 195 procedure Check_Postcondition_Use_In_Inlined_Subprogram 196 (Prag : Node_Id; 197 Spec_Id : Entity_Id); 198 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition, 199 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma 200 -- Prag is associated with subprogram Spec_Id subject to Inline_Always. 201 202 procedure Check_State_And_Constituent_Use 203 (States : Elist_Id; 204 Constits : Elist_Id; 205 Context : Node_Id); 206 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_] 207 -- Global and Initializes. Determine whether a state from list States and a 208 -- corresponding constituent from list Constits (if any) appear in the same 209 -- context denoted by Context. If this is the case, emit an error. 210 211 procedure Contract_Freeze_Error 212 (Contract_Id : Entity_Id; 213 Freeze_Id : Entity_Id); 214 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and 215 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity 216 -- of a body which caused contract "freezing" and Contract_Id denotes the 217 -- entity of the affected contstruct. 218 219 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id); 220 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma 221 -- Prag that duplicates previous pragma Prev. 222 223 function Find_Related_Context 224 (Prag : Node_Id; 225 Do_Checks : Boolean := False) return Node_Id; 226 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers, 227 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and 228 -- Part_Of. Find the first source declaration or statement found while 229 -- traversing the previous node chain starting from pragma Prag. If flag 230 -- Do_Checks is set, the routine reports duplicate pragmas. The routine 231 -- returns Empty when reaching the start of the node chain. 232 233 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; 234 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the 235 -- original one, following the renaming chain) is returned. Otherwise the 236 -- entity is returned unchanged. Should be in Einfo??? 237 238 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type; 239 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram 240 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type 241 -- SPARK_Mode_Type. 242 243 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean; 244 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends. 245 -- Determine whether dependency clause Clause is surrounded by extra 246 -- parentheses. If this is the case, issue an error message. 247 248 function Is_CCT_Instance (Ref : Node_Id) return Boolean; 249 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] 250 -- Global. Determine whether reference Ref denotes the current instance of 251 -- a concurrent type. 252 253 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; 254 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of 255 -- pragma Depends. Determine whether the type of dependency item Item is 256 -- tagged, unconstrained array, unconstrained record or a record with at 257 -- least one unconstrained component. 258 259 procedure Record_Possible_Body_Reference 260 (State_Id : Entity_Id; 261 Ref : Node_Id); 262 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] 263 -- Global. Given an abstract state denoted by State_Id and a reference Ref 264 -- to it, determine whether the reference appears in a package body that 265 -- will eventually refine the state. If this is the case, record the 266 -- reference for future checks (see Analyze_Refined_State_In_Decls). 267 268 procedure Resolve_State (N : Node_Id); 269 -- Handle the overloading of state names by functions. When N denotes a 270 -- function, this routine finds the corresponding state and sets the entity 271 -- of N to that of the state. 272 273 procedure Rewrite_Assertion_Kind (N : Node_Id); 274 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class, 275 -- then it is rewritten as an identifier with the corresponding special 276 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check 277 -- and Check_Policy. 278 279 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id); 280 -- Place semantic information on the argument of an Elaborate/Elaborate_All 281 -- pragma. Entity name for unit and its parents is taken from item in 282 -- previous with_clause that mentions the unit. 283 284 Dummy : Integer := 0; 285 pragma Volatile (Dummy); 286 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization 287 288 procedure ip; 289 pragma No_Inline (ip); 290 -- A dummy procedure called when pragma Inspection_Point is analyzed. This 291 -- is just to help debugging the front end. If a pragma Inspection_Point 292 -- is added to a source program, then breaking on ip will get you to that 293 -- point in the program. 294 295 procedure rv; 296 pragma No_Inline (rv); 297 -- This is a dummy function called by the processing for pragma Reviewable. 298 -- It is there for assisting front end debugging. By placing a Reviewable 299 -- pragma in the source program, a breakpoint on rv catches this place in 300 -- the source, allowing convenient stepping to the point of interest. 301 302 ------------------------------- 303 -- Adjust_External_Name_Case -- 304 ------------------------------- 305 306 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is 307 CC : Char_Code; 308 309 begin 310 -- Adjust case of literal if required 311 312 if Opt.External_Name_Exp_Casing = As_Is then 313 return N; 314 315 else 316 -- Copy existing string 317 318 Start_String; 319 320 -- Set proper casing 321 322 for J in 1 .. String_Length (Strval (N)) loop 323 CC := Get_String_Char (Strval (N), J); 324 325 if Opt.External_Name_Exp_Casing = Uppercase 326 and then CC >= Get_Char_Code ('a') 327 and then CC <= Get_Char_Code ('z') 328 then 329 Store_String_Char (CC - 32); 330 331 elsif Opt.External_Name_Exp_Casing = Lowercase 332 and then CC >= Get_Char_Code ('A') 333 and then CC <= Get_Char_Code ('Z') 334 then 335 Store_String_Char (CC + 32); 336 337 else 338 Store_String_Char (CC); 339 end if; 340 end loop; 341 342 return 343 Make_String_Literal (Sloc (N), 344 Strval => End_String); 345 end if; 346 end Adjust_External_Name_Case; 347 348 ----------------------------------------- 349 -- Analyze_Contract_Cases_In_Decl_Part -- 350 ----------------------------------------- 351 352 procedure Analyze_Contract_Cases_In_Decl_Part 353 (N : Node_Id; 354 Freeze_Id : Entity_Id := Empty) 355 is 356 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 357 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 358 359 Others_Seen : Boolean := False; 360 -- This flag is set when an "others" choice is encountered. It is used 361 -- to detect multiple illegal occurrences of "others". 362 363 procedure Analyze_Contract_Case (CCase : Node_Id); 364 -- Verify the legality of a single contract case 365 366 --------------------------- 367 -- Analyze_Contract_Case -- 368 --------------------------- 369 370 procedure Analyze_Contract_Case (CCase : Node_Id) is 371 Case_Guard : Node_Id; 372 Conseq : Node_Id; 373 Errors : Nat; 374 Extra_Guard : Node_Id; 375 376 begin 377 if Nkind (CCase) = N_Component_Association then 378 Case_Guard := First (Choices (CCase)); 379 Conseq := Expression (CCase); 380 381 -- Each contract case must have exactly one case guard 382 383 Extra_Guard := Next (Case_Guard); 384 385 if Present (Extra_Guard) then 386 Error_Msg_N 387 ("contract case must have exactly one case guard", 388 Extra_Guard); 389 end if; 390 391 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1)) 392 393 if Nkind (Case_Guard) = N_Others_Choice then 394 if Others_Seen then 395 Error_Msg_N 396 ("only one others choice allowed in contract cases", 397 Case_Guard); 398 else 399 Others_Seen := True; 400 end if; 401 402 elsif Others_Seen then 403 Error_Msg_N 404 ("others must be the last choice in contract cases", N); 405 end if; 406 407 -- Preanalyze the case guard and consequence 408 409 if Nkind (Case_Guard) /= N_Others_Choice then 410 Errors := Serious_Errors_Detected; 411 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); 412 413 -- Emit a clarification message when the case guard contains 414 -- at least one undefined reference, possibly due to contract 415 -- "freezing". 416 417 if Errors /= Serious_Errors_Detected 418 and then Present (Freeze_Id) 419 and then Has_Undefined_Reference (Case_Guard) 420 then 421 Contract_Freeze_Error (Spec_Id, Freeze_Id); 422 end if; 423 end if; 424 425 Errors := Serious_Errors_Detected; 426 Preanalyze_Assert_Expression (Conseq, Standard_Boolean); 427 428 -- Emit a clarification message when the consequence contains 429 -- at least one undefined reference, possibly due to contract 430 -- "freezing". 431 432 if Errors /= Serious_Errors_Detected 433 and then Present (Freeze_Id) 434 and then Has_Undefined_Reference (Conseq) 435 then 436 Contract_Freeze_Error (Spec_Id, Freeze_Id); 437 end if; 438 439 -- The contract case is malformed 440 441 else 442 Error_Msg_N ("wrong syntax in contract case", CCase); 443 end if; 444 end Analyze_Contract_Case; 445 446 -- Local variables 447 448 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 449 450 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 451 452 CCase : Node_Id; 453 Restore_Scope : Boolean := False; 454 455 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part 456 457 begin 458 -- Do not analyze the pragma multiple times 459 460 if Is_Analyzed_Pragma (N) then 461 return; 462 end if; 463 464 -- Set the Ghost mode in effect from the pragma. Due to the delayed 465 -- analysis of the pragma, the Ghost mode at point of declaration and 466 -- point of analysis may not necessarely be the same. Use the mode in 467 -- effect at the point of declaration. 468 469 Set_Ghost_Mode (N); 470 471 -- Single and multiple contract cases must appear in aggregate form. If 472 -- this is not the case, then either the parser of the analysis of the 473 -- pragma failed to produce an aggregate. 474 475 pragma Assert (Nkind (CCases) = N_Aggregate); 476 477 if Present (Component_Associations (CCases)) then 478 479 -- Ensure that the formal parameters are visible when analyzing all 480 -- clauses. This falls out of the general rule of aspects pertaining 481 -- to subprogram declarations. 482 483 if not In_Open_Scopes (Spec_Id) then 484 Restore_Scope := True; 485 Push_Scope (Spec_Id); 486 487 if Is_Generic_Subprogram (Spec_Id) then 488 Install_Generic_Formals (Spec_Id); 489 else 490 Install_Formals (Spec_Id); 491 end if; 492 end if; 493 494 CCase := First (Component_Associations (CCases)); 495 while Present (CCase) loop 496 Analyze_Contract_Case (CCase); 497 Next (CCase); 498 end loop; 499 500 if Restore_Scope then 501 End_Scope; 502 end if; 503 504 -- Currently it is not possible to inline pre/postconditions on a 505 -- subprogram subject to pragma Inline_Always. 506 507 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 508 509 -- Otherwise the pragma is illegal 510 511 else 512 Error_Msg_N ("wrong syntax for constract cases", N); 513 end if; 514 515 Ghost_Mode := Save_Ghost_Mode; 516 Set_Is_Analyzed_Pragma (N); 517 end Analyze_Contract_Cases_In_Decl_Part; 518 519 ---------------------------------- 520 -- Analyze_Depends_In_Decl_Part -- 521 ---------------------------------- 522 523 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is 524 Loc : constant Source_Ptr := Sloc (N); 525 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 526 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 527 528 All_Inputs_Seen : Elist_Id := No_Elist; 529 -- A list containing the entities of all the inputs processed so far. 530 -- The list is populated with unique entities because the same input 531 -- may appear in multiple input lists. 532 533 All_Outputs_Seen : Elist_Id := No_Elist; 534 -- A list containing the entities of all the outputs processed so far. 535 -- The list is populated with unique entities because output items are 536 -- unique in a dependence relation. 537 538 Constits_Seen : Elist_Id := No_Elist; 539 -- A list containing the entities of all constituents processed so far. 540 -- It aids in detecting illegal usage of a state and a corresponding 541 -- constituent in pragma [Refinde_]Depends. 542 543 Global_Seen : Boolean := False; 544 -- A flag set when pragma Global has been processed 545 546 Null_Output_Seen : Boolean := False; 547 -- A flag used to track the legality of a null output 548 549 Result_Seen : Boolean := False; 550 -- A flag set when Spec_Id'Result is processed 551 552 States_Seen : Elist_Id := No_Elist; 553 -- A list containing the entities of all states processed so far. It 554 -- helps in detecting illegal usage of a state and a corresponding 555 -- constituent in pragma [Refined_]Depends. 556 557 Subp_Inputs : Elist_Id := No_Elist; 558 Subp_Outputs : Elist_Id := No_Elist; 559 -- Two lists containing the full set of inputs and output of the related 560 -- subprograms. Note that these lists contain both nodes and entities. 561 562 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id); 563 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind 564 -- to the name buffer. The individual kinds are as follows: 565 -- E_Abstract_State - "state" 566 -- E_Constant - "constant" 567 -- E_Discriminant - "discriminant" 568 -- E_Generic_In_Out_Parameter - "generic parameter" 569 -- E_Generic_In_Parameter - "generic parameter" 570 -- E_In_Parameter - "parameter" 571 -- E_In_Out_Parameter - "parameter" 572 -- E_Loop_Parameter - "loop parameter" 573 -- E_Out_Parameter - "parameter" 574 -- E_Protected_Type - "current instance of protected type" 575 -- E_Task_Type - "current instance of task type" 576 -- E_Variable - "global" 577 578 procedure Analyze_Dependency_Clause 579 (Clause : Node_Id; 580 Is_Last : Boolean); 581 -- Verify the legality of a single dependency clause. Flag Is_Last 582 -- denotes whether Clause is the last clause in the relation. 583 584 procedure Check_Function_Return; 585 -- Verify that Funtion'Result appears as one of the outputs 586 -- (SPARK RM 6.1.5(10)). 587 588 procedure Check_Role 589 (Item : Node_Id; 590 Item_Id : Entity_Id; 591 Is_Input : Boolean; 592 Self_Ref : Boolean); 593 -- Ensure that an item fulfils its designated input and/or output role 594 -- as specified by pragma Global (if any) or the enclosing context. If 595 -- this is not the case, emit an error. Item and Item_Id denote the 596 -- attributes of an item. Flag Is_Input should be set when item comes 597 -- from an input list. Flag Self_Ref should be set when the item is an 598 -- output and the dependency clause has operator "+". 599 600 procedure Check_Usage 601 (Subp_Items : Elist_Id; 602 Used_Items : Elist_Id; 603 Is_Input : Boolean); 604 -- Verify that all items from Subp_Items appear in Used_Items. Emit an 605 -- error if this is not the case. 606 607 procedure Normalize_Clause (Clause : Node_Id); 608 -- Remove a self-dependency "+" from the input list of a clause 609 610 ----------------------------- 611 -- Add_Item_To_Name_Buffer -- 612 ----------------------------- 613 614 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is 615 begin 616 if Ekind (Item_Id) = E_Abstract_State then 617 Add_Str_To_Name_Buffer ("state"); 618 619 elsif Ekind (Item_Id) = E_Constant then 620 Add_Str_To_Name_Buffer ("constant"); 621 622 elsif Ekind (Item_Id) = E_Discriminant then 623 Add_Str_To_Name_Buffer ("discriminant"); 624 625 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, 626 E_Generic_In_Parameter) 627 then 628 Add_Str_To_Name_Buffer ("generic parameter"); 629 630 elsif Is_Formal (Item_Id) then 631 Add_Str_To_Name_Buffer ("parameter"); 632 633 elsif Ekind (Item_Id) = E_Loop_Parameter then 634 Add_Str_To_Name_Buffer ("loop parameter"); 635 636 elsif Ekind (Item_Id) = E_Protected_Type 637 or else Is_Single_Protected_Object (Item_Id) 638 then 639 Add_Str_To_Name_Buffer ("current instance of protected type"); 640 641 elsif Ekind (Item_Id) = E_Task_Type 642 or else Is_Single_Task_Object (Item_Id) 643 then 644 Add_Str_To_Name_Buffer ("current instance of task type"); 645 646 elsif Ekind (Item_Id) = E_Variable then 647 Add_Str_To_Name_Buffer ("global"); 648 649 -- The routine should not be called with non-SPARK items 650 651 else 652 raise Program_Error; 653 end if; 654 end Add_Item_To_Name_Buffer; 655 656 ------------------------------- 657 -- Analyze_Dependency_Clause -- 658 ------------------------------- 659 660 procedure Analyze_Dependency_Clause 661 (Clause : Node_Id; 662 Is_Last : Boolean) 663 is 664 procedure Analyze_Input_List (Inputs : Node_Id); 665 -- Verify the legality of a single input list 666 667 procedure Analyze_Input_Output 668 (Item : Node_Id; 669 Is_Input : Boolean; 670 Self_Ref : Boolean; 671 Top_Level : Boolean; 672 Seen : in out Elist_Id; 673 Null_Seen : in out Boolean; 674 Non_Null_Seen : in out Boolean); 675 -- Verify the legality of a single input or output item. Flag 676 -- Is_Input should be set whenever Item is an input, False when it 677 -- denotes an output. Flag Self_Ref should be set when the item is an 678 -- output and the dependency clause has a "+". Flag Top_Level should 679 -- be set whenever Item appears immediately within an input or output 680 -- list. Seen is a collection of all abstract states, objects and 681 -- formals processed so far. Flag Null_Seen denotes whether a null 682 -- input or output has been encountered. Flag Non_Null_Seen denotes 683 -- whether a non-null input or output has been encountered. 684 685 ------------------------ 686 -- Analyze_Input_List -- 687 ------------------------ 688 689 procedure Analyze_Input_List (Inputs : Node_Id) is 690 Inputs_Seen : Elist_Id := No_Elist; 691 -- A list containing the entities of all inputs that appear in the 692 -- current input list. 693 694 Non_Null_Input_Seen : Boolean := False; 695 Null_Input_Seen : Boolean := False; 696 -- Flags used to check the legality of an input list 697 698 Input : Node_Id; 699 700 begin 701 -- Multiple inputs appear as an aggregate 702 703 if Nkind (Inputs) = N_Aggregate then 704 if Present (Component_Associations (Inputs)) then 705 SPARK_Msg_N 706 ("nested dependency relations not allowed", Inputs); 707 708 elsif Present (Expressions (Inputs)) then 709 Input := First (Expressions (Inputs)); 710 while Present (Input) loop 711 Analyze_Input_Output 712 (Item => Input, 713 Is_Input => True, 714 Self_Ref => False, 715 Top_Level => False, 716 Seen => Inputs_Seen, 717 Null_Seen => Null_Input_Seen, 718 Non_Null_Seen => Non_Null_Input_Seen); 719 720 Next (Input); 721 end loop; 722 723 -- Syntax error, always report 724 725 else 726 Error_Msg_N ("malformed input dependency list", Inputs); 727 end if; 728 729 -- Process a solitary input 730 731 else 732 Analyze_Input_Output 733 (Item => Inputs, 734 Is_Input => True, 735 Self_Ref => False, 736 Top_Level => False, 737 Seen => Inputs_Seen, 738 Null_Seen => Null_Input_Seen, 739 Non_Null_Seen => Non_Null_Input_Seen); 740 end if; 741 742 -- Detect an illegal dependency clause of the form 743 744 -- (null =>[+] null) 745 746 if Null_Output_Seen and then Null_Input_Seen then 747 SPARK_Msg_N 748 ("null dependency clause cannot have a null input list", 749 Inputs); 750 end if; 751 end Analyze_Input_List; 752 753 -------------------------- 754 -- Analyze_Input_Output -- 755 -------------------------- 756 757 procedure Analyze_Input_Output 758 (Item : Node_Id; 759 Is_Input : Boolean; 760 Self_Ref : Boolean; 761 Top_Level : Boolean; 762 Seen : in out Elist_Id; 763 Null_Seen : in out Boolean; 764 Non_Null_Seen : in out Boolean) 765 is 766 Is_Output : constant Boolean := not Is_Input; 767 Grouped : Node_Id; 768 Item_Id : Entity_Id; 769 770 begin 771 -- Multiple input or output items appear as an aggregate 772 773 if Nkind (Item) = N_Aggregate then 774 if not Top_Level then 775 SPARK_Msg_N ("nested grouping of items not allowed", Item); 776 777 elsif Present (Component_Associations (Item)) then 778 SPARK_Msg_N 779 ("nested dependency relations not allowed", Item); 780 781 -- Recursively analyze the grouped items 782 783 elsif Present (Expressions (Item)) then 784 Grouped := First (Expressions (Item)); 785 while Present (Grouped) loop 786 Analyze_Input_Output 787 (Item => Grouped, 788 Is_Input => Is_Input, 789 Self_Ref => Self_Ref, 790 Top_Level => False, 791 Seen => Seen, 792 Null_Seen => Null_Seen, 793 Non_Null_Seen => Non_Null_Seen); 794 795 Next (Grouped); 796 end loop; 797 798 -- Syntax error, always report 799 800 else 801 Error_Msg_N ("malformed dependency list", Item); 802 end if; 803 804 -- Process attribute 'Result in the context of a dependency clause 805 806 elsif Is_Attribute_Result (Item) then 807 Non_Null_Seen := True; 808 809 Analyze (Item); 810 811 -- Attribute 'Result is allowed to appear on the output side of 812 -- a dependency clause (SPARK RM 6.1.5(6)). 813 814 if Is_Input then 815 SPARK_Msg_N ("function result cannot act as input", Item); 816 817 elsif Null_Seen then 818 SPARK_Msg_N 819 ("cannot mix null and non-null dependency items", Item); 820 821 else 822 Result_Seen := True; 823 end if; 824 825 -- Detect multiple uses of null in a single dependency list or 826 -- throughout the whole relation. Verify the placement of a null 827 -- output list relative to the other clauses (SPARK RM 6.1.5(12)). 828 829 elsif Nkind (Item) = N_Null then 830 if Null_Seen then 831 SPARK_Msg_N 832 ("multiple null dependency relations not allowed", Item); 833 834 elsif Non_Null_Seen then 835 SPARK_Msg_N 836 ("cannot mix null and non-null dependency items", Item); 837 838 else 839 Null_Seen := True; 840 841 if Is_Output then 842 if not Is_Last then 843 SPARK_Msg_N 844 ("null output list must be the last clause in a " 845 & "dependency relation", Item); 846 847 -- Catch a useless dependence of the form: 848 -- null =>+ ... 849 850 elsif Self_Ref then 851 SPARK_Msg_N 852 ("useless dependence, null depends on itself", Item); 853 end if; 854 end if; 855 end if; 856 857 -- Default case 858 859 else 860 Non_Null_Seen := True; 861 862 if Null_Seen then 863 SPARK_Msg_N ("cannot mix null and non-null items", Item); 864 end if; 865 866 Analyze (Item); 867 Resolve_State (Item); 868 869 -- Find the entity of the item. If this is a renaming, climb 870 -- the renaming chain to reach the root object. Renamings of 871 -- non-entire objects do not yield an entity (Empty). 872 873 Item_Id := Entity_Of (Item); 874 875 if Present (Item_Id) then 876 877 -- Constants 878 879 if Ekind_In (Item_Id, E_Constant, 880 E_Discriminant, 881 E_Loop_Parameter) 882 or else 883 884 -- Current instances of concurrent types 885 886 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) 887 or else 888 889 -- Formal parameters 890 891 Ekind_In (Item_Id, E_Generic_In_Out_Parameter, 892 E_Generic_In_Parameter, 893 E_In_Parameter, 894 E_In_Out_Parameter, 895 E_Out_Parameter) 896 or else 897 898 -- States, variables 899 900 Ekind_In (Item_Id, E_Abstract_State, E_Variable) 901 then 902 -- The item denotes a concurrent type, but it is not the 903 -- current instance of an enclosing concurrent type. 904 905 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) 906 and then not Is_CCT_Instance (Item) 907 then 908 SPARK_Msg_N 909 ("invalid use of subtype mark in dependency " 910 & "relation", Item); 911 end if; 912 913 -- Ensure that the item fulfils its role as input and/or 914 -- output as specified by pragma Global or the enclosing 915 -- context. 916 917 Check_Role (Item, Item_Id, Is_Input, Self_Ref); 918 919 -- Detect multiple uses of the same state, variable or 920 -- formal parameter. If this is not the case, add the 921 -- item to the list of processed relations. 922 923 if Contains (Seen, Item_Id) then 924 SPARK_Msg_NE 925 ("duplicate use of item &", Item, Item_Id); 926 else 927 Append_New_Elmt (Item_Id, Seen); 928 end if; 929 930 -- Detect illegal use of an input related to a null 931 -- output. Such input items cannot appear in other 932 -- input lists (SPARK RM 6.1.5(13)). 933 934 if Is_Input 935 and then Null_Output_Seen 936 and then Contains (All_Inputs_Seen, Item_Id) 937 then 938 SPARK_Msg_N 939 ("input of a null output list cannot appear in " 940 & "multiple input lists", Item); 941 end if; 942 943 -- Add an input or a self-referential output to the list 944 -- of all processed inputs. 945 946 if Is_Input or else Self_Ref then 947 Append_New_Elmt (Item_Id, All_Inputs_Seen); 948 end if; 949 950 -- State related checks (SPARK RM 6.1.5(3)) 951 952 if Ekind (Item_Id) = E_Abstract_State then 953 954 -- Package and subprogram bodies are instantiated 955 -- individually in a separate compiler pass. Due to 956 -- this mode of instantiation, the refinement of a 957 -- state may no longer be visible when a subprogram 958 -- body contract is instantiated. Since the generic 959 -- template is legal, do not perform this check in 960 -- the instance to circumvent this oddity. 961 962 if Is_Generic_Instance (Spec_Id) then 963 null; 964 965 -- An abstract state with visible refinement cannot 966 -- appear in pragma [Refined_]Depends as its place 967 -- must be taken by some of its constituents 968 -- (SPARK RM 6.1.4(7)). 969 970 elsif Has_Visible_Refinement (Item_Id) then 971 SPARK_Msg_NE 972 ("cannot mention state & in dependence relation", 973 Item, Item_Id); 974 SPARK_Msg_N ("\use its constituents instead", Item); 975 return; 976 977 -- If the reference to the abstract state appears in 978 -- an enclosing package body that will eventually 979 -- refine the state, record the reference for future 980 -- checks. 981 982 else 983 Record_Possible_Body_Reference 984 (State_Id => Item_Id, 985 Ref => Item); 986 end if; 987 end if; 988 989 -- When the item renames an entire object, replace the 990 -- item with a reference to the object. 991 992 if Entity (Item) /= Item_Id then 993 Rewrite (Item, 994 New_Occurrence_Of (Item_Id, Sloc (Item))); 995 Analyze (Item); 996 end if; 997 998 -- Add the entity of the current item to the list of 999 -- processed items. 1000 1001 if Ekind (Item_Id) = E_Abstract_State then 1002 Append_New_Elmt (Item_Id, States_Seen); 1003 1004 -- The variable may eventually become a constituent of a 1005 -- single protected/task type. Record the reference now 1006 -- and verify its legality when analyzing the contract of 1007 -- the variable (SPARK RM 9.3). 1008 1009 elsif Ekind (Item_Id) = E_Variable then 1010 Record_Possible_Part_Of_Reference 1011 (Var_Id => Item_Id, 1012 Ref => Item); 1013 end if; 1014 1015 if Ekind_In (Item_Id, E_Abstract_State, 1016 E_Constant, 1017 E_Variable) 1018 and then Present (Encapsulating_State (Item_Id)) 1019 then 1020 Append_New_Elmt (Item_Id, Constits_Seen); 1021 end if; 1022 1023 -- All other input/output items are illegal 1024 -- (SPARK RM 6.1.5(1)). 1025 1026 else 1027 SPARK_Msg_N 1028 ("item must denote parameter, variable, state or " 1029 & "current instance of concurren type", Item); 1030 end if; 1031 1032 -- All other input/output items are illegal 1033 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report. 1034 1035 else 1036 Error_Msg_N 1037 ("item must denote parameter, variable, state or current " 1038 & "instance of concurrent type", Item); 1039 end if; 1040 end if; 1041 end Analyze_Input_Output; 1042 1043 -- Local variables 1044 1045 Inputs : Node_Id; 1046 Output : Node_Id; 1047 Self_Ref : Boolean; 1048 1049 Non_Null_Output_Seen : Boolean := False; 1050 -- Flag used to check the legality of an output list 1051 1052 -- Start of processing for Analyze_Dependency_Clause 1053 1054 begin 1055 Inputs := Expression (Clause); 1056 Self_Ref := False; 1057 1058 -- An input list with a self-dependency appears as operator "+" where 1059 -- the actuals inputs are the right operand. 1060 1061 if Nkind (Inputs) = N_Op_Plus then 1062 Inputs := Right_Opnd (Inputs); 1063 Self_Ref := True; 1064 end if; 1065 1066 -- Process the output_list of a dependency_clause 1067 1068 Output := First (Choices (Clause)); 1069 while Present (Output) loop 1070 Analyze_Input_Output 1071 (Item => Output, 1072 Is_Input => False, 1073 Self_Ref => Self_Ref, 1074 Top_Level => True, 1075 Seen => All_Outputs_Seen, 1076 Null_Seen => Null_Output_Seen, 1077 Non_Null_Seen => Non_Null_Output_Seen); 1078 1079 Next (Output); 1080 end loop; 1081 1082 -- Process the input_list of a dependency_clause 1083 1084 Analyze_Input_List (Inputs); 1085 end Analyze_Dependency_Clause; 1086 1087 --------------------------- 1088 -- Check_Function_Return -- 1089 --------------------------- 1090 1091 procedure Check_Function_Return is 1092 begin 1093 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 1094 and then not Result_Seen 1095 then 1096 SPARK_Msg_NE 1097 ("result of & must appear in exactly one output list", 1098 N, Spec_Id); 1099 end if; 1100 end Check_Function_Return; 1101 1102 ---------------- 1103 -- Check_Role -- 1104 ---------------- 1105 1106 procedure Check_Role 1107 (Item : Node_Id; 1108 Item_Id : Entity_Id; 1109 Is_Input : Boolean; 1110 Self_Ref : Boolean) 1111 is 1112 procedure Find_Role 1113 (Item_Is_Input : out Boolean; 1114 Item_Is_Output : out Boolean); 1115 -- Find the input/output role of Item_Id. Flags Item_Is_Input and 1116 -- Item_Is_Output are set depending on the role. 1117 1118 procedure Role_Error 1119 (Item_Is_Input : Boolean; 1120 Item_Is_Output : Boolean); 1121 -- Emit an error message concerning the incorrect use of Item in 1122 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output 1123 -- denote whether the item is an input and/or an output. 1124 1125 --------------- 1126 -- Find_Role -- 1127 --------------- 1128 1129 procedure Find_Role 1130 (Item_Is_Input : out Boolean; 1131 Item_Is_Output : out Boolean) 1132 is 1133 begin 1134 Item_Is_Input := False; 1135 Item_Is_Output := False; 1136 1137 -- Abstract states 1138 1139 if Ekind (Item_Id) = E_Abstract_State then 1140 1141 -- When pragma Global is present, the mode of the state may be 1142 -- further constrained by setting a more restrictive mode. 1143 1144 if Global_Seen then 1145 if Appears_In (Subp_Inputs, Item_Id) then 1146 Item_Is_Input := True; 1147 end if; 1148 1149 if Appears_In (Subp_Outputs, Item_Id) then 1150 Item_Is_Output := True; 1151 end if; 1152 1153 -- Otherwise the state has a default IN OUT mode 1154 1155 else 1156 Item_Is_Input := True; 1157 Item_Is_Output := True; 1158 end if; 1159 1160 -- Constants 1161 1162 elsif Ekind_In (Item_Id, E_Constant, 1163 E_Discriminant, 1164 E_Loop_Parameter) 1165 then 1166 Item_Is_Input := True; 1167 1168 -- Parameters 1169 1170 elsif Ekind_In (Item_Id, E_Generic_In_Parameter, 1171 E_In_Parameter) 1172 then 1173 Item_Is_Input := True; 1174 1175 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, 1176 E_In_Out_Parameter) 1177 then 1178 Item_Is_Input := True; 1179 Item_Is_Output := True; 1180 1181 elsif Ekind (Item_Id) = E_Out_Parameter then 1182 if Scope (Item_Id) = Spec_Id then 1183 1184 -- An OUT parameter of the related subprogram has mode IN 1185 -- if its type is unconstrained or tagged because array 1186 -- bounds, discriminants or tags can be read. 1187 1188 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then 1189 Item_Is_Input := True; 1190 end if; 1191 1192 Item_Is_Output := True; 1193 1194 -- An OUT parameter of an enclosing subprogram behaves as a 1195 -- read-write variable in which case the mode is IN OUT. 1196 1197 else 1198 Item_Is_Input := True; 1199 Item_Is_Output := True; 1200 end if; 1201 1202 -- Protected types 1203 1204 elsif Ekind (Item_Id) = E_Protected_Type then 1205 1206 -- A protected type acts as a formal parameter of mode IN when 1207 -- it applies to a protected function. 1208 1209 if Ekind (Spec_Id) = E_Function then 1210 Item_Is_Input := True; 1211 1212 -- Otherwise the protected type acts as a formal of mode IN OUT 1213 1214 else 1215 Item_Is_Input := True; 1216 Item_Is_Output := True; 1217 end if; 1218 1219 -- Task types 1220 1221 elsif Ekind (Item_Id) = E_Task_Type then 1222 Item_Is_Input := True; 1223 Item_Is_Output := True; 1224 1225 -- Variable case 1226 1227 else pragma Assert (Ekind (Item_Id) = E_Variable); 1228 1229 -- When pragma Global is present, the mode of the variable may 1230 -- be further constrained by setting a more restrictive mode. 1231 1232 if Global_Seen then 1233 1234 -- A variable has mode IN when its type is unconstrained or 1235 -- tagged because array bounds, discriminants or tags can be 1236 -- read. 1237 1238 if Appears_In (Subp_Inputs, Item_Id) 1239 or else Is_Unconstrained_Or_Tagged_Item (Item_Id) 1240 then 1241 Item_Is_Input := True; 1242 end if; 1243 1244 if Appears_In (Subp_Outputs, Item_Id) then 1245 Item_Is_Output := True; 1246 end if; 1247 1248 -- Otherwise the variable has a default IN OUT mode 1249 1250 else 1251 Item_Is_Input := True; 1252 Item_Is_Output := True; 1253 end if; 1254 end if; 1255 end Find_Role; 1256 1257 ---------------- 1258 -- Role_Error -- 1259 ---------------- 1260 1261 procedure Role_Error 1262 (Item_Is_Input : Boolean; 1263 Item_Is_Output : Boolean) 1264 is 1265 Error_Msg : Name_Id; 1266 1267 begin 1268 Name_Len := 0; 1269 1270 -- When the item is not part of the input and the output set of 1271 -- the related subprogram, then it appears as extra in pragma 1272 -- [Refined_]Depends. 1273 1274 if not Item_Is_Input and then not Item_Is_Output then 1275 Add_Item_To_Name_Buffer (Item_Id); 1276 Add_Str_To_Name_Buffer 1277 (" & cannot appear in dependence relation"); 1278 1279 Error_Msg := Name_Find; 1280 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1281 1282 Error_Msg_Name_1 := Chars (Spec_Id); 1283 SPARK_Msg_NE 1284 (Fix_Msg (Spec_Id, "\& is not part of the input or output " 1285 & "set of subprogram %"), Item, Item_Id); 1286 1287 -- The mode of the item and its role in pragma [Refined_]Depends 1288 -- are in conflict. Construct a detailed message explaining the 1289 -- illegality (SPARK RM 6.1.5(5-6)). 1290 1291 else 1292 if Item_Is_Input then 1293 Add_Str_To_Name_Buffer ("read-only"); 1294 else 1295 Add_Str_To_Name_Buffer ("write-only"); 1296 end if; 1297 1298 Add_Char_To_Name_Buffer (' '); 1299 Add_Item_To_Name_Buffer (Item_Id); 1300 Add_Str_To_Name_Buffer (" & cannot appear as "); 1301 1302 if Item_Is_Input then 1303 Add_Str_To_Name_Buffer ("output"); 1304 else 1305 Add_Str_To_Name_Buffer ("input"); 1306 end if; 1307 1308 Add_Str_To_Name_Buffer (" in dependence relation"); 1309 Error_Msg := Name_Find; 1310 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1311 end if; 1312 end Role_Error; 1313 1314 -- Local variables 1315 1316 Item_Is_Input : Boolean; 1317 Item_Is_Output : Boolean; 1318 1319 -- Start of processing for Check_Role 1320 1321 begin 1322 Find_Role (Item_Is_Input, Item_Is_Output); 1323 1324 -- Input item 1325 1326 if Is_Input then 1327 if not Item_Is_Input then 1328 Role_Error (Item_Is_Input, Item_Is_Output); 1329 end if; 1330 1331 -- Self-referential item 1332 1333 elsif Self_Ref then 1334 if not Item_Is_Input or else not Item_Is_Output then 1335 Role_Error (Item_Is_Input, Item_Is_Output); 1336 end if; 1337 1338 -- Output item 1339 1340 elsif not Item_Is_Output then 1341 Role_Error (Item_Is_Input, Item_Is_Output); 1342 end if; 1343 end Check_Role; 1344 1345 ----------------- 1346 -- Check_Usage -- 1347 ----------------- 1348 1349 procedure Check_Usage 1350 (Subp_Items : Elist_Id; 1351 Used_Items : Elist_Id; 1352 Is_Input : Boolean) 1353 is 1354 procedure Usage_Error (Item_Id : Entity_Id); 1355 -- Emit an error concerning the illegal usage of an item 1356 1357 ----------------- 1358 -- Usage_Error -- 1359 ----------------- 1360 1361 procedure Usage_Error (Item_Id : Entity_Id) is 1362 Error_Msg : Name_Id; 1363 1364 begin 1365 -- Input case 1366 1367 if Is_Input then 1368 1369 -- Unconstrained and tagged items are not part of the explicit 1370 -- input set of the related subprogram, they do not have to be 1371 -- present in a dependence relation and should not be flagged 1372 -- (SPARK RM 6.1.5(8)). 1373 1374 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then 1375 Name_Len := 0; 1376 1377 Add_Item_To_Name_Buffer (Item_Id); 1378 Add_Str_To_Name_Buffer 1379 (" & is missing from input dependence list"); 1380 1381 Error_Msg := Name_Find; 1382 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); 1383 end if; 1384 1385 -- Output case (SPARK RM 6.1.5(10)) 1386 1387 else 1388 Name_Len := 0; 1389 1390 Add_Item_To_Name_Buffer (Item_Id); 1391 Add_Str_To_Name_Buffer 1392 (" & is missing from output dependence list"); 1393 1394 Error_Msg := Name_Find; 1395 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); 1396 end if; 1397 end Usage_Error; 1398 1399 -- Local variables 1400 1401 Elmt : Elmt_Id; 1402 Item : Node_Id; 1403 Item_Id : Entity_Id; 1404 1405 -- Start of processing for Check_Usage 1406 1407 begin 1408 if No (Subp_Items) then 1409 return; 1410 end if; 1411 1412 -- Each input or output of the subprogram must appear in a dependency 1413 -- relation. 1414 1415 Elmt := First_Elmt (Subp_Items); 1416 while Present (Elmt) loop 1417 Item := Node (Elmt); 1418 1419 if Nkind (Item) = N_Defining_Identifier then 1420 Item_Id := Item; 1421 else 1422 Item_Id := Entity_Of (Item); 1423 end if; 1424 1425 -- The item does not appear in a dependency 1426 1427 if Present (Item_Id) 1428 and then not Contains (Used_Items, Item_Id) 1429 then 1430 -- The current instance of a concurrent type behaves as a 1431 -- formal parameter (SPARK RM 6.1.4). 1432 1433 if Is_Formal (Item_Id) 1434 or else Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) 1435 then 1436 Usage_Error (Item_Id); 1437 1438 -- States and global objects are not used properly only when 1439 -- the subprogram is subject to pragma Global. 1440 1441 elsif Global_Seen then 1442 Usage_Error (Item_Id); 1443 end if; 1444 end if; 1445 1446 Next_Elmt (Elmt); 1447 end loop; 1448 end Check_Usage; 1449 1450 ---------------------- 1451 -- Normalize_Clause -- 1452 ---------------------- 1453 1454 procedure Normalize_Clause (Clause : Node_Id) is 1455 procedure Create_Or_Modify_Clause 1456 (Output : Node_Id; 1457 Outputs : Node_Id; 1458 Inputs : Node_Id; 1459 After : Node_Id; 1460 In_Place : Boolean; 1461 Multiple : Boolean); 1462 -- Create a brand new clause to represent the self-reference or 1463 -- modify the input and/or output lists of an existing clause. Output 1464 -- denotes a self-referencial output. Outputs is the output list of a 1465 -- clause. Inputs is the input list of a clause. After denotes the 1466 -- clause after which the new clause is to be inserted. Flag In_Place 1467 -- should be set when normalizing the last output of an output list. 1468 -- Flag Multiple should be set when Output comes from a list with 1469 -- multiple items. 1470 1471 ----------------------------- 1472 -- Create_Or_Modify_Clause -- 1473 ----------------------------- 1474 1475 procedure Create_Or_Modify_Clause 1476 (Output : Node_Id; 1477 Outputs : Node_Id; 1478 Inputs : Node_Id; 1479 After : Node_Id; 1480 In_Place : Boolean; 1481 Multiple : Boolean) 1482 is 1483 procedure Propagate_Output 1484 (Output : Node_Id; 1485 Inputs : Node_Id); 1486 -- Handle the various cases of output propagation to the input 1487 -- list. Output denotes a self-referencial output item. Inputs 1488 -- is the input list of a clause. 1489 1490 ---------------------- 1491 -- Propagate_Output -- 1492 ---------------------- 1493 1494 procedure Propagate_Output 1495 (Output : Node_Id; 1496 Inputs : Node_Id) 1497 is 1498 function In_Input_List 1499 (Item : Entity_Id; 1500 Inputs : List_Id) return Boolean; 1501 -- Determine whether a particulat item appears in the input 1502 -- list of a clause. 1503 1504 ------------------- 1505 -- In_Input_List -- 1506 ------------------- 1507 1508 function In_Input_List 1509 (Item : Entity_Id; 1510 Inputs : List_Id) return Boolean 1511 is 1512 Elmt : Node_Id; 1513 1514 begin 1515 Elmt := First (Inputs); 1516 while Present (Elmt) loop 1517 if Entity_Of (Elmt) = Item then 1518 return True; 1519 end if; 1520 1521 Next (Elmt); 1522 end loop; 1523 1524 return False; 1525 end In_Input_List; 1526 1527 -- Local variables 1528 1529 Output_Id : constant Entity_Id := Entity_Of (Output); 1530 Grouped : List_Id; 1531 1532 -- Start of processing for Propagate_Output 1533 1534 begin 1535 -- The clause is of the form: 1536 1537 -- (Output =>+ null) 1538 1539 -- Remove null input and replace it with a copy of the output: 1540 1541 -- (Output => Output) 1542 1543 if Nkind (Inputs) = N_Null then 1544 Rewrite (Inputs, New_Copy_Tree (Output)); 1545 1546 -- The clause is of the form: 1547 1548 -- (Output =>+ (Input1, ..., InputN)) 1549 1550 -- Determine whether the output is not already mentioned in the 1551 -- input list and if not, add it to the list of inputs: 1552 1553 -- (Output => (Output, Input1, ..., InputN)) 1554 1555 elsif Nkind (Inputs) = N_Aggregate then 1556 Grouped := Expressions (Inputs); 1557 1558 if not In_Input_List 1559 (Item => Output_Id, 1560 Inputs => Grouped) 1561 then 1562 Prepend_To (Grouped, New_Copy_Tree (Output)); 1563 end if; 1564 1565 -- The clause is of the form: 1566 1567 -- (Output =>+ Input) 1568 1569 -- If the input does not mention the output, group the two 1570 -- together: 1571 1572 -- (Output => (Output, Input)) 1573 1574 elsif Entity_Of (Inputs) /= Output_Id then 1575 Rewrite (Inputs, 1576 Make_Aggregate (Loc, 1577 Expressions => New_List ( 1578 New_Copy_Tree (Output), 1579 New_Copy_Tree (Inputs)))); 1580 end if; 1581 end Propagate_Output; 1582 1583 -- Local variables 1584 1585 Loc : constant Source_Ptr := Sloc (Clause); 1586 New_Clause : Node_Id; 1587 1588 -- Start of processing for Create_Or_Modify_Clause 1589 1590 begin 1591 -- A null output depending on itself does not require any 1592 -- normalization. 1593 1594 if Nkind (Output) = N_Null then 1595 return; 1596 1597 -- A function result cannot depend on itself because it cannot 1598 -- appear in the input list of a relation (SPARK RM 6.1.5(10)). 1599 1600 elsif Is_Attribute_Result (Output) then 1601 SPARK_Msg_N ("function result cannot depend on itself", Output); 1602 return; 1603 end if; 1604 1605 -- When performing the transformation in place, simply add the 1606 -- output to the list of inputs (if not already there). This 1607 -- case arises when dealing with the last output of an output 1608 -- list. Perform the normalization in place to avoid generating 1609 -- a malformed tree. 1610 1611 if In_Place then 1612 Propagate_Output (Output, Inputs); 1613 1614 -- A list with multiple outputs is slowly trimmed until only 1615 -- one element remains. When this happens, replace aggregate 1616 -- with the element itself. 1617 1618 if Multiple then 1619 Remove (Output); 1620 Rewrite (Outputs, Output); 1621 end if; 1622 1623 -- Default case 1624 1625 else 1626 -- Unchain the output from its output list as it will appear in 1627 -- a new clause. Note that we cannot simply rewrite the output 1628 -- as null because this will violate the semantics of pragma 1629 -- Depends. 1630 1631 Remove (Output); 1632 1633 -- Generate a new clause of the form: 1634 -- (Output => Inputs) 1635 1636 New_Clause := 1637 Make_Component_Association (Loc, 1638 Choices => New_List (Output), 1639 Expression => New_Copy_Tree (Inputs)); 1640 1641 -- The new clause contains replicated content that has already 1642 -- been analyzed. There is not need to reanalyze or renormalize 1643 -- it again. 1644 1645 Set_Analyzed (New_Clause); 1646 1647 Propagate_Output 1648 (Output => First (Choices (New_Clause)), 1649 Inputs => Expression (New_Clause)); 1650 1651 Insert_After (After, New_Clause); 1652 end if; 1653 end Create_Or_Modify_Clause; 1654 1655 -- Local variables 1656 1657 Outputs : constant Node_Id := First (Choices (Clause)); 1658 Inputs : Node_Id; 1659 Last_Output : Node_Id; 1660 Next_Output : Node_Id; 1661 Output : Node_Id; 1662 1663 -- Start of processing for Normalize_Clause 1664 1665 begin 1666 -- A self-dependency appears as operator "+". Remove the "+" from the 1667 -- tree by moving the real inputs to their proper place. 1668 1669 if Nkind (Expression (Clause)) = N_Op_Plus then 1670 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause))); 1671 Inputs := Expression (Clause); 1672 1673 -- Multiple outputs appear as an aggregate 1674 1675 if Nkind (Outputs) = N_Aggregate then 1676 Last_Output := Last (Expressions (Outputs)); 1677 1678 Output := First (Expressions (Outputs)); 1679 while Present (Output) loop 1680 1681 -- Normalization may remove an output from its list, 1682 -- preserve the subsequent output now. 1683 1684 Next_Output := Next (Output); 1685 1686 Create_Or_Modify_Clause 1687 (Output => Output, 1688 Outputs => Outputs, 1689 Inputs => Inputs, 1690 After => Clause, 1691 In_Place => Output = Last_Output, 1692 Multiple => True); 1693 1694 Output := Next_Output; 1695 end loop; 1696 1697 -- Solitary output 1698 1699 else 1700 Create_Or_Modify_Clause 1701 (Output => Outputs, 1702 Outputs => Empty, 1703 Inputs => Inputs, 1704 After => Empty, 1705 In_Place => True, 1706 Multiple => False); 1707 end if; 1708 end if; 1709 end Normalize_Clause; 1710 1711 -- Local variables 1712 1713 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 1714 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 1715 1716 Clause : Node_Id; 1717 Errors : Nat; 1718 Last_Clause : Node_Id; 1719 Restore_Scope : Boolean := False; 1720 1721 -- Start of processing for Analyze_Depends_In_Decl_Part 1722 1723 begin 1724 -- Do not analyze the pragma multiple times 1725 1726 if Is_Analyzed_Pragma (N) then 1727 return; 1728 end if; 1729 1730 -- Empty dependency list 1731 1732 if Nkind (Deps) = N_Null then 1733 1734 -- Gather all states, objects and formal parameters that the 1735 -- subprogram may depend on. These items are obtained from the 1736 -- parameter profile or pragma [Refined_]Global (if available). 1737 1738 Collect_Subprogram_Inputs_Outputs 1739 (Subp_Id => Subp_Id, 1740 Subp_Inputs => Subp_Inputs, 1741 Subp_Outputs => Subp_Outputs, 1742 Global_Seen => Global_Seen); 1743 1744 -- Verify that every input or output of the subprogram appear in a 1745 -- dependency. 1746 1747 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 1748 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 1749 Check_Function_Return; 1750 1751 -- Dependency clauses appear as component associations of an aggregate 1752 1753 elsif Nkind (Deps) = N_Aggregate then 1754 1755 -- Do not attempt to perform analysis of a syntactically illegal 1756 -- clause as this will lead to misleading errors. 1757 1758 if Has_Extra_Parentheses (Deps) then 1759 return; 1760 end if; 1761 1762 if Present (Component_Associations (Deps)) then 1763 Last_Clause := Last (Component_Associations (Deps)); 1764 1765 -- Gather all states, objects and formal parameters that the 1766 -- subprogram may depend on. These items are obtained from the 1767 -- parameter profile or pragma [Refined_]Global (if available). 1768 1769 Collect_Subprogram_Inputs_Outputs 1770 (Subp_Id => Subp_Id, 1771 Subp_Inputs => Subp_Inputs, 1772 Subp_Outputs => Subp_Outputs, 1773 Global_Seen => Global_Seen); 1774 1775 -- When pragma [Refined_]Depends appears on a single concurrent 1776 -- type, it is relocated to the anonymous object. 1777 1778 if Is_Single_Concurrent_Object (Spec_Id) then 1779 null; 1780 1781 -- Ensure that the formal parameters are visible when analyzing 1782 -- all clauses. This falls out of the general rule of aspects 1783 -- pertaining to subprogram declarations. 1784 1785 elsif not In_Open_Scopes (Spec_Id) then 1786 Restore_Scope := True; 1787 Push_Scope (Spec_Id); 1788 1789 if Ekind (Spec_Id) = E_Task_Type then 1790 if Has_Discriminants (Spec_Id) then 1791 Install_Discriminants (Spec_Id); 1792 end if; 1793 1794 elsif Is_Generic_Subprogram (Spec_Id) then 1795 Install_Generic_Formals (Spec_Id); 1796 1797 else 1798 Install_Formals (Spec_Id); 1799 end if; 1800 end if; 1801 1802 Clause := First (Component_Associations (Deps)); 1803 while Present (Clause) loop 1804 Errors := Serious_Errors_Detected; 1805 1806 -- The normalization mechanism may create extra clauses that 1807 -- contain replicated input and output names. There is no need 1808 -- to reanalyze them. 1809 1810 if not Analyzed (Clause) then 1811 Set_Analyzed (Clause); 1812 1813 Analyze_Dependency_Clause 1814 (Clause => Clause, 1815 Is_Last => Clause = Last_Clause); 1816 end if; 1817 1818 -- Do not normalize a clause if errors were detected (count 1819 -- of Serious_Errors has increased) because the inputs and/or 1820 -- outputs may denote illegal items. Normalization is disabled 1821 -- in ASIS mode as it alters the tree by introducing new nodes 1822 -- similar to expansion. 1823 1824 if Serious_Errors_Detected = Errors and then not ASIS_Mode then 1825 Normalize_Clause (Clause); 1826 end if; 1827 1828 Next (Clause); 1829 end loop; 1830 1831 if Restore_Scope then 1832 End_Scope; 1833 end if; 1834 1835 -- Verify that every input or output of the subprogram appear in a 1836 -- dependency. 1837 1838 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 1839 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 1840 Check_Function_Return; 1841 1842 -- The dependency list is malformed. This is a syntax error, always 1843 -- report. 1844 1845 else 1846 Error_Msg_N ("malformed dependency relation", Deps); 1847 return; 1848 end if; 1849 1850 -- The top level dependency relation is malformed. This is a syntax 1851 -- error, always report. 1852 1853 else 1854 Error_Msg_N ("malformed dependency relation", Deps); 1855 goto Leave; 1856 end if; 1857 1858 -- Ensure that a state and a corresponding constituent do not appear 1859 -- together in pragma [Refined_]Depends. 1860 1861 Check_State_And_Constituent_Use 1862 (States => States_Seen, 1863 Constits => Constits_Seen, 1864 Context => N); 1865 1866 <<Leave>> 1867 Set_Is_Analyzed_Pragma (N); 1868 end Analyze_Depends_In_Decl_Part; 1869 1870 -------------------------------------------- 1871 -- Analyze_External_Property_In_Decl_Part -- 1872 -------------------------------------------- 1873 1874 procedure Analyze_External_Property_In_Decl_Part 1875 (N : Node_Id; 1876 Expr_Val : out Boolean) 1877 is 1878 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 1879 Obj_Decl : constant Node_Id := Find_Related_Context (N); 1880 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 1881 Expr : Node_Id; 1882 1883 begin 1884 Expr_Val := False; 1885 1886 -- Do not analyze the pragma multiple times 1887 1888 if Is_Analyzed_Pragma (N) then 1889 return; 1890 end if; 1891 1892 Error_Msg_Name_1 := Pragma_Name (N); 1893 1894 -- An external property pragma must apply to an effectively volatile 1895 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)). 1896 -- The check is performed at the end of the declarative region due to a 1897 -- possible out-of-order arrangement of pragmas: 1898 1899 -- Obj : ...; 1900 -- pragma Async_Readers (Obj); 1901 -- pragma Volatile (Obj); 1902 1903 if not Is_Effectively_Volatile (Obj_Id) then 1904 SPARK_Msg_N 1905 ("external property % must apply to a volatile object", N); 1906 end if; 1907 1908 -- Ensure that the Boolean expression (if present) is static. A missing 1909 -- argument defaults the value to True (SPARK RM 7.1.2(5)). 1910 1911 Expr_Val := True; 1912 1913 if Present (Arg1) then 1914 Expr := Get_Pragma_Arg (Arg1); 1915 1916 if Is_OK_Static_Expression (Expr) then 1917 Expr_Val := Is_True (Expr_Value (Expr)); 1918 end if; 1919 end if; 1920 1921 Set_Is_Analyzed_Pragma (N); 1922 end Analyze_External_Property_In_Decl_Part; 1923 1924 --------------------------------- 1925 -- Analyze_Global_In_Decl_Part -- 1926 --------------------------------- 1927 1928 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is 1929 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 1930 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 1931 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 1932 1933 Constits_Seen : Elist_Id := No_Elist; 1934 -- A list containing the entities of all constituents processed so far. 1935 -- It aids in detecting illegal usage of a state and a corresponding 1936 -- constituent in pragma [Refinde_]Global. 1937 1938 Seen : Elist_Id := No_Elist; 1939 -- A list containing the entities of all the items processed so far. It 1940 -- plays a role in detecting distinct entities. 1941 1942 States_Seen : Elist_Id := No_Elist; 1943 -- A list containing the entities of all states processed so far. It 1944 -- helps in detecting illegal usage of a state and a corresponding 1945 -- constituent in pragma [Refined_]Global. 1946 1947 In_Out_Seen : Boolean := False; 1948 Input_Seen : Boolean := False; 1949 Output_Seen : Boolean := False; 1950 Proof_Seen : Boolean := False; 1951 -- Flags used to verify the consistency of modes 1952 1953 procedure Analyze_Global_List 1954 (List : Node_Id; 1955 Global_Mode : Name_Id := Name_Input); 1956 -- Verify the legality of a single global list declaration. Global_Mode 1957 -- denotes the current mode in effect. 1958 1959 ------------------------- 1960 -- Analyze_Global_List -- 1961 ------------------------- 1962 1963 procedure Analyze_Global_List 1964 (List : Node_Id; 1965 Global_Mode : Name_Id := Name_Input) 1966 is 1967 procedure Analyze_Global_Item 1968 (Item : Node_Id; 1969 Global_Mode : Name_Id); 1970 -- Verify the legality of a single global item declaration denoted by 1971 -- Item. Global_Mode denotes the current mode in effect. 1972 1973 procedure Check_Duplicate_Mode 1974 (Mode : Node_Id; 1975 Status : in out Boolean); 1976 -- Flag Status denotes whether a particular mode has been seen while 1977 -- processing a global list. This routine verifies that Mode is not a 1978 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)). 1979 1980 procedure Check_Mode_Restriction_In_Enclosing_Context 1981 (Item : Node_Id; 1982 Item_Id : Entity_Id); 1983 -- Verify that an item of mode In_Out or Output does not appear as an 1984 -- input in the Global aspect of an enclosing subprogram. If this is 1985 -- the case, emit an error. Item and Item_Id are respectively the 1986 -- item and its entity. 1987 1988 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); 1989 -- Mode denotes either In_Out or Output. Depending on the kind of the 1990 -- related subprogram, emit an error if those two modes apply to a 1991 -- function (SPARK RM 6.1.4(10)). 1992 1993 ------------------------- 1994 -- Analyze_Global_Item -- 1995 ------------------------- 1996 1997 procedure Analyze_Global_Item 1998 (Item : Node_Id; 1999 Global_Mode : Name_Id) 2000 is 2001 Item_Id : Entity_Id; 2002 2003 begin 2004 -- Detect one of the following cases 2005 2006 -- with Global => (null, Name) 2007 -- with Global => (Name_1, null, Name_2) 2008 -- with Global => (Name, null) 2009 2010 if Nkind (Item) = N_Null then 2011 SPARK_Msg_N ("cannot mix null and non-null global items", Item); 2012 return; 2013 end if; 2014 2015 Analyze (Item); 2016 Resolve_State (Item); 2017 2018 -- Find the entity of the item. If this is a renaming, climb the 2019 -- renaming chain to reach the root object. Renamings of non- 2020 -- entire objects do not yield an entity (Empty). 2021 2022 Item_Id := Entity_Of (Item); 2023 2024 if Present (Item_Id) then 2025 2026 -- A global item may denote a formal parameter of an enclosing 2027 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to 2028 -- provide a better error diagnostic. 2029 2030 if Is_Formal (Item_Id) then 2031 if Scope (Item_Id) = Spec_Id then 2032 SPARK_Msg_NE 2033 (Fix_Msg (Spec_Id, "global item cannot reference " 2034 & "parameter of subprogram &"), Item, Spec_Id); 2035 return; 2036 end if; 2037 2038 -- A global item may denote a concurrent type as long as it is 2039 -- the current instance of an enclosing concurrent type 2040 -- (SPARK RM 6.1.4). 2041 2042 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then 2043 if Is_CCT_Instance (Item) then 2044 2045 -- Pragma [Refined_]Global associated with a protected 2046 -- subprogram cannot mention the current instance of a 2047 -- protected type because the instance behaves as a 2048 -- formal parameter. 2049 2050 if Ekind (Item_Id) = E_Protected_Type 2051 and then Scope (Spec_Id) = Item_Id 2052 then 2053 Error_Msg_Name_1 := Chars (Item_Id); 2054 SPARK_Msg_NE 2055 (Fix_Msg (Spec_Id, "global item of subprogram & " 2056 & "cannot reference current instance of protected " 2057 & "type %"), Item, Spec_Id); 2058 return; 2059 2060 -- Pragma [Refined_]Global associated with a task type 2061 -- cannot mention the current instance of a task type 2062 -- because the instance behaves as a formal parameter. 2063 2064 elsif Ekind (Item_Id) = E_Task_Type 2065 and then Spec_Id = Item_Id 2066 then 2067 Error_Msg_Name_1 := Chars (Item_Id); 2068 SPARK_Msg_NE 2069 (Fix_Msg (Spec_Id, "global item of subprogram & " 2070 & "cannot reference current instance of task type " 2071 & "%"), Item, Spec_Id); 2072 return; 2073 end if; 2074 2075 -- Otherwise the global item denotes a subtype mark that is 2076 -- not a current instance. 2077 2078 else 2079 SPARK_Msg_N 2080 ("invalid use of subtype mark in global list", Item); 2081 return; 2082 end if; 2083 2084 -- A formal object may act as a global item inside a generic 2085 2086 elsif Is_Formal_Object (Item_Id) then 2087 null; 2088 2089 -- The only legal references are those to abstract states, 2090 -- objects and various kinds of constants (SPARK RM 6.1.4(4)). 2091 2092 elsif not Ekind_In (Item_Id, E_Abstract_State, 2093 E_Constant, 2094 E_Discriminant, 2095 E_Loop_Parameter, 2096 E_Variable) 2097 then 2098 SPARK_Msg_N 2099 ("global item must denote object, state or current " 2100 & "instance of concurrent type", Item); 2101 return; 2102 end if; 2103 2104 -- State related checks 2105 2106 if Ekind (Item_Id) = E_Abstract_State then 2107 2108 -- Package and subprogram bodies are instantiated 2109 -- individually in a separate compiler pass. Due to this 2110 -- mode of instantiation, the refinement of a state may 2111 -- no longer be visible when a subprogram body contract 2112 -- is instantiated. Since the generic template is legal, 2113 -- do not perform this check in the instance to circumvent 2114 -- this oddity. 2115 2116 if Is_Generic_Instance (Spec_Id) then 2117 null; 2118 2119 -- An abstract state with visible refinement cannot appear 2120 -- in pragma [Refined_]Global as its place must be taken by 2121 -- some of its constituents (SPARK RM 6.1.4(7)). 2122 2123 elsif Has_Visible_Refinement (Item_Id) then 2124 SPARK_Msg_NE 2125 ("cannot mention state & in global refinement", 2126 Item, Item_Id); 2127 SPARK_Msg_N ("\use its constituents instead", Item); 2128 return; 2129 2130 -- An external state cannot appear as a global item of a 2131 -- nonvolatile function (SPARK RM 7.1.3(8)). 2132 2133 elsif Is_External_State (Item_Id) 2134 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function) 2135 and then not Is_Volatile_Function (Spec_Id) 2136 then 2137 SPARK_Msg_NE 2138 ("external state & cannot act as global item of " 2139 & "nonvolatile function", Item, Item_Id); 2140 return; 2141 2142 -- If the reference to the abstract state appears in an 2143 -- enclosing package body that will eventually refine the 2144 -- state, record the reference for future checks. 2145 2146 else 2147 Record_Possible_Body_Reference 2148 (State_Id => Item_Id, 2149 Ref => Item); 2150 end if; 2151 2152 -- Constant related checks 2153 2154 elsif Ekind (Item_Id) = E_Constant then 2155 2156 -- A constant is a read-only item, therefore it cannot act 2157 -- as an output. 2158 2159 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2160 SPARK_Msg_NE 2161 ("constant & cannot act as output", Item, Item_Id); 2162 return; 2163 end if; 2164 2165 -- Discriminant related checks 2166 2167 elsif Ekind (Item_Id) = E_Discriminant then 2168 2169 -- A discriminant is a read-only item, therefore it cannot 2170 -- act as an output. 2171 2172 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2173 SPARK_Msg_NE 2174 ("discriminant & cannot act as output", Item, Item_Id); 2175 return; 2176 end if; 2177 2178 -- Loop parameter related checks 2179 2180 elsif Ekind (Item_Id) = E_Loop_Parameter then 2181 2182 -- A loop parameter is a read-only item, therefore it cannot 2183 -- act as an output. 2184 2185 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2186 SPARK_Msg_NE 2187 ("loop parameter & cannot act as output", 2188 Item, Item_Id); 2189 return; 2190 end if; 2191 2192 -- Variable related checks. These are only relevant when 2193 -- SPARK_Mode is on as they are not standard Ada legality 2194 -- rules. 2195 2196 elsif SPARK_Mode = On 2197 and then Ekind (Item_Id) = E_Variable 2198 and then Is_Effectively_Volatile (Item_Id) 2199 then 2200 -- An effectively volatile object cannot appear as a global 2201 -- item of a nonvolatile function (SPARK RM 7.1.3(8)). 2202 2203 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 2204 and then not Is_Volatile_Function (Spec_Id) 2205 then 2206 Error_Msg_NE 2207 ("volatile object & cannot act as global item of a " 2208 & "function", Item, Item_Id); 2209 return; 2210 2211 -- An effectively volatile object with external property 2212 -- Effective_Reads set to True must have mode Output or 2213 -- In_Out (SPARK RM 7.1.3(11)). 2214 2215 elsif Effective_Reads_Enabled (Item_Id) 2216 and then Global_Mode = Name_Input 2217 then 2218 Error_Msg_NE 2219 ("volatile object & with property Effective_Reads must " 2220 & "have mode In_Out or Output", Item, Item_Id); 2221 return; 2222 end if; 2223 end if; 2224 2225 -- When the item renames an entire object, replace the item 2226 -- with a reference to the object. 2227 2228 if Entity (Item) /= Item_Id then 2229 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item))); 2230 Analyze (Item); 2231 end if; 2232 2233 -- Some form of illegal construct masquerading as a name 2234 -- (SPARK RM 6.1.4(4)). 2235 2236 else 2237 Error_Msg_N 2238 ("global item must denote object, state or current instance " 2239 & "of concurrent type", Item); 2240 return; 2241 end if; 2242 2243 -- Verify that an output does not appear as an input in an 2244 -- enclosing subprogram. 2245 2246 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2247 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id); 2248 end if; 2249 2250 -- The same entity might be referenced through various way. 2251 -- Check the entity of the item rather than the item itself 2252 -- (SPARK RM 6.1.4(10)). 2253 2254 if Contains (Seen, Item_Id) then 2255 SPARK_Msg_N ("duplicate global item", Item); 2256 2257 -- Add the entity of the current item to the list of processed 2258 -- items. 2259 2260 else 2261 Append_New_Elmt (Item_Id, Seen); 2262 2263 if Ekind (Item_Id) = E_Abstract_State then 2264 Append_New_Elmt (Item_Id, States_Seen); 2265 2266 -- The variable may eventually become a constituent of a single 2267 -- protected/task type. Record the reference now and verify its 2268 -- legality when analyzing the contract of the variable 2269 -- (SPARK RM 9.3). 2270 2271 elsif Ekind (Item_Id) = E_Variable then 2272 Record_Possible_Part_Of_Reference 2273 (Var_Id => Item_Id, 2274 Ref => Item); 2275 end if; 2276 2277 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable) 2278 and then Present (Encapsulating_State (Item_Id)) 2279 then 2280 Append_New_Elmt (Item_Id, Constits_Seen); 2281 end if; 2282 end if; 2283 end Analyze_Global_Item; 2284 2285 -------------------------- 2286 -- Check_Duplicate_Mode -- 2287 -------------------------- 2288 2289 procedure Check_Duplicate_Mode 2290 (Mode : Node_Id; 2291 Status : in out Boolean) 2292 is 2293 begin 2294 if Status then 2295 SPARK_Msg_N ("duplicate global mode", Mode); 2296 end if; 2297 2298 Status := True; 2299 end Check_Duplicate_Mode; 2300 2301 ------------------------------------------------- 2302 -- Check_Mode_Restriction_In_Enclosing_Context -- 2303 ------------------------------------------------- 2304 2305 procedure Check_Mode_Restriction_In_Enclosing_Context 2306 (Item : Node_Id; 2307 Item_Id : Entity_Id) 2308 is 2309 Context : Entity_Id; 2310 Dummy : Boolean; 2311 Inputs : Elist_Id := No_Elist; 2312 Outputs : Elist_Id := No_Elist; 2313 2314 begin 2315 -- Traverse the scope stack looking for enclosing subprograms 2316 -- subject to pragma [Refined_]Global. 2317 2318 Context := Scope (Subp_Id); 2319 while Present (Context) and then Context /= Standard_Standard loop 2320 if Is_Subprogram (Context) 2321 and then 2322 (Present (Get_Pragma (Context, Pragma_Global)) 2323 or else 2324 Present (Get_Pragma (Context, Pragma_Refined_Global))) 2325 then 2326 Collect_Subprogram_Inputs_Outputs 2327 (Subp_Id => Context, 2328 Subp_Inputs => Inputs, 2329 Subp_Outputs => Outputs, 2330 Global_Seen => Dummy); 2331 2332 -- The item is classified as In_Out or Output but appears as 2333 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)). 2334 2335 if Appears_In (Inputs, Item_Id) 2336 and then not Appears_In (Outputs, Item_Id) 2337 then 2338 SPARK_Msg_NE 2339 ("global item & cannot have mode In_Out or Output", 2340 Item, Item_Id); 2341 2342 SPARK_Msg_NE 2343 (Fix_Msg (Subp_Id, "\item already appears as input of " 2344 & "subprogram &"), Item, Context); 2345 2346 -- Stop the traversal once an error has been detected 2347 2348 exit; 2349 end if; 2350 end if; 2351 2352 Context := Scope (Context); 2353 end loop; 2354 end Check_Mode_Restriction_In_Enclosing_Context; 2355 2356 ---------------------------------------- 2357 -- Check_Mode_Restriction_In_Function -- 2358 ---------------------------------------- 2359 2360 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is 2361 begin 2362 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 2363 SPARK_Msg_N 2364 ("global mode & is not applicable to functions", Mode); 2365 end if; 2366 end Check_Mode_Restriction_In_Function; 2367 2368 -- Local variables 2369 2370 Assoc : Node_Id; 2371 Item : Node_Id; 2372 Mode : Node_Id; 2373 2374 -- Start of processing for Analyze_Global_List 2375 2376 begin 2377 if Nkind (List) = N_Null then 2378 Set_Analyzed (List); 2379 2380 -- Single global item declaration 2381 2382 elsif Nkind_In (List, N_Expanded_Name, 2383 N_Identifier, 2384 N_Selected_Component) 2385 then 2386 Analyze_Global_Item (List, Global_Mode); 2387 2388 -- Simple global list or moded global list declaration 2389 2390 elsif Nkind (List) = N_Aggregate then 2391 Set_Analyzed (List); 2392 2393 -- The declaration of a simple global list appear as a collection 2394 -- of expressions. 2395 2396 if Present (Expressions (List)) then 2397 if Present (Component_Associations (List)) then 2398 SPARK_Msg_N 2399 ("cannot mix moded and non-moded global lists", List); 2400 end if; 2401 2402 Item := First (Expressions (List)); 2403 while Present (Item) loop 2404 Analyze_Global_Item (Item, Global_Mode); 2405 Next (Item); 2406 end loop; 2407 2408 -- The declaration of a moded global list appears as a collection 2409 -- of component associations where individual choices denote 2410 -- modes. 2411 2412 elsif Present (Component_Associations (List)) then 2413 if Present (Expressions (List)) then 2414 SPARK_Msg_N 2415 ("cannot mix moded and non-moded global lists", List); 2416 end if; 2417 2418 Assoc := First (Component_Associations (List)); 2419 while Present (Assoc) loop 2420 Mode := First (Choices (Assoc)); 2421 2422 if Nkind (Mode) = N_Identifier then 2423 if Chars (Mode) = Name_In_Out then 2424 Check_Duplicate_Mode (Mode, In_Out_Seen); 2425 Check_Mode_Restriction_In_Function (Mode); 2426 2427 elsif Chars (Mode) = Name_Input then 2428 Check_Duplicate_Mode (Mode, Input_Seen); 2429 2430 elsif Chars (Mode) = Name_Output then 2431 Check_Duplicate_Mode (Mode, Output_Seen); 2432 Check_Mode_Restriction_In_Function (Mode); 2433 2434 elsif Chars (Mode) = Name_Proof_In then 2435 Check_Duplicate_Mode (Mode, Proof_Seen); 2436 2437 else 2438 SPARK_Msg_N ("invalid mode selector", Mode); 2439 end if; 2440 2441 else 2442 SPARK_Msg_N ("invalid mode selector", Mode); 2443 end if; 2444 2445 -- Items in a moded list appear as a collection of 2446 -- expressions. Reuse the existing machinery to analyze 2447 -- them. 2448 2449 Analyze_Global_List 2450 (List => Expression (Assoc), 2451 Global_Mode => Chars (Mode)); 2452 2453 Next (Assoc); 2454 end loop; 2455 2456 -- Invalid tree 2457 2458 else 2459 raise Program_Error; 2460 end if; 2461 2462 -- Any other attempt to declare a global item is illegal. This is a 2463 -- syntax error, always report. 2464 2465 else 2466 Error_Msg_N ("malformed global list", List); 2467 end if; 2468 end Analyze_Global_List; 2469 2470 -- Local variables 2471 2472 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 2473 2474 Restore_Scope : Boolean := False; 2475 2476 -- Start of processing for Analyze_Global_In_Decl_Part 2477 2478 begin 2479 -- Do not analyze the pragma multiple times 2480 2481 if Is_Analyzed_Pragma (N) then 2482 return; 2483 end if; 2484 2485 -- There is nothing to be done for a null global list 2486 2487 if Nkind (Items) = N_Null then 2488 Set_Analyzed (Items); 2489 2490 -- Analyze the various forms of global lists and items. Note that some 2491 -- of these may be malformed in which case the analysis emits error 2492 -- messages. 2493 2494 else 2495 -- When pragma [Refined_]Global appears on a single concurrent type, 2496 -- it is relocated to the anonymous object. 2497 2498 if Is_Single_Concurrent_Object (Spec_Id) then 2499 null; 2500 2501 -- Ensure that the formal parameters are visible when processing an 2502 -- item. This falls out of the general rule of aspects pertaining to 2503 -- subprogram declarations. 2504 2505 elsif not In_Open_Scopes (Spec_Id) then 2506 Restore_Scope := True; 2507 Push_Scope (Spec_Id); 2508 2509 if Ekind (Spec_Id) = E_Task_Type then 2510 if Has_Discriminants (Spec_Id) then 2511 Install_Discriminants (Spec_Id); 2512 end if; 2513 2514 elsif Is_Generic_Subprogram (Spec_Id) then 2515 Install_Generic_Formals (Spec_Id); 2516 2517 else 2518 Install_Formals (Spec_Id); 2519 end if; 2520 end if; 2521 2522 Analyze_Global_List (Items); 2523 2524 if Restore_Scope then 2525 End_Scope; 2526 end if; 2527 end if; 2528 2529 -- Ensure that a state and a corresponding constituent do not appear 2530 -- together in pragma [Refined_]Global. 2531 2532 Check_State_And_Constituent_Use 2533 (States => States_Seen, 2534 Constits => Constits_Seen, 2535 Context => N); 2536 2537 Set_Is_Analyzed_Pragma (N); 2538 end Analyze_Global_In_Decl_Part; 2539 2540 -------------------------------------------- 2541 -- Analyze_Initial_Condition_In_Decl_Part -- 2542 -------------------------------------------- 2543 2544 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is 2545 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 2546 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 2547 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id)); 2548 2549 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 2550 2551 begin 2552 -- Do not analyze the pragma multiple times 2553 2554 if Is_Analyzed_Pragma (N) then 2555 return; 2556 end if; 2557 2558 -- Set the Ghost mode in effect from the pragma. Due to the delayed 2559 -- analysis of the pragma, the Ghost mode at point of declaration and 2560 -- point of analysis may not necessarely be the same. Use the mode in 2561 -- effect at the point of declaration. 2562 2563 Set_Ghost_Mode (N); 2564 2565 -- The expression is preanalyzed because it has not been moved to its 2566 -- final place yet. A direct analysis may generate side effects and this 2567 -- is not desired at this point. 2568 2569 Preanalyze_Assert_Expression (Expr, Standard_Boolean); 2570 Ghost_Mode := Save_Ghost_Mode; 2571 2572 Set_Is_Analyzed_Pragma (N); 2573 end Analyze_Initial_Condition_In_Decl_Part; 2574 2575 -------------------------------------- 2576 -- Analyze_Initializes_In_Decl_Part -- 2577 -------------------------------------- 2578 2579 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is 2580 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 2581 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 2582 2583 Constits_Seen : Elist_Id := No_Elist; 2584 -- A list containing the entities of all constituents processed so far. 2585 -- It aids in detecting illegal usage of a state and a corresponding 2586 -- constituent in pragma Initializes. 2587 2588 Items_Seen : Elist_Id := No_Elist; 2589 -- A list of all initialization items processed so far. This list is 2590 -- used to detect duplicate items. 2591 2592 Non_Null_Seen : Boolean := False; 2593 Null_Seen : Boolean := False; 2594 -- Flags used to check the legality of a null initialization list 2595 2596 States_And_Objs : Elist_Id := No_Elist; 2597 -- A list of all abstract states and objects declared in the visible 2598 -- declarations of the related package. This list is used to detect the 2599 -- legality of initialization items. 2600 2601 States_Seen : Elist_Id := No_Elist; 2602 -- A list containing the entities of all states processed so far. It 2603 -- helps in detecting illegal usage of a state and a corresponding 2604 -- constituent in pragma Initializes. 2605 2606 procedure Analyze_Initialization_Item (Item : Node_Id); 2607 -- Verify the legality of a single initialization item 2608 2609 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id); 2610 -- Verify the legality of a single initialization item followed by a 2611 -- list of input items. 2612 2613 procedure Collect_States_And_Objects; 2614 -- Inspect the visible declarations of the related package and gather 2615 -- the entities of all abstract states and objects in States_And_Objs. 2616 2617 --------------------------------- 2618 -- Analyze_Initialization_Item -- 2619 --------------------------------- 2620 2621 procedure Analyze_Initialization_Item (Item : Node_Id) is 2622 Item_Id : Entity_Id; 2623 2624 begin 2625 -- Null initialization list 2626 2627 if Nkind (Item) = N_Null then 2628 if Null_Seen then 2629 SPARK_Msg_N ("multiple null initializations not allowed", Item); 2630 2631 elsif Non_Null_Seen then 2632 SPARK_Msg_N 2633 ("cannot mix null and non-null initialization items", Item); 2634 else 2635 Null_Seen := True; 2636 end if; 2637 2638 -- Initialization item 2639 2640 else 2641 Non_Null_Seen := True; 2642 2643 if Null_Seen then 2644 SPARK_Msg_N 2645 ("cannot mix null and non-null initialization items", Item); 2646 end if; 2647 2648 Analyze (Item); 2649 Resolve_State (Item); 2650 2651 if Is_Entity_Name (Item) then 2652 Item_Id := Entity_Of (Item); 2653 2654 if Ekind_In (Item_Id, E_Abstract_State, 2655 E_Constant, 2656 E_Variable) 2657 then 2658 -- The state or variable must be declared in the visible 2659 -- declarations of the package (SPARK RM 7.1.5(7)). 2660 2661 if not Contains (States_And_Objs, Item_Id) then 2662 Error_Msg_Name_1 := Chars (Pack_Id); 2663 SPARK_Msg_NE 2664 ("initialization item & must appear in the visible " 2665 & "declarations of package %", Item, Item_Id); 2666 2667 -- Detect a duplicate use of the same initialization item 2668 -- (SPARK RM 7.1.5(5)). 2669 2670 elsif Contains (Items_Seen, Item_Id) then 2671 SPARK_Msg_N ("duplicate initialization item", Item); 2672 2673 -- The item is legal, add it to the list of processed states 2674 -- and variables. 2675 2676 else 2677 Append_New_Elmt (Item_Id, Items_Seen); 2678 2679 if Ekind (Item_Id) = E_Abstract_State then 2680 Append_New_Elmt (Item_Id, States_Seen); 2681 end if; 2682 2683 if Present (Encapsulating_State (Item_Id)) then 2684 Append_New_Elmt (Item_Id, Constits_Seen); 2685 end if; 2686 end if; 2687 2688 -- The item references something that is not a state or object 2689 -- (SPARK RM 7.1.5(3)). 2690 2691 else 2692 SPARK_Msg_N 2693 ("initialization item must denote object or state", Item); 2694 end if; 2695 2696 -- Some form of illegal construct masquerading as a name 2697 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. 2698 2699 else 2700 Error_Msg_N 2701 ("initialization item must denote object or state", Item); 2702 end if; 2703 end if; 2704 end Analyze_Initialization_Item; 2705 2706 --------------------------------------------- 2707 -- Analyze_Initialization_Item_With_Inputs -- 2708 --------------------------------------------- 2709 2710 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is 2711 Inputs_Seen : Elist_Id := No_Elist; 2712 -- A list of all inputs processed so far. This list is used to detect 2713 -- duplicate uses of an input. 2714 2715 Non_Null_Seen : Boolean := False; 2716 Null_Seen : Boolean := False; 2717 -- Flags used to check the legality of an input list 2718 2719 procedure Analyze_Input_Item (Input : Node_Id); 2720 -- Verify the legality of a single input item 2721 2722 ------------------------ 2723 -- Analyze_Input_Item -- 2724 ------------------------ 2725 2726 procedure Analyze_Input_Item (Input : Node_Id) is 2727 Input_Id : Entity_Id; 2728 2729 begin 2730 -- Null input list 2731 2732 if Nkind (Input) = N_Null then 2733 if Null_Seen then 2734 SPARK_Msg_N 2735 ("multiple null initializations not allowed", Item); 2736 2737 elsif Non_Null_Seen then 2738 SPARK_Msg_N 2739 ("cannot mix null and non-null initialization item", Item); 2740 else 2741 Null_Seen := True; 2742 end if; 2743 2744 -- Input item 2745 2746 else 2747 Non_Null_Seen := True; 2748 2749 if Null_Seen then 2750 SPARK_Msg_N 2751 ("cannot mix null and non-null initialization item", Item); 2752 end if; 2753 2754 Analyze (Input); 2755 Resolve_State (Input); 2756 2757 if Is_Entity_Name (Input) then 2758 Input_Id := Entity_Of (Input); 2759 2760 if Ekind_In (Input_Id, E_Abstract_State, 2761 E_Constant, 2762 E_In_Parameter, 2763 E_In_Out_Parameter, 2764 E_Out_Parameter, 2765 E_Variable) 2766 then 2767 -- The input cannot denote states or objects declared 2768 -- within the related package (SPARK RM 7.1.5(4)). 2769 2770 if Within_Scope (Input_Id, Current_Scope) then 2771 Error_Msg_Name_1 := Chars (Pack_Id); 2772 SPARK_Msg_NE 2773 ("input item & cannot denote a visible object or " 2774 & "state of package %", Input, Input_Id); 2775 2776 -- Detect a duplicate use of the same input item 2777 -- (SPARK RM 7.1.5(5)). 2778 2779 elsif Contains (Inputs_Seen, Input_Id) then 2780 SPARK_Msg_N ("duplicate input item", Input); 2781 2782 -- Input is legal, add it to the list of processed inputs 2783 2784 else 2785 Append_New_Elmt (Input_Id, Inputs_Seen); 2786 2787 if Ekind (Input_Id) = E_Abstract_State then 2788 Append_New_Elmt (Input_Id, States_Seen); 2789 end if; 2790 2791 if Ekind_In (Input_Id, E_Abstract_State, 2792 E_Constant, 2793 E_Variable) 2794 and then Present (Encapsulating_State (Input_Id)) 2795 then 2796 Append_New_Elmt (Input_Id, Constits_Seen); 2797 end if; 2798 end if; 2799 2800 -- The input references something that is not a state or an 2801 -- object (SPARK RM 7.1.5(3)). 2802 2803 else 2804 SPARK_Msg_N 2805 ("input item must denote object or state", Input); 2806 end if; 2807 2808 -- Some form of illegal construct masquerading as a name 2809 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. 2810 2811 else 2812 Error_Msg_N 2813 ("input item must denote object or state", Input); 2814 end if; 2815 end if; 2816 end Analyze_Input_Item; 2817 2818 -- Local variables 2819 2820 Inputs : constant Node_Id := Expression (Item); 2821 Elmt : Node_Id; 2822 Input : Node_Id; 2823 2824 Name_Seen : Boolean := False; 2825 -- A flag used to detect multiple item names 2826 2827 -- Start of processing for Analyze_Initialization_Item_With_Inputs 2828 2829 begin 2830 -- Inspect the name of an item with inputs 2831 2832 Elmt := First (Choices (Item)); 2833 while Present (Elmt) loop 2834 if Name_Seen then 2835 SPARK_Msg_N ("only one item allowed in initialization", Elmt); 2836 else 2837 Name_Seen := True; 2838 Analyze_Initialization_Item (Elmt); 2839 end if; 2840 2841 Next (Elmt); 2842 end loop; 2843 2844 -- Multiple input items appear as an aggregate 2845 2846 if Nkind (Inputs) = N_Aggregate then 2847 if Present (Expressions (Inputs)) then 2848 Input := First (Expressions (Inputs)); 2849 while Present (Input) loop 2850 Analyze_Input_Item (Input); 2851 Next (Input); 2852 end loop; 2853 end if; 2854 2855 if Present (Component_Associations (Inputs)) then 2856 SPARK_Msg_N 2857 ("inputs must appear in named association form", Inputs); 2858 end if; 2859 2860 -- Single input item 2861 2862 else 2863 Analyze_Input_Item (Inputs); 2864 end if; 2865 end Analyze_Initialization_Item_With_Inputs; 2866 2867 -------------------------------- 2868 -- Collect_States_And_Objects -- 2869 -------------------------------- 2870 2871 procedure Collect_States_And_Objects is 2872 Pack_Spec : constant Node_Id := Specification (Pack_Decl); 2873 Decl : Node_Id; 2874 2875 begin 2876 -- Collect the abstract states defined in the package (if any) 2877 2878 if Present (Abstract_States (Pack_Id)) then 2879 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id)); 2880 end if; 2881 2882 -- Collect all objects the appear in the visible declarations of the 2883 -- related package. 2884 2885 if Present (Visible_Declarations (Pack_Spec)) then 2886 Decl := First (Visible_Declarations (Pack_Spec)); 2887 while Present (Decl) loop 2888 if Comes_From_Source (Decl) 2889 and then Nkind (Decl) = N_Object_Declaration 2890 then 2891 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); 2892 end if; 2893 2894 Next (Decl); 2895 end loop; 2896 end if; 2897 end Collect_States_And_Objects; 2898 2899 -- Local variables 2900 2901 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id)); 2902 Init : Node_Id; 2903 2904 -- Start of processing for Analyze_Initializes_In_Decl_Part 2905 2906 begin 2907 -- Do not analyze the pragma multiple times 2908 2909 if Is_Analyzed_Pragma (N) then 2910 return; 2911 end if; 2912 2913 -- Nothing to do when the initialization list is empty 2914 2915 if Nkind (Inits) = N_Null then 2916 return; 2917 end if; 2918 2919 -- Single and multiple initialization clauses appear as an aggregate. If 2920 -- this is not the case, then either the parser or the analysis of the 2921 -- pragma failed to produce an aggregate. 2922 2923 pragma Assert (Nkind (Inits) = N_Aggregate); 2924 2925 -- Initialize the various lists used during analysis 2926 2927 Collect_States_And_Objects; 2928 2929 if Present (Expressions (Inits)) then 2930 Init := First (Expressions (Inits)); 2931 while Present (Init) loop 2932 Analyze_Initialization_Item (Init); 2933 Next (Init); 2934 end loop; 2935 end if; 2936 2937 if Present (Component_Associations (Inits)) then 2938 Init := First (Component_Associations (Inits)); 2939 while Present (Init) loop 2940 Analyze_Initialization_Item_With_Inputs (Init); 2941 Next (Init); 2942 end loop; 2943 end if; 2944 2945 -- Ensure that a state and a corresponding constituent do not appear 2946 -- together in pragma Initializes. 2947 2948 Check_State_And_Constituent_Use 2949 (States => States_Seen, 2950 Constits => Constits_Seen, 2951 Context => N); 2952 2953 Set_Is_Analyzed_Pragma (N); 2954 end Analyze_Initializes_In_Decl_Part; 2955 2956 --------------------- 2957 -- Analyze_Part_Of -- 2958 --------------------- 2959 2960 procedure Analyze_Part_Of 2961 (Indic : Node_Id; 2962 Item_Id : Entity_Id; 2963 Encap : Node_Id; 2964 Encap_Id : out Entity_Id; 2965 Legal : out Boolean) 2966 is 2967 Encap_Typ : Entity_Id; 2968 Item_Decl : Node_Id; 2969 Pack_Id : Entity_Id; 2970 Placement : State_Space_Kind; 2971 Parent_Unit : Entity_Id; 2972 2973 begin 2974 -- Assume that the indicator is illegal 2975 2976 Encap_Id := Empty; 2977 Legal := False; 2978 2979 if Nkind_In (Encap, N_Expanded_Name, 2980 N_Identifier, 2981 N_Selected_Component) 2982 then 2983 Analyze (Encap); 2984 Resolve_State (Encap); 2985 2986 Encap_Id := Entity (Encap); 2987 2988 -- The encapsulator is an abstract state 2989 2990 if Ekind (Encap_Id) = E_Abstract_State then 2991 null; 2992 2993 -- The encapsulator is a single concurrent type (SPARK RM 9.3) 2994 2995 elsif Is_Single_Concurrent_Object (Encap_Id) then 2996 null; 2997 2998 -- Otherwise the encapsulator is not a legal choice 2999 3000 else 3001 SPARK_Msg_N 3002 ("indicator Part_Of must denote abstract state, single " 3003 & "protected type or single task type", Encap); 3004 return; 3005 end if; 3006 3007 -- This is a syntax error, always report 3008 3009 else 3010 Error_Msg_N 3011 ("indicator Part_Of must denote abstract state, single protected " 3012 & "type or single task type", Encap); 3013 return; 3014 end if; 3015 3016 -- Catch a case where indicator Part_Of denotes the abstract view of a 3017 -- variable which appears as an abstract state (SPARK RM 10.1.2 2). 3018 3019 if From_Limited_With (Encap_Id) 3020 and then Present (Non_Limited_View (Encap_Id)) 3021 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable 3022 then 3023 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap); 3024 SPARK_Msg_N ("\& denotes abstract view of object", Encap); 3025 return; 3026 end if; 3027 3028 -- The encapsulator is an abstract state 3029 3030 if Ekind (Encap_Id) = E_Abstract_State then 3031 3032 -- Determine where the object, package instantiation or state lives 3033 -- with respect to the enclosing packages or package bodies. 3034 3035 Find_Placement_In_State_Space 3036 (Item_Id => Item_Id, 3037 Placement => Placement, 3038 Pack_Id => Pack_Id); 3039 3040 -- The item appears in a non-package construct with a declarative 3041 -- part (subprogram, block, etc). As such, the item is not allowed 3042 -- to be a part of an encapsulating state because the item is not 3043 -- visible. 3044 3045 if Placement = Not_In_Package then 3046 SPARK_Msg_N 3047 ("indicator Part_Of cannot appear in this context " 3048 & "(SPARK RM 7.2.6(5))", Indic); 3049 Error_Msg_Name_1 := Chars (Scope (Encap_Id)); 3050 SPARK_Msg_NE 3051 ("\& is not part of the hidden state of package %", 3052 Indic, Item_Id); 3053 3054 -- The item appears in the visible state space of some package. In 3055 -- general this scenario does not warrant Part_Of except when the 3056 -- package is a private child unit and the encapsulating state is 3057 -- declared in a parent unit or a public descendant of that parent 3058 -- unit. 3059 3060 elsif Placement = Visible_State_Space then 3061 if Is_Child_Unit (Pack_Id) 3062 and then Is_Private_Descendant (Pack_Id) 3063 then 3064 -- A variable or state abstraction which is part of the visible 3065 -- state of a private child unit (or one of its public 3066 -- descendants) must have its Part_Of indicator specified. The 3067 -- Part_Of indicator must denote a state abstraction declared 3068 -- by either the parent unit of the private unit or by a public 3069 -- descendant of that parent unit. 3070 3071 -- Find nearest private ancestor (which can be the current unit 3072 -- itself). 3073 3074 Parent_Unit := Pack_Id; 3075 while Present (Parent_Unit) loop 3076 exit when 3077 Private_Present 3078 (Parent (Unit_Declaration_Node (Parent_Unit))); 3079 Parent_Unit := Scope (Parent_Unit); 3080 end loop; 3081 3082 Parent_Unit := Scope (Parent_Unit); 3083 3084 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then 3085 SPARK_Msg_NE 3086 ("indicator Part_Of must denote abstract state or public " 3087 & "descendant of & (SPARK RM 7.2.6(3))", 3088 Indic, Parent_Unit); 3089 3090 elsif Scope (Encap_Id) = Parent_Unit 3091 or else 3092 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id)) 3093 and then not Is_Private_Descendant (Scope (Encap_Id))) 3094 then 3095 null; 3096 3097 else 3098 SPARK_Msg_NE 3099 ("indicator Part_Of must denote abstract state or public " 3100 & "descendant of & (SPARK RM 7.2.6(3))", 3101 Indic, Parent_Unit); 3102 end if; 3103 3104 -- Indicator Part_Of is not needed when the related package is not 3105 -- a private child unit or a public descendant thereof. 3106 3107 else 3108 SPARK_Msg_N 3109 ("indicator Part_Of cannot appear in this context " 3110 & "(SPARK RM 7.2.6(5))", Indic); 3111 Error_Msg_Name_1 := Chars (Pack_Id); 3112 SPARK_Msg_NE 3113 ("\& is declared in the visible part of package %", 3114 Indic, Item_Id); 3115 end if; 3116 3117 -- When the item appears in the private state space of a package, the 3118 -- encapsulating state must be declared in the same package. 3119 3120 elsif Placement = Private_State_Space then 3121 if Scope (Encap_Id) /= Pack_Id then 3122 SPARK_Msg_NE 3123 ("indicator Part_Of must designate an abstract state of " 3124 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id); 3125 Error_Msg_Name_1 := Chars (Pack_Id); 3126 SPARK_Msg_NE 3127 ("\& is declared in the private part of package %", 3128 Indic, Item_Id); 3129 end if; 3130 3131 -- Items declared in the body state space of a package do not need 3132 -- Part_Of indicators as the refinement has already been seen. 3133 3134 else 3135 SPARK_Msg_N 3136 ("indicator Part_Of cannot appear in this context " 3137 & "(SPARK RM 7.2.6(5))", Indic); 3138 3139 if Scope (Encap_Id) = Pack_Id then 3140 Error_Msg_Name_1 := Chars (Pack_Id); 3141 SPARK_Msg_NE 3142 ("\& is declared in the body of package %", Indic, Item_Id); 3143 end if; 3144 end if; 3145 3146 -- The encapsulator is a single concurrent type 3147 3148 else 3149 Encap_Typ := Etype (Encap_Id); 3150 3151 -- Only abstract states and variables can act as constituents of an 3152 -- encapsulating single concurrent type. 3153 3154 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 3155 null; 3156 3157 -- The constituent is a constant 3158 3159 elsif Ekind (Item_Id) = E_Constant then 3160 Error_Msg_Name_1 := Chars (Encap_Id); 3161 SPARK_Msg_NE 3162 (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of " 3163 & "single protected type %"), Indic, Item_Id); 3164 3165 -- The constituent is a package instantiation 3166 3167 else 3168 Error_Msg_Name_1 := Chars (Encap_Id); 3169 SPARK_Msg_NE 3170 (Fix_Msg (Encap_Typ, "package instantiation & cannot act as " 3171 & "constituent of single protected type %"), Indic, Item_Id); 3172 end if; 3173 3174 -- When the item denotes an abstract state of a nested package, use 3175 -- the declaration of the package to detect proper placement. 3176 3177 -- package Pack is 3178 -- task T; 3179 -- package Nested 3180 -- with Abstract_State => (State with Part_Of => T) 3181 3182 if Ekind (Item_Id) = E_Abstract_State then 3183 Item_Decl := Unit_Declaration_Node (Scope (Item_Id)); 3184 else 3185 Item_Decl := Declaration_Node (Item_Id); 3186 end if; 3187 3188 -- Both the item and its encapsulating single concurrent type must 3189 -- appear in the same declarative region (SPARK RM 9.3). Note that 3190 -- privacy is ignored. 3191 3192 if Parent (Item_Decl) /= Parent (Declaration_Node (Encap_Id)) then 3193 Error_Msg_Name_1 := Chars (Encap_Id); 3194 SPARK_Msg_NE 3195 (Fix_Msg (Encap_Typ, "constituent & must be declared " 3196 & "immediately within the same region as single protected " 3197 & "type %"), Indic, Item_Id); 3198 end if; 3199 end if; 3200 3201 Legal := True; 3202 end Analyze_Part_Of; 3203 3204 ---------------------------------- 3205 -- Analyze_Part_Of_In_Decl_Part -- 3206 ---------------------------------- 3207 3208 procedure Analyze_Part_Of_In_Decl_Part 3209 (N : Node_Id; 3210 Freeze_Id : Entity_Id := Empty) 3211 is 3212 Encap : constant Node_Id := 3213 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 3214 Errors : constant Nat := Serious_Errors_Detected; 3215 Var_Decl : constant Node_Id := Find_Related_Context (N); 3216 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl); 3217 Encap_Id : Entity_Id; 3218 Legal : Boolean; 3219 3220 begin 3221 -- Detect any discrepancies between the placement of the variable with 3222 -- respect to general state space and the encapsulating state or single 3223 -- concurrent type. 3224 3225 Analyze_Part_Of 3226 (Indic => N, 3227 Item_Id => Var_Id, 3228 Encap => Encap, 3229 Encap_Id => Encap_Id, 3230 Legal => Legal); 3231 3232 -- The Part_Of indicator turns the variable into a constituent of the 3233 -- encapsulating state or single concurrent type. 3234 3235 if Legal then 3236 pragma Assert (Present (Encap_Id)); 3237 3238 Append_Elmt (Var_Id, Part_Of_Constituents (Encap_Id)); 3239 Set_Encapsulating_State (Var_Id, Encap_Id); 3240 end if; 3241 3242 -- Emit a clarification message when the encapsulator is undefined, 3243 -- possibly due to contract "freezing". 3244 3245 if Errors /= Serious_Errors_Detected 3246 and then Present (Freeze_Id) 3247 and then Has_Undefined_Reference (Encap) 3248 then 3249 Contract_Freeze_Error (Var_Id, Freeze_Id); 3250 end if; 3251 end Analyze_Part_Of_In_Decl_Part; 3252 3253 -------------------- 3254 -- Analyze_Pragma -- 3255 -------------------- 3256 3257 procedure Analyze_Pragma (N : Node_Id) is 3258 Loc : constant Source_Ptr := Sloc (N); 3259 Prag_Id : Pragma_Id; 3260 3261 Pname : Name_Id; 3262 -- Name of the source pragma, or name of the corresponding aspect for 3263 -- pragmas which originate in a source aspect. In the latter case, the 3264 -- name may be different from the pragma name. 3265 3266 Pragma_Exit : exception; 3267 -- This exception is used to exit pragma processing completely. It 3268 -- is used when an error is detected, and no further processing is 3269 -- required. It is also used if an earlier error has left the tree in 3270 -- a state where the pragma should not be processed. 3271 3272 Arg_Count : Nat; 3273 -- Number of pragma argument associations 3274 3275 Arg1 : Node_Id; 3276 Arg2 : Node_Id; 3277 Arg3 : Node_Id; 3278 Arg4 : Node_Id; 3279 -- First four pragma arguments (pragma argument association nodes, or 3280 -- Empty if the corresponding argument does not exist). 3281 3282 type Name_List is array (Natural range <>) of Name_Id; 3283 type Args_List is array (Natural range <>) of Node_Id; 3284 -- Types used for arguments to Check_Arg_Order and Gather_Associations 3285 3286 ----------------------- 3287 -- Local Subprograms -- 3288 ----------------------- 3289 3290 procedure Acquire_Warning_Match_String (Arg : Node_Id); 3291 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to 3292 -- get the given string argument, and place it in Name_Buffer, adding 3293 -- leading and trailing asterisks if they are not already present. The 3294 -- caller has already checked that Arg is a static string expression. 3295 3296 procedure Ada_2005_Pragma; 3297 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In 3298 -- Ada 95 mode, these are implementation defined pragmas, so should be 3299 -- caught by the No_Implementation_Pragmas restriction. 3300 3301 procedure Ada_2012_Pragma; 3302 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. 3303 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so 3304 -- should be caught by the No_Implementation_Pragmas restriction. 3305 3306 procedure Analyze_Depends_Global 3307 (Spec_Id : out Entity_Id; 3308 Subp_Decl : out Node_Id; 3309 Legal : out Boolean); 3310 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the 3311 -- legality of the placement and related context of the pragma. Spec_Id 3312 -- is the entity of the related subprogram. Subp_Decl is the declaration 3313 -- of the related subprogram. Sets flag Legal when the pragma is legal. 3314 3315 procedure Analyze_If_Present (Id : Pragma_Id); 3316 -- Inspect the remainder of the list containing pragma N and look for 3317 -- a pragma that matches Id. If found, analyze the pragma. 3318 3319 procedure Analyze_Pre_Post_Condition; 3320 -- Subsidiary to the analysis of pragmas Precondition and Postcondition 3321 3322 procedure Analyze_Refined_Depends_Global_Post 3323 (Spec_Id : out Entity_Id; 3324 Body_Id : out Entity_Id; 3325 Legal : out Boolean); 3326 -- Subsidiary routine to the analysis of body pragmas Refined_Depends, 3327 -- Refined_Global and Refined_Post. Verify the legality of the placement 3328 -- and related context of the pragma. Spec_Id is the entity of the 3329 -- related subprogram. Body_Id is the entity of the subprogram body. 3330 -- Flag Legal is set when the pragma is legal. 3331 3332 procedure Check_Ada_83_Warning; 3333 -- Issues a warning message for the current pragma if operating in Ada 3334 -- 83 mode (used for language pragmas that are not a standard part of 3335 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use 3336 -- of 95 pragma. 3337 3338 procedure Check_Arg_Count (Required : Nat); 3339 -- Check argument count for pragma is equal to given parameter. If not, 3340 -- then issue an error message and raise Pragma_Exit. 3341 3342 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument 3343 -- Arg which can either be a pragma argument association, in which case 3344 -- the check is applied to the expression of the association or an 3345 -- expression directly. 3346 3347 procedure Check_Arg_Is_External_Name (Arg : Node_Id); 3348 -- Check that an argument has the right form for an EXTERNAL_NAME 3349 -- parameter of an extended import/export pragma. The rule is that the 3350 -- name must be an identifier or string literal (in Ada 83 mode) or a 3351 -- static string expression (in Ada 95 mode). 3352 3353 procedure Check_Arg_Is_Identifier (Arg : Node_Id); 3354 -- Check the specified argument Arg to make sure that it is an 3355 -- identifier. If not give error and raise Pragma_Exit. 3356 3357 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); 3358 -- Check the specified argument Arg to make sure that it is an integer 3359 -- literal. If not give error and raise Pragma_Exit. 3360 3361 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); 3362 -- Check the specified argument Arg to make sure that it has the proper 3363 -- syntactic form for a local name and meets the semantic requirements 3364 -- for a local name. The local name is analyzed as part of the 3365 -- processing for this call. In addition, the local name is required 3366 -- to represent an entity at the library level. 3367 3368 procedure Check_Arg_Is_Local_Name (Arg : Node_Id); 3369 -- Check the specified argument Arg to make sure that it has the proper 3370 -- syntactic form for a local name and meets the semantic requirements 3371 -- for a local name. The local name is analyzed as part of the 3372 -- processing for this call. 3373 3374 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); 3375 -- Check the specified argument Arg to make sure that it is a valid 3376 -- locking policy name. If not give error and raise Pragma_Exit. 3377 3378 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); 3379 -- Check the specified argument Arg to make sure that it is a valid 3380 -- elaboration policy name. If not give error and raise Pragma_Exit. 3381 3382 procedure Check_Arg_Is_One_Of 3383 (Arg : Node_Id; 3384 N1, N2 : Name_Id); 3385 procedure Check_Arg_Is_One_Of 3386 (Arg : Node_Id; 3387 N1, N2, N3 : Name_Id); 3388 procedure Check_Arg_Is_One_Of 3389 (Arg : Node_Id; 3390 N1, N2, N3, N4 : Name_Id); 3391 procedure Check_Arg_Is_One_Of 3392 (Arg : Node_Id; 3393 N1, N2, N3, N4, N5 : Name_Id); 3394 -- Check the specified argument Arg to make sure that it is an 3395 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if 3396 -- present). If not then give error and raise Pragma_Exit. 3397 3398 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); 3399 -- Check the specified argument Arg to make sure that it is a valid 3400 -- queuing policy name. If not give error and raise Pragma_Exit. 3401 3402 procedure Check_Arg_Is_OK_Static_Expression 3403 (Arg : Node_Id; 3404 Typ : Entity_Id := Empty); 3405 -- Check the specified argument Arg to make sure that it is a static 3406 -- expression of the given type (i.e. it will be analyzed and resolved 3407 -- using this type, which can be any valid argument to Resolve, e.g. 3408 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 3409 -- Typ is left Empty, then any static expression is allowed. Includes 3410 -- checking that the argument does not raise Constraint_Error. 3411 3412 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); 3413 -- Check the specified argument Arg to make sure that it is a valid task 3414 -- dispatching policy name. If not give error and raise Pragma_Exit. 3415 3416 procedure Check_Arg_Order (Names : Name_List); 3417 -- Checks for an instance of two arguments with identifiers for the 3418 -- current pragma which are not in the sequence indicated by Names, 3419 -- and if so, generates a fatal message about bad order of arguments. 3420 3421 procedure Check_At_Least_N_Arguments (N : Nat); 3422 -- Check there are at least N arguments present 3423 3424 procedure Check_At_Most_N_Arguments (N : Nat); 3425 -- Check there are no more than N arguments present 3426 3427 procedure Check_Component 3428 (Comp : Node_Id; 3429 UU_Typ : Entity_Id; 3430 In_Variant_Part : Boolean := False); 3431 -- Examine an Unchecked_Union component for correct use of per-object 3432 -- constrained subtypes, and for restrictions on finalizable components. 3433 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part 3434 -- should be set when Comp comes from a record variant. 3435 3436 procedure Check_Duplicate_Pragma (E : Entity_Id); 3437 -- Check if a rep item of the same name as the current pragma is already 3438 -- chained as a rep pragma to the given entity. If so give a message 3439 -- about the duplicate, and then raise Pragma_Exit so does not return. 3440 -- Note that if E is a type, then this routine avoids flagging a pragma 3441 -- which applies to a parent type from which E is derived. 3442 3443 procedure Check_Duplicated_Export_Name (Nam : Node_Id); 3444 -- Nam is an N_String_Literal node containing the external name set by 3445 -- an Import or Export pragma (or extended Import or Export pragma). 3446 -- This procedure checks for possible duplications if this is the export 3447 -- case, and if found, issues an appropriate error message. 3448 3449 procedure Check_Expr_Is_OK_Static_Expression 3450 (Expr : Node_Id; 3451 Typ : Entity_Id := Empty); 3452 -- Check the specified expression Expr to make sure that it is a static 3453 -- expression of the given type (i.e. it will be analyzed and resolved 3454 -- using this type, which can be any valid argument to Resolve, e.g. 3455 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 3456 -- Typ is left Empty, then any static expression is allowed. Includes 3457 -- checking that the expression does not raise Constraint_Error. 3458 3459 procedure Check_First_Subtype (Arg : Node_Id); 3460 -- Checks that Arg, whose expression is an entity name, references a 3461 -- first subtype. 3462 3463 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id); 3464 -- Checks that the given argument has an identifier, and if so, requires 3465 -- it to match the given identifier name. If there is no identifier, or 3466 -- a non-matching identifier, then an error message is given and 3467 -- Pragma_Exit is raised. 3468 3469 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); 3470 -- Checks that the given argument has an identifier, and if so, requires 3471 -- it to match one of the given identifier names. If there is no 3472 -- identifier, or a non-matching identifier, then an error message is 3473 -- given and Pragma_Exit is raised. 3474 3475 procedure Check_In_Main_Program; 3476 -- Common checks for pragmas that appear within a main program 3477 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). 3478 3479 procedure Check_Interrupt_Or_Attach_Handler; 3480 -- Common processing for first argument of pragma Interrupt_Handler or 3481 -- pragma Attach_Handler. 3482 3483 procedure Check_Loop_Pragma_Placement; 3484 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant 3485 -- appear immediately within a construct restricted to loops, and that 3486 -- pragmas Loop_Invariant and Loop_Variant are grouped together. 3487 3488 procedure Check_Is_In_Decl_Part_Or_Package_Spec; 3489 -- Check that pragma appears in a declarative part, or in a package 3490 -- specification, i.e. that it does not occur in a statement sequence 3491 -- in a body. 3492 3493 procedure Check_No_Identifier (Arg : Node_Id); 3494 -- Checks that the given argument does not have an identifier. If 3495 -- an identifier is present, then an error message is issued, and 3496 -- Pragma_Exit is raised. 3497 3498 procedure Check_No_Identifiers; 3499 -- Checks that none of the arguments to the pragma has an identifier. 3500 -- If any argument has an identifier, then an error message is issued, 3501 -- and Pragma_Exit is raised. 3502 3503 procedure Check_No_Link_Name; 3504 -- Checks that no link name is specified 3505 3506 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 3507 -- Checks if the given argument has an identifier, and if so, requires 3508 -- it to match the given identifier name. If there is a non-matching 3509 -- identifier, then an error message is given and Pragma_Exit is raised. 3510 3511 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); 3512 -- Checks if the given argument has an identifier, and if so, requires 3513 -- it to match the given identifier name. If there is a non-matching 3514 -- identifier, then an error message is given and Pragma_Exit is raised. 3515 -- In this version of the procedure, the identifier name is given as 3516 -- a string with lower case letters. 3517 3518 procedure Check_Static_Boolean_Expression (Expr : Node_Id); 3519 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers, 3520 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes, 3521 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr 3522 -- is an OK static boolean expression. Emit an error if this is not the 3523 -- case. 3524 3525 procedure Check_Static_Constraint (Constr : Node_Id); 3526 -- Constr is a constraint from an N_Subtype_Indication node from a 3527 -- component constraint in an Unchecked_Union type. This routine checks 3528 -- that the constraint is static as required by the restrictions for 3529 -- Unchecked_Union. 3530 3531 procedure Check_Valid_Configuration_Pragma; 3532 -- Legality checks for placement of a configuration pragma 3533 3534 procedure Check_Valid_Library_Unit_Pragma; 3535 -- Legality checks for library unit pragmas. A special case arises for 3536 -- pragmas in generic instances that come from copies of the original 3537 -- library unit pragmas in the generic templates. In the case of other 3538 -- than library level instantiations these can appear in contexts which 3539 -- would normally be invalid (they only apply to the original template 3540 -- and to library level instantiations), and they are simply ignored, 3541 -- which is implemented by rewriting them as null statements. 3542 3543 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); 3544 -- Check an Unchecked_Union variant for lack of nested variants and 3545 -- presence of at least one component. UU_Typ is the related Unchecked_ 3546 -- Union type. 3547 3548 procedure Ensure_Aggregate_Form (Arg : Node_Id); 3549 -- Subsidiary routine to the processing of pragmas Abstract_State, 3550 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends, 3551 -- Refined_Global and Refined_State. Transform argument Arg into 3552 -- an aggregate if not one already. N_Null is never transformed. 3553 -- Arg may denote an aspect specification or a pragma argument 3554 -- association. 3555 3556 procedure Error_Pragma (Msg : String); 3557 pragma No_Return (Error_Pragma); 3558 -- Outputs error message for current pragma. The message contains a % 3559 -- that will be replaced with the pragma name, and the flag is placed 3560 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine 3561 -- calls Fix_Error (see spec of that procedure for details). 3562 3563 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); 3564 pragma No_Return (Error_Pragma_Arg); 3565 -- Outputs error message for current pragma. The message may contain 3566 -- a % that will be replaced with the pragma name. The parameter Arg 3567 -- may either be a pragma argument association, in which case the flag 3568 -- is placed on the expression of this association, or an expression, 3569 -- in which case the flag is placed directly on the expression. The 3570 -- message is placed using Error_Msg_N, so the message may also contain 3571 -- an & insertion character which will reference the given Arg value. 3572 -- After placing the message, Pragma_Exit is raised. Note: this routine 3573 -- calls Fix_Error (see spec of that procedure for details). 3574 3575 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); 3576 pragma No_Return (Error_Pragma_Arg); 3577 -- Similar to above form of Error_Pragma_Arg except that two messages 3578 -- are provided, the second is a continuation comment starting with \. 3579 3580 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); 3581 pragma No_Return (Error_Pragma_Arg_Ident); 3582 -- Outputs error message for current pragma. The message may contain a % 3583 -- that will be replaced with the pragma name. The parameter Arg must be 3584 -- a pragma argument association with a non-empty identifier (i.e. its 3585 -- Chars field must be set), and the error message is placed on the 3586 -- identifier. The message is placed using Error_Msg_N so the message 3587 -- may also contain an & insertion character which will reference 3588 -- the identifier. After placing the message, Pragma_Exit is raised. 3589 -- Note: this routine calls Fix_Error (see spec of that procedure for 3590 -- details). 3591 3592 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); 3593 pragma No_Return (Error_Pragma_Ref); 3594 -- Outputs error message for current pragma. The message may contain 3595 -- a % that will be replaced with the pragma name. The parameter Ref 3596 -- must be an entity whose name can be referenced by & and sloc by #. 3597 -- After placing the message, Pragma_Exit is raised. Note: this routine 3598 -- calls Fix_Error (see spec of that procedure for details). 3599 3600 function Find_Lib_Unit_Name return Entity_Id; 3601 -- Used for a library unit pragma to find the entity to which the 3602 -- library unit pragma applies, returns the entity found. 3603 3604 procedure Find_Program_Unit_Name (Id : Node_Id); 3605 -- If the pragma is a compilation unit pragma, the id must denote the 3606 -- compilation unit in the same compilation, and the pragma must appear 3607 -- in the list of preceding or trailing pragmas. If it is a program 3608 -- unit pragma that is not a compilation unit pragma, then the 3609 -- identifier must be visible. 3610 3611 function Find_Unique_Parameterless_Procedure 3612 (Name : Entity_Id; 3613 Arg : Node_Id) return Entity_Id; 3614 -- Used for a procedure pragma to find the unique parameterless 3615 -- procedure identified by Name, returns it if it exists, otherwise 3616 -- errors out and uses Arg as the pragma argument for the message. 3617 3618 function Fix_Error (Msg : String) return String; 3619 -- This is called prior to issuing an error message. Msg is the normal 3620 -- error message issued in the pragma case. This routine checks for the 3621 -- case of a pragma coming from an aspect in the source, and returns a 3622 -- message suitable for the aspect case as follows: 3623 -- 3624 -- Each substring "pragma" is replaced by "aspect" 3625 -- 3626 -- If "argument of" is at the start of the error message text, it is 3627 -- replaced by "entity for". 3628 -- 3629 -- If "argument" is at the start of the error message text, it is 3630 -- replaced by "entity". 3631 -- 3632 -- So for example, "argument of pragma X must be discrete type" 3633 -- returns "entity for aspect X must be a discrete type". 3634 3635 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may 3636 -- be different from the pragma name). If the current pragma results 3637 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the 3638 -- original pragma name. 3639 3640 procedure Gather_Associations 3641 (Names : Name_List; 3642 Args : out Args_List); 3643 -- This procedure is used to gather the arguments for a pragma that 3644 -- permits arbitrary ordering of parameters using the normal rules 3645 -- for named and positional parameters. The Names argument is a list 3646 -- of Name_Id values that corresponds to the allowed pragma argument 3647 -- association identifiers in order. The result returned in Args is 3648 -- a list of corresponding expressions that are the pragma arguments. 3649 -- Note that this is a list of expressions, not of pragma argument 3650 -- associations (Gather_Associations has completely checked all the 3651 -- optional identifiers when it returns). An entry in Args is Empty 3652 -- on return if the corresponding argument is not present. 3653 3654 procedure GNAT_Pragma; 3655 -- Called for all GNAT defined pragmas to check the relevant restriction 3656 -- (No_Implementation_Pragmas). 3657 3658 function Is_Before_First_Decl 3659 (Pragma_Node : Node_Id; 3660 Decls : List_Id) return Boolean; 3661 -- Return True if Pragma_Node is before the first declarative item in 3662 -- Decls where Decls is the list of declarative items. 3663 3664 function Is_Configuration_Pragma return Boolean; 3665 -- Determines if the placement of the current pragma is appropriate 3666 -- for a configuration pragma. 3667 3668 function Is_In_Context_Clause return Boolean; 3669 -- Returns True if pragma appears within the context clause of a unit, 3670 -- and False for any other placement (does not generate any messages). 3671 3672 function Is_Static_String_Expression (Arg : Node_Id) return Boolean; 3673 -- Analyzes the argument, and determines if it is a static string 3674 -- expression, returns True if so, False if non-static or not String. 3675 -- A special case is that a string literal returns True in Ada 83 mode 3676 -- (which has no such thing as static string expressions). Note that 3677 -- the call analyzes its argument, so this cannot be used for the case 3678 -- where an identifier might not be declared. 3679 3680 procedure Pragma_Misplaced; 3681 pragma No_Return (Pragma_Misplaced); 3682 -- Issue fatal error message for misplaced pragma 3683 3684 procedure Process_Atomic_Independent_Shared_Volatile; 3685 -- Common processing for pragmas Atomic, Independent, Shared, Volatile, 3686 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma 3687 -- and treated as being identical in effect to pragma Atomic. 3688 3689 procedure Process_Compile_Time_Warning_Or_Error; 3690 -- Common processing for Compile_Time_Error and Compile_Time_Warning 3691 3692 procedure Process_Convention 3693 (C : out Convention_Id; 3694 Ent : out Entity_Id); 3695 -- Common processing for Convention, Interface, Import and Export. 3696 -- Checks first two arguments of pragma, and sets the appropriate 3697 -- convention value in the specified entity or entities. On return 3698 -- C is the convention, Ent is the referenced entity. 3699 3700 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); 3701 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is 3702 -- Name_Suppress for Disable and Name_Unsuppress for Enable. 3703 3704 procedure Process_Extended_Import_Export_Object_Pragma 3705 (Arg_Internal : Node_Id; 3706 Arg_External : Node_Id; 3707 Arg_Size : Node_Id); 3708 -- Common processing for the pragmas Import/Export_Object. The three 3709 -- arguments correspond to the three named parameters of the pragmas. An 3710 -- argument is empty if the corresponding parameter is not present in 3711 -- the pragma. 3712 3713 procedure Process_Extended_Import_Export_Internal_Arg 3714 (Arg_Internal : Node_Id := Empty); 3715 -- Common processing for all extended Import and Export pragmas. The 3716 -- argument is the pragma parameter for the Internal argument. If 3717 -- Arg_Internal is empty or inappropriate, an error message is posted. 3718 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is 3719 -- set to identify the referenced entity. 3720 3721 procedure Process_Extended_Import_Export_Subprogram_Pragma 3722 (Arg_Internal : Node_Id; 3723 Arg_External : Node_Id; 3724 Arg_Parameter_Types : Node_Id; 3725 Arg_Result_Type : Node_Id := Empty; 3726 Arg_Mechanism : Node_Id; 3727 Arg_Result_Mechanism : Node_Id := Empty); 3728 -- Common processing for all extended Import and Export pragmas applying 3729 -- to subprograms. The caller omits any arguments that do not apply to 3730 -- the pragma in question (for example, Arg_Result_Type can be non-Empty 3731 -- only in the Import_Function and Export_Function cases). The argument 3732 -- names correspond to the allowed pragma association identifiers. 3733 3734 procedure Process_Generic_List; 3735 -- Common processing for Share_Generic and Inline_Generic 3736 3737 procedure Process_Import_Or_Interface; 3738 -- Common processing for Import or Interface 3739 3740 procedure Process_Import_Predefined_Type; 3741 -- Processing for completing a type with pragma Import. This is used 3742 -- to declare types that match predefined C types, especially for cases 3743 -- without corresponding Ada predefined type. 3744 3745 type Inline_Status is (Suppressed, Disabled, Enabled); 3746 -- Inline status of a subprogram, indicated as follows: 3747 -- Suppressed: inlining is suppressed for the subprogram 3748 -- Disabled: no inlining is requested for the subprogram 3749 -- Enabled: inlining is requested/required for the subprogram 3750 3751 procedure Process_Inline (Status : Inline_Status); 3752 -- Common processing for Inline, Inline_Always and No_Inline. Parameter 3753 -- indicates the inline status specified by the pragma. 3754 3755 procedure Process_Interface_Name 3756 (Subprogram_Def : Entity_Id; 3757 Ext_Arg : Node_Id; 3758 Link_Arg : Node_Id); 3759 -- Given the last two arguments of pragma Import, pragma Export, or 3760 -- pragma Interface_Name, performs validity checks and sets the 3761 -- Interface_Name field of the given subprogram entity to the 3762 -- appropriate external or link name, depending on the arguments given. 3763 -- Ext_Arg is always present, but Link_Arg may be missing. Note that 3764 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and 3765 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg 3766 -- nor Link_Arg is present, the interface name is set to the default 3767 -- from the subprogram name. 3768 3769 procedure Process_Interrupt_Or_Attach_Handler; 3770 -- Common processing for Interrupt and Attach_Handler pragmas 3771 3772 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); 3773 -- Common processing for Restrictions and Restriction_Warnings pragmas. 3774 -- Warn is True for Restriction_Warnings, or for Restrictions if the 3775 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag 3776 -- is not set in the Restrictions case. 3777 3778 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); 3779 -- Common processing for Suppress and Unsuppress. The boolean parameter 3780 -- Suppress_Case is True for the Suppress case, and False for the 3781 -- Unsuppress case. 3782 3783 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id); 3784 -- Subsidiary to the analysis of pragmas Independent[_Components]. 3785 -- Record such a pragma N applied to entity E for future checks. 3786 3787 procedure Set_Exported (E : Entity_Id; Arg : Node_Id); 3788 -- This procedure sets the Is_Exported flag for the given entity, 3789 -- checking that the entity was not previously imported. Arg is 3790 -- the argument that specified the entity. A check is also made 3791 -- for exporting inappropriate entities. 3792 3793 procedure Set_Extended_Import_Export_External_Name 3794 (Internal_Ent : Entity_Id; 3795 Arg_External : Node_Id); 3796 -- Common processing for all extended import export pragmas. The first 3797 -- argument, Internal_Ent, is the internal entity, which has already 3798 -- been checked for validity by the caller. Arg_External is from the 3799 -- Import or Export pragma, and may be null if no External parameter 3800 -- was present. If Arg_External is present and is a non-null string 3801 -- (a null string is treated as the default), then the Interface_Name 3802 -- field of Internal_Ent is set appropriately. 3803 3804 procedure Set_Imported (E : Entity_Id); 3805 -- This procedure sets the Is_Imported flag for the given entity, 3806 -- checking that it is not previously exported or imported. 3807 3808 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); 3809 -- Mech is a parameter passing mechanism (see Import_Function syntax 3810 -- for MECHANISM_NAME). This routine checks that the mechanism argument 3811 -- has the right form, and if not issues an error message. If the 3812 -- argument has the right form then the Mechanism field of Ent is 3813 -- set appropriately. 3814 3815 procedure Set_Rational_Profile; 3816 -- Activate the set of configuration pragmas and permissions that make 3817 -- up the Rational profile. 3818 3819 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id); 3820 -- Activate the set of configuration pragmas and restrictions that make 3821 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or 3822 -- Ravenscar. N is the corresponding pragma node, which is used for 3823 -- error messages on any constructs violating the profile. 3824 3825 ---------------------------------- 3826 -- Acquire_Warning_Match_String -- 3827 ---------------------------------- 3828 3829 procedure Acquire_Warning_Match_String (Arg : Node_Id) is 3830 begin 3831 String_To_Name_Buffer 3832 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); 3833 3834 -- Add asterisk at start if not already there 3835 3836 if Name_Len > 0 and then Name_Buffer (1) /= '*' then 3837 Name_Buffer (2 .. Name_Len + 1) := 3838 Name_Buffer (1 .. Name_Len); 3839 Name_Buffer (1) := '*'; 3840 Name_Len := Name_Len + 1; 3841 end if; 3842 3843 -- Add asterisk at end if not already there 3844 3845 if Name_Buffer (Name_Len) /= '*' then 3846 Name_Len := Name_Len + 1; 3847 Name_Buffer (Name_Len) := '*'; 3848 end if; 3849 end Acquire_Warning_Match_String; 3850 3851 --------------------- 3852 -- Ada_2005_Pragma -- 3853 --------------------- 3854 3855 procedure Ada_2005_Pragma is 3856 begin 3857 if Ada_Version <= Ada_95 then 3858 Check_Restriction (No_Implementation_Pragmas, N); 3859 end if; 3860 end Ada_2005_Pragma; 3861 3862 --------------------- 3863 -- Ada_2012_Pragma -- 3864 --------------------- 3865 3866 procedure Ada_2012_Pragma is 3867 begin 3868 if Ada_Version <= Ada_2005 then 3869 Check_Restriction (No_Implementation_Pragmas, N); 3870 end if; 3871 end Ada_2012_Pragma; 3872 3873 ---------------------------- 3874 -- Analyze_Depends_Global -- 3875 ---------------------------- 3876 3877 procedure Analyze_Depends_Global 3878 (Spec_Id : out Entity_Id; 3879 Subp_Decl : out Node_Id; 3880 Legal : out Boolean) 3881 is 3882 begin 3883 -- Assume that the pragma is illegal 3884 3885 Spec_Id := Empty; 3886 Subp_Decl := Empty; 3887 Legal := False; 3888 3889 GNAT_Pragma; 3890 Check_Arg_Count (1); 3891 3892 -- Ensure the proper placement of the pragma. Depends/Global must be 3893 -- associated with a subprogram declaration or a body that acts as a 3894 -- spec. 3895 3896 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); 3897 3898 -- Entry 3899 3900 if Nkind (Subp_Decl) = N_Entry_Declaration then 3901 null; 3902 3903 -- Generic subprogram 3904 3905 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 3906 null; 3907 3908 -- Object declaration of a single concurrent type 3909 3910 elsif Nkind (Subp_Decl) = N_Object_Declaration then 3911 null; 3912 3913 -- Single task type 3914 3915 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then 3916 null; 3917 3918 -- Subprogram body acts as spec 3919 3920 elsif Nkind (Subp_Decl) = N_Subprogram_Body 3921 and then No (Corresponding_Spec (Subp_Decl)) 3922 then 3923 null; 3924 3925 -- Subprogram body stub acts as spec 3926 3927 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 3928 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 3929 then 3930 null; 3931 3932 -- Subprogram declaration 3933 3934 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 3935 null; 3936 3937 -- Task type 3938 3939 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then 3940 null; 3941 3942 else 3943 Pragma_Misplaced; 3944 return; 3945 end if; 3946 3947 -- If we get here, then the pragma is legal 3948 3949 Legal := True; 3950 Spec_Id := Unique_Defining_Entity (Subp_Decl); 3951 3952 -- When the related context is an entry, the entry must belong to a 3953 -- protected unit (SPARK RM 6.1.4(6)). 3954 3955 if Is_Entry_Declaration (Spec_Id) 3956 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type 3957 then 3958 Pragma_Misplaced; 3959 return; 3960 3961 -- When the related context is an anonymous object created for a 3962 -- simple concurrent type, the type must be a task 3963 -- (SPARK RM 6.1.4(6)). 3964 3965 elsif Is_Single_Concurrent_Object (Spec_Id) 3966 and then Ekind (Etype (Spec_Id)) /= E_Task_Type 3967 then 3968 Pragma_Misplaced; 3969 return; 3970 end if; 3971 3972 -- A pragma that applies to a Ghost entity becomes Ghost for the 3973 -- purposes of legality checks and removal of ignored Ghost code. 3974 3975 Mark_Pragma_As_Ghost (N, Spec_Id); 3976 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 3977 end Analyze_Depends_Global; 3978 3979 ------------------------ 3980 -- Analyze_If_Present -- 3981 ------------------------ 3982 3983 procedure Analyze_If_Present (Id : Pragma_Id) is 3984 Stmt : Node_Id; 3985 3986 begin 3987 pragma Assert (Is_List_Member (N)); 3988 3989 -- Inspect the declarations or statements following pragma N looking 3990 -- for another pragma whose Id matches the caller's request. If it is 3991 -- available, analyze it. 3992 3993 Stmt := Next (N); 3994 while Present (Stmt) loop 3995 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then 3996 Analyze_Pragma (Stmt); 3997 exit; 3998 3999 -- The first source declaration or statement immediately following 4000 -- N ends the region where a pragma may appear. 4001 4002 elsif Comes_From_Source (Stmt) then 4003 exit; 4004 end if; 4005 4006 Next (Stmt); 4007 end loop; 4008 end Analyze_If_Present; 4009 4010 -------------------------------- 4011 -- Analyze_Pre_Post_Condition -- 4012 -------------------------------- 4013 4014 procedure Analyze_Pre_Post_Condition is 4015 Prag_Iden : constant Node_Id := Pragma_Identifier (N); 4016 Subp_Decl : Node_Id; 4017 Subp_Id : Entity_Id; 4018 4019 Duplicates_OK : Boolean := False; 4020 -- Flag set when a pre/postcondition allows multiple pragmas of the 4021 -- same kind. 4022 4023 In_Body_OK : Boolean := False; 4024 -- Flag set when a pre/postcondition is allowed to appear on a body 4025 -- even though the subprogram may have a spec. 4026 4027 Is_Pre_Post : Boolean := False; 4028 -- Flag set when the pragma is one of Pre, Pre_Class, Post or 4029 -- Post_Class. 4030 4031 begin 4032 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to 4033 -- offer uniformity among the various kinds of pre/postconditions by 4034 -- rewriting the pragma identifier. This allows the retrieval of the 4035 -- original pragma name by routine Original_Aspect_Pragma_Name. 4036 4037 if Comes_From_Source (N) then 4038 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then 4039 Is_Pre_Post := True; 4040 Set_Class_Present (N, Pname = Name_Pre_Class); 4041 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition)); 4042 4043 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then 4044 Is_Pre_Post := True; 4045 Set_Class_Present (N, Pname = Name_Post_Class); 4046 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition)); 4047 end if; 4048 end if; 4049 4050 -- Determine the semantics with respect to duplicates and placement 4051 -- in a body. Pragmas Precondition and Postcondition were introduced 4052 -- before aspects and are not subject to the same aspect-like rules. 4053 4054 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then 4055 Duplicates_OK := True; 4056 In_Body_OK := True; 4057 end if; 4058 4059 GNAT_Pragma; 4060 4061 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single 4062 -- argument without an identifier. 4063 4064 if Is_Pre_Post then 4065 Check_Arg_Count (1); 4066 Check_No_Identifiers; 4067 4068 -- Pragmas Precondition and Postcondition have complex argument 4069 -- profile. 4070 4071 else 4072 Check_At_Least_N_Arguments (1); 4073 Check_At_Most_N_Arguments (2); 4074 Check_Optional_Identifier (Arg1, Name_Check); 4075 4076 if Present (Arg2) then 4077 Check_Optional_Identifier (Arg2, Name_Message); 4078 Preanalyze_Spec_Expression 4079 (Get_Pragma_Arg (Arg2), Standard_String); 4080 end if; 4081 end if; 4082 4083 -- For a pragma PPC in the extended main source unit, record enabled 4084 -- status in SCO. 4085 -- ??? nothing checks that the pragma is in the main source unit 4086 4087 if Is_Checked (N) and then not Split_PPC (N) then 4088 Set_SCO_Pragma_Enabled (Loc); 4089 end if; 4090 4091 -- Ensure the proper placement of the pragma 4092 4093 Subp_Decl := 4094 Find_Related_Declaration_Or_Body 4095 (N, Do_Checks => not Duplicates_OK); 4096 4097 -- When a pre/postcondition pragma applies to an abstract subprogram, 4098 -- its original form must be an aspect with 'Class. 4099 4100 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 4101 if not From_Aspect_Specification (N) then 4102 Error_Pragma 4103 ("pragma % cannot be applied to abstract subprogram"); 4104 4105 elsif not Class_Present (N) then 4106 Error_Pragma 4107 ("aspect % requires ''Class for abstract subprogram"); 4108 end if; 4109 4110 -- Entry declaration 4111 4112 elsif Nkind (Subp_Decl) = N_Entry_Declaration then 4113 null; 4114 4115 -- Generic subprogram declaration 4116 4117 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 4118 null; 4119 4120 -- Subprogram body 4121 4122 elsif Nkind (Subp_Decl) = N_Subprogram_Body 4123 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK) 4124 then 4125 null; 4126 4127 -- Subprogram body stub 4128 4129 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4130 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK) 4131 then 4132 null; 4133 4134 -- Subprogram declaration 4135 4136 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 4137 4138 -- AI05-0230: When a pre/postcondition pragma applies to a null 4139 -- procedure, its original form must be an aspect with 'Class. 4140 4141 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification 4142 and then Null_Present (Specification (Subp_Decl)) 4143 and then From_Aspect_Specification (N) 4144 and then not Class_Present (N) 4145 then 4146 Error_Pragma ("aspect % requires ''Class for null procedure"); 4147 end if; 4148 4149 -- Otherwise the placement is illegal 4150 4151 else 4152 Pragma_Misplaced; 4153 return; 4154 end if; 4155 4156 Subp_Id := Defining_Entity (Subp_Decl); 4157 4158 -- Chain the pragma on the contract for further processing by 4159 -- Analyze_Pre_Post_Condition_In_Decl_Part. 4160 4161 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 4162 4163 -- A pragma that applies to a Ghost entity becomes Ghost for the 4164 -- purposes of legality checks and removal of ignored Ghost code. 4165 4166 Mark_Pragma_As_Ghost (N, Subp_Id); 4167 4168 -- Fully analyze the pragma when it appears inside an entry or 4169 -- subprogram body because it cannot benefit from forward references. 4170 4171 if Nkind_In (Subp_Decl, N_Entry_Body, 4172 N_Subprogram_Body, 4173 N_Subprogram_Body_Stub) 4174 then 4175 -- The legality checks of pragmas Precondition and Postcondition 4176 -- are affected by the SPARK mode in effect and the volatility of 4177 -- the context. Analyze all pragmas in a specific order. 4178 4179 Analyze_If_Present (Pragma_SPARK_Mode); 4180 Analyze_If_Present (Pragma_Volatile_Function); 4181 Analyze_Pre_Post_Condition_In_Decl_Part (N); 4182 end if; 4183 end Analyze_Pre_Post_Condition; 4184 4185 ----------------------------------------- 4186 -- Analyze_Refined_Depends_Global_Post -- 4187 ----------------------------------------- 4188 4189 procedure Analyze_Refined_Depends_Global_Post 4190 (Spec_Id : out Entity_Id; 4191 Body_Id : out Entity_Id; 4192 Legal : out Boolean) 4193 is 4194 Body_Decl : Node_Id; 4195 Spec_Decl : Node_Id; 4196 4197 begin 4198 -- Assume that the pragma is illegal 4199 4200 Spec_Id := Empty; 4201 Body_Id := Empty; 4202 Legal := False; 4203 4204 GNAT_Pragma; 4205 Check_Arg_Count (1); 4206 Check_No_Identifiers; 4207 4208 -- Verify the placement of the pragma and check for duplicates. The 4209 -- pragma must apply to a subprogram body [stub]. 4210 4211 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); 4212 4213 -- Entry body 4214 4215 if Nkind (Body_Decl) = N_Entry_Body then 4216 null; 4217 4218 -- Subprogram body 4219 4220 elsif Nkind (Body_Decl) = N_Subprogram_Body then 4221 null; 4222 4223 -- Subprogram body stub 4224 4225 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then 4226 null; 4227 4228 -- Task body 4229 4230 elsif Nkind (Body_Decl) = N_Task_Body then 4231 null; 4232 4233 else 4234 Pragma_Misplaced; 4235 return; 4236 end if; 4237 4238 Body_Id := Defining_Entity (Body_Decl); 4239 Spec_Id := Unique_Defining_Entity (Body_Decl); 4240 4241 -- The pragma must apply to the second declaration of a subprogram. 4242 -- In other words, the body [stub] cannot acts as a spec. 4243 4244 if No (Spec_Id) then 4245 Error_Pragma ("pragma % cannot apply to a stand alone body"); 4246 return; 4247 4248 -- Catch the case where the subprogram body is a subunit and acts as 4249 -- the third declaration of the subprogram. 4250 4251 elsif Nkind (Parent (Body_Decl)) = N_Subunit then 4252 Error_Pragma ("pragma % cannot apply to a subunit"); 4253 return; 4254 end if; 4255 4256 -- A refined pragma can only apply to the body [stub] of a subprogram 4257 -- declared in the visible part of a package. Retrieve the context of 4258 -- the subprogram declaration. 4259 4260 Spec_Decl := Unit_Declaration_Node (Spec_Id); 4261 4262 -- When dealing with protected entries or protected subprograms, use 4263 -- the enclosing protected type as the proper context. 4264 4265 if Ekind_In (Spec_Id, E_Entry, 4266 E_Entry_Family, 4267 E_Function, 4268 E_Procedure) 4269 and then Ekind (Scope (Spec_Id)) = E_Protected_Type 4270 then 4271 Spec_Decl := Declaration_Node (Scope (Spec_Id)); 4272 end if; 4273 4274 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then 4275 Error_Pragma 4276 (Fix_Msg (Spec_Id, "pragma % must apply to the body of " 4277 & "subprogram declared in a package specification")); 4278 return; 4279 end if; 4280 4281 -- If we get here, then the pragma is legal 4282 4283 Legal := True; 4284 4285 -- A pragma that applies to a Ghost entity becomes Ghost for the 4286 -- purposes of legality checks and removal of ignored Ghost code. 4287 4288 Mark_Pragma_As_Ghost (N, Spec_Id); 4289 4290 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then 4291 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 4292 end if; 4293 end Analyze_Refined_Depends_Global_Post; 4294 4295 -------------------------- 4296 -- Check_Ada_83_Warning -- 4297 -------------------------- 4298 4299 procedure Check_Ada_83_Warning is 4300 begin 4301 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 4302 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N); 4303 end if; 4304 end Check_Ada_83_Warning; 4305 4306 --------------------- 4307 -- Check_Arg_Count -- 4308 --------------------- 4309 4310 procedure Check_Arg_Count (Required : Nat) is 4311 begin 4312 if Arg_Count /= Required then 4313 Error_Pragma ("wrong number of arguments for pragma%"); 4314 end if; 4315 end Check_Arg_Count; 4316 4317 -------------------------------- 4318 -- Check_Arg_Is_External_Name -- 4319 -------------------------------- 4320 4321 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is 4322 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4323 4324 begin 4325 if Nkind (Argx) = N_Identifier then 4326 return; 4327 4328 else 4329 Analyze_And_Resolve (Argx, Standard_String); 4330 4331 if Is_OK_Static_Expression (Argx) then 4332 return; 4333 4334 elsif Etype (Argx) = Any_Type then 4335 raise Pragma_Exit; 4336 4337 -- An interesting special case, if we have a string literal and 4338 -- we are in Ada 83 mode, then we allow it even though it will 4339 -- not be flagged as static. This allows expected Ada 83 mode 4340 -- use of external names which are string literals, even though 4341 -- technically these are not static in Ada 83. 4342 4343 elsif Ada_Version = Ada_83 4344 and then Nkind (Argx) = N_String_Literal 4345 then 4346 return; 4347 4348 -- Static expression that raises Constraint_Error. This has 4349 -- already been flagged, so just exit from pragma processing. 4350 4351 elsif Is_OK_Static_Expression (Argx) then 4352 raise Pragma_Exit; 4353 4354 -- Here we have a real error (non-static expression) 4355 4356 else 4357 Error_Msg_Name_1 := Pname; 4358 4359 declare 4360 Msg : constant String := 4361 "argument for pragma% must be a identifier or " 4362 & "static string expression!"; 4363 begin 4364 Flag_Non_Static_Expr (Fix_Error (Msg), Argx); 4365 raise Pragma_Exit; 4366 end; 4367 end if; 4368 end if; 4369 end Check_Arg_Is_External_Name; 4370 4371 ----------------------------- 4372 -- Check_Arg_Is_Identifier -- 4373 ----------------------------- 4374 4375 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is 4376 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4377 begin 4378 if Nkind (Argx) /= N_Identifier then 4379 Error_Pragma_Arg 4380 ("argument for pragma% must be identifier", Argx); 4381 end if; 4382 end Check_Arg_Is_Identifier; 4383 4384 ---------------------------------- 4385 -- Check_Arg_Is_Integer_Literal -- 4386 ---------------------------------- 4387 4388 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is 4389 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4390 begin 4391 if Nkind (Argx) /= N_Integer_Literal then 4392 Error_Pragma_Arg 4393 ("argument for pragma% must be integer literal", Argx); 4394 end if; 4395 end Check_Arg_Is_Integer_Literal; 4396 4397 ------------------------------------------- 4398 -- Check_Arg_Is_Library_Level_Local_Name -- 4399 ------------------------------------------- 4400 4401 -- LOCAL_NAME ::= 4402 -- DIRECT_NAME 4403 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 4404 -- | library_unit_NAME 4405 4406 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is 4407 begin 4408 Check_Arg_Is_Local_Name (Arg); 4409 4410 -- If it came from an aspect, we want to give the error just as if it 4411 -- came from source. 4412 4413 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) 4414 and then (Comes_From_Source (N) 4415 or else Present (Corresponding_Aspect (Parent (Arg)))) 4416 then 4417 Error_Pragma_Arg 4418 ("argument for pragma% must be library level entity", Arg); 4419 end if; 4420 end Check_Arg_Is_Library_Level_Local_Name; 4421 4422 ----------------------------- 4423 -- Check_Arg_Is_Local_Name -- 4424 ----------------------------- 4425 4426 -- LOCAL_NAME ::= 4427 -- DIRECT_NAME 4428 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 4429 -- | library_unit_NAME 4430 4431 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is 4432 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4433 4434 begin 4435 Analyze (Argx); 4436 4437 if Nkind (Argx) not in N_Direct_Name 4438 and then (Nkind (Argx) /= N_Attribute_Reference 4439 or else Present (Expressions (Argx)) 4440 or else Nkind (Prefix (Argx)) /= N_Identifier) 4441 and then (not Is_Entity_Name (Argx) 4442 or else not Is_Compilation_Unit (Entity (Argx))) 4443 then 4444 Error_Pragma_Arg ("argument for pragma% must be local name", Argx); 4445 end if; 4446 4447 -- No further check required if not an entity name 4448 4449 if not Is_Entity_Name (Argx) then 4450 null; 4451 4452 else 4453 declare 4454 OK : Boolean; 4455 Ent : constant Entity_Id := Entity (Argx); 4456 Scop : constant Entity_Id := Scope (Ent); 4457 4458 begin 4459 -- Case of a pragma applied to a compilation unit: pragma must 4460 -- occur immediately after the program unit in the compilation. 4461 4462 if Is_Compilation_Unit (Ent) then 4463 declare 4464 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 4465 4466 begin 4467 -- Case of pragma placed immediately after spec 4468 4469 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then 4470 OK := True; 4471 4472 -- Case of pragma placed immediately after body 4473 4474 elsif Nkind (Decl) = N_Subprogram_Declaration 4475 and then Present (Corresponding_Body (Decl)) 4476 then 4477 OK := Parent (N) = 4478 Aux_Decls_Node 4479 (Parent (Unit_Declaration_Node 4480 (Corresponding_Body (Decl)))); 4481 4482 -- All other cases are illegal 4483 4484 else 4485 OK := False; 4486 end if; 4487 end; 4488 4489 -- Special restricted placement rule from 10.2.1(11.8/2) 4490 4491 elsif Is_Generic_Formal (Ent) 4492 and then Prag_Id = Pragma_Preelaborable_Initialization 4493 then 4494 OK := List_Containing (N) = 4495 Generic_Formal_Declarations 4496 (Unit_Declaration_Node (Scop)); 4497 4498 -- If this is an aspect applied to a subprogram body, the 4499 -- pragma is inserted in its declarative part. 4500 4501 elsif From_Aspect_Specification (N) 4502 and then Ent = Current_Scope 4503 and then 4504 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body 4505 then 4506 OK := True; 4507 4508 -- If the aspect is a predicate (possibly others ???) and the 4509 -- context is a record type, this is a discriminant expression 4510 -- within a type declaration, that freezes the predicated 4511 -- subtype. 4512 4513 elsif From_Aspect_Specification (N) 4514 and then Prag_Id = Pragma_Predicate 4515 and then Ekind (Current_Scope) = E_Record_Type 4516 and then Scop = Scope (Current_Scope) 4517 then 4518 OK := True; 4519 4520 -- Default case, just check that the pragma occurs in the scope 4521 -- of the entity denoted by the name. 4522 4523 else 4524 OK := Current_Scope = Scop; 4525 end if; 4526 4527 if not OK then 4528 Error_Pragma_Arg 4529 ("pragma% argument must be in same declarative part", Arg); 4530 end if; 4531 end; 4532 end if; 4533 end Check_Arg_Is_Local_Name; 4534 4535 --------------------------------- 4536 -- Check_Arg_Is_Locking_Policy -- 4537 --------------------------------- 4538 4539 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is 4540 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4541 4542 begin 4543 Check_Arg_Is_Identifier (Argx); 4544 4545 if not Is_Locking_Policy_Name (Chars (Argx)) then 4546 Error_Pragma_Arg ("& is not a valid locking policy name", Argx); 4547 end if; 4548 end Check_Arg_Is_Locking_Policy; 4549 4550 ----------------------------------------------- 4551 -- Check_Arg_Is_Partition_Elaboration_Policy -- 4552 ----------------------------------------------- 4553 4554 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is 4555 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4556 4557 begin 4558 Check_Arg_Is_Identifier (Argx); 4559 4560 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then 4561 Error_Pragma_Arg 4562 ("& is not a valid partition elaboration policy name", Argx); 4563 end if; 4564 end Check_Arg_Is_Partition_Elaboration_Policy; 4565 4566 ------------------------- 4567 -- Check_Arg_Is_One_Of -- 4568 ------------------------- 4569 4570 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 4571 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4572 4573 begin 4574 Check_Arg_Is_Identifier (Argx); 4575 4576 if not Nam_In (Chars (Argx), N1, N2) then 4577 Error_Msg_Name_2 := N1; 4578 Error_Msg_Name_3 := N2; 4579 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); 4580 end if; 4581 end Check_Arg_Is_One_Of; 4582 4583 procedure Check_Arg_Is_One_Of 4584 (Arg : Node_Id; 4585 N1, N2, N3 : Name_Id) 4586 is 4587 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4588 4589 begin 4590 Check_Arg_Is_Identifier (Argx); 4591 4592 if not Nam_In (Chars (Argx), N1, N2, N3) then 4593 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 4594 end if; 4595 end Check_Arg_Is_One_Of; 4596 4597 procedure Check_Arg_Is_One_Of 4598 (Arg : Node_Id; 4599 N1, N2, N3, N4 : Name_Id) 4600 is 4601 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4602 4603 begin 4604 Check_Arg_Is_Identifier (Argx); 4605 4606 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then 4607 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 4608 end if; 4609 end Check_Arg_Is_One_Of; 4610 4611 procedure Check_Arg_Is_One_Of 4612 (Arg : Node_Id; 4613 N1, N2, N3, N4, N5 : Name_Id) 4614 is 4615 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4616 4617 begin 4618 Check_Arg_Is_Identifier (Argx); 4619 4620 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then 4621 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 4622 end if; 4623 end Check_Arg_Is_One_Of; 4624 4625 --------------------------------- 4626 -- Check_Arg_Is_Queuing_Policy -- 4627 --------------------------------- 4628 4629 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is 4630 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4631 4632 begin 4633 Check_Arg_Is_Identifier (Argx); 4634 4635 if not Is_Queuing_Policy_Name (Chars (Argx)) then 4636 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); 4637 end if; 4638 end Check_Arg_Is_Queuing_Policy; 4639 4640 --------------------------------------- 4641 -- Check_Arg_Is_OK_Static_Expression -- 4642 --------------------------------------- 4643 4644 procedure Check_Arg_Is_OK_Static_Expression 4645 (Arg : Node_Id; 4646 Typ : Entity_Id := Empty) 4647 is 4648 begin 4649 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ); 4650 end Check_Arg_Is_OK_Static_Expression; 4651 4652 ------------------------------------------ 4653 -- Check_Arg_Is_Task_Dispatching_Policy -- 4654 ------------------------------------------ 4655 4656 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is 4657 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4658 4659 begin 4660 Check_Arg_Is_Identifier (Argx); 4661 4662 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then 4663 Error_Pragma_Arg 4664 ("& is not an allowed task dispatching policy name", Argx); 4665 end if; 4666 end Check_Arg_Is_Task_Dispatching_Policy; 4667 4668 --------------------- 4669 -- Check_Arg_Order -- 4670 --------------------- 4671 4672 procedure Check_Arg_Order (Names : Name_List) is 4673 Arg : Node_Id; 4674 4675 Highest_So_Far : Natural := 0; 4676 -- Highest index in Names seen do far 4677 4678 begin 4679 Arg := Arg1; 4680 for J in 1 .. Arg_Count loop 4681 if Chars (Arg) /= No_Name then 4682 for K in Names'Range loop 4683 if Chars (Arg) = Names (K) then 4684 if K < Highest_So_Far then 4685 Error_Msg_Name_1 := Pname; 4686 Error_Msg_N 4687 ("parameters out of order for pragma%", Arg); 4688 Error_Msg_Name_1 := Names (K); 4689 Error_Msg_Name_2 := Names (Highest_So_Far); 4690 Error_Msg_N ("\% must appear before %", Arg); 4691 raise Pragma_Exit; 4692 4693 else 4694 Highest_So_Far := K; 4695 end if; 4696 end if; 4697 end loop; 4698 end if; 4699 4700 Arg := Next (Arg); 4701 end loop; 4702 end Check_Arg_Order; 4703 4704 -------------------------------- 4705 -- Check_At_Least_N_Arguments -- 4706 -------------------------------- 4707 4708 procedure Check_At_Least_N_Arguments (N : Nat) is 4709 begin 4710 if Arg_Count < N then 4711 Error_Pragma ("too few arguments for pragma%"); 4712 end if; 4713 end Check_At_Least_N_Arguments; 4714 4715 ------------------------------- 4716 -- Check_At_Most_N_Arguments -- 4717 ------------------------------- 4718 4719 procedure Check_At_Most_N_Arguments (N : Nat) is 4720 Arg : Node_Id; 4721 begin 4722 if Arg_Count > N then 4723 Arg := Arg1; 4724 for J in 1 .. N loop 4725 Next (Arg); 4726 Error_Pragma_Arg ("too many arguments for pragma%", Arg); 4727 end loop; 4728 end if; 4729 end Check_At_Most_N_Arguments; 4730 4731 --------------------- 4732 -- Check_Component -- 4733 --------------------- 4734 4735 procedure Check_Component 4736 (Comp : Node_Id; 4737 UU_Typ : Entity_Id; 4738 In_Variant_Part : Boolean := False) 4739 is 4740 Comp_Id : constant Entity_Id := Defining_Identifier (Comp); 4741 Sindic : constant Node_Id := 4742 Subtype_Indication (Component_Definition (Comp)); 4743 Typ : constant Entity_Id := Etype (Comp_Id); 4744 4745 begin 4746 -- Ada 2005 (AI-216): If a component subtype is subject to a per- 4747 -- object constraint, then the component type shall be an Unchecked_ 4748 -- Union. 4749 4750 if Nkind (Sindic) = N_Subtype_Indication 4751 and then Has_Per_Object_Constraint (Comp_Id) 4752 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) 4753 then 4754 Error_Msg_N 4755 ("component subtype subject to per-object constraint " 4756 & "must be an Unchecked_Union", Comp); 4757 4758 -- Ada 2012 (AI05-0026): For an unchecked union type declared within 4759 -- the body of a generic unit, or within the body of any of its 4760 -- descendant library units, no part of the type of a component 4761 -- declared in a variant_part of the unchecked union type shall be of 4762 -- a formal private type or formal private extension declared within 4763 -- the formal part of the generic unit. 4764 4765 elsif Ada_Version >= Ada_2012 4766 and then In_Generic_Body (UU_Typ) 4767 and then In_Variant_Part 4768 and then Is_Private_Type (Typ) 4769 and then Is_Generic_Type (Typ) 4770 then 4771 Error_Msg_N 4772 ("component of unchecked union cannot be of generic type", Comp); 4773 4774 elsif Needs_Finalization (Typ) then 4775 Error_Msg_N 4776 ("component of unchecked union cannot be controlled", Comp); 4777 4778 elsif Has_Task (Typ) then 4779 Error_Msg_N 4780 ("component of unchecked union cannot have tasks", Comp); 4781 end if; 4782 end Check_Component; 4783 4784 ---------------------------- 4785 -- Check_Duplicate_Pragma -- 4786 ---------------------------- 4787 4788 procedure Check_Duplicate_Pragma (E : Entity_Id) is 4789 Id : Entity_Id := E; 4790 P : Node_Id; 4791 4792 begin 4793 -- Nothing to do if this pragma comes from an aspect specification, 4794 -- since we could not be duplicating a pragma, and we dealt with the 4795 -- case of duplicated aspects in Analyze_Aspect_Specifications. 4796 4797 if From_Aspect_Specification (N) then 4798 return; 4799 end if; 4800 4801 -- Otherwise current pragma may duplicate previous pragma or a 4802 -- previously given aspect specification or attribute definition 4803 -- clause for the same pragma. 4804 4805 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False); 4806 4807 if Present (P) then 4808 4809 -- If the entity is a type, then we have to make sure that the 4810 -- ostensible duplicate is not for a parent type from which this 4811 -- type is derived. 4812 4813 if Is_Type (E) then 4814 if Nkind (P) = N_Pragma then 4815 declare 4816 Args : constant List_Id := 4817 Pragma_Argument_Associations (P); 4818 begin 4819 if Present (Args) 4820 and then Is_Entity_Name (Expression (First (Args))) 4821 and then Is_Type (Entity (Expression (First (Args)))) 4822 and then Entity (Expression (First (Args))) /= E 4823 then 4824 return; 4825 end if; 4826 end; 4827 4828 elsif Nkind (P) = N_Aspect_Specification 4829 and then Is_Type (Entity (P)) 4830 and then Entity (P) /= E 4831 then 4832 return; 4833 end if; 4834 end if; 4835 4836 -- Here we have a definite duplicate 4837 4838 Error_Msg_Name_1 := Pragma_Name (N); 4839 Error_Msg_Sloc := Sloc (P); 4840 4841 -- For a single protected or a single task object, the error is 4842 -- issued on the original entity. 4843 4844 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then 4845 Id := Defining_Identifier (Original_Node (Parent (Id))); 4846 end if; 4847 4848 if Nkind (P) = N_Aspect_Specification 4849 or else From_Aspect_Specification (P) 4850 then 4851 Error_Msg_NE ("aspect% for & previously given#", N, Id); 4852 else 4853 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); 4854 end if; 4855 4856 raise Pragma_Exit; 4857 end if; 4858 end Check_Duplicate_Pragma; 4859 4860 ---------------------------------- 4861 -- Check_Duplicated_Export_Name -- 4862 ---------------------------------- 4863 4864 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is 4865 String_Val : constant String_Id := Strval (Nam); 4866 4867 begin 4868 -- We are only interested in the export case, and in the case of 4869 -- generics, it is the instance, not the template, that is the 4870 -- problem (the template will generate a warning in any case). 4871 4872 if not Inside_A_Generic 4873 and then (Prag_Id = Pragma_Export 4874 or else 4875 Prag_Id = Pragma_Export_Procedure 4876 or else 4877 Prag_Id = Pragma_Export_Valued_Procedure 4878 or else 4879 Prag_Id = Pragma_Export_Function) 4880 then 4881 for J in Externals.First .. Externals.Last loop 4882 if String_Equal (String_Val, Strval (Externals.Table (J))) then 4883 Error_Msg_Sloc := Sloc (Externals.Table (J)); 4884 Error_Msg_N ("external name duplicates name given#", Nam); 4885 exit; 4886 end if; 4887 end loop; 4888 4889 Externals.Append (Nam); 4890 end if; 4891 end Check_Duplicated_Export_Name; 4892 4893 ---------------------------------------- 4894 -- Check_Expr_Is_OK_Static_Expression -- 4895 ---------------------------------------- 4896 4897 procedure Check_Expr_Is_OK_Static_Expression 4898 (Expr : Node_Id; 4899 Typ : Entity_Id := Empty) 4900 is 4901 begin 4902 if Present (Typ) then 4903 Analyze_And_Resolve (Expr, Typ); 4904 else 4905 Analyze_And_Resolve (Expr); 4906 end if; 4907 4908 if Is_OK_Static_Expression (Expr) then 4909 return; 4910 4911 elsif Etype (Expr) = Any_Type then 4912 raise Pragma_Exit; 4913 4914 -- An interesting special case, if we have a string literal and we 4915 -- are in Ada 83 mode, then we allow it even though it will not be 4916 -- flagged as static. This allows the use of Ada 95 pragmas like 4917 -- Import in Ada 83 mode. They will of course be flagged with 4918 -- warnings as usual, but will not cause errors. 4919 4920 elsif Ada_Version = Ada_83 4921 and then Nkind (Expr) = N_String_Literal 4922 then 4923 return; 4924 4925 -- Static expression that raises Constraint_Error. This has already 4926 -- been flagged, so just exit from pragma processing. 4927 4928 elsif Is_OK_Static_Expression (Expr) then 4929 raise Pragma_Exit; 4930 4931 -- Finally, we have a real error 4932 4933 else 4934 Error_Msg_Name_1 := Pname; 4935 Flag_Non_Static_Expr 4936 (Fix_Error ("argument for pragma% must be a static expression!"), 4937 Expr); 4938 raise Pragma_Exit; 4939 end if; 4940 end Check_Expr_Is_OK_Static_Expression; 4941 4942 ------------------------- 4943 -- Check_First_Subtype -- 4944 ------------------------- 4945 4946 procedure Check_First_Subtype (Arg : Node_Id) is 4947 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4948 Ent : constant Entity_Id := Entity (Argx); 4949 4950 begin 4951 if Is_First_Subtype (Ent) then 4952 null; 4953 4954 elsif Is_Type (Ent) then 4955 Error_Pragma_Arg 4956 ("pragma% cannot apply to subtype", Argx); 4957 4958 elsif Is_Object (Ent) then 4959 Error_Pragma_Arg 4960 ("pragma% cannot apply to object, requires a type", Argx); 4961 4962 else 4963 Error_Pragma_Arg 4964 ("pragma% cannot apply to&, requires a type", Argx); 4965 end if; 4966 end Check_First_Subtype; 4967 4968 ---------------------- 4969 -- Check_Identifier -- 4970 ---------------------- 4971 4972 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is 4973 begin 4974 if Present (Arg) 4975 and then Nkind (Arg) = N_Pragma_Argument_Association 4976 then 4977 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then 4978 Error_Msg_Name_1 := Pname; 4979 Error_Msg_Name_2 := Id; 4980 Error_Msg_N ("pragma% argument expects identifier%", Arg); 4981 raise Pragma_Exit; 4982 end if; 4983 end if; 4984 end Check_Identifier; 4985 4986 -------------------------------- 4987 -- Check_Identifier_Is_One_Of -- 4988 -------------------------------- 4989 4990 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 4991 begin 4992 if Present (Arg) 4993 and then Nkind (Arg) = N_Pragma_Argument_Association 4994 then 4995 if Chars (Arg) = No_Name then 4996 Error_Msg_Name_1 := Pname; 4997 Error_Msg_N ("pragma% argument expects an identifier", Arg); 4998 raise Pragma_Exit; 4999 5000 elsif Chars (Arg) /= N1 5001 and then Chars (Arg) /= N2 5002 then 5003 Error_Msg_Name_1 := Pname; 5004 Error_Msg_N ("invalid identifier for pragma% argument", Arg); 5005 raise Pragma_Exit; 5006 end if; 5007 end if; 5008 end Check_Identifier_Is_One_Of; 5009 5010 --------------------------- 5011 -- Check_In_Main_Program -- 5012 --------------------------- 5013 5014 procedure Check_In_Main_Program is 5015 P : constant Node_Id := Parent (N); 5016 5017 begin 5018 -- Must be in subprogram body 5019 5020 if Nkind (P) /= N_Subprogram_Body then 5021 Error_Pragma ("% pragma allowed only in subprogram"); 5022 5023 -- Otherwise warn if obviously not main program 5024 5025 elsif Present (Parameter_Specifications (Specification (P))) 5026 or else not Is_Compilation_Unit (Defining_Entity (P)) 5027 then 5028 Error_Msg_Name_1 := Pname; 5029 Error_Msg_N 5030 ("??pragma% is only effective in main program", N); 5031 end if; 5032 end Check_In_Main_Program; 5033 5034 --------------------------------------- 5035 -- Check_Interrupt_Or_Attach_Handler -- 5036 --------------------------------------- 5037 5038 procedure Check_Interrupt_Or_Attach_Handler is 5039 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); 5040 Handler_Proc, Proc_Scope : Entity_Id; 5041 5042 begin 5043 Analyze (Arg1_X); 5044 5045 if Prag_Id = Pragma_Interrupt_Handler then 5046 Check_Restriction (No_Dynamic_Attachment, N); 5047 end if; 5048 5049 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 5050 Proc_Scope := Scope (Handler_Proc); 5051 5052 -- On AAMP only, a pragma Interrupt_Handler is supported for 5053 -- nonprotected parameterless procedures. 5054 5055 if not AAMP_On_Target 5056 or else Prag_Id = Pragma_Attach_Handler 5057 then 5058 if Ekind (Proc_Scope) /= E_Protected_Type then 5059 Error_Pragma_Arg 5060 ("argument of pragma% must be protected procedure", Arg1); 5061 end if; 5062 5063 -- For pragma case (as opposed to access case), check placement. 5064 -- We don't need to do that for aspects, because we have the 5065 -- check that they aspect applies an appropriate procedure. 5066 5067 if not From_Aspect_Specification (N) 5068 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope)) 5069 then 5070 Error_Pragma ("pragma% must be in protected definition"); 5071 end if; 5072 end if; 5073 5074 if not Is_Library_Level_Entity (Proc_Scope) 5075 or else (AAMP_On_Target 5076 and then not Is_Library_Level_Entity (Handler_Proc)) 5077 then 5078 Error_Pragma_Arg 5079 ("argument for pragma% must be library level entity", Arg1); 5080 end if; 5081 5082 -- AI05-0033: A pragma cannot appear within a generic body, because 5083 -- instance can be in a nested scope. The check that protected type 5084 -- is itself a library-level declaration is done elsewhere. 5085 5086 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly 5087 -- handle code prior to AI-0033. Analysis tools typically are not 5088 -- interested in this pragma in any case, so no need to worry too 5089 -- much about its placement. 5090 5091 if Inside_A_Generic then 5092 if Ekind (Scope (Current_Scope)) = E_Generic_Package 5093 and then In_Package_Body (Scope (Current_Scope)) 5094 and then not Relaxed_RM_Semantics 5095 then 5096 Error_Pragma ("pragma% cannot be used inside a generic"); 5097 end if; 5098 end if; 5099 end Check_Interrupt_Or_Attach_Handler; 5100 5101 --------------------------------- 5102 -- Check_Loop_Pragma_Placement -- 5103 --------------------------------- 5104 5105 procedure Check_Loop_Pragma_Placement is 5106 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id); 5107 -- Verify whether the current pragma is properly grouped with other 5108 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the 5109 -- related loop where the pragma appears. 5110 5111 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean; 5112 -- Determine whether an arbitrary statement Stmt denotes pragma 5113 -- Loop_Invariant or Loop_Variant. 5114 5115 procedure Placement_Error (Constr : Node_Id); 5116 pragma No_Return (Placement_Error); 5117 -- Node Constr denotes the last loop restricted construct before we 5118 -- encountered an illegal relation between enclosing constructs. Emit 5119 -- an error depending on what Constr was. 5120 5121 -------------------------------- 5122 -- Check_Loop_Pragma_Grouping -- 5123 -------------------------------- 5124 5125 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is 5126 Stop_Search : exception; 5127 -- This exception is used to terminate the recursive descent of 5128 -- routine Check_Grouping. 5129 5130 procedure Check_Grouping (L : List_Id); 5131 -- Find the first group of pragmas in list L and if successful, 5132 -- ensure that the current pragma is part of that group. The 5133 -- routine raises Stop_Search once such a check is performed to 5134 -- halt the recursive descent. 5135 5136 procedure Grouping_Error (Prag : Node_Id); 5137 pragma No_Return (Grouping_Error); 5138 -- Emit an error concerning the current pragma indicating that it 5139 -- should be placed after pragma Prag. 5140 5141 -------------------- 5142 -- Check_Grouping -- 5143 -------------------- 5144 5145 procedure Check_Grouping (L : List_Id) is 5146 HSS : Node_Id; 5147 Prag : Node_Id; 5148 Stmt : Node_Id; 5149 5150 begin 5151 -- Inspect the list of declarations or statements looking for 5152 -- the first grouping of pragmas: 5153 5154 -- loop 5155 -- pragma Loop_Invariant ...; 5156 -- pragma Loop_Variant ...; 5157 -- . . . -- (1) 5158 -- pragma Loop_Variant ...; -- current pragma 5159 5160 -- If the current pragma is not in the grouping, then it must 5161 -- either appear in a different declarative or statement list 5162 -- or the construct at (1) is separating the pragma from the 5163 -- grouping. 5164 5165 Stmt := First (L); 5166 while Present (Stmt) loop 5167 5168 -- Pragmas Loop_Invariant and Loop_Variant may only appear 5169 -- inside a loop or a block housed inside a loop. Inspect 5170 -- the declarations and statements of the block as they may 5171 -- contain the first grouping. 5172 5173 if Nkind (Stmt) = N_Block_Statement then 5174 HSS := Handled_Statement_Sequence (Stmt); 5175 5176 Check_Grouping (Declarations (Stmt)); 5177 5178 if Present (HSS) then 5179 Check_Grouping (Statements (HSS)); 5180 end if; 5181 5182 -- First pragma of the first topmost grouping has been found 5183 5184 elsif Is_Loop_Pragma (Stmt) then 5185 5186 -- The group and the current pragma are not in the same 5187 -- declarative or statement list. 5188 5189 if List_Containing (Stmt) /= List_Containing (N) then 5190 Grouping_Error (Stmt); 5191 5192 -- Try to reach the current pragma from the first pragma 5193 -- of the grouping while skipping other members: 5194 5195 -- pragma Loop_Invariant ...; -- first pragma 5196 -- pragma Loop_Variant ...; -- member 5197 -- . . . 5198 -- pragma Loop_Variant ...; -- current pragma 5199 5200 else 5201 while Present (Stmt) loop 5202 5203 -- The current pragma is either the first pragma 5204 -- of the group or is a member of the group. Stop 5205 -- the search as the placement is legal. 5206 5207 if Stmt = N then 5208 raise Stop_Search; 5209 5210 -- Skip group members, but keep track of the last 5211 -- pragma in the group. 5212 5213 elsif Is_Loop_Pragma (Stmt) then 5214 Prag := Stmt; 5215 5216 -- Skip declarations and statements generated by 5217 -- the compiler during expansion. 5218 5219 elsif not Comes_From_Source (Stmt) then 5220 null; 5221 5222 -- A non-pragma is separating the group from the 5223 -- current pragma, the placement is illegal. 5224 5225 else 5226 Grouping_Error (Prag); 5227 end if; 5228 5229 Next (Stmt); 5230 end loop; 5231 5232 -- If the traversal did not reach the current pragma, 5233 -- then the list must be malformed. 5234 5235 raise Program_Error; 5236 end if; 5237 end if; 5238 5239 Next (Stmt); 5240 end loop; 5241 end Check_Grouping; 5242 5243 -------------------- 5244 -- Grouping_Error -- 5245 -------------------- 5246 5247 procedure Grouping_Error (Prag : Node_Id) is 5248 begin 5249 Error_Msg_Sloc := Sloc (Prag); 5250 Error_Pragma ("pragma% must appear next to pragma#"); 5251 end Grouping_Error; 5252 5253 -- Start of processing for Check_Loop_Pragma_Grouping 5254 5255 begin 5256 -- Inspect the statements of the loop or nested blocks housed 5257 -- within to determine whether the current pragma is part of the 5258 -- first topmost grouping of Loop_Invariant and Loop_Variant. 5259 5260 Check_Grouping (Statements (Loop_Stmt)); 5261 5262 exception 5263 when Stop_Search => null; 5264 end Check_Loop_Pragma_Grouping; 5265 5266 -------------------- 5267 -- Is_Loop_Pragma -- 5268 -------------------- 5269 5270 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is 5271 begin 5272 -- Inspect the original node as Loop_Invariant and Loop_Variant 5273 -- pragmas are rewritten to null when assertions are disabled. 5274 5275 if Nkind (Original_Node (Stmt)) = N_Pragma then 5276 return 5277 Nam_In (Pragma_Name (Original_Node (Stmt)), 5278 Name_Loop_Invariant, 5279 Name_Loop_Variant); 5280 else 5281 return False; 5282 end if; 5283 end Is_Loop_Pragma; 5284 5285 --------------------- 5286 -- Placement_Error -- 5287 --------------------- 5288 5289 procedure Placement_Error (Constr : Node_Id) is 5290 LA : constant String := " with Loop_Entry"; 5291 5292 begin 5293 if Prag_Id = Pragma_Assert then 5294 Error_Msg_String (1 .. LA'Length) := LA; 5295 Error_Msg_Strlen := LA'Length; 5296 else 5297 Error_Msg_Strlen := 0; 5298 end if; 5299 5300 if Nkind (Constr) = N_Pragma then 5301 Error_Pragma 5302 ("pragma %~ must appear immediately within the statements " 5303 & "of a loop"); 5304 else 5305 Error_Pragma_Arg 5306 ("block containing pragma %~ must appear immediately within " 5307 & "the statements of a loop", Constr); 5308 end if; 5309 end Placement_Error; 5310 5311 -- Local declarations 5312 5313 Prev : Node_Id; 5314 Stmt : Node_Id; 5315 5316 -- Start of processing for Check_Loop_Pragma_Placement 5317 5318 begin 5319 -- Check that pragma appears immediately within a loop statement, 5320 -- ignoring intervening block statements. 5321 5322 Prev := N; 5323 Stmt := Parent (N); 5324 while Present (Stmt) loop 5325 5326 -- The pragma or previous block must appear immediately within the 5327 -- current block's declarative or statement part. 5328 5329 if Nkind (Stmt) = N_Block_Statement then 5330 if (No (Declarations (Stmt)) 5331 or else List_Containing (Prev) /= Declarations (Stmt)) 5332 and then 5333 List_Containing (Prev) /= 5334 Statements (Handled_Statement_Sequence (Stmt)) 5335 then 5336 Placement_Error (Prev); 5337 return; 5338 5339 -- Keep inspecting the parents because we are now within a 5340 -- chain of nested blocks. 5341 5342 else 5343 Prev := Stmt; 5344 Stmt := Parent (Stmt); 5345 end if; 5346 5347 -- The pragma or previous block must appear immediately within the 5348 -- statements of the loop. 5349 5350 elsif Nkind (Stmt) = N_Loop_Statement then 5351 if List_Containing (Prev) /= Statements (Stmt) then 5352 Placement_Error (Prev); 5353 end if; 5354 5355 -- Stop the traversal because we reached the innermost loop 5356 -- regardless of whether we encountered an error or not. 5357 5358 exit; 5359 5360 -- Ignore a handled statement sequence. Note that this node may 5361 -- be related to a subprogram body in which case we will emit an 5362 -- error on the next iteration of the search. 5363 5364 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then 5365 Stmt := Parent (Stmt); 5366 5367 -- Any other statement breaks the chain from the pragma to the 5368 -- loop. 5369 5370 else 5371 Placement_Error (Prev); 5372 return; 5373 end if; 5374 end loop; 5375 5376 -- Check that the current pragma Loop_Invariant or Loop_Variant is 5377 -- grouped together with other such pragmas. 5378 5379 if Is_Loop_Pragma (N) then 5380 5381 -- The previous check should have located the related loop 5382 5383 pragma Assert (Nkind (Stmt) = N_Loop_Statement); 5384 Check_Loop_Pragma_Grouping (Stmt); 5385 end if; 5386 end Check_Loop_Pragma_Placement; 5387 5388 ------------------------------------------- 5389 -- Check_Is_In_Decl_Part_Or_Package_Spec -- 5390 ------------------------------------------- 5391 5392 procedure Check_Is_In_Decl_Part_Or_Package_Spec is 5393 P : Node_Id; 5394 5395 begin 5396 P := Parent (N); 5397 loop 5398 if No (P) then 5399 exit; 5400 5401 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then 5402 exit; 5403 5404 elsif Nkind_In (P, N_Package_Specification, 5405 N_Block_Statement) 5406 then 5407 return; 5408 5409 -- Note: the following tests seem a little peculiar, because 5410 -- they test for bodies, but if we were in the statement part 5411 -- of the body, we would already have hit the handled statement 5412 -- sequence, so the only way we get here is by being in the 5413 -- declarative part of the body. 5414 5415 elsif Nkind_In (P, N_Subprogram_Body, 5416 N_Package_Body, 5417 N_Task_Body, 5418 N_Entry_Body) 5419 then 5420 return; 5421 end if; 5422 5423 P := Parent (P); 5424 end loop; 5425 5426 Error_Pragma ("pragma% is not in declarative part or package spec"); 5427 end Check_Is_In_Decl_Part_Or_Package_Spec; 5428 5429 ------------------------- 5430 -- Check_No_Identifier -- 5431 ------------------------- 5432 5433 procedure Check_No_Identifier (Arg : Node_Id) is 5434 begin 5435 if Nkind (Arg) = N_Pragma_Argument_Association 5436 and then Chars (Arg) /= No_Name 5437 then 5438 Error_Pragma_Arg_Ident 5439 ("pragma% does not permit identifier& here", Arg); 5440 end if; 5441 end Check_No_Identifier; 5442 5443 -------------------------- 5444 -- Check_No_Identifiers -- 5445 -------------------------- 5446 5447 procedure Check_No_Identifiers is 5448 Arg_Node : Node_Id; 5449 begin 5450 Arg_Node := Arg1; 5451 for J in 1 .. Arg_Count loop 5452 Check_No_Identifier (Arg_Node); 5453 Next (Arg_Node); 5454 end loop; 5455 end Check_No_Identifiers; 5456 5457 ------------------------ 5458 -- Check_No_Link_Name -- 5459 ------------------------ 5460 5461 procedure Check_No_Link_Name is 5462 begin 5463 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then 5464 Arg4 := Arg3; 5465 end if; 5466 5467 if Present (Arg4) then 5468 Error_Pragma_Arg 5469 ("Link_Name argument not allowed for Import Intrinsic", Arg4); 5470 end if; 5471 end Check_No_Link_Name; 5472 5473 ------------------------------- 5474 -- Check_Optional_Identifier -- 5475 ------------------------------- 5476 5477 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 5478 begin 5479 if Present (Arg) 5480 and then Nkind (Arg) = N_Pragma_Argument_Association 5481 and then Chars (Arg) /= No_Name 5482 then 5483 if Chars (Arg) /= Id then 5484 Error_Msg_Name_1 := Pname; 5485 Error_Msg_Name_2 := Id; 5486 Error_Msg_N ("pragma% argument expects identifier%", Arg); 5487 raise Pragma_Exit; 5488 end if; 5489 end if; 5490 end Check_Optional_Identifier; 5491 5492 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is 5493 begin 5494 Name_Buffer (1 .. Id'Length) := Id; 5495 Name_Len := Id'Length; 5496 Check_Optional_Identifier (Arg, Name_Find); 5497 end Check_Optional_Identifier; 5498 5499 ------------------------------------- 5500 -- Check_Static_Boolean_Expression -- 5501 ------------------------------------- 5502 5503 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is 5504 begin 5505 if Present (Expr) then 5506 Analyze_And_Resolve (Expr, Standard_Boolean); 5507 5508 if not Is_OK_Static_Expression (Expr) then 5509 Error_Pragma_Arg 5510 ("expression of pragma % must be static", Expr); 5511 end if; 5512 end if; 5513 end Check_Static_Boolean_Expression; 5514 5515 ----------------------------- 5516 -- Check_Static_Constraint -- 5517 ----------------------------- 5518 5519 -- Note: for convenience in writing this procedure, in addition to 5520 -- the officially (i.e. by spec) allowed argument which is always a 5521 -- constraint, it also allows ranges and discriminant associations. 5522 -- Above is not clear ??? 5523 5524 procedure Check_Static_Constraint (Constr : Node_Id) is 5525 5526 procedure Require_Static (E : Node_Id); 5527 -- Require given expression to be static expression 5528 5529 -------------------- 5530 -- Require_Static -- 5531 -------------------- 5532 5533 procedure Require_Static (E : Node_Id) is 5534 begin 5535 if not Is_OK_Static_Expression (E) then 5536 Flag_Non_Static_Expr 5537 ("non-static constraint not allowed in Unchecked_Union!", E); 5538 raise Pragma_Exit; 5539 end if; 5540 end Require_Static; 5541 5542 -- Start of processing for Check_Static_Constraint 5543 5544 begin 5545 case Nkind (Constr) is 5546 when N_Discriminant_Association => 5547 Require_Static (Expression (Constr)); 5548 5549 when N_Range => 5550 Require_Static (Low_Bound (Constr)); 5551 Require_Static (High_Bound (Constr)); 5552 5553 when N_Attribute_Reference => 5554 Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); 5555 Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); 5556 5557 when N_Range_Constraint => 5558 Check_Static_Constraint (Range_Expression (Constr)); 5559 5560 when N_Index_Or_Discriminant_Constraint => 5561 declare 5562 IDC : Entity_Id; 5563 begin 5564 IDC := First (Constraints (Constr)); 5565 while Present (IDC) loop 5566 Check_Static_Constraint (IDC); 5567 Next (IDC); 5568 end loop; 5569 end; 5570 5571 when others => 5572 null; 5573 end case; 5574 end Check_Static_Constraint; 5575 5576 -------------------------------------- 5577 -- Check_Valid_Configuration_Pragma -- 5578 -------------------------------------- 5579 5580 -- A configuration pragma must appear in the context clause of a 5581 -- compilation unit, and only other pragmas may precede it. Note that 5582 -- the test also allows use in a configuration pragma file. 5583 5584 procedure Check_Valid_Configuration_Pragma is 5585 begin 5586 if not Is_Configuration_Pragma then 5587 Error_Pragma ("incorrect placement for configuration pragma%"); 5588 end if; 5589 end Check_Valid_Configuration_Pragma; 5590 5591 ------------------------------------- 5592 -- Check_Valid_Library_Unit_Pragma -- 5593 ------------------------------------- 5594 5595 procedure Check_Valid_Library_Unit_Pragma is 5596 Plist : List_Id; 5597 Parent_Node : Node_Id; 5598 Unit_Name : Entity_Id; 5599 Unit_Kind : Node_Kind; 5600 Unit_Node : Node_Id; 5601 Sindex : Source_File_Index; 5602 5603 begin 5604 if not Is_List_Member (N) then 5605 Pragma_Misplaced; 5606 5607 else 5608 Plist := List_Containing (N); 5609 Parent_Node := Parent (Plist); 5610 5611 if Parent_Node = Empty then 5612 Pragma_Misplaced; 5613 5614 -- Case of pragma appearing after a compilation unit. In this case 5615 -- it must have an argument with the corresponding name and must 5616 -- be part of the following pragmas of its parent. 5617 5618 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then 5619 if Plist /= Pragmas_After (Parent_Node) then 5620 Pragma_Misplaced; 5621 5622 elsif Arg_Count = 0 then 5623 Error_Pragma 5624 ("argument required if outside compilation unit"); 5625 5626 else 5627 Check_No_Identifiers; 5628 Check_Arg_Count (1); 5629 Unit_Node := Unit (Parent (Parent_Node)); 5630 Unit_Kind := Nkind (Unit_Node); 5631 5632 Analyze (Get_Pragma_Arg (Arg1)); 5633 5634 if Unit_Kind = N_Generic_Subprogram_Declaration 5635 or else Unit_Kind = N_Subprogram_Declaration 5636 then 5637 Unit_Name := Defining_Entity (Unit_Node); 5638 5639 elsif Unit_Kind in N_Generic_Instantiation then 5640 Unit_Name := Defining_Entity (Unit_Node); 5641 5642 else 5643 Unit_Name := Cunit_Entity (Current_Sem_Unit); 5644 end if; 5645 5646 if Chars (Unit_Name) /= 5647 Chars (Entity (Get_Pragma_Arg (Arg1))) 5648 then 5649 Error_Pragma_Arg 5650 ("pragma% argument is not current unit name", Arg1); 5651 end if; 5652 5653 if Ekind (Unit_Name) = E_Package 5654 and then Present (Renamed_Entity (Unit_Name)) 5655 then 5656 Error_Pragma ("pragma% not allowed for renamed package"); 5657 end if; 5658 end if; 5659 5660 -- Pragma appears other than after a compilation unit 5661 5662 else 5663 -- Here we check for the generic instantiation case and also 5664 -- for the case of processing a generic formal package. We 5665 -- detect these cases by noting that the Sloc on the node 5666 -- does not belong to the current compilation unit. 5667 5668 Sindex := Source_Index (Current_Sem_Unit); 5669 5670 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then 5671 Rewrite (N, Make_Null_Statement (Loc)); 5672 return; 5673 5674 -- If before first declaration, the pragma applies to the 5675 -- enclosing unit, and the name if present must be this name. 5676 5677 elsif Is_Before_First_Decl (N, Plist) then 5678 Unit_Node := Unit_Declaration_Node (Current_Scope); 5679 Unit_Kind := Nkind (Unit_Node); 5680 5681 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then 5682 Pragma_Misplaced; 5683 5684 elsif Unit_Kind = N_Subprogram_Body 5685 and then not Acts_As_Spec (Unit_Node) 5686 then 5687 Pragma_Misplaced; 5688 5689 elsif Nkind (Parent_Node) = N_Package_Body then 5690 Pragma_Misplaced; 5691 5692 elsif Nkind (Parent_Node) = N_Package_Specification 5693 and then Plist = Private_Declarations (Parent_Node) 5694 then 5695 Pragma_Misplaced; 5696 5697 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration 5698 or else Nkind (Parent_Node) = 5699 N_Generic_Subprogram_Declaration) 5700 and then Plist = Generic_Formal_Declarations (Parent_Node) 5701 then 5702 Pragma_Misplaced; 5703 5704 elsif Arg_Count > 0 then 5705 Analyze (Get_Pragma_Arg (Arg1)); 5706 5707 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then 5708 Error_Pragma_Arg 5709 ("name in pragma% must be enclosing unit", Arg1); 5710 end if; 5711 5712 -- It is legal to have no argument in this context 5713 5714 else 5715 return; 5716 end if; 5717 5718 -- Error if not before first declaration. This is because a 5719 -- library unit pragma argument must be the name of a library 5720 -- unit (RM 10.1.5(7)), but the only names permitted in this 5721 -- context are (RM 10.1.5(6)) names of subprogram declarations, 5722 -- generic subprogram declarations or generic instantiations. 5723 5724 else 5725 Error_Pragma 5726 ("pragma% misplaced, must be before first declaration"); 5727 end if; 5728 end if; 5729 end if; 5730 end Check_Valid_Library_Unit_Pragma; 5731 5732 ------------------- 5733 -- Check_Variant -- 5734 ------------------- 5735 5736 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is 5737 Clist : constant Node_Id := Component_List (Variant); 5738 Comp : Node_Id; 5739 5740 begin 5741 Comp := First (Component_Items (Clist)); 5742 while Present (Comp) loop 5743 Check_Component (Comp, UU_Typ, In_Variant_Part => True); 5744 Next (Comp); 5745 end loop; 5746 end Check_Variant; 5747 5748 --------------------------- 5749 -- Ensure_Aggregate_Form -- 5750 --------------------------- 5751 5752 procedure Ensure_Aggregate_Form (Arg : Node_Id) is 5753 CFSD : constant Boolean := Get_Comes_From_Source_Default; 5754 Expr : constant Node_Id := Expression (Arg); 5755 Loc : constant Source_Ptr := Sloc (Expr); 5756 Comps : List_Id := No_List; 5757 Exprs : List_Id := No_List; 5758 Nam : Name_Id := No_Name; 5759 Nam_Loc : Source_Ptr; 5760 5761 begin 5762 -- The pragma argument is in positional form: 5763 5764 -- pragma Depends (Nam => ...) 5765 -- ^ 5766 -- Chars field 5767 5768 -- Note that the Sloc of the Chars field is the Sloc of the pragma 5769 -- argument association. 5770 5771 if Nkind (Arg) = N_Pragma_Argument_Association then 5772 Nam := Chars (Arg); 5773 Nam_Loc := Sloc (Arg); 5774 5775 -- Remove the pragma argument name as this will be captured in the 5776 -- aggregate. 5777 5778 Set_Chars (Arg, No_Name); 5779 end if; 5780 5781 -- The argument is already in aggregate form, but the presence of a 5782 -- name causes this to be interpreted as named association which in 5783 -- turn must be converted into an aggregate. 5784 5785 -- pragma Global (In_Out => (A, B, C)) 5786 -- ^ ^ 5787 -- name aggregate 5788 5789 -- pragma Global ((In_Out => (A, B, C))) 5790 -- ^ ^ 5791 -- aggregate aggregate 5792 5793 if Nkind (Expr) = N_Aggregate then 5794 if Nam = No_Name then 5795 return; 5796 end if; 5797 5798 -- Do not transform a null argument into an aggregate as N_Null has 5799 -- special meaning in formal verification pragmas. 5800 5801 elsif Nkind (Expr) = N_Null then 5802 return; 5803 end if; 5804 5805 -- Everything comes from source if the original comes from source 5806 5807 Set_Comes_From_Source_Default (Comes_From_Source (Arg)); 5808 5809 -- Positional argument is transformed into an aggregate with an 5810 -- Expressions list. 5811 5812 if Nam = No_Name then 5813 Exprs := New_List (Relocate_Node (Expr)); 5814 5815 -- An associative argument is transformed into an aggregate with 5816 -- Component_Associations. 5817 5818 else 5819 Comps := New_List ( 5820 Make_Component_Association (Loc, 5821 Choices => New_List (Make_Identifier (Nam_Loc, Nam)), 5822 Expression => Relocate_Node (Expr))); 5823 end if; 5824 5825 Set_Expression (Arg, 5826 Make_Aggregate (Loc, 5827 Component_Associations => Comps, 5828 Expressions => Exprs)); 5829 5830 -- Restore Comes_From_Source default 5831 5832 Set_Comes_From_Source_Default (CFSD); 5833 end Ensure_Aggregate_Form; 5834 5835 ------------------ 5836 -- Error_Pragma -- 5837 ------------------ 5838 5839 procedure Error_Pragma (Msg : String) is 5840 begin 5841 Error_Msg_Name_1 := Pname; 5842 Error_Msg_N (Fix_Error (Msg), N); 5843 raise Pragma_Exit; 5844 end Error_Pragma; 5845 5846 ---------------------- 5847 -- Error_Pragma_Arg -- 5848 ---------------------- 5849 5850 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is 5851 begin 5852 Error_Msg_Name_1 := Pname; 5853 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg)); 5854 raise Pragma_Exit; 5855 end Error_Pragma_Arg; 5856 5857 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is 5858 begin 5859 Error_Msg_Name_1 := Pname; 5860 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg)); 5861 Error_Pragma_Arg (Msg2, Arg); 5862 end Error_Pragma_Arg; 5863 5864 ---------------------------- 5865 -- Error_Pragma_Arg_Ident -- 5866 ---------------------------- 5867 5868 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is 5869 begin 5870 Error_Msg_Name_1 := Pname; 5871 Error_Msg_N (Fix_Error (Msg), Arg); 5872 raise Pragma_Exit; 5873 end Error_Pragma_Arg_Ident; 5874 5875 ---------------------- 5876 -- Error_Pragma_Ref -- 5877 ---------------------- 5878 5879 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is 5880 begin 5881 Error_Msg_Name_1 := Pname; 5882 Error_Msg_Sloc := Sloc (Ref); 5883 Error_Msg_NE (Fix_Error (Msg), N, Ref); 5884 raise Pragma_Exit; 5885 end Error_Pragma_Ref; 5886 5887 ------------------------ 5888 -- Find_Lib_Unit_Name -- 5889 ------------------------ 5890 5891 function Find_Lib_Unit_Name return Entity_Id is 5892 begin 5893 -- Return inner compilation unit entity, for case of nested 5894 -- categorization pragmas. This happens in generic unit. 5895 5896 if Nkind (Parent (N)) = N_Package_Specification 5897 and then Defining_Entity (Parent (N)) /= Current_Scope 5898 then 5899 return Defining_Entity (Parent (N)); 5900 else 5901 return Current_Scope; 5902 end if; 5903 end Find_Lib_Unit_Name; 5904 5905 ---------------------------- 5906 -- Find_Program_Unit_Name -- 5907 ---------------------------- 5908 5909 procedure Find_Program_Unit_Name (Id : Node_Id) is 5910 Unit_Name : Entity_Id; 5911 Unit_Kind : Node_Kind; 5912 P : constant Node_Id := Parent (N); 5913 5914 begin 5915 if Nkind (P) = N_Compilation_Unit then 5916 Unit_Kind := Nkind (Unit (P)); 5917 5918 if Nkind_In (Unit_Kind, N_Subprogram_Declaration, 5919 N_Package_Declaration) 5920 or else Unit_Kind in N_Generic_Declaration 5921 then 5922 Unit_Name := Defining_Entity (Unit (P)); 5923 5924 if Chars (Id) = Chars (Unit_Name) then 5925 Set_Entity (Id, Unit_Name); 5926 Set_Etype (Id, Etype (Unit_Name)); 5927 else 5928 Set_Etype (Id, Any_Type); 5929 Error_Pragma 5930 ("cannot find program unit referenced by pragma%"); 5931 end if; 5932 5933 else 5934 Set_Etype (Id, Any_Type); 5935 Error_Pragma ("pragma% inapplicable to this unit"); 5936 end if; 5937 5938 else 5939 Analyze (Id); 5940 end if; 5941 end Find_Program_Unit_Name; 5942 5943 ----------------------------------------- 5944 -- Find_Unique_Parameterless_Procedure -- 5945 ----------------------------------------- 5946 5947 function Find_Unique_Parameterless_Procedure 5948 (Name : Entity_Id; 5949 Arg : Node_Id) return Entity_Id 5950 is 5951 Proc : Entity_Id := Empty; 5952 5953 begin 5954 -- The body of this procedure needs some comments ??? 5955 5956 if not Is_Entity_Name (Name) then 5957 Error_Pragma_Arg 5958 ("argument of pragma% must be entity name", Arg); 5959 5960 elsif not Is_Overloaded (Name) then 5961 Proc := Entity (Name); 5962 5963 if Ekind (Proc) /= E_Procedure 5964 or else Present (First_Formal (Proc)) 5965 then 5966 Error_Pragma_Arg 5967 ("argument of pragma% must be parameterless procedure", Arg); 5968 end if; 5969 5970 else 5971 declare 5972 Found : Boolean := False; 5973 It : Interp; 5974 Index : Interp_Index; 5975 5976 begin 5977 Get_First_Interp (Name, Index, It); 5978 while Present (It.Nam) loop 5979 Proc := It.Nam; 5980 5981 if Ekind (Proc) = E_Procedure 5982 and then No (First_Formal (Proc)) 5983 then 5984 if not Found then 5985 Found := True; 5986 Set_Entity (Name, Proc); 5987 Set_Is_Overloaded (Name, False); 5988 else 5989 Error_Pragma_Arg 5990 ("ambiguous handler name for pragma% ", Arg); 5991 end if; 5992 end if; 5993 5994 Get_Next_Interp (Index, It); 5995 end loop; 5996 5997 if not Found then 5998 Error_Pragma_Arg 5999 ("argument of pragma% must be parameterless procedure", 6000 Arg); 6001 else 6002 Proc := Entity (Name); 6003 end if; 6004 end; 6005 end if; 6006 6007 return Proc; 6008 end Find_Unique_Parameterless_Procedure; 6009 6010 --------------- 6011 -- Fix_Error -- 6012 --------------- 6013 6014 function Fix_Error (Msg : String) return String is 6015 Res : String (Msg'Range) := Msg; 6016 Res_Last : Natural := Msg'Last; 6017 J : Natural; 6018 6019 begin 6020 -- If we have a rewriting of another pragma, go to that pragma 6021 6022 if Is_Rewrite_Substitution (N) 6023 and then Nkind (Original_Node (N)) = N_Pragma 6024 then 6025 Error_Msg_Name_1 := Pragma_Name (Original_Node (N)); 6026 end if; 6027 6028 -- Case where pragma comes from an aspect specification 6029 6030 if From_Aspect_Specification (N) then 6031 6032 -- Change appearence of "pragma" in message to "aspect" 6033 6034 J := Res'First; 6035 while J <= Res_Last - 5 loop 6036 if Res (J .. J + 5) = "pragma" then 6037 Res (J .. J + 5) := "aspect"; 6038 J := J + 6; 6039 6040 else 6041 J := J + 1; 6042 end if; 6043 end loop; 6044 6045 -- Change "argument of" at start of message to "entity for" 6046 6047 if Res'Length > 11 6048 and then Res (Res'First .. Res'First + 10) = "argument of" 6049 then 6050 Res (Res'First .. Res'First + 9) := "entity for"; 6051 Res (Res'First + 10 .. Res_Last - 1) := 6052 Res (Res'First + 11 .. Res_Last); 6053 Res_Last := Res_Last - 1; 6054 end if; 6055 6056 -- Change "argument" at start of message to "entity" 6057 6058 if Res'Length > 8 6059 and then Res (Res'First .. Res'First + 7) = "argument" 6060 then 6061 Res (Res'First .. Res'First + 5) := "entity"; 6062 Res (Res'First + 6 .. Res_Last - 2) := 6063 Res (Res'First + 8 .. Res_Last); 6064 Res_Last := Res_Last - 2; 6065 end if; 6066 6067 -- Get name from corresponding aspect 6068 6069 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N); 6070 end if; 6071 6072 -- Return possibly modified message 6073 6074 return Res (Res'First .. Res_Last); 6075 end Fix_Error; 6076 6077 ------------------------- 6078 -- Gather_Associations -- 6079 ------------------------- 6080 6081 procedure Gather_Associations 6082 (Names : Name_List; 6083 Args : out Args_List) 6084 is 6085 Arg : Node_Id; 6086 6087 begin 6088 -- Initialize all parameters to Empty 6089 6090 for J in Args'Range loop 6091 Args (J) := Empty; 6092 end loop; 6093 6094 -- That's all we have to do if there are no argument associations 6095 6096 if No (Pragma_Argument_Associations (N)) then 6097 return; 6098 end if; 6099 6100 -- Otherwise first deal with any positional parameters present 6101 6102 Arg := First (Pragma_Argument_Associations (N)); 6103 for Index in Args'Range loop 6104 exit when No (Arg) or else Chars (Arg) /= No_Name; 6105 Args (Index) := Get_Pragma_Arg (Arg); 6106 Next (Arg); 6107 end loop; 6108 6109 -- Positional parameters all processed, if any left, then we 6110 -- have too many positional parameters. 6111 6112 if Present (Arg) and then Chars (Arg) = No_Name then 6113 Error_Pragma_Arg 6114 ("too many positional associations for pragma%", Arg); 6115 end if; 6116 6117 -- Process named parameters if any are present 6118 6119 while Present (Arg) loop 6120 if Chars (Arg) = No_Name then 6121 Error_Pragma_Arg 6122 ("positional association cannot follow named association", 6123 Arg); 6124 6125 else 6126 for Index in Names'Range loop 6127 if Names (Index) = Chars (Arg) then 6128 if Present (Args (Index)) then 6129 Error_Pragma_Arg 6130 ("duplicate argument association for pragma%", Arg); 6131 else 6132 Args (Index) := Get_Pragma_Arg (Arg); 6133 exit; 6134 end if; 6135 end if; 6136 6137 if Index = Names'Last then 6138 Error_Msg_Name_1 := Pname; 6139 Error_Msg_N ("pragma% does not allow & argument", Arg); 6140 6141 -- Check for possible misspelling 6142 6143 for Index1 in Names'Range loop 6144 if Is_Bad_Spelling_Of 6145 (Chars (Arg), Names (Index1)) 6146 then 6147 Error_Msg_Name_1 := Names (Index1); 6148 Error_Msg_N -- CODEFIX 6149 ("\possible misspelling of%", Arg); 6150 exit; 6151 end if; 6152 end loop; 6153 6154 raise Pragma_Exit; 6155 end if; 6156 end loop; 6157 end if; 6158 6159 Next (Arg); 6160 end loop; 6161 end Gather_Associations; 6162 6163 ----------------- 6164 -- GNAT_Pragma -- 6165 ----------------- 6166 6167 procedure GNAT_Pragma is 6168 begin 6169 -- We need to check the No_Implementation_Pragmas restriction for 6170 -- the case of a pragma from source. Note that the case of aspects 6171 -- generating corresponding pragmas marks these pragmas as not being 6172 -- from source, so this test also catches that case. 6173 6174 if Comes_From_Source (N) then 6175 Check_Restriction (No_Implementation_Pragmas, N); 6176 end if; 6177 end GNAT_Pragma; 6178 6179 -------------------------- 6180 -- Is_Before_First_Decl -- 6181 -------------------------- 6182 6183 function Is_Before_First_Decl 6184 (Pragma_Node : Node_Id; 6185 Decls : List_Id) return Boolean 6186 is 6187 Item : Node_Id := First (Decls); 6188 6189 begin 6190 -- Only other pragmas can come before this pragma 6191 6192 loop 6193 if No (Item) or else Nkind (Item) /= N_Pragma then 6194 return False; 6195 6196 elsif Item = Pragma_Node then 6197 return True; 6198 end if; 6199 6200 Next (Item); 6201 end loop; 6202 end Is_Before_First_Decl; 6203 6204 ----------------------------- 6205 -- Is_Configuration_Pragma -- 6206 ----------------------------- 6207 6208 -- A configuration pragma must appear in the context clause of a 6209 -- compilation unit, and only other pragmas may precede it. Note that 6210 -- the test below also permits use in a configuration pragma file. 6211 6212 function Is_Configuration_Pragma return Boolean is 6213 Lis : constant List_Id := List_Containing (N); 6214 Par : constant Node_Id := Parent (N); 6215 Prg : Node_Id; 6216 6217 begin 6218 -- If no parent, then we are in the configuration pragma file, 6219 -- so the placement is definitely appropriate. 6220 6221 if No (Par) then 6222 return True; 6223 6224 -- Otherwise we must be in the context clause of a compilation unit 6225 -- and the only thing allowed before us in the context list is more 6226 -- configuration pragmas. 6227 6228 elsif Nkind (Par) = N_Compilation_Unit 6229 and then Context_Items (Par) = Lis 6230 then 6231 Prg := First (Lis); 6232 6233 loop 6234 if Prg = N then 6235 return True; 6236 elsif Nkind (Prg) /= N_Pragma then 6237 return False; 6238 end if; 6239 6240 Next (Prg); 6241 end loop; 6242 6243 else 6244 return False; 6245 end if; 6246 end Is_Configuration_Pragma; 6247 6248 -------------------------- 6249 -- Is_In_Context_Clause -- 6250 -------------------------- 6251 6252 function Is_In_Context_Clause return Boolean is 6253 Plist : List_Id; 6254 Parent_Node : Node_Id; 6255 6256 begin 6257 if not Is_List_Member (N) then 6258 return False; 6259 6260 else 6261 Plist := List_Containing (N); 6262 Parent_Node := Parent (Plist); 6263 6264 if Parent_Node = Empty 6265 or else Nkind (Parent_Node) /= N_Compilation_Unit 6266 or else Context_Items (Parent_Node) /= Plist 6267 then 6268 return False; 6269 end if; 6270 end if; 6271 6272 return True; 6273 end Is_In_Context_Clause; 6274 6275 --------------------------------- 6276 -- Is_Static_String_Expression -- 6277 --------------------------------- 6278 6279 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is 6280 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 6281 Lit : constant Boolean := Nkind (Argx) = N_String_Literal; 6282 6283 begin 6284 Analyze_And_Resolve (Argx); 6285 6286 -- Special case Ada 83, where the expression will never be static, 6287 -- but we will return true if we had a string literal to start with. 6288 6289 if Ada_Version = Ada_83 then 6290 return Lit; 6291 6292 -- Normal case, true only if we end up with a string literal that 6293 -- is marked as being the result of evaluating a static expression. 6294 6295 else 6296 return Is_OK_Static_Expression (Argx) 6297 and then Nkind (Argx) = N_String_Literal; 6298 end if; 6299 6300 end Is_Static_String_Expression; 6301 6302 ---------------------- 6303 -- Pragma_Misplaced -- 6304 ---------------------- 6305 6306 procedure Pragma_Misplaced is 6307 begin 6308 Error_Pragma ("incorrect placement of pragma%"); 6309 end Pragma_Misplaced; 6310 6311 ------------------------------------------------ 6312 -- Process_Atomic_Independent_Shared_Volatile -- 6313 ------------------------------------------------ 6314 6315 procedure Process_Atomic_Independent_Shared_Volatile is 6316 D : Node_Id; 6317 E : Entity_Id; 6318 E_Id : Node_Id; 6319 K : Node_Kind; 6320 6321 procedure Set_Atomic_VFA (E : Entity_Id); 6322 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if 6323 -- no explicit alignment was given, set alignment to unknown, since 6324 -- back end knows what the alignment requirements are for atomic and 6325 -- full access arrays. Note: this is necessary for derived types. 6326 6327 -------------------- 6328 -- Set_Atomic_VFA -- 6329 -------------------- 6330 6331 procedure Set_Atomic_VFA (E : Entity_Id) is 6332 begin 6333 if Prag_Id = Pragma_Volatile_Full_Access then 6334 Set_Is_Volatile_Full_Access (E); 6335 else 6336 Set_Is_Atomic (E); 6337 end if; 6338 6339 if not Has_Alignment_Clause (E) then 6340 Set_Alignment (E, Uint_0); 6341 end if; 6342 end Set_Atomic_VFA; 6343 6344 -- Start of processing for Process_Atomic_Independent_Shared_Volatile 6345 6346 begin 6347 Check_Ada_83_Warning; 6348 Check_No_Identifiers; 6349 Check_Arg_Count (1); 6350 Check_Arg_Is_Local_Name (Arg1); 6351 E_Id := Get_Pragma_Arg (Arg1); 6352 6353 if Etype (E_Id) = Any_Type then 6354 return; 6355 end if; 6356 6357 E := Entity (E_Id); 6358 D := Declaration_Node (E); 6359 K := Nkind (D); 6360 6361 -- A pragma that applies to a Ghost entity becomes Ghost for the 6362 -- purposes of legality checks and removal of ignored Ghost code. 6363 6364 Mark_Pragma_As_Ghost (N, E); 6365 6366 -- Check duplicate before we chain ourselves 6367 6368 Check_Duplicate_Pragma (E); 6369 6370 -- Check Atomic and VFA used together 6371 6372 if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access) 6373 or else (Is_Volatile_Full_Access (E) 6374 and then (Prag_Id = Pragma_Atomic 6375 or else 6376 Prag_Id = Pragma_Shared)) 6377 then 6378 Error_Pragma 6379 ("cannot have Volatile_Full_Access and Atomic for same entity"); 6380 end if; 6381 6382 -- Check for applying VFA to an entity which has aliased component 6383 6384 if Prag_Id = Pragma_Volatile_Full_Access then 6385 declare 6386 Comp : Entity_Id; 6387 Aliased_Comp : Boolean := False; 6388 -- Set True if aliased component present 6389 6390 begin 6391 if Is_Array_Type (Etype (E)) then 6392 Aliased_Comp := Has_Aliased_Components (Etype (E)); 6393 6394 -- Record case, too bad Has_Aliased_Components is not also 6395 -- set for records, should it be ??? 6396 6397 elsif Is_Record_Type (Etype (E)) then 6398 Comp := First_Component_Or_Discriminant (Etype (E)); 6399 while Present (Comp) loop 6400 if Is_Aliased (Comp) 6401 or else Is_Aliased (Etype (Comp)) 6402 then 6403 Aliased_Comp := True; 6404 exit; 6405 end if; 6406 6407 Next_Component_Or_Discriminant (Comp); 6408 end loop; 6409 end if; 6410 6411 if Aliased_Comp then 6412 Error_Pragma 6413 ("cannot apply Volatile_Full_Access (aliased component " 6414 & "present)"); 6415 end if; 6416 end; 6417 end if; 6418 6419 -- Now check appropriateness of the entity 6420 6421 if Is_Type (E) then 6422 if Rep_Item_Too_Early (E, N) 6423 or else 6424 Rep_Item_Too_Late (E, N) 6425 then 6426 return; 6427 else 6428 Check_First_Subtype (Arg1); 6429 end if; 6430 6431 -- Attribute belongs on the base type. If the view of the type is 6432 -- currently private, it also belongs on the underlying type. 6433 6434 if Prag_Id = Pragma_Atomic 6435 or else 6436 Prag_Id = Pragma_Shared 6437 or else 6438 Prag_Id = Pragma_Volatile_Full_Access 6439 then 6440 Set_Atomic_VFA (E); 6441 Set_Atomic_VFA (Base_Type (E)); 6442 Set_Atomic_VFA (Underlying_Type (E)); 6443 end if; 6444 6445 -- Atomic/Shared/Volatile_Full_Access imply Independent 6446 6447 if Prag_Id /= Pragma_Volatile then 6448 Set_Is_Independent (E); 6449 Set_Is_Independent (Base_Type (E)); 6450 Set_Is_Independent (Underlying_Type (E)); 6451 6452 if Prag_Id = Pragma_Independent then 6453 Record_Independence_Check (N, Base_Type (E)); 6454 end if; 6455 end if; 6456 6457 -- Atomic/Shared/Volatile_Full_Access imply Volatile 6458 6459 if Prag_Id /= Pragma_Independent then 6460 Set_Is_Volatile (E); 6461 Set_Is_Volatile (Base_Type (E)); 6462 Set_Is_Volatile (Underlying_Type (E)); 6463 6464 Set_Treat_As_Volatile (E); 6465 Set_Treat_As_Volatile (Underlying_Type (E)); 6466 end if; 6467 6468 elsif K = N_Object_Declaration 6469 or else (K = N_Component_Declaration 6470 and then Original_Record_Component (E) = E) 6471 then 6472 if Rep_Item_Too_Late (E, N) then 6473 return; 6474 end if; 6475 6476 if Prag_Id = Pragma_Atomic 6477 or else 6478 Prag_Id = Pragma_Shared 6479 or else 6480 Prag_Id = Pragma_Volatile_Full_Access 6481 then 6482 if Prag_Id = Pragma_Volatile_Full_Access then 6483 Set_Is_Volatile_Full_Access (E); 6484 else 6485 Set_Is_Atomic (E); 6486 end if; 6487 6488 -- If the object declaration has an explicit initialization, a 6489 -- temporary may have to be created to hold the expression, to 6490 -- ensure that access to the object remain atomic. 6491 6492 if Nkind (Parent (E)) = N_Object_Declaration 6493 and then Present (Expression (Parent (E))) 6494 then 6495 Set_Has_Delayed_Freeze (E); 6496 end if; 6497 end if; 6498 6499 -- Atomic/Shared/Volatile_Full_Access imply Independent 6500 6501 if Prag_Id /= Pragma_Volatile then 6502 Set_Is_Independent (E); 6503 6504 if Prag_Id = Pragma_Independent then 6505 Record_Independence_Check (N, E); 6506 end if; 6507 end if; 6508 6509 -- Atomic/Shared/Volatile_Full_Access imply Volatile 6510 6511 if Prag_Id /= Pragma_Independent then 6512 Set_Is_Volatile (E); 6513 Set_Treat_As_Volatile (E); 6514 end if; 6515 6516 else 6517 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 6518 end if; 6519 6520 -- The following check is only relevant when SPARK_Mode is on as 6521 -- this is not a standard Ada legality rule. Pragma Volatile can 6522 -- only apply to a full type declaration or an object declaration 6523 -- (SPARK RM C.6(1)). 6524 6525 if SPARK_Mode = On 6526 and then Prag_Id = Pragma_Volatile 6527 and then not Nkind_In (K, N_Full_Type_Declaration, 6528 N_Object_Declaration) 6529 then 6530 Error_Pragma_Arg 6531 ("argument of pragma % must denote a full type or object " 6532 & "declaration", Arg1); 6533 end if; 6534 end Process_Atomic_Independent_Shared_Volatile; 6535 6536 ------------------------------------------- 6537 -- Process_Compile_Time_Warning_Or_Error -- 6538 ------------------------------------------- 6539 6540 procedure Process_Compile_Time_Warning_Or_Error is 6541 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 6542 6543 begin 6544 Check_Arg_Count (2); 6545 Check_No_Identifiers; 6546 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 6547 Analyze_And_Resolve (Arg1x, Standard_Boolean); 6548 6549 if Compile_Time_Known_Value (Arg1x) then 6550 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then 6551 declare 6552 Str : constant String_Id := 6553 Strval (Get_Pragma_Arg (Arg2)); 6554 Len : constant Int := String_Length (Str); 6555 Cont : Boolean; 6556 Ptr : Nat; 6557 CC : Char_Code; 6558 C : Character; 6559 Cent : constant Entity_Id := 6560 Cunit_Entity (Current_Sem_Unit); 6561 6562 Force : constant Boolean := 6563 Prag_Id = Pragma_Compile_Time_Warning 6564 and then 6565 Is_Spec_Name (Unit_Name (Current_Sem_Unit)) 6566 and then (Ekind (Cent) /= E_Package 6567 or else not In_Private_Part (Cent)); 6568 -- Set True if this is the warning case, and we are in the 6569 -- visible part of a package spec, or in a subprogram spec, 6570 -- in which case we want to force the client to see the 6571 -- warning, even though it is not in the main unit. 6572 6573 begin 6574 -- Loop through segments of message separated by line feeds. 6575 -- We output these segments as separate messages with 6576 -- continuation marks for all but the first. 6577 6578 Cont := False; 6579 Ptr := 1; 6580 loop 6581 Error_Msg_Strlen := 0; 6582 6583 -- Loop to copy characters from argument to error message 6584 -- string buffer. 6585 6586 loop 6587 exit when Ptr > Len; 6588 CC := Get_String_Char (Str, Ptr); 6589 Ptr := Ptr + 1; 6590 6591 -- Ignore wide chars ??? else store character 6592 6593 if In_Character_Range (CC) then 6594 C := Get_Character (CC); 6595 exit when C = ASCII.LF; 6596 Error_Msg_Strlen := Error_Msg_Strlen + 1; 6597 Error_Msg_String (Error_Msg_Strlen) := C; 6598 end if; 6599 end loop; 6600 6601 -- Here with one line ready to go 6602 6603 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; 6604 6605 -- If this is a warning in a spec, then we want clients 6606 -- to see the warning, so mark the message with the 6607 -- special sequence !! to force the warning. In the case 6608 -- of a package spec, we do not force this if we are in 6609 -- the private part of the spec. 6610 6611 if Force then 6612 if Cont = False then 6613 Error_Msg_N ("<<~!!", Arg1); 6614 Cont := True; 6615 else 6616 Error_Msg_N ("\<<~!!", Arg1); 6617 end if; 6618 6619 -- Error, rather than warning, or in a body, so we do not 6620 -- need to force visibility for client (error will be 6621 -- output in any case, and this is the situation in which 6622 -- we do not want a client to get a warning, since the 6623 -- warning is in the body or the spec private part). 6624 6625 else 6626 if Cont = False then 6627 Error_Msg_N ("<<~", Arg1); 6628 Cont := True; 6629 else 6630 Error_Msg_N ("\<<~", Arg1); 6631 end if; 6632 end if; 6633 6634 exit when Ptr > Len; 6635 end loop; 6636 end; 6637 end if; 6638 end if; 6639 end Process_Compile_Time_Warning_Or_Error; 6640 6641 ------------------------ 6642 -- Process_Convention -- 6643 ------------------------ 6644 6645 procedure Process_Convention 6646 (C : out Convention_Id; 6647 Ent : out Entity_Id) 6648 is 6649 Cname : Name_Id; 6650 6651 procedure Diagnose_Multiple_Pragmas (S : Entity_Id); 6652 -- Called if we have more than one Export/Import/Convention pragma. 6653 -- This is generally illegal, but we have a special case of allowing 6654 -- Import and Interface to coexist if they specify the convention in 6655 -- a consistent manner. We are allowed to do this, since Interface is 6656 -- an implementation defined pragma, and we choose to do it since we 6657 -- know Rational allows this combination. S is the entity id of the 6658 -- subprogram in question. This procedure also sets the special flag 6659 -- Import_Interface_Present in both pragmas in the case where we do 6660 -- have matching Import and Interface pragmas. 6661 6662 procedure Set_Convention_From_Pragma (E : Entity_Id); 6663 -- Set convention in entity E, and also flag that the entity has a 6664 -- convention pragma. If entity is for a private or incomplete type, 6665 -- also set convention and flag on underlying type. This procedure 6666 -- also deals with the special case of C_Pass_By_Copy convention, 6667 -- and error checks for inappropriate convention specification. 6668 6669 ------------------------------- 6670 -- Diagnose_Multiple_Pragmas -- 6671 ------------------------------- 6672 6673 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is 6674 Pdec : constant Node_Id := Declaration_Node (S); 6675 Decl : Node_Id; 6676 Err : Boolean; 6677 6678 function Same_Convention (Decl : Node_Id) return Boolean; 6679 -- Decl is a pragma node. This function returns True if this 6680 -- pragma has a first argument that is an identifier with a 6681 -- Chars field corresponding to the Convention_Id C. 6682 6683 function Same_Name (Decl : Node_Id) return Boolean; 6684 -- Decl is a pragma node. This function returns True if this 6685 -- pragma has a second argument that is an identifier with a 6686 -- Chars field that matches the Chars of the current subprogram. 6687 6688 --------------------- 6689 -- Same_Convention -- 6690 --------------------- 6691 6692 function Same_Convention (Decl : Node_Id) return Boolean is 6693 Arg1 : constant Node_Id := 6694 First (Pragma_Argument_Associations (Decl)); 6695 6696 begin 6697 if Present (Arg1) then 6698 declare 6699 Arg : constant Node_Id := Get_Pragma_Arg (Arg1); 6700 begin 6701 if Nkind (Arg) = N_Identifier 6702 and then Is_Convention_Name (Chars (Arg)) 6703 and then Get_Convention_Id (Chars (Arg)) = C 6704 then 6705 return True; 6706 end if; 6707 end; 6708 end if; 6709 6710 return False; 6711 end Same_Convention; 6712 6713 --------------- 6714 -- Same_Name -- 6715 --------------- 6716 6717 function Same_Name (Decl : Node_Id) return Boolean is 6718 Arg1 : constant Node_Id := 6719 First (Pragma_Argument_Associations (Decl)); 6720 Arg2 : Node_Id; 6721 6722 begin 6723 if No (Arg1) then 6724 return False; 6725 end if; 6726 6727 Arg2 := Next (Arg1); 6728 6729 if No (Arg2) then 6730 return False; 6731 end if; 6732 6733 declare 6734 Arg : constant Node_Id := Get_Pragma_Arg (Arg2); 6735 begin 6736 if Nkind (Arg) = N_Identifier 6737 and then Chars (Arg) = Chars (S) 6738 then 6739 return True; 6740 end if; 6741 end; 6742 6743 return False; 6744 end Same_Name; 6745 6746 -- Start of processing for Diagnose_Multiple_Pragmas 6747 6748 begin 6749 Err := True; 6750 6751 -- Definitely give message if we have Convention/Export here 6752 6753 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then 6754 null; 6755 6756 -- If we have an Import or Export, scan back from pragma to 6757 -- find any previous pragma applying to the same procedure. 6758 -- The scan will be terminated by the start of the list, or 6759 -- hitting the subprogram declaration. This won't allow one 6760 -- pragma to appear in the public part and one in the private 6761 -- part, but that seems very unlikely in practice. 6762 6763 else 6764 Decl := Prev (N); 6765 while Present (Decl) and then Decl /= Pdec loop 6766 6767 -- Look for pragma with same name as us 6768 6769 if Nkind (Decl) = N_Pragma 6770 and then Same_Name (Decl) 6771 then 6772 -- Give error if same as our pragma or Export/Convention 6773 6774 if Nam_In (Pragma_Name (Decl), Name_Export, 6775 Name_Convention, 6776 Pragma_Name (N)) 6777 then 6778 exit; 6779 6780 -- Case of Import/Interface or the other way round 6781 6782 elsif Nam_In (Pragma_Name (Decl), Name_Interface, 6783 Name_Import) 6784 then 6785 -- Here we know that we have Import and Interface. It 6786 -- doesn't matter which way round they are. See if 6787 -- they specify the same convention. If so, all OK, 6788 -- and set special flags to stop other messages 6789 6790 if Same_Convention (Decl) then 6791 Set_Import_Interface_Present (N); 6792 Set_Import_Interface_Present (Decl); 6793 Err := False; 6794 6795 -- If different conventions, special message 6796 6797 else 6798 Error_Msg_Sloc := Sloc (Decl); 6799 Error_Pragma_Arg 6800 ("convention differs from that given#", Arg1); 6801 return; 6802 end if; 6803 end if; 6804 end if; 6805 6806 Next (Decl); 6807 end loop; 6808 end if; 6809 6810 -- Give message if needed if we fall through those tests 6811 -- except on Relaxed_RM_Semantics where we let go: either this 6812 -- is a case accepted/ignored by other Ada compilers (e.g. 6813 -- a mix of Convention and Import), or another error will be 6814 -- generated later (e.g. using both Import and Export). 6815 6816 if Err and not Relaxed_RM_Semantics then 6817 Error_Pragma_Arg 6818 ("at most one Convention/Export/Import pragma is allowed", 6819 Arg2); 6820 end if; 6821 end Diagnose_Multiple_Pragmas; 6822 6823 -------------------------------- 6824 -- Set_Convention_From_Pragma -- 6825 -------------------------------- 6826 6827 procedure Set_Convention_From_Pragma (E : Entity_Id) is 6828 begin 6829 -- Ada 2005 (AI-430): Check invalid attempt to change convention 6830 -- for an overridden dispatching operation. Technically this is 6831 -- an amendment and should only be done in Ada 2005 mode. However, 6832 -- this is clearly a mistake, since the problem that is addressed 6833 -- by this AI is that there is a clear gap in the RM. 6834 6835 if Is_Dispatching_Operation (E) 6836 and then Present (Overridden_Operation (E)) 6837 and then C /= Convention (Overridden_Operation (E)) 6838 then 6839 Error_Pragma_Arg 6840 ("cannot change convention for overridden dispatching " 6841 & "operation", Arg1); 6842 end if; 6843 6844 -- Special checks for Convention_Stdcall 6845 6846 if C = Convention_Stdcall then 6847 6848 -- A dispatching call is not allowed. A dispatching subprogram 6849 -- cannot be used to interface to the Win32 API, so in fact 6850 -- this check does not impose any effective restriction. 6851 6852 if Is_Dispatching_Operation (E) then 6853 Error_Msg_Sloc := Sloc (E); 6854 6855 -- Note: make this unconditional so that if there is more 6856 -- than one call to which the pragma applies, we get a 6857 -- message for each call. Also don't use Error_Pragma, 6858 -- so that we get multiple messages. 6859 6860 Error_Msg_N 6861 ("dispatching subprogram# cannot use Stdcall convention!", 6862 Arg1); 6863 6864 -- Subprograms are not allowed 6865 6866 elsif not Is_Subprogram_Or_Generic_Subprogram (E) 6867 6868 -- A variable is OK 6869 6870 and then Ekind (E) /= E_Variable 6871 6872 -- An access to subprogram is also allowed 6873 6874 and then not 6875 (Is_Access_Type (E) 6876 and then Ekind (Designated_Type (E)) = E_Subprogram_Type) 6877 6878 -- Allow internal call to set convention of subprogram type 6879 6880 and then not (Ekind (E) = E_Subprogram_Type) 6881 then 6882 Error_Pragma_Arg 6883 ("second argument of pragma% must be subprogram (type)", 6884 Arg2); 6885 end if; 6886 end if; 6887 6888 -- Set the convention 6889 6890 Set_Convention (E, C); 6891 Set_Has_Convention_Pragma (E); 6892 6893 -- For the case of a record base type, also set the convention of 6894 -- any anonymous access types declared in the record which do not 6895 -- currently have a specified convention. 6896 6897 if Is_Record_Type (E) and then Is_Base_Type (E) then 6898 declare 6899 Comp : Node_Id; 6900 6901 begin 6902 Comp := First_Component (E); 6903 while Present (Comp) loop 6904 if Present (Etype (Comp)) 6905 and then Ekind_In (Etype (Comp), 6906 E_Anonymous_Access_Type, 6907 E_Anonymous_Access_Subprogram_Type) 6908 and then not Has_Convention_Pragma (Comp) 6909 then 6910 Set_Convention (Comp, C); 6911 end if; 6912 6913 Next_Component (Comp); 6914 end loop; 6915 end; 6916 end if; 6917 6918 -- Deal with incomplete/private type case, where underlying type 6919 -- is available, so set convention of that underlying type. 6920 6921 if Is_Incomplete_Or_Private_Type (E) 6922 and then Present (Underlying_Type (E)) 6923 then 6924 Set_Convention (Underlying_Type (E), C); 6925 Set_Has_Convention_Pragma (Underlying_Type (E), True); 6926 end if; 6927 6928 -- A class-wide type should inherit the convention of the specific 6929 -- root type (although this isn't specified clearly by the RM). 6930 6931 if Is_Type (E) and then Present (Class_Wide_Type (E)) then 6932 Set_Convention (Class_Wide_Type (E), C); 6933 end if; 6934 6935 -- If the entity is a record type, then check for special case of 6936 -- C_Pass_By_Copy, which is treated the same as C except that the 6937 -- special record flag is set. This convention is only permitted 6938 -- on record types (see AI95-00131). 6939 6940 if Cname = Name_C_Pass_By_Copy then 6941 if Is_Record_Type (E) then 6942 Set_C_Pass_By_Copy (Base_Type (E)); 6943 elsif Is_Incomplete_Or_Private_Type (E) 6944 and then Is_Record_Type (Underlying_Type (E)) 6945 then 6946 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); 6947 else 6948 Error_Pragma_Arg 6949 ("C_Pass_By_Copy convention allowed only for record type", 6950 Arg2); 6951 end if; 6952 end if; 6953 6954 -- If the entity is a derived boolean type, check for the special 6955 -- case of convention C, C++, or Fortran, where we consider any 6956 -- nonzero value to represent true. 6957 6958 if Is_Discrete_Type (E) 6959 and then Root_Type (Etype (E)) = Standard_Boolean 6960 and then 6961 (C = Convention_C 6962 or else 6963 C = Convention_CPP 6964 or else 6965 C = Convention_Fortran) 6966 then 6967 Set_Nonzero_Is_True (Base_Type (E)); 6968 end if; 6969 end Set_Convention_From_Pragma; 6970 6971 -- Local variables 6972 6973 Comp_Unit : Unit_Number_Type; 6974 E : Entity_Id; 6975 E1 : Entity_Id; 6976 Id : Node_Id; 6977 6978 -- Start of processing for Process_Convention 6979 6980 begin 6981 Check_At_Least_N_Arguments (2); 6982 Check_Optional_Identifier (Arg1, Name_Convention); 6983 Check_Arg_Is_Identifier (Arg1); 6984 Cname := Chars (Get_Pragma_Arg (Arg1)); 6985 6986 -- C_Pass_By_Copy is treated as a synonym for convention C (this is 6987 -- tested again below to set the critical flag). 6988 6989 if Cname = Name_C_Pass_By_Copy then 6990 C := Convention_C; 6991 6992 -- Otherwise we must have something in the standard convention list 6993 6994 elsif Is_Convention_Name (Cname) then 6995 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); 6996 6997 -- Otherwise warn on unrecognized convention 6998 6999 else 7000 if Warn_On_Export_Import then 7001 Error_Msg_N 7002 ("??unrecognized convention name, C assumed", 7003 Get_Pragma_Arg (Arg1)); 7004 end if; 7005 7006 C := Convention_C; 7007 end if; 7008 7009 Check_Optional_Identifier (Arg2, Name_Entity); 7010 Check_Arg_Is_Local_Name (Arg2); 7011 7012 Id := Get_Pragma_Arg (Arg2); 7013 Analyze (Id); 7014 7015 if not Is_Entity_Name (Id) then 7016 Error_Pragma_Arg ("entity name required", Arg2); 7017 end if; 7018 7019 E := Entity (Id); 7020 7021 -- Set entity to return 7022 7023 Ent := E; 7024 7025 -- Ada_Pass_By_Copy special checking 7026 7027 if C = Convention_Ada_Pass_By_Copy then 7028 if not Is_First_Subtype (E) then 7029 Error_Pragma_Arg 7030 ("convention `Ada_Pass_By_Copy` only allowed for types", 7031 Arg2); 7032 end if; 7033 7034 if Is_By_Reference_Type (E) then 7035 Error_Pragma_Arg 7036 ("convention `Ada_Pass_By_Copy` not allowed for by-reference " 7037 & "type", Arg1); 7038 end if; 7039 7040 -- Ada_Pass_By_Reference special checking 7041 7042 elsif C = Convention_Ada_Pass_By_Reference then 7043 if not Is_First_Subtype (E) then 7044 Error_Pragma_Arg 7045 ("convention `Ada_Pass_By_Reference` only allowed for types", 7046 Arg2); 7047 end if; 7048 7049 if Is_By_Copy_Type (E) then 7050 Error_Pragma_Arg 7051 ("convention `Ada_Pass_By_Reference` not allowed for by-copy " 7052 & "type", Arg1); 7053 end if; 7054 end if; 7055 7056 -- Go to renamed subprogram if present, since convention applies to 7057 -- the actual renamed entity, not to the renaming entity. If the 7058 -- subprogram is inherited, go to parent subprogram. 7059 7060 if Is_Subprogram (E) 7061 and then Present (Alias (E)) 7062 then 7063 if Nkind (Parent (Declaration_Node (E))) = 7064 N_Subprogram_Renaming_Declaration 7065 then 7066 if Scope (E) /= Scope (Alias (E)) then 7067 Error_Pragma_Ref 7068 ("cannot apply pragma% to non-local entity&#", E); 7069 end if; 7070 7071 E := Alias (E); 7072 7073 elsif Nkind_In (Parent (E), N_Full_Type_Declaration, 7074 N_Private_Extension_Declaration) 7075 and then Scope (E) = Scope (Alias (E)) 7076 then 7077 E := Alias (E); 7078 7079 -- Return the parent subprogram the entity was inherited from 7080 7081 Ent := E; 7082 end if; 7083 end if; 7084 7085 -- Check that we are not applying this to a specless body. Relax this 7086 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers. 7087 7088 if Is_Subprogram (E) 7089 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body 7090 and then not Relaxed_RM_Semantics 7091 then 7092 Error_Pragma 7093 ("pragma% requires separate spec and must come before body"); 7094 end if; 7095 7096 -- Check that we are not applying this to a named constant 7097 7098 if Ekind_In (E, E_Named_Integer, E_Named_Real) then 7099 Error_Msg_Name_1 := Pname; 7100 Error_Msg_N 7101 ("cannot apply pragma% to named constant!", 7102 Get_Pragma_Arg (Arg2)); 7103 Error_Pragma_Arg 7104 ("\supply appropriate type for&!", Arg2); 7105 end if; 7106 7107 if Ekind (E) = E_Enumeration_Literal then 7108 Error_Pragma ("enumeration literal not allowed for pragma%"); 7109 end if; 7110 7111 -- Check for rep item appearing too early or too late 7112 7113 if Etype (E) = Any_Type 7114 or else Rep_Item_Too_Early (E, N) 7115 then 7116 raise Pragma_Exit; 7117 7118 elsif Present (Underlying_Type (E)) then 7119 E := Underlying_Type (E); 7120 end if; 7121 7122 if Rep_Item_Too_Late (E, N) then 7123 raise Pragma_Exit; 7124 end if; 7125 7126 if Has_Convention_Pragma (E) then 7127 Diagnose_Multiple_Pragmas (E); 7128 7129 elsif Convention (E) = Convention_Protected 7130 or else Ekind (Scope (E)) = E_Protected_Type 7131 then 7132 Error_Pragma_Arg 7133 ("a protected operation cannot be given a different convention", 7134 Arg2); 7135 end if; 7136 7137 -- For Intrinsic, a subprogram is required 7138 7139 if C = Convention_Intrinsic 7140 and then not Is_Subprogram_Or_Generic_Subprogram (E) 7141 then 7142 Error_Pragma_Arg 7143 ("second argument of pragma% must be a subprogram", Arg2); 7144 end if; 7145 7146 -- Deal with non-subprogram cases 7147 7148 if not Is_Subprogram_Or_Generic_Subprogram (E) then 7149 Set_Convention_From_Pragma (E); 7150 7151 if Is_Type (E) then 7152 7153 -- The pragma must apply to a first subtype, but it can also 7154 -- apply to a generic type in a generic formal part, in which 7155 -- case it will also appear in the corresponding instance. 7156 7157 if Is_Generic_Type (E) or else In_Instance then 7158 null; 7159 else 7160 Check_First_Subtype (Arg2); 7161 end if; 7162 7163 Set_Convention_From_Pragma (Base_Type (E)); 7164 7165 -- For access subprograms, we must set the convention on the 7166 -- internally generated directly designated type as well. 7167 7168 if Ekind (E) = E_Access_Subprogram_Type then 7169 Set_Convention_From_Pragma (Directly_Designated_Type (E)); 7170 end if; 7171 end if; 7172 7173 -- For the subprogram case, set proper convention for all homonyms 7174 -- in same scope and the same declarative part, i.e. the same 7175 -- compilation unit. 7176 7177 else 7178 Comp_Unit := Get_Source_Unit (E); 7179 Set_Convention_From_Pragma (E); 7180 7181 -- Treat a pragma Import as an implicit body, and pragma import 7182 -- as implicit reference (for navigation in GPS). 7183 7184 if Prag_Id = Pragma_Import then 7185 Generate_Reference (E, Id, 'b'); 7186 7187 -- For exported entities we restrict the generation of references 7188 -- to entities exported to foreign languages since entities 7189 -- exported to Ada do not provide further information to GPS and 7190 -- add undesired references to the output of the gnatxref tool. 7191 7192 elsif Prag_Id = Pragma_Export 7193 and then Convention (E) /= Convention_Ada 7194 then 7195 Generate_Reference (E, Id, 'i'); 7196 end if; 7197 7198 -- If the pragma comes from an aspect, it only applies to the 7199 -- given entity, not its homonyms. 7200 7201 if From_Aspect_Specification (N) then 7202 return; 7203 end if; 7204 7205 -- Otherwise Loop through the homonyms of the pragma argument's 7206 -- entity, an apply convention to those in the current scope. 7207 7208 E1 := Ent; 7209 7210 loop 7211 E1 := Homonym (E1); 7212 exit when No (E1) or else Scope (E1) /= Current_Scope; 7213 7214 -- Ignore entry for which convention is already set 7215 7216 if Has_Convention_Pragma (E1) then 7217 goto Continue; 7218 end if; 7219 7220 -- Do not set the pragma on inherited operations or on formal 7221 -- subprograms. 7222 7223 if Comes_From_Source (E1) 7224 and then Comp_Unit = Get_Source_Unit (E1) 7225 and then not Is_Formal_Subprogram (E1) 7226 and then Nkind (Original_Node (Parent (E1))) /= 7227 N_Full_Type_Declaration 7228 then 7229 if Present (Alias (E1)) 7230 and then Scope (E1) /= Scope (Alias (E1)) 7231 then 7232 Error_Pragma_Ref 7233 ("cannot apply pragma% to non-local entity& declared#", 7234 E1); 7235 end if; 7236 7237 Set_Convention_From_Pragma (E1); 7238 7239 if Prag_Id = Pragma_Import then 7240 Generate_Reference (E1, Id, 'b'); 7241 end if; 7242 end if; 7243 7244 <<Continue>> 7245 null; 7246 end loop; 7247 end if; 7248 end Process_Convention; 7249 7250 ---------------------------------------- 7251 -- Process_Disable_Enable_Atomic_Sync -- 7252 ---------------------------------------- 7253 7254 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is 7255 begin 7256 Check_No_Identifiers; 7257 Check_At_Most_N_Arguments (1); 7258 7259 -- Modeled internally as 7260 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity]) 7261 7262 Rewrite (N, 7263 Make_Pragma (Loc, 7264 Pragma_Identifier => 7265 Make_Identifier (Loc, Nam), 7266 Pragma_Argument_Associations => New_List ( 7267 Make_Pragma_Argument_Association (Loc, 7268 Expression => 7269 Make_Identifier (Loc, Name_Atomic_Synchronization))))); 7270 7271 if Present (Arg1) then 7272 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); 7273 end if; 7274 7275 Analyze (N); 7276 end Process_Disable_Enable_Atomic_Sync; 7277 7278 ------------------------------------------------- 7279 -- Process_Extended_Import_Export_Internal_Arg -- 7280 ------------------------------------------------- 7281 7282 procedure Process_Extended_Import_Export_Internal_Arg 7283 (Arg_Internal : Node_Id := Empty) 7284 is 7285 begin 7286 if No (Arg_Internal) then 7287 Error_Pragma ("Internal parameter required for pragma%"); 7288 end if; 7289 7290 if Nkind (Arg_Internal) = N_Identifier then 7291 null; 7292 7293 elsif Nkind (Arg_Internal) = N_Operator_Symbol 7294 and then (Prag_Id = Pragma_Import_Function 7295 or else 7296 Prag_Id = Pragma_Export_Function) 7297 then 7298 null; 7299 7300 else 7301 Error_Pragma_Arg 7302 ("wrong form for Internal parameter for pragma%", Arg_Internal); 7303 end if; 7304 7305 Check_Arg_Is_Local_Name (Arg_Internal); 7306 end Process_Extended_Import_Export_Internal_Arg; 7307 7308 -------------------------------------------------- 7309 -- Process_Extended_Import_Export_Object_Pragma -- 7310 -------------------------------------------------- 7311 7312 procedure Process_Extended_Import_Export_Object_Pragma 7313 (Arg_Internal : Node_Id; 7314 Arg_External : Node_Id; 7315 Arg_Size : Node_Id) 7316 is 7317 Def_Id : Entity_Id; 7318 7319 begin 7320 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 7321 Def_Id := Entity (Arg_Internal); 7322 7323 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 7324 Error_Pragma_Arg 7325 ("pragma% must designate an object", Arg_Internal); 7326 end if; 7327 7328 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 7329 or else 7330 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 7331 then 7332 Error_Pragma_Arg 7333 ("previous Common/Psect_Object applies, pragma % not permitted", 7334 Arg_Internal); 7335 end if; 7336 7337 if Rep_Item_Too_Late (Def_Id, N) then 7338 raise Pragma_Exit; 7339 end if; 7340 7341 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 7342 7343 if Present (Arg_Size) then 7344 Check_Arg_Is_External_Name (Arg_Size); 7345 end if; 7346 7347 -- Export_Object case 7348 7349 if Prag_Id = Pragma_Export_Object then 7350 if not Is_Library_Level_Entity (Def_Id) then 7351 Error_Pragma_Arg 7352 ("argument for pragma% must be library level entity", 7353 Arg_Internal); 7354 end if; 7355 7356 if Ekind (Current_Scope) = E_Generic_Package then 7357 Error_Pragma ("pragma& cannot appear in a generic unit"); 7358 end if; 7359 7360 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then 7361 Error_Pragma_Arg 7362 ("exported object must have compile time known size", 7363 Arg_Internal); 7364 end if; 7365 7366 if Warn_On_Export_Import and then Is_Exported (Def_Id) then 7367 Error_Msg_N ("??duplicate Export_Object pragma", N); 7368 else 7369 Set_Exported (Def_Id, Arg_Internal); 7370 end if; 7371 7372 -- Import_Object case 7373 7374 else 7375 if Is_Concurrent_Type (Etype (Def_Id)) then 7376 Error_Pragma_Arg 7377 ("cannot use pragma% for task/protected object", 7378 Arg_Internal); 7379 end if; 7380 7381 if Ekind (Def_Id) = E_Constant then 7382 Error_Pragma_Arg 7383 ("cannot import a constant", Arg_Internal); 7384 end if; 7385 7386 if Warn_On_Export_Import 7387 and then Has_Discriminants (Etype (Def_Id)) 7388 then 7389 Error_Msg_N 7390 ("imported value must be initialized??", Arg_Internal); 7391 end if; 7392 7393 if Warn_On_Export_Import 7394 and then Is_Access_Type (Etype (Def_Id)) 7395 then 7396 Error_Pragma_Arg 7397 ("cannot import object of an access type??", Arg_Internal); 7398 end if; 7399 7400 if Warn_On_Export_Import 7401 and then Is_Imported (Def_Id) 7402 then 7403 Error_Msg_N ("??duplicate Import_Object pragma", N); 7404 7405 -- Check for explicit initialization present. Note that an 7406 -- initialization generated by the code generator, e.g. for an 7407 -- access type, does not count here. 7408 7409 elsif Present (Expression (Parent (Def_Id))) 7410 and then 7411 Comes_From_Source 7412 (Original_Node (Expression (Parent (Def_Id)))) 7413 then 7414 Error_Msg_Sloc := Sloc (Def_Id); 7415 Error_Pragma_Arg 7416 ("imported entities cannot be initialized (RM B.1(24))", 7417 "\no initialization allowed for & declared#", Arg1); 7418 else 7419 Set_Imported (Def_Id); 7420 Note_Possible_Modification (Arg_Internal, Sure => False); 7421 end if; 7422 end if; 7423 end Process_Extended_Import_Export_Object_Pragma; 7424 7425 ------------------------------------------------------ 7426 -- Process_Extended_Import_Export_Subprogram_Pragma -- 7427 ------------------------------------------------------ 7428 7429 procedure Process_Extended_Import_Export_Subprogram_Pragma 7430 (Arg_Internal : Node_Id; 7431 Arg_External : Node_Id; 7432 Arg_Parameter_Types : Node_Id; 7433 Arg_Result_Type : Node_Id := Empty; 7434 Arg_Mechanism : Node_Id; 7435 Arg_Result_Mechanism : Node_Id := Empty) 7436 is 7437 Ent : Entity_Id; 7438 Def_Id : Entity_Id; 7439 Hom_Id : Entity_Id; 7440 Formal : Entity_Id; 7441 Ambiguous : Boolean; 7442 Match : Boolean; 7443 7444 function Same_Base_Type 7445 (Ptype : Node_Id; 7446 Formal : Entity_Id) return Boolean; 7447 -- Determines if Ptype references the type of Formal. Note that only 7448 -- the base types need to match according to the spec. Ptype here is 7449 -- the argument from the pragma, which is either a type name, or an 7450 -- access attribute. 7451 7452 -------------------- 7453 -- Same_Base_Type -- 7454 -------------------- 7455 7456 function Same_Base_Type 7457 (Ptype : Node_Id; 7458 Formal : Entity_Id) return Boolean 7459 is 7460 Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); 7461 Pref : Node_Id; 7462 7463 begin 7464 -- Case where pragma argument is typ'Access 7465 7466 if Nkind (Ptype) = N_Attribute_Reference 7467 and then Attribute_Name (Ptype) = Name_Access 7468 then 7469 Pref := Prefix (Ptype); 7470 Find_Type (Pref); 7471 7472 if not Is_Entity_Name (Pref) 7473 or else Entity (Pref) = Any_Type 7474 then 7475 raise Pragma_Exit; 7476 end if; 7477 7478 -- We have a match if the corresponding argument is of an 7479 -- anonymous access type, and its designated type matches the 7480 -- type of the prefix of the access attribute 7481 7482 return Ekind (Ftyp) = E_Anonymous_Access_Type 7483 and then Base_Type (Entity (Pref)) = 7484 Base_Type (Etype (Designated_Type (Ftyp))); 7485 7486 -- Case where pragma argument is a type name 7487 7488 else 7489 Find_Type (Ptype); 7490 7491 if not Is_Entity_Name (Ptype) 7492 or else Entity (Ptype) = Any_Type 7493 then 7494 raise Pragma_Exit; 7495 end if; 7496 7497 -- We have a match if the corresponding argument is of the type 7498 -- given in the pragma (comparing base types) 7499 7500 return Base_Type (Entity (Ptype)) = Ftyp; 7501 end if; 7502 end Same_Base_Type; 7503 7504 -- Start of processing for 7505 -- Process_Extended_Import_Export_Subprogram_Pragma 7506 7507 begin 7508 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 7509 Ent := Empty; 7510 Ambiguous := False; 7511 7512 -- Loop through homonyms (overloadings) of the entity 7513 7514 Hom_Id := Entity (Arg_Internal); 7515 while Present (Hom_Id) loop 7516 Def_Id := Get_Base_Subprogram (Hom_Id); 7517 7518 -- We need a subprogram in the current scope 7519 7520 if not Is_Subprogram (Def_Id) 7521 or else Scope (Def_Id) /= Current_Scope 7522 then 7523 null; 7524 7525 else 7526 Match := True; 7527 7528 -- Pragma cannot apply to subprogram body 7529 7530 if Is_Subprogram (Def_Id) 7531 and then Nkind (Parent (Declaration_Node (Def_Id))) = 7532 N_Subprogram_Body 7533 then 7534 Error_Pragma 7535 ("pragma% requires separate spec" 7536 & " and must come before body"); 7537 end if; 7538 7539 -- Test result type if given, note that the result type 7540 -- parameter can only be present for the function cases. 7541 7542 if Present (Arg_Result_Type) 7543 and then not Same_Base_Type (Arg_Result_Type, Def_Id) 7544 then 7545 Match := False; 7546 7547 elsif Etype (Def_Id) /= Standard_Void_Type 7548 and then 7549 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure) 7550 then 7551 Match := False; 7552 7553 -- Test parameter types if given. Note that this parameter 7554 -- has not been analyzed (and must not be, since it is 7555 -- semantic nonsense), so we get it as the parser left it. 7556 7557 elsif Present (Arg_Parameter_Types) then 7558 Check_Matching_Types : declare 7559 Formal : Entity_Id; 7560 Ptype : Node_Id; 7561 7562 begin 7563 Formal := First_Formal (Def_Id); 7564 7565 if Nkind (Arg_Parameter_Types) = N_Null then 7566 if Present (Formal) then 7567 Match := False; 7568 end if; 7569 7570 -- A list of one type, e.g. (List) is parsed as 7571 -- a parenthesized expression. 7572 7573 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate 7574 and then Paren_Count (Arg_Parameter_Types) = 1 7575 then 7576 if No (Formal) 7577 or else Present (Next_Formal (Formal)) 7578 then 7579 Match := False; 7580 else 7581 Match := 7582 Same_Base_Type (Arg_Parameter_Types, Formal); 7583 end if; 7584 7585 -- A list of more than one type is parsed as a aggregate 7586 7587 elsif Nkind (Arg_Parameter_Types) = N_Aggregate 7588 and then Paren_Count (Arg_Parameter_Types) = 0 7589 then 7590 Ptype := First (Expressions (Arg_Parameter_Types)); 7591 while Present (Ptype) or else Present (Formal) loop 7592 if No (Ptype) 7593 or else No (Formal) 7594 or else not Same_Base_Type (Ptype, Formal) 7595 then 7596 Match := False; 7597 exit; 7598 else 7599 Next_Formal (Formal); 7600 Next (Ptype); 7601 end if; 7602 end loop; 7603 7604 -- Anything else is of the wrong form 7605 7606 else 7607 Error_Pragma_Arg 7608 ("wrong form for Parameter_Types parameter", 7609 Arg_Parameter_Types); 7610 end if; 7611 end Check_Matching_Types; 7612 end if; 7613 7614 -- Match is now False if the entry we found did not match 7615 -- either a supplied Parameter_Types or Result_Types argument 7616 7617 if Match then 7618 if No (Ent) then 7619 Ent := Def_Id; 7620 7621 -- Ambiguous case, the flag Ambiguous shows if we already 7622 -- detected this and output the initial messages. 7623 7624 else 7625 if not Ambiguous then 7626 Ambiguous := True; 7627 Error_Msg_Name_1 := Pname; 7628 Error_Msg_N 7629 ("pragma% does not uniquely identify subprogram!", 7630 N); 7631 Error_Msg_Sloc := Sloc (Ent); 7632 Error_Msg_N ("matching subprogram #!", N); 7633 Ent := Empty; 7634 end if; 7635 7636 Error_Msg_Sloc := Sloc (Def_Id); 7637 Error_Msg_N ("matching subprogram #!", N); 7638 end if; 7639 end if; 7640 end if; 7641 7642 Hom_Id := Homonym (Hom_Id); 7643 end loop; 7644 7645 -- See if we found an entry 7646 7647 if No (Ent) then 7648 if not Ambiguous then 7649 if Is_Generic_Subprogram (Entity (Arg_Internal)) then 7650 Error_Pragma 7651 ("pragma% cannot be given for generic subprogram"); 7652 else 7653 Error_Pragma 7654 ("pragma% does not identify local subprogram"); 7655 end if; 7656 end if; 7657 7658 return; 7659 end if; 7660 7661 -- Import pragmas must be for imported entities 7662 7663 if Prag_Id = Pragma_Import_Function 7664 or else 7665 Prag_Id = Pragma_Import_Procedure 7666 or else 7667 Prag_Id = Pragma_Import_Valued_Procedure 7668 then 7669 if not Is_Imported (Ent) then 7670 Error_Pragma 7671 ("pragma Import or Interface must precede pragma%"); 7672 end if; 7673 7674 -- Here we have the Export case which can set the entity as exported 7675 7676 -- But does not do so if the specified external name is null, since 7677 -- that is taken as a signal in DEC Ada 83 (with which we want to be 7678 -- compatible) to request no external name. 7679 7680 elsif Nkind (Arg_External) = N_String_Literal 7681 and then String_Length (Strval (Arg_External)) = 0 7682 then 7683 null; 7684 7685 -- In all other cases, set entity as exported 7686 7687 else 7688 Set_Exported (Ent, Arg_Internal); 7689 end if; 7690 7691 -- Special processing for Valued_Procedure cases 7692 7693 if Prag_Id = Pragma_Import_Valued_Procedure 7694 or else 7695 Prag_Id = Pragma_Export_Valued_Procedure 7696 then 7697 Formal := First_Formal (Ent); 7698 7699 if No (Formal) then 7700 Error_Pragma ("at least one parameter required for pragma%"); 7701 7702 elsif Ekind (Formal) /= E_Out_Parameter then 7703 Error_Pragma ("first parameter must have mode out for pragma%"); 7704 7705 else 7706 Set_Is_Valued_Procedure (Ent); 7707 end if; 7708 end if; 7709 7710 Set_Extended_Import_Export_External_Name (Ent, Arg_External); 7711 7712 -- Process Result_Mechanism argument if present. We have already 7713 -- checked that this is only allowed for the function case. 7714 7715 if Present (Arg_Result_Mechanism) then 7716 Set_Mechanism_Value (Ent, Arg_Result_Mechanism); 7717 end if; 7718 7719 -- Process Mechanism parameter if present. Note that this parameter 7720 -- is not analyzed, and must not be analyzed since it is semantic 7721 -- nonsense, so we get it in exactly as the parser left it. 7722 7723 if Present (Arg_Mechanism) then 7724 declare 7725 Formal : Entity_Id; 7726 Massoc : Node_Id; 7727 Mname : Node_Id; 7728 Choice : Node_Id; 7729 7730 begin 7731 -- A single mechanism association without a formal parameter 7732 -- name is parsed as a parenthesized expression. All other 7733 -- cases are parsed as aggregates, so we rewrite the single 7734 -- parameter case as an aggregate for consistency. 7735 7736 if Nkind (Arg_Mechanism) /= N_Aggregate 7737 and then Paren_Count (Arg_Mechanism) = 1 7738 then 7739 Rewrite (Arg_Mechanism, 7740 Make_Aggregate (Sloc (Arg_Mechanism), 7741 Expressions => New_List ( 7742 Relocate_Node (Arg_Mechanism)))); 7743 end if; 7744 7745 -- Case of only mechanism name given, applies to all formals 7746 7747 if Nkind (Arg_Mechanism) /= N_Aggregate then 7748 Formal := First_Formal (Ent); 7749 while Present (Formal) loop 7750 Set_Mechanism_Value (Formal, Arg_Mechanism); 7751 Next_Formal (Formal); 7752 end loop; 7753 7754 -- Case of list of mechanism associations given 7755 7756 else 7757 if Null_Record_Present (Arg_Mechanism) then 7758 Error_Pragma_Arg 7759 ("inappropriate form for Mechanism parameter", 7760 Arg_Mechanism); 7761 end if; 7762 7763 -- Deal with positional ones first 7764 7765 Formal := First_Formal (Ent); 7766 7767 if Present (Expressions (Arg_Mechanism)) then 7768 Mname := First (Expressions (Arg_Mechanism)); 7769 while Present (Mname) loop 7770 if No (Formal) then 7771 Error_Pragma_Arg 7772 ("too many mechanism associations", Mname); 7773 end if; 7774 7775 Set_Mechanism_Value (Formal, Mname); 7776 Next_Formal (Formal); 7777 Next (Mname); 7778 end loop; 7779 end if; 7780 7781 -- Deal with named entries 7782 7783 if Present (Component_Associations (Arg_Mechanism)) then 7784 Massoc := First (Component_Associations (Arg_Mechanism)); 7785 while Present (Massoc) loop 7786 Choice := First (Choices (Massoc)); 7787 7788 if Nkind (Choice) /= N_Identifier 7789 or else Present (Next (Choice)) 7790 then 7791 Error_Pragma_Arg 7792 ("incorrect form for mechanism association", 7793 Massoc); 7794 end if; 7795 7796 Formal := First_Formal (Ent); 7797 loop 7798 if No (Formal) then 7799 Error_Pragma_Arg 7800 ("parameter name & not present", Choice); 7801 end if; 7802 7803 if Chars (Choice) = Chars (Formal) then 7804 Set_Mechanism_Value 7805 (Formal, Expression (Massoc)); 7806 7807 -- Set entity on identifier (needed by ASIS) 7808 7809 Set_Entity (Choice, Formal); 7810 7811 exit; 7812 end if; 7813 7814 Next_Formal (Formal); 7815 end loop; 7816 7817 Next (Massoc); 7818 end loop; 7819 end if; 7820 end if; 7821 end; 7822 end if; 7823 end Process_Extended_Import_Export_Subprogram_Pragma; 7824 7825 -------------------------- 7826 -- Process_Generic_List -- 7827 -------------------------- 7828 7829 procedure Process_Generic_List is 7830 Arg : Node_Id; 7831 Exp : Node_Id; 7832 7833 begin 7834 Check_No_Identifiers; 7835 Check_At_Least_N_Arguments (1); 7836 7837 -- Check all arguments are names of generic units or instances 7838 7839 Arg := Arg1; 7840 while Present (Arg) loop 7841 Exp := Get_Pragma_Arg (Arg); 7842 Analyze (Exp); 7843 7844 if not Is_Entity_Name (Exp) 7845 or else 7846 (not Is_Generic_Instance (Entity (Exp)) 7847 and then 7848 not Is_Generic_Unit (Entity (Exp))) 7849 then 7850 Error_Pragma_Arg 7851 ("pragma% argument must be name of generic unit/instance", 7852 Arg); 7853 end if; 7854 7855 Next (Arg); 7856 end loop; 7857 end Process_Generic_List; 7858 7859 ------------------------------------ 7860 -- Process_Import_Predefined_Type -- 7861 ------------------------------------ 7862 7863 procedure Process_Import_Predefined_Type is 7864 Loc : constant Source_Ptr := Sloc (N); 7865 Elmt : Elmt_Id; 7866 Ftyp : Node_Id := Empty; 7867 Decl : Node_Id; 7868 Def : Node_Id; 7869 Nam : Name_Id; 7870 7871 begin 7872 String_To_Name_Buffer (Strval (Expression (Arg3))); 7873 Nam := Name_Find; 7874 7875 Elmt := First_Elmt (Predefined_Float_Types); 7876 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop 7877 Next_Elmt (Elmt); 7878 end loop; 7879 7880 Ftyp := Node (Elmt); 7881 7882 if Present (Ftyp) then 7883 7884 -- Don't build a derived type declaration, because predefined C 7885 -- types have no declaration anywhere, so cannot really be named. 7886 -- Instead build a full type declaration, starting with an 7887 -- appropriate type definition is built 7888 7889 if Is_Floating_Point_Type (Ftyp) then 7890 Def := Make_Floating_Point_Definition (Loc, 7891 Make_Integer_Literal (Loc, Digits_Value (Ftyp)), 7892 Make_Real_Range_Specification (Loc, 7893 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))), 7894 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp))))); 7895 7896 -- Should never have a predefined type we cannot handle 7897 7898 else 7899 raise Program_Error; 7900 end if; 7901 7902 -- Build and insert a Full_Type_Declaration, which will be 7903 -- analyzed as soon as this list entry has been analyzed. 7904 7905 Decl := Make_Full_Type_Declaration (Loc, 7906 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))), 7907 Type_Definition => Def); 7908 7909 Insert_After (N, Decl); 7910 Mark_Rewrite_Insertion (Decl); 7911 7912 else 7913 Error_Pragma_Arg ("no matching type found for pragma%", 7914 Arg2); 7915 end if; 7916 end Process_Import_Predefined_Type; 7917 7918 --------------------------------- 7919 -- Process_Import_Or_Interface -- 7920 --------------------------------- 7921 7922 procedure Process_Import_Or_Interface is 7923 C : Convention_Id; 7924 Def_Id : Entity_Id; 7925 Hom_Id : Entity_Id; 7926 7927 begin 7928 -- In Relaxed_RM_Semantics, support old Ada 83 style: 7929 -- pragma Import (Entity, "external name"); 7930 7931 if Relaxed_RM_Semantics 7932 and then Arg_Count = 2 7933 and then Prag_Id = Pragma_Import 7934 and then Nkind (Expression (Arg2)) = N_String_Literal 7935 then 7936 C := Convention_C; 7937 Def_Id := Get_Pragma_Arg (Arg1); 7938 Analyze (Def_Id); 7939 7940 if not Is_Entity_Name (Def_Id) then 7941 Error_Pragma_Arg ("entity name required", Arg1); 7942 end if; 7943 7944 Def_Id := Entity (Def_Id); 7945 Kill_Size_Check_Code (Def_Id); 7946 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False); 7947 7948 else 7949 Process_Convention (C, Def_Id); 7950 7951 -- A pragma that applies to a Ghost entity becomes Ghost for the 7952 -- purposes of legality checks and removal of ignored Ghost code. 7953 7954 Mark_Pragma_As_Ghost (N, Def_Id); 7955 Kill_Size_Check_Code (Def_Id); 7956 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); 7957 end if; 7958 7959 -- Various error checks 7960 7961 if Ekind_In (Def_Id, E_Variable, E_Constant) then 7962 7963 -- We do not permit Import to apply to a renaming declaration 7964 7965 if Present (Renamed_Object (Def_Id)) then 7966 Error_Pragma_Arg 7967 ("pragma% not allowed for object renaming", Arg2); 7968 7969 -- User initialization is not allowed for imported object, but 7970 -- the object declaration may contain a default initialization, 7971 -- that will be discarded. Note that an explicit initialization 7972 -- only counts if it comes from source, otherwise it is simply 7973 -- the code generator making an implicit initialization explicit. 7974 7975 elsif Present (Expression (Parent (Def_Id))) 7976 and then Comes_From_Source 7977 (Original_Node (Expression (Parent (Def_Id)))) 7978 then 7979 -- Set imported flag to prevent cascaded errors 7980 7981 Set_Is_Imported (Def_Id); 7982 7983 Error_Msg_Sloc := Sloc (Def_Id); 7984 Error_Pragma_Arg 7985 ("no initialization allowed for declaration of& #", 7986 "\imported entities cannot be initialized (RM B.1(24))", 7987 Arg2); 7988 7989 else 7990 -- If the pragma comes from an aspect specification the 7991 -- Is_Imported flag has already been set. 7992 7993 if not From_Aspect_Specification (N) then 7994 Set_Imported (Def_Id); 7995 end if; 7996 7997 Process_Interface_Name (Def_Id, Arg3, Arg4); 7998 7999 -- Note that we do not set Is_Public here. That's because we 8000 -- only want to set it if there is no address clause, and we 8001 -- don't know that yet, so we delay that processing till 8002 -- freeze time. 8003 8004 -- pragma Import completes deferred constants 8005 8006 if Ekind (Def_Id) = E_Constant then 8007 Set_Has_Completion (Def_Id); 8008 end if; 8009 8010 -- It is not possible to import a constant of an unconstrained 8011 -- array type (e.g. string) because there is no simple way to 8012 -- write a meaningful subtype for it. 8013 8014 if Is_Array_Type (Etype (Def_Id)) 8015 and then not Is_Constrained (Etype (Def_Id)) 8016 then 8017 Error_Msg_NE 8018 ("imported constant& must have a constrained subtype", 8019 N, Def_Id); 8020 end if; 8021 end if; 8022 8023 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then 8024 8025 -- If the name is overloaded, pragma applies to all of the denoted 8026 -- entities in the same declarative part, unless the pragma comes 8027 -- from an aspect specification or was generated by the compiler 8028 -- (such as for pragma Provide_Shift_Operators). 8029 8030 Hom_Id := Def_Id; 8031 while Present (Hom_Id) loop 8032 8033 Def_Id := Get_Base_Subprogram (Hom_Id); 8034 8035 -- Ignore inherited subprograms because the pragma will apply 8036 -- to the parent operation, which is the one called. 8037 8038 if Is_Overloadable (Def_Id) 8039 and then Present (Alias (Def_Id)) 8040 then 8041 null; 8042 8043 -- If it is not a subprogram, it must be in an outer scope and 8044 -- pragma does not apply. 8045 8046 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then 8047 null; 8048 8049 -- The pragma does not apply to primitives of interfaces 8050 8051 elsif Is_Dispatching_Operation (Def_Id) 8052 and then Present (Find_Dispatching_Type (Def_Id)) 8053 and then Is_Interface (Find_Dispatching_Type (Def_Id)) 8054 then 8055 null; 8056 8057 -- Verify that the homonym is in the same declarative part (not 8058 -- just the same scope). If the pragma comes from an aspect 8059 -- specification we know that it is part of the declaration. 8060 8061 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) 8062 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux 8063 and then not From_Aspect_Specification (N) 8064 then 8065 exit; 8066 8067 else 8068 -- If the pragma comes from an aspect specification the 8069 -- Is_Imported flag has already been set. 8070 8071 if not From_Aspect_Specification (N) then 8072 Set_Imported (Def_Id); 8073 end if; 8074 8075 -- Reject an Import applied to an abstract subprogram 8076 8077 if Is_Subprogram (Def_Id) 8078 and then Is_Abstract_Subprogram (Def_Id) 8079 then 8080 Error_Msg_Sloc := Sloc (Def_Id); 8081 Error_Msg_NE 8082 ("cannot import abstract subprogram& declared#", 8083 Arg2, Def_Id); 8084 end if; 8085 8086 -- Special processing for Convention_Intrinsic 8087 8088 if C = Convention_Intrinsic then 8089 8090 -- Link_Name argument not allowed for intrinsic 8091 8092 Check_No_Link_Name; 8093 8094 Set_Is_Intrinsic_Subprogram (Def_Id); 8095 8096 -- If no external name is present, then check that this 8097 -- is a valid intrinsic subprogram. If an external name 8098 -- is present, then this is handled by the back end. 8099 8100 if No (Arg3) then 8101 Check_Intrinsic_Subprogram 8102 (Def_Id, Get_Pragma_Arg (Arg2)); 8103 end if; 8104 end if; 8105 8106 -- Verify that the subprogram does not have a completion 8107 -- through a renaming declaration. For other completions the 8108 -- pragma appears as a too late representation. 8109 8110 declare 8111 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); 8112 8113 begin 8114 if Present (Decl) 8115 and then Nkind (Decl) = N_Subprogram_Declaration 8116 and then Present (Corresponding_Body (Decl)) 8117 and then Nkind (Unit_Declaration_Node 8118 (Corresponding_Body (Decl))) = 8119 N_Subprogram_Renaming_Declaration 8120 then 8121 Error_Msg_Sloc := Sloc (Def_Id); 8122 Error_Msg_NE 8123 ("cannot import&, renaming already provided for " 8124 & "declaration #", N, Def_Id); 8125 end if; 8126 end; 8127 8128 -- If the pragma comes from an aspect specification, there 8129 -- must be an Import aspect specified as well. In the rare 8130 -- case where Import is set to False, the suprogram needs to 8131 -- have a local completion. 8132 8133 declare 8134 Imp_Aspect : constant Node_Id := 8135 Find_Aspect (Def_Id, Aspect_Import); 8136 Expr : Node_Id; 8137 8138 begin 8139 if Present (Imp_Aspect) 8140 and then Present (Expression (Imp_Aspect)) 8141 then 8142 Expr := Expression (Imp_Aspect); 8143 Analyze_And_Resolve (Expr, Standard_Boolean); 8144 8145 if Is_Entity_Name (Expr) 8146 and then Entity (Expr) = Standard_True 8147 then 8148 Set_Has_Completion (Def_Id); 8149 end if; 8150 8151 -- If there is no expression, the default is True, as for 8152 -- all boolean aspects. Same for the older pragma. 8153 8154 else 8155 Set_Has_Completion (Def_Id); 8156 end if; 8157 end; 8158 8159 Process_Interface_Name (Def_Id, Arg3, Arg4); 8160 end if; 8161 8162 if Is_Compilation_Unit (Hom_Id) then 8163 8164 -- Its possible homonyms are not affected by the pragma. 8165 -- Such homonyms might be present in the context of other 8166 -- units being compiled. 8167 8168 exit; 8169 8170 elsif From_Aspect_Specification (N) then 8171 exit; 8172 8173 -- If the pragma was created by the compiler, then we don't 8174 -- want it to apply to other homonyms. This kind of case can 8175 -- occur when using pragma Provide_Shift_Operators, which 8176 -- generates implicit shift and rotate operators with Import 8177 -- pragmas that might apply to earlier explicit or implicit 8178 -- declarations marked with Import (for example, coming from 8179 -- an earlier pragma Provide_Shift_Operators for another type), 8180 -- and we don't generally want other homonyms being treated 8181 -- as imported or the pragma flagged as an illegal duplicate. 8182 8183 elsif not Comes_From_Source (N) then 8184 exit; 8185 8186 else 8187 Hom_Id := Homonym (Hom_Id); 8188 end if; 8189 end loop; 8190 8191 -- Import a CPP class 8192 8193 elsif C = Convention_CPP 8194 and then (Is_Record_Type (Def_Id) 8195 or else Ekind (Def_Id) = E_Incomplete_Type) 8196 then 8197 if Ekind (Def_Id) = E_Incomplete_Type then 8198 if Present (Full_View (Def_Id)) then 8199 Def_Id := Full_View (Def_Id); 8200 8201 else 8202 Error_Msg_N 8203 ("cannot import 'C'P'P type before full declaration seen", 8204 Get_Pragma_Arg (Arg2)); 8205 8206 -- Although we have reported the error we decorate it as 8207 -- CPP_Class to avoid reporting spurious errors 8208 8209 Set_Is_CPP_Class (Def_Id); 8210 return; 8211 end if; 8212 end if; 8213 8214 -- Types treated as CPP classes must be declared limited (note: 8215 -- this used to be a warning but there is no real benefit to it 8216 -- since we did effectively intend to treat the type as limited 8217 -- anyway). 8218 8219 if not Is_Limited_Type (Def_Id) then 8220 Error_Msg_N 8221 ("imported 'C'P'P type must be limited", 8222 Get_Pragma_Arg (Arg2)); 8223 end if; 8224 8225 if Etype (Def_Id) /= Def_Id 8226 and then not Is_CPP_Class (Root_Type (Def_Id)) 8227 then 8228 Error_Msg_N ("root type must be a 'C'P'P type", Arg1); 8229 end if; 8230 8231 Set_Is_CPP_Class (Def_Id); 8232 8233 -- Imported CPP types must not have discriminants (because C++ 8234 -- classes do not have discriminants). 8235 8236 if Has_Discriminants (Def_Id) then 8237 Error_Msg_N 8238 ("imported 'C'P'P type cannot have discriminants", 8239 First (Discriminant_Specifications 8240 (Declaration_Node (Def_Id)))); 8241 end if; 8242 8243 -- Check that components of imported CPP types do not have default 8244 -- expressions. For private types this check is performed when the 8245 -- full view is analyzed (see Process_Full_View). 8246 8247 if not Is_Private_Type (Def_Id) then 8248 Check_CPP_Type_Has_No_Defaults (Def_Id); 8249 end if; 8250 8251 -- Import a CPP exception 8252 8253 elsif C = Convention_CPP 8254 and then Ekind (Def_Id) = E_Exception 8255 then 8256 if No (Arg3) then 8257 Error_Pragma_Arg 8258 ("'External_'Name arguments is required for 'Cpp exception", 8259 Arg3); 8260 else 8261 -- As only a string is allowed, Check_Arg_Is_External_Name 8262 -- isn't called. 8263 8264 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 8265 end if; 8266 8267 if Present (Arg4) then 8268 Error_Pragma_Arg 8269 ("Link_Name argument not allowed for imported Cpp exception", 8270 Arg4); 8271 end if; 8272 8273 -- Do not call Set_Interface_Name as the name of the exception 8274 -- shouldn't be modified (and in particular it shouldn't be 8275 -- the External_Name). For exceptions, the External_Name is the 8276 -- name of the RTTI structure. 8277 8278 -- ??? Emit an error if pragma Import/Export_Exception is present 8279 8280 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then 8281 Check_No_Link_Name; 8282 Check_Arg_Count (3); 8283 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 8284 8285 Process_Import_Predefined_Type; 8286 8287 else 8288 Error_Pragma_Arg 8289 ("second argument of pragma% must be object, subprogram " 8290 & "or incomplete type", 8291 Arg2); 8292 end if; 8293 8294 -- If this pragma applies to a compilation unit, then the unit, which 8295 -- is a subprogram, does not require (or allow) a body. We also do 8296 -- not need to elaborate imported procedures. 8297 8298 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 8299 declare 8300 Cunit : constant Node_Id := Parent (Parent (N)); 8301 begin 8302 Set_Body_Required (Cunit, False); 8303 end; 8304 end if; 8305 end Process_Import_Or_Interface; 8306 8307 -------------------- 8308 -- Process_Inline -- 8309 -------------------- 8310 8311 procedure Process_Inline (Status : Inline_Status) is 8312 Applies : Boolean; 8313 Assoc : Node_Id; 8314 Decl : Node_Id; 8315 Subp : Entity_Id; 8316 Subp_Id : Node_Id; 8317 8318 Ghost_Error_Posted : Boolean := False; 8319 -- Flag set when an error concerning the illegal mix of Ghost and 8320 -- non-Ghost subprograms is emitted. 8321 8322 Ghost_Id : Entity_Id := Empty; 8323 -- The entity of the first Ghost subprogram encountered while 8324 -- processing the arguments of the pragma. 8325 8326 procedure Make_Inline (Subp : Entity_Id); 8327 -- Subp is the defining unit name of the subprogram declaration. Set 8328 -- the flag, as well as the flag in the corresponding body, if there 8329 -- is one present. 8330 8331 procedure Set_Inline_Flags (Subp : Entity_Id); 8332 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also 8333 -- Has_Pragma_Inline_Always for the Inline_Always case. 8334 8335 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; 8336 -- Returns True if it can be determined at this stage that inlining 8337 -- is not possible, for example if the body is available and contains 8338 -- exception handlers, we prevent inlining, since otherwise we can 8339 -- get undefined symbols at link time. This function also emits a 8340 -- warning if front-end inlining is enabled and the pragma appears 8341 -- too late. 8342 -- 8343 -- ??? is business with link symbols still valid, or does it relate 8344 -- to front end ZCX which is being phased out ??? 8345 8346 --------------------------- 8347 -- Inlining_Not_Possible -- 8348 --------------------------- 8349 8350 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is 8351 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 8352 Stats : Node_Id; 8353 8354 begin 8355 if Nkind (Decl) = N_Subprogram_Body then 8356 Stats := Handled_Statement_Sequence (Decl); 8357 return Present (Exception_Handlers (Stats)) 8358 or else Present (At_End_Proc (Stats)); 8359 8360 elsif Nkind (Decl) = N_Subprogram_Declaration 8361 and then Present (Corresponding_Body (Decl)) 8362 then 8363 if Front_End_Inlining 8364 and then Analyzed (Corresponding_Body (Decl)) 8365 then 8366 Error_Msg_N ("pragma appears too late, ignored??", N); 8367 return True; 8368 8369 -- If the subprogram is a renaming as body, the body is just a 8370 -- call to the renamed subprogram, and inlining is trivially 8371 -- possible. 8372 8373 elsif 8374 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = 8375 N_Subprogram_Renaming_Declaration 8376 then 8377 return False; 8378 8379 else 8380 Stats := 8381 Handled_Statement_Sequence 8382 (Unit_Declaration_Node (Corresponding_Body (Decl))); 8383 8384 return 8385 Present (Exception_Handlers (Stats)) 8386 or else Present (At_End_Proc (Stats)); 8387 end if; 8388 8389 else 8390 -- If body is not available, assume the best, the check is 8391 -- performed again when compiling enclosing package bodies. 8392 8393 return False; 8394 end if; 8395 end Inlining_Not_Possible; 8396 8397 ----------------- 8398 -- Make_Inline -- 8399 ----------------- 8400 8401 procedure Make_Inline (Subp : Entity_Id) is 8402 Kind : constant Entity_Kind := Ekind (Subp); 8403 Inner_Subp : Entity_Id := Subp; 8404 8405 begin 8406 -- Ignore if bad type, avoid cascaded error 8407 8408 if Etype (Subp) = Any_Type then 8409 Applies := True; 8410 return; 8411 8412 -- If inlining is not possible, for now do not treat as an error 8413 8414 elsif Status /= Suppressed 8415 and then Inlining_Not_Possible (Subp) 8416 then 8417 Applies := True; 8418 return; 8419 8420 -- Here we have a candidate for inlining, but we must exclude 8421 -- derived operations. Otherwise we would end up trying to inline 8422 -- a phantom declaration, and the result would be to drag in a 8423 -- body which has no direct inlining associated with it. That 8424 -- would not only be inefficient but would also result in the 8425 -- backend doing cross-unit inlining in cases where it was 8426 -- definitely inappropriate to do so. 8427 8428 -- However, a simple Comes_From_Source test is insufficient, since 8429 -- we do want to allow inlining of generic instances which also do 8430 -- not come from source. We also need to recognize specs generated 8431 -- by the front-end for bodies that carry the pragma. Finally, 8432 -- predefined operators do not come from source but are not 8433 -- inlineable either. 8434 8435 elsif Is_Generic_Instance (Subp) 8436 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration 8437 then 8438 null; 8439 8440 elsif not Comes_From_Source (Subp) 8441 and then Scope (Subp) /= Standard_Standard 8442 then 8443 Applies := True; 8444 return; 8445 end if; 8446 8447 -- The referenced entity must either be the enclosing entity, or 8448 -- an entity declared within the current open scope. 8449 8450 if Present (Scope (Subp)) 8451 and then Scope (Subp) /= Current_Scope 8452 and then Subp /= Current_Scope 8453 then 8454 Error_Pragma_Arg 8455 ("argument of% must be entity in current scope", Assoc); 8456 return; 8457 end if; 8458 8459 -- Processing for procedure, operator or function. If subprogram 8460 -- is aliased (as for an instance) indicate that the renamed 8461 -- entity (if declared in the same unit) is inlined. 8462 8463 if Is_Subprogram (Subp) then 8464 Inner_Subp := Ultimate_Alias (Inner_Subp); 8465 8466 if In_Same_Source_Unit (Subp, Inner_Subp) then 8467 Set_Inline_Flags (Inner_Subp); 8468 8469 Decl := Parent (Parent (Inner_Subp)); 8470 8471 if Nkind (Decl) = N_Subprogram_Declaration 8472 and then Present (Corresponding_Body (Decl)) 8473 then 8474 Set_Inline_Flags (Corresponding_Body (Decl)); 8475 8476 elsif Is_Generic_Instance (Subp) then 8477 8478 -- Indicate that the body needs to be created for 8479 -- inlining subsequent calls. The instantiation node 8480 -- follows the declaration of the wrapper package 8481 -- created for it. 8482 8483 if Scope (Subp) /= Standard_Standard 8484 and then 8485 Need_Subprogram_Instance_Body 8486 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), 8487 Subp) 8488 then 8489 null; 8490 end if; 8491 8492 -- Inline is a program unit pragma (RM 10.1.5) and cannot 8493 -- appear in a formal part to apply to a formal subprogram. 8494 -- Do not apply check within an instance or a formal package 8495 -- the test will have been applied to the original generic. 8496 8497 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration 8498 and then List_Containing (Decl) = List_Containing (N) 8499 and then not In_Instance 8500 then 8501 Error_Msg_N 8502 ("Inline cannot apply to a formal subprogram", N); 8503 8504 -- If Subp is a renaming, it is the renamed entity that 8505 -- will appear in any call, and be inlined. However, for 8506 -- ASIS uses it is convenient to indicate that the renaming 8507 -- itself is an inlined subprogram, so that some gnatcheck 8508 -- rules can be applied in the absence of expansion. 8509 8510 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then 8511 Set_Inline_Flags (Subp); 8512 end if; 8513 end if; 8514 8515 Applies := True; 8516 8517 -- For a generic subprogram set flag as well, for use at the point 8518 -- of instantiation, to determine whether the body should be 8519 -- generated. 8520 8521 elsif Is_Generic_Subprogram (Subp) then 8522 Set_Inline_Flags (Subp); 8523 Applies := True; 8524 8525 -- Literals are by definition inlined 8526 8527 elsif Kind = E_Enumeration_Literal then 8528 null; 8529 8530 -- Anything else is an error 8531 8532 else 8533 Error_Pragma_Arg 8534 ("expect subprogram name for pragma%", Assoc); 8535 end if; 8536 end Make_Inline; 8537 8538 ---------------------- 8539 -- Set_Inline_Flags -- 8540 ---------------------- 8541 8542 procedure Set_Inline_Flags (Subp : Entity_Id) is 8543 begin 8544 -- First set the Has_Pragma_XXX flags and issue the appropriate 8545 -- errors and warnings for suspicious combinations. 8546 8547 if Prag_Id = Pragma_No_Inline then 8548 if Has_Pragma_Inline_Always (Subp) then 8549 Error_Msg_N 8550 ("Inline_Always and No_Inline are mutually exclusive", N); 8551 elsif Has_Pragma_Inline (Subp) then 8552 Error_Msg_NE 8553 ("Inline and No_Inline both specified for& ??", 8554 N, Entity (Subp_Id)); 8555 end if; 8556 8557 Set_Has_Pragma_No_Inline (Subp); 8558 else 8559 if Prag_Id = Pragma_Inline_Always then 8560 if Has_Pragma_No_Inline (Subp) then 8561 Error_Msg_N 8562 ("Inline_Always and No_Inline are mutually exclusive", 8563 N); 8564 end if; 8565 8566 Set_Has_Pragma_Inline_Always (Subp); 8567 else 8568 if Has_Pragma_No_Inline (Subp) then 8569 Error_Msg_NE 8570 ("Inline and No_Inline both specified for& ??", 8571 N, Entity (Subp_Id)); 8572 end if; 8573 end if; 8574 8575 if not Has_Pragma_Inline (Subp) then 8576 Set_Has_Pragma_Inline (Subp); 8577 end if; 8578 end if; 8579 8580 -- Then adjust the Is_Inlined flag. It can never be set if the 8581 -- subprogram is subject to pragma No_Inline. 8582 8583 case Status is 8584 when Suppressed => 8585 Set_Is_Inlined (Subp, False); 8586 when Disabled => 8587 null; 8588 when Enabled => 8589 if not Has_Pragma_No_Inline (Subp) then 8590 Set_Is_Inlined (Subp, True); 8591 end if; 8592 end case; 8593 8594 -- A pragma that applies to a Ghost entity becomes Ghost for the 8595 -- purposes of legality checks and removal of ignored Ghost code. 8596 8597 Mark_Pragma_As_Ghost (N, Subp); 8598 8599 -- Capture the entity of the first Ghost subprogram being 8600 -- processed for error detection purposes. 8601 8602 if Is_Ghost_Entity (Subp) then 8603 if No (Ghost_Id) then 8604 Ghost_Id := Subp; 8605 end if; 8606 8607 -- Otherwise the subprogram is non-Ghost. It is illegal to mix 8608 -- references to Ghost and non-Ghost entities (SPARK RM 6.9). 8609 8610 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then 8611 Ghost_Error_Posted := True; 8612 8613 Error_Msg_Name_1 := Pname; 8614 Error_Msg_N 8615 ("pragma % cannot mention ghost and non-ghost subprograms", 8616 N); 8617 8618 Error_Msg_Sloc := Sloc (Ghost_Id); 8619 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 8620 8621 Error_Msg_Sloc := Sloc (Subp); 8622 Error_Msg_NE ("\& # declared as non-ghost", N, Subp); 8623 end if; 8624 end Set_Inline_Flags; 8625 8626 -- Start of processing for Process_Inline 8627 8628 begin 8629 Check_No_Identifiers; 8630 Check_At_Least_N_Arguments (1); 8631 8632 if Status = Enabled then 8633 Inline_Processing_Required := True; 8634 end if; 8635 8636 Assoc := Arg1; 8637 while Present (Assoc) loop 8638 Subp_Id := Get_Pragma_Arg (Assoc); 8639 Analyze (Subp_Id); 8640 Applies := False; 8641 8642 if Is_Entity_Name (Subp_Id) then 8643 Subp := Entity (Subp_Id); 8644 8645 if Subp = Any_Id then 8646 8647 -- If previous error, avoid cascaded errors 8648 8649 Check_Error_Detected; 8650 Applies := True; 8651 8652 else 8653 Make_Inline (Subp); 8654 8655 -- For the pragma case, climb homonym chain. This is 8656 -- what implements allowing the pragma in the renaming 8657 -- case, with the result applying to the ancestors, and 8658 -- also allows Inline to apply to all previous homonyms. 8659 8660 if not From_Aspect_Specification (N) then 8661 while Present (Homonym (Subp)) 8662 and then Scope (Homonym (Subp)) = Current_Scope 8663 loop 8664 Make_Inline (Homonym (Subp)); 8665 Subp := Homonym (Subp); 8666 end loop; 8667 end if; 8668 end if; 8669 end if; 8670 8671 if not Applies then 8672 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc); 8673 end if; 8674 8675 Next (Assoc); 8676 end loop; 8677 end Process_Inline; 8678 8679 ---------------------------- 8680 -- Process_Interface_Name -- 8681 ---------------------------- 8682 8683 procedure Process_Interface_Name 8684 (Subprogram_Def : Entity_Id; 8685 Ext_Arg : Node_Id; 8686 Link_Arg : Node_Id) 8687 is 8688 Ext_Nam : Node_Id; 8689 Link_Nam : Node_Id; 8690 String_Val : String_Id; 8691 8692 procedure Check_Form_Of_Interface_Name (SN : Node_Id); 8693 -- SN is a string literal node for an interface name. This routine 8694 -- performs some minimal checks that the name is reasonable. In 8695 -- particular that no spaces or other obviously incorrect characters 8696 -- appear. This is only a warning, since any characters are allowed. 8697 8698 ---------------------------------- 8699 -- Check_Form_Of_Interface_Name -- 8700 ---------------------------------- 8701 8702 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is 8703 S : constant String_Id := Strval (Expr_Value_S (SN)); 8704 SL : constant Nat := String_Length (S); 8705 C : Char_Code; 8706 8707 begin 8708 if SL = 0 then 8709 Error_Msg_N ("interface name cannot be null string", SN); 8710 end if; 8711 8712 for J in 1 .. SL loop 8713 C := Get_String_Char (S, J); 8714 8715 -- Look for dubious character and issue unconditional warning. 8716 -- Definitely dubious if not in character range. 8717 8718 if not In_Character_Range (C) 8719 8720 -- Commas, spaces and (back)slashes are dubious 8721 8722 or else Get_Character (C) = ',' 8723 or else Get_Character (C) = '\' 8724 or else Get_Character (C) = ' ' 8725 or else Get_Character (C) = '/' 8726 then 8727 Error_Msg 8728 ("??interface name contains illegal character", 8729 Sloc (SN) + Source_Ptr (J)); 8730 end if; 8731 end loop; 8732 end Check_Form_Of_Interface_Name; 8733 8734 -- Start of processing for Process_Interface_Name 8735 8736 begin 8737 if No (Link_Arg) then 8738 if No (Ext_Arg) then 8739 return; 8740 8741 elsif Chars (Ext_Arg) = Name_Link_Name then 8742 Ext_Nam := Empty; 8743 Link_Nam := Expression (Ext_Arg); 8744 8745 else 8746 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 8747 Ext_Nam := Expression (Ext_Arg); 8748 Link_Nam := Empty; 8749 end if; 8750 8751 else 8752 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 8753 Check_Optional_Identifier (Link_Arg, Name_Link_Name); 8754 Ext_Nam := Expression (Ext_Arg); 8755 Link_Nam := Expression (Link_Arg); 8756 end if; 8757 8758 -- Check expressions for external name and link name are static 8759 8760 if Present (Ext_Nam) then 8761 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String); 8762 Check_Form_Of_Interface_Name (Ext_Nam); 8763 8764 -- Verify that external name is not the name of a local entity, 8765 -- which would hide the imported one and could lead to run-time 8766 -- surprises. The problem can only arise for entities declared in 8767 -- a package body (otherwise the external name is fully qualified 8768 -- and will not conflict). 8769 8770 declare 8771 Nam : Name_Id; 8772 E : Entity_Id; 8773 Par : Node_Id; 8774 8775 begin 8776 if Prag_Id = Pragma_Import then 8777 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); 8778 Nam := Name_Find; 8779 E := Entity_Id (Get_Name_Table_Int (Nam)); 8780 8781 if Nam /= Chars (Subprogram_Def) 8782 and then Present (E) 8783 and then not Is_Overloadable (E) 8784 and then Is_Immediately_Visible (E) 8785 and then not Is_Imported (E) 8786 and then Ekind (Scope (E)) = E_Package 8787 then 8788 Par := Parent (E); 8789 while Present (Par) loop 8790 if Nkind (Par) = N_Package_Body then 8791 Error_Msg_Sloc := Sloc (E); 8792 Error_Msg_NE 8793 ("imported entity is hidden by & declared#", 8794 Ext_Arg, E); 8795 exit; 8796 end if; 8797 8798 Par := Parent (Par); 8799 end loop; 8800 end if; 8801 end if; 8802 end; 8803 end if; 8804 8805 if Present (Link_Nam) then 8806 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String); 8807 Check_Form_Of_Interface_Name (Link_Nam); 8808 end if; 8809 8810 -- If there is no link name, just set the external name 8811 8812 if No (Link_Nam) then 8813 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); 8814 8815 -- For the Link_Name case, the given literal is preceded by an 8816 -- asterisk, which indicates to GCC that the given name should be 8817 -- taken literally, and in particular that no prepending of 8818 -- underlines should occur, even in systems where this is the 8819 -- normal default. 8820 8821 else 8822 Start_String; 8823 Store_String_Char (Get_Char_Code ('*')); 8824 String_Val := Strval (Expr_Value_S (Link_Nam)); 8825 Store_String_Chars (String_Val); 8826 Link_Nam := 8827 Make_String_Literal (Sloc (Link_Nam), 8828 Strval => End_String); 8829 end if; 8830 8831 -- Set the interface name. If the entity is a generic instance, use 8832 -- its alias, which is the callable entity. 8833 8834 if Is_Generic_Instance (Subprogram_Def) then 8835 Set_Encoded_Interface_Name 8836 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); 8837 else 8838 Set_Encoded_Interface_Name 8839 (Get_Base_Subprogram (Subprogram_Def), Link_Nam); 8840 end if; 8841 8842 Check_Duplicated_Export_Name (Link_Nam); 8843 end Process_Interface_Name; 8844 8845 ----------------------------------------- 8846 -- Process_Interrupt_Or_Attach_Handler -- 8847 ----------------------------------------- 8848 8849 procedure Process_Interrupt_Or_Attach_Handler is 8850 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1)); 8851 Prot_Typ : constant Entity_Id := Scope (Handler); 8852 8853 begin 8854 -- A pragma that applies to a Ghost entity becomes Ghost for the 8855 -- purposes of legality checks and removal of ignored Ghost code. 8856 8857 Mark_Pragma_As_Ghost (N, Handler); 8858 Set_Is_Interrupt_Handler (Handler); 8859 8860 -- If the pragma is not associated with a handler procedure within a 8861 -- protected type, then it must be for a nonprotected procedure for 8862 -- the AAMP target, in which case we don't associate a representation 8863 -- item with the procedure's scope. 8864 8865 if Ekind (Prot_Typ) = E_Protected_Type then 8866 Record_Rep_Item (Prot_Typ, N); 8867 end if; 8868 8869 -- Chain the pragma on the contract for completeness 8870 8871 Add_Contract_Item (N, Handler); 8872 end Process_Interrupt_Or_Attach_Handler; 8873 8874 -------------------------------------------------- 8875 -- Process_Restrictions_Or_Restriction_Warnings -- 8876 -------------------------------------------------- 8877 8878 -- Note: some of the simple identifier cases were handled in par-prag, 8879 -- but it is harmless (and more straightforward) to simply handle all 8880 -- cases here, even if it means we repeat a bit of work in some cases. 8881 8882 procedure Process_Restrictions_Or_Restriction_Warnings 8883 (Warn : Boolean) 8884 is 8885 Arg : Node_Id; 8886 R_Id : Restriction_Id; 8887 Id : Name_Id; 8888 Expr : Node_Id; 8889 Val : Uint; 8890 8891 begin 8892 -- Ignore all Restrictions pragmas in CodePeer mode 8893 8894 if CodePeer_Mode then 8895 return; 8896 end if; 8897 8898 Check_Ada_83_Warning; 8899 Check_At_Least_N_Arguments (1); 8900 Check_Valid_Configuration_Pragma; 8901 8902 Arg := Arg1; 8903 while Present (Arg) loop 8904 Id := Chars (Arg); 8905 Expr := Get_Pragma_Arg (Arg); 8906 8907 -- Case of no restriction identifier present 8908 8909 if Id = No_Name then 8910 if Nkind (Expr) /= N_Identifier then 8911 Error_Pragma_Arg 8912 ("invalid form for restriction", Arg); 8913 end if; 8914 8915 R_Id := 8916 Get_Restriction_Id 8917 (Process_Restriction_Synonyms (Expr)); 8918 8919 if R_Id not in All_Boolean_Restrictions then 8920 Error_Msg_Name_1 := Pname; 8921 Error_Msg_N 8922 ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); 8923 8924 -- Check for possible misspelling 8925 8926 for J in Restriction_Id loop 8927 declare 8928 Rnm : constant String := Restriction_Id'Image (J); 8929 8930 begin 8931 Name_Buffer (1 .. Rnm'Length) := Rnm; 8932 Name_Len := Rnm'Length; 8933 Set_Casing (All_Lower_Case); 8934 8935 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then 8936 Set_Casing 8937 (Identifier_Casing (Current_Source_File)); 8938 Error_Msg_String (1 .. Rnm'Length) := 8939 Name_Buffer (1 .. Name_Len); 8940 Error_Msg_Strlen := Rnm'Length; 8941 Error_Msg_N -- CODEFIX 8942 ("\possible misspelling of ""~""", 8943 Get_Pragma_Arg (Arg)); 8944 exit; 8945 end if; 8946 end; 8947 end loop; 8948 8949 raise Pragma_Exit; 8950 end if; 8951 8952 if Implementation_Restriction (R_Id) then 8953 Check_Restriction (No_Implementation_Restrictions, Arg); 8954 end if; 8955 8956 -- Special processing for No_Elaboration_Code restriction 8957 8958 if R_Id = No_Elaboration_Code then 8959 8960 -- Restriction is only recognized within a configuration 8961 -- pragma file, or within a unit of the main extended 8962 -- program. Note: the test for Main_Unit is needed to 8963 -- properly include the case of configuration pragma files. 8964 8965 if not (Current_Sem_Unit = Main_Unit 8966 or else In_Extended_Main_Source_Unit (N)) 8967 then 8968 return; 8969 8970 -- Don't allow in a subunit unless already specified in 8971 -- body or spec. 8972 8973 elsif Nkind (Parent (N)) = N_Compilation_Unit 8974 and then Nkind (Unit (Parent (N))) = N_Subunit 8975 and then not Restriction_Active (No_Elaboration_Code) 8976 then 8977 Error_Msg_N 8978 ("invalid specification of ""No_Elaboration_Code""", 8979 N); 8980 Error_Msg_N 8981 ("\restriction cannot be specified in a subunit", N); 8982 Error_Msg_N 8983 ("\unless also specified in body or spec", N); 8984 return; 8985 8986 -- If we accept a No_Elaboration_Code restriction, then it 8987 -- needs to be added to the configuration restriction set so 8988 -- that we get proper application to other units in the main 8989 -- extended source as required. 8990 8991 else 8992 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 8993 end if; 8994 end if; 8995 8996 -- If this is a warning, then set the warning unless we already 8997 -- have a real restriction active (we never want a warning to 8998 -- override a real restriction). 8999 9000 if Warn then 9001 if not Restriction_Active (R_Id) then 9002 Set_Restriction (R_Id, N); 9003 Restriction_Warnings (R_Id) := True; 9004 end if; 9005 9006 -- If real restriction case, then set it and make sure that the 9007 -- restriction warning flag is off, since a real restriction 9008 -- always overrides a warning. 9009 9010 else 9011 Set_Restriction (R_Id, N); 9012 Restriction_Warnings (R_Id) := False; 9013 end if; 9014 9015 -- Check for obsolescent restrictions in Ada 2005 mode 9016 9017 if not Warn 9018 and then Ada_Version >= Ada_2005 9019 and then (R_Id = No_Asynchronous_Control 9020 or else 9021 R_Id = No_Unchecked_Deallocation 9022 or else 9023 R_Id = No_Unchecked_Conversion) 9024 then 9025 Check_Restriction (No_Obsolescent_Features, N); 9026 end if; 9027 9028 -- A very special case that must be processed here: pragma 9029 -- Restrictions (No_Exceptions) turns off all run-time 9030 -- checking. This is a bit dubious in terms of the formal 9031 -- language definition, but it is what is intended by RM 9032 -- H.4(12). Restriction_Warnings never affects generated code 9033 -- so this is done only in the real restriction case. 9034 9035 -- Atomic_Synchronization is not a real check, so it is not 9036 -- affected by this processing). 9037 9038 -- Ignore the effect of pragma Restrictions (No_Exceptions) on 9039 -- run-time checks in CodePeer and GNATprove modes: we want to 9040 -- generate checks for analysis purposes, as set respectively 9041 -- by -gnatC and -gnatd.F 9042 9043 if not Warn 9044 and then not (CodePeer_Mode or GNATprove_Mode) 9045 and then R_Id = No_Exceptions 9046 then 9047 for J in Scope_Suppress.Suppress'Range loop 9048 if J /= Atomic_Synchronization then 9049 Scope_Suppress.Suppress (J) := True; 9050 end if; 9051 end loop; 9052 end if; 9053 9054 -- Case of No_Dependence => unit-name. Note that the parser 9055 -- already made the necessary entry in the No_Dependence table. 9056 9057 elsif Id = Name_No_Dependence then 9058 if not OK_No_Dependence_Unit_Name (Expr) then 9059 raise Pragma_Exit; 9060 end if; 9061 9062 -- Case of No_Specification_Of_Aspect => aspect-identifier 9063 9064 elsif Id = Name_No_Specification_Of_Aspect then 9065 declare 9066 A_Id : Aspect_Id; 9067 9068 begin 9069 if Nkind (Expr) /= N_Identifier then 9070 A_Id := No_Aspect; 9071 else 9072 A_Id := Get_Aspect_Id (Chars (Expr)); 9073 end if; 9074 9075 if A_Id = No_Aspect then 9076 Error_Pragma_Arg ("invalid restriction name", Arg); 9077 else 9078 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); 9079 end if; 9080 end; 9081 9082 -- Case of No_Use_Of_Attribute => attribute-identifier 9083 9084 elsif Id = Name_No_Use_Of_Attribute then 9085 if Nkind (Expr) /= N_Identifier 9086 or else not Is_Attribute_Name (Chars (Expr)) 9087 then 9088 Error_Msg_N ("unknown attribute name??", Expr); 9089 9090 else 9091 Set_Restriction_No_Use_Of_Attribute (Expr, Warn); 9092 end if; 9093 9094 -- Case of No_Use_Of_Entity => fully-qualified-name 9095 9096 elsif Id = Name_No_Use_Of_Entity then 9097 9098 -- Restriction is only recognized within a configuration 9099 -- pragma file, or within a unit of the main extended 9100 -- program. Note: the test for Main_Unit is needed to 9101 -- properly include the case of configuration pragma files. 9102 9103 if Current_Sem_Unit = Main_Unit 9104 or else In_Extended_Main_Source_Unit (N) 9105 then 9106 if not OK_No_Dependence_Unit_Name (Expr) then 9107 Error_Msg_N ("wrong form for entity name", Expr); 9108 else 9109 Set_Restriction_No_Use_Of_Entity 9110 (Expr, Warn, No_Profile); 9111 end if; 9112 end if; 9113 9114 -- Case of No_Use_Of_Pragma => pragma-identifier 9115 9116 elsif Id = Name_No_Use_Of_Pragma then 9117 if Nkind (Expr) /= N_Identifier 9118 or else not Is_Pragma_Name (Chars (Expr)) 9119 then 9120 Error_Msg_N ("unknown pragma name??", Expr); 9121 else 9122 Set_Restriction_No_Use_Of_Pragma (Expr, Warn); 9123 end if; 9124 9125 -- All other cases of restriction identifier present 9126 9127 else 9128 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); 9129 Analyze_And_Resolve (Expr, Any_Integer); 9130 9131 if R_Id not in All_Parameter_Restrictions then 9132 Error_Pragma_Arg 9133 ("invalid restriction parameter identifier", Arg); 9134 9135 elsif not Is_OK_Static_Expression (Expr) then 9136 Flag_Non_Static_Expr 9137 ("value must be static expression!", Expr); 9138 raise Pragma_Exit; 9139 9140 elsif not Is_Integer_Type (Etype (Expr)) 9141 or else Expr_Value (Expr) < 0 9142 then 9143 Error_Pragma_Arg 9144 ("value must be non-negative integer", Arg); 9145 end if; 9146 9147 -- Restriction pragma is active 9148 9149 Val := Expr_Value (Expr); 9150 9151 if not UI_Is_In_Int_Range (Val) then 9152 Error_Pragma_Arg 9153 ("pragma ignored, value too large??", Arg); 9154 end if; 9155 9156 -- Warning case. If the real restriction is active, then we 9157 -- ignore the request, since warning never overrides a real 9158 -- restriction. Otherwise we set the proper warning. Note that 9159 -- this circuit sets the warning again if it is already set, 9160 -- which is what we want, since the constant may have changed. 9161 9162 if Warn then 9163 if not Restriction_Active (R_Id) then 9164 Set_Restriction 9165 (R_Id, N, Integer (UI_To_Int (Val))); 9166 Restriction_Warnings (R_Id) := True; 9167 end if; 9168 9169 -- Real restriction case, set restriction and make sure warning 9170 -- flag is off since real restriction always overrides warning. 9171 9172 else 9173 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); 9174 Restriction_Warnings (R_Id) := False; 9175 end if; 9176 end if; 9177 9178 Next (Arg); 9179 end loop; 9180 end Process_Restrictions_Or_Restriction_Warnings; 9181 9182 --------------------------------- 9183 -- Process_Suppress_Unsuppress -- 9184 --------------------------------- 9185 9186 -- Note: this procedure makes entries in the check suppress data 9187 -- structures managed by Sem. See spec of package Sem for full 9188 -- details on how we handle recording of check suppression. 9189 9190 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is 9191 C : Check_Id; 9192 E : Entity_Id; 9193 E_Id : Node_Id; 9194 9195 In_Package_Spec : constant Boolean := 9196 Is_Package_Or_Generic_Package (Current_Scope) 9197 and then not In_Package_Body (Current_Scope); 9198 9199 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); 9200 -- Used to suppress a single check on the given entity 9201 9202 -------------------------------- 9203 -- Suppress_Unsuppress_Echeck -- 9204 -------------------------------- 9205 9206 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is 9207 begin 9208 -- Check for error of trying to set atomic synchronization for 9209 -- a non-atomic variable. 9210 9211 if C = Atomic_Synchronization 9212 and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) 9213 then 9214 Error_Msg_N 9215 ("pragma & requires atomic type or variable", 9216 Pragma_Identifier (Original_Node (N))); 9217 end if; 9218 9219 Set_Checks_May_Be_Suppressed (E); 9220 9221 if In_Package_Spec then 9222 Push_Global_Suppress_Stack_Entry 9223 (Entity => E, 9224 Check => C, 9225 Suppress => Suppress_Case); 9226 else 9227 Push_Local_Suppress_Stack_Entry 9228 (Entity => E, 9229 Check => C, 9230 Suppress => Suppress_Case); 9231 end if; 9232 9233 -- If this is a first subtype, and the base type is distinct, 9234 -- then also set the suppress flags on the base type. 9235 9236 if Is_First_Subtype (E) and then Etype (E) /= E then 9237 Suppress_Unsuppress_Echeck (Etype (E), C); 9238 end if; 9239 end Suppress_Unsuppress_Echeck; 9240 9241 -- Start of processing for Process_Suppress_Unsuppress 9242 9243 begin 9244 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes 9245 -- on user code: we want to generate checks for analysis purposes, as 9246 -- set respectively by -gnatC and -gnatd.F 9247 9248 if Comes_From_Source (N) 9249 and then (CodePeer_Mode or GNATprove_Mode) 9250 then 9251 return; 9252 end if; 9253 9254 -- Suppress/Unsuppress can appear as a configuration pragma, or in a 9255 -- declarative part or a package spec (RM 11.5(5)). 9256 9257 if not Is_Configuration_Pragma then 9258 Check_Is_In_Decl_Part_Or_Package_Spec; 9259 end if; 9260 9261 Check_At_Least_N_Arguments (1); 9262 Check_At_Most_N_Arguments (2); 9263 Check_No_Identifier (Arg1); 9264 Check_Arg_Is_Identifier (Arg1); 9265 9266 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); 9267 9268 if C = No_Check_Id then 9269 Error_Pragma_Arg 9270 ("argument of pragma% is not valid check name", Arg1); 9271 end if; 9272 9273 -- Warn that suppress of Elaboration_Check has no effect in SPARK 9274 9275 if C = Elaboration_Check and then SPARK_Mode = On then 9276 Error_Pragma_Arg 9277 ("Suppress of Elaboration_Check ignored in SPARK??", 9278 "\elaboration checking rules are statically enforced " 9279 & "(SPARK RM 7.7)", Arg1); 9280 end if; 9281 9282 -- One-argument case 9283 9284 if Arg_Count = 1 then 9285 9286 -- Make an entry in the local scope suppress table. This is the 9287 -- table that directly shows the current value of the scope 9288 -- suppress check for any check id value. 9289 9290 if C = All_Checks then 9291 9292 -- For All_Checks, we set all specific predefined checks with 9293 -- the exception of Elaboration_Check, which is handled 9294 -- specially because of not wanting All_Checks to have the 9295 -- effect of deactivating static elaboration order processing. 9296 -- Atomic_Synchronization is also not affected, since this is 9297 -- not a real check. 9298 9299 for J in Scope_Suppress.Suppress'Range loop 9300 if J /= Elaboration_Check 9301 and then 9302 J /= Atomic_Synchronization 9303 then 9304 Scope_Suppress.Suppress (J) := Suppress_Case; 9305 end if; 9306 end loop; 9307 9308 -- If not All_Checks, and predefined check, then set appropriate 9309 -- scope entry. Note that we will set Elaboration_Check if this 9310 -- is explicitly specified. Atomic_Synchronization is allowed 9311 -- only if internally generated and entity is atomic. 9312 9313 elsif C in Predefined_Check_Id 9314 and then (not Comes_From_Source (N) 9315 or else C /= Atomic_Synchronization) 9316 then 9317 Scope_Suppress.Suppress (C) := Suppress_Case; 9318 end if; 9319 9320 -- Also make an entry in the Local_Entity_Suppress table 9321 9322 Push_Local_Suppress_Stack_Entry 9323 (Entity => Empty, 9324 Check => C, 9325 Suppress => Suppress_Case); 9326 9327 -- Case of two arguments present, where the check is suppressed for 9328 -- a specified entity (given as the second argument of the pragma) 9329 9330 else 9331 -- This is obsolescent in Ada 2005 mode 9332 9333 if Ada_Version >= Ada_2005 then 9334 Check_Restriction (No_Obsolescent_Features, Arg2); 9335 end if; 9336 9337 Check_Optional_Identifier (Arg2, Name_On); 9338 E_Id := Get_Pragma_Arg (Arg2); 9339 Analyze (E_Id); 9340 9341 if not Is_Entity_Name (E_Id) then 9342 Error_Pragma_Arg 9343 ("second argument of pragma% must be entity name", Arg2); 9344 end if; 9345 9346 E := Entity (E_Id); 9347 9348 if E = Any_Id then 9349 return; 9350 end if; 9351 9352 -- A pragma that applies to a Ghost entity becomes Ghost for the 9353 -- purposes of legality checks and removal of ignored Ghost code. 9354 9355 Mark_Pragma_As_Ghost (N, E); 9356 9357 -- Enforce RM 11.5(7) which requires that for a pragma that 9358 -- appears within a package spec, the named entity must be 9359 -- within the package spec. We allow the package name itself 9360 -- to be mentioned since that makes sense, although it is not 9361 -- strictly allowed by 11.5(7). 9362 9363 if In_Package_Spec 9364 and then E /= Current_Scope 9365 and then Scope (E) /= Current_Scope 9366 then 9367 Error_Pragma_Arg 9368 ("entity in pragma% is not in package spec (RM 11.5(7))", 9369 Arg2); 9370 end if; 9371 9372 -- Loop through homonyms. As noted below, in the case of a package 9373 -- spec, only homonyms within the package spec are considered. 9374 9375 loop 9376 Suppress_Unsuppress_Echeck (E, C); 9377 9378 if Is_Generic_Instance (E) 9379 and then Is_Subprogram (E) 9380 and then Present (Alias (E)) 9381 then 9382 Suppress_Unsuppress_Echeck (Alias (E), C); 9383 end if; 9384 9385 -- Move to next homonym if not aspect spec case 9386 9387 exit when From_Aspect_Specification (N); 9388 E := Homonym (E); 9389 exit when No (E); 9390 9391 -- If we are within a package specification, the pragma only 9392 -- applies to homonyms in the same scope. 9393 9394 exit when In_Package_Spec 9395 and then Scope (E) /= Current_Scope; 9396 end loop; 9397 end if; 9398 end Process_Suppress_Unsuppress; 9399 9400 ------------------------------- 9401 -- Record_Independence_Check -- 9402 ------------------------------- 9403 9404 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is 9405 begin 9406 -- For GCC back ends the validation is done a priori 9407 9408 if not AAMP_On_Target then 9409 return; 9410 end if; 9411 9412 Independence_Checks.Append ((N, E)); 9413 end Record_Independence_Check; 9414 9415 ------------------ 9416 -- Set_Exported -- 9417 ------------------ 9418 9419 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is 9420 begin 9421 if Is_Imported (E) then 9422 Error_Pragma_Arg 9423 ("cannot export entity& that was previously imported", Arg); 9424 9425 elsif Present (Address_Clause (E)) 9426 and then not Relaxed_RM_Semantics 9427 then 9428 Error_Pragma_Arg 9429 ("cannot export entity& that has an address clause", Arg); 9430 end if; 9431 9432 Set_Is_Exported (E); 9433 9434 -- Generate a reference for entity explicitly, because the 9435 -- identifier may be overloaded and name resolution will not 9436 -- generate one. 9437 9438 Generate_Reference (E, Arg); 9439 9440 -- Deal with exporting non-library level entity 9441 9442 if not Is_Library_Level_Entity (E) then 9443 9444 -- Not allowed at all for subprograms 9445 9446 if Is_Subprogram (E) then 9447 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); 9448 9449 -- Otherwise set public and statically allocated 9450 9451 else 9452 Set_Is_Public (E); 9453 Set_Is_Statically_Allocated (E); 9454 9455 -- Warn if the corresponding W flag is set 9456 9457 if Warn_On_Export_Import 9458 9459 -- Only do this for something that was in the source. Not 9460 -- clear if this can be False now (there used for sure to be 9461 -- cases on some systems where it was False), but anyway the 9462 -- test is harmless if not needed, so it is retained. 9463 9464 and then Comes_From_Source (Arg) 9465 then 9466 Error_Msg_NE 9467 ("?x?& has been made static as a result of Export", 9468 Arg, E); 9469 Error_Msg_N 9470 ("\?x?this usage is non-standard and non-portable", 9471 Arg); 9472 end if; 9473 end if; 9474 end if; 9475 9476 if Warn_On_Export_Import and then Is_Type (E) then 9477 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); 9478 end if; 9479 9480 if Warn_On_Export_Import and Inside_A_Generic then 9481 Error_Msg_NE 9482 ("all instances of& will have the same external name?x?", 9483 Arg, E); 9484 end if; 9485 end Set_Exported; 9486 9487 ---------------------------------------------- 9488 -- Set_Extended_Import_Export_External_Name -- 9489 ---------------------------------------------- 9490 9491 procedure Set_Extended_Import_Export_External_Name 9492 (Internal_Ent : Entity_Id; 9493 Arg_External : Node_Id) 9494 is 9495 Old_Name : constant Node_Id := Interface_Name (Internal_Ent); 9496 New_Name : Node_Id; 9497 9498 begin 9499 if No (Arg_External) then 9500 return; 9501 end if; 9502 9503 Check_Arg_Is_External_Name (Arg_External); 9504 9505 if Nkind (Arg_External) = N_String_Literal then 9506 if String_Length (Strval (Arg_External)) = 0 then 9507 return; 9508 else 9509 New_Name := Adjust_External_Name_Case (Arg_External); 9510 end if; 9511 9512 elsif Nkind (Arg_External) = N_Identifier then 9513 New_Name := Get_Default_External_Name (Arg_External); 9514 9515 -- Check_Arg_Is_External_Name should let through only identifiers and 9516 -- string literals or static string expressions (which are folded to 9517 -- string literals). 9518 9519 else 9520 raise Program_Error; 9521 end if; 9522 9523 -- If we already have an external name set (by a prior normal Import 9524 -- or Export pragma), then the external names must match 9525 9526 if Present (Interface_Name (Internal_Ent)) then 9527 9528 -- Ignore mismatching names in CodePeer mode, to support some 9529 -- old compilers which would export the same procedure under 9530 -- different names, e.g: 9531 -- procedure P; 9532 -- pragma Export_Procedure (P, "a"); 9533 -- pragma Export_Procedure (P, "b"); 9534 9535 if CodePeer_Mode then 9536 return; 9537 end if; 9538 9539 Check_Matching_Internal_Names : declare 9540 S1 : constant String_Id := Strval (Old_Name); 9541 S2 : constant String_Id := Strval (New_Name); 9542 9543 procedure Mismatch; 9544 pragma No_Return (Mismatch); 9545 -- Called if names do not match 9546 9547 -------------- 9548 -- Mismatch -- 9549 -------------- 9550 9551 procedure Mismatch is 9552 begin 9553 Error_Msg_Sloc := Sloc (Old_Name); 9554 Error_Pragma_Arg 9555 ("external name does not match that given #", 9556 Arg_External); 9557 end Mismatch; 9558 9559 -- Start of processing for Check_Matching_Internal_Names 9560 9561 begin 9562 if String_Length (S1) /= String_Length (S2) then 9563 Mismatch; 9564 9565 else 9566 for J in 1 .. String_Length (S1) loop 9567 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then 9568 Mismatch; 9569 end if; 9570 end loop; 9571 end if; 9572 end Check_Matching_Internal_Names; 9573 9574 -- Otherwise set the given name 9575 9576 else 9577 Set_Encoded_Interface_Name (Internal_Ent, New_Name); 9578 Check_Duplicated_Export_Name (New_Name); 9579 end if; 9580 end Set_Extended_Import_Export_External_Name; 9581 9582 ------------------ 9583 -- Set_Imported -- 9584 ------------------ 9585 9586 procedure Set_Imported (E : Entity_Id) is 9587 begin 9588 -- Error message if already imported or exported 9589 9590 if Is_Exported (E) or else Is_Imported (E) then 9591 9592 -- Error if being set Exported twice 9593 9594 if Is_Exported (E) then 9595 Error_Msg_NE ("entity& was previously exported", N, E); 9596 9597 -- Ignore error in CodePeer mode where we treat all imported 9598 -- subprograms as unknown. 9599 9600 elsif CodePeer_Mode then 9601 goto OK; 9602 9603 -- OK if Import/Interface case 9604 9605 elsif Import_Interface_Present (N) then 9606 goto OK; 9607 9608 -- Error if being set Imported twice 9609 9610 else 9611 Error_Msg_NE ("entity& was previously imported", N, E); 9612 end if; 9613 9614 Error_Msg_Name_1 := Pname; 9615 Error_Msg_N 9616 ("\(pragma% applies to all previous entities)", N); 9617 9618 Error_Msg_Sloc := Sloc (E); 9619 Error_Msg_NE ("\import not allowed for& declared#", N, E); 9620 9621 -- Here if not previously imported or exported, OK to import 9622 9623 else 9624 Set_Is_Imported (E); 9625 9626 -- For subprogram, set Import_Pragma field 9627 9628 if Is_Subprogram (E) then 9629 Set_Import_Pragma (E, N); 9630 end if; 9631 9632 -- If the entity is an object that is not at the library level, 9633 -- then it is statically allocated. We do not worry about objects 9634 -- with address clauses in this context since they are not really 9635 -- imported in the linker sense. 9636 9637 if Is_Object (E) 9638 and then not Is_Library_Level_Entity (E) 9639 and then No (Address_Clause (E)) 9640 then 9641 Set_Is_Statically_Allocated (E); 9642 end if; 9643 end if; 9644 9645 <<OK>> null; 9646 end Set_Imported; 9647 9648 ------------------------- 9649 -- Set_Mechanism_Value -- 9650 ------------------------- 9651 9652 -- Note: the mechanism name has not been analyzed (and cannot indeed be 9653 -- analyzed, since it is semantic nonsense), so we get it in the exact 9654 -- form created by the parser. 9655 9656 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is 9657 procedure Bad_Mechanism; 9658 pragma No_Return (Bad_Mechanism); 9659 -- Signal bad mechanism name 9660 9661 ------------------------- 9662 -- Bad_Mechanism_Value -- 9663 ------------------------- 9664 9665 procedure Bad_Mechanism is 9666 begin 9667 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); 9668 end Bad_Mechanism; 9669 9670 -- Start of processing for Set_Mechanism_Value 9671 9672 begin 9673 if Mechanism (Ent) /= Default_Mechanism then 9674 Error_Msg_NE 9675 ("mechanism for & has already been set", Mech_Name, Ent); 9676 end if; 9677 9678 -- MECHANISM_NAME ::= value | reference 9679 9680 if Nkind (Mech_Name) = N_Identifier then 9681 if Chars (Mech_Name) = Name_Value then 9682 Set_Mechanism (Ent, By_Copy); 9683 return; 9684 9685 elsif Chars (Mech_Name) = Name_Reference then 9686 Set_Mechanism (Ent, By_Reference); 9687 return; 9688 9689 elsif Chars (Mech_Name) = Name_Copy then 9690 Error_Pragma_Arg 9691 ("bad mechanism name, Value assumed", Mech_Name); 9692 9693 else 9694 Bad_Mechanism; 9695 end if; 9696 9697 else 9698 Bad_Mechanism; 9699 end if; 9700 end Set_Mechanism_Value; 9701 9702 -------------------------- 9703 -- Set_Rational_Profile -- 9704 -------------------------- 9705 9706 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and 9707 -- extension to the semantics of renaming declarations. 9708 9709 procedure Set_Rational_Profile is 9710 begin 9711 Implicit_Packing := True; 9712 Overriding_Renamings := True; 9713 Use_VADS_Size := True; 9714 end Set_Rational_Profile; 9715 9716 --------------------------- 9717 -- Set_Ravenscar_Profile -- 9718 --------------------------- 9719 9720 -- The tasks to be done here are 9721 9722 -- Set required policies 9723 9724 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 9725 -- pragma Locking_Policy (Ceiling_Locking) 9726 9727 -- Set Detect_Blocking mode 9728 9729 -- Set required restrictions (see System.Rident for detailed list) 9730 9731 -- Set the No_Dependence rules 9732 -- No_Dependence => Ada.Asynchronous_Task_Control 9733 -- No_Dependence => Ada.Calendar 9734 -- No_Dependence => Ada.Execution_Time.Group_Budget 9735 -- No_Dependence => Ada.Execution_Time.Timers 9736 -- No_Dependence => Ada.Task_Attributes 9737 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 9738 9739 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is 9740 procedure Set_Error_Msg_To_Profile_Name; 9741 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the 9742 -- profile. 9743 9744 ----------------------------------- 9745 -- Set_Error_Msg_To_Profile_Name -- 9746 ----------------------------------- 9747 9748 procedure Set_Error_Msg_To_Profile_Name is 9749 Prof_Nam : constant Node_Id := 9750 Get_Pragma_Arg 9751 (First (Pragma_Argument_Associations (N))); 9752 9753 begin 9754 Get_Name_String (Chars (Prof_Nam)); 9755 Adjust_Name_Case (Sloc (Prof_Nam)); 9756 Error_Msg_Strlen := Name_Len; 9757 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); 9758 end Set_Error_Msg_To_Profile_Name; 9759 9760 -- Local variables 9761 9762 Nod : Node_Id; 9763 Pref : Node_Id; 9764 Pref_Id : Node_Id; 9765 Sel_Id : Node_Id; 9766 9767 -- Start of processing for Set_Ravenscar_Profile 9768 9769 begin 9770 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 9771 9772 if Task_Dispatching_Policy /= ' ' 9773 and then Task_Dispatching_Policy /= 'F' 9774 then 9775 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 9776 Set_Error_Msg_To_Profile_Name; 9777 Error_Pragma ("Profile (~) incompatible with policy#"); 9778 9779 -- Set the FIFO_Within_Priorities policy, but always preserve 9780 -- System_Location since we like the error message with the run time 9781 -- name. 9782 9783 else 9784 Task_Dispatching_Policy := 'F'; 9785 9786 if Task_Dispatching_Policy_Sloc /= System_Location then 9787 Task_Dispatching_Policy_Sloc := Loc; 9788 end if; 9789 end if; 9790 9791 -- pragma Locking_Policy (Ceiling_Locking) 9792 9793 if Locking_Policy /= ' ' 9794 and then Locking_Policy /= 'C' 9795 then 9796 Error_Msg_Sloc := Locking_Policy_Sloc; 9797 Set_Error_Msg_To_Profile_Name; 9798 Error_Pragma ("Profile (~) incompatible with policy#"); 9799 9800 -- Set the Ceiling_Locking policy, but preserve System_Location since 9801 -- we like the error message with the run time name. 9802 9803 else 9804 Locking_Policy := 'C'; 9805 9806 if Locking_Policy_Sloc /= System_Location then 9807 Locking_Policy_Sloc := Loc; 9808 end if; 9809 end if; 9810 9811 -- pragma Detect_Blocking 9812 9813 Detect_Blocking := True; 9814 9815 -- Set the corresponding restrictions 9816 9817 Set_Profile_Restrictions 9818 (Profile, N, Warn => Treat_Restrictions_As_Warnings); 9819 9820 -- Set the No_Dependence restrictions 9821 9822 -- The following No_Dependence restrictions: 9823 -- No_Dependence => Ada.Asynchronous_Task_Control 9824 -- No_Dependence => Ada.Calendar 9825 -- No_Dependence => Ada.Task_Attributes 9826 -- are already set by previous call to Set_Profile_Restrictions. 9827 9828 -- Set the following restrictions which were added to Ada 2005: 9829 -- No_Dependence => Ada.Execution_Time.Group_Budget 9830 -- No_Dependence => Ada.Execution_Time.Timers 9831 9832 -- ??? The use of Name_Buffer here is suspicious. The names should 9833 -- be registered in snames.ads-tmpl and used to build the qualified 9834 -- names of units. 9835 9836 if Ada_Version >= Ada_2005 then 9837 Name_Buffer (1 .. 3) := "ada"; 9838 Name_Len := 3; 9839 9840 Pref_Id := Make_Identifier (Loc, Name_Find); 9841 9842 Name_Buffer (1 .. 14) := "execution_time"; 9843 Name_Len := 14; 9844 9845 Sel_Id := Make_Identifier (Loc, Name_Find); 9846 9847 Pref := 9848 Make_Selected_Component 9849 (Sloc => Loc, 9850 Prefix => Pref_Id, 9851 Selector_Name => Sel_Id); 9852 9853 Name_Buffer (1 .. 13) := "group_budgets"; 9854 Name_Len := 13; 9855 9856 Sel_Id := Make_Identifier (Loc, Name_Find); 9857 9858 Nod := 9859 Make_Selected_Component 9860 (Sloc => Loc, 9861 Prefix => Pref, 9862 Selector_Name => Sel_Id); 9863 9864 Set_Restriction_No_Dependence 9865 (Unit => Nod, 9866 Warn => Treat_Restrictions_As_Warnings, 9867 Profile => Ravenscar); 9868 9869 Name_Buffer (1 .. 6) := "timers"; 9870 Name_Len := 6; 9871 9872 Sel_Id := Make_Identifier (Loc, Name_Find); 9873 9874 Nod := 9875 Make_Selected_Component 9876 (Sloc => Loc, 9877 Prefix => Pref, 9878 Selector_Name => Sel_Id); 9879 9880 Set_Restriction_No_Dependence 9881 (Unit => Nod, 9882 Warn => Treat_Restrictions_As_Warnings, 9883 Profile => Ravenscar); 9884 end if; 9885 9886 -- Set the following restriction which was added to Ada 2012 (see 9887 -- AI-0171): 9888 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 9889 9890 if Ada_Version >= Ada_2012 then 9891 Name_Buffer (1 .. 6) := "system"; 9892 Name_Len := 6; 9893 9894 Pref_Id := Make_Identifier (Loc, Name_Find); 9895 9896 Name_Buffer (1 .. 15) := "multiprocessors"; 9897 Name_Len := 15; 9898 9899 Sel_Id := Make_Identifier (Loc, Name_Find); 9900 9901 Pref := 9902 Make_Selected_Component 9903 (Sloc => Loc, 9904 Prefix => Pref_Id, 9905 Selector_Name => Sel_Id); 9906 9907 Name_Buffer (1 .. 19) := "dispatching_domains"; 9908 Name_Len := 19; 9909 9910 Sel_Id := Make_Identifier (Loc, Name_Find); 9911 9912 Nod := 9913 Make_Selected_Component 9914 (Sloc => Loc, 9915 Prefix => Pref, 9916 Selector_Name => Sel_Id); 9917 9918 Set_Restriction_No_Dependence 9919 (Unit => Nod, 9920 Warn => Treat_Restrictions_As_Warnings, 9921 Profile => Ravenscar); 9922 end if; 9923 end Set_Ravenscar_Profile; 9924 9925 -- Start of processing for Analyze_Pragma 9926 9927 begin 9928 -- The following code is a defense against recursion. Not clear that 9929 -- this can happen legitimately, but perhaps some error situations can 9930 -- cause it, and we did see this recursion during testing. 9931 9932 if Analyzed (N) then 9933 return; 9934 else 9935 Set_Analyzed (N); 9936 end if; 9937 9938 -- Deal with unrecognized pragma 9939 9940 Pname := Pragma_Name (N); 9941 9942 if not Is_Pragma_Name (Pname) then 9943 if Warn_On_Unrecognized_Pragma then 9944 Error_Msg_Name_1 := Pname; 9945 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N)); 9946 9947 for PN in First_Pragma_Name .. Last_Pragma_Name loop 9948 if Is_Bad_Spelling_Of (Pname, PN) then 9949 Error_Msg_Name_1 := PN; 9950 Error_Msg_N -- CODEFIX 9951 ("\?g?possible misspelling of %!", Pragma_Identifier (N)); 9952 exit; 9953 end if; 9954 end loop; 9955 end if; 9956 9957 return; 9958 end if; 9959 9960 -- Ignore pragma if Ignore_Pragma applies 9961 9962 if Get_Name_Table_Boolean3 (Pname) then 9963 return; 9964 end if; 9965 9966 -- Here to start processing for recognized pragma 9967 9968 Prag_Id := Get_Pragma_Id (Pname); 9969 Pname := Original_Aspect_Pragma_Name (N); 9970 9971 -- Capture setting of Opt.Uneval_Old 9972 9973 case Opt.Uneval_Old is 9974 when 'A' => 9975 Set_Uneval_Old_Accept (N); 9976 when 'E' => 9977 null; 9978 when 'W' => 9979 Set_Uneval_Old_Warn (N); 9980 when others => 9981 raise Program_Error; 9982 end case; 9983 9984 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored 9985 -- is already set, indicating that we have already checked the policy 9986 -- at the right point. This happens for example in the case of a pragma 9987 -- that is derived from an Aspect. 9988 9989 if Is_Ignored (N) or else Is_Checked (N) then 9990 null; 9991 9992 -- For a pragma that is a rewriting of another pragma, copy the 9993 -- Is_Checked/Is_Ignored status from the rewritten pragma. 9994 9995 elsif Is_Rewrite_Substitution (N) 9996 and then Nkind (Original_Node (N)) = N_Pragma 9997 and then Original_Node (N) /= N 9998 then 9999 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 10000 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 10001 10002 -- Otherwise query the applicable policy at this point 10003 10004 else 10005 Check_Applicable_Policy (N); 10006 10007 -- If pragma is disabled, rewrite as NULL and skip analysis 10008 10009 if Is_Disabled (N) then 10010 Rewrite (N, Make_Null_Statement (Loc)); 10011 Analyze (N); 10012 raise Pragma_Exit; 10013 end if; 10014 end if; 10015 10016 -- Preset arguments 10017 10018 Arg_Count := 0; 10019 Arg1 := Empty; 10020 Arg2 := Empty; 10021 Arg3 := Empty; 10022 Arg4 := Empty; 10023 10024 if Present (Pragma_Argument_Associations (N)) then 10025 Arg_Count := List_Length (Pragma_Argument_Associations (N)); 10026 Arg1 := First (Pragma_Argument_Associations (N)); 10027 10028 if Present (Arg1) then 10029 Arg2 := Next (Arg1); 10030 10031 if Present (Arg2) then 10032 Arg3 := Next (Arg2); 10033 10034 if Present (Arg3) then 10035 Arg4 := Next (Arg3); 10036 end if; 10037 end if; 10038 end if; 10039 end if; 10040 10041 Check_Restriction_No_Use_Of_Pragma (N); 10042 10043 -- An enumeration type defines the pragmas that are supported by the 10044 -- implementation. Get_Pragma_Id (in package Prag) transforms a name 10045 -- into the corresponding enumeration value for the following case. 10046 10047 case Prag_Id is 10048 10049 ----------------- 10050 -- Abort_Defer -- 10051 ----------------- 10052 10053 -- pragma Abort_Defer; 10054 10055 when Pragma_Abort_Defer => 10056 GNAT_Pragma; 10057 Check_Arg_Count (0); 10058 10059 -- The only required semantic processing is to check the 10060 -- placement. This pragma must appear at the start of the 10061 -- statement sequence of a handled sequence of statements. 10062 10063 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 10064 or else N /= First (Statements (Parent (N))) 10065 then 10066 Pragma_Misplaced; 10067 end if; 10068 10069 -------------------- 10070 -- Abstract_State -- 10071 -------------------- 10072 10073 -- pragma Abstract_State (ABSTRACT_STATE_LIST); 10074 10075 -- ABSTRACT_STATE_LIST ::= 10076 -- null 10077 -- | STATE_NAME_WITH_OPTIONS 10078 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS}) 10079 10080 -- STATE_NAME_WITH_OPTIONS ::= 10081 -- STATE_NAME 10082 -- | (STATE_NAME with OPTION_LIST) 10083 10084 -- OPTION_LIST ::= OPTION {, OPTION} 10085 10086 -- OPTION ::= 10087 -- SIMPLE_OPTION 10088 -- | NAME_VALUE_OPTION 10089 10090 -- SIMPLE_OPTION ::= Ghost | Synchronous 10091 10092 -- NAME_VALUE_OPTION ::= 10093 -- Part_Of => ABSTRACT_STATE 10094 -- | External [=> EXTERNAL_PROPERTY_LIST] 10095 10096 -- EXTERNAL_PROPERTY_LIST ::= 10097 -- EXTERNAL_PROPERTY 10098 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY}) 10099 10100 -- EXTERNAL_PROPERTY ::= 10101 -- Async_Readers [=> boolean_EXPRESSION] 10102 -- | Async_Writers [=> boolean_EXPRESSION] 10103 -- | Effective_Reads [=> boolean_EXPRESSION] 10104 -- | Effective_Writes [=> boolean_EXPRESSION] 10105 -- others => boolean_EXPRESSION 10106 10107 -- STATE_NAME ::= defining_identifier 10108 10109 -- ABSTRACT_STATE ::= name 10110 10111 -- Characteristics: 10112 10113 -- * Analysis - The annotation is fully analyzed immediately upon 10114 -- elaboration as it cannot forward reference entities. 10115 10116 -- * Expansion - None. 10117 10118 -- * Template - The annotation utilizes the generic template of the 10119 -- related package declaration. 10120 10121 -- * Globals - The annotation cannot reference global entities. 10122 10123 -- * Instance - The annotation is instantiated automatically when 10124 -- the related generic package is instantiated. 10125 10126 when Pragma_Abstract_State => Abstract_State : declare 10127 Missing_Parentheses : Boolean := False; 10128 -- Flag set when a state declaration with options is not properly 10129 -- parenthesized. 10130 10131 -- Flags used to verify the consistency of states 10132 10133 Non_Null_Seen : Boolean := False; 10134 Null_Seen : Boolean := False; 10135 10136 procedure Analyze_Abstract_State 10137 (State : Node_Id; 10138 Pack_Id : Entity_Id); 10139 -- Verify the legality of a single state declaration. Create and 10140 -- decorate a state abstraction entity and introduce it into the 10141 -- visibility chain. Pack_Id denotes the entity or the related 10142 -- package where pragma Abstract_State appears. 10143 10144 procedure Malformed_State_Error (State : Node_Id); 10145 -- Emit an error concerning the illegal declaration of abstract 10146 -- state State. This routine diagnoses syntax errors that lead to 10147 -- a different parse tree. The error is issued regardless of the 10148 -- SPARK mode in effect. 10149 10150 ---------------------------- 10151 -- Analyze_Abstract_State -- 10152 ---------------------------- 10153 10154 procedure Analyze_Abstract_State 10155 (State : Node_Id; 10156 Pack_Id : Entity_Id) 10157 is 10158 -- Flags used to verify the consistency of options 10159 10160 AR_Seen : Boolean := False; 10161 AW_Seen : Boolean := False; 10162 ER_Seen : Boolean := False; 10163 EW_Seen : Boolean := False; 10164 External_Seen : Boolean := False; 10165 Ghost_Seen : Boolean := False; 10166 Others_Seen : Boolean := False; 10167 Part_Of_Seen : Boolean := False; 10168 Synchronous_Seen : Boolean := False; 10169 10170 -- Flags used to store the static value of all external states' 10171 -- expressions. 10172 10173 AR_Val : Boolean := False; 10174 AW_Val : Boolean := False; 10175 ER_Val : Boolean := False; 10176 EW_Val : Boolean := False; 10177 10178 State_Id : Entity_Id := Empty; 10179 -- The entity to be generated for the current state declaration 10180 10181 procedure Analyze_External_Option (Opt : Node_Id); 10182 -- Verify the legality of option External 10183 10184 procedure Analyze_External_Property 10185 (Prop : Node_Id; 10186 Expr : Node_Id := Empty); 10187 -- Verify the legailty of a single external property. Prop 10188 -- denotes the external property. Expr is the expression used 10189 -- to set the property. 10190 10191 procedure Analyze_Part_Of_Option (Opt : Node_Id); 10192 -- Verify the legality of option Part_Of 10193 10194 procedure Check_Duplicate_Option 10195 (Opt : Node_Id; 10196 Status : in out Boolean); 10197 -- Flag Status denotes whether a particular option has been 10198 -- seen while processing a state. This routine verifies that 10199 -- Opt is not a duplicate option and sets the flag Status 10200 -- (SPARK RM 7.1.4(1)). 10201 10202 procedure Check_Duplicate_Property 10203 (Prop : Node_Id; 10204 Status : in out Boolean); 10205 -- Flag Status denotes whether a particular property has been 10206 -- seen while processing option External. This routine verifies 10207 -- that Prop is not a duplicate property and sets flag Status. 10208 -- Opt is not a duplicate property and sets the flag Status. 10209 -- (SPARK RM 7.1.4(2)) 10210 10211 procedure Check_Ghost_Synchronous; 10212 -- Ensure that the abstract state is not subject to both Ghost 10213 -- and Synchronous simple options. Emit an error if this is the 10214 -- case. 10215 10216 procedure Create_Abstract_State 10217 (Nam : Name_Id; 10218 Decl : Node_Id; 10219 Loc : Source_Ptr; 10220 Is_Null : Boolean); 10221 -- Generate an abstract state entity with name Nam and enter it 10222 -- into visibility. Decl is the "declaration" of the state as 10223 -- it appears in pragma Abstract_State. Loc is the location of 10224 -- the related state "declaration". Flag Is_Null should be set 10225 -- when the associated Abstract_State pragma defines a null 10226 -- state. 10227 10228 ----------------------------- 10229 -- Analyze_External_Option -- 10230 ----------------------------- 10231 10232 procedure Analyze_External_Option (Opt : Node_Id) is 10233 Errors : constant Nat := Serious_Errors_Detected; 10234 Prop : Node_Id; 10235 Props : Node_Id := Empty; 10236 10237 begin 10238 if Nkind (Opt) = N_Component_Association then 10239 Props := Expression (Opt); 10240 end if; 10241 10242 -- External state with properties 10243 10244 if Present (Props) then 10245 10246 -- Multiple properties appear as an aggregate 10247 10248 if Nkind (Props) = N_Aggregate then 10249 10250 -- Simple property form 10251 10252 Prop := First (Expressions (Props)); 10253 while Present (Prop) loop 10254 Analyze_External_Property (Prop); 10255 Next (Prop); 10256 end loop; 10257 10258 -- Property with expression form 10259 10260 Prop := First (Component_Associations (Props)); 10261 while Present (Prop) loop 10262 Analyze_External_Property 10263 (Prop => First (Choices (Prop)), 10264 Expr => Expression (Prop)); 10265 10266 Next (Prop); 10267 end loop; 10268 10269 -- Single property 10270 10271 else 10272 Analyze_External_Property (Props); 10273 end if; 10274 10275 -- An external state defined without any properties defaults 10276 -- all properties to True. 10277 10278 else 10279 AR_Val := True; 10280 AW_Val := True; 10281 ER_Val := True; 10282 EW_Val := True; 10283 end if; 10284 10285 -- Once all external properties have been processed, verify 10286 -- their mutual interaction. Do not perform the check when 10287 -- at least one of the properties is illegal as this will 10288 -- produce a bogus error. 10289 10290 if Errors = Serious_Errors_Detected then 10291 Check_External_Properties 10292 (State, AR_Val, AW_Val, ER_Val, EW_Val); 10293 end if; 10294 end Analyze_External_Option; 10295 10296 ------------------------------- 10297 -- Analyze_External_Property -- 10298 ------------------------------- 10299 10300 procedure Analyze_External_Property 10301 (Prop : Node_Id; 10302 Expr : Node_Id := Empty) 10303 is 10304 Expr_Val : Boolean; 10305 10306 begin 10307 -- Check the placement of "others" (if available) 10308 10309 if Nkind (Prop) = N_Others_Choice then 10310 if Others_Seen then 10311 SPARK_Msg_N 10312 ("only one others choice allowed in option External", 10313 Prop); 10314 else 10315 Others_Seen := True; 10316 end if; 10317 10318 elsif Others_Seen then 10319 SPARK_Msg_N 10320 ("others must be the last property in option External", 10321 Prop); 10322 10323 -- The only remaining legal options are the four predefined 10324 -- external properties. 10325 10326 elsif Nkind (Prop) = N_Identifier 10327 and then Nam_In (Chars (Prop), Name_Async_Readers, 10328 Name_Async_Writers, 10329 Name_Effective_Reads, 10330 Name_Effective_Writes) 10331 then 10332 null; 10333 10334 -- Otherwise the construct is not a valid property 10335 10336 else 10337 SPARK_Msg_N ("invalid external state property", Prop); 10338 return; 10339 end if; 10340 10341 -- Ensure that the expression of the external state property 10342 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)). 10343 10344 if Present (Expr) then 10345 Analyze_And_Resolve (Expr, Standard_Boolean); 10346 10347 if Is_OK_Static_Expression (Expr) then 10348 Expr_Val := Is_True (Expr_Value (Expr)); 10349 else 10350 SPARK_Msg_N 10351 ("expression of external state property must be " 10352 & "static", Expr); 10353 end if; 10354 10355 -- The lack of expression defaults the property to True 10356 10357 else 10358 Expr_Val := True; 10359 end if; 10360 10361 -- Named properties 10362 10363 if Nkind (Prop) = N_Identifier then 10364 if Chars (Prop) = Name_Async_Readers then 10365 Check_Duplicate_Property (Prop, AR_Seen); 10366 AR_Val := Expr_Val; 10367 10368 elsif Chars (Prop) = Name_Async_Writers then 10369 Check_Duplicate_Property (Prop, AW_Seen); 10370 AW_Val := Expr_Val; 10371 10372 elsif Chars (Prop) = Name_Effective_Reads then 10373 Check_Duplicate_Property (Prop, ER_Seen); 10374 ER_Val := Expr_Val; 10375 10376 else 10377 Check_Duplicate_Property (Prop, EW_Seen); 10378 EW_Val := Expr_Val; 10379 end if; 10380 10381 -- The handling of property "others" must take into account 10382 -- all other named properties that have been encountered so 10383 -- far. Only those that have not been seen are affected by 10384 -- "others". 10385 10386 else 10387 if not AR_Seen then 10388 AR_Val := Expr_Val; 10389 end if; 10390 10391 if not AW_Seen then 10392 AW_Val := Expr_Val; 10393 end if; 10394 10395 if not ER_Seen then 10396 ER_Val := Expr_Val; 10397 end if; 10398 10399 if not EW_Seen then 10400 EW_Val := Expr_Val; 10401 end if; 10402 end if; 10403 end Analyze_External_Property; 10404 10405 ---------------------------- 10406 -- Analyze_Part_Of_Option -- 10407 ---------------------------- 10408 10409 procedure Analyze_Part_Of_Option (Opt : Node_Id) is 10410 Encap : constant Node_Id := Expression (Opt); 10411 Encap_Id : Entity_Id; 10412 Legal : Boolean; 10413 10414 begin 10415 Check_Duplicate_Option (Opt, Part_Of_Seen); 10416 10417 Analyze_Part_Of 10418 (Indic => First (Choices (Opt)), 10419 Item_Id => State_Id, 10420 Encap => Encap, 10421 Encap_Id => Encap_Id, 10422 Legal => Legal); 10423 10424 -- The Part_Of indicator transforms the abstract state into 10425 -- a constituent of the encapsulating state or single 10426 -- concurrent type. 10427 10428 if Legal then 10429 pragma Assert (Present (Encap_Id)); 10430 10431 Append_Elmt (State_Id, Part_Of_Constituents (Encap_Id)); 10432 Set_Encapsulating_State (State_Id, Encap_Id); 10433 end if; 10434 end Analyze_Part_Of_Option; 10435 10436 ---------------------------- 10437 -- Check_Duplicate_Option -- 10438 ---------------------------- 10439 10440 procedure Check_Duplicate_Option 10441 (Opt : Node_Id; 10442 Status : in out Boolean) 10443 is 10444 begin 10445 if Status then 10446 SPARK_Msg_N ("duplicate state option", Opt); 10447 end if; 10448 10449 Status := True; 10450 end Check_Duplicate_Option; 10451 10452 ------------------------------ 10453 -- Check_Duplicate_Property -- 10454 ------------------------------ 10455 10456 procedure Check_Duplicate_Property 10457 (Prop : Node_Id; 10458 Status : in out Boolean) 10459 is 10460 begin 10461 if Status then 10462 SPARK_Msg_N ("duplicate external property", Prop); 10463 end if; 10464 10465 Status := True; 10466 end Check_Duplicate_Property; 10467 10468 ----------------------------- 10469 -- Check_Ghost_Synchronous -- 10470 ----------------------------- 10471 10472 procedure Check_Ghost_Synchronous is 10473 begin 10474 -- A synchronized abstract state cannot be Ghost and vice 10475 -- versa (SPARK RM 6.9(19)). 10476 10477 if Ghost_Seen and Synchronous_Seen then 10478 SPARK_Msg_N ("synchronized state cannot be ghost", State); 10479 end if; 10480 end Check_Ghost_Synchronous; 10481 10482 --------------------------- 10483 -- Create_Abstract_State -- 10484 --------------------------- 10485 10486 procedure Create_Abstract_State 10487 (Nam : Name_Id; 10488 Decl : Node_Id; 10489 Loc : Source_Ptr; 10490 Is_Null : Boolean) 10491 is 10492 begin 10493 -- The abstract state may be semi-declared when the related 10494 -- package was withed through a limited with clause. In that 10495 -- case reuse the entity to fully declare the state. 10496 10497 if Present (Decl) and then Present (Entity (Decl)) then 10498 State_Id := Entity (Decl); 10499 10500 -- Otherwise the elaboration of pragma Abstract_State 10501 -- declares the state. 10502 10503 else 10504 State_Id := Make_Defining_Identifier (Loc, Nam); 10505 10506 if Present (Decl) then 10507 Set_Entity (Decl, State_Id); 10508 end if; 10509 end if; 10510 10511 -- Null states never come from source 10512 10513 Set_Comes_From_Source (State_Id, not Is_Null); 10514 Set_Parent (State_Id, State); 10515 Set_Ekind (State_Id, E_Abstract_State); 10516 Set_Etype (State_Id, Standard_Void_Type); 10517 Set_Encapsulating_State (State_Id, Empty); 10518 Set_Refinement_Constituents (State_Id, New_Elmt_List); 10519 Set_Part_Of_Constituents (State_Id, New_Elmt_List); 10520 10521 -- An abstract state declared within a Ghost region becomes 10522 -- Ghost (SPARK RM 6.9(2)). 10523 10524 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then 10525 Set_Is_Ghost_Entity (State_Id); 10526 end if; 10527 10528 -- Establish a link between the state declaration and the 10529 -- abstract state entity. Note that a null state remains as 10530 -- N_Null and does not carry any linkages. 10531 10532 if not Is_Null then 10533 if Present (Decl) then 10534 Set_Entity (Decl, State_Id); 10535 Set_Etype (Decl, Standard_Void_Type); 10536 end if; 10537 10538 -- Every non-null state must be defined, nameable and 10539 -- resolvable. 10540 10541 Push_Scope (Pack_Id); 10542 Generate_Definition (State_Id); 10543 Enter_Name (State_Id); 10544 Pop_Scope; 10545 end if; 10546 end Create_Abstract_State; 10547 10548 -- Local variables 10549 10550 Opt : Node_Id; 10551 Opt_Nam : Node_Id; 10552 10553 -- Start of processing for Analyze_Abstract_State 10554 10555 begin 10556 -- A package with a null abstract state is not allowed to 10557 -- declare additional states. 10558 10559 if Null_Seen then 10560 SPARK_Msg_NE 10561 ("package & has null abstract state", State, Pack_Id); 10562 10563 -- Null states appear as internally generated entities 10564 10565 elsif Nkind (State) = N_Null then 10566 Create_Abstract_State 10567 (Nam => New_Internal_Name ('S'), 10568 Decl => Empty, 10569 Loc => Sloc (State), 10570 Is_Null => True); 10571 Null_Seen := True; 10572 10573 -- Catch a case where a null state appears in a list of 10574 -- non-null states. 10575 10576 if Non_Null_Seen then 10577 SPARK_Msg_NE 10578 ("package & has non-null abstract state", 10579 State, Pack_Id); 10580 end if; 10581 10582 -- Simple state declaration 10583 10584 elsif Nkind (State) = N_Identifier then 10585 Create_Abstract_State 10586 (Nam => Chars (State), 10587 Decl => State, 10588 Loc => Sloc (State), 10589 Is_Null => False); 10590 Non_Null_Seen := True; 10591 10592 -- State declaration with various options. This construct 10593 -- appears as an extension aggregate in the tree. 10594 10595 elsif Nkind (State) = N_Extension_Aggregate then 10596 if Nkind (Ancestor_Part (State)) = N_Identifier then 10597 Create_Abstract_State 10598 (Nam => Chars (Ancestor_Part (State)), 10599 Decl => Ancestor_Part (State), 10600 Loc => Sloc (Ancestor_Part (State)), 10601 Is_Null => False); 10602 Non_Null_Seen := True; 10603 else 10604 SPARK_Msg_N 10605 ("state name must be an identifier", 10606 Ancestor_Part (State)); 10607 end if; 10608 10609 -- Options External, Ghost and Synchronous appear as 10610 -- expressions. 10611 10612 Opt := First (Expressions (State)); 10613 while Present (Opt) loop 10614 if Nkind (Opt) = N_Identifier then 10615 10616 -- External 10617 10618 if Chars (Opt) = Name_External then 10619 Check_Duplicate_Option (Opt, External_Seen); 10620 Analyze_External_Option (Opt); 10621 10622 -- Ghost 10623 10624 elsif Chars (Opt) = Name_Ghost then 10625 Check_Duplicate_Option (Opt, Ghost_Seen); 10626 Check_Ghost_Synchronous; 10627 10628 if Present (State_Id) then 10629 Set_Is_Ghost_Entity (State_Id); 10630 end if; 10631 10632 -- Synchronous 10633 10634 elsif Chars (Opt) = Name_Synchronous then 10635 Check_Duplicate_Option (Opt, Synchronous_Seen); 10636 Check_Ghost_Synchronous; 10637 10638 -- Option Part_Of without an encapsulating state is 10639 -- illegal (SPARK RM 7.1.4(9)). 10640 10641 elsif Chars (Opt) = Name_Part_Of then 10642 SPARK_Msg_N 10643 ("indicator Part_Of must denote abstract state, " 10644 & "single protected type or single task type", 10645 Opt); 10646 10647 -- Do not emit an error message when a previous state 10648 -- declaration with options was not parenthesized as 10649 -- the option is actually another state declaration. 10650 -- 10651 -- with Abstract_State 10652 -- (State_1 with ..., -- missing parentheses 10653 -- (State_2 with ...), 10654 -- State_3) -- ok state declaration 10655 10656 elsif Missing_Parentheses then 10657 null; 10658 10659 -- Otherwise the option is not allowed. Note that it 10660 -- is not possible to distinguish between an option 10661 -- and a state declaration when a previous state with 10662 -- options not properly parentheses. 10663 -- 10664 -- with Abstract_State 10665 -- (State_1 with ..., -- missing parentheses 10666 -- State_2); -- could be an option 10667 10668 else 10669 SPARK_Msg_N 10670 ("simple option not allowed in state declaration", 10671 Opt); 10672 end if; 10673 10674 -- Catch a case where missing parentheses around a state 10675 -- declaration with options cause a subsequent state 10676 -- declaration with options to be treated as an option. 10677 -- 10678 -- with Abstract_State 10679 -- (State_1 with ..., -- missing parentheses 10680 -- (State_2 with ...)) 10681 10682 elsif Nkind (Opt) = N_Extension_Aggregate then 10683 Missing_Parentheses := True; 10684 SPARK_Msg_N 10685 ("state declaration must be parenthesized", 10686 Ancestor_Part (State)); 10687 10688 -- Otherwise the option is malformed 10689 10690 else 10691 SPARK_Msg_N ("malformed option", Opt); 10692 end if; 10693 10694 Next (Opt); 10695 end loop; 10696 10697 -- Options External and Part_Of appear as component 10698 -- associations. 10699 10700 Opt := First (Component_Associations (State)); 10701 while Present (Opt) loop 10702 Opt_Nam := First (Choices (Opt)); 10703 10704 if Nkind (Opt_Nam) = N_Identifier then 10705 if Chars (Opt_Nam) = Name_External then 10706 Analyze_External_Option (Opt); 10707 10708 elsif Chars (Opt_Nam) = Name_Part_Of then 10709 Analyze_Part_Of_Option (Opt); 10710 10711 else 10712 SPARK_Msg_N ("invalid state option", Opt); 10713 end if; 10714 else 10715 SPARK_Msg_N ("invalid state option", Opt); 10716 end if; 10717 10718 Next (Opt); 10719 end loop; 10720 10721 -- Any other attempt to declare a state is illegal 10722 10723 else 10724 Malformed_State_Error (State); 10725 return; 10726 end if; 10727 10728 -- Guard against a junk state. In such cases no entity is 10729 -- generated and the subsequent checks cannot be applied. 10730 10731 if Present (State_Id) then 10732 10733 -- Verify whether the state does not introduce an illegal 10734 -- hidden state within a package subject to a null abstract 10735 -- state. 10736 10737 Check_No_Hidden_State (State_Id); 10738 10739 -- Check whether the lack of option Part_Of agrees with the 10740 -- placement of the abstract state with respect to the state 10741 -- space. 10742 10743 if not Part_Of_Seen then 10744 Check_Missing_Part_Of (State_Id); 10745 end if; 10746 10747 -- Associate the state with its related package 10748 10749 if No (Abstract_States (Pack_Id)) then 10750 Set_Abstract_States (Pack_Id, New_Elmt_List); 10751 end if; 10752 10753 Append_Elmt (State_Id, Abstract_States (Pack_Id)); 10754 end if; 10755 end Analyze_Abstract_State; 10756 10757 --------------------------- 10758 -- Malformed_State_Error -- 10759 --------------------------- 10760 10761 procedure Malformed_State_Error (State : Node_Id) is 10762 begin 10763 Error_Msg_N ("malformed abstract state declaration", State); 10764 10765 -- An abstract state with a simple option is being declared 10766 -- with "=>" rather than the legal "with". The state appears 10767 -- as a component association. 10768 10769 if Nkind (State) = N_Component_Association then 10770 Error_Msg_N ("\use WITH to specify simple option", State); 10771 end if; 10772 end Malformed_State_Error; 10773 10774 -- Local variables 10775 10776 Pack_Decl : Node_Id; 10777 Pack_Id : Entity_Id; 10778 State : Node_Id; 10779 States : Node_Id; 10780 10781 -- Start of processing for Abstract_State 10782 10783 begin 10784 GNAT_Pragma; 10785 Check_No_Identifiers; 10786 Check_Arg_Count (1); 10787 10788 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 10789 10790 -- Ensure the proper placement of the pragma. Abstract states must 10791 -- be associated with a package declaration. 10792 10793 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 10794 N_Package_Declaration) 10795 then 10796 null; 10797 10798 -- Otherwise the pragma is associated with an illegal construct 10799 10800 else 10801 Pragma_Misplaced; 10802 return; 10803 end if; 10804 10805 Pack_Id := Defining_Entity (Pack_Decl); 10806 10807 -- Chain the pragma on the contract for completeness 10808 10809 Add_Contract_Item (N, Pack_Id); 10810 10811 -- The legality checks of pragmas Abstract_State, Initializes, and 10812 -- Initial_Condition are affected by the SPARK mode in effect. In 10813 -- addition, these three pragmas are subject to an inherent order: 10814 10815 -- 1) Abstract_State 10816 -- 2) Initializes 10817 -- 3) Initial_Condition 10818 10819 -- Analyze all these pragmas in the order outlined above 10820 10821 Analyze_If_Present (Pragma_SPARK_Mode); 10822 10823 -- A pragma that applies to a Ghost entity becomes Ghost for the 10824 -- purposes of legality checks and removal of ignored Ghost code. 10825 10826 Mark_Pragma_As_Ghost (N, Pack_Id); 10827 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id)); 10828 10829 States := Expression (Get_Argument (N, Pack_Id)); 10830 10831 -- Multiple non-null abstract states appear as an aggregate 10832 10833 if Nkind (States) = N_Aggregate then 10834 State := First (Expressions (States)); 10835 while Present (State) loop 10836 Analyze_Abstract_State (State, Pack_Id); 10837 Next (State); 10838 end loop; 10839 10840 -- An abstract state with a simple option is being illegaly 10841 -- declared with "=>" rather than "with". In this case the 10842 -- state declaration appears as a component association. 10843 10844 if Present (Component_Associations (States)) then 10845 State := First (Component_Associations (States)); 10846 while Present (State) loop 10847 Malformed_State_Error (State); 10848 Next (State); 10849 end loop; 10850 end if; 10851 10852 -- Various forms of a single abstract state. Note that these may 10853 -- include malformed state declarations. 10854 10855 else 10856 Analyze_Abstract_State (States, Pack_Id); 10857 end if; 10858 10859 Analyze_If_Present (Pragma_Initializes); 10860 Analyze_If_Present (Pragma_Initial_Condition); 10861 end Abstract_State; 10862 10863 ------------ 10864 -- Ada_83 -- 10865 ------------ 10866 10867 -- pragma Ada_83; 10868 10869 -- Note: this pragma also has some specific processing in Par.Prag 10870 -- because we want to set the Ada version mode during parsing. 10871 10872 when Pragma_Ada_83 => 10873 GNAT_Pragma; 10874 Check_Arg_Count (0); 10875 10876 -- We really should check unconditionally for proper configuration 10877 -- pragma placement, since we really don't want mixed Ada modes 10878 -- within a single unit, and the GNAT reference manual has always 10879 -- said this was a configuration pragma, but we did not check and 10880 -- are hesitant to add the check now. 10881 10882 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 10883 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 10884 -- or Ada 2012 mode. 10885 10886 if Ada_Version >= Ada_2005 then 10887 Check_Valid_Configuration_Pragma; 10888 end if; 10889 10890 -- Now set Ada 83 mode 10891 10892 Ada_Version := Ada_83; 10893 Ada_Version_Explicit := Ada_83; 10894 Ada_Version_Pragma := N; 10895 10896 ------------ 10897 -- Ada_95 -- 10898 ------------ 10899 10900 -- pragma Ada_95; 10901 10902 -- Note: this pragma also has some specific processing in Par.Prag 10903 -- because we want to set the Ada 83 version mode during parsing. 10904 10905 when Pragma_Ada_95 => 10906 GNAT_Pragma; 10907 Check_Arg_Count (0); 10908 10909 -- We really should check unconditionally for proper configuration 10910 -- pragma placement, since we really don't want mixed Ada modes 10911 -- within a single unit, and the GNAT reference manual has always 10912 -- said this was a configuration pragma, but we did not check and 10913 -- are hesitant to add the check now. 10914 10915 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 10916 -- or Ada 95, so we must check if we are in Ada 2005 mode. 10917 10918 if Ada_Version >= Ada_2005 then 10919 Check_Valid_Configuration_Pragma; 10920 end if; 10921 10922 -- Now set Ada 95 mode 10923 10924 Ada_Version := Ada_95; 10925 Ada_Version_Explicit := Ada_95; 10926 Ada_Version_Pragma := N; 10927 10928 --------------------- 10929 -- Ada_05/Ada_2005 -- 10930 --------------------- 10931 10932 -- pragma Ada_05; 10933 -- pragma Ada_05 (LOCAL_NAME); 10934 10935 -- pragma Ada_2005; 10936 -- pragma Ada_2005 (LOCAL_NAME): 10937 10938 -- Note: these pragmas also have some specific processing in Par.Prag 10939 -- because we want to set the Ada 2005 version mode during parsing. 10940 10941 -- The one argument form is used for managing the transition from 10942 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked 10943 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95 10944 -- mode will generate a warning. In addition, in Ada_83 or Ada_95 10945 -- mode, a preference rule is established which does not choose 10946 -- such an entity unless it is unambiguously specified. This avoids 10947 -- extra subprograms marked this way from generating ambiguities in 10948 -- otherwise legal pre-Ada_2005 programs. The one argument form is 10949 -- intended for exclusive use in the GNAT run-time library. 10950 10951 when Pragma_Ada_05 | Pragma_Ada_2005 => declare 10952 E_Id : Node_Id; 10953 10954 begin 10955 GNAT_Pragma; 10956 10957 if Arg_Count = 1 then 10958 Check_Arg_Is_Local_Name (Arg1); 10959 E_Id := Get_Pragma_Arg (Arg1); 10960 10961 if Etype (E_Id) = Any_Type then 10962 return; 10963 end if; 10964 10965 Set_Is_Ada_2005_Only (Entity (E_Id)); 10966 Record_Rep_Item (Entity (E_Id), N); 10967 10968 else 10969 Check_Arg_Count (0); 10970 10971 -- For Ada_2005 we unconditionally enforce the documented 10972 -- configuration pragma placement, since we do not want to 10973 -- tolerate mixed modes in a unit involving Ada 2005. That 10974 -- would cause real difficulties for those cases where there 10975 -- are incompatibilities between Ada 95 and Ada 2005. 10976 10977 Check_Valid_Configuration_Pragma; 10978 10979 -- Now set appropriate Ada mode 10980 10981 Ada_Version := Ada_2005; 10982 Ada_Version_Explicit := Ada_2005; 10983 Ada_Version_Pragma := N; 10984 end if; 10985 end; 10986 10987 --------------------- 10988 -- Ada_12/Ada_2012 -- 10989 --------------------- 10990 10991 -- pragma Ada_12; 10992 -- pragma Ada_12 (LOCAL_NAME); 10993 10994 -- pragma Ada_2012; 10995 -- pragma Ada_2012 (LOCAL_NAME): 10996 10997 -- Note: these pragmas also have some specific processing in Par.Prag 10998 -- because we want to set the Ada 2012 version mode during parsing. 10999 11000 -- The one argument form is used for managing the transition from Ada 11001 -- 2005 to Ada 2012 in the run-time library. If an entity is marked 11002 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012 11003 -- mode will generate a warning. In addition, in any pre-Ada_2012 11004 -- mode, a preference rule is established which does not choose 11005 -- such an entity unless it is unambiguously specified. This avoids 11006 -- extra subprograms marked this way from generating ambiguities in 11007 -- otherwise legal pre-Ada_2012 programs. The one argument form is 11008 -- intended for exclusive use in the GNAT run-time library. 11009 11010 when Pragma_Ada_12 | Pragma_Ada_2012 => declare 11011 E_Id : Node_Id; 11012 11013 begin 11014 GNAT_Pragma; 11015 11016 if Arg_Count = 1 then 11017 Check_Arg_Is_Local_Name (Arg1); 11018 E_Id := Get_Pragma_Arg (Arg1); 11019 11020 if Etype (E_Id) = Any_Type then 11021 return; 11022 end if; 11023 11024 Set_Is_Ada_2012_Only (Entity (E_Id)); 11025 Record_Rep_Item (Entity (E_Id), N); 11026 11027 else 11028 Check_Arg_Count (0); 11029 11030 -- For Ada_2012 we unconditionally enforce the documented 11031 -- configuration pragma placement, since we do not want to 11032 -- tolerate mixed modes in a unit involving Ada 2012. That 11033 -- would cause real difficulties for those cases where there 11034 -- are incompatibilities between Ada 95 and Ada 2012. We could 11035 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. 11036 11037 Check_Valid_Configuration_Pragma; 11038 11039 -- Now set appropriate Ada mode 11040 11041 Ada_Version := Ada_2012; 11042 Ada_Version_Explicit := Ada_2012; 11043 Ada_Version_Pragma := N; 11044 end if; 11045 end; 11046 11047 ---------------------- 11048 -- All_Calls_Remote -- 11049 ---------------------- 11050 11051 -- pragma All_Calls_Remote [(library_package_NAME)]; 11052 11053 when Pragma_All_Calls_Remote => All_Calls_Remote : declare 11054 Lib_Entity : Entity_Id; 11055 11056 begin 11057 Check_Ada_83_Warning; 11058 Check_Valid_Library_Unit_Pragma; 11059 11060 if Nkind (N) = N_Null_Statement then 11061 return; 11062 end if; 11063 11064 Lib_Entity := Find_Lib_Unit_Name; 11065 11066 -- A pragma that applies to a Ghost entity becomes Ghost for the 11067 -- purposes of legality checks and removal of ignored Ghost code. 11068 11069 Mark_Pragma_As_Ghost (N, Lib_Entity); 11070 11071 -- This pragma should only apply to a RCI unit (RM E.2.3(23)) 11072 11073 if Present (Lib_Entity) and then not Debug_Flag_U then 11074 if not Is_Remote_Call_Interface (Lib_Entity) then 11075 Error_Pragma ("pragma% only apply to rci unit"); 11076 11077 -- Set flag for entity of the library unit 11078 11079 else 11080 Set_Has_All_Calls_Remote (Lib_Entity); 11081 end if; 11082 end if; 11083 end All_Calls_Remote; 11084 11085 --------------------------- 11086 -- Allow_Integer_Address -- 11087 --------------------------- 11088 11089 -- pragma Allow_Integer_Address; 11090 11091 when Pragma_Allow_Integer_Address => 11092 GNAT_Pragma; 11093 Check_Valid_Configuration_Pragma; 11094 Check_Arg_Count (0); 11095 11096 -- If Address is a private type, then set the flag to allow 11097 -- integer address values. If Address is not private, then this 11098 -- pragma has no purpose, so it is simply ignored. Not clear if 11099 -- there are any such targets now. 11100 11101 if Opt.Address_Is_Private then 11102 Opt.Allow_Integer_Address := True; 11103 end if; 11104 11105 -------------- 11106 -- Annotate -- 11107 -------------- 11108 11109 -- pragma Annotate 11110 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]); 11111 -- ARG ::= NAME | EXPRESSION 11112 11113 -- The first two arguments are by convention intended to refer to an 11114 -- external tool and a tool-specific function. These arguments are 11115 -- not analyzed. 11116 11117 when Pragma_Annotate => Annotate : declare 11118 Arg : Node_Id; 11119 Expr : Node_Id; 11120 Nam_Arg : Node_Id; 11121 11122 begin 11123 GNAT_Pragma; 11124 Check_At_Least_N_Arguments (1); 11125 11126 Nam_Arg := Last (Pragma_Argument_Associations (N)); 11127 11128 -- Determine whether the last argument is "Entity => local_NAME" 11129 -- and if it is, perform the required semantic checks. Remove the 11130 -- argument from further processing. 11131 11132 if Nkind (Nam_Arg) = N_Pragma_Argument_Association 11133 and then Chars (Nam_Arg) = Name_Entity 11134 then 11135 Check_Arg_Is_Local_Name (Nam_Arg); 11136 Arg_Count := Arg_Count - 1; 11137 11138 -- A pragma that applies to a Ghost entity becomes Ghost for 11139 -- the purposes of legality checks and removal of ignored Ghost 11140 -- code. 11141 11142 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg)) 11143 and then Present (Entity (Get_Pragma_Arg (Nam_Arg))) 11144 then 11145 Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg))); 11146 end if; 11147 11148 -- Not allowed in compiler units (bootstrap issues) 11149 11150 Check_Compiler_Unit ("Entity for pragma Annotate", N); 11151 end if; 11152 11153 -- Continue the processing with last argument removed for now 11154 11155 Check_Arg_Is_Identifier (Arg1); 11156 Check_No_Identifiers; 11157 Store_Note (N); 11158 11159 -- The second parameter is optional, it is never analyzed 11160 11161 if No (Arg2) then 11162 null; 11163 11164 -- Otherwise there is a second parameter 11165 11166 else 11167 -- The second parameter must be an identifier 11168 11169 Check_Arg_Is_Identifier (Arg2); 11170 11171 -- Process the remaining parameters (if any) 11172 11173 Arg := Next (Arg2); 11174 while Present (Arg) loop 11175 Expr := Get_Pragma_Arg (Arg); 11176 Analyze (Expr); 11177 11178 if Is_Entity_Name (Expr) then 11179 null; 11180 11181 -- For string literals, we assume Standard_String as the 11182 -- type, unless the string contains wide or wide_wide 11183 -- characters. 11184 11185 elsif Nkind (Expr) = N_String_Literal then 11186 if Has_Wide_Wide_Character (Expr) then 11187 Resolve (Expr, Standard_Wide_Wide_String); 11188 elsif Has_Wide_Character (Expr) then 11189 Resolve (Expr, Standard_Wide_String); 11190 else 11191 Resolve (Expr, Standard_String); 11192 end if; 11193 11194 elsif Is_Overloaded (Expr) then 11195 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr); 11196 11197 else 11198 Resolve (Expr); 11199 end if; 11200 11201 Next (Arg); 11202 end loop; 11203 end if; 11204 end Annotate; 11205 11206 ------------------------------------------------- 11207 -- Assert/Assert_And_Cut/Assume/Loop_Invariant -- 11208 ------------------------------------------------- 11209 11210 -- pragma Assert 11211 -- ( [Check => ] Boolean_EXPRESSION 11212 -- [, [Message =>] Static_String_EXPRESSION]); 11213 11214 -- pragma Assert_And_Cut 11215 -- ( [Check => ] Boolean_EXPRESSION 11216 -- [, [Message =>] Static_String_EXPRESSION]); 11217 11218 -- pragma Assume 11219 -- ( [Check => ] Boolean_EXPRESSION 11220 -- [, [Message =>] Static_String_EXPRESSION]); 11221 11222 -- pragma Loop_Invariant 11223 -- ( [Check => ] Boolean_EXPRESSION 11224 -- [, [Message =>] Static_String_EXPRESSION]); 11225 11226 when Pragma_Assert | 11227 Pragma_Assert_And_Cut | 11228 Pragma_Assume | 11229 Pragma_Loop_Invariant => 11230 Assert : declare 11231 function Contains_Loop_Entry (Expr : Node_Id) return Boolean; 11232 -- Determine whether expression Expr contains a Loop_Entry 11233 -- attribute reference. 11234 11235 ------------------------- 11236 -- Contains_Loop_Entry -- 11237 ------------------------- 11238 11239 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is 11240 Has_Loop_Entry : Boolean := False; 11241 11242 function Process (N : Node_Id) return Traverse_Result; 11243 -- Process function for traversal to look for Loop_Entry 11244 11245 ------------- 11246 -- Process -- 11247 ------------- 11248 11249 function Process (N : Node_Id) return Traverse_Result is 11250 begin 11251 if Nkind (N) = N_Attribute_Reference 11252 and then Attribute_Name (N) = Name_Loop_Entry 11253 then 11254 Has_Loop_Entry := True; 11255 return Abandon; 11256 else 11257 return OK; 11258 end if; 11259 end Process; 11260 11261 procedure Traverse is new Traverse_Proc (Process); 11262 11263 -- Start of processing for Contains_Loop_Entry 11264 11265 begin 11266 Traverse (Expr); 11267 return Has_Loop_Entry; 11268 end Contains_Loop_Entry; 11269 11270 -- Local variables 11271 11272 Expr : Node_Id; 11273 New_Args : List_Id; 11274 11275 -- Start of processing for Assert 11276 11277 begin 11278 -- Assert is an Ada 2005 RM-defined pragma 11279 11280 if Prag_Id = Pragma_Assert then 11281 Ada_2005_Pragma; 11282 11283 -- The remaining ones are GNAT pragmas 11284 11285 else 11286 GNAT_Pragma; 11287 end if; 11288 11289 Check_At_Least_N_Arguments (1); 11290 Check_At_Most_N_Arguments (2); 11291 Check_Arg_Order ((Name_Check, Name_Message)); 11292 Check_Optional_Identifier (Arg1, Name_Check); 11293 Expr := Get_Pragma_Arg (Arg1); 11294 11295 -- Special processing for Loop_Invariant, Loop_Variant or for 11296 -- other cases where a Loop_Entry attribute is present. If the 11297 -- assertion pragma contains attribute Loop_Entry, ensure that 11298 -- the related pragma is within a loop. 11299 11300 if Prag_Id = Pragma_Loop_Invariant 11301 or else Prag_Id = Pragma_Loop_Variant 11302 or else Contains_Loop_Entry (Expr) 11303 then 11304 Check_Loop_Pragma_Placement; 11305 11306 -- Perform preanalysis to deal with embedded Loop_Entry 11307 -- attributes. 11308 11309 Preanalyze_Assert_Expression (Expr, Any_Boolean); 11310 end if; 11311 11312 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating 11313 -- a corresponding Check pragma: 11314 11315 -- pragma Check (name, condition [, msg]); 11316 11317 -- Where name is the identifier matching the pragma name. So 11318 -- rewrite pragma in this manner, transfer the message argument 11319 -- if present, and analyze the result 11320 11321 -- Note: When dealing with a semantically analyzed tree, the 11322 -- information that a Check node N corresponds to a source Assert, 11323 -- Assume, or Assert_And_Cut pragma can be retrieved from the 11324 -- pragma kind of Original_Node(N). 11325 11326 New_Args := New_List ( 11327 Make_Pragma_Argument_Association (Loc, 11328 Expression => Make_Identifier (Loc, Pname)), 11329 Make_Pragma_Argument_Association (Sloc (Expr), 11330 Expression => Expr)); 11331 11332 if Arg_Count > 1 then 11333 Check_Optional_Identifier (Arg2, Name_Message); 11334 11335 -- Provide semantic annnotations for optional argument, for 11336 -- ASIS use, before rewriting. 11337 11338 Preanalyze_And_Resolve (Expression (Arg2), Standard_String); 11339 Append_To (New_Args, New_Copy_Tree (Arg2)); 11340 end if; 11341 11342 -- Rewrite as Check pragma 11343 11344 Rewrite (N, 11345 Make_Pragma (Loc, 11346 Chars => Name_Check, 11347 Pragma_Argument_Associations => New_Args)); 11348 11349 Analyze (N); 11350 end Assert; 11351 11352 ---------------------- 11353 -- Assertion_Policy -- 11354 ---------------------- 11355 11356 -- pragma Assertion_Policy (POLICY_IDENTIFIER); 11357 11358 -- The following form is Ada 2012 only, but we allow it in all modes 11359 11360 -- Pragma Assertion_Policy ( 11361 -- ASSERTION_KIND => POLICY_IDENTIFIER 11362 -- {, ASSERTION_KIND => POLICY_IDENTIFIER}); 11363 11364 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND 11365 11366 -- RM_ASSERTION_KIND ::= Assert | 11367 -- Static_Predicate | 11368 -- Dynamic_Predicate | 11369 -- Pre | 11370 -- Pre'Class | 11371 -- Post | 11372 -- Post'Class | 11373 -- Type_Invariant | 11374 -- Type_Invariant'Class 11375 11376 -- ID_ASSERTION_KIND ::= Assert_And_Cut | 11377 -- Assume | 11378 -- Contract_Cases | 11379 -- Debug | 11380 -- Default_Initial_Condition | 11381 -- Ghost | 11382 -- Initial_Condition | 11383 -- Loop_Invariant | 11384 -- Loop_Variant | 11385 -- Postcondition | 11386 -- Precondition | 11387 -- Predicate | 11388 -- Refined_Post | 11389 -- Statement_Assertions 11390 11391 -- Note: The RM_ASSERTION_KIND list is language-defined, and the 11392 -- ID_ASSERTION_KIND list contains implementation-defined additions 11393 -- recognized by GNAT. The effect is to control the behavior of 11394 -- identically named aspects and pragmas, depending on the specified 11395 -- policy identifier: 11396 11397 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore 11398 11399 -- Note: Check and Ignore are language-defined. Disable is a GNAT 11400 -- implementation-defined addition that results in totally ignoring 11401 -- the corresponding assertion. If Disable is specified, then the 11402 -- argument of the assertion is not even analyzed. This is useful 11403 -- when the aspect/pragma argument references entities in a with'ed 11404 -- package that is replaced by a dummy package in the final build. 11405 11406 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class, 11407 -- and Type_Invariant'Class were recognized by the parser and 11408 -- transformed into references to the special internal identifiers 11409 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special 11410 -- processing is required here. 11411 11412 when Pragma_Assertion_Policy => Assertion_Policy : declare 11413 Arg : Node_Id; 11414 Kind : Name_Id; 11415 LocP : Source_Ptr; 11416 Policy : Node_Id; 11417 11418 begin 11419 Ada_2005_Pragma; 11420 11421 -- This can always appear as a configuration pragma 11422 11423 if Is_Configuration_Pragma then 11424 null; 11425 11426 -- It can also appear in a declarative part or package spec in Ada 11427 -- 2012 mode. We allow this in other modes, but in that case we 11428 -- consider that we have an Ada 2012 pragma on our hands. 11429 11430 else 11431 Check_Is_In_Decl_Part_Or_Package_Spec; 11432 Ada_2012_Pragma; 11433 end if; 11434 11435 -- One argument case with no identifier (first form above) 11436 11437 if Arg_Count = 1 11438 and then (Nkind (Arg1) /= N_Pragma_Argument_Association 11439 or else Chars (Arg1) = No_Name) 11440 then 11441 Check_Arg_Is_One_Of 11442 (Arg1, Name_Check, Name_Disable, Name_Ignore); 11443 11444 -- Treat one argument Assertion_Policy as equivalent to: 11445 11446 -- pragma Check_Policy (Assertion, policy) 11447 11448 -- So rewrite pragma in that manner and link on to the chain 11449 -- of Check_Policy pragmas, marking the pragma as analyzed. 11450 11451 Policy := Get_Pragma_Arg (Arg1); 11452 11453 Rewrite (N, 11454 Make_Pragma (Loc, 11455 Chars => Name_Check_Policy, 11456 Pragma_Argument_Associations => New_List ( 11457 Make_Pragma_Argument_Association (Loc, 11458 Expression => Make_Identifier (Loc, Name_Assertion)), 11459 11460 Make_Pragma_Argument_Association (Loc, 11461 Expression => 11462 Make_Identifier (Sloc (Policy), Chars (Policy)))))); 11463 Analyze (N); 11464 11465 -- Here if we have two or more arguments 11466 11467 else 11468 Check_At_Least_N_Arguments (1); 11469 Ada_2012_Pragma; 11470 11471 -- Loop through arguments 11472 11473 Arg := Arg1; 11474 while Present (Arg) loop 11475 LocP := Sloc (Arg); 11476 11477 -- Kind must be specified 11478 11479 if Nkind (Arg) /= N_Pragma_Argument_Association 11480 or else Chars (Arg) = No_Name 11481 then 11482 Error_Pragma_Arg 11483 ("missing assertion kind for pragma%", Arg); 11484 end if; 11485 11486 -- Check Kind and Policy have allowed forms 11487 11488 Kind := Chars (Arg); 11489 11490 if not Is_Valid_Assertion_Kind (Kind) then 11491 Error_Pragma_Arg 11492 ("invalid assertion kind for pragma%", Arg); 11493 end if; 11494 11495 Check_Arg_Is_One_Of 11496 (Arg, Name_Check, Name_Disable, Name_Ignore); 11497 11498 -- Rewrite the Assertion_Policy pragma as a series of 11499 -- Check_Policy pragmas of the form: 11500 11501 -- Check_Policy (Kind, Policy); 11502 11503 -- Note: the insertion of the pragmas cannot be done with 11504 -- Insert_Action because in the configuration case, there 11505 -- are no scopes on the scope stack and the mechanism will 11506 -- fail. 11507 11508 Insert_Before_And_Analyze (N, 11509 Make_Pragma (LocP, 11510 Chars => Name_Check_Policy, 11511 Pragma_Argument_Associations => New_List ( 11512 Make_Pragma_Argument_Association (LocP, 11513 Expression => Make_Identifier (LocP, Kind)), 11514 Make_Pragma_Argument_Association (LocP, 11515 Expression => Get_Pragma_Arg (Arg))))); 11516 11517 Arg := Next (Arg); 11518 end loop; 11519 11520 -- Rewrite the Assertion_Policy pragma as null since we have 11521 -- now inserted all the equivalent Check pragmas. 11522 11523 Rewrite (N, Make_Null_Statement (Loc)); 11524 Analyze (N); 11525 end if; 11526 end Assertion_Policy; 11527 11528 ------------------------------ 11529 -- Assume_No_Invalid_Values -- 11530 ------------------------------ 11531 11532 -- pragma Assume_No_Invalid_Values (On | Off); 11533 11534 when Pragma_Assume_No_Invalid_Values => 11535 GNAT_Pragma; 11536 Check_Valid_Configuration_Pragma; 11537 Check_Arg_Count (1); 11538 Check_No_Identifiers; 11539 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 11540 11541 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 11542 Assume_No_Invalid_Values := True; 11543 else 11544 Assume_No_Invalid_Values := False; 11545 end if; 11546 11547 -------------------------- 11548 -- Attribute_Definition -- 11549 -------------------------- 11550 11551 -- pragma Attribute_Definition 11552 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, 11553 -- [Entity =>] LOCAL_NAME, 11554 -- [Expression =>] EXPRESSION | NAME); 11555 11556 when Pragma_Attribute_Definition => Attribute_Definition : declare 11557 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); 11558 Aname : Name_Id; 11559 11560 begin 11561 GNAT_Pragma; 11562 Check_Arg_Count (3); 11563 Check_Optional_Identifier (Arg1, "attribute"); 11564 Check_Optional_Identifier (Arg2, "entity"); 11565 Check_Optional_Identifier (Arg3, "expression"); 11566 11567 if Nkind (Attribute_Designator) /= N_Identifier then 11568 Error_Msg_N ("attribute name expected", Attribute_Designator); 11569 return; 11570 end if; 11571 11572 Check_Arg_Is_Local_Name (Arg2); 11573 11574 -- If the attribute is not recognized, then issue a warning (not 11575 -- an error), and ignore the pragma. 11576 11577 Aname := Chars (Attribute_Designator); 11578 11579 if not Is_Attribute_Name (Aname) then 11580 Bad_Attribute (Attribute_Designator, Aname, Warn => True); 11581 return; 11582 end if; 11583 11584 -- Otherwise, rewrite the pragma as an attribute definition clause 11585 11586 Rewrite (N, 11587 Make_Attribute_Definition_Clause (Loc, 11588 Name => Get_Pragma_Arg (Arg2), 11589 Chars => Aname, 11590 Expression => Get_Pragma_Arg (Arg3))); 11591 Analyze (N); 11592 end Attribute_Definition; 11593 11594 ------------------------------------------------------------------ 11595 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- 11596 ------------------------------------------------------------------ 11597 11598 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ]; 11599 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ]; 11600 -- pragma Effective_Reads [ (boolean_EXPRESSION) ]; 11601 -- pragma Effective_Writes [ (boolean_EXPRESSION) ]; 11602 11603 when Pragma_Async_Readers | 11604 Pragma_Async_Writers | 11605 Pragma_Effective_Reads | 11606 Pragma_Effective_Writes => 11607 Async_Effective : declare 11608 Obj_Decl : Node_Id; 11609 Obj_Id : Entity_Id; 11610 11611 begin 11612 GNAT_Pragma; 11613 Check_No_Identifiers; 11614 Check_At_Most_N_Arguments (1); 11615 11616 Obj_Decl := Find_Related_Context (N, Do_Checks => True); 11617 11618 -- Object declaration 11619 11620 if Nkind (Obj_Decl) = N_Object_Declaration then 11621 null; 11622 11623 -- Otherwise the pragma is associated with an illegal construact 11624 11625 else 11626 Pragma_Misplaced; 11627 return; 11628 end if; 11629 11630 Obj_Id := Defining_Entity (Obj_Decl); 11631 11632 -- Perform minimal verification to ensure that the argument is at 11633 -- least a variable. Subsequent finer grained checks will be done 11634 -- at the end of the declarative region the contains the pragma. 11635 11636 if Ekind (Obj_Id) = E_Variable then 11637 11638 -- Chain the pragma on the contract for further processing by 11639 -- Analyze_External_Property_In_Decl_Part. 11640 11641 Add_Contract_Item (N, Obj_Id); 11642 11643 -- A pragma that applies to a Ghost entity becomes Ghost for 11644 -- the purposes of legality checks and removal of ignored Ghost 11645 -- code. 11646 11647 Mark_Pragma_As_Ghost (N, Obj_Id); 11648 11649 -- Analyze the Boolean expression (if any) 11650 11651 if Present (Arg1) then 11652 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 11653 end if; 11654 11655 -- Otherwise the external property applies to a constant 11656 11657 else 11658 Error_Pragma ("pragma % must apply to a volatile object"); 11659 end if; 11660 end Async_Effective; 11661 11662 ------------------ 11663 -- Asynchronous -- 11664 ------------------ 11665 11666 -- pragma Asynchronous (LOCAL_NAME); 11667 11668 when Pragma_Asynchronous => Asynchronous : declare 11669 C_Ent : Entity_Id; 11670 Decl : Node_Id; 11671 Formal : Entity_Id; 11672 L : List_Id; 11673 Nm : Entity_Id; 11674 S : Node_Id; 11675 11676 procedure Process_Async_Pragma; 11677 -- Common processing for procedure and access-to-procedure case 11678 11679 -------------------------- 11680 -- Process_Async_Pragma -- 11681 -------------------------- 11682 11683 procedure Process_Async_Pragma is 11684 begin 11685 if No (L) then 11686 Set_Is_Asynchronous (Nm); 11687 return; 11688 end if; 11689 11690 -- The formals should be of mode IN (RM E.4.1(6)) 11691 11692 S := First (L); 11693 while Present (S) loop 11694 Formal := Defining_Identifier (S); 11695 11696 if Nkind (Formal) = N_Defining_Identifier 11697 and then Ekind (Formal) /= E_In_Parameter 11698 then 11699 Error_Pragma_Arg 11700 ("pragma% procedure can only have IN parameter", 11701 Arg1); 11702 end if; 11703 11704 Next (S); 11705 end loop; 11706 11707 Set_Is_Asynchronous (Nm); 11708 end Process_Async_Pragma; 11709 11710 -- Start of processing for pragma Asynchronous 11711 11712 begin 11713 Check_Ada_83_Warning; 11714 Check_No_Identifiers; 11715 Check_Arg_Count (1); 11716 Check_Arg_Is_Local_Name (Arg1); 11717 11718 if Debug_Flag_U then 11719 return; 11720 end if; 11721 11722 C_Ent := Cunit_Entity (Current_Sem_Unit); 11723 Analyze (Get_Pragma_Arg (Arg1)); 11724 Nm := Entity (Get_Pragma_Arg (Arg1)); 11725 11726 -- A pragma that applies to a Ghost entity becomes Ghost for the 11727 -- purposes of legality checks and removal of ignored Ghost code. 11728 11729 Mark_Pragma_As_Ghost (N, Nm); 11730 11731 if not Is_Remote_Call_Interface (C_Ent) 11732 and then not Is_Remote_Types (C_Ent) 11733 then 11734 -- This pragma should only appear in an RCI or Remote Types 11735 -- unit (RM E.4.1(4)). 11736 11737 Error_Pragma 11738 ("pragma% not in Remote_Call_Interface or Remote_Types unit"); 11739 end if; 11740 11741 if Ekind (Nm) = E_Procedure 11742 and then Nkind (Parent (Nm)) = N_Procedure_Specification 11743 then 11744 if not Is_Remote_Call_Interface (Nm) then 11745 Error_Pragma_Arg 11746 ("pragma% cannot be applied on non-remote procedure", 11747 Arg1); 11748 end if; 11749 11750 L := Parameter_Specifications (Parent (Nm)); 11751 Process_Async_Pragma; 11752 return; 11753 11754 elsif Ekind (Nm) = E_Function then 11755 Error_Pragma_Arg 11756 ("pragma% cannot be applied to function", Arg1); 11757 11758 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then 11759 if Is_Record_Type (Nm) then 11760 11761 -- A record type that is the Equivalent_Type for a remote 11762 -- access-to-subprogram type. 11763 11764 Decl := Declaration_Node (Corresponding_Remote_Type (Nm)); 11765 11766 else 11767 -- A non-expanded RAS type (distribution is not enabled) 11768 11769 Decl := Declaration_Node (Nm); 11770 end if; 11771 11772 if Nkind (Decl) = N_Full_Type_Declaration 11773 and then Nkind (Type_Definition (Decl)) = 11774 N_Access_Procedure_Definition 11775 then 11776 L := Parameter_Specifications (Type_Definition (Decl)); 11777 Process_Async_Pragma; 11778 11779 if Is_Asynchronous (Nm) 11780 and then Expander_Active 11781 and then Get_PCS_Name /= Name_No_DSA 11782 then 11783 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); 11784 end if; 11785 11786 else 11787 Error_Pragma_Arg 11788 ("pragma% cannot reference access-to-function type", 11789 Arg1); 11790 end if; 11791 11792 -- Only other possibility is Access-to-class-wide type 11793 11794 elsif Is_Access_Type (Nm) 11795 and then Is_Class_Wide_Type (Designated_Type (Nm)) 11796 then 11797 Check_First_Subtype (Arg1); 11798 Set_Is_Asynchronous (Nm); 11799 if Expander_Active then 11800 RACW_Type_Is_Asynchronous (Nm); 11801 end if; 11802 11803 else 11804 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); 11805 end if; 11806 end Asynchronous; 11807 11808 ------------ 11809 -- Atomic -- 11810 ------------ 11811 11812 -- pragma Atomic (LOCAL_NAME); 11813 11814 when Pragma_Atomic => 11815 Process_Atomic_Independent_Shared_Volatile; 11816 11817 ----------------------- 11818 -- Atomic_Components -- 11819 ----------------------- 11820 11821 -- pragma Atomic_Components (array_LOCAL_NAME); 11822 11823 -- This processing is shared by Volatile_Components 11824 11825 when Pragma_Atomic_Components | 11826 Pragma_Volatile_Components => 11827 Atomic_Components : declare 11828 D : Node_Id; 11829 E : Entity_Id; 11830 E_Id : Node_Id; 11831 K : Node_Kind; 11832 11833 begin 11834 Check_Ada_83_Warning; 11835 Check_No_Identifiers; 11836 Check_Arg_Count (1); 11837 Check_Arg_Is_Local_Name (Arg1); 11838 E_Id := Get_Pragma_Arg (Arg1); 11839 11840 if Etype (E_Id) = Any_Type then 11841 return; 11842 end if; 11843 11844 E := Entity (E_Id); 11845 11846 -- A pragma that applies to a Ghost entity becomes Ghost for the 11847 -- purposes of legality checks and removal of ignored Ghost code. 11848 11849 Mark_Pragma_As_Ghost (N, E); 11850 Check_Duplicate_Pragma (E); 11851 11852 if Rep_Item_Too_Early (E, N) 11853 or else 11854 Rep_Item_Too_Late (E, N) 11855 then 11856 return; 11857 end if; 11858 11859 D := Declaration_Node (E); 11860 K := Nkind (D); 11861 11862 if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) 11863 or else 11864 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 11865 and then Nkind (D) = N_Object_Declaration 11866 and then Nkind (Object_Definition (D)) = 11867 N_Constrained_Array_Definition) 11868 then 11869 -- The flag is set on the object, or on the base type 11870 11871 if Nkind (D) /= N_Object_Declaration then 11872 E := Base_Type (E); 11873 end if; 11874 11875 -- Atomic implies both Independent and Volatile 11876 11877 if Prag_Id = Pragma_Atomic_Components then 11878 Set_Has_Atomic_Components (E); 11879 Set_Has_Independent_Components (E); 11880 end if; 11881 11882 Set_Has_Volatile_Components (E); 11883 11884 else 11885 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 11886 end if; 11887 end Atomic_Components; 11888 11889 -------------------- 11890 -- Attach_Handler -- 11891 -------------------- 11892 11893 -- pragma Attach_Handler (handler_NAME, EXPRESSION); 11894 11895 when Pragma_Attach_Handler => 11896 Check_Ada_83_Warning; 11897 Check_No_Identifiers; 11898 Check_Arg_Count (2); 11899 11900 if No_Run_Time_Mode then 11901 Error_Msg_CRT ("Attach_Handler pragma", N); 11902 else 11903 Check_Interrupt_Or_Attach_Handler; 11904 11905 -- The expression that designates the attribute may depend on a 11906 -- discriminant, and is therefore a per-object expression, to 11907 -- be expanded in the init proc. If expansion is enabled, then 11908 -- perform semantic checks on a copy only. 11909 11910 declare 11911 Temp : Node_Id; 11912 Typ : Node_Id; 11913 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2); 11914 11915 begin 11916 -- In Relaxed_RM_Semantics mode, we allow any static 11917 -- integer value, for compatibility with other compilers. 11918 11919 if Relaxed_RM_Semantics 11920 and then Nkind (Parg2) = N_Integer_Literal 11921 then 11922 Typ := Standard_Integer; 11923 else 11924 Typ := RTE (RE_Interrupt_ID); 11925 end if; 11926 11927 if Expander_Active then 11928 Temp := New_Copy_Tree (Parg2); 11929 Set_Parent (Temp, N); 11930 Preanalyze_And_Resolve (Temp, Typ); 11931 else 11932 Analyze (Parg2); 11933 Resolve (Parg2, Typ); 11934 end if; 11935 end; 11936 11937 Process_Interrupt_Or_Attach_Handler; 11938 end if; 11939 11940 -------------------- 11941 -- C_Pass_By_Copy -- 11942 -------------------- 11943 11944 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); 11945 11946 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare 11947 Arg : Node_Id; 11948 Val : Uint; 11949 11950 begin 11951 GNAT_Pragma; 11952 Check_Valid_Configuration_Pragma; 11953 Check_Arg_Count (1); 11954 Check_Optional_Identifier (Arg1, "max_size"); 11955 11956 Arg := Get_Pragma_Arg (Arg1); 11957 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer); 11958 11959 Val := Expr_Value (Arg); 11960 11961 if Val <= 0 then 11962 Error_Pragma_Arg 11963 ("maximum size for pragma% must be positive", Arg1); 11964 11965 elsif UI_Is_In_Int_Range (Val) then 11966 Default_C_Record_Mechanism := UI_To_Int (Val); 11967 11968 -- If a giant value is given, Int'Last will do well enough. 11969 -- If sometime someone complains that a record larger than 11970 -- two gigabytes is not copied, we will worry about it then. 11971 11972 else 11973 Default_C_Record_Mechanism := Mechanism_Type'Last; 11974 end if; 11975 end C_Pass_By_Copy; 11976 11977 ----------- 11978 -- Check -- 11979 ----------- 11980 11981 -- pragma Check ([Name =>] CHECK_KIND, 11982 -- [Check =>] Boolean_EXPRESSION 11983 -- [,[Message =>] String_EXPRESSION]); 11984 11985 -- CHECK_KIND ::= IDENTIFIER | 11986 -- Pre'Class | 11987 -- Post'Class | 11988 -- Invariant'Class | 11989 -- Type_Invariant'Class 11990 11991 -- The identifiers Assertions and Statement_Assertions are not 11992 -- allowed, since they have special meaning for Check_Policy. 11993 11994 when Pragma_Check => Check : declare 11995 Cname : Name_Id; 11996 Eloc : Source_Ptr; 11997 Expr : Node_Id; 11998 Str : Node_Id; 11999 12000 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 12001 12002 begin 12003 -- Pragma Check is Ghost when it applies to a Ghost entity. Set 12004 -- the mode now to ensure that any nodes generated during analysis 12005 -- and expansion are marked as Ghost. 12006 12007 Set_Ghost_Mode (N); 12008 12009 GNAT_Pragma; 12010 Check_At_Least_N_Arguments (2); 12011 Check_At_Most_N_Arguments (3); 12012 Check_Optional_Identifier (Arg1, Name_Name); 12013 Check_Optional_Identifier (Arg2, Name_Check); 12014 12015 if Arg_Count = 3 then 12016 Check_Optional_Identifier (Arg3, Name_Message); 12017 Str := Get_Pragma_Arg (Arg3); 12018 end if; 12019 12020 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1)); 12021 Check_Arg_Is_Identifier (Arg1); 12022 Cname := Chars (Get_Pragma_Arg (Arg1)); 12023 12024 -- Check forbidden name Assertions or Statement_Assertions 12025 12026 case Cname is 12027 when Name_Assertions => 12028 Error_Pragma_Arg 12029 ("""Assertions"" is not allowed as a check kind for " 12030 & "pragma%", Arg1); 12031 12032 when Name_Statement_Assertions => 12033 Error_Pragma_Arg 12034 ("""Statement_Assertions"" is not allowed as a check kind " 12035 & "for pragma%", Arg1); 12036 12037 when others => 12038 null; 12039 end case; 12040 12041 -- Check applicable policy. We skip this if Checked/Ignored status 12042 -- is already set (e.g. in the case of a pragma from an aspect). 12043 12044 if Is_Checked (N) or else Is_Ignored (N) then 12045 null; 12046 12047 -- For a non-source pragma that is a rewriting of another pragma, 12048 -- copy the Is_Checked/Ignored status from the rewritten pragma. 12049 12050 elsif Is_Rewrite_Substitution (N) 12051 and then Nkind (Original_Node (N)) = N_Pragma 12052 and then Original_Node (N) /= N 12053 then 12054 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 12055 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 12056 12057 -- Otherwise query the applicable policy at this point 12058 12059 else 12060 case Check_Kind (Cname) is 12061 when Name_Ignore => 12062 Set_Is_Ignored (N, True); 12063 Set_Is_Checked (N, False); 12064 12065 when Name_Check => 12066 Set_Is_Ignored (N, False); 12067 Set_Is_Checked (N, True); 12068 12069 -- For disable, rewrite pragma as null statement and skip 12070 -- rest of the analysis of the pragma. 12071 12072 when Name_Disable => 12073 Rewrite (N, Make_Null_Statement (Loc)); 12074 Analyze (N); 12075 raise Pragma_Exit; 12076 12077 -- No other possibilities 12078 12079 when others => 12080 raise Program_Error; 12081 end case; 12082 end if; 12083 12084 -- If check kind was not Disable, then continue pragma analysis 12085 12086 Expr := Get_Pragma_Arg (Arg2); 12087 12088 -- Deal with SCO generation 12089 12090 case Cname is 12091 12092 -- Nothing to do for invariants and predicates as the checks 12093 -- occur in the client units. The SCO for the aspect in the 12094 -- declaration unit is conservatively always enabled. 12095 12096 when Name_Invariant | Name_Predicate => 12097 null; 12098 12099 -- Otherwise mark aspect/pragma SCO as enabled 12100 12101 when others => 12102 if Is_Checked (N) and then not Split_PPC (N) then 12103 Set_SCO_Pragma_Enabled (Loc); 12104 end if; 12105 end case; 12106 12107 -- Deal with analyzing the string argument 12108 12109 if Arg_Count = 3 then 12110 12111 -- If checks are not on we don't want any expansion (since 12112 -- such expansion would not get properly deleted) but 12113 -- we do want to analyze (to get proper references). 12114 -- The Preanalyze_And_Resolve routine does just what we want 12115 12116 if Is_Ignored (N) then 12117 Preanalyze_And_Resolve (Str, Standard_String); 12118 12119 -- Otherwise we need a proper analysis and expansion 12120 12121 else 12122 Analyze_And_Resolve (Str, Standard_String); 12123 end if; 12124 end if; 12125 12126 -- Now you might think we could just do the same with the Boolean 12127 -- expression if checks are off (and expansion is on) and then 12128 -- rewrite the check as a null statement. This would work but we 12129 -- would lose the useful warnings about an assertion being bound 12130 -- to fail even if assertions are turned off. 12131 12132 -- So instead we wrap the boolean expression in an if statement 12133 -- that looks like: 12134 12135 -- if False and then condition then 12136 -- null; 12137 -- end if; 12138 12139 -- The reason we do this rewriting during semantic analysis rather 12140 -- than as part of normal expansion is that we cannot analyze and 12141 -- expand the code for the boolean expression directly, or it may 12142 -- cause insertion of actions that would escape the attempt to 12143 -- suppress the check code. 12144 12145 -- Note that the Sloc for the if statement corresponds to the 12146 -- argument condition, not the pragma itself. The reason for 12147 -- this is that we may generate a warning if the condition is 12148 -- False at compile time, and we do not want to delete this 12149 -- warning when we delete the if statement. 12150 12151 if Expander_Active and Is_Ignored (N) then 12152 Eloc := Sloc (Expr); 12153 12154 Rewrite (N, 12155 Make_If_Statement (Eloc, 12156 Condition => 12157 Make_And_Then (Eloc, 12158 Left_Opnd => Make_Identifier (Eloc, Name_False), 12159 Right_Opnd => Expr), 12160 Then_Statements => New_List ( 12161 Make_Null_Statement (Eloc)))); 12162 12163 -- Now go ahead and analyze the if statement 12164 12165 In_Assertion_Expr := In_Assertion_Expr + 1; 12166 12167 -- One rather special treatment. If we are now in Eliminated 12168 -- overflow mode, then suppress overflow checking since we do 12169 -- not want to drag in the bignum stuff if we are in Ignore 12170 -- mode anyway. This is particularly important if we are using 12171 -- a configurable run time that does not support bignum ops. 12172 12173 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then 12174 declare 12175 Svo : constant Boolean := 12176 Scope_Suppress.Suppress (Overflow_Check); 12177 begin 12178 Scope_Suppress.Overflow_Mode_Assertions := Strict; 12179 Scope_Suppress.Suppress (Overflow_Check) := True; 12180 Analyze (N); 12181 Scope_Suppress.Suppress (Overflow_Check) := Svo; 12182 Scope_Suppress.Overflow_Mode_Assertions := Eliminated; 12183 end; 12184 12185 -- Not that special case 12186 12187 else 12188 Analyze (N); 12189 end if; 12190 12191 -- All done with this check 12192 12193 In_Assertion_Expr := In_Assertion_Expr - 1; 12194 12195 -- Check is active or expansion not active. In these cases we can 12196 -- just go ahead and analyze the boolean with no worries. 12197 12198 else 12199 In_Assertion_Expr := In_Assertion_Expr + 1; 12200 Analyze_And_Resolve (Expr, Any_Boolean); 12201 In_Assertion_Expr := In_Assertion_Expr - 1; 12202 end if; 12203 12204 Ghost_Mode := Save_Ghost_Mode; 12205 end Check; 12206 12207 -------------------------- 12208 -- Check_Float_Overflow -- 12209 -------------------------- 12210 12211 -- pragma Check_Float_Overflow; 12212 12213 when Pragma_Check_Float_Overflow => 12214 GNAT_Pragma; 12215 Check_Valid_Configuration_Pragma; 12216 Check_Arg_Count (0); 12217 Check_Float_Overflow := not Machine_Overflows_On_Target; 12218 12219 ---------------- 12220 -- Check_Name -- 12221 ---------------- 12222 12223 -- pragma Check_Name (check_IDENTIFIER); 12224 12225 when Pragma_Check_Name => 12226 GNAT_Pragma; 12227 Check_No_Identifiers; 12228 Check_Valid_Configuration_Pragma; 12229 Check_Arg_Count (1); 12230 Check_Arg_Is_Identifier (Arg1); 12231 12232 declare 12233 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 12234 12235 begin 12236 for J in Check_Names.First .. Check_Names.Last loop 12237 if Check_Names.Table (J) = Nam then 12238 return; 12239 end if; 12240 end loop; 12241 12242 Check_Names.Append (Nam); 12243 end; 12244 12245 ------------------ 12246 -- Check_Policy -- 12247 ------------------ 12248 12249 -- This is the old style syntax, which is still allowed in all modes: 12250 12251 -- pragma Check_Policy ([Name =>] CHECK_KIND 12252 -- [Policy =>] POLICY_IDENTIFIER); 12253 12254 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore 12255 12256 -- CHECK_KIND ::= IDENTIFIER | 12257 -- Pre'Class | 12258 -- Post'Class | 12259 -- Type_Invariant'Class | 12260 -- Invariant'Class 12261 12262 -- This is the new style syntax, compatible with Assertion_Policy 12263 -- and also allowed in all modes. 12264 12265 -- Pragma Check_Policy ( 12266 -- CHECK_KIND => POLICY_IDENTIFIER 12267 -- {, CHECK_KIND => POLICY_IDENTIFIER}); 12268 12269 -- Note: the identifiers Name and Policy are not allowed as 12270 -- Check_Kind values. This avoids ambiguities between the old and 12271 -- new form syntax. 12272 12273 when Pragma_Check_Policy => Check_Policy : declare 12274 Ident : Node_Id; 12275 Kind : Node_Id; 12276 12277 begin 12278 GNAT_Pragma; 12279 Check_At_Least_N_Arguments (1); 12280 12281 -- A Check_Policy pragma can appear either as a configuration 12282 -- pragma, or in a declarative part or a package spec (see RM 12283 -- 11.5(5) for rules for Suppress/Unsuppress which are also 12284 -- followed for Check_Policy). 12285 12286 if not Is_Configuration_Pragma then 12287 Check_Is_In_Decl_Part_Or_Package_Spec; 12288 end if; 12289 12290 -- Figure out if we have the old or new syntax. We have the 12291 -- old syntax if the first argument has no identifier, or the 12292 -- identifier is Name. 12293 12294 if Nkind (Arg1) /= N_Pragma_Argument_Association 12295 or else Nam_In (Chars (Arg1), No_Name, Name_Name) 12296 then 12297 -- Old syntax 12298 12299 Check_Arg_Count (2); 12300 Check_Optional_Identifier (Arg1, Name_Name); 12301 Kind := Get_Pragma_Arg (Arg1); 12302 Rewrite_Assertion_Kind (Kind); 12303 Check_Arg_Is_Identifier (Arg1); 12304 12305 -- Check forbidden check kind 12306 12307 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then 12308 Error_Msg_Name_2 := Chars (Kind); 12309 Error_Pragma_Arg 12310 ("pragma% does not allow% as check name", Arg1); 12311 end if; 12312 12313 -- Check policy 12314 12315 Check_Optional_Identifier (Arg2, Name_Policy); 12316 Check_Arg_Is_One_Of 12317 (Arg2, 12318 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); 12319 Ident := Get_Pragma_Arg (Arg2); 12320 12321 if Chars (Kind) = Name_Ghost then 12322 12323 -- Pragma Check_Policy specifying a Ghost policy cannot 12324 -- occur within a ghost subprogram or package. 12325 12326 if Ghost_Mode > None then 12327 Error_Pragma 12328 ("pragma % cannot appear within ghost subprogram or " 12329 & "package"); 12330 12331 -- The policy identifier of pragma Ghost must be either 12332 -- Check or Ignore (SPARK RM 6.9(7)). 12333 12334 elsif not Nam_In (Chars (Ident), Name_Check, 12335 Name_Ignore) 12336 then 12337 Error_Pragma_Arg 12338 ("argument of pragma % Ghost must be Check or Ignore", 12339 Arg2); 12340 end if; 12341 end if; 12342 12343 -- And chain pragma on the Check_Policy_List for search 12344 12345 Set_Next_Pragma (N, Opt.Check_Policy_List); 12346 Opt.Check_Policy_List := N; 12347 12348 -- For the new syntax, what we do is to convert each argument to 12349 -- an old syntax equivalent. We do that because we want to chain 12350 -- old style Check_Policy pragmas for the search (we don't want 12351 -- to have to deal with multiple arguments in the search). 12352 12353 else 12354 declare 12355 Arg : Node_Id; 12356 Argx : Node_Id; 12357 LocP : Source_Ptr; 12358 12359 begin 12360 Arg := Arg1; 12361 while Present (Arg) loop 12362 LocP := Sloc (Arg); 12363 Argx := Get_Pragma_Arg (Arg); 12364 12365 -- Kind must be specified 12366 12367 if Nkind (Arg) /= N_Pragma_Argument_Association 12368 or else Chars (Arg) = No_Name 12369 then 12370 Error_Pragma_Arg 12371 ("missing assertion kind for pragma%", Arg); 12372 end if; 12373 12374 -- Construct equivalent old form syntax Check_Policy 12375 -- pragma and insert it to get remaining checks. 12376 12377 Insert_Action (N, 12378 Make_Pragma (LocP, 12379 Chars => Name_Check_Policy, 12380 Pragma_Argument_Associations => New_List ( 12381 Make_Pragma_Argument_Association (LocP, 12382 Expression => 12383 Make_Identifier (LocP, Chars (Arg))), 12384 Make_Pragma_Argument_Association (Sloc (Argx), 12385 Expression => Argx)))); 12386 12387 Arg := Next (Arg); 12388 end loop; 12389 12390 -- Rewrite original Check_Policy pragma to null, since we 12391 -- have converted it into a series of old syntax pragmas. 12392 12393 Rewrite (N, Make_Null_Statement (Loc)); 12394 Analyze (N); 12395 end; 12396 end if; 12397 end Check_Policy; 12398 12399 ------------- 12400 -- Comment -- 12401 ------------- 12402 12403 -- pragma Comment (static_string_EXPRESSION) 12404 12405 -- Processing for pragma Comment shares the circuitry for pragma 12406 -- Ident. The only differences are that Ident enforces a limit of 31 12407 -- characters on its argument, and also enforces limitations on 12408 -- placement for DEC compatibility. Pragma Comment shares neither of 12409 -- these restrictions. 12410 12411 ------------------- 12412 -- Common_Object -- 12413 ------------------- 12414 12415 -- pragma Common_Object ( 12416 -- [Internal =>] LOCAL_NAME 12417 -- [, [External =>] EXTERNAL_SYMBOL] 12418 -- [, [Size =>] EXTERNAL_SYMBOL]); 12419 12420 -- Processing for this pragma is shared with Psect_Object 12421 12422 ------------------------ 12423 -- Compile_Time_Error -- 12424 ------------------------ 12425 12426 -- pragma Compile_Time_Error 12427 -- (boolean_EXPRESSION, static_string_EXPRESSION); 12428 12429 when Pragma_Compile_Time_Error => 12430 GNAT_Pragma; 12431 Process_Compile_Time_Warning_Or_Error; 12432 12433 -------------------------- 12434 -- Compile_Time_Warning -- 12435 -------------------------- 12436 12437 -- pragma Compile_Time_Warning 12438 -- (boolean_EXPRESSION, static_string_EXPRESSION); 12439 12440 when Pragma_Compile_Time_Warning => 12441 GNAT_Pragma; 12442 Process_Compile_Time_Warning_Or_Error; 12443 12444 --------------------------- 12445 -- Compiler_Unit_Warning -- 12446 --------------------------- 12447 12448 -- pragma Compiler_Unit_Warning; 12449 12450 -- Historical note 12451 12452 -- Originally, we had only pragma Compiler_Unit, and it resulted in 12453 -- errors not warnings. This means that we had introduced a big extra 12454 -- inertia to compiler changes, since even if we implemented a new 12455 -- feature, and even if all versions to be used for bootstrapping 12456 -- implemented this new feature, we could not use it, since old 12457 -- compilers would give errors for using this feature in units 12458 -- having Compiler_Unit pragmas. 12459 12460 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the 12461 -- problem. We no longer have any units mentioning Compiler_Unit, 12462 -- so old compilers see Compiler_Unit_Warning which is unrecognized, 12463 -- and thus generates a warning which can be ignored. So that deals 12464 -- with the problem of old compilers not implementing the newer form 12465 -- of the pragma. 12466 12467 -- Newer compilers recognize the new pragma, but generate warning 12468 -- messages instead of errors, which again can be ignored in the 12469 -- case of an old compiler which implements a wanted new feature 12470 -- but at the time felt like warning about it for older compilers. 12471 12472 -- We retain Compiler_Unit so that new compilers can be used to build 12473 -- older run-times that use this pragma. That's an unusual case, but 12474 -- it's easy enough to handle, so why not? 12475 12476 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning => 12477 GNAT_Pragma; 12478 Check_Arg_Count (0); 12479 12480 -- Only recognized in main unit 12481 12482 if Current_Sem_Unit = Main_Unit then 12483 Compiler_Unit := True; 12484 end if; 12485 12486 ----------------------------- 12487 -- Complete_Representation -- 12488 ----------------------------- 12489 12490 -- pragma Complete_Representation; 12491 12492 when Pragma_Complete_Representation => 12493 GNAT_Pragma; 12494 Check_Arg_Count (0); 12495 12496 if Nkind (Parent (N)) /= N_Record_Representation_Clause then 12497 Error_Pragma 12498 ("pragma & must appear within record representation clause"); 12499 end if; 12500 12501 ---------------------------- 12502 -- Complex_Representation -- 12503 ---------------------------- 12504 12505 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); 12506 12507 when Pragma_Complex_Representation => Complex_Representation : declare 12508 E_Id : Entity_Id; 12509 E : Entity_Id; 12510 Ent : Entity_Id; 12511 12512 begin 12513 GNAT_Pragma; 12514 Check_Arg_Count (1); 12515 Check_Optional_Identifier (Arg1, Name_Entity); 12516 Check_Arg_Is_Local_Name (Arg1); 12517 E_Id := Get_Pragma_Arg (Arg1); 12518 12519 if Etype (E_Id) = Any_Type then 12520 return; 12521 end if; 12522 12523 E := Entity (E_Id); 12524 12525 if not Is_Record_Type (E) then 12526 Error_Pragma_Arg 12527 ("argument for pragma% must be record type", Arg1); 12528 end if; 12529 12530 Ent := First_Entity (E); 12531 12532 if No (Ent) 12533 or else No (Next_Entity (Ent)) 12534 or else Present (Next_Entity (Next_Entity (Ent))) 12535 or else not Is_Floating_Point_Type (Etype (Ent)) 12536 or else Etype (Ent) /= Etype (Next_Entity (Ent)) 12537 then 12538 Error_Pragma_Arg 12539 ("record for pragma% must have two fields of the same " 12540 & "floating-point type", Arg1); 12541 12542 else 12543 Set_Has_Complex_Representation (Base_Type (E)); 12544 12545 -- We need to treat the type has having a non-standard 12546 -- representation, for back-end purposes, even though in 12547 -- general a complex will have the default representation 12548 -- of a record with two real components. 12549 12550 Set_Has_Non_Standard_Rep (Base_Type (E)); 12551 end if; 12552 end Complex_Representation; 12553 12554 ------------------------- 12555 -- Component_Alignment -- 12556 ------------------------- 12557 12558 -- pragma Component_Alignment ( 12559 -- [Form =>] ALIGNMENT_CHOICE 12560 -- [, [Name =>] type_LOCAL_NAME]); 12561 -- 12562 -- ALIGNMENT_CHOICE ::= 12563 -- Component_Size 12564 -- | Component_Size_4 12565 -- | Storage_Unit 12566 -- | Default 12567 12568 when Pragma_Component_Alignment => Component_AlignmentP : declare 12569 Args : Args_List (1 .. 2); 12570 Names : constant Name_List (1 .. 2) := ( 12571 Name_Form, 12572 Name_Name); 12573 12574 Form : Node_Id renames Args (1); 12575 Name : Node_Id renames Args (2); 12576 12577 Atype : Component_Alignment_Kind; 12578 Typ : Entity_Id; 12579 12580 begin 12581 GNAT_Pragma; 12582 Gather_Associations (Names, Args); 12583 12584 if No (Form) then 12585 Error_Pragma ("missing Form argument for pragma%"); 12586 end if; 12587 12588 Check_Arg_Is_Identifier (Form); 12589 12590 -- Get proper alignment, note that Default = Component_Size on all 12591 -- machines we have so far, and we want to set this value rather 12592 -- than the default value to indicate that it has been explicitly 12593 -- set (and thus will not get overridden by the default component 12594 -- alignment for the current scope) 12595 12596 if Chars (Form) = Name_Component_Size then 12597 Atype := Calign_Component_Size; 12598 12599 elsif Chars (Form) = Name_Component_Size_4 then 12600 Atype := Calign_Component_Size_4; 12601 12602 elsif Chars (Form) = Name_Default then 12603 Atype := Calign_Component_Size; 12604 12605 elsif Chars (Form) = Name_Storage_Unit then 12606 Atype := Calign_Storage_Unit; 12607 12608 else 12609 Error_Pragma_Arg 12610 ("invalid Form parameter for pragma%", Form); 12611 end if; 12612 12613 -- Case with no name, supplied, affects scope table entry 12614 12615 if No (Name) then 12616 Scope_Stack.Table 12617 (Scope_Stack.Last).Component_Alignment_Default := Atype; 12618 12619 -- Case of name supplied 12620 12621 else 12622 Check_Arg_Is_Local_Name (Name); 12623 Find_Type (Name); 12624 Typ := Entity (Name); 12625 12626 if Typ = Any_Type 12627 or else Rep_Item_Too_Early (Typ, N) 12628 then 12629 return; 12630 else 12631 Typ := Underlying_Type (Typ); 12632 end if; 12633 12634 if not Is_Record_Type (Typ) 12635 and then not Is_Array_Type (Typ) 12636 then 12637 Error_Pragma_Arg 12638 ("Name parameter of pragma% must identify record or " 12639 & "array type", Name); 12640 end if; 12641 12642 -- An explicit Component_Alignment pragma overrides an 12643 -- implicit pragma Pack, but not an explicit one. 12644 12645 if not Has_Pragma_Pack (Base_Type (Typ)) then 12646 Set_Is_Packed (Base_Type (Typ), False); 12647 Set_Component_Alignment (Base_Type (Typ), Atype); 12648 end if; 12649 end if; 12650 end Component_AlignmentP; 12651 12652 -------------------------------- 12653 -- Constant_After_Elaboration -- 12654 -------------------------------- 12655 12656 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ]; 12657 12658 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration : 12659 declare 12660 Obj_Decl : Node_Id; 12661 Obj_Id : Entity_Id; 12662 12663 begin 12664 GNAT_Pragma; 12665 Check_No_Identifiers; 12666 Check_At_Most_N_Arguments (1); 12667 12668 Obj_Decl := Find_Related_Context (N, Do_Checks => True); 12669 12670 -- Object declaration 12671 12672 if Nkind (Obj_Decl) = N_Object_Declaration then 12673 null; 12674 12675 -- Otherwise the pragma is associated with an illegal construct 12676 12677 else 12678 Pragma_Misplaced; 12679 return; 12680 end if; 12681 12682 Obj_Id := Defining_Entity (Obj_Decl); 12683 12684 -- The object declaration must be a library-level variable which 12685 -- is either explicitly initialized or obtains a value during the 12686 -- elaboration of a package body (SPARK RM 3.3.1). 12687 12688 if Ekind (Obj_Id) = E_Variable then 12689 if not Is_Library_Level_Entity (Obj_Id) then 12690 Error_Pragma 12691 ("pragma % must apply to a library level variable"); 12692 return; 12693 end if; 12694 12695 -- Otherwise the pragma applies to a constant, which is illegal 12696 12697 else 12698 Error_Pragma ("pragma % must apply to a variable declaration"); 12699 return; 12700 end if; 12701 12702 -- Chain the pragma on the contract for completeness 12703 12704 Add_Contract_Item (N, Obj_Id); 12705 12706 -- A pragma that applies to a Ghost entity becomes Ghost for the 12707 -- purposes of legality checks and removal of ignored Ghost code. 12708 12709 Mark_Pragma_As_Ghost (N, Obj_Id); 12710 12711 -- Analyze the Boolean expression (if any) 12712 12713 if Present (Arg1) then 12714 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 12715 end if; 12716 end Constant_After_Elaboration; 12717 12718 -------------------- 12719 -- Contract_Cases -- 12720 -------------------- 12721 12722 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE)); 12723 12724 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE 12725 12726 -- CASE_GUARD ::= boolean_EXPRESSION | others 12727 12728 -- CONSEQUENCE ::= boolean_EXPRESSION 12729 12730 -- Characteristics: 12731 12732 -- * Analysis - The annotation undergoes initial checks to verify 12733 -- the legal placement and context. Secondary checks preanalyze the 12734 -- expressions in: 12735 12736 -- Analyze_Contract_Cases_In_Decl_Part 12737 12738 -- * Expansion - The annotation is expanded during the expansion of 12739 -- the related subprogram [body] contract as performed in: 12740 12741 -- Expand_Subprogram_Contract 12742 12743 -- * Template - The annotation utilizes the generic template of the 12744 -- related subprogram [body] when it is: 12745 12746 -- aspect on subprogram declaration 12747 -- aspect on stand alone subprogram body 12748 -- pragma on stand alone subprogram body 12749 12750 -- The annotation must prepare its own template when it is: 12751 12752 -- pragma on subprogram declaration 12753 12754 -- * Globals - Capture of global references must occur after full 12755 -- analysis. 12756 12757 -- * Instance - The annotation is instantiated automatically when 12758 -- the related generic subprogram [body] is instantiated except for 12759 -- the "pragma on subprogram declaration" case. In that scenario 12760 -- the annotation must instantiate itself. 12761 12762 when Pragma_Contract_Cases => Contract_Cases : declare 12763 Spec_Id : Entity_Id; 12764 Subp_Decl : Node_Id; 12765 12766 begin 12767 GNAT_Pragma; 12768 Check_No_Identifiers; 12769 Check_Arg_Count (1); 12770 12771 -- Ensure the proper placement of the pragma. Contract_Cases must 12772 -- be associated with a subprogram declaration or a body that acts 12773 -- as a spec. 12774 12775 Subp_Decl := 12776 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 12777 12778 -- Entry 12779 12780 if Nkind (Subp_Decl) = N_Entry_Declaration then 12781 null; 12782 12783 -- Generic subprogram 12784 12785 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 12786 null; 12787 12788 -- Body acts as spec 12789 12790 elsif Nkind (Subp_Decl) = N_Subprogram_Body 12791 and then No (Corresponding_Spec (Subp_Decl)) 12792 then 12793 null; 12794 12795 -- Body stub acts as spec 12796 12797 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 12798 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 12799 then 12800 null; 12801 12802 -- Subprogram 12803 12804 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 12805 null; 12806 12807 else 12808 Pragma_Misplaced; 12809 return; 12810 end if; 12811 12812 Spec_Id := Unique_Defining_Entity (Subp_Decl); 12813 12814 -- Chain the pragma on the contract for further processing by 12815 -- Analyze_Contract_Cases_In_Decl_Part. 12816 12817 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 12818 12819 -- A pragma that applies to a Ghost entity becomes Ghost for the 12820 -- purposes of legality checks and removal of ignored Ghost code. 12821 12822 Mark_Pragma_As_Ghost (N, Spec_Id); 12823 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 12824 12825 -- Fully analyze the pragma when it appears inside an entry 12826 -- or subprogram body because it cannot benefit from forward 12827 -- references. 12828 12829 if Nkind_In (Subp_Decl, N_Entry_Body, 12830 N_Subprogram_Body, 12831 N_Subprogram_Body_Stub) 12832 then 12833 -- The legality checks of pragma Contract_Cases are affected by 12834 -- the SPARK mode in effect and the volatility of the context. 12835 -- Analyze all pragmas in a specific order. 12836 12837 Analyze_If_Present (Pragma_SPARK_Mode); 12838 Analyze_If_Present (Pragma_Volatile_Function); 12839 Analyze_Contract_Cases_In_Decl_Part (N); 12840 end if; 12841 end Contract_Cases; 12842 12843 ---------------- 12844 -- Controlled -- 12845 ---------------- 12846 12847 -- pragma Controlled (first_subtype_LOCAL_NAME); 12848 12849 when Pragma_Controlled => Controlled : declare 12850 Arg : Node_Id; 12851 12852 begin 12853 Check_No_Identifiers; 12854 Check_Arg_Count (1); 12855 Check_Arg_Is_Local_Name (Arg1); 12856 Arg := Get_Pragma_Arg (Arg1); 12857 12858 if not Is_Entity_Name (Arg) 12859 or else not Is_Access_Type (Entity (Arg)) 12860 then 12861 Error_Pragma_Arg ("pragma% requires access type", Arg1); 12862 else 12863 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); 12864 end if; 12865 end Controlled; 12866 12867 ---------------- 12868 -- Convention -- 12869 ---------------- 12870 12871 -- pragma Convention ([Convention =>] convention_IDENTIFIER, 12872 -- [Entity =>] LOCAL_NAME); 12873 12874 when Pragma_Convention => Convention : declare 12875 C : Convention_Id; 12876 E : Entity_Id; 12877 pragma Warnings (Off, C); 12878 pragma Warnings (Off, E); 12879 begin 12880 Check_Arg_Order ((Name_Convention, Name_Entity)); 12881 Check_Ada_83_Warning; 12882 Check_Arg_Count (2); 12883 Process_Convention (C, E); 12884 12885 -- A pragma that applies to a Ghost entity becomes Ghost for the 12886 -- purposes of legality checks and removal of ignored Ghost code. 12887 12888 Mark_Pragma_As_Ghost (N, E); 12889 end Convention; 12890 12891 --------------------------- 12892 -- Convention_Identifier -- 12893 --------------------------- 12894 12895 -- pragma Convention_Identifier ([Name =>] IDENTIFIER, 12896 -- [Convention =>] convention_IDENTIFIER); 12897 12898 when Pragma_Convention_Identifier => Convention_Identifier : declare 12899 Idnam : Name_Id; 12900 Cname : Name_Id; 12901 12902 begin 12903 GNAT_Pragma; 12904 Check_Arg_Order ((Name_Name, Name_Convention)); 12905 Check_Arg_Count (2); 12906 Check_Optional_Identifier (Arg1, Name_Name); 12907 Check_Optional_Identifier (Arg2, Name_Convention); 12908 Check_Arg_Is_Identifier (Arg1); 12909 Check_Arg_Is_Identifier (Arg2); 12910 Idnam := Chars (Get_Pragma_Arg (Arg1)); 12911 Cname := Chars (Get_Pragma_Arg (Arg2)); 12912 12913 if Is_Convention_Name (Cname) then 12914 Record_Convention_Identifier 12915 (Idnam, Get_Convention_Id (Cname)); 12916 else 12917 Error_Pragma_Arg 12918 ("second arg for % pragma must be convention", Arg2); 12919 end if; 12920 end Convention_Identifier; 12921 12922 --------------- 12923 -- CPP_Class -- 12924 --------------- 12925 12926 -- pragma CPP_Class ([Entity =>] LOCAL_NAME) 12927 12928 when Pragma_CPP_Class => CPP_Class : declare 12929 begin 12930 GNAT_Pragma; 12931 12932 if Warn_On_Obsolescent_Feature then 12933 Error_Msg_N 12934 ("'G'N'A'T pragma cpp'_class is now obsolete and has no " 12935 & "effect; replace it by pragma import?j?", N); 12936 end if; 12937 12938 Check_Arg_Count (1); 12939 12940 Rewrite (N, 12941 Make_Pragma (Loc, 12942 Chars => Name_Import, 12943 Pragma_Argument_Associations => New_List ( 12944 Make_Pragma_Argument_Association (Loc, 12945 Expression => Make_Identifier (Loc, Name_CPP)), 12946 New_Copy (First (Pragma_Argument_Associations (N)))))); 12947 Analyze (N); 12948 end CPP_Class; 12949 12950 --------------------- 12951 -- CPP_Constructor -- 12952 --------------------- 12953 12954 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME 12955 -- [, [External_Name =>] static_string_EXPRESSION ] 12956 -- [, [Link_Name =>] static_string_EXPRESSION ]); 12957 12958 when Pragma_CPP_Constructor => CPP_Constructor : declare 12959 Elmt : Elmt_Id; 12960 Id : Entity_Id; 12961 Def_Id : Entity_Id; 12962 Tag_Typ : Entity_Id; 12963 12964 begin 12965 GNAT_Pragma; 12966 Check_At_Least_N_Arguments (1); 12967 Check_At_Most_N_Arguments (3); 12968 Check_Optional_Identifier (Arg1, Name_Entity); 12969 Check_Arg_Is_Local_Name (Arg1); 12970 12971 Id := Get_Pragma_Arg (Arg1); 12972 Find_Program_Unit_Name (Id); 12973 12974 -- If we did not find the name, we are done 12975 12976 if Etype (Id) = Any_Type then 12977 return; 12978 end if; 12979 12980 Def_Id := Entity (Id); 12981 12982 -- Check if already defined as constructor 12983 12984 if Is_Constructor (Def_Id) then 12985 Error_Msg_N 12986 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1); 12987 return; 12988 end if; 12989 12990 if Ekind (Def_Id) = E_Function 12991 and then (Is_CPP_Class (Etype (Def_Id)) 12992 or else (Is_Class_Wide_Type (Etype (Def_Id)) 12993 and then 12994 Is_CPP_Class (Root_Type (Etype (Def_Id))))) 12995 then 12996 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then 12997 Error_Msg_N 12998 ("'C'P'P constructor must be defined in the scope of " 12999 & "its returned type", Arg1); 13000 end if; 13001 13002 if Arg_Count >= 2 then 13003 Set_Imported (Def_Id); 13004 Set_Is_Public (Def_Id); 13005 Process_Interface_Name (Def_Id, Arg2, Arg3); 13006 end if; 13007 13008 Set_Has_Completion (Def_Id); 13009 Set_Is_Constructor (Def_Id); 13010 Set_Convention (Def_Id, Convention_CPP); 13011 13012 -- Imported C++ constructors are not dispatching primitives 13013 -- because in C++ they don't have a dispatch table slot. 13014 -- However, in Ada the constructor has the profile of a 13015 -- function that returns a tagged type and therefore it has 13016 -- been treated as a primitive operation during semantic 13017 -- analysis. We now remove it from the list of primitive 13018 -- operations of the type. 13019 13020 if Is_Tagged_Type (Etype (Def_Id)) 13021 and then not Is_Class_Wide_Type (Etype (Def_Id)) 13022 and then Is_Dispatching_Operation (Def_Id) 13023 then 13024 Tag_Typ := Etype (Def_Id); 13025 13026 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 13027 while Present (Elmt) and then Node (Elmt) /= Def_Id loop 13028 Next_Elmt (Elmt); 13029 end loop; 13030 13031 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); 13032 Set_Is_Dispatching_Operation (Def_Id, False); 13033 end if; 13034 13035 -- For backward compatibility, if the constructor returns a 13036 -- class wide type, and we internally change the return type to 13037 -- the corresponding root type. 13038 13039 if Is_Class_Wide_Type (Etype (Def_Id)) then 13040 Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); 13041 end if; 13042 else 13043 Error_Pragma_Arg 13044 ("pragma% requires function returning a 'C'P'P_Class type", 13045 Arg1); 13046 end if; 13047 end CPP_Constructor; 13048 13049 ----------------- 13050 -- CPP_Virtual -- 13051 ----------------- 13052 13053 when Pragma_CPP_Virtual => CPP_Virtual : declare 13054 begin 13055 GNAT_Pragma; 13056 13057 if Warn_On_Obsolescent_Feature then 13058 Error_Msg_N 13059 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no " 13060 & "effect?j?", N); 13061 end if; 13062 end CPP_Virtual; 13063 13064 ---------------- 13065 -- CPP_Vtable -- 13066 ---------------- 13067 13068 when Pragma_CPP_Vtable => CPP_Vtable : declare 13069 begin 13070 GNAT_Pragma; 13071 13072 if Warn_On_Obsolescent_Feature then 13073 Error_Msg_N 13074 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no " 13075 & "effect?j?", N); 13076 end if; 13077 end CPP_Vtable; 13078 13079 --------- 13080 -- CPU -- 13081 --------- 13082 13083 -- pragma CPU (EXPRESSION); 13084 13085 when Pragma_CPU => CPU : declare 13086 P : constant Node_Id := Parent (N); 13087 Arg : Node_Id; 13088 Ent : Entity_Id; 13089 13090 begin 13091 Ada_2012_Pragma; 13092 Check_No_Identifiers; 13093 Check_Arg_Count (1); 13094 13095 -- Subprogram case 13096 13097 if Nkind (P) = N_Subprogram_Body then 13098 Check_In_Main_Program; 13099 13100 Arg := Get_Pragma_Arg (Arg1); 13101 Analyze_And_Resolve (Arg, Any_Integer); 13102 13103 Ent := Defining_Unit_Name (Specification (P)); 13104 13105 if Nkind (Ent) = N_Defining_Program_Unit_Name then 13106 Ent := Defining_Identifier (Ent); 13107 end if; 13108 13109 -- Must be static 13110 13111 if not Is_OK_Static_Expression (Arg) then 13112 Flag_Non_Static_Expr 13113 ("main subprogram affinity is not static!", Arg); 13114 raise Pragma_Exit; 13115 13116 -- If constraint error, then we already signalled an error 13117 13118 elsif Raises_Constraint_Error (Arg) then 13119 null; 13120 13121 -- Otherwise check in range 13122 13123 else 13124 declare 13125 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); 13126 -- This is the entity System.Multiprocessors.CPU_Range; 13127 13128 Val : constant Uint := Expr_Value (Arg); 13129 13130 begin 13131 if Val < Expr_Value (Type_Low_Bound (CPU_Id)) 13132 or else 13133 Val > Expr_Value (Type_High_Bound (CPU_Id)) 13134 then 13135 Error_Pragma_Arg 13136 ("main subprogram CPU is out of range", Arg1); 13137 end if; 13138 end; 13139 end if; 13140 13141 Set_Main_CPU 13142 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 13143 13144 -- Task case 13145 13146 elsif Nkind (P) = N_Task_Definition then 13147 Arg := Get_Pragma_Arg (Arg1); 13148 Ent := Defining_Identifier (Parent (P)); 13149 13150 -- The expression must be analyzed in the special manner 13151 -- described in "Handling of Default and Per-Object 13152 -- Expressions" in sem.ads. 13153 13154 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); 13155 13156 -- Anything else is incorrect 13157 13158 else 13159 Pragma_Misplaced; 13160 end if; 13161 13162 -- Check duplicate pragma before we chain the pragma in the Rep 13163 -- Item chain of Ent. 13164 13165 Check_Duplicate_Pragma (Ent); 13166 Record_Rep_Item (Ent, N); 13167 end CPU; 13168 13169 ----------- 13170 -- Debug -- 13171 ----------- 13172 13173 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); 13174 13175 when Pragma_Debug => Debug : declare 13176 Cond : Node_Id; 13177 Call : Node_Id; 13178 13179 begin 13180 GNAT_Pragma; 13181 13182 -- The condition for executing the call is that the expander 13183 -- is active and that we are not ignoring this debug pragma. 13184 13185 Cond := 13186 New_Occurrence_Of 13187 (Boolean_Literals 13188 (Expander_Active and then not Is_Ignored (N)), 13189 Loc); 13190 13191 if not Is_Ignored (N) then 13192 Set_SCO_Pragma_Enabled (Loc); 13193 end if; 13194 13195 if Arg_Count = 2 then 13196 Cond := 13197 Make_And_Then (Loc, 13198 Left_Opnd => Relocate_Node (Cond), 13199 Right_Opnd => Get_Pragma_Arg (Arg1)); 13200 Call := Get_Pragma_Arg (Arg2); 13201 else 13202 Call := Get_Pragma_Arg (Arg1); 13203 end if; 13204 13205 if Nkind_In (Call, 13206 N_Indexed_Component, 13207 N_Function_Call, 13208 N_Identifier, 13209 N_Expanded_Name, 13210 N_Selected_Component) 13211 then 13212 -- If this pragma Debug comes from source, its argument was 13213 -- parsed as a name form (which is syntactically identical). 13214 -- In a generic context a parameterless call will be left as 13215 -- an expanded name (if global) or selected_component if local. 13216 -- Change it to a procedure call statement now. 13217 13218 Change_Name_To_Procedure_Call_Statement (Call); 13219 13220 elsif Nkind (Call) = N_Procedure_Call_Statement then 13221 13222 -- Already in the form of a procedure call statement: nothing 13223 -- to do (could happen in case of an internally generated 13224 -- pragma Debug). 13225 13226 null; 13227 13228 else 13229 -- All other cases: diagnose error 13230 13231 Error_Msg 13232 ("argument of pragma ""Debug"" is not procedure call", 13233 Sloc (Call)); 13234 return; 13235 end if; 13236 13237 -- Rewrite into a conditional with an appropriate condition. We 13238 -- wrap the procedure call in a block so that overhead from e.g. 13239 -- use of the secondary stack does not generate execution overhead 13240 -- for suppressed conditions. 13241 13242 -- Normally the analysis that follows will freeze the subprogram 13243 -- being called. However, if the call is to a null procedure, 13244 -- we want to freeze it before creating the block, because the 13245 -- analysis that follows may be done with expansion disabled, in 13246 -- which case the body will not be generated, leading to spurious 13247 -- errors. 13248 13249 if Nkind (Call) = N_Procedure_Call_Statement 13250 and then Is_Entity_Name (Name (Call)) 13251 then 13252 Analyze (Name (Call)); 13253 Freeze_Before (N, Entity (Name (Call))); 13254 end if; 13255 13256 Rewrite (N, 13257 Make_Implicit_If_Statement (N, 13258 Condition => Cond, 13259 Then_Statements => New_List ( 13260 Make_Block_Statement (Loc, 13261 Handled_Statement_Sequence => 13262 Make_Handled_Sequence_Of_Statements (Loc, 13263 Statements => New_List (Relocate_Node (Call))))))); 13264 Analyze (N); 13265 13266 -- Ignore pragma Debug in GNATprove mode. Do this rewriting 13267 -- after analysis of the normally rewritten node, to capture all 13268 -- references to entities, which avoids issuing wrong warnings 13269 -- about unused entities. 13270 13271 if GNATprove_Mode then 13272 Rewrite (N, Make_Null_Statement (Loc)); 13273 end if; 13274 end Debug; 13275 13276 ------------------ 13277 -- Debug_Policy -- 13278 ------------------ 13279 13280 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore) 13281 13282 when Pragma_Debug_Policy => 13283 GNAT_Pragma; 13284 Check_Arg_Count (1); 13285 Check_No_Identifiers; 13286 Check_Arg_Is_Identifier (Arg1); 13287 13288 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so 13289 -- rewrite it that way, and let the rest of the checking come 13290 -- from analyzing the rewritten pragma. 13291 13292 Rewrite (N, 13293 Make_Pragma (Loc, 13294 Chars => Name_Check_Policy, 13295 Pragma_Argument_Associations => New_List ( 13296 Make_Pragma_Argument_Association (Loc, 13297 Expression => Make_Identifier (Loc, Name_Debug)), 13298 13299 Make_Pragma_Argument_Association (Loc, 13300 Expression => Get_Pragma_Arg (Arg1))))); 13301 Analyze (N); 13302 13303 ------------------------------- 13304 -- Default_Initial_Condition -- 13305 ------------------------------- 13306 13307 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ]; 13308 13309 when Pragma_Default_Initial_Condition => Default_Init_Cond : declare 13310 Discard : Boolean; 13311 Stmt : Node_Id; 13312 Typ : Entity_Id; 13313 13314 begin 13315 GNAT_Pragma; 13316 Check_No_Identifiers; 13317 Check_At_Most_N_Arguments (1); 13318 13319 Stmt := Prev (N); 13320 while Present (Stmt) loop 13321 13322 -- Skip prior pragmas, but check for duplicates 13323 13324 if Nkind (Stmt) = N_Pragma then 13325 if Pragma_Name (Stmt) = Pname then 13326 Error_Msg_Name_1 := Pname; 13327 Error_Msg_Sloc := Sloc (Stmt); 13328 Error_Msg_N ("pragma % duplicates pragma declared#", N); 13329 end if; 13330 13331 -- Skip internally generated code 13332 13333 elsif not Comes_From_Source (Stmt) then 13334 null; 13335 13336 -- The associated private type [extension] has been found, stop 13337 -- the search. 13338 13339 elsif Nkind_In (Stmt, N_Private_Extension_Declaration, 13340 N_Private_Type_Declaration) 13341 then 13342 Typ := Defining_Entity (Stmt); 13343 exit; 13344 13345 -- The pragma does not apply to a legal construct, issue an 13346 -- error and stop the analysis. 13347 13348 else 13349 Pragma_Misplaced; 13350 return; 13351 end if; 13352 13353 Stmt := Prev (Stmt); 13354 end loop; 13355 13356 -- A pragma that applies to a Ghost entity becomes Ghost for the 13357 -- purposes of legality checks and removal of ignored Ghost code. 13358 13359 Mark_Pragma_As_Ghost (N, Typ); 13360 Set_Has_Default_Init_Cond (Typ); 13361 Set_Has_Inherited_Default_Init_Cond (Typ, False); 13362 13363 -- Chain the pragma on the rep item chain for further processing 13364 13365 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 13366 end Default_Init_Cond; 13367 13368 ---------------------------------- 13369 -- Default_Scalar_Storage_Order -- 13370 ---------------------------------- 13371 13372 -- pragma Default_Scalar_Storage_Order 13373 -- (High_Order_First | Low_Order_First); 13374 13375 when Pragma_Default_Scalar_Storage_Order => DSSO : declare 13376 Default : Character; 13377 13378 begin 13379 GNAT_Pragma; 13380 Check_Arg_Count (1); 13381 13382 -- Default_Scalar_Storage_Order can appear as a configuration 13383 -- pragma, or in a declarative part of a package spec. 13384 13385 if not Is_Configuration_Pragma then 13386 Check_Is_In_Decl_Part_Or_Package_Spec; 13387 end if; 13388 13389 Check_No_Identifiers; 13390 Check_Arg_Is_One_Of 13391 (Arg1, Name_High_Order_First, Name_Low_Order_First); 13392 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 13393 Default := Fold_Upper (Name_Buffer (1)); 13394 13395 if not Support_Nondefault_SSO_On_Target 13396 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H')) 13397 then 13398 if Warn_On_Unrecognized_Pragma then 13399 Error_Msg_N 13400 ("non-default Scalar_Storage_Order not supported " 13401 & "on target?g?", N); 13402 Error_Msg_N 13403 ("\pragma Default_Scalar_Storage_Order ignored?g?", N); 13404 end if; 13405 13406 -- Here set the specified default 13407 13408 else 13409 Opt.Default_SSO := Default; 13410 end if; 13411 end DSSO; 13412 13413 -------------------------- 13414 -- Default_Storage_Pool -- 13415 -------------------------- 13416 13417 -- pragma Default_Storage_Pool (storage_pool_NAME | null); 13418 13419 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare 13420 Pool : Node_Id; 13421 13422 begin 13423 Ada_2012_Pragma; 13424 Check_Arg_Count (1); 13425 13426 -- Default_Storage_Pool can appear as a configuration pragma, or 13427 -- in a declarative part of a package spec. 13428 13429 if not Is_Configuration_Pragma then 13430 Check_Is_In_Decl_Part_Or_Package_Spec; 13431 end if; 13432 13433 if Present (Arg1) then 13434 Pool := Get_Pragma_Arg (Arg1); 13435 13436 -- Case of Default_Storage_Pool (null); 13437 13438 if Nkind (Pool) = N_Null then 13439 Analyze (Pool); 13440 13441 -- This is an odd case, this is not really an expression, 13442 -- so we don't have a type for it. So just set the type to 13443 -- Empty. 13444 13445 Set_Etype (Pool, Empty); 13446 13447 -- Case of Default_Storage_Pool (storage_pool_NAME); 13448 13449 else 13450 -- If it's a configuration pragma, then the only allowed 13451 -- argument is "null". 13452 13453 if Is_Configuration_Pragma then 13454 Error_Pragma_Arg ("NULL expected", Arg1); 13455 end if; 13456 13457 -- The expected type for a non-"null" argument is 13458 -- Root_Storage_Pool'Class, and the pool must be a variable. 13459 13460 Analyze_And_Resolve 13461 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 13462 13463 if Is_Variable (Pool) then 13464 13465 -- A pragma that applies to a Ghost entity becomes Ghost 13466 -- for the purposes of legality checks and removal of 13467 -- ignored Ghost code. 13468 13469 Mark_Pragma_As_Ghost (N, Entity (Pool)); 13470 13471 else 13472 Error_Pragma_Arg 13473 ("default storage pool must be a variable", Arg1); 13474 end if; 13475 end if; 13476 13477 -- Record the pool name (or null). Freeze.Freeze_Entity for an 13478 -- access type will use this information to set the appropriate 13479 -- attributes of the access type. 13480 13481 Default_Pool := Pool; 13482 end if; 13483 end Default_Storage_Pool; 13484 13485 ------------- 13486 -- Depends -- 13487 ------------- 13488 13489 -- pragma Depends (DEPENDENCY_RELATION); 13490 13491 -- DEPENDENCY_RELATION ::= 13492 -- null 13493 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}) 13494 13495 -- DEPENDENCY_CLAUSE ::= 13496 -- OUTPUT_LIST =>[+] INPUT_LIST 13497 -- | NULL_DEPENDENCY_CLAUSE 13498 13499 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 13500 13501 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 13502 13503 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 13504 13505 -- OUTPUT ::= NAME | FUNCTION_RESULT 13506 -- INPUT ::= NAME 13507 13508 -- where FUNCTION_RESULT is a function Result attribute_reference 13509 13510 -- Characteristics: 13511 13512 -- * Analysis - The annotation undergoes initial checks to verify 13513 -- the legal placement and context. Secondary checks fully analyze 13514 -- the dependency clauses in: 13515 13516 -- Analyze_Depends_In_Decl_Part 13517 13518 -- * Expansion - None. 13519 13520 -- * Template - The annotation utilizes the generic template of the 13521 -- related subprogram [body] when it is: 13522 13523 -- aspect on subprogram declaration 13524 -- aspect on stand alone subprogram body 13525 -- pragma on stand alone subprogram body 13526 13527 -- The annotation must prepare its own template when it is: 13528 13529 -- pragma on subprogram declaration 13530 13531 -- * Globals - Capture of global references must occur after full 13532 -- analysis. 13533 13534 -- * Instance - The annotation is instantiated automatically when 13535 -- the related generic subprogram [body] is instantiated except for 13536 -- the "pragma on subprogram declaration" case. In that scenario 13537 -- the annotation must instantiate itself. 13538 13539 when Pragma_Depends => Depends : declare 13540 Legal : Boolean; 13541 Spec_Id : Entity_Id; 13542 Subp_Decl : Node_Id; 13543 13544 begin 13545 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); 13546 13547 if Legal then 13548 13549 -- Chain the pragma on the contract for further processing by 13550 -- Analyze_Depends_In_Decl_Part. 13551 13552 Add_Contract_Item (N, Spec_Id); 13553 13554 -- Fully analyze the pragma when it appears inside an entry 13555 -- or subprogram body because it cannot benefit from forward 13556 -- references. 13557 13558 if Nkind_In (Subp_Decl, N_Entry_Body, 13559 N_Subprogram_Body, 13560 N_Subprogram_Body_Stub) 13561 then 13562 -- The legality checks of pragmas Depends and Global are 13563 -- affected by the SPARK mode in effect and the volatility 13564 -- of the context. In addition these two pragmas are subject 13565 -- to an inherent order: 13566 13567 -- 1) Global 13568 -- 2) Depends 13569 13570 -- Analyze all these pragmas in the order outlined above 13571 13572 Analyze_If_Present (Pragma_SPARK_Mode); 13573 Analyze_If_Present (Pragma_Volatile_Function); 13574 Analyze_If_Present (Pragma_Global); 13575 Analyze_Depends_In_Decl_Part (N); 13576 end if; 13577 end if; 13578 end Depends; 13579 13580 --------------------- 13581 -- Detect_Blocking -- 13582 --------------------- 13583 13584 -- pragma Detect_Blocking; 13585 13586 when Pragma_Detect_Blocking => 13587 Ada_2005_Pragma; 13588 Check_Arg_Count (0); 13589 Check_Valid_Configuration_Pragma; 13590 Detect_Blocking := True; 13591 13592 ------------------------------------ 13593 -- Disable_Atomic_Synchronization -- 13594 ------------------------------------ 13595 13596 -- pragma Disable_Atomic_Synchronization [(Entity)]; 13597 13598 when Pragma_Disable_Atomic_Synchronization => 13599 GNAT_Pragma; 13600 Process_Disable_Enable_Atomic_Sync (Name_Suppress); 13601 13602 ------------------- 13603 -- Discard_Names -- 13604 ------------------- 13605 13606 -- pragma Discard_Names [([On =>] LOCAL_NAME)]; 13607 13608 when Pragma_Discard_Names => Discard_Names : declare 13609 E : Entity_Id; 13610 E_Id : Node_Id; 13611 13612 begin 13613 Check_Ada_83_Warning; 13614 13615 -- Deal with configuration pragma case 13616 13617 if Arg_Count = 0 and then Is_Configuration_Pragma then 13618 Global_Discard_Names := True; 13619 return; 13620 13621 -- Otherwise, check correct appropriate context 13622 13623 else 13624 Check_Is_In_Decl_Part_Or_Package_Spec; 13625 13626 if Arg_Count = 0 then 13627 13628 -- If there is no parameter, then from now on this pragma 13629 -- applies to any enumeration, exception or tagged type 13630 -- defined in the current declarative part, and recursively 13631 -- to any nested scope. 13632 13633 Set_Discard_Names (Current_Scope); 13634 return; 13635 13636 else 13637 Check_Arg_Count (1); 13638 Check_Optional_Identifier (Arg1, Name_On); 13639 Check_Arg_Is_Local_Name (Arg1); 13640 13641 E_Id := Get_Pragma_Arg (Arg1); 13642 13643 if Etype (E_Id) = Any_Type then 13644 return; 13645 else 13646 E := Entity (E_Id); 13647 end if; 13648 13649 -- A pragma that applies to a Ghost entity becomes Ghost for 13650 -- the purposes of legality checks and removal of ignored 13651 -- Ghost code. 13652 13653 Mark_Pragma_As_Ghost (N, E); 13654 13655 if (Is_First_Subtype (E) 13656 and then 13657 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) 13658 or else Ekind (E) = E_Exception 13659 then 13660 Set_Discard_Names (E); 13661 Record_Rep_Item (E, N); 13662 13663 else 13664 Error_Pragma_Arg 13665 ("inappropriate entity for pragma%", Arg1); 13666 end if; 13667 end if; 13668 end if; 13669 end Discard_Names; 13670 13671 ------------------------ 13672 -- Dispatching_Domain -- 13673 ------------------------ 13674 13675 -- pragma Dispatching_Domain (EXPRESSION); 13676 13677 when Pragma_Dispatching_Domain => Dispatching_Domain : declare 13678 P : constant Node_Id := Parent (N); 13679 Arg : Node_Id; 13680 Ent : Entity_Id; 13681 13682 begin 13683 Ada_2012_Pragma; 13684 Check_No_Identifiers; 13685 Check_Arg_Count (1); 13686 13687 -- This pragma is born obsolete, but not the aspect 13688 13689 if not From_Aspect_Specification (N) then 13690 Check_Restriction 13691 (No_Obsolescent_Features, Pragma_Identifier (N)); 13692 end if; 13693 13694 if Nkind (P) = N_Task_Definition then 13695 Arg := Get_Pragma_Arg (Arg1); 13696 Ent := Defining_Identifier (Parent (P)); 13697 13698 -- A pragma that applies to a Ghost entity becomes Ghost for 13699 -- the purposes of legality checks and removal of ignored Ghost 13700 -- code. 13701 13702 Mark_Pragma_As_Ghost (N, Ent); 13703 13704 -- The expression must be analyzed in the special manner 13705 -- described in "Handling of Default and Per-Object 13706 -- Expressions" in sem.ads. 13707 13708 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); 13709 13710 -- Check duplicate pragma before we chain the pragma in the Rep 13711 -- Item chain of Ent. 13712 13713 Check_Duplicate_Pragma (Ent); 13714 Record_Rep_Item (Ent, N); 13715 13716 -- Anything else is incorrect 13717 13718 else 13719 Pragma_Misplaced; 13720 end if; 13721 end Dispatching_Domain; 13722 13723 --------------- 13724 -- Elaborate -- 13725 --------------- 13726 13727 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); 13728 13729 when Pragma_Elaborate => Elaborate : declare 13730 Arg : Node_Id; 13731 Citem : Node_Id; 13732 13733 begin 13734 -- Pragma must be in context items list of a compilation unit 13735 13736 if not Is_In_Context_Clause then 13737 Pragma_Misplaced; 13738 end if; 13739 13740 -- Must be at least one argument 13741 13742 if Arg_Count = 0 then 13743 Error_Pragma ("pragma% requires at least one argument"); 13744 end if; 13745 13746 -- In Ada 83 mode, there can be no items following it in the 13747 -- context list except other pragmas and implicit with clauses 13748 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this 13749 -- placement rule does not apply. 13750 13751 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 13752 Citem := Next (N); 13753 while Present (Citem) loop 13754 if Nkind (Citem) = N_Pragma 13755 or else (Nkind (Citem) = N_With_Clause 13756 and then Implicit_With (Citem)) 13757 then 13758 null; 13759 else 13760 Error_Pragma 13761 ("(Ada 83) pragma% must be at end of context clause"); 13762 end if; 13763 13764 Next (Citem); 13765 end loop; 13766 end if; 13767 13768 -- Finally, the arguments must all be units mentioned in a with 13769 -- clause in the same context clause. Note we already checked (in 13770 -- Par.Prag) that the arguments are all identifiers or selected 13771 -- components. 13772 13773 Arg := Arg1; 13774 Outer : while Present (Arg) loop 13775 Citem := First (List_Containing (N)); 13776 Inner : while Citem /= N loop 13777 if Nkind (Citem) = N_With_Clause 13778 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 13779 then 13780 Set_Elaborate_Present (Citem, True); 13781 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 13782 13783 -- With the pragma present, elaboration calls on 13784 -- subprograms from the named unit need no further 13785 -- checks, as long as the pragma appears in the current 13786 -- compilation unit. If the pragma appears in some unit 13787 -- in the context, there might still be a need for an 13788 -- Elaborate_All_Desirable from the current compilation 13789 -- to the named unit, so we keep the check enabled. 13790 13791 if In_Extended_Main_Source_Unit (N) then 13792 13793 -- This does not apply in SPARK mode, where we allow 13794 -- pragma Elaborate, but we don't trust it to be right 13795 -- so we will still insist on the Elaborate_All. 13796 13797 if SPARK_Mode /= On then 13798 Set_Suppress_Elaboration_Warnings 13799 (Entity (Name (Citem))); 13800 end if; 13801 end if; 13802 13803 exit Inner; 13804 end if; 13805 13806 Next (Citem); 13807 end loop Inner; 13808 13809 if Citem = N then 13810 Error_Pragma_Arg 13811 ("argument of pragma% is not withed unit", Arg); 13812 end if; 13813 13814 Next (Arg); 13815 end loop Outer; 13816 13817 -- Give a warning if operating in static mode with one of the 13818 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set. 13819 13820 if Elab_Warnings 13821 and not Dynamic_Elaboration_Checks 13822 13823 -- pragma Elaborate not allowed in SPARK mode anyway. We 13824 -- already complained about it, no point in generating any 13825 -- further complaint. 13826 13827 and SPARK_Mode /= On 13828 then 13829 Error_Msg_N 13830 ("?l?use of pragma Elaborate may not be safe", N); 13831 Error_Msg_N 13832 ("?l?use pragma Elaborate_All instead if possible", N); 13833 end if; 13834 end Elaborate; 13835 13836 ------------------- 13837 -- Elaborate_All -- 13838 ------------------- 13839 13840 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); 13841 13842 when Pragma_Elaborate_All => Elaborate_All : declare 13843 Arg : Node_Id; 13844 Citem : Node_Id; 13845 13846 begin 13847 Check_Ada_83_Warning; 13848 13849 -- Pragma must be in context items list of a compilation unit 13850 13851 if not Is_In_Context_Clause then 13852 Pragma_Misplaced; 13853 end if; 13854 13855 -- Must be at least one argument 13856 13857 if Arg_Count = 0 then 13858 Error_Pragma ("pragma% requires at least one argument"); 13859 end if; 13860 13861 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not 13862 -- have to appear at the end of the context clause, but may 13863 -- appear mixed in with other items, even in Ada 83 mode. 13864 13865 -- Final check: the arguments must all be units mentioned in 13866 -- a with clause in the same context clause. Note that we 13867 -- already checked (in Par.Prag) that all the arguments are 13868 -- either identifiers or selected components. 13869 13870 Arg := Arg1; 13871 Outr : while Present (Arg) loop 13872 Citem := First (List_Containing (N)); 13873 Innr : while Citem /= N loop 13874 if Nkind (Citem) = N_With_Clause 13875 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 13876 then 13877 Set_Elaborate_All_Present (Citem, True); 13878 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 13879 13880 -- Suppress warnings and elaboration checks on the named 13881 -- unit if the pragma is in the current compilation, as 13882 -- for pragma Elaborate. 13883 13884 if In_Extended_Main_Source_Unit (N) then 13885 Set_Suppress_Elaboration_Warnings 13886 (Entity (Name (Citem))); 13887 end if; 13888 exit Innr; 13889 end if; 13890 13891 Next (Citem); 13892 end loop Innr; 13893 13894 if Citem = N then 13895 Set_Error_Posted (N); 13896 Error_Pragma_Arg 13897 ("argument of pragma% is not withed unit", Arg); 13898 end if; 13899 13900 Next (Arg); 13901 end loop Outr; 13902 end Elaborate_All; 13903 13904 -------------------- 13905 -- Elaborate_Body -- 13906 -------------------- 13907 13908 -- pragma Elaborate_Body [( library_unit_NAME )]; 13909 13910 when Pragma_Elaborate_Body => Elaborate_Body : declare 13911 Cunit_Node : Node_Id; 13912 Cunit_Ent : Entity_Id; 13913 13914 begin 13915 Check_Ada_83_Warning; 13916 Check_Valid_Library_Unit_Pragma; 13917 13918 if Nkind (N) = N_Null_Statement then 13919 return; 13920 end if; 13921 13922 Cunit_Node := Cunit (Current_Sem_Unit); 13923 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 13924 13925 -- A pragma that applies to a Ghost entity becomes Ghost for the 13926 -- purposes of legality checks and removal of ignored Ghost code. 13927 13928 Mark_Pragma_As_Ghost (N, Cunit_Ent); 13929 13930 if Nkind_In (Unit (Cunit_Node), N_Package_Body, 13931 N_Subprogram_Body) 13932 then 13933 Error_Pragma ("pragma% must refer to a spec, not a body"); 13934 else 13935 Set_Body_Required (Cunit_Node, True); 13936 Set_Has_Pragma_Elaborate_Body (Cunit_Ent); 13937 13938 -- If we are in dynamic elaboration mode, then we suppress 13939 -- elaboration warnings for the unit, since it is definitely 13940 -- fine NOT to do dynamic checks at the first level (and such 13941 -- checks will be suppressed because no elaboration boolean 13942 -- is created for Elaborate_Body packages). 13943 13944 -- But in the static model of elaboration, Elaborate_Body is 13945 -- definitely NOT good enough to ensure elaboration safety on 13946 -- its own, since the body may WITH other units that are not 13947 -- safe from an elaboration point of view, so a client must 13948 -- still do an Elaborate_All on such units. 13949 13950 -- Debug flag -gnatdD restores the old behavior of 3.13, where 13951 -- Elaborate_Body always suppressed elab warnings. 13952 13953 if Dynamic_Elaboration_Checks or Debug_Flag_DD then 13954 Set_Suppress_Elaboration_Warnings (Cunit_Ent); 13955 end if; 13956 end if; 13957 end Elaborate_Body; 13958 13959 ------------------------ 13960 -- Elaboration_Checks -- 13961 ------------------------ 13962 13963 -- pragma Elaboration_Checks (Static | Dynamic); 13964 13965 when Pragma_Elaboration_Checks => 13966 GNAT_Pragma; 13967 Check_Arg_Count (1); 13968 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); 13969 13970 -- Set flag accordingly (ignore attempt at dynamic elaboration 13971 -- checks in SPARK mode). 13972 13973 Dynamic_Elaboration_Checks := 13974 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic) 13975 and then SPARK_Mode /= On; 13976 13977 --------------- 13978 -- Eliminate -- 13979 --------------- 13980 13981 -- pragma Eliminate ( 13982 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, 13983 -- [,[Entity =>] IDENTIFIER | 13984 -- SELECTED_COMPONENT | 13985 -- STRING_LITERAL] 13986 -- [, OVERLOADING_RESOLUTION]); 13987 13988 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE | 13989 -- SOURCE_LOCATION 13990 13991 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE | 13992 -- FUNCTION_PROFILE 13993 13994 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES 13995 13996 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,] 13997 -- Result_Type => result_SUBTYPE_NAME] 13998 13999 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) 14000 -- SUBTYPE_NAME ::= STRING_LITERAL 14001 14002 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE 14003 -- SOURCE_TRACE ::= STRING_LITERAL 14004 14005 when Pragma_Eliminate => Eliminate : declare 14006 Args : Args_List (1 .. 5); 14007 Names : constant Name_List (1 .. 5) := ( 14008 Name_Unit_Name, 14009 Name_Entity, 14010 Name_Parameter_Types, 14011 Name_Result_Type, 14012 Name_Source_Location); 14013 14014 Unit_Name : Node_Id renames Args (1); 14015 Entity : Node_Id renames Args (2); 14016 Parameter_Types : Node_Id renames Args (3); 14017 Result_Type : Node_Id renames Args (4); 14018 Source_Location : Node_Id renames Args (5); 14019 14020 begin 14021 GNAT_Pragma; 14022 Check_Valid_Configuration_Pragma; 14023 Gather_Associations (Names, Args); 14024 14025 if No (Unit_Name) then 14026 Error_Pragma ("missing Unit_Name argument for pragma%"); 14027 end if; 14028 14029 if No (Entity) 14030 and then (Present (Parameter_Types) 14031 or else 14032 Present (Result_Type) 14033 or else 14034 Present (Source_Location)) 14035 then 14036 Error_Pragma ("missing Entity argument for pragma%"); 14037 end if; 14038 14039 if (Present (Parameter_Types) 14040 or else 14041 Present (Result_Type)) 14042 and then 14043 Present (Source_Location) 14044 then 14045 Error_Pragma 14046 ("parameter profile and source location cannot be used " 14047 & "together in pragma%"); 14048 end if; 14049 14050 Process_Eliminate_Pragma 14051 (N, 14052 Unit_Name, 14053 Entity, 14054 Parameter_Types, 14055 Result_Type, 14056 Source_Location); 14057 end Eliminate; 14058 14059 ----------------------------------- 14060 -- Enable_Atomic_Synchronization -- 14061 ----------------------------------- 14062 14063 -- pragma Enable_Atomic_Synchronization [(Entity)]; 14064 14065 when Pragma_Enable_Atomic_Synchronization => 14066 GNAT_Pragma; 14067 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress); 14068 14069 ------------ 14070 -- Export -- 14071 ------------ 14072 14073 -- pragma Export ( 14074 -- [ Convention =>] convention_IDENTIFIER, 14075 -- [ Entity =>] LOCAL_NAME 14076 -- [, [External_Name =>] static_string_EXPRESSION ] 14077 -- [, [Link_Name =>] static_string_EXPRESSION ]); 14078 14079 when Pragma_Export => Export : declare 14080 C : Convention_Id; 14081 Def_Id : Entity_Id; 14082 14083 pragma Warnings (Off, C); 14084 14085 begin 14086 Check_Ada_83_Warning; 14087 Check_Arg_Order 14088 ((Name_Convention, 14089 Name_Entity, 14090 Name_External_Name, 14091 Name_Link_Name)); 14092 14093 Check_At_Least_N_Arguments (2); 14094 Check_At_Most_N_Arguments (4); 14095 14096 -- In Relaxed_RM_Semantics, support old Ada 83 style: 14097 -- pragma Export (Entity, "external name"); 14098 14099 if Relaxed_RM_Semantics 14100 and then Arg_Count = 2 14101 and then Nkind (Expression (Arg2)) = N_String_Literal 14102 then 14103 C := Convention_C; 14104 Def_Id := Get_Pragma_Arg (Arg1); 14105 Analyze (Def_Id); 14106 14107 if not Is_Entity_Name (Def_Id) then 14108 Error_Pragma_Arg ("entity name required", Arg1); 14109 end if; 14110 14111 Def_Id := Entity (Def_Id); 14112 Set_Exported (Def_Id, Arg1); 14113 14114 else 14115 Process_Convention (C, Def_Id); 14116 14117 -- A pragma that applies to a Ghost entity becomes Ghost for 14118 -- the purposes of legality checks and removal of ignored Ghost 14119 -- code. 14120 14121 Mark_Pragma_As_Ghost (N, Def_Id); 14122 14123 if Ekind (Def_Id) /= E_Constant then 14124 Note_Possible_Modification 14125 (Get_Pragma_Arg (Arg2), Sure => False); 14126 end if; 14127 14128 Process_Interface_Name (Def_Id, Arg3, Arg4); 14129 Set_Exported (Def_Id, Arg2); 14130 end if; 14131 14132 -- If the entity is a deferred constant, propagate the information 14133 -- to the full view, because gigi elaborates the full view only. 14134 14135 if Ekind (Def_Id) = E_Constant 14136 and then Present (Full_View (Def_Id)) 14137 then 14138 declare 14139 Id2 : constant Entity_Id := Full_View (Def_Id); 14140 begin 14141 Set_Is_Exported (Id2, Is_Exported (Def_Id)); 14142 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); 14143 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); 14144 end; 14145 end if; 14146 end Export; 14147 14148 --------------------- 14149 -- Export_Function -- 14150 --------------------- 14151 14152 -- pragma Export_Function ( 14153 -- [Internal =>] LOCAL_NAME 14154 -- [, [External =>] EXTERNAL_SYMBOL] 14155 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 14156 -- [, [Result_Type =>] TYPE_DESIGNATOR] 14157 -- [, [Mechanism =>] MECHANISM] 14158 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 14159 14160 -- EXTERNAL_SYMBOL ::= 14161 -- IDENTIFIER 14162 -- | static_string_EXPRESSION 14163 14164 -- PARAMETER_TYPES ::= 14165 -- null 14166 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 14167 14168 -- TYPE_DESIGNATOR ::= 14169 -- subtype_NAME 14170 -- | subtype_Name ' Access 14171 14172 -- MECHANISM ::= 14173 -- MECHANISM_NAME 14174 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 14175 14176 -- MECHANISM_ASSOCIATION ::= 14177 -- [formal_parameter_NAME =>] MECHANISM_NAME 14178 14179 -- MECHANISM_NAME ::= 14180 -- Value 14181 -- | Reference 14182 14183 when Pragma_Export_Function => Export_Function : declare 14184 Args : Args_List (1 .. 6); 14185 Names : constant Name_List (1 .. 6) := ( 14186 Name_Internal, 14187 Name_External, 14188 Name_Parameter_Types, 14189 Name_Result_Type, 14190 Name_Mechanism, 14191 Name_Result_Mechanism); 14192 14193 Internal : Node_Id renames Args (1); 14194 External : Node_Id renames Args (2); 14195 Parameter_Types : Node_Id renames Args (3); 14196 Result_Type : Node_Id renames Args (4); 14197 Mechanism : Node_Id renames Args (5); 14198 Result_Mechanism : Node_Id renames Args (6); 14199 14200 begin 14201 GNAT_Pragma; 14202 Gather_Associations (Names, Args); 14203 Process_Extended_Import_Export_Subprogram_Pragma ( 14204 Arg_Internal => Internal, 14205 Arg_External => External, 14206 Arg_Parameter_Types => Parameter_Types, 14207 Arg_Result_Type => Result_Type, 14208 Arg_Mechanism => Mechanism, 14209 Arg_Result_Mechanism => Result_Mechanism); 14210 end Export_Function; 14211 14212 ------------------- 14213 -- Export_Object -- 14214 ------------------- 14215 14216 -- pragma Export_Object ( 14217 -- [Internal =>] LOCAL_NAME 14218 -- [, [External =>] EXTERNAL_SYMBOL] 14219 -- [, [Size =>] EXTERNAL_SYMBOL]); 14220 14221 -- EXTERNAL_SYMBOL ::= 14222 -- IDENTIFIER 14223 -- | static_string_EXPRESSION 14224 14225 -- PARAMETER_TYPES ::= 14226 -- null 14227 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 14228 14229 -- TYPE_DESIGNATOR ::= 14230 -- subtype_NAME 14231 -- | subtype_Name ' Access 14232 14233 -- MECHANISM ::= 14234 -- MECHANISM_NAME 14235 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 14236 14237 -- MECHANISM_ASSOCIATION ::= 14238 -- [formal_parameter_NAME =>] MECHANISM_NAME 14239 14240 -- MECHANISM_NAME ::= 14241 -- Value 14242 -- | Reference 14243 14244 when Pragma_Export_Object => Export_Object : declare 14245 Args : Args_List (1 .. 3); 14246 Names : constant Name_List (1 .. 3) := ( 14247 Name_Internal, 14248 Name_External, 14249 Name_Size); 14250 14251 Internal : Node_Id renames Args (1); 14252 External : Node_Id renames Args (2); 14253 Size : Node_Id renames Args (3); 14254 14255 begin 14256 GNAT_Pragma; 14257 Gather_Associations (Names, Args); 14258 Process_Extended_Import_Export_Object_Pragma ( 14259 Arg_Internal => Internal, 14260 Arg_External => External, 14261 Arg_Size => Size); 14262 end Export_Object; 14263 14264 ---------------------- 14265 -- Export_Procedure -- 14266 ---------------------- 14267 14268 -- pragma Export_Procedure ( 14269 -- [Internal =>] LOCAL_NAME 14270 -- [, [External =>] EXTERNAL_SYMBOL] 14271 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 14272 -- [, [Mechanism =>] MECHANISM]); 14273 14274 -- EXTERNAL_SYMBOL ::= 14275 -- IDENTIFIER 14276 -- | static_string_EXPRESSION 14277 14278 -- PARAMETER_TYPES ::= 14279 -- null 14280 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 14281 14282 -- TYPE_DESIGNATOR ::= 14283 -- subtype_NAME 14284 -- | subtype_Name ' Access 14285 14286 -- MECHANISM ::= 14287 -- MECHANISM_NAME 14288 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 14289 14290 -- MECHANISM_ASSOCIATION ::= 14291 -- [formal_parameter_NAME =>] MECHANISM_NAME 14292 14293 -- MECHANISM_NAME ::= 14294 -- Value 14295 -- | Reference 14296 14297 when Pragma_Export_Procedure => Export_Procedure : declare 14298 Args : Args_List (1 .. 4); 14299 Names : constant Name_List (1 .. 4) := ( 14300 Name_Internal, 14301 Name_External, 14302 Name_Parameter_Types, 14303 Name_Mechanism); 14304 14305 Internal : Node_Id renames Args (1); 14306 External : Node_Id renames Args (2); 14307 Parameter_Types : Node_Id renames Args (3); 14308 Mechanism : Node_Id renames Args (4); 14309 14310 begin 14311 GNAT_Pragma; 14312 Gather_Associations (Names, Args); 14313 Process_Extended_Import_Export_Subprogram_Pragma ( 14314 Arg_Internal => Internal, 14315 Arg_External => External, 14316 Arg_Parameter_Types => Parameter_Types, 14317 Arg_Mechanism => Mechanism); 14318 end Export_Procedure; 14319 14320 ------------------ 14321 -- Export_Value -- 14322 ------------------ 14323 14324 -- pragma Export_Value ( 14325 -- [Value =>] static_integer_EXPRESSION, 14326 -- [Link_Name =>] static_string_EXPRESSION); 14327 14328 when Pragma_Export_Value => 14329 GNAT_Pragma; 14330 Check_Arg_Order ((Name_Value, Name_Link_Name)); 14331 Check_Arg_Count (2); 14332 14333 Check_Optional_Identifier (Arg1, Name_Value); 14334 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); 14335 14336 Check_Optional_Identifier (Arg2, Name_Link_Name); 14337 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 14338 14339 ----------------------------- 14340 -- Export_Valued_Procedure -- 14341 ----------------------------- 14342 14343 -- pragma Export_Valued_Procedure ( 14344 -- [Internal =>] LOCAL_NAME 14345 -- [, [External =>] EXTERNAL_SYMBOL,] 14346 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 14347 -- [, [Mechanism =>] MECHANISM]); 14348 14349 -- EXTERNAL_SYMBOL ::= 14350 -- IDENTIFIER 14351 -- | static_string_EXPRESSION 14352 14353 -- PARAMETER_TYPES ::= 14354 -- null 14355 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 14356 14357 -- TYPE_DESIGNATOR ::= 14358 -- subtype_NAME 14359 -- | subtype_Name ' Access 14360 14361 -- MECHANISM ::= 14362 -- MECHANISM_NAME 14363 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 14364 14365 -- MECHANISM_ASSOCIATION ::= 14366 -- [formal_parameter_NAME =>] MECHANISM_NAME 14367 14368 -- MECHANISM_NAME ::= 14369 -- Value 14370 -- | Reference 14371 14372 when Pragma_Export_Valued_Procedure => 14373 Export_Valued_Procedure : declare 14374 Args : Args_List (1 .. 4); 14375 Names : constant Name_List (1 .. 4) := ( 14376 Name_Internal, 14377 Name_External, 14378 Name_Parameter_Types, 14379 Name_Mechanism); 14380 14381 Internal : Node_Id renames Args (1); 14382 External : Node_Id renames Args (2); 14383 Parameter_Types : Node_Id renames Args (3); 14384 Mechanism : Node_Id renames Args (4); 14385 14386 begin 14387 GNAT_Pragma; 14388 Gather_Associations (Names, Args); 14389 Process_Extended_Import_Export_Subprogram_Pragma ( 14390 Arg_Internal => Internal, 14391 Arg_External => External, 14392 Arg_Parameter_Types => Parameter_Types, 14393 Arg_Mechanism => Mechanism); 14394 end Export_Valued_Procedure; 14395 14396 ------------------- 14397 -- Extend_System -- 14398 ------------------- 14399 14400 -- pragma Extend_System ([Name =>] Identifier); 14401 14402 when Pragma_Extend_System => Extend_System : declare 14403 begin 14404 GNAT_Pragma; 14405 Check_Valid_Configuration_Pragma; 14406 Check_Arg_Count (1); 14407 Check_Optional_Identifier (Arg1, Name_Name); 14408 Check_Arg_Is_Identifier (Arg1); 14409 14410 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 14411 14412 if Name_Len > 4 14413 and then Name_Buffer (1 .. 4) = "aux_" 14414 then 14415 if Present (System_Extend_Pragma_Arg) then 14416 if Chars (Get_Pragma_Arg (Arg1)) = 14417 Chars (Expression (System_Extend_Pragma_Arg)) 14418 then 14419 null; 14420 else 14421 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg); 14422 Error_Pragma ("pragma% conflicts with that #"); 14423 end if; 14424 14425 else 14426 System_Extend_Pragma_Arg := Arg1; 14427 14428 if not GNAT_Mode then 14429 System_Extend_Unit := Arg1; 14430 end if; 14431 end if; 14432 else 14433 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); 14434 end if; 14435 end Extend_System; 14436 14437 ------------------------ 14438 -- Extensions_Allowed -- 14439 ------------------------ 14440 14441 -- pragma Extensions_Allowed (ON | OFF); 14442 14443 when Pragma_Extensions_Allowed => 14444 GNAT_Pragma; 14445 Check_Arg_Count (1); 14446 Check_No_Identifiers; 14447 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 14448 14449 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 14450 Extensions_Allowed := True; 14451 Ada_Version := Ada_Version_Type'Last; 14452 14453 else 14454 Extensions_Allowed := False; 14455 Ada_Version := Ada_Version_Explicit; 14456 Ada_Version_Pragma := Empty; 14457 end if; 14458 14459 ------------------------ 14460 -- Extensions_Visible -- 14461 ------------------------ 14462 14463 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ]; 14464 14465 -- Characteristics: 14466 14467 -- * Analysis - The annotation is fully analyzed immediately upon 14468 -- elaboration as its expression must be static. 14469 14470 -- * Expansion - None. 14471 14472 -- * Template - The annotation utilizes the generic template of the 14473 -- related subprogram [body] when it is: 14474 14475 -- aspect on subprogram declaration 14476 -- aspect on stand alone subprogram body 14477 -- pragma on stand alone subprogram body 14478 14479 -- The annotation must prepare its own template when it is: 14480 14481 -- pragma on subprogram declaration 14482 14483 -- * Globals - Capture of global references must occur after full 14484 -- analysis. 14485 14486 -- * Instance - The annotation is instantiated automatically when 14487 -- the related generic subprogram [body] is instantiated except for 14488 -- the "pragma on subprogram declaration" case. In that scenario 14489 -- the annotation must instantiate itself. 14490 14491 when Pragma_Extensions_Visible => Extensions_Visible : declare 14492 Formal : Entity_Id; 14493 Has_OK_Formal : Boolean := False; 14494 Spec_Id : Entity_Id; 14495 Subp_Decl : Node_Id; 14496 14497 begin 14498 GNAT_Pragma; 14499 Check_No_Identifiers; 14500 Check_At_Most_N_Arguments (1); 14501 14502 Subp_Decl := 14503 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 14504 14505 -- Abstract subprogram declaration 14506 14507 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 14508 null; 14509 14510 -- Generic subprogram declaration 14511 14512 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 14513 null; 14514 14515 -- Body acts as spec 14516 14517 elsif Nkind (Subp_Decl) = N_Subprogram_Body 14518 and then No (Corresponding_Spec (Subp_Decl)) 14519 then 14520 null; 14521 14522 -- Body stub acts as spec 14523 14524 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 14525 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 14526 then 14527 null; 14528 14529 -- Subprogram declaration 14530 14531 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 14532 null; 14533 14534 -- Otherwise the pragma is associated with an illegal construct 14535 14536 else 14537 Error_Pragma ("pragma % must apply to a subprogram"); 14538 return; 14539 end if; 14540 14541 -- Chain the pragma on the contract for completeness 14542 14543 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 14544 14545 -- The legality checks of pragma Extension_Visible are affected 14546 -- by the SPARK mode in effect. Analyze all pragmas in specific 14547 -- order. 14548 14549 Analyze_If_Present (Pragma_SPARK_Mode); 14550 14551 -- Mark the pragma as Ghost if the related subprogram is also 14552 -- Ghost. This also ensures that any expansion performed further 14553 -- below will produce Ghost nodes. 14554 14555 Spec_Id := Unique_Defining_Entity (Subp_Decl); 14556 Mark_Pragma_As_Ghost (N, Spec_Id); 14557 14558 -- Examine the formals of the related subprogram 14559 14560 Formal := First_Formal (Spec_Id); 14561 while Present (Formal) loop 14562 14563 -- At least one of the formals is of a specific tagged type, 14564 -- the pragma is legal. 14565 14566 if Is_Specific_Tagged_Type (Etype (Formal)) then 14567 Has_OK_Formal := True; 14568 exit; 14569 14570 -- A generic subprogram with at least one formal of a private 14571 -- type ensures the legality of the pragma because the actual 14572 -- may be specifically tagged. Note that this is verified by 14573 -- the check above at instantiation time. 14574 14575 elsif Is_Private_Type (Etype (Formal)) 14576 and then Is_Generic_Type (Etype (Formal)) 14577 then 14578 Has_OK_Formal := True; 14579 exit; 14580 end if; 14581 14582 Next_Formal (Formal); 14583 end loop; 14584 14585 if not Has_OK_Formal then 14586 Error_Msg_Name_1 := Pname; 14587 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N); 14588 Error_Msg_NE 14589 ("\subprogram & lacks parameter of specific tagged or " 14590 & "generic private type", N, Spec_Id); 14591 14592 return; 14593 end if; 14594 14595 -- Analyze the Boolean expression (if any) 14596 14597 if Present (Arg1) then 14598 Check_Static_Boolean_Expression 14599 (Expression (Get_Argument (N, Spec_Id))); 14600 end if; 14601 end Extensions_Visible; 14602 14603 -------------- 14604 -- External -- 14605 -------------- 14606 14607 -- pragma External ( 14608 -- [ Convention =>] convention_IDENTIFIER, 14609 -- [ Entity =>] LOCAL_NAME 14610 -- [, [External_Name =>] static_string_EXPRESSION ] 14611 -- [, [Link_Name =>] static_string_EXPRESSION ]); 14612 14613 when Pragma_External => External : declare 14614 C : Convention_Id; 14615 E : Entity_Id; 14616 pragma Warnings (Off, C); 14617 14618 begin 14619 GNAT_Pragma; 14620 Check_Arg_Order 14621 ((Name_Convention, 14622 Name_Entity, 14623 Name_External_Name, 14624 Name_Link_Name)); 14625 Check_At_Least_N_Arguments (2); 14626 Check_At_Most_N_Arguments (4); 14627 Process_Convention (C, E); 14628 14629 -- A pragma that applies to a Ghost entity becomes Ghost for the 14630 -- purposes of legality checks and removal of ignored Ghost code. 14631 14632 Mark_Pragma_As_Ghost (N, E); 14633 14634 Note_Possible_Modification 14635 (Get_Pragma_Arg (Arg2), Sure => False); 14636 Process_Interface_Name (E, Arg3, Arg4); 14637 Set_Exported (E, Arg2); 14638 end External; 14639 14640 -------------------------- 14641 -- External_Name_Casing -- 14642 -------------------------- 14643 14644 -- pragma External_Name_Casing ( 14645 -- UPPERCASE | LOWERCASE 14646 -- [, AS_IS | UPPERCASE | LOWERCASE]); 14647 14648 when Pragma_External_Name_Casing => External_Name_Casing : declare 14649 begin 14650 GNAT_Pragma; 14651 Check_No_Identifiers; 14652 14653 if Arg_Count = 2 then 14654 Check_Arg_Is_One_Of 14655 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase); 14656 14657 case Chars (Get_Pragma_Arg (Arg2)) is 14658 when Name_As_Is => 14659 Opt.External_Name_Exp_Casing := As_Is; 14660 14661 when Name_Uppercase => 14662 Opt.External_Name_Exp_Casing := Uppercase; 14663 14664 when Name_Lowercase => 14665 Opt.External_Name_Exp_Casing := Lowercase; 14666 14667 when others => 14668 null; 14669 end case; 14670 14671 else 14672 Check_Arg_Count (1); 14673 end if; 14674 14675 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase); 14676 14677 case Chars (Get_Pragma_Arg (Arg1)) is 14678 when Name_Uppercase => 14679 Opt.External_Name_Imp_Casing := Uppercase; 14680 14681 when Name_Lowercase => 14682 Opt.External_Name_Imp_Casing := Lowercase; 14683 14684 when others => 14685 null; 14686 end case; 14687 end External_Name_Casing; 14688 14689 --------------- 14690 -- Fast_Math -- 14691 --------------- 14692 14693 -- pragma Fast_Math; 14694 14695 when Pragma_Fast_Math => 14696 GNAT_Pragma; 14697 Check_No_Identifiers; 14698 Check_Valid_Configuration_Pragma; 14699 Fast_Math := True; 14700 14701 -------------------------- 14702 -- Favor_Top_Level -- 14703 -------------------------- 14704 14705 -- pragma Favor_Top_Level (type_NAME); 14706 14707 when Pragma_Favor_Top_Level => Favor_Top_Level : declare 14708 Typ : Entity_Id; 14709 14710 begin 14711 GNAT_Pragma; 14712 Check_No_Identifiers; 14713 Check_Arg_Count (1); 14714 Check_Arg_Is_Local_Name (Arg1); 14715 Typ := Entity (Get_Pragma_Arg (Arg1)); 14716 14717 -- A pragma that applies to a Ghost entity becomes Ghost for the 14718 -- purposes of legality checks and removal of ignored Ghost code. 14719 14720 Mark_Pragma_As_Ghost (N, Typ); 14721 14722 -- If it's an access-to-subprogram type (in particular, not a 14723 -- subtype), set the flag on that type. 14724 14725 if Is_Access_Subprogram_Type (Typ) then 14726 Set_Can_Use_Internal_Rep (Typ, False); 14727 14728 -- Otherwise it's an error (name denotes the wrong sort of entity) 14729 14730 else 14731 Error_Pragma_Arg 14732 ("access-to-subprogram type expected", 14733 Get_Pragma_Arg (Arg1)); 14734 end if; 14735 end Favor_Top_Level; 14736 14737 --------------------------- 14738 -- Finalize_Storage_Only -- 14739 --------------------------- 14740 14741 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); 14742 14743 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare 14744 Assoc : constant Node_Id := Arg1; 14745 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 14746 Typ : Entity_Id; 14747 14748 begin 14749 GNAT_Pragma; 14750 Check_No_Identifiers; 14751 Check_Arg_Count (1); 14752 Check_Arg_Is_Local_Name (Arg1); 14753 14754 Find_Type (Type_Id); 14755 Typ := Entity (Type_Id); 14756 14757 if Typ = Any_Type 14758 or else Rep_Item_Too_Early (Typ, N) 14759 then 14760 return; 14761 else 14762 Typ := Underlying_Type (Typ); 14763 end if; 14764 14765 if not Is_Controlled (Typ) then 14766 Error_Pragma ("pragma% must specify controlled type"); 14767 end if; 14768 14769 Check_First_Subtype (Arg1); 14770 14771 if Finalize_Storage_Only (Typ) then 14772 Error_Pragma ("duplicate pragma%, only one allowed"); 14773 14774 elsif not Rep_Item_Too_Late (Typ, N) then 14775 Set_Finalize_Storage_Only (Base_Type (Typ), True); 14776 end if; 14777 end Finalize_Storage; 14778 14779 ----------- 14780 -- Ghost -- 14781 ----------- 14782 14783 -- pragma Ghost [ (boolean_EXPRESSION) ]; 14784 14785 when Pragma_Ghost => Ghost : declare 14786 Context : Node_Id; 14787 Expr : Node_Id; 14788 Id : Entity_Id; 14789 Orig_Stmt : Node_Id; 14790 Prev_Id : Entity_Id; 14791 Stmt : Node_Id; 14792 14793 begin 14794 GNAT_Pragma; 14795 Check_No_Identifiers; 14796 Check_At_Most_N_Arguments (1); 14797 14798 Id := Empty; 14799 Stmt := Prev (N); 14800 while Present (Stmt) loop 14801 14802 -- Skip prior pragmas, but check for duplicates 14803 14804 if Nkind (Stmt) = N_Pragma then 14805 if Pragma_Name (Stmt) = Pname then 14806 Error_Msg_Name_1 := Pname; 14807 Error_Msg_Sloc := Sloc (Stmt); 14808 Error_Msg_N ("pragma % duplicates pragma declared#", N); 14809 end if; 14810 14811 -- Task unit declared without a definition cannot be subject to 14812 -- pragma Ghost (SPARK RM 6.9(19)). 14813 14814 elsif Nkind_In (Stmt, N_Single_Task_Declaration, 14815 N_Task_Type_Declaration) 14816 then 14817 Error_Pragma ("pragma % cannot apply to a task type"); 14818 return; 14819 14820 -- Skip internally generated code 14821 14822 elsif not Comes_From_Source (Stmt) then 14823 Orig_Stmt := Original_Node (Stmt); 14824 14825 -- When pragma Ghost applies to an untagged derivation, the 14826 -- derivation is transformed into a [sub]type declaration. 14827 14828 if Nkind_In (Stmt, N_Full_Type_Declaration, 14829 N_Subtype_Declaration) 14830 and then Comes_From_Source (Orig_Stmt) 14831 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration 14832 and then Nkind (Type_Definition (Orig_Stmt)) = 14833 N_Derived_Type_Definition 14834 then 14835 Id := Defining_Entity (Stmt); 14836 exit; 14837 14838 -- When pragma Ghost applies to an expression function, the 14839 -- expression function is transformed into a subprogram. 14840 14841 elsif Nkind (Stmt) = N_Subprogram_Declaration 14842 and then Comes_From_Source (Orig_Stmt) 14843 and then Nkind (Orig_Stmt) = N_Expression_Function 14844 then 14845 Id := Defining_Entity (Stmt); 14846 exit; 14847 end if; 14848 14849 -- The pragma applies to a legal construct, stop the traversal 14850 14851 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration, 14852 N_Full_Type_Declaration, 14853 N_Generic_Subprogram_Declaration, 14854 N_Object_Declaration, 14855 N_Private_Extension_Declaration, 14856 N_Private_Type_Declaration, 14857 N_Subprogram_Declaration, 14858 N_Subtype_Declaration) 14859 then 14860 Id := Defining_Entity (Stmt); 14861 exit; 14862 14863 -- The pragma does not apply to a legal construct, issue an 14864 -- error and stop the analysis. 14865 14866 else 14867 Error_Pragma 14868 ("pragma % must apply to an object, package, subprogram " 14869 & "or type"); 14870 return; 14871 end if; 14872 14873 Stmt := Prev (Stmt); 14874 end loop; 14875 14876 Context := Parent (N); 14877 14878 -- Handle compilation units 14879 14880 if Nkind (Context) = N_Compilation_Unit_Aux then 14881 Context := Unit (Parent (Context)); 14882 end if; 14883 14884 -- Protected and task types cannot be subject to pragma Ghost 14885 -- (SPARK RM 6.9(19)). 14886 14887 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition) 14888 then 14889 Error_Pragma ("pragma % cannot apply to a protected type"); 14890 return; 14891 14892 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then 14893 Error_Pragma ("pragma % cannot apply to a task type"); 14894 return; 14895 end if; 14896 14897 if No (Id) then 14898 14899 -- When pragma Ghost is associated with a [generic] package, it 14900 -- appears in the visible declarations. 14901 14902 if Nkind (Context) = N_Package_Specification 14903 and then Present (Visible_Declarations (Context)) 14904 and then List_Containing (N) = Visible_Declarations (Context) 14905 then 14906 Id := Defining_Entity (Context); 14907 14908 -- Pragma Ghost applies to a stand alone subprogram body 14909 14910 elsif Nkind (Context) = N_Subprogram_Body 14911 and then No (Corresponding_Spec (Context)) 14912 then 14913 Id := Defining_Entity (Context); 14914 end if; 14915 end if; 14916 14917 if No (Id) then 14918 Error_Pragma 14919 ("pragma % must apply to an object, package, subprogram or " 14920 & "type"); 14921 return; 14922 end if; 14923 14924 -- A derived type or type extension cannot be subject to pragma 14925 -- Ghost if either the parent type or one of the progenitor types 14926 -- is not Ghost (SPARK RM 6.9(9)). 14927 14928 if Is_Derived_Type (Id) then 14929 Check_Ghost_Derivation (Id); 14930 end if; 14931 14932 -- Handle completions of types and constants that are subject to 14933 -- pragma Ghost. 14934 14935 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then 14936 Prev_Id := Incomplete_Or_Partial_View (Id); 14937 14938 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then 14939 Error_Msg_Name_1 := Pname; 14940 14941 -- The full declaration of a deferred constant cannot be 14942 -- subject to pragma Ghost unless the deferred declaration 14943 -- is also Ghost (SPARK RM 6.9(10)). 14944 14945 if Ekind (Prev_Id) = E_Constant then 14946 Error_Msg_Name_1 := Pname; 14947 Error_Msg_NE (Fix_Error 14948 ("pragma % must apply to declaration of deferred " 14949 & "constant &"), N, Id); 14950 return; 14951 14952 -- Pragma Ghost may appear on the full view of an incomplete 14953 -- type because the incomplete declaration lacks aspects and 14954 -- cannot be subject to pragma Ghost. 14955 14956 elsif Ekind (Prev_Id) = E_Incomplete_Type then 14957 null; 14958 14959 -- The full declaration of a type cannot be subject to 14960 -- pragma Ghost unless the partial view is also Ghost 14961 -- (SPARK RM 6.9(10)). 14962 14963 else 14964 Error_Msg_NE (Fix_Error 14965 ("pragma % must apply to partial view of type &"), 14966 N, Id); 14967 return; 14968 end if; 14969 end if; 14970 14971 -- A synchronized object cannot be subject to pragma Ghost 14972 -- (SPARK RM 6.9(19)). 14973 14974 elsif Ekind (Id) = E_Variable then 14975 if Is_Protected_Type (Etype (Id)) then 14976 Error_Pragma ("pragma % cannot apply to a protected object"); 14977 return; 14978 14979 elsif Is_Task_Type (Etype (Id)) then 14980 Error_Pragma ("pragma % cannot apply to a task object"); 14981 return; 14982 end if; 14983 end if; 14984 14985 -- Analyze the Boolean expression (if any) 14986 14987 if Present (Arg1) then 14988 Expr := Get_Pragma_Arg (Arg1); 14989 14990 Analyze_And_Resolve (Expr, Standard_Boolean); 14991 14992 if Is_OK_Static_Expression (Expr) then 14993 14994 -- "Ghostness" cannot be turned off once enabled within a 14995 -- region (SPARK RM 6.9(7)). 14996 14997 if Is_False (Expr_Value (Expr)) 14998 and then Ghost_Mode > None 14999 then 15000 Error_Pragma 15001 ("pragma % with value False cannot appear in enabled " 15002 & "ghost region"); 15003 return; 15004 end if; 15005 15006 -- Otherwie the expression is not static 15007 15008 else 15009 Error_Pragma_Arg 15010 ("expression of pragma % must be static", Expr); 15011 return; 15012 end if; 15013 end if; 15014 15015 Set_Is_Ghost_Entity (Id); 15016 end Ghost; 15017 15018 ------------ 15019 -- Global -- 15020 ------------ 15021 15022 -- pragma Global (GLOBAL_SPECIFICATION); 15023 15024 -- GLOBAL_SPECIFICATION ::= 15025 -- null 15026 -- | (GLOBAL_LIST) 15027 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}) 15028 15029 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 15030 15031 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 15032 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 15033 -- GLOBAL_ITEM ::= NAME 15034 15035 -- Characteristics: 15036 15037 -- * Analysis - The annotation undergoes initial checks to verify 15038 -- the legal placement and context. Secondary checks fully analyze 15039 -- the dependency clauses in: 15040 15041 -- Analyze_Global_In_Decl_Part 15042 15043 -- * Expansion - None. 15044 15045 -- * Template - The annotation utilizes the generic template of the 15046 -- related subprogram [body] when it is: 15047 15048 -- aspect on subprogram declaration 15049 -- aspect on stand alone subprogram body 15050 -- pragma on stand alone subprogram body 15051 15052 -- The annotation must prepare its own template when it is: 15053 15054 -- pragma on subprogram declaration 15055 15056 -- * Globals - Capture of global references must occur after full 15057 -- analysis. 15058 15059 -- * Instance - The annotation is instantiated automatically when 15060 -- the related generic subprogram [body] is instantiated except for 15061 -- the "pragma on subprogram declaration" case. In that scenario 15062 -- the annotation must instantiate itself. 15063 15064 when Pragma_Global => Global : declare 15065 Legal : Boolean; 15066 Spec_Id : Entity_Id; 15067 Subp_Decl : Node_Id; 15068 15069 begin 15070 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); 15071 15072 if Legal then 15073 15074 -- Chain the pragma on the contract for further processing by 15075 -- Analyze_Global_In_Decl_Part. 15076 15077 Add_Contract_Item (N, Spec_Id); 15078 15079 -- Fully analyze the pragma when it appears inside an entry 15080 -- or subprogram body because it cannot benefit from forward 15081 -- references. 15082 15083 if Nkind_In (Subp_Decl, N_Entry_Body, 15084 N_Subprogram_Body, 15085 N_Subprogram_Body_Stub) 15086 then 15087 -- The legality checks of pragmas Depends and Global are 15088 -- affected by the SPARK mode in effect and the volatility 15089 -- of the context. In addition these two pragmas are subject 15090 -- to an inherent order: 15091 15092 -- 1) Global 15093 -- 2) Depends 15094 15095 -- Analyze all these pragmas in the order outlined above 15096 15097 Analyze_If_Present (Pragma_SPARK_Mode); 15098 Analyze_If_Present (Pragma_Volatile_Function); 15099 Analyze_Global_In_Decl_Part (N); 15100 Analyze_If_Present (Pragma_Depends); 15101 end if; 15102 end if; 15103 end Global; 15104 15105 ----------- 15106 -- Ident -- 15107 ----------- 15108 15109 -- pragma Ident (static_string_EXPRESSION) 15110 15111 -- Note: pragma Comment shares this processing. Pragma Ident is 15112 -- identical in effect to pragma Commment. 15113 15114 when Pragma_Ident | Pragma_Comment => Ident : declare 15115 Str : Node_Id; 15116 15117 begin 15118 GNAT_Pragma; 15119 Check_Arg_Count (1); 15120 Check_No_Identifiers; 15121 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 15122 Store_Note (N); 15123 15124 Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); 15125 15126 declare 15127 CS : Node_Id; 15128 GP : Node_Id; 15129 15130 begin 15131 GP := Parent (Parent (N)); 15132 15133 if Nkind_In (GP, N_Package_Declaration, 15134 N_Generic_Package_Declaration) 15135 then 15136 GP := Parent (GP); 15137 end if; 15138 15139 -- If we have a compilation unit, then record the ident value, 15140 -- checking for improper duplication. 15141 15142 if Nkind (GP) = N_Compilation_Unit then 15143 CS := Ident_String (Current_Sem_Unit); 15144 15145 if Present (CS) then 15146 15147 -- If we have multiple instances, concatenate them, but 15148 -- not in ASIS, where we want the original tree. 15149 15150 if not ASIS_Mode then 15151 Start_String (Strval (CS)); 15152 Store_String_Char (' '); 15153 Store_String_Chars (Strval (Str)); 15154 Set_Strval (CS, End_String); 15155 end if; 15156 15157 else 15158 Set_Ident_String (Current_Sem_Unit, Str); 15159 end if; 15160 15161 -- For subunits, we just ignore the Ident, since in GNAT these 15162 -- are not separate object files, and hence not separate units 15163 -- in the unit table. 15164 15165 elsif Nkind (GP) = N_Subunit then 15166 null; 15167 end if; 15168 end; 15169 end Ident; 15170 15171 ------------------- 15172 -- Ignore_Pragma -- 15173 ------------------- 15174 15175 -- pragma Ignore_Pragma (pragma_IDENTIFIER); 15176 15177 -- Entirely handled in the parser, nothing to do here 15178 15179 when Pragma_Ignore_Pragma => 15180 null; 15181 15182 ---------------------------- 15183 -- Implementation_Defined -- 15184 ---------------------------- 15185 15186 -- pragma Implementation_Defined (LOCAL_NAME); 15187 15188 -- Marks previously declared entity as implementation defined. For 15189 -- an overloaded entity, applies to the most recent homonym. 15190 15191 -- pragma Implementation_Defined; 15192 15193 -- The form with no arguments appears anywhere within a scope, most 15194 -- typically a package spec, and indicates that all entities that are 15195 -- defined within the package spec are Implementation_Defined. 15196 15197 when Pragma_Implementation_Defined => Implementation_Defined : declare 15198 Ent : Entity_Id; 15199 15200 begin 15201 GNAT_Pragma; 15202 Check_No_Identifiers; 15203 15204 -- Form with no arguments 15205 15206 if Arg_Count = 0 then 15207 Set_Is_Implementation_Defined (Current_Scope); 15208 15209 -- Form with one argument 15210 15211 else 15212 Check_Arg_Count (1); 15213 Check_Arg_Is_Local_Name (Arg1); 15214 Ent := Entity (Get_Pragma_Arg (Arg1)); 15215 Set_Is_Implementation_Defined (Ent); 15216 end if; 15217 end Implementation_Defined; 15218 15219 ----------------- 15220 -- Implemented -- 15221 ----------------- 15222 15223 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND); 15224 15225 -- IMPLEMENTATION_KIND ::= 15226 -- By_Entry | By_Protected_Procedure | By_Any | Optional 15227 15228 -- "By_Any" and "Optional" are treated as synonyms in order to 15229 -- support Ada 2012 aspect Synchronization. 15230 15231 when Pragma_Implemented => Implemented : declare 15232 Proc_Id : Entity_Id; 15233 Typ : Entity_Id; 15234 15235 begin 15236 Ada_2012_Pragma; 15237 Check_Arg_Count (2); 15238 Check_No_Identifiers; 15239 Check_Arg_Is_Identifier (Arg1); 15240 Check_Arg_Is_Local_Name (Arg1); 15241 Check_Arg_Is_One_Of (Arg2, 15242 Name_By_Any, 15243 Name_By_Entry, 15244 Name_By_Protected_Procedure, 15245 Name_Optional); 15246 15247 -- Extract the name of the local procedure 15248 15249 Proc_Id := Entity (Get_Pragma_Arg (Arg1)); 15250 15251 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a 15252 -- primitive procedure of a synchronized tagged type. 15253 15254 if Ekind (Proc_Id) = E_Procedure 15255 and then Is_Primitive (Proc_Id) 15256 and then Present (First_Formal (Proc_Id)) 15257 then 15258 Typ := Etype (First_Formal (Proc_Id)); 15259 15260 if Is_Tagged_Type (Typ) 15261 and then 15262 15263 -- Check for a protected, a synchronized or a task interface 15264 15265 ((Is_Interface (Typ) 15266 and then Is_Synchronized_Interface (Typ)) 15267 15268 -- Check for a protected type or a task type that implements 15269 -- an interface. 15270 15271 or else 15272 (Is_Concurrent_Record_Type (Typ) 15273 and then Present (Interfaces (Typ))) 15274 15275 -- In analysis-only mode, examine original protected type 15276 15277 or else 15278 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration 15279 and then Present (Interface_List (Parent (Typ)))) 15280 15281 -- Check for a private record extension with keyword 15282 -- "synchronized". 15283 15284 or else 15285 (Ekind_In (Typ, E_Record_Type_With_Private, 15286 E_Record_Subtype_With_Private) 15287 and then Synchronized_Present (Parent (Typ)))) 15288 then 15289 null; 15290 else 15291 Error_Pragma_Arg 15292 ("controlling formal must be of synchronized tagged type", 15293 Arg1); 15294 return; 15295 end if; 15296 15297 -- Procedures declared inside a protected type must be accepted 15298 15299 elsif Ekind (Proc_Id) = E_Procedure 15300 and then Is_Protected_Type (Scope (Proc_Id)) 15301 then 15302 null; 15303 15304 -- The first argument is not a primitive procedure 15305 15306 else 15307 Error_Pragma_Arg 15308 ("pragma % must be applied to a primitive procedure", Arg1); 15309 return; 15310 end if; 15311 15312 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind 15313 -- By_Protected_Procedure to the primitive procedure of a task 15314 -- interface. 15315 15316 if Chars (Arg2) = Name_By_Protected_Procedure 15317 and then Is_Interface (Typ) 15318 and then Is_Task_Interface (Typ) 15319 then 15320 Error_Pragma_Arg 15321 ("implementation kind By_Protected_Procedure cannot be " 15322 & "applied to a task interface primitive", Arg2); 15323 return; 15324 end if; 15325 15326 Record_Rep_Item (Proc_Id, N); 15327 end Implemented; 15328 15329 ---------------------- 15330 -- Implicit_Packing -- 15331 ---------------------- 15332 15333 -- pragma Implicit_Packing; 15334 15335 when Pragma_Implicit_Packing => 15336 GNAT_Pragma; 15337 Check_Arg_Count (0); 15338 Implicit_Packing := True; 15339 15340 ------------ 15341 -- Import -- 15342 ------------ 15343 15344 -- pragma Import ( 15345 -- [Convention =>] convention_IDENTIFIER, 15346 -- [Entity =>] LOCAL_NAME 15347 -- [, [External_Name =>] static_string_EXPRESSION ] 15348 -- [, [Link_Name =>] static_string_EXPRESSION ]); 15349 15350 when Pragma_Import => 15351 Check_Ada_83_Warning; 15352 Check_Arg_Order 15353 ((Name_Convention, 15354 Name_Entity, 15355 Name_External_Name, 15356 Name_Link_Name)); 15357 15358 Check_At_Least_N_Arguments (2); 15359 Check_At_Most_N_Arguments (4); 15360 Process_Import_Or_Interface; 15361 15362 --------------------- 15363 -- Import_Function -- 15364 --------------------- 15365 15366 -- pragma Import_Function ( 15367 -- [Internal =>] LOCAL_NAME, 15368 -- [, [External =>] EXTERNAL_SYMBOL] 15369 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 15370 -- [, [Result_Type =>] SUBTYPE_MARK] 15371 -- [, [Mechanism =>] MECHANISM] 15372 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 15373 15374 -- EXTERNAL_SYMBOL ::= 15375 -- IDENTIFIER 15376 -- | static_string_EXPRESSION 15377 15378 -- PARAMETER_TYPES ::= 15379 -- null 15380 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 15381 15382 -- TYPE_DESIGNATOR ::= 15383 -- subtype_NAME 15384 -- | subtype_Name ' Access 15385 15386 -- MECHANISM ::= 15387 -- MECHANISM_NAME 15388 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 15389 15390 -- MECHANISM_ASSOCIATION ::= 15391 -- [formal_parameter_NAME =>] MECHANISM_NAME 15392 15393 -- MECHANISM_NAME ::= 15394 -- Value 15395 -- | Reference 15396 15397 when Pragma_Import_Function => Import_Function : declare 15398 Args : Args_List (1 .. 6); 15399 Names : constant Name_List (1 .. 6) := ( 15400 Name_Internal, 15401 Name_External, 15402 Name_Parameter_Types, 15403 Name_Result_Type, 15404 Name_Mechanism, 15405 Name_Result_Mechanism); 15406 15407 Internal : Node_Id renames Args (1); 15408 External : Node_Id renames Args (2); 15409 Parameter_Types : Node_Id renames Args (3); 15410 Result_Type : Node_Id renames Args (4); 15411 Mechanism : Node_Id renames Args (5); 15412 Result_Mechanism : Node_Id renames Args (6); 15413 15414 begin 15415 GNAT_Pragma; 15416 Gather_Associations (Names, Args); 15417 Process_Extended_Import_Export_Subprogram_Pragma ( 15418 Arg_Internal => Internal, 15419 Arg_External => External, 15420 Arg_Parameter_Types => Parameter_Types, 15421 Arg_Result_Type => Result_Type, 15422 Arg_Mechanism => Mechanism, 15423 Arg_Result_Mechanism => Result_Mechanism); 15424 end Import_Function; 15425 15426 ------------------- 15427 -- Import_Object -- 15428 ------------------- 15429 15430 -- pragma Import_Object ( 15431 -- [Internal =>] LOCAL_NAME 15432 -- [, [External =>] EXTERNAL_SYMBOL] 15433 -- [, [Size =>] EXTERNAL_SYMBOL]); 15434 15435 -- EXTERNAL_SYMBOL ::= 15436 -- IDENTIFIER 15437 -- | static_string_EXPRESSION 15438 15439 when Pragma_Import_Object => Import_Object : declare 15440 Args : Args_List (1 .. 3); 15441 Names : constant Name_List (1 .. 3) := ( 15442 Name_Internal, 15443 Name_External, 15444 Name_Size); 15445 15446 Internal : Node_Id renames Args (1); 15447 External : Node_Id renames Args (2); 15448 Size : Node_Id renames Args (3); 15449 15450 begin 15451 GNAT_Pragma; 15452 Gather_Associations (Names, Args); 15453 Process_Extended_Import_Export_Object_Pragma ( 15454 Arg_Internal => Internal, 15455 Arg_External => External, 15456 Arg_Size => Size); 15457 end Import_Object; 15458 15459 ---------------------- 15460 -- Import_Procedure -- 15461 ---------------------- 15462 15463 -- pragma Import_Procedure ( 15464 -- [Internal =>] LOCAL_NAME 15465 -- [, [External =>] EXTERNAL_SYMBOL] 15466 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 15467 -- [, [Mechanism =>] MECHANISM]); 15468 15469 -- EXTERNAL_SYMBOL ::= 15470 -- IDENTIFIER 15471 -- | static_string_EXPRESSION 15472 15473 -- PARAMETER_TYPES ::= 15474 -- null 15475 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 15476 15477 -- TYPE_DESIGNATOR ::= 15478 -- subtype_NAME 15479 -- | subtype_Name ' Access 15480 15481 -- MECHANISM ::= 15482 -- MECHANISM_NAME 15483 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 15484 15485 -- MECHANISM_ASSOCIATION ::= 15486 -- [formal_parameter_NAME =>] MECHANISM_NAME 15487 15488 -- MECHANISM_NAME ::= 15489 -- Value 15490 -- | Reference 15491 15492 when Pragma_Import_Procedure => Import_Procedure : declare 15493 Args : Args_List (1 .. 4); 15494 Names : constant Name_List (1 .. 4) := ( 15495 Name_Internal, 15496 Name_External, 15497 Name_Parameter_Types, 15498 Name_Mechanism); 15499 15500 Internal : Node_Id renames Args (1); 15501 External : Node_Id renames Args (2); 15502 Parameter_Types : Node_Id renames Args (3); 15503 Mechanism : Node_Id renames Args (4); 15504 15505 begin 15506 GNAT_Pragma; 15507 Gather_Associations (Names, Args); 15508 Process_Extended_Import_Export_Subprogram_Pragma ( 15509 Arg_Internal => Internal, 15510 Arg_External => External, 15511 Arg_Parameter_Types => Parameter_Types, 15512 Arg_Mechanism => Mechanism); 15513 end Import_Procedure; 15514 15515 ----------------------------- 15516 -- Import_Valued_Procedure -- 15517 ----------------------------- 15518 15519 -- pragma Import_Valued_Procedure ( 15520 -- [Internal =>] LOCAL_NAME 15521 -- [, [External =>] EXTERNAL_SYMBOL] 15522 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 15523 -- [, [Mechanism =>] MECHANISM]); 15524 15525 -- EXTERNAL_SYMBOL ::= 15526 -- IDENTIFIER 15527 -- | static_string_EXPRESSION 15528 15529 -- PARAMETER_TYPES ::= 15530 -- null 15531 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 15532 15533 -- TYPE_DESIGNATOR ::= 15534 -- subtype_NAME 15535 -- | subtype_Name ' Access 15536 15537 -- MECHANISM ::= 15538 -- MECHANISM_NAME 15539 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 15540 15541 -- MECHANISM_ASSOCIATION ::= 15542 -- [formal_parameter_NAME =>] MECHANISM_NAME 15543 15544 -- MECHANISM_NAME ::= 15545 -- Value 15546 -- | Reference 15547 15548 when Pragma_Import_Valued_Procedure => 15549 Import_Valued_Procedure : declare 15550 Args : Args_List (1 .. 4); 15551 Names : constant Name_List (1 .. 4) := ( 15552 Name_Internal, 15553 Name_External, 15554 Name_Parameter_Types, 15555 Name_Mechanism); 15556 15557 Internal : Node_Id renames Args (1); 15558 External : Node_Id renames Args (2); 15559 Parameter_Types : Node_Id renames Args (3); 15560 Mechanism : Node_Id renames Args (4); 15561 15562 begin 15563 GNAT_Pragma; 15564 Gather_Associations (Names, Args); 15565 Process_Extended_Import_Export_Subprogram_Pragma ( 15566 Arg_Internal => Internal, 15567 Arg_External => External, 15568 Arg_Parameter_Types => Parameter_Types, 15569 Arg_Mechanism => Mechanism); 15570 end Import_Valued_Procedure; 15571 15572 ----------------- 15573 -- Independent -- 15574 ----------------- 15575 15576 -- pragma Independent (LOCAL_NAME); 15577 15578 when Pragma_Independent => 15579 Process_Atomic_Independent_Shared_Volatile; 15580 15581 ---------------------------- 15582 -- Independent_Components -- 15583 ---------------------------- 15584 15585 -- pragma Independent_Components (array_or_record_LOCAL_NAME); 15586 15587 when Pragma_Independent_Components => Independent_Components : declare 15588 C : Node_Id; 15589 D : Node_Id; 15590 E_Id : Node_Id; 15591 E : Entity_Id; 15592 K : Node_Kind; 15593 15594 begin 15595 Check_Ada_83_Warning; 15596 Ada_2012_Pragma; 15597 Check_No_Identifiers; 15598 Check_Arg_Count (1); 15599 Check_Arg_Is_Local_Name (Arg1); 15600 E_Id := Get_Pragma_Arg (Arg1); 15601 15602 if Etype (E_Id) = Any_Type then 15603 return; 15604 end if; 15605 15606 E := Entity (E_Id); 15607 15608 -- A pragma that applies to a Ghost entity becomes Ghost for the 15609 -- purposes of legality checks and removal of ignored Ghost code. 15610 15611 Mark_Pragma_As_Ghost (N, E); 15612 15613 -- Check duplicate before we chain ourselves 15614 15615 Check_Duplicate_Pragma (E); 15616 15617 -- Check appropriate entity 15618 15619 if Rep_Item_Too_Early (E, N) 15620 or else 15621 Rep_Item_Too_Late (E, N) 15622 then 15623 return; 15624 end if; 15625 15626 D := Declaration_Node (E); 15627 K := Nkind (D); 15628 15629 -- The flag is set on the base type, or on the object 15630 15631 if K = N_Full_Type_Declaration 15632 and then (Is_Array_Type (E) or else Is_Record_Type (E)) 15633 then 15634 Set_Has_Independent_Components (Base_Type (E)); 15635 Record_Independence_Check (N, Base_Type (E)); 15636 15637 -- For record type, set all components independent 15638 15639 if Is_Record_Type (E) then 15640 C := First_Component (E); 15641 while Present (C) loop 15642 Set_Is_Independent (C); 15643 Next_Component (C); 15644 end loop; 15645 end if; 15646 15647 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 15648 and then Nkind (D) = N_Object_Declaration 15649 and then Nkind (Object_Definition (D)) = 15650 N_Constrained_Array_Definition 15651 then 15652 Set_Has_Independent_Components (E); 15653 Record_Independence_Check (N, E); 15654 15655 else 15656 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 15657 end if; 15658 end Independent_Components; 15659 15660 ----------------------- 15661 -- Initial_Condition -- 15662 ----------------------- 15663 15664 -- pragma Initial_Condition (boolean_EXPRESSION); 15665 15666 -- Characteristics: 15667 15668 -- * Analysis - The annotation undergoes initial checks to verify 15669 -- the legal placement and context. Secondary checks preanalyze the 15670 -- expression in: 15671 15672 -- Analyze_Initial_Condition_In_Decl_Part 15673 15674 -- * Expansion - The annotation is expanded during the expansion of 15675 -- the package body whose declaration is subject to the annotation 15676 -- as done in: 15677 15678 -- Expand_Pragma_Initial_Condition 15679 15680 -- * Template - The annotation utilizes the generic template of the 15681 -- related package declaration. 15682 15683 -- * Globals - Capture of global references must occur after full 15684 -- analysis. 15685 15686 -- * Instance - The annotation is instantiated automatically when 15687 -- the related generic package is instantiated. 15688 15689 when Pragma_Initial_Condition => Initial_Condition : declare 15690 Pack_Decl : Node_Id; 15691 Pack_Id : Entity_Id; 15692 15693 begin 15694 GNAT_Pragma; 15695 Check_No_Identifiers; 15696 Check_Arg_Count (1); 15697 15698 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 15699 15700 -- Ensure the proper placement of the pragma. Initial_Condition 15701 -- must be associated with a package declaration. 15702 15703 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 15704 N_Package_Declaration) 15705 then 15706 null; 15707 15708 -- Otherwise the pragma is associated with an illegal context 15709 15710 else 15711 Pragma_Misplaced; 15712 return; 15713 end if; 15714 15715 Pack_Id := Defining_Entity (Pack_Decl); 15716 15717 -- Chain the pragma on the contract for further processing by 15718 -- Analyze_Initial_Condition_In_Decl_Part. 15719 15720 Add_Contract_Item (N, Pack_Id); 15721 15722 -- The legality checks of pragmas Abstract_State, Initializes, and 15723 -- Initial_Condition are affected by the SPARK mode in effect. In 15724 -- addition, these three pragmas are subject to an inherent order: 15725 15726 -- 1) Abstract_State 15727 -- 2) Initializes 15728 -- 3) Initial_Condition 15729 15730 -- Analyze all these pragmas in the order outlined above 15731 15732 Analyze_If_Present (Pragma_SPARK_Mode); 15733 Analyze_If_Present (Pragma_Abstract_State); 15734 Analyze_If_Present (Pragma_Initializes); 15735 15736 -- A pragma that applies to a Ghost entity becomes Ghost for the 15737 -- purposes of legality checks and removal of ignored Ghost code. 15738 15739 Mark_Pragma_As_Ghost (N, Pack_Id); 15740 end Initial_Condition; 15741 15742 ------------------------ 15743 -- Initialize_Scalars -- 15744 ------------------------ 15745 15746 -- pragma Initialize_Scalars; 15747 15748 when Pragma_Initialize_Scalars => 15749 GNAT_Pragma; 15750 Check_Arg_Count (0); 15751 Check_Valid_Configuration_Pragma; 15752 Check_Restriction (No_Initialize_Scalars, N); 15753 15754 -- Initialize_Scalars creates false positives in CodePeer, and 15755 -- incorrect negative results in GNATprove mode, so ignore this 15756 -- pragma in these modes. 15757 15758 if not Restriction_Active (No_Initialize_Scalars) 15759 and then not (CodePeer_Mode or GNATprove_Mode) 15760 then 15761 Init_Or_Norm_Scalars := True; 15762 Initialize_Scalars := True; 15763 end if; 15764 15765 ----------------- 15766 -- Initializes -- 15767 ----------------- 15768 15769 -- pragma Initializes (INITIALIZATION_LIST); 15770 15771 -- INITIALIZATION_LIST ::= 15772 -- null 15773 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM}) 15774 15775 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST] 15776 15777 -- INPUT_LIST ::= 15778 -- null 15779 -- | INPUT 15780 -- | (INPUT {, INPUT}) 15781 15782 -- INPUT ::= name 15783 15784 -- Characteristics: 15785 15786 -- * Analysis - The annotation undergoes initial checks to verify 15787 -- the legal placement and context. Secondary checks preanalyze the 15788 -- expression in: 15789 15790 -- Analyze_Initializes_In_Decl_Part 15791 15792 -- * Expansion - None. 15793 15794 -- * Template - The annotation utilizes the generic template of the 15795 -- related package declaration. 15796 15797 -- * Globals - Capture of global references must occur after full 15798 -- analysis. 15799 15800 -- * Instance - The annotation is instantiated automatically when 15801 -- the related generic package is instantiated. 15802 15803 when Pragma_Initializes => Initializes : declare 15804 Pack_Decl : Node_Id; 15805 Pack_Id : Entity_Id; 15806 15807 begin 15808 GNAT_Pragma; 15809 Check_No_Identifiers; 15810 Check_Arg_Count (1); 15811 15812 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 15813 15814 -- Ensure the proper placement of the pragma. Initializes must be 15815 -- associated with a package declaration. 15816 15817 if Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 15818 N_Package_Declaration) 15819 then 15820 null; 15821 15822 -- Otherwise the pragma is associated with an illegal construc 15823 15824 else 15825 Pragma_Misplaced; 15826 return; 15827 end if; 15828 15829 Pack_Id := Defining_Entity (Pack_Decl); 15830 15831 -- Chain the pragma on the contract for further processing by 15832 -- Analyze_Initializes_In_Decl_Part. 15833 15834 Add_Contract_Item (N, Pack_Id); 15835 15836 -- The legality checks of pragmas Abstract_State, Initializes, and 15837 -- Initial_Condition are affected by the SPARK mode in effect. In 15838 -- addition, these three pragmas are subject to an inherent order: 15839 15840 -- 1) Abstract_State 15841 -- 2) Initializes 15842 -- 3) Initial_Condition 15843 15844 -- Analyze all these pragmas in the order outlined above 15845 15846 Analyze_If_Present (Pragma_SPARK_Mode); 15847 Analyze_If_Present (Pragma_Abstract_State); 15848 15849 -- A pragma that applies to a Ghost entity becomes Ghost for the 15850 -- purposes of legality checks and removal of ignored Ghost code. 15851 15852 Mark_Pragma_As_Ghost (N, Pack_Id); 15853 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id)); 15854 15855 Analyze_If_Present (Pragma_Initial_Condition); 15856 end Initializes; 15857 15858 ------------ 15859 -- Inline -- 15860 ------------ 15861 15862 -- pragma Inline ( NAME {, NAME} ); 15863 15864 when Pragma_Inline => 15865 15866 -- Pragma always active unless in GNATprove mode. It is disabled 15867 -- in GNATprove mode because frontend inlining is applied 15868 -- independently of pragmas Inline and Inline_Always for 15869 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode 15870 -- in inline.ads. 15871 15872 if not GNATprove_Mode then 15873 15874 -- Inline status is Enabled if inlining option is active 15875 15876 if Inline_Active then 15877 Process_Inline (Enabled); 15878 else 15879 Process_Inline (Disabled); 15880 end if; 15881 end if; 15882 15883 ------------------- 15884 -- Inline_Always -- 15885 ------------------- 15886 15887 -- pragma Inline_Always ( NAME {, NAME} ); 15888 15889 when Pragma_Inline_Always => 15890 GNAT_Pragma; 15891 15892 -- Pragma always active unless in CodePeer mode or GNATprove 15893 -- mode. It is disabled in CodePeer mode because inlining is 15894 -- not helpful, and enabling it caused walk order issues. It 15895 -- is disabled in GNATprove mode because frontend inlining is 15896 -- applied independently of pragmas Inline and Inline_Always for 15897 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in 15898 -- inline.ads. 15899 15900 if not CodePeer_Mode and not GNATprove_Mode then 15901 Process_Inline (Enabled); 15902 end if; 15903 15904 -------------------- 15905 -- Inline_Generic -- 15906 -------------------- 15907 15908 -- pragma Inline_Generic (NAME {, NAME}); 15909 15910 when Pragma_Inline_Generic => 15911 GNAT_Pragma; 15912 Process_Generic_List; 15913 15914 ---------------------- 15915 -- Inspection_Point -- 15916 ---------------------- 15917 15918 -- pragma Inspection_Point [(object_NAME {, object_NAME})]; 15919 15920 when Pragma_Inspection_Point => Inspection_Point : declare 15921 Arg : Node_Id; 15922 Exp : Node_Id; 15923 15924 begin 15925 ip; 15926 15927 if Arg_Count > 0 then 15928 Arg := Arg1; 15929 loop 15930 Exp := Get_Pragma_Arg (Arg); 15931 Analyze (Exp); 15932 15933 if not Is_Entity_Name (Exp) 15934 or else not Is_Object (Entity (Exp)) 15935 then 15936 Error_Pragma_Arg ("object name required", Arg); 15937 end if; 15938 15939 Next (Arg); 15940 exit when No (Arg); 15941 end loop; 15942 end if; 15943 end Inspection_Point; 15944 15945 --------------- 15946 -- Interface -- 15947 --------------- 15948 15949 -- pragma Interface ( 15950 -- [ Convention =>] convention_IDENTIFIER, 15951 -- [ Entity =>] LOCAL_NAME 15952 -- [, [External_Name =>] static_string_EXPRESSION ] 15953 -- [, [Link_Name =>] static_string_EXPRESSION ]); 15954 15955 when Pragma_Interface => 15956 GNAT_Pragma; 15957 Check_Arg_Order 15958 ((Name_Convention, 15959 Name_Entity, 15960 Name_External_Name, 15961 Name_Link_Name)); 15962 Check_At_Least_N_Arguments (2); 15963 Check_At_Most_N_Arguments (4); 15964 Process_Import_Or_Interface; 15965 15966 -- In Ada 2005, the permission to use Interface (a reserved word) 15967 -- as a pragma name is considered an obsolescent feature, and this 15968 -- pragma was already obsolescent in Ada 95. 15969 15970 if Ada_Version >= Ada_95 then 15971 Check_Restriction 15972 (No_Obsolescent_Features, Pragma_Identifier (N)); 15973 15974 if Warn_On_Obsolescent_Feature then 15975 Error_Msg_N 15976 ("pragma Interface is an obsolescent feature?j?", N); 15977 Error_Msg_N 15978 ("|use pragma Import instead?j?", N); 15979 end if; 15980 end if; 15981 15982 -------------------- 15983 -- Interface_Name -- 15984 -------------------- 15985 15986 -- pragma Interface_Name ( 15987 -- [ Entity =>] LOCAL_NAME 15988 -- [,[External_Name =>] static_string_EXPRESSION ] 15989 -- [,[Link_Name =>] static_string_EXPRESSION ]); 15990 15991 when Pragma_Interface_Name => Interface_Name : declare 15992 Id : Node_Id; 15993 Def_Id : Entity_Id; 15994 Hom_Id : Entity_Id; 15995 Found : Boolean; 15996 15997 begin 15998 GNAT_Pragma; 15999 Check_Arg_Order 16000 ((Name_Entity, Name_External_Name, Name_Link_Name)); 16001 Check_At_Least_N_Arguments (2); 16002 Check_At_Most_N_Arguments (3); 16003 Id := Get_Pragma_Arg (Arg1); 16004 Analyze (Id); 16005 16006 -- This is obsolete from Ada 95 on, but it is an implementation 16007 -- defined pragma, so we do not consider that it violates the 16008 -- restriction (No_Obsolescent_Features). 16009 16010 if Ada_Version >= Ada_95 then 16011 if Warn_On_Obsolescent_Feature then 16012 Error_Msg_N 16013 ("pragma Interface_Name is an obsolescent feature?j?", N); 16014 Error_Msg_N 16015 ("|use pragma Import instead?j?", N); 16016 end if; 16017 end if; 16018 16019 if not Is_Entity_Name (Id) then 16020 Error_Pragma_Arg 16021 ("first argument for pragma% must be entity name", Arg1); 16022 elsif Etype (Id) = Any_Type then 16023 return; 16024 else 16025 Def_Id := Entity (Id); 16026 end if; 16027 16028 -- Special DEC-compatible processing for the object case, forces 16029 -- object to be imported. 16030 16031 if Ekind (Def_Id) = E_Variable then 16032 Kill_Size_Check_Code (Def_Id); 16033 Note_Possible_Modification (Id, Sure => False); 16034 16035 -- Initialization is not allowed for imported variable 16036 16037 if Present (Expression (Parent (Def_Id))) 16038 and then Comes_From_Source (Expression (Parent (Def_Id))) 16039 then 16040 Error_Msg_Sloc := Sloc (Def_Id); 16041 Error_Pragma_Arg 16042 ("no initialization allowed for declaration of& #", 16043 Arg2); 16044 16045 else 16046 -- For compatibility, support VADS usage of providing both 16047 -- pragmas Interface and Interface_Name to obtain the effect 16048 -- of a single Import pragma. 16049 16050 if Is_Imported (Def_Id) 16051 and then Present (First_Rep_Item (Def_Id)) 16052 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma 16053 and then 16054 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface 16055 then 16056 null; 16057 else 16058 Set_Imported (Def_Id); 16059 end if; 16060 16061 Set_Is_Public (Def_Id); 16062 Process_Interface_Name (Def_Id, Arg2, Arg3); 16063 end if; 16064 16065 -- Otherwise must be subprogram 16066 16067 elsif not Is_Subprogram (Def_Id) then 16068 Error_Pragma_Arg 16069 ("argument of pragma% is not subprogram", Arg1); 16070 16071 else 16072 Check_At_Most_N_Arguments (3); 16073 Hom_Id := Def_Id; 16074 Found := False; 16075 16076 -- Loop through homonyms 16077 16078 loop 16079 Def_Id := Get_Base_Subprogram (Hom_Id); 16080 16081 if Is_Imported (Def_Id) then 16082 Process_Interface_Name (Def_Id, Arg2, Arg3); 16083 Found := True; 16084 end if; 16085 16086 exit when From_Aspect_Specification (N); 16087 Hom_Id := Homonym (Hom_Id); 16088 16089 exit when No (Hom_Id) 16090 or else Scope (Hom_Id) /= Current_Scope; 16091 end loop; 16092 16093 if not Found then 16094 Error_Pragma_Arg 16095 ("argument of pragma% is not imported subprogram", 16096 Arg1); 16097 end if; 16098 end if; 16099 end Interface_Name; 16100 16101 ----------------------- 16102 -- Interrupt_Handler -- 16103 ----------------------- 16104 16105 -- pragma Interrupt_Handler (handler_NAME); 16106 16107 when Pragma_Interrupt_Handler => 16108 Check_Ada_83_Warning; 16109 Check_Arg_Count (1); 16110 Check_No_Identifiers; 16111 16112 if No_Run_Time_Mode then 16113 Error_Msg_CRT ("Interrupt_Handler pragma", N); 16114 else 16115 Check_Interrupt_Or_Attach_Handler; 16116 Process_Interrupt_Or_Attach_Handler; 16117 end if; 16118 16119 ------------------------ 16120 -- Interrupt_Priority -- 16121 ------------------------ 16122 16123 -- pragma Interrupt_Priority [(EXPRESSION)]; 16124 16125 when Pragma_Interrupt_Priority => Interrupt_Priority : declare 16126 P : constant Node_Id := Parent (N); 16127 Arg : Node_Id; 16128 Ent : Entity_Id; 16129 16130 begin 16131 Check_Ada_83_Warning; 16132 16133 if Arg_Count /= 0 then 16134 Arg := Get_Pragma_Arg (Arg1); 16135 Check_Arg_Count (1); 16136 Check_No_Identifiers; 16137 16138 -- The expression must be analyzed in the special manner 16139 -- described in "Handling of Default and Per-Object 16140 -- Expressions" in sem.ads. 16141 16142 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); 16143 end if; 16144 16145 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then 16146 Pragma_Misplaced; 16147 return; 16148 16149 else 16150 Ent := Defining_Identifier (Parent (P)); 16151 16152 -- Check duplicate pragma before we chain the pragma in the Rep 16153 -- Item chain of Ent. 16154 16155 Check_Duplicate_Pragma (Ent); 16156 Record_Rep_Item (Ent, N); 16157 16158 -- Check the No_Task_At_Interrupt_Priority restriction 16159 16160 if Nkind (P) = N_Task_Definition then 16161 Check_Restriction (No_Task_At_Interrupt_Priority, N); 16162 end if; 16163 end if; 16164 end Interrupt_Priority; 16165 16166 --------------------- 16167 -- Interrupt_State -- 16168 --------------------- 16169 16170 -- pragma Interrupt_State ( 16171 -- [Name =>] INTERRUPT_ID, 16172 -- [State =>] INTERRUPT_STATE); 16173 16174 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION 16175 -- INTERRUPT_STATE => System | Runtime | User 16176 16177 -- Note: if the interrupt id is given as an identifier, then it must 16178 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is 16179 -- given as a static integer expression which must be in the range of 16180 -- Ada.Interrupts.Interrupt_ID. 16181 16182 when Pragma_Interrupt_State => Interrupt_State : declare 16183 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); 16184 -- This is the entity Ada.Interrupts.Interrupt_ID; 16185 16186 State_Type : Character; 16187 -- Set to 's'/'r'/'u' for System/Runtime/User 16188 16189 IST_Num : Pos; 16190 -- Index to entry in Interrupt_States table 16191 16192 Int_Val : Uint; 16193 -- Value of interrupt 16194 16195 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); 16196 -- The first argument to the pragma 16197 16198 Int_Ent : Entity_Id; 16199 -- Interrupt entity in Ada.Interrupts.Names 16200 16201 begin 16202 GNAT_Pragma; 16203 Check_Arg_Order ((Name_Name, Name_State)); 16204 Check_Arg_Count (2); 16205 16206 Check_Optional_Identifier (Arg1, Name_Name); 16207 Check_Optional_Identifier (Arg2, Name_State); 16208 Check_Arg_Is_Identifier (Arg2); 16209 16210 -- First argument is identifier 16211 16212 if Nkind (Arg1X) = N_Identifier then 16213 16214 -- Search list of names in Ada.Interrupts.Names 16215 16216 Int_Ent := First_Entity (RTE (RE_Names)); 16217 loop 16218 if No (Int_Ent) then 16219 Error_Pragma_Arg ("invalid interrupt name", Arg1); 16220 16221 elsif Chars (Int_Ent) = Chars (Arg1X) then 16222 Int_Val := Expr_Value (Constant_Value (Int_Ent)); 16223 exit; 16224 end if; 16225 16226 Next_Entity (Int_Ent); 16227 end loop; 16228 16229 -- First argument is not an identifier, so it must be a static 16230 -- expression of type Ada.Interrupts.Interrupt_ID. 16231 16232 else 16233 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); 16234 Int_Val := Expr_Value (Arg1X); 16235 16236 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) 16237 or else 16238 Int_Val > Expr_Value (Type_High_Bound (Int_Id)) 16239 then 16240 Error_Pragma_Arg 16241 ("value not in range of type " 16242 & """Ada.Interrupts.Interrupt_'I'D""", Arg1); 16243 end if; 16244 end if; 16245 16246 -- Check OK state 16247 16248 case Chars (Get_Pragma_Arg (Arg2)) is 16249 when Name_Runtime => State_Type := 'r'; 16250 when Name_System => State_Type := 's'; 16251 when Name_User => State_Type := 'u'; 16252 16253 when others => 16254 Error_Pragma_Arg ("invalid interrupt state", Arg2); 16255 end case; 16256 16257 -- Check if entry is already stored 16258 16259 IST_Num := Interrupt_States.First; 16260 loop 16261 -- If entry not found, add it 16262 16263 if IST_Num > Interrupt_States.Last then 16264 Interrupt_States.Append 16265 ((Interrupt_Number => UI_To_Int (Int_Val), 16266 Interrupt_State => State_Type, 16267 Pragma_Loc => Loc)); 16268 exit; 16269 16270 -- Case of entry for the same entry 16271 16272 elsif Int_Val = Interrupt_States.Table (IST_Num). 16273 Interrupt_Number 16274 then 16275 -- If state matches, done, no need to make redundant entry 16276 16277 exit when 16278 State_Type = Interrupt_States.Table (IST_Num). 16279 Interrupt_State; 16280 16281 -- Otherwise if state does not match, error 16282 16283 Error_Msg_Sloc := 16284 Interrupt_States.Table (IST_Num).Pragma_Loc; 16285 Error_Pragma_Arg 16286 ("state conflicts with that given #", Arg2); 16287 exit; 16288 end if; 16289 16290 IST_Num := IST_Num + 1; 16291 end loop; 16292 end Interrupt_State; 16293 16294 --------------- 16295 -- Invariant -- 16296 --------------- 16297 16298 -- pragma Invariant 16299 -- ([Entity =>] type_LOCAL_NAME, 16300 -- [Check =>] EXPRESSION 16301 -- [,[Message =>] String_Expression]); 16302 16303 when Pragma_Invariant => Invariant : declare 16304 Discard : Boolean; 16305 Typ : Entity_Id; 16306 Type_Id : Node_Id; 16307 16308 begin 16309 GNAT_Pragma; 16310 Check_At_Least_N_Arguments (2); 16311 Check_At_Most_N_Arguments (3); 16312 Check_Optional_Identifier (Arg1, Name_Entity); 16313 Check_Optional_Identifier (Arg2, Name_Check); 16314 16315 if Arg_Count = 3 then 16316 Check_Optional_Identifier (Arg3, Name_Message); 16317 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 16318 end if; 16319 16320 Check_Arg_Is_Local_Name (Arg1); 16321 16322 Type_Id := Get_Pragma_Arg (Arg1); 16323 Find_Type (Type_Id); 16324 Typ := Entity (Type_Id); 16325 16326 if Typ = Any_Type then 16327 return; 16328 16329 -- Invariants allowed in interface types (RM 7.3.2(3/3)) 16330 16331 elsif Is_Interface (Typ) then 16332 null; 16333 16334 -- An invariant must apply to a private type, or appear in the 16335 -- private part of a package spec and apply to a completion. 16336 -- a class-wide invariant can only appear on a private declaration 16337 -- or private extension, not a completion. 16338 16339 elsif Ekind_In (Typ, E_Private_Type, 16340 E_Record_Type_With_Private, 16341 E_Limited_Private_Type) 16342 then 16343 null; 16344 16345 elsif In_Private_Part (Current_Scope) 16346 and then Has_Private_Declaration (Typ) 16347 and then not Class_Present (N) 16348 then 16349 null; 16350 16351 elsif In_Private_Part (Current_Scope) then 16352 Error_Pragma_Arg 16353 ("pragma% only allowed for private type declared in " 16354 & "visible part", Arg1); 16355 16356 else 16357 Error_Pragma_Arg 16358 ("pragma% only allowed for private type", Arg1); 16359 end if; 16360 16361 -- A pragma that applies to a Ghost entity becomes Ghost for the 16362 -- purposes of legality checks and removal of ignored Ghost code. 16363 16364 Mark_Pragma_As_Ghost (N, Typ); 16365 16366 -- Not allowed for abstract type in the non-class case (it is 16367 -- allowed to use Invariant'Class for abstract types). 16368 16369 if Is_Abstract_Type (Typ) and then not Class_Present (N) then 16370 Error_Pragma_Arg 16371 ("pragma% not allowed for abstract type", Arg1); 16372 end if; 16373 16374 -- Link the pragma on to the rep item chain, for processing when 16375 -- the type is frozen. 16376 16377 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 16378 16379 -- Note that the type has at least one invariant, and also that 16380 -- it has inheritable invariants if we have Invariant'Class 16381 -- or Type_Invariant'Class. Build the corresponding invariant 16382 -- procedure declaration, so that calls to it can be generated 16383 -- before the body is built (e.g. within an expression function). 16384 16385 -- Interface types have no invariant procedure; their invariants 16386 -- are propagated to the build invariant procedure of all the 16387 -- types covering the interface type. 16388 16389 if not Is_Interface (Typ) then 16390 Insert_After_And_Analyze 16391 (N, Build_Invariant_Procedure_Declaration (Typ)); 16392 end if; 16393 16394 if Class_Present (N) then 16395 Set_Has_Inheritable_Invariants (Typ); 16396 end if; 16397 end Invariant; 16398 16399 ---------------- 16400 -- Keep_Names -- 16401 ---------------- 16402 16403 -- pragma Keep_Names ([On => ] LOCAL_NAME); 16404 16405 when Pragma_Keep_Names => Keep_Names : declare 16406 Arg : Node_Id; 16407 16408 begin 16409 GNAT_Pragma; 16410 Check_Arg_Count (1); 16411 Check_Optional_Identifier (Arg1, Name_On); 16412 Check_Arg_Is_Local_Name (Arg1); 16413 16414 Arg := Get_Pragma_Arg (Arg1); 16415 Analyze (Arg); 16416 16417 if Etype (Arg) = Any_Type then 16418 return; 16419 end if; 16420 16421 if not Is_Entity_Name (Arg) 16422 or else Ekind (Entity (Arg)) /= E_Enumeration_Type 16423 then 16424 Error_Pragma_Arg 16425 ("pragma% requires a local enumeration type", Arg1); 16426 end if; 16427 16428 Set_Discard_Names (Entity (Arg), False); 16429 end Keep_Names; 16430 16431 ------------- 16432 -- License -- 16433 ------------- 16434 16435 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL); 16436 16437 when Pragma_License => 16438 GNAT_Pragma; 16439 16440 -- Do not analyze pragma any further in CodePeer mode, to avoid 16441 -- extraneous errors in this implementation-dependent pragma, 16442 -- which has a different profile on other compilers. 16443 16444 if CodePeer_Mode then 16445 return; 16446 end if; 16447 16448 Check_Arg_Count (1); 16449 Check_No_Identifiers; 16450 Check_Valid_Configuration_Pragma; 16451 Check_Arg_Is_Identifier (Arg1); 16452 16453 declare 16454 Sind : constant Source_File_Index := 16455 Source_Index (Current_Sem_Unit); 16456 16457 begin 16458 case Chars (Get_Pragma_Arg (Arg1)) is 16459 when Name_GPL => 16460 Set_License (Sind, GPL); 16461 16462 when Name_Modified_GPL => 16463 Set_License (Sind, Modified_GPL); 16464 16465 when Name_Restricted => 16466 Set_License (Sind, Restricted); 16467 16468 when Name_Unrestricted => 16469 Set_License (Sind, Unrestricted); 16470 16471 when others => 16472 Error_Pragma_Arg ("invalid license name", Arg1); 16473 end case; 16474 end; 16475 16476 --------------- 16477 -- Link_With -- 16478 --------------- 16479 16480 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION}); 16481 16482 when Pragma_Link_With => Link_With : declare 16483 Arg : Node_Id; 16484 16485 begin 16486 GNAT_Pragma; 16487 16488 if Operating_Mode = Generate_Code 16489 and then In_Extended_Main_Source_Unit (N) 16490 then 16491 Check_At_Least_N_Arguments (1); 16492 Check_No_Identifiers; 16493 Check_Is_In_Decl_Part_Or_Package_Spec; 16494 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 16495 Start_String; 16496 16497 Arg := Arg1; 16498 while Present (Arg) loop 16499 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); 16500 16501 -- Store argument, converting sequences of spaces to a 16502 -- single null character (this is one of the differences 16503 -- in processing between Link_With and Linker_Options). 16504 16505 Arg_Store : declare 16506 C : constant Char_Code := Get_Char_Code (' '); 16507 S : constant String_Id := 16508 Strval (Expr_Value_S (Get_Pragma_Arg (Arg))); 16509 L : constant Nat := String_Length (S); 16510 F : Nat := 1; 16511 16512 procedure Skip_Spaces; 16513 -- Advance F past any spaces 16514 16515 ----------------- 16516 -- Skip_Spaces -- 16517 ----------------- 16518 16519 procedure Skip_Spaces is 16520 begin 16521 while F <= L and then Get_String_Char (S, F) = C loop 16522 F := F + 1; 16523 end loop; 16524 end Skip_Spaces; 16525 16526 -- Start of processing for Arg_Store 16527 16528 begin 16529 Skip_Spaces; -- skip leading spaces 16530 16531 -- Loop through characters, changing any embedded 16532 -- sequence of spaces to a single null character (this 16533 -- is how Link_With/Linker_Options differ) 16534 16535 while F <= L loop 16536 if Get_String_Char (S, F) = C then 16537 Skip_Spaces; 16538 exit when F > L; 16539 Store_String_Char (ASCII.NUL); 16540 16541 else 16542 Store_String_Char (Get_String_Char (S, F)); 16543 F := F + 1; 16544 end if; 16545 end loop; 16546 end Arg_Store; 16547 16548 Arg := Next (Arg); 16549 16550 if Present (Arg) then 16551 Store_String_Char (ASCII.NUL); 16552 end if; 16553 end loop; 16554 16555 Store_Linker_Option_String (End_String); 16556 end if; 16557 end Link_With; 16558 16559 ------------------ 16560 -- Linker_Alias -- 16561 ------------------ 16562 16563 -- pragma Linker_Alias ( 16564 -- [Entity =>] LOCAL_NAME 16565 -- [Target =>] static_string_EXPRESSION); 16566 16567 when Pragma_Linker_Alias => 16568 GNAT_Pragma; 16569 Check_Arg_Order ((Name_Entity, Name_Target)); 16570 Check_Arg_Count (2); 16571 Check_Optional_Identifier (Arg1, Name_Entity); 16572 Check_Optional_Identifier (Arg2, Name_Target); 16573 Check_Arg_Is_Library_Level_Local_Name (Arg1); 16574 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 16575 16576 -- The only processing required is to link this item on to the 16577 -- list of rep items for the given entity. This is accomplished 16578 -- by the call to Rep_Item_Too_Late (when no error is detected 16579 -- and False is returned). 16580 16581 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then 16582 return; 16583 else 16584 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 16585 end if; 16586 16587 ------------------------ 16588 -- Linker_Constructor -- 16589 ------------------------ 16590 16591 -- pragma Linker_Constructor (procedure_LOCAL_NAME); 16592 16593 -- Code is shared with Linker_Destructor 16594 16595 ----------------------- 16596 -- Linker_Destructor -- 16597 ----------------------- 16598 16599 -- pragma Linker_Destructor (procedure_LOCAL_NAME); 16600 16601 when Pragma_Linker_Constructor | 16602 Pragma_Linker_Destructor => 16603 Linker_Constructor : declare 16604 Arg1_X : Node_Id; 16605 Proc : Entity_Id; 16606 16607 begin 16608 GNAT_Pragma; 16609 Check_Arg_Count (1); 16610 Check_No_Identifiers; 16611 Check_Arg_Is_Local_Name (Arg1); 16612 Arg1_X := Get_Pragma_Arg (Arg1); 16613 Analyze (Arg1_X); 16614 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 16615 16616 if not Is_Library_Level_Entity (Proc) then 16617 Error_Pragma_Arg 16618 ("argument for pragma% must be library level entity", Arg1); 16619 end if; 16620 16621 -- The only processing required is to link this item on to the 16622 -- list of rep items for the given entity. This is accomplished 16623 -- by the call to Rep_Item_Too_Late (when no error is detected 16624 -- and False is returned). 16625 16626 if Rep_Item_Too_Late (Proc, N) then 16627 return; 16628 else 16629 Set_Has_Gigi_Rep_Item (Proc); 16630 end if; 16631 end Linker_Constructor; 16632 16633 -------------------- 16634 -- Linker_Options -- 16635 -------------------- 16636 16637 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); 16638 16639 when Pragma_Linker_Options => Linker_Options : declare 16640 Arg : Node_Id; 16641 16642 begin 16643 Check_Ada_83_Warning; 16644 Check_No_Identifiers; 16645 Check_Arg_Count (1); 16646 Check_Is_In_Decl_Part_Or_Package_Spec; 16647 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 16648 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); 16649 16650 Arg := Arg2; 16651 while Present (Arg) loop 16652 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); 16653 Store_String_Char (ASCII.NUL); 16654 Store_String_Chars 16655 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); 16656 Arg := Next (Arg); 16657 end loop; 16658 16659 if Operating_Mode = Generate_Code 16660 and then In_Extended_Main_Source_Unit (N) 16661 then 16662 Store_Linker_Option_String (End_String); 16663 end if; 16664 end Linker_Options; 16665 16666 -------------------- 16667 -- Linker_Section -- 16668 -------------------- 16669 16670 -- pragma Linker_Section ( 16671 -- [Entity =>] LOCAL_NAME 16672 -- [Section =>] static_string_EXPRESSION); 16673 16674 when Pragma_Linker_Section => Linker_Section : declare 16675 Arg : Node_Id; 16676 Ent : Entity_Id; 16677 LPE : Node_Id; 16678 16679 Ghost_Error_Posted : Boolean := False; 16680 -- Flag set when an error concerning the illegal mix of Ghost and 16681 -- non-Ghost subprograms is emitted. 16682 16683 Ghost_Id : Entity_Id := Empty; 16684 -- The entity of the first Ghost subprogram encountered while 16685 -- processing the arguments of the pragma. 16686 16687 begin 16688 GNAT_Pragma; 16689 Check_Arg_Order ((Name_Entity, Name_Section)); 16690 Check_Arg_Count (2); 16691 Check_Optional_Identifier (Arg1, Name_Entity); 16692 Check_Optional_Identifier (Arg2, Name_Section); 16693 Check_Arg_Is_Library_Level_Local_Name (Arg1); 16694 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 16695 16696 -- Check kind of entity 16697 16698 Arg := Get_Pragma_Arg (Arg1); 16699 Ent := Entity (Arg); 16700 16701 case Ekind (Ent) is 16702 16703 -- Objects (constants and variables) and types. For these cases 16704 -- all we need to do is to set the Linker_Section_pragma field, 16705 -- checking that we do not have a duplicate. 16706 16707 when E_Constant | E_Variable | Type_Kind => 16708 LPE := Linker_Section_Pragma (Ent); 16709 16710 if Present (LPE) then 16711 Error_Msg_Sloc := Sloc (LPE); 16712 Error_Msg_NE 16713 ("Linker_Section already specified for &#", Arg1, Ent); 16714 end if; 16715 16716 Set_Linker_Section_Pragma (Ent, N); 16717 16718 -- A pragma that applies to a Ghost entity becomes Ghost for 16719 -- the purposes of legality checks and removal of ignored 16720 -- Ghost code. 16721 16722 Mark_Pragma_As_Ghost (N, Ent); 16723 16724 -- Subprograms 16725 16726 when Subprogram_Kind => 16727 16728 -- Aspect case, entity already set 16729 16730 if From_Aspect_Specification (N) then 16731 Set_Linker_Section_Pragma 16732 (Entity (Corresponding_Aspect (N)), N); 16733 16734 -- Pragma case, we must climb the homonym chain, but skip 16735 -- any for which the linker section is already set. 16736 16737 else 16738 loop 16739 if No (Linker_Section_Pragma (Ent)) then 16740 Set_Linker_Section_Pragma (Ent, N); 16741 16742 -- A pragma that applies to a Ghost entity becomes 16743 -- Ghost for the purposes of legality checks and 16744 -- removal of ignored Ghost code. 16745 16746 Mark_Pragma_As_Ghost (N, Ent); 16747 16748 -- Capture the entity of the first Ghost subprogram 16749 -- being processed for error detection purposes. 16750 16751 if Is_Ghost_Entity (Ent) then 16752 if No (Ghost_Id) then 16753 Ghost_Id := Ent; 16754 end if; 16755 16756 -- Otherwise the subprogram is non-Ghost. It is 16757 -- illegal to mix references to Ghost and non-Ghost 16758 -- entities (SPARK RM 6.9). 16759 16760 elsif Present (Ghost_Id) 16761 and then not Ghost_Error_Posted 16762 then 16763 Ghost_Error_Posted := True; 16764 16765 Error_Msg_Name_1 := Pname; 16766 Error_Msg_N 16767 ("pragma % cannot mention ghost and " 16768 & "non-ghost subprograms", N); 16769 16770 Error_Msg_Sloc := Sloc (Ghost_Id); 16771 Error_Msg_NE 16772 ("\& # declared as ghost", N, Ghost_Id); 16773 16774 Error_Msg_Sloc := Sloc (Ent); 16775 Error_Msg_NE 16776 ("\& # declared as non-ghost", N, Ent); 16777 end if; 16778 end if; 16779 16780 Ent := Homonym (Ent); 16781 exit when No (Ent) 16782 or else Scope (Ent) /= Current_Scope; 16783 end loop; 16784 end if; 16785 16786 -- All other cases are illegal 16787 16788 when others => 16789 Error_Pragma_Arg 16790 ("pragma% applies only to objects, subprograms, and types", 16791 Arg1); 16792 end case; 16793 end Linker_Section; 16794 16795 ---------- 16796 -- List -- 16797 ---------- 16798 16799 -- pragma List (On | Off) 16800 16801 -- There is nothing to do here, since we did all the processing for 16802 -- this pragma in Par.Prag (so that it works properly even in syntax 16803 -- only mode). 16804 16805 when Pragma_List => 16806 null; 16807 16808 --------------- 16809 -- Lock_Free -- 16810 --------------- 16811 16812 -- pragma Lock_Free [(Boolean_EXPRESSION)]; 16813 16814 when Pragma_Lock_Free => Lock_Free : declare 16815 P : constant Node_Id := Parent (N); 16816 Arg : Node_Id; 16817 Ent : Entity_Id; 16818 Val : Boolean; 16819 16820 begin 16821 Check_No_Identifiers; 16822 Check_At_Most_N_Arguments (1); 16823 16824 -- Protected definition case 16825 16826 if Nkind (P) = N_Protected_Definition then 16827 Ent := Defining_Identifier (Parent (P)); 16828 16829 -- One argument 16830 16831 if Arg_Count = 1 then 16832 Arg := Get_Pragma_Arg (Arg1); 16833 Val := Is_True (Static_Boolean (Arg)); 16834 16835 -- No arguments (expression is considered to be True) 16836 16837 else 16838 Val := True; 16839 end if; 16840 16841 -- Check duplicate pragma before we chain the pragma in the Rep 16842 -- Item chain of Ent. 16843 16844 Check_Duplicate_Pragma (Ent); 16845 Record_Rep_Item (Ent, N); 16846 Set_Uses_Lock_Free (Ent, Val); 16847 16848 -- Anything else is incorrect placement 16849 16850 else 16851 Pragma_Misplaced; 16852 end if; 16853 end Lock_Free; 16854 16855 -------------------- 16856 -- Locking_Policy -- 16857 -------------------- 16858 16859 -- pragma Locking_Policy (policy_IDENTIFIER); 16860 16861 when Pragma_Locking_Policy => declare 16862 subtype LP_Range is Name_Id 16863 range First_Locking_Policy_Name .. Last_Locking_Policy_Name; 16864 LP_Val : LP_Range; 16865 LP : Character; 16866 16867 begin 16868 Check_Ada_83_Warning; 16869 Check_Arg_Count (1); 16870 Check_No_Identifiers; 16871 Check_Arg_Is_Locking_Policy (Arg1); 16872 Check_Valid_Configuration_Pragma; 16873 LP_Val := Chars (Get_Pragma_Arg (Arg1)); 16874 16875 case LP_Val is 16876 when Name_Ceiling_Locking => 16877 LP := 'C'; 16878 when Name_Inheritance_Locking => 16879 LP := 'I'; 16880 when Name_Concurrent_Readers_Locking => 16881 LP := 'R'; 16882 end case; 16883 16884 if Locking_Policy /= ' ' 16885 and then Locking_Policy /= LP 16886 then 16887 Error_Msg_Sloc := Locking_Policy_Sloc; 16888 Error_Pragma ("locking policy incompatible with policy#"); 16889 16890 -- Set new policy, but always preserve System_Location since we 16891 -- like the error message with the run time name. 16892 16893 else 16894 Locking_Policy := LP; 16895 16896 if Locking_Policy_Sloc /= System_Location then 16897 Locking_Policy_Sloc := Loc; 16898 end if; 16899 end if; 16900 end; 16901 16902 ------------------- 16903 -- Loop_Optimize -- 16904 ------------------- 16905 16906 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } ); 16907 16908 -- OPTIMIZATION_HINT ::= 16909 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector 16910 16911 when Pragma_Loop_Optimize => Loop_Optimize : declare 16912 Hint : Node_Id; 16913 16914 begin 16915 GNAT_Pragma; 16916 Check_At_Least_N_Arguments (1); 16917 Check_No_Identifiers; 16918 16919 Hint := First (Pragma_Argument_Associations (N)); 16920 while Present (Hint) loop 16921 Check_Arg_Is_One_Of (Hint, Name_Ivdep, 16922 Name_No_Unroll, 16923 Name_Unroll, 16924 Name_No_Vector, 16925 Name_Vector); 16926 Next (Hint); 16927 end loop; 16928 16929 Check_Loop_Pragma_Placement; 16930 end Loop_Optimize; 16931 16932 ------------------ 16933 -- Loop_Variant -- 16934 ------------------ 16935 16936 -- pragma Loop_Variant 16937 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } ); 16938 16939 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION 16940 16941 -- CHANGE_DIRECTION ::= Increases | Decreases 16942 16943 when Pragma_Loop_Variant => Loop_Variant : declare 16944 Variant : Node_Id; 16945 16946 begin 16947 GNAT_Pragma; 16948 Check_At_Least_N_Arguments (1); 16949 Check_Loop_Pragma_Placement; 16950 16951 -- Process all increasing / decreasing expressions 16952 16953 Variant := First (Pragma_Argument_Associations (N)); 16954 while Present (Variant) loop 16955 if not Nam_In (Chars (Variant), Name_Decreases, 16956 Name_Increases) 16957 then 16958 Error_Pragma_Arg ("wrong change modifier", Variant); 16959 end if; 16960 16961 Preanalyze_Assert_Expression 16962 (Expression (Variant), Any_Discrete); 16963 16964 Next (Variant); 16965 end loop; 16966 end Loop_Variant; 16967 16968 ----------------------- 16969 -- Machine_Attribute -- 16970 ----------------------- 16971 16972 -- pragma Machine_Attribute ( 16973 -- [Entity =>] LOCAL_NAME, 16974 -- [Attribute_Name =>] static_string_EXPRESSION 16975 -- [, [Info =>] static_EXPRESSION] ); 16976 16977 when Pragma_Machine_Attribute => Machine_Attribute : declare 16978 Def_Id : Entity_Id; 16979 16980 begin 16981 GNAT_Pragma; 16982 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info)); 16983 16984 if Arg_Count = 3 then 16985 Check_Optional_Identifier (Arg3, Name_Info); 16986 Check_Arg_Is_OK_Static_Expression (Arg3); 16987 else 16988 Check_Arg_Count (2); 16989 end if; 16990 16991 Check_Optional_Identifier (Arg1, Name_Entity); 16992 Check_Optional_Identifier (Arg2, Name_Attribute_Name); 16993 Check_Arg_Is_Local_Name (Arg1); 16994 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 16995 Def_Id := Entity (Get_Pragma_Arg (Arg1)); 16996 16997 if Is_Access_Type (Def_Id) then 16998 Def_Id := Designated_Type (Def_Id); 16999 end if; 17000 17001 if Rep_Item_Too_Early (Def_Id, N) then 17002 return; 17003 end if; 17004 17005 Def_Id := Underlying_Type (Def_Id); 17006 17007 -- The only processing required is to link this item on to the 17008 -- list of rep items for the given entity. This is accomplished 17009 -- by the call to Rep_Item_Too_Late (when no error is detected 17010 -- and False is returned). 17011 17012 if Rep_Item_Too_Late (Def_Id, N) then 17013 return; 17014 else 17015 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 17016 end if; 17017 end Machine_Attribute; 17018 17019 ---------- 17020 -- Main -- 17021 ---------- 17022 17023 -- pragma Main 17024 -- (MAIN_OPTION [, MAIN_OPTION]); 17025 17026 -- MAIN_OPTION ::= 17027 -- [STACK_SIZE =>] static_integer_EXPRESSION 17028 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION 17029 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION 17030 17031 when Pragma_Main => Main : declare 17032 Args : Args_List (1 .. 3); 17033 Names : constant Name_List (1 .. 3) := ( 17034 Name_Stack_Size, 17035 Name_Task_Stack_Size_Default, 17036 Name_Time_Slicing_Enabled); 17037 17038 Nod : Node_Id; 17039 17040 begin 17041 GNAT_Pragma; 17042 Gather_Associations (Names, Args); 17043 17044 for J in 1 .. 2 loop 17045 if Present (Args (J)) then 17046 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); 17047 end if; 17048 end loop; 17049 17050 if Present (Args (3)) then 17051 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean); 17052 end if; 17053 17054 Nod := Next (N); 17055 while Present (Nod) loop 17056 if Nkind (Nod) = N_Pragma 17057 and then Pragma_Name (Nod) = Name_Main 17058 then 17059 Error_Msg_Name_1 := Pname; 17060 Error_Msg_N ("duplicate pragma% not permitted", Nod); 17061 end if; 17062 17063 Next (Nod); 17064 end loop; 17065 end Main; 17066 17067 ------------------ 17068 -- Main_Storage -- 17069 ------------------ 17070 17071 -- pragma Main_Storage 17072 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); 17073 17074 -- MAIN_STORAGE_OPTION ::= 17075 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION 17076 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION 17077 17078 when Pragma_Main_Storage => Main_Storage : declare 17079 Args : Args_List (1 .. 2); 17080 Names : constant Name_List (1 .. 2) := ( 17081 Name_Working_Storage, 17082 Name_Top_Guard); 17083 17084 Nod : Node_Id; 17085 17086 begin 17087 GNAT_Pragma; 17088 Gather_Associations (Names, Args); 17089 17090 for J in 1 .. 2 loop 17091 if Present (Args (J)) then 17092 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); 17093 end if; 17094 end loop; 17095 17096 Check_In_Main_Program; 17097 17098 Nod := Next (N); 17099 while Present (Nod) loop 17100 if Nkind (Nod) = N_Pragma 17101 and then Pragma_Name (Nod) = Name_Main_Storage 17102 then 17103 Error_Msg_Name_1 := Pname; 17104 Error_Msg_N ("duplicate pragma% not permitted", Nod); 17105 end if; 17106 17107 Next (Nod); 17108 end loop; 17109 end Main_Storage; 17110 17111 ----------------- 17112 -- Memory_Size -- 17113 ----------------- 17114 17115 -- pragma Memory_Size (NUMERIC_LITERAL) 17116 17117 when Pragma_Memory_Size => 17118 GNAT_Pragma; 17119 17120 -- Memory size is simply ignored 17121 17122 Check_No_Identifiers; 17123 Check_Arg_Count (1); 17124 Check_Arg_Is_Integer_Literal (Arg1); 17125 17126 ------------- 17127 -- No_Body -- 17128 ------------- 17129 17130 -- pragma No_Body; 17131 17132 -- The only correct use of this pragma is on its own in a file, in 17133 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body 17134 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to 17135 -- check for a file containing nothing but a No_Body pragma). If we 17136 -- attempt to process it during normal semantics processing, it means 17137 -- it was misplaced. 17138 17139 when Pragma_No_Body => 17140 GNAT_Pragma; 17141 Pragma_Misplaced; 17142 17143 ----------------------------- 17144 -- No_Elaboration_Code_All -- 17145 ----------------------------- 17146 17147 -- pragma No_Elaboration_Code_All; 17148 17149 when Pragma_No_Elaboration_Code_All => 17150 GNAT_Pragma; 17151 Check_Valid_Library_Unit_Pragma; 17152 17153 if Nkind (N) = N_Null_Statement then 17154 return; 17155 end if; 17156 17157 -- Must appear for a spec or generic spec 17158 17159 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)), 17160 N_Generic_Package_Declaration, 17161 N_Generic_Subprogram_Declaration, 17162 N_Package_Declaration, 17163 N_Subprogram_Declaration) 17164 then 17165 Error_Pragma 17166 (Fix_Error 17167 ("pragma% can only occur for package " 17168 & "or subprogram spec")); 17169 end if; 17170 17171 -- Set flag in unit table 17172 17173 Set_No_Elab_Code_All (Current_Sem_Unit); 17174 17175 -- Set restriction No_Elaboration_Code if this is the main unit 17176 17177 if Current_Sem_Unit = Main_Unit then 17178 Set_Restriction (No_Elaboration_Code, N); 17179 end if; 17180 17181 -- If we are in the main unit or in an extended main source unit, 17182 -- then we also add it to the configuration restrictions so that 17183 -- it will apply to all units in the extended main source. 17184 17185 if Current_Sem_Unit = Main_Unit 17186 or else In_Extended_Main_Source_Unit (N) 17187 then 17188 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 17189 end if; 17190 17191 -- If in main extended unit, activate transitive with test 17192 17193 if In_Extended_Main_Source_Unit (N) then 17194 Opt.No_Elab_Code_All_Pragma := N; 17195 end if; 17196 17197 --------------- 17198 -- No_Inline -- 17199 --------------- 17200 17201 -- pragma No_Inline ( NAME {, NAME} ); 17202 17203 when Pragma_No_Inline => 17204 GNAT_Pragma; 17205 Process_Inline (Suppressed); 17206 17207 --------------- 17208 -- No_Return -- 17209 --------------- 17210 17211 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name}); 17212 17213 when Pragma_No_Return => No_Return : declare 17214 Arg : Node_Id; 17215 E : Entity_Id; 17216 Found : Boolean; 17217 Id : Node_Id; 17218 17219 Ghost_Error_Posted : Boolean := False; 17220 -- Flag set when an error concerning the illegal mix of Ghost and 17221 -- non-Ghost subprograms is emitted. 17222 17223 Ghost_Id : Entity_Id := Empty; 17224 -- The entity of the first Ghost procedure encountered while 17225 -- processing the arguments of the pragma. 17226 17227 begin 17228 Ada_2005_Pragma; 17229 Check_At_Least_N_Arguments (1); 17230 17231 -- Loop through arguments of pragma 17232 17233 Arg := Arg1; 17234 while Present (Arg) loop 17235 Check_Arg_Is_Local_Name (Arg); 17236 Id := Get_Pragma_Arg (Arg); 17237 Analyze (Id); 17238 17239 if not Is_Entity_Name (Id) then 17240 Error_Pragma_Arg ("entity name required", Arg); 17241 end if; 17242 17243 if Etype (Id) = Any_Type then 17244 raise Pragma_Exit; 17245 end if; 17246 17247 -- Loop to find matching procedures 17248 17249 E := Entity (Id); 17250 17251 Found := False; 17252 while Present (E) 17253 and then Scope (E) = Current_Scope 17254 loop 17255 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then 17256 Set_No_Return (E); 17257 17258 -- A pragma that applies to a Ghost entity becomes Ghost 17259 -- for the purposes of legality checks and removal of 17260 -- ignored Ghost code. 17261 17262 Mark_Pragma_As_Ghost (N, E); 17263 17264 -- Capture the entity of the first Ghost procedure being 17265 -- processed for error detection purposes. 17266 17267 if Is_Ghost_Entity (E) then 17268 if No (Ghost_Id) then 17269 Ghost_Id := E; 17270 end if; 17271 17272 -- Otherwise the subprogram is non-Ghost. It is illegal 17273 -- to mix references to Ghost and non-Ghost entities 17274 -- (SPARK RM 6.9). 17275 17276 elsif Present (Ghost_Id) 17277 and then not Ghost_Error_Posted 17278 then 17279 Ghost_Error_Posted := True; 17280 17281 Error_Msg_Name_1 := Pname; 17282 Error_Msg_N 17283 ("pragma % cannot mention ghost and non-ghost " 17284 & "procedures", N); 17285 17286 Error_Msg_Sloc := Sloc (Ghost_Id); 17287 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 17288 17289 Error_Msg_Sloc := Sloc (E); 17290 Error_Msg_NE ("\& # declared as non-ghost", N, E); 17291 end if; 17292 17293 -- Set flag on any alias as well 17294 17295 if Is_Overloadable (E) and then Present (Alias (E)) then 17296 Set_No_Return (Alias (E)); 17297 end if; 17298 17299 Found := True; 17300 end if; 17301 17302 exit when From_Aspect_Specification (N); 17303 E := Homonym (E); 17304 end loop; 17305 17306 -- If entity in not in current scope it may be the enclosing 17307 -- suprogram body to which the aspect applies. 17308 17309 if not Found then 17310 if Entity (Id) = Current_Scope 17311 and then From_Aspect_Specification (N) 17312 then 17313 Set_No_Return (Entity (Id)); 17314 else 17315 Error_Pragma_Arg ("no procedure& found for pragma%", Arg); 17316 end if; 17317 end if; 17318 17319 Next (Arg); 17320 end loop; 17321 end No_Return; 17322 17323 ----------------- 17324 -- No_Run_Time -- 17325 ----------------- 17326 17327 -- pragma No_Run_Time; 17328 17329 -- Note: this pragma is retained for backwards compatibility. See 17330 -- body of Rtsfind for full details on its handling. 17331 17332 when Pragma_No_Run_Time => 17333 GNAT_Pragma; 17334 Check_Valid_Configuration_Pragma; 17335 Check_Arg_Count (0); 17336 17337 No_Run_Time_Mode := True; 17338 Configurable_Run_Time_Mode := True; 17339 17340 -- Set Duration to 32 bits if word size is 32 17341 17342 if Ttypes.System_Word_Size = 32 then 17343 Duration_32_Bits_On_Target := True; 17344 end if; 17345 17346 -- Set appropriate restrictions 17347 17348 Set_Restriction (No_Finalization, N); 17349 Set_Restriction (No_Exception_Handlers, N); 17350 Set_Restriction (Max_Tasks, N, 0); 17351 Set_Restriction (No_Tasking, N); 17352 17353 ----------------------- 17354 -- No_Tagged_Streams -- 17355 ----------------------- 17356 17357 -- pragma No_Tagged_Streams; 17358 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME); 17359 17360 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare 17361 E : Entity_Id; 17362 E_Id : Node_Id; 17363 17364 begin 17365 GNAT_Pragma; 17366 Check_At_Most_N_Arguments (1); 17367 17368 -- One argument case 17369 17370 if Arg_Count = 1 then 17371 Check_Optional_Identifier (Arg1, Name_Entity); 17372 Check_Arg_Is_Local_Name (Arg1); 17373 E_Id := Get_Pragma_Arg (Arg1); 17374 17375 if Etype (E_Id) = Any_Type then 17376 return; 17377 end if; 17378 17379 E := Entity (E_Id); 17380 17381 Check_Duplicate_Pragma (E); 17382 17383 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then 17384 Error_Pragma_Arg 17385 ("argument for pragma% must be root tagged type", Arg1); 17386 end if; 17387 17388 if Rep_Item_Too_Early (E, N) 17389 or else 17390 Rep_Item_Too_Late (E, N) 17391 then 17392 return; 17393 else 17394 Set_No_Tagged_Streams_Pragma (E, N); 17395 end if; 17396 17397 -- Zero argument case 17398 17399 else 17400 Check_Is_In_Decl_Part_Or_Package_Spec; 17401 No_Tagged_Streams := N; 17402 end if; 17403 end No_Tagged_Strms; 17404 17405 ------------------------ 17406 -- No_Strict_Aliasing -- 17407 ------------------------ 17408 17409 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; 17410 17411 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare 17412 E_Id : Entity_Id; 17413 17414 begin 17415 GNAT_Pragma; 17416 Check_At_Most_N_Arguments (1); 17417 17418 if Arg_Count = 0 then 17419 Check_Valid_Configuration_Pragma; 17420 Opt.No_Strict_Aliasing := True; 17421 17422 else 17423 Check_Optional_Identifier (Arg2, Name_Entity); 17424 Check_Arg_Is_Local_Name (Arg1); 17425 E_Id := Entity (Get_Pragma_Arg (Arg1)); 17426 17427 if E_Id = Any_Type then 17428 return; 17429 elsif No (E_Id) or else not Is_Access_Type (E_Id) then 17430 Error_Pragma_Arg ("pragma% requires access type", Arg1); 17431 end if; 17432 17433 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); 17434 end if; 17435 end No_Strict_Aliasing; 17436 17437 ----------------------- 17438 -- Normalize_Scalars -- 17439 ----------------------- 17440 17441 -- pragma Normalize_Scalars; 17442 17443 when Pragma_Normalize_Scalars => 17444 Check_Ada_83_Warning; 17445 Check_Arg_Count (0); 17446 Check_Valid_Configuration_Pragma; 17447 17448 -- Normalize_Scalars creates false positives in CodePeer, and 17449 -- incorrect negative results in GNATprove mode, so ignore this 17450 -- pragma in these modes. 17451 17452 if not (CodePeer_Mode or GNATprove_Mode) then 17453 Normalize_Scalars := True; 17454 Init_Or_Norm_Scalars := True; 17455 end if; 17456 17457 ----------------- 17458 -- Obsolescent -- 17459 ----------------- 17460 17461 -- pragma Obsolescent; 17462 17463 -- pragma Obsolescent ( 17464 -- [Message =>] static_string_EXPRESSION 17465 -- [,[Version =>] Ada_05]]); 17466 17467 -- pragma Obsolescent ( 17468 -- [Entity =>] NAME 17469 -- [,[Message =>] static_string_EXPRESSION 17470 -- [,[Version =>] Ada_05]] ); 17471 17472 when Pragma_Obsolescent => Obsolescent : declare 17473 Decl : Node_Id; 17474 Ename : Node_Id; 17475 17476 procedure Set_Obsolescent (E : Entity_Id); 17477 -- Given an entity Ent, mark it as obsolescent if appropriate 17478 17479 --------------------- 17480 -- Set_Obsolescent -- 17481 --------------------- 17482 17483 procedure Set_Obsolescent (E : Entity_Id) is 17484 Active : Boolean; 17485 Ent : Entity_Id; 17486 S : String_Id; 17487 17488 begin 17489 Active := True; 17490 Ent := E; 17491 17492 -- A pragma that applies to a Ghost entity becomes Ghost for 17493 -- the purposes of legality checks and removal of ignored Ghost 17494 -- code. 17495 17496 Mark_Pragma_As_Ghost (N, E); 17497 17498 -- Entity name was given 17499 17500 if Present (Ename) then 17501 17502 -- If entity name matches, we are fine. Save entity in 17503 -- pragma argument, for ASIS use. 17504 17505 if Chars (Ename) = Chars (Ent) then 17506 Set_Entity (Ename, Ent); 17507 Generate_Reference (Ent, Ename); 17508 17509 -- If entity name does not match, only possibility is an 17510 -- enumeration literal from an enumeration type declaration. 17511 17512 elsif Ekind (Ent) /= E_Enumeration_Type then 17513 Error_Pragma 17514 ("pragma % entity name does not match declaration"); 17515 17516 else 17517 Ent := First_Literal (E); 17518 loop 17519 if No (Ent) then 17520 Error_Pragma 17521 ("pragma % entity name does not match any " 17522 & "enumeration literal"); 17523 17524 elsif Chars (Ent) = Chars (Ename) then 17525 Set_Entity (Ename, Ent); 17526 Generate_Reference (Ent, Ename); 17527 exit; 17528 17529 else 17530 Ent := Next_Literal (Ent); 17531 end if; 17532 end loop; 17533 end if; 17534 end if; 17535 17536 -- Ent points to entity to be marked 17537 17538 if Arg_Count >= 1 then 17539 17540 -- Deal with static string argument 17541 17542 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 17543 S := Strval (Get_Pragma_Arg (Arg1)); 17544 17545 for J in 1 .. String_Length (S) loop 17546 if not In_Character_Range (Get_String_Char (S, J)) then 17547 Error_Pragma_Arg 17548 ("pragma% argument does not allow wide characters", 17549 Arg1); 17550 end if; 17551 end loop; 17552 17553 Obsolescent_Warnings.Append 17554 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1)))); 17555 17556 -- Check for Ada_05 parameter 17557 17558 if Arg_Count /= 1 then 17559 Check_Arg_Count (2); 17560 17561 declare 17562 Argx : constant Node_Id := Get_Pragma_Arg (Arg2); 17563 17564 begin 17565 Check_Arg_Is_Identifier (Argx); 17566 17567 if Chars (Argx) /= Name_Ada_05 then 17568 Error_Msg_Name_2 := Name_Ada_05; 17569 Error_Pragma_Arg 17570 ("only allowed argument for pragma% is %", Argx); 17571 end if; 17572 17573 if Ada_Version_Explicit < Ada_2005 17574 or else not Warn_On_Ada_2005_Compatibility 17575 then 17576 Active := False; 17577 end if; 17578 end; 17579 end if; 17580 end if; 17581 17582 -- Set flag if pragma active 17583 17584 if Active then 17585 Set_Is_Obsolescent (Ent); 17586 end if; 17587 17588 return; 17589 end Set_Obsolescent; 17590 17591 -- Start of processing for pragma Obsolescent 17592 17593 begin 17594 GNAT_Pragma; 17595 17596 Check_At_Most_N_Arguments (3); 17597 17598 -- See if first argument specifies an entity name 17599 17600 if Arg_Count >= 1 17601 and then 17602 (Chars (Arg1) = Name_Entity 17603 or else 17604 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, 17605 N_Identifier, 17606 N_Operator_Symbol)) 17607 then 17608 Ename := Get_Pragma_Arg (Arg1); 17609 17610 -- Eliminate first argument, so we can share processing 17611 17612 Arg1 := Arg2; 17613 Arg2 := Arg3; 17614 Arg_Count := Arg_Count - 1; 17615 17616 -- No Entity name argument given 17617 17618 else 17619 Ename := Empty; 17620 end if; 17621 17622 if Arg_Count >= 1 then 17623 Check_Optional_Identifier (Arg1, Name_Message); 17624 17625 if Arg_Count = 2 then 17626 Check_Optional_Identifier (Arg2, Name_Version); 17627 end if; 17628 end if; 17629 17630 -- Get immediately preceding declaration 17631 17632 Decl := Prev (N); 17633 while Present (Decl) and then Nkind (Decl) = N_Pragma loop 17634 Prev (Decl); 17635 end loop; 17636 17637 -- Cases where we do not follow anything other than another pragma 17638 17639 if No (Decl) then 17640 17641 -- First case: library level compilation unit declaration with 17642 -- the pragma immediately following the declaration. 17643 17644 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 17645 Set_Obsolescent 17646 (Defining_Entity (Unit (Parent (Parent (N))))); 17647 return; 17648 17649 -- Case 2: library unit placement for package 17650 17651 else 17652 declare 17653 Ent : constant Entity_Id := Find_Lib_Unit_Name; 17654 begin 17655 if Is_Package_Or_Generic_Package (Ent) then 17656 Set_Obsolescent (Ent); 17657 return; 17658 end if; 17659 end; 17660 end if; 17661 17662 -- Cases where we must follow a declaration, including an 17663 -- abstract subprogram declaration, which is not in the 17664 -- other node subtypes. 17665 17666 else 17667 if Nkind (Decl) not in N_Declaration 17668 and then Nkind (Decl) not in N_Later_Decl_Item 17669 and then Nkind (Decl) not in N_Generic_Declaration 17670 and then Nkind (Decl) not in N_Renaming_Declaration 17671 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration 17672 then 17673 Error_Pragma 17674 ("pragma% misplaced, " 17675 & "must immediately follow a declaration"); 17676 17677 else 17678 Set_Obsolescent (Defining_Entity (Decl)); 17679 return; 17680 end if; 17681 end if; 17682 end Obsolescent; 17683 17684 -------------- 17685 -- Optimize -- 17686 -------------- 17687 17688 -- pragma Optimize (Time | Space | Off); 17689 17690 -- The actual check for optimize is done in Gigi. Note that this 17691 -- pragma does not actually change the optimization setting, it 17692 -- simply checks that it is consistent with the pragma. 17693 17694 when Pragma_Optimize => 17695 Check_No_Identifiers; 17696 Check_Arg_Count (1); 17697 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); 17698 17699 ------------------------ 17700 -- Optimize_Alignment -- 17701 ------------------------ 17702 17703 -- pragma Optimize_Alignment (Time | Space | Off); 17704 17705 when Pragma_Optimize_Alignment => Optimize_Alignment : begin 17706 GNAT_Pragma; 17707 Check_No_Identifiers; 17708 Check_Arg_Count (1); 17709 Check_Valid_Configuration_Pragma; 17710 17711 declare 17712 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 17713 begin 17714 case Nam is 17715 when Name_Time => 17716 Opt.Optimize_Alignment := 'T'; 17717 when Name_Space => 17718 Opt.Optimize_Alignment := 'S'; 17719 when Name_Off => 17720 Opt.Optimize_Alignment := 'O'; 17721 when others => 17722 Error_Pragma_Arg ("invalid argument for pragma%", Arg1); 17723 end case; 17724 end; 17725 17726 -- Set indication that mode is set locally. If we are in fact in a 17727 -- configuration pragma file, this setting is harmless since the 17728 -- switch will get reset anyway at the start of each unit. 17729 17730 Optimize_Alignment_Local := True; 17731 end Optimize_Alignment; 17732 17733 ------------- 17734 -- Ordered -- 17735 ------------- 17736 17737 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); 17738 17739 when Pragma_Ordered => Ordered : declare 17740 Assoc : constant Node_Id := Arg1; 17741 Type_Id : Node_Id; 17742 Typ : Entity_Id; 17743 17744 begin 17745 GNAT_Pragma; 17746 Check_No_Identifiers; 17747 Check_Arg_Count (1); 17748 Check_Arg_Is_Local_Name (Arg1); 17749 17750 Type_Id := Get_Pragma_Arg (Assoc); 17751 Find_Type (Type_Id); 17752 Typ := Entity (Type_Id); 17753 17754 if Typ = Any_Type then 17755 return; 17756 else 17757 Typ := Underlying_Type (Typ); 17758 end if; 17759 17760 if not Is_Enumeration_Type (Typ) then 17761 Error_Pragma ("pragma% must specify enumeration type"); 17762 end if; 17763 17764 Check_First_Subtype (Arg1); 17765 Set_Has_Pragma_Ordered (Base_Type (Typ)); 17766 end Ordered; 17767 17768 ------------------- 17769 -- Overflow_Mode -- 17770 ------------------- 17771 17772 -- pragma Overflow_Mode 17773 -- ([General => ] MODE [, [Assertions => ] MODE]); 17774 17775 -- MODE := STRICT | MINIMIZED | ELIMINATED 17776 17777 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64 17778 -- since System.Bignums makes this assumption. This is true of nearly 17779 -- all (all?) targets. 17780 17781 when Pragma_Overflow_Mode => Overflow_Mode : declare 17782 function Get_Overflow_Mode 17783 (Name : Name_Id; 17784 Arg : Node_Id) return Overflow_Mode_Type; 17785 -- Function to process one pragma argument, Arg. If an identifier 17786 -- is present, it must be Name. Mode type is returned if a valid 17787 -- argument exists, otherwise an error is signalled. 17788 17789 ----------------------- 17790 -- Get_Overflow_Mode -- 17791 ----------------------- 17792 17793 function Get_Overflow_Mode 17794 (Name : Name_Id; 17795 Arg : Node_Id) return Overflow_Mode_Type 17796 is 17797 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 17798 17799 begin 17800 Check_Optional_Identifier (Arg, Name); 17801 Check_Arg_Is_Identifier (Argx); 17802 17803 if Chars (Argx) = Name_Strict then 17804 return Strict; 17805 17806 elsif Chars (Argx) = Name_Minimized then 17807 return Minimized; 17808 17809 elsif Chars (Argx) = Name_Eliminated then 17810 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then 17811 Error_Pragma_Arg 17812 ("Eliminated not implemented on this target", Argx); 17813 else 17814 return Eliminated; 17815 end if; 17816 17817 else 17818 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 17819 end if; 17820 end Get_Overflow_Mode; 17821 17822 -- Start of processing for Overflow_Mode 17823 17824 begin 17825 GNAT_Pragma; 17826 Check_At_Least_N_Arguments (1); 17827 Check_At_Most_N_Arguments (2); 17828 17829 -- Process first argument 17830 17831 Scope_Suppress.Overflow_Mode_General := 17832 Get_Overflow_Mode (Name_General, Arg1); 17833 17834 -- Case of only one argument 17835 17836 if Arg_Count = 1 then 17837 Scope_Suppress.Overflow_Mode_Assertions := 17838 Scope_Suppress.Overflow_Mode_General; 17839 17840 -- Case of two arguments present 17841 17842 else 17843 Scope_Suppress.Overflow_Mode_Assertions := 17844 Get_Overflow_Mode (Name_Assertions, Arg2); 17845 end if; 17846 end Overflow_Mode; 17847 17848 -------------------------- 17849 -- Overriding Renamings -- 17850 -------------------------- 17851 17852 -- pragma Overriding_Renamings; 17853 17854 when Pragma_Overriding_Renamings => 17855 GNAT_Pragma; 17856 Check_Arg_Count (0); 17857 Check_Valid_Configuration_Pragma; 17858 Overriding_Renamings := True; 17859 17860 ---------- 17861 -- Pack -- 17862 ---------- 17863 17864 -- pragma Pack (first_subtype_LOCAL_NAME); 17865 17866 when Pragma_Pack => Pack : declare 17867 Assoc : constant Node_Id := Arg1; 17868 Ctyp : Entity_Id; 17869 Ignore : Boolean := False; 17870 Typ : Entity_Id; 17871 Type_Id : Node_Id; 17872 17873 begin 17874 Check_No_Identifiers; 17875 Check_Arg_Count (1); 17876 Check_Arg_Is_Local_Name (Arg1); 17877 Type_Id := Get_Pragma_Arg (Assoc); 17878 17879 if not Is_Entity_Name (Type_Id) 17880 or else not Is_Type (Entity (Type_Id)) 17881 then 17882 Error_Pragma_Arg 17883 ("argument for pragma% must be type or subtype", Arg1); 17884 end if; 17885 17886 Find_Type (Type_Id); 17887 Typ := Entity (Type_Id); 17888 17889 if Typ = Any_Type 17890 or else Rep_Item_Too_Early (Typ, N) 17891 then 17892 return; 17893 else 17894 Typ := Underlying_Type (Typ); 17895 end if; 17896 17897 -- A pragma that applies to a Ghost entity becomes Ghost for the 17898 -- purposes of legality checks and removal of ignored Ghost code. 17899 17900 Mark_Pragma_As_Ghost (N, Typ); 17901 17902 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then 17903 Error_Pragma ("pragma% must specify array or record type"); 17904 end if; 17905 17906 Check_First_Subtype (Arg1); 17907 Check_Duplicate_Pragma (Typ); 17908 17909 -- Array type 17910 17911 if Is_Array_Type (Typ) then 17912 Ctyp := Component_Type (Typ); 17913 17914 -- Ignore pack that does nothing 17915 17916 if Known_Static_Esize (Ctyp) 17917 and then Known_Static_RM_Size (Ctyp) 17918 and then Esize (Ctyp) = RM_Size (Ctyp) 17919 and then Addressable (Esize (Ctyp)) 17920 then 17921 Ignore := True; 17922 end if; 17923 17924 -- Process OK pragma Pack. Note that if there is a separate 17925 -- component clause present, the Pack will be cancelled. This 17926 -- processing is in Freeze. 17927 17928 if not Rep_Item_Too_Late (Typ, N) then 17929 17930 -- In CodePeer mode, we do not need complex front-end 17931 -- expansions related to pragma Pack, so disable handling 17932 -- of pragma Pack. 17933 17934 if CodePeer_Mode then 17935 null; 17936 17937 -- Normal case where we do the pack action 17938 17939 else 17940 if not Ignore then 17941 Set_Is_Packed (Base_Type (Typ)); 17942 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 17943 end if; 17944 17945 Set_Has_Pragma_Pack (Base_Type (Typ)); 17946 end if; 17947 end if; 17948 17949 -- For record types, the pack is always effective 17950 17951 else pragma Assert (Is_Record_Type (Typ)); 17952 if not Rep_Item_Too_Late (Typ, N) then 17953 Set_Is_Packed (Base_Type (Typ)); 17954 Set_Has_Pragma_Pack (Base_Type (Typ)); 17955 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 17956 end if; 17957 end if; 17958 end Pack; 17959 17960 ---------- 17961 -- Page -- 17962 ---------- 17963 17964 -- pragma Page; 17965 17966 -- There is nothing to do here, since we did all the processing for 17967 -- this pragma in Par.Prag (so that it works properly even in syntax 17968 -- only mode). 17969 17970 when Pragma_Page => 17971 null; 17972 17973 ------------- 17974 -- Part_Of -- 17975 ------------- 17976 17977 -- pragma Part_Of (ABSTRACT_STATE); 17978 17979 -- ABSTRACT_STATE ::= NAME 17980 17981 when Pragma_Part_Of => Part_Of : declare 17982 procedure Propagate_Part_Of 17983 (Pack_Id : Entity_Id; 17984 State_Id : Entity_Id; 17985 Instance : Node_Id); 17986 -- Propagate the Part_Of indicator to all abstract states and 17987 -- objects declared in the visible state space of a package 17988 -- denoted by Pack_Id. State_Id is the encapsulating state. 17989 -- Instance is the package instantiation node. 17990 17991 ----------------------- 17992 -- Propagate_Part_Of -- 17993 ----------------------- 17994 17995 procedure Propagate_Part_Of 17996 (Pack_Id : Entity_Id; 17997 State_Id : Entity_Id; 17998 Instance : Node_Id) 17999 is 18000 Has_Item : Boolean := False; 18001 -- Flag set when the visible state space contains at least one 18002 -- abstract state or variable. 18003 18004 procedure Propagate_Part_Of (Pack_Id : Entity_Id); 18005 -- Propagate the Part_Of indicator to all abstract states and 18006 -- objects declared in the visible state space of a package 18007 -- denoted by Pack_Id. 18008 18009 ----------------------- 18010 -- Propagate_Part_Of -- 18011 ----------------------- 18012 18013 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is 18014 Item_Id : Entity_Id; 18015 18016 begin 18017 -- Traverse the entity chain of the package and set relevant 18018 -- attributes of abstract states and objects declared in the 18019 -- visible state space of the package. 18020 18021 Item_Id := First_Entity (Pack_Id); 18022 while Present (Item_Id) 18023 and then not In_Private_Part (Item_Id) 18024 loop 18025 -- Do not consider internally generated items 18026 18027 if not Comes_From_Source (Item_Id) then 18028 null; 18029 18030 -- The Part_Of indicator turns an abstract state or an 18031 -- object into a constituent of the encapsulating state. 18032 18033 elsif Ekind_In (Item_Id, E_Abstract_State, 18034 E_Constant, 18035 E_Variable) 18036 then 18037 Has_Item := True; 18038 18039 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id)); 18040 Set_Encapsulating_State (Item_Id, State_Id); 18041 18042 -- Recursively handle nested packages and instantiations 18043 18044 elsif Ekind (Item_Id) = E_Package then 18045 Propagate_Part_Of (Item_Id); 18046 end if; 18047 18048 Next_Entity (Item_Id); 18049 end loop; 18050 end Propagate_Part_Of; 18051 18052 -- Start of processing for Propagate_Part_Of 18053 18054 begin 18055 Propagate_Part_Of (Pack_Id); 18056 18057 -- Detect a package instantiation that is subject to a Part_Of 18058 -- indicator, but has no visible state. 18059 18060 if not Has_Item then 18061 SPARK_Msg_NE 18062 ("package instantiation & has Part_Of indicator but " 18063 & "lacks visible state", Instance, Pack_Id); 18064 end if; 18065 end Propagate_Part_Of; 18066 18067 -- Local variables 18068 18069 Encap : Node_Id; 18070 Encap_Id : Entity_Id; 18071 Item_Id : Entity_Id; 18072 Legal : Boolean; 18073 Stmt : Node_Id; 18074 18075 -- Start of processing for Part_Of 18076 18077 begin 18078 GNAT_Pragma; 18079 Check_No_Identifiers; 18080 Check_Arg_Count (1); 18081 18082 Stmt := Find_Related_Context (N, Do_Checks => True); 18083 18084 -- Object declaration 18085 18086 if Nkind (Stmt) = N_Object_Declaration then 18087 null; 18088 18089 -- Package instantiation 18090 18091 elsif Nkind (Stmt) = N_Package_Instantiation then 18092 null; 18093 18094 -- Single concurrent type declaration 18095 18096 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then 18097 null; 18098 18099 -- Otherwise the pragma is associated with an illegal construct 18100 18101 else 18102 Pragma_Misplaced; 18103 return; 18104 end if; 18105 18106 -- Extract the entity of the related object declaration or package 18107 -- instantiation. In the case of the instantiation, use the entity 18108 -- of the instance spec. 18109 18110 if Nkind (Stmt) = N_Package_Instantiation then 18111 Stmt := Instance_Spec (Stmt); 18112 end if; 18113 18114 Item_Id := Defining_Entity (Stmt); 18115 Encap := Get_Pragma_Arg (Arg1); 18116 18117 -- A pragma that applies to a Ghost entity becomes Ghost for the 18118 -- purposes of legality checks and removal of ignored Ghost code. 18119 18120 Mark_Pragma_As_Ghost (N, Item_Id); 18121 18122 -- Chain the pragma on the contract for further processing by 18123 -- Analyze_Part_Of_In_Decl_Part or for completeness. 18124 18125 Add_Contract_Item (N, Item_Id); 18126 18127 -- A variable may act as consituent of a single concurrent type 18128 -- which in turn could be declared after the variable. Due to this 18129 -- discrepancy, the full analysis of indicator Part_Of is delayed 18130 -- until the end of the enclosing declarative region (see routine 18131 -- Analyze_Part_Of_In_Decl_Part). 18132 18133 if Ekind (Item_Id) = E_Variable then 18134 null; 18135 18136 -- Otherwise indicator Part_Of applies to a constant or a package 18137 -- instantiation. 18138 18139 else 18140 -- Detect any discrepancies between the placement of the 18141 -- constant or package instantiation with respect to state 18142 -- space and the encapsulating state. 18143 18144 Analyze_Part_Of 18145 (Indic => N, 18146 Item_Id => Item_Id, 18147 Encap => Encap, 18148 Encap_Id => Encap_Id, 18149 Legal => Legal); 18150 18151 if Legal then 18152 pragma Assert (Present (Encap_Id)); 18153 18154 if Ekind (Item_Id) = E_Constant then 18155 Append_Elmt (Item_Id, Part_Of_Constituents (Encap_Id)); 18156 Set_Encapsulating_State (Item_Id, Encap_Id); 18157 18158 -- Propagate the Part_Of indicator to the visible state 18159 -- space of the package instantiation. 18160 18161 else 18162 Propagate_Part_Of 18163 (Pack_Id => Item_Id, 18164 State_Id => Encap_Id, 18165 Instance => Stmt); 18166 end if; 18167 end if; 18168 end if; 18169 end Part_Of; 18170 18171 ---------------------------------- 18172 -- Partition_Elaboration_Policy -- 18173 ---------------------------------- 18174 18175 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER); 18176 18177 when Pragma_Partition_Elaboration_Policy => declare 18178 subtype PEP_Range is Name_Id 18179 range First_Partition_Elaboration_Policy_Name 18180 .. Last_Partition_Elaboration_Policy_Name; 18181 PEP_Val : PEP_Range; 18182 PEP : Character; 18183 18184 begin 18185 Ada_2005_Pragma; 18186 Check_Arg_Count (1); 18187 Check_No_Identifiers; 18188 Check_Arg_Is_Partition_Elaboration_Policy (Arg1); 18189 Check_Valid_Configuration_Pragma; 18190 PEP_Val := Chars (Get_Pragma_Arg (Arg1)); 18191 18192 case PEP_Val is 18193 when Name_Concurrent => 18194 PEP := 'C'; 18195 when Name_Sequential => 18196 PEP := 'S'; 18197 end case; 18198 18199 if Partition_Elaboration_Policy /= ' ' 18200 and then Partition_Elaboration_Policy /= PEP 18201 then 18202 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc; 18203 Error_Pragma 18204 ("partition elaboration policy incompatible with policy#"); 18205 18206 -- Set new policy, but always preserve System_Location since we 18207 -- like the error message with the run time name. 18208 18209 else 18210 Partition_Elaboration_Policy := PEP; 18211 18212 if Partition_Elaboration_Policy_Sloc /= System_Location then 18213 Partition_Elaboration_Policy_Sloc := Loc; 18214 end if; 18215 end if; 18216 end; 18217 18218 ------------- 18219 -- Passive -- 18220 ------------- 18221 18222 -- pragma Passive [(PASSIVE_FORM)]; 18223 18224 -- PASSIVE_FORM ::= Semaphore | No 18225 18226 when Pragma_Passive => 18227 GNAT_Pragma; 18228 18229 if Nkind (Parent (N)) /= N_Task_Definition then 18230 Error_Pragma ("pragma% must be within task definition"); 18231 end if; 18232 18233 if Arg_Count /= 0 then 18234 Check_Arg_Count (1); 18235 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); 18236 end if; 18237 18238 ---------------------------------- 18239 -- Preelaborable_Initialization -- 18240 ---------------------------------- 18241 18242 -- pragma Preelaborable_Initialization (DIRECT_NAME); 18243 18244 when Pragma_Preelaborable_Initialization => Preelab_Init : declare 18245 Ent : Entity_Id; 18246 18247 begin 18248 Ada_2005_Pragma; 18249 Check_Arg_Count (1); 18250 Check_No_Identifiers; 18251 Check_Arg_Is_Identifier (Arg1); 18252 Check_Arg_Is_Local_Name (Arg1); 18253 Check_First_Subtype (Arg1); 18254 Ent := Entity (Get_Pragma_Arg (Arg1)); 18255 18256 -- A pragma that applies to a Ghost entity becomes Ghost for the 18257 -- purposes of legality checks and removal of ignored Ghost code. 18258 18259 Mark_Pragma_As_Ghost (N, Ent); 18260 18261 -- The pragma may come from an aspect on a private declaration, 18262 -- even if the freeze point at which this is analyzed in the 18263 -- private part after the full view. 18264 18265 if Has_Private_Declaration (Ent) 18266 and then From_Aspect_Specification (N) 18267 then 18268 null; 18269 18270 -- Check appropriate type argument 18271 18272 elsif Is_Private_Type (Ent) 18273 or else Is_Protected_Type (Ent) 18274 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)) 18275 18276 -- AI05-0028: The pragma applies to all composite types. Note 18277 -- that we apply this binding interpretation to earlier versions 18278 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable 18279 -- choice since there are other compilers that do the same. 18280 18281 or else Is_Composite_Type (Ent) 18282 then 18283 null; 18284 18285 else 18286 Error_Pragma_Arg 18287 ("pragma % can only be applied to private, formal derived, " 18288 & "protected, or composite type", Arg1); 18289 end if; 18290 18291 -- Give an error if the pragma is applied to a protected type that 18292 -- does not qualify (due to having entries, or due to components 18293 -- that do not qualify). 18294 18295 if Is_Protected_Type (Ent) 18296 and then not Has_Preelaborable_Initialization (Ent) 18297 then 18298 Error_Msg_N 18299 ("protected type & does not have preelaborable " 18300 & "initialization", Ent); 18301 18302 -- Otherwise mark the type as definitely having preelaborable 18303 -- initialization. 18304 18305 else 18306 Set_Known_To_Have_Preelab_Init (Ent); 18307 end if; 18308 18309 if Has_Pragma_Preelab_Init (Ent) 18310 and then Warn_On_Redundant_Constructs 18311 then 18312 Error_Pragma ("?r?duplicate pragma%!"); 18313 else 18314 Set_Has_Pragma_Preelab_Init (Ent); 18315 end if; 18316 end Preelab_Init; 18317 18318 -------------------- 18319 -- Persistent_BSS -- 18320 -------------------- 18321 18322 -- pragma Persistent_BSS [(object_NAME)]; 18323 18324 when Pragma_Persistent_BSS => Persistent_BSS : declare 18325 Decl : Node_Id; 18326 Ent : Entity_Id; 18327 Prag : Node_Id; 18328 18329 begin 18330 GNAT_Pragma; 18331 Check_At_Most_N_Arguments (1); 18332 18333 -- Case of application to specific object (one argument) 18334 18335 if Arg_Count = 1 then 18336 Check_Arg_Is_Library_Level_Local_Name (Arg1); 18337 18338 if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) 18339 or else not 18340 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, 18341 E_Constant) 18342 then 18343 Error_Pragma_Arg ("pragma% only applies to objects", Arg1); 18344 end if; 18345 18346 Ent := Entity (Get_Pragma_Arg (Arg1)); 18347 Decl := Parent (Ent); 18348 18349 -- A pragma that applies to a Ghost entity becomes Ghost for 18350 -- the purposes of legality checks and removal of ignored Ghost 18351 -- code. 18352 18353 Mark_Pragma_As_Ghost (N, Ent); 18354 18355 -- Check for duplication before inserting in list of 18356 -- representation items. 18357 18358 Check_Duplicate_Pragma (Ent); 18359 18360 if Rep_Item_Too_Late (Ent, N) then 18361 return; 18362 end if; 18363 18364 if Present (Expression (Decl)) then 18365 Error_Pragma_Arg 18366 ("object for pragma% cannot have initialization", Arg1); 18367 end if; 18368 18369 if not Is_Potentially_Persistent_Type (Etype (Ent)) then 18370 Error_Pragma_Arg 18371 ("object type for pragma% is not potentially persistent", 18372 Arg1); 18373 end if; 18374 18375 Prag := 18376 Make_Linker_Section_Pragma 18377 (Ent, Sloc (N), ".persistent.bss"); 18378 Insert_After (N, Prag); 18379 Analyze (Prag); 18380 18381 -- Case of use as configuration pragma with no arguments 18382 18383 else 18384 Check_Valid_Configuration_Pragma; 18385 Persistent_BSS_Mode := True; 18386 end if; 18387 end Persistent_BSS; 18388 18389 ------------- 18390 -- Polling -- 18391 ------------- 18392 18393 -- pragma Polling (ON | OFF); 18394 18395 when Pragma_Polling => 18396 GNAT_Pragma; 18397 Check_Arg_Count (1); 18398 Check_No_Identifiers; 18399 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 18400 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); 18401 18402 ----------------------------------- 18403 -- Post/Post_Class/Postcondition -- 18404 ----------------------------------- 18405 18406 -- pragma Post (Boolean_EXPRESSION); 18407 -- pragma Post_Class (Boolean_EXPRESSION); 18408 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION 18409 -- [,[Message =>] String_EXPRESSION]); 18410 18411 -- Characteristics: 18412 18413 -- * Analysis - The annotation undergoes initial checks to verify 18414 -- the legal placement and context. Secondary checks preanalyze the 18415 -- expression in: 18416 18417 -- Analyze_Pre_Post_Condition_In_Decl_Part 18418 18419 -- * Expansion - The annotation is expanded during the expansion of 18420 -- the related subprogram [body] contract as performed in: 18421 18422 -- Expand_Subprogram_Contract 18423 18424 -- * Template - The annotation utilizes the generic template of the 18425 -- related subprogram [body] when it is: 18426 18427 -- aspect on subprogram declaration 18428 -- aspect on stand alone subprogram body 18429 -- pragma on stand alone subprogram body 18430 18431 -- The annotation must prepare its own template when it is: 18432 18433 -- pragma on subprogram declaration 18434 18435 -- * Globals - Capture of global references must occur after full 18436 -- analysis. 18437 18438 -- * Instance - The annotation is instantiated automatically when 18439 -- the related generic subprogram [body] is instantiated except for 18440 -- the "pragma on subprogram declaration" case. In that scenario 18441 -- the annotation must instantiate itself. 18442 18443 when Pragma_Post | 18444 Pragma_Post_Class | 18445 Pragma_Postcondition => 18446 Analyze_Pre_Post_Condition; 18447 18448 -------------------------------- 18449 -- Pre/Pre_Class/Precondition -- 18450 -------------------------------- 18451 18452 -- pragma Pre (Boolean_EXPRESSION); 18453 -- pragma Pre_Class (Boolean_EXPRESSION); 18454 -- pragma Precondition ([Check =>] Boolean_EXPRESSION 18455 -- [,[Message =>] String_EXPRESSION]); 18456 18457 -- Characteristics: 18458 18459 -- * Analysis - The annotation undergoes initial checks to verify 18460 -- the legal placement and context. Secondary checks preanalyze the 18461 -- expression in: 18462 18463 -- Analyze_Pre_Post_Condition_In_Decl_Part 18464 18465 -- * Expansion - The annotation is expanded during the expansion of 18466 -- the related subprogram [body] contract as performed in: 18467 18468 -- Expand_Subprogram_Contract 18469 18470 -- * Template - The annotation utilizes the generic template of the 18471 -- related subprogram [body] when it is: 18472 18473 -- aspect on subprogram declaration 18474 -- aspect on stand alone subprogram body 18475 -- pragma on stand alone subprogram body 18476 18477 -- The annotation must prepare its own template when it is: 18478 18479 -- pragma on subprogram declaration 18480 18481 -- * Globals - Capture of global references must occur after full 18482 -- analysis. 18483 18484 -- * Instance - The annotation is instantiated automatically when 18485 -- the related generic subprogram [body] is instantiated except for 18486 -- the "pragma on subprogram declaration" case. In that scenario 18487 -- the annotation must instantiate itself. 18488 18489 when Pragma_Pre | 18490 Pragma_Pre_Class | 18491 Pragma_Precondition => 18492 Analyze_Pre_Post_Condition; 18493 18494 --------------- 18495 -- Predicate -- 18496 --------------- 18497 18498 -- pragma Predicate 18499 -- ([Entity =>] type_LOCAL_NAME, 18500 -- [Check =>] boolean_EXPRESSION); 18501 18502 when Pragma_Predicate => Predicate : declare 18503 Discard : Boolean; 18504 Typ : Entity_Id; 18505 Type_Id : Node_Id; 18506 18507 begin 18508 GNAT_Pragma; 18509 Check_Arg_Count (2); 18510 Check_Optional_Identifier (Arg1, Name_Entity); 18511 Check_Optional_Identifier (Arg2, Name_Check); 18512 18513 Check_Arg_Is_Local_Name (Arg1); 18514 18515 Type_Id := Get_Pragma_Arg (Arg1); 18516 Find_Type (Type_Id); 18517 Typ := Entity (Type_Id); 18518 18519 if Typ = Any_Type then 18520 return; 18521 end if; 18522 18523 -- A pragma that applies to a Ghost entity becomes Ghost for the 18524 -- purposes of legality checks and removal of ignored Ghost code. 18525 18526 Mark_Pragma_As_Ghost (N, Typ); 18527 18528 -- The remaining processing is simply to link the pragma on to 18529 -- the rep item chain, for processing when the type is frozen. 18530 -- This is accomplished by a call to Rep_Item_Too_Late. We also 18531 -- mark the type as having predicates. 18532 18533 Set_Has_Predicates (Typ); 18534 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 18535 end Predicate; 18536 18537 ----------------------- 18538 -- Predicate_Failure -- 18539 ----------------------- 18540 18541 -- pragma Predicate_Failure 18542 -- ([Entity =>] type_LOCAL_NAME, 18543 -- [Message =>] string_EXPRESSION); 18544 18545 when Pragma_Predicate_Failure => Predicate_Failure : declare 18546 Discard : Boolean; 18547 Typ : Entity_Id; 18548 Type_Id : Node_Id; 18549 18550 begin 18551 GNAT_Pragma; 18552 Check_Arg_Count (2); 18553 Check_Optional_Identifier (Arg1, Name_Entity); 18554 Check_Optional_Identifier (Arg2, Name_Message); 18555 18556 Check_Arg_Is_Local_Name (Arg1); 18557 18558 Type_Id := Get_Pragma_Arg (Arg1); 18559 Find_Type (Type_Id); 18560 Typ := Entity (Type_Id); 18561 18562 if Typ = Any_Type then 18563 return; 18564 end if; 18565 18566 -- A pragma that applies to a Ghost entity becomes Ghost for the 18567 -- purposes of legality checks and removal of ignored Ghost code. 18568 18569 Mark_Pragma_As_Ghost (N, Typ); 18570 18571 -- The remaining processing is simply to link the pragma on to 18572 -- the rep item chain, for processing when the type is frozen. 18573 -- This is accomplished by a call to Rep_Item_Too_Late. 18574 18575 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 18576 end Predicate_Failure; 18577 18578 ------------------ 18579 -- Preelaborate -- 18580 ------------------ 18581 18582 -- pragma Preelaborate [(library_unit_NAME)]; 18583 18584 -- Set the flag Is_Preelaborated of program unit name entity 18585 18586 when Pragma_Preelaborate => Preelaborate : declare 18587 Pa : constant Node_Id := Parent (N); 18588 Pk : constant Node_Kind := Nkind (Pa); 18589 Ent : Entity_Id; 18590 18591 begin 18592 Check_Ada_83_Warning; 18593 Check_Valid_Library_Unit_Pragma; 18594 18595 if Nkind (N) = N_Null_Statement then 18596 return; 18597 end if; 18598 18599 Ent := Find_Lib_Unit_Name; 18600 18601 -- A pragma that applies to a Ghost entity becomes Ghost for the 18602 -- purposes of legality checks and removal of ignored Ghost code. 18603 18604 Mark_Pragma_As_Ghost (N, Ent); 18605 Check_Duplicate_Pragma (Ent); 18606 18607 -- This filters out pragmas inside generic parents that show up 18608 -- inside instantiations. Pragmas that come from aspects in the 18609 -- unit are not ignored. 18610 18611 if Present (Ent) then 18612 if Pk = N_Package_Specification 18613 and then Present (Generic_Parent (Pa)) 18614 and then not From_Aspect_Specification (N) 18615 then 18616 null; 18617 18618 else 18619 if not Debug_Flag_U then 18620 Set_Is_Preelaborated (Ent); 18621 Set_Suppress_Elaboration_Warnings (Ent); 18622 end if; 18623 end if; 18624 end if; 18625 end Preelaborate; 18626 18627 ------------------------------- 18628 -- Prefix_Exception_Messages -- 18629 ------------------------------- 18630 18631 -- pragma Prefix_Exception_Messages; 18632 18633 when Pragma_Prefix_Exception_Messages => 18634 GNAT_Pragma; 18635 Check_Valid_Configuration_Pragma; 18636 Check_Arg_Count (0); 18637 Prefix_Exception_Messages := True; 18638 18639 -------------- 18640 -- Priority -- 18641 -------------- 18642 18643 -- pragma Priority (EXPRESSION); 18644 18645 when Pragma_Priority => Priority : declare 18646 P : constant Node_Id := Parent (N); 18647 Arg : Node_Id; 18648 Ent : Entity_Id; 18649 18650 begin 18651 Check_No_Identifiers; 18652 Check_Arg_Count (1); 18653 18654 -- Subprogram case 18655 18656 if Nkind (P) = N_Subprogram_Body then 18657 Check_In_Main_Program; 18658 18659 Ent := Defining_Unit_Name (Specification (P)); 18660 18661 if Nkind (Ent) = N_Defining_Program_Unit_Name then 18662 Ent := Defining_Identifier (Ent); 18663 end if; 18664 18665 Arg := Get_Pragma_Arg (Arg1); 18666 Analyze_And_Resolve (Arg, Standard_Integer); 18667 18668 -- Must be static 18669 18670 if not Is_OK_Static_Expression (Arg) then 18671 Flag_Non_Static_Expr 18672 ("main subprogram priority is not static!", Arg); 18673 raise Pragma_Exit; 18674 18675 -- If constraint error, then we already signalled an error 18676 18677 elsif Raises_Constraint_Error (Arg) then 18678 null; 18679 18680 -- Otherwise check in range except if Relaxed_RM_Semantics 18681 -- where we ignore the value if out of range. 18682 18683 else 18684 declare 18685 Val : constant Uint := Expr_Value (Arg); 18686 begin 18687 if not Relaxed_RM_Semantics 18688 and then 18689 (Val < 0 18690 or else Val > Expr_Value (Expression 18691 (Parent (RTE (RE_Max_Priority))))) 18692 then 18693 Error_Pragma_Arg 18694 ("main subprogram priority is out of range", Arg1); 18695 else 18696 Set_Main_Priority 18697 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 18698 end if; 18699 end; 18700 end if; 18701 18702 -- Load an arbitrary entity from System.Tasking.Stages or 18703 -- System.Tasking.Restricted.Stages (depending on the 18704 -- supported profile) to make sure that one of these packages 18705 -- is implicitly with'ed, since we need to have the tasking 18706 -- run time active for the pragma Priority to have any effect. 18707 -- Previously we with'ed the package System.Tasking, but this 18708 -- package does not trigger the required initialization of the 18709 -- run-time library. 18710 18711 declare 18712 Discard : Entity_Id; 18713 pragma Warnings (Off, Discard); 18714 begin 18715 if Restricted_Profile then 18716 Discard := RTE (RE_Activate_Restricted_Tasks); 18717 else 18718 Discard := RTE (RE_Activate_Tasks); 18719 end if; 18720 end; 18721 18722 -- Task or Protected, must be of type Integer 18723 18724 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then 18725 Arg := Get_Pragma_Arg (Arg1); 18726 Ent := Defining_Identifier (Parent (P)); 18727 18728 -- The expression must be analyzed in the special manner 18729 -- described in "Handling of Default and Per-Object 18730 -- Expressions" in sem.ads. 18731 18732 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); 18733 18734 if not Is_OK_Static_Expression (Arg) then 18735 Check_Restriction (Static_Priorities, Arg); 18736 end if; 18737 18738 -- Anything else is incorrect 18739 18740 else 18741 Pragma_Misplaced; 18742 end if; 18743 18744 -- Check duplicate pragma before we chain the pragma in the Rep 18745 -- Item chain of Ent. 18746 18747 Check_Duplicate_Pragma (Ent); 18748 Record_Rep_Item (Ent, N); 18749 end Priority; 18750 18751 ----------------------------------- 18752 -- Priority_Specific_Dispatching -- 18753 ----------------------------------- 18754 18755 -- pragma Priority_Specific_Dispatching ( 18756 -- policy_IDENTIFIER, 18757 -- first_priority_EXPRESSION, 18758 -- last_priority_EXPRESSION); 18759 18760 when Pragma_Priority_Specific_Dispatching => 18761 Priority_Specific_Dispatching : declare 18762 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority); 18763 -- This is the entity System.Any_Priority; 18764 18765 DP : Character; 18766 Lower_Bound : Node_Id; 18767 Upper_Bound : Node_Id; 18768 Lower_Val : Uint; 18769 Upper_Val : Uint; 18770 18771 begin 18772 Ada_2005_Pragma; 18773 Check_Arg_Count (3); 18774 Check_No_Identifiers; 18775 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 18776 Check_Valid_Configuration_Pragma; 18777 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 18778 DP := Fold_Upper (Name_Buffer (1)); 18779 18780 Lower_Bound := Get_Pragma_Arg (Arg2); 18781 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer); 18782 Lower_Val := Expr_Value (Lower_Bound); 18783 18784 Upper_Bound := Get_Pragma_Arg (Arg3); 18785 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer); 18786 Upper_Val := Expr_Value (Upper_Bound); 18787 18788 -- It is not allowed to use Task_Dispatching_Policy and 18789 -- Priority_Specific_Dispatching in the same partition. 18790 18791 if Task_Dispatching_Policy /= ' ' then 18792 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 18793 Error_Pragma 18794 ("pragma% incompatible with Task_Dispatching_Policy#"); 18795 18796 -- Check lower bound in range 18797 18798 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 18799 or else 18800 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id)) 18801 then 18802 Error_Pragma_Arg 18803 ("first_priority is out of range", Arg2); 18804 18805 -- Check upper bound in range 18806 18807 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 18808 or else 18809 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id)) 18810 then 18811 Error_Pragma_Arg 18812 ("last_priority is out of range", Arg3); 18813 18814 -- Check that the priority range is valid 18815 18816 elsif Lower_Val > Upper_Val then 18817 Error_Pragma 18818 ("last_priority_expression must be greater than or equal to " 18819 & "first_priority_expression"); 18820 18821 -- Store the new policy, but always preserve System_Location since 18822 -- we like the error message with the run-time name. 18823 18824 else 18825 -- Check overlapping in the priority ranges specified in other 18826 -- Priority_Specific_Dispatching pragmas within the same 18827 -- partition. We can only check those we know about. 18828 18829 for J in 18830 Specific_Dispatching.First .. Specific_Dispatching.Last 18831 loop 18832 if Specific_Dispatching.Table (J).First_Priority in 18833 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 18834 or else Specific_Dispatching.Table (J).Last_Priority in 18835 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 18836 then 18837 Error_Msg_Sloc := 18838 Specific_Dispatching.Table (J).Pragma_Loc; 18839 Error_Pragma 18840 ("priority range overlaps with " 18841 & "Priority_Specific_Dispatching#"); 18842 end if; 18843 end loop; 18844 18845 -- The use of Priority_Specific_Dispatching is incompatible 18846 -- with Task_Dispatching_Policy. 18847 18848 if Task_Dispatching_Policy /= ' ' then 18849 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 18850 Error_Pragma 18851 ("Priority_Specific_Dispatching incompatible " 18852 & "with Task_Dispatching_Policy#"); 18853 end if; 18854 18855 -- The use of Priority_Specific_Dispatching forces ceiling 18856 -- locking policy. 18857 18858 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then 18859 Error_Msg_Sloc := Locking_Policy_Sloc; 18860 Error_Pragma 18861 ("Priority_Specific_Dispatching incompatible " 18862 & "with Locking_Policy#"); 18863 18864 -- Set the Ceiling_Locking policy, but preserve System_Location 18865 -- since we like the error message with the run time name. 18866 18867 else 18868 Locking_Policy := 'C'; 18869 18870 if Locking_Policy_Sloc /= System_Location then 18871 Locking_Policy_Sloc := Loc; 18872 end if; 18873 end if; 18874 18875 -- Add entry in the table 18876 18877 Specific_Dispatching.Append 18878 ((Dispatching_Policy => DP, 18879 First_Priority => UI_To_Int (Lower_Val), 18880 Last_Priority => UI_To_Int (Upper_Val), 18881 Pragma_Loc => Loc)); 18882 end if; 18883 end Priority_Specific_Dispatching; 18884 18885 ------------- 18886 -- Profile -- 18887 ------------- 18888 18889 -- pragma Profile (profile_IDENTIFIER); 18890 18891 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational 18892 18893 when Pragma_Profile => 18894 Ada_2005_Pragma; 18895 Check_Arg_Count (1); 18896 Check_Valid_Configuration_Pragma; 18897 Check_No_Identifiers; 18898 18899 declare 18900 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 18901 18902 begin 18903 if Chars (Argx) = Name_Ravenscar then 18904 Set_Ravenscar_Profile (Ravenscar, N); 18905 18906 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then 18907 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N); 18908 18909 elsif Chars (Argx) = Name_Restricted then 18910 Set_Profile_Restrictions 18911 (Restricted, 18912 N, Warn => Treat_Restrictions_As_Warnings); 18913 18914 elsif Chars (Argx) = Name_Rational then 18915 Set_Rational_Profile; 18916 18917 elsif Chars (Argx) = Name_No_Implementation_Extensions then 18918 Set_Profile_Restrictions 18919 (No_Implementation_Extensions, 18920 N, Warn => Treat_Restrictions_As_Warnings); 18921 18922 else 18923 Error_Pragma_Arg ("& is not a valid profile", Argx); 18924 end if; 18925 end; 18926 18927 ---------------------- 18928 -- Profile_Warnings -- 18929 ---------------------- 18930 18931 -- pragma Profile_Warnings (profile_IDENTIFIER); 18932 18933 -- profile_IDENTIFIER => Restricted | Ravenscar 18934 18935 when Pragma_Profile_Warnings => 18936 GNAT_Pragma; 18937 Check_Arg_Count (1); 18938 Check_Valid_Configuration_Pragma; 18939 Check_No_Identifiers; 18940 18941 declare 18942 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 18943 18944 begin 18945 if Chars (Argx) = Name_Ravenscar then 18946 Set_Profile_Restrictions (Ravenscar, N, Warn => True); 18947 18948 elsif Chars (Argx) = Name_Restricted then 18949 Set_Profile_Restrictions (Restricted, N, Warn => True); 18950 18951 elsif Chars (Argx) = Name_No_Implementation_Extensions then 18952 Set_Profile_Restrictions 18953 (No_Implementation_Extensions, N, Warn => True); 18954 18955 else 18956 Error_Pragma_Arg ("& is not a valid profile", Argx); 18957 end if; 18958 end; 18959 18960 -------------------------- 18961 -- Propagate_Exceptions -- 18962 -------------------------- 18963 18964 -- pragma Propagate_Exceptions; 18965 18966 -- Note: this pragma is obsolete and has no effect 18967 18968 when Pragma_Propagate_Exceptions => 18969 GNAT_Pragma; 18970 Check_Arg_Count (0); 18971 18972 if Warn_On_Obsolescent_Feature then 18973 Error_Msg_N 18974 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " & 18975 "and has no effect?j?", N); 18976 end if; 18977 18978 ----------------------------- 18979 -- Provide_Shift_Operators -- 18980 ----------------------------- 18981 18982 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME); 18983 18984 when Pragma_Provide_Shift_Operators => 18985 Provide_Shift_Operators : declare 18986 Ent : Entity_Id; 18987 18988 procedure Declare_Shift_Operator (Nam : Name_Id); 18989 -- Insert declaration and pragma Instrinsic for named shift op 18990 18991 ---------------------------- 18992 -- Declare_Shift_Operator -- 18993 ---------------------------- 18994 18995 procedure Declare_Shift_Operator (Nam : Name_Id) is 18996 Func : Node_Id; 18997 Import : Node_Id; 18998 18999 begin 19000 Func := 19001 Make_Subprogram_Declaration (Loc, 19002 Make_Function_Specification (Loc, 19003 Defining_Unit_Name => 19004 Make_Defining_Identifier (Loc, Chars => Nam), 19005 19006 Result_Definition => 19007 Make_Identifier (Loc, Chars => Chars (Ent)), 19008 19009 Parameter_Specifications => New_List ( 19010 Make_Parameter_Specification (Loc, 19011 Defining_Identifier => 19012 Make_Defining_Identifier (Loc, Name_Value), 19013 Parameter_Type => 19014 Make_Identifier (Loc, Chars => Chars (Ent))), 19015 19016 Make_Parameter_Specification (Loc, 19017 Defining_Identifier => 19018 Make_Defining_Identifier (Loc, Name_Amount), 19019 Parameter_Type => 19020 New_Occurrence_Of (Standard_Natural, Loc))))); 19021 19022 Import := 19023 Make_Pragma (Loc, 19024 Pragma_Identifier => Make_Identifier (Loc, Name_Import), 19025 Pragma_Argument_Associations => New_List ( 19026 Make_Pragma_Argument_Association (Loc, 19027 Expression => Make_Identifier (Loc, Name_Intrinsic)), 19028 Make_Pragma_Argument_Association (Loc, 19029 Expression => Make_Identifier (Loc, Nam)))); 19030 19031 Insert_After (N, Import); 19032 Insert_After (N, Func); 19033 end Declare_Shift_Operator; 19034 19035 -- Start of processing for Provide_Shift_Operators 19036 19037 begin 19038 GNAT_Pragma; 19039 Check_Arg_Count (1); 19040 Check_Arg_Is_Local_Name (Arg1); 19041 19042 Arg1 := Get_Pragma_Arg (Arg1); 19043 19044 -- We must have an entity name 19045 19046 if not Is_Entity_Name (Arg1) then 19047 Error_Pragma_Arg 19048 ("pragma % must apply to integer first subtype", Arg1); 19049 end if; 19050 19051 -- If no Entity, means there was a prior error so ignore 19052 19053 if Present (Entity (Arg1)) then 19054 Ent := Entity (Arg1); 19055 19056 -- Apply error checks 19057 19058 if not Is_First_Subtype (Ent) then 19059 Error_Pragma_Arg 19060 ("cannot apply pragma %", 19061 "\& is not a first subtype", 19062 Arg1); 19063 19064 elsif not Is_Integer_Type (Ent) then 19065 Error_Pragma_Arg 19066 ("cannot apply pragma %", 19067 "\& is not an integer type", 19068 Arg1); 19069 19070 elsif Has_Shift_Operator (Ent) then 19071 Error_Pragma_Arg 19072 ("cannot apply pragma %", 19073 "\& already has declared shift operators", 19074 Arg1); 19075 19076 elsif Is_Frozen (Ent) then 19077 Error_Pragma_Arg 19078 ("pragma % appears too late", 19079 "\& is already frozen", 19080 Arg1); 19081 end if; 19082 19083 -- Now declare the operators. We do this during analysis rather 19084 -- than expansion, since we want the operators available if we 19085 -- are operating in -gnatc or ASIS mode. 19086 19087 Declare_Shift_Operator (Name_Rotate_Left); 19088 Declare_Shift_Operator (Name_Rotate_Right); 19089 Declare_Shift_Operator (Name_Shift_Left); 19090 Declare_Shift_Operator (Name_Shift_Right); 19091 Declare_Shift_Operator (Name_Shift_Right_Arithmetic); 19092 end if; 19093 end Provide_Shift_Operators; 19094 19095 ------------------ 19096 -- Psect_Object -- 19097 ------------------ 19098 19099 -- pragma Psect_Object ( 19100 -- [Internal =>] LOCAL_NAME, 19101 -- [, [External =>] EXTERNAL_SYMBOL] 19102 -- [, [Size =>] EXTERNAL_SYMBOL]); 19103 19104 when Pragma_Psect_Object | Pragma_Common_Object => 19105 Psect_Object : declare 19106 Args : Args_List (1 .. 3); 19107 Names : constant Name_List (1 .. 3) := ( 19108 Name_Internal, 19109 Name_External, 19110 Name_Size); 19111 19112 Internal : Node_Id renames Args (1); 19113 External : Node_Id renames Args (2); 19114 Size : Node_Id renames Args (3); 19115 19116 Def_Id : Entity_Id; 19117 19118 procedure Check_Arg (Arg : Node_Id); 19119 -- Checks that argument is either a string literal or an 19120 -- identifier, and posts error message if not. 19121 19122 --------------- 19123 -- Check_Arg -- 19124 --------------- 19125 19126 procedure Check_Arg (Arg : Node_Id) is 19127 begin 19128 if not Nkind_In (Original_Node (Arg), 19129 N_String_Literal, 19130 N_Identifier) 19131 then 19132 Error_Pragma_Arg 19133 ("inappropriate argument for pragma %", Arg); 19134 end if; 19135 end Check_Arg; 19136 19137 -- Start of processing for Common_Object/Psect_Object 19138 19139 begin 19140 GNAT_Pragma; 19141 Gather_Associations (Names, Args); 19142 Process_Extended_Import_Export_Internal_Arg (Internal); 19143 19144 Def_Id := Entity (Internal); 19145 19146 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 19147 Error_Pragma_Arg 19148 ("pragma% must designate an object", Internal); 19149 end if; 19150 19151 Check_Arg (Internal); 19152 19153 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then 19154 Error_Pragma_Arg 19155 ("cannot use pragma% for imported/exported object", 19156 Internal); 19157 end if; 19158 19159 if Is_Concurrent_Type (Etype (Internal)) then 19160 Error_Pragma_Arg 19161 ("cannot specify pragma % for task/protected object", 19162 Internal); 19163 end if; 19164 19165 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 19166 or else 19167 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 19168 then 19169 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N); 19170 end if; 19171 19172 if Ekind (Def_Id) = E_Constant then 19173 Error_Pragma_Arg 19174 ("cannot specify pragma % for a constant", Internal); 19175 end if; 19176 19177 if Is_Record_Type (Etype (Internal)) then 19178 declare 19179 Ent : Entity_Id; 19180 Decl : Entity_Id; 19181 19182 begin 19183 Ent := First_Entity (Etype (Internal)); 19184 while Present (Ent) loop 19185 Decl := Declaration_Node (Ent); 19186 19187 if Ekind (Ent) = E_Component 19188 and then Nkind (Decl) = N_Component_Declaration 19189 and then Present (Expression (Decl)) 19190 and then Warn_On_Export_Import 19191 then 19192 Error_Msg_N 19193 ("?x?object for pragma % has defaults", Internal); 19194 exit; 19195 19196 else 19197 Next_Entity (Ent); 19198 end if; 19199 end loop; 19200 end; 19201 end if; 19202 19203 if Present (Size) then 19204 Check_Arg (Size); 19205 end if; 19206 19207 if Present (External) then 19208 Check_Arg_Is_External_Name (External); 19209 end if; 19210 19211 -- If all error tests pass, link pragma on to the rep item chain 19212 19213 Record_Rep_Item (Def_Id, N); 19214 end Psect_Object; 19215 19216 ---------- 19217 -- Pure -- 19218 ---------- 19219 19220 -- pragma Pure [(library_unit_NAME)]; 19221 19222 when Pragma_Pure => Pure : declare 19223 Ent : Entity_Id; 19224 19225 begin 19226 Check_Ada_83_Warning; 19227 Check_Valid_Library_Unit_Pragma; 19228 19229 if Nkind (N) = N_Null_Statement then 19230 return; 19231 end if; 19232 19233 Ent := Find_Lib_Unit_Name; 19234 19235 -- A pragma that applies to a Ghost entity becomes Ghost for the 19236 -- purposes of legality checks and removal of ignored Ghost code. 19237 19238 Mark_Pragma_As_Ghost (N, Ent); 19239 19240 if not Debug_Flag_U then 19241 Set_Is_Pure (Ent); 19242 Set_Has_Pragma_Pure (Ent); 19243 Set_Suppress_Elaboration_Warnings (Ent); 19244 end if; 19245 end Pure; 19246 19247 ------------------- 19248 -- Pure_Function -- 19249 ------------------- 19250 19251 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME); 19252 19253 when Pragma_Pure_Function => Pure_Function : declare 19254 Def_Id : Entity_Id; 19255 E : Entity_Id; 19256 E_Id : Node_Id; 19257 Effective : Boolean := False; 19258 19259 begin 19260 GNAT_Pragma; 19261 Check_Arg_Count (1); 19262 Check_Optional_Identifier (Arg1, Name_Entity); 19263 Check_Arg_Is_Local_Name (Arg1); 19264 E_Id := Get_Pragma_Arg (Arg1); 19265 19266 if Error_Posted (E_Id) then 19267 return; 19268 end if; 19269 19270 -- Loop through homonyms (overloadings) of referenced entity 19271 19272 E := Entity (E_Id); 19273 19274 -- A pragma that applies to a Ghost entity becomes Ghost for the 19275 -- purposes of legality checks and removal of ignored Ghost code. 19276 19277 Mark_Pragma_As_Ghost (N, E); 19278 19279 if Present (E) then 19280 loop 19281 Def_Id := Get_Base_Subprogram (E); 19282 19283 if not Ekind_In (Def_Id, E_Function, 19284 E_Generic_Function, 19285 E_Operator) 19286 then 19287 Error_Pragma_Arg 19288 ("pragma% requires a function name", Arg1); 19289 end if; 19290 19291 Set_Is_Pure (Def_Id); 19292 19293 if not Has_Pragma_Pure_Function (Def_Id) then 19294 Set_Has_Pragma_Pure_Function (Def_Id); 19295 Effective := True; 19296 end if; 19297 19298 exit when From_Aspect_Specification (N); 19299 E := Homonym (E); 19300 exit when No (E) or else Scope (E) /= Current_Scope; 19301 end loop; 19302 19303 if not Effective 19304 and then Warn_On_Redundant_Constructs 19305 then 19306 Error_Msg_NE 19307 ("pragma Pure_Function on& is redundant?r?", 19308 N, Entity (E_Id)); 19309 end if; 19310 end if; 19311 end Pure_Function; 19312 19313 -------------------- 19314 -- Queuing_Policy -- 19315 -------------------- 19316 19317 -- pragma Queuing_Policy (policy_IDENTIFIER); 19318 19319 when Pragma_Queuing_Policy => declare 19320 QP : Character; 19321 19322 begin 19323 Check_Ada_83_Warning; 19324 Check_Arg_Count (1); 19325 Check_No_Identifiers; 19326 Check_Arg_Is_Queuing_Policy (Arg1); 19327 Check_Valid_Configuration_Pragma; 19328 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 19329 QP := Fold_Upper (Name_Buffer (1)); 19330 19331 if Queuing_Policy /= ' ' 19332 and then Queuing_Policy /= QP 19333 then 19334 Error_Msg_Sloc := Queuing_Policy_Sloc; 19335 Error_Pragma ("queuing policy incompatible with policy#"); 19336 19337 -- Set new policy, but always preserve System_Location since we 19338 -- like the error message with the run time name. 19339 19340 else 19341 Queuing_Policy := QP; 19342 19343 if Queuing_Policy_Sloc /= System_Location then 19344 Queuing_Policy_Sloc := Loc; 19345 end if; 19346 end if; 19347 end; 19348 19349 -------------- 19350 -- Rational -- 19351 -------------- 19352 19353 -- pragma Rational, for compatibility with foreign compiler 19354 19355 when Pragma_Rational => 19356 Set_Rational_Profile; 19357 19358 --------------------- 19359 -- Refined_Depends -- 19360 --------------------- 19361 19362 -- pragma Refined_Depends (DEPENDENCY_RELATION); 19363 19364 -- DEPENDENCY_RELATION ::= 19365 -- null 19366 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}) 19367 19368 -- DEPENDENCY_CLAUSE ::= 19369 -- OUTPUT_LIST =>[+] INPUT_LIST 19370 -- | NULL_DEPENDENCY_CLAUSE 19371 19372 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 19373 19374 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 19375 19376 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 19377 19378 -- OUTPUT ::= NAME | FUNCTION_RESULT 19379 -- INPUT ::= NAME 19380 19381 -- where FUNCTION_RESULT is a function Result attribute_reference 19382 19383 -- Characteristics: 19384 19385 -- * Analysis - The annotation undergoes initial checks to verify 19386 -- the legal placement and context. Secondary checks fully analyze 19387 -- the dependency clauses/global list in: 19388 19389 -- Analyze_Refined_Depends_In_Decl_Part 19390 19391 -- * Expansion - None. 19392 19393 -- * Template - The annotation utilizes the generic template of the 19394 -- related subprogram body. 19395 19396 -- * Globals - Capture of global references must occur after full 19397 -- analysis. 19398 19399 -- * Instance - The annotation is instantiated automatically when 19400 -- the related generic subprogram body is instantiated. 19401 19402 when Pragma_Refined_Depends => Refined_Depends : declare 19403 Body_Id : Entity_Id; 19404 Legal : Boolean; 19405 Spec_Id : Entity_Id; 19406 19407 begin 19408 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 19409 19410 if Legal then 19411 19412 -- Chain the pragma on the contract for further processing by 19413 -- Analyze_Refined_Depends_In_Decl_Part. 19414 19415 Add_Contract_Item (N, Body_Id); 19416 19417 -- The legality checks of pragmas Refined_Depends and 19418 -- Refined_Global are affected by the SPARK mode in effect and 19419 -- the volatility of the context. In addition these two pragmas 19420 -- are subject to an inherent order: 19421 19422 -- 1) Refined_Global 19423 -- 2) Refined_Depends 19424 19425 -- Analyze all these pragmas in the order outlined above 19426 19427 Analyze_If_Present (Pragma_SPARK_Mode); 19428 Analyze_If_Present (Pragma_Volatile_Function); 19429 Analyze_If_Present (Pragma_Refined_Global); 19430 Analyze_Refined_Depends_In_Decl_Part (N); 19431 end if; 19432 end Refined_Depends; 19433 19434 -------------------- 19435 -- Refined_Global -- 19436 -------------------- 19437 19438 -- pragma Refined_Global (GLOBAL_SPECIFICATION); 19439 19440 -- GLOBAL_SPECIFICATION ::= 19441 -- null 19442 -- | (GLOBAL_LIST) 19443 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}) 19444 19445 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 19446 19447 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 19448 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 19449 -- GLOBAL_ITEM ::= NAME 19450 19451 -- Characteristics: 19452 19453 -- * Analysis - The annotation undergoes initial checks to verify 19454 -- the legal placement and context. Secondary checks fully analyze 19455 -- the dependency clauses/global list in: 19456 19457 -- Analyze_Refined_Global_In_Decl_Part 19458 19459 -- * Expansion - None. 19460 19461 -- * Template - The annotation utilizes the generic template of the 19462 -- related subprogram body. 19463 19464 -- * Globals - Capture of global references must occur after full 19465 -- analysis. 19466 19467 -- * Instance - The annotation is instantiated automatically when 19468 -- the related generic subprogram body is instantiated. 19469 19470 when Pragma_Refined_Global => Refined_Global : declare 19471 Body_Id : Entity_Id; 19472 Legal : Boolean; 19473 Spec_Id : Entity_Id; 19474 19475 begin 19476 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 19477 19478 if Legal then 19479 19480 -- Chain the pragma on the contract for further processing by 19481 -- Analyze_Refined_Global_In_Decl_Part. 19482 19483 Add_Contract_Item (N, Body_Id); 19484 19485 -- The legality checks of pragmas Refined_Depends and 19486 -- Refined_Global are affected by the SPARK mode in effect and 19487 -- the volatility of the context. In addition these two pragmas 19488 -- are subject to an inherent order: 19489 19490 -- 1) Refined_Global 19491 -- 2) Refined_Depends 19492 19493 -- Analyze all these pragmas in the order outlined above 19494 19495 Analyze_If_Present (Pragma_SPARK_Mode); 19496 Analyze_If_Present (Pragma_Volatile_Function); 19497 Analyze_Refined_Global_In_Decl_Part (N); 19498 Analyze_If_Present (Pragma_Refined_Depends); 19499 end if; 19500 end Refined_Global; 19501 19502 ------------------ 19503 -- Refined_Post -- 19504 ------------------ 19505 19506 -- pragma Refined_Post (boolean_EXPRESSION); 19507 19508 -- Characteristics: 19509 19510 -- * Analysis - The annotation is fully analyzed immediately upon 19511 -- elaboration as it cannot forward reference entities. 19512 19513 -- * Expansion - The annotation is expanded during the expansion of 19514 -- the related subprogram body contract as performed in: 19515 19516 -- Expand_Subprogram_Contract 19517 19518 -- * Template - The annotation utilizes the generic template of the 19519 -- related subprogram body. 19520 19521 -- * Globals - Capture of global references must occur after full 19522 -- analysis. 19523 19524 -- * Instance - The annotation is instantiated automatically when 19525 -- the related generic subprogram body is instantiated. 19526 19527 when Pragma_Refined_Post => Refined_Post : declare 19528 Body_Id : Entity_Id; 19529 Legal : Boolean; 19530 Spec_Id : Entity_Id; 19531 19532 begin 19533 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 19534 19535 -- Fully analyze the pragma when it appears inside a subprogram 19536 -- body because it cannot benefit from forward references. 19537 19538 if Legal then 19539 19540 -- Chain the pragma on the contract for completeness 19541 19542 Add_Contract_Item (N, Body_Id); 19543 19544 -- The legality checks of pragma Refined_Post are affected by 19545 -- the SPARK mode in effect and the volatility of the context. 19546 -- Analyze all pragmas in a specific order. 19547 19548 Analyze_If_Present (Pragma_SPARK_Mode); 19549 Analyze_If_Present (Pragma_Volatile_Function); 19550 Analyze_Pre_Post_Condition_In_Decl_Part (N); 19551 19552 -- Currently it is not possible to inline pre/postconditions on 19553 -- a subprogram subject to pragma Inline_Always. 19554 19555 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 19556 end if; 19557 end Refined_Post; 19558 19559 ------------------- 19560 -- Refined_State -- 19561 ------------------- 19562 19563 -- pragma Refined_State (REFINEMENT_LIST); 19564 19565 -- REFINEMENT_LIST ::= 19566 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE}) 19567 19568 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST 19569 19570 -- CONSTITUENT_LIST ::= 19571 -- null 19572 -- | CONSTITUENT 19573 -- | (CONSTITUENT {, CONSTITUENT}) 19574 19575 -- CONSTITUENT ::= object_NAME | state_NAME 19576 19577 -- Characteristics: 19578 19579 -- * Analysis - The annotation undergoes initial checks to verify 19580 -- the legal placement and context. Secondary checks preanalyze the 19581 -- refinement clauses in: 19582 19583 -- Analyze_Refined_State_In_Decl_Part 19584 19585 -- * Expansion - None. 19586 19587 -- * Template - The annotation utilizes the template of the related 19588 -- package body. 19589 19590 -- * Globals - Capture of global references must occur after full 19591 -- analysis. 19592 19593 -- * Instance - The annotation is instantiated automatically when 19594 -- the related generic package body is instantiated. 19595 19596 when Pragma_Refined_State => Refined_State : declare 19597 Pack_Decl : Node_Id; 19598 Spec_Id : Entity_Id; 19599 19600 begin 19601 GNAT_Pragma; 19602 Check_No_Identifiers; 19603 Check_Arg_Count (1); 19604 19605 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 19606 19607 -- Ensure the proper placement of the pragma. Refined states must 19608 -- be associated with a package body. 19609 19610 if Nkind (Pack_Decl) = N_Package_Body then 19611 null; 19612 19613 -- Otherwise the pragma is associated with an illegal construct 19614 19615 else 19616 Pragma_Misplaced; 19617 return; 19618 end if; 19619 19620 Spec_Id := Corresponding_Spec (Pack_Decl); 19621 19622 -- Chain the pragma on the contract for further processing by 19623 -- Analyze_Refined_State_In_Decl_Part. 19624 19625 Add_Contract_Item (N, Defining_Entity (Pack_Decl)); 19626 19627 -- The legality checks of pragma Refined_State are affected by the 19628 -- SPARK mode in effect. Analyze all pragmas in a specific order. 19629 19630 Analyze_If_Present (Pragma_SPARK_Mode); 19631 19632 -- A pragma that applies to a Ghost entity becomes Ghost for the 19633 -- purposes of legality checks and removal of ignored Ghost code. 19634 19635 Mark_Pragma_As_Ghost (N, Spec_Id); 19636 19637 -- State refinement is allowed only when the corresponding package 19638 -- declaration has non-null pragma Abstract_State. Refinement not 19639 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)). 19640 19641 if SPARK_Mode /= Off 19642 and then 19643 (No (Abstract_States (Spec_Id)) 19644 or else Has_Null_Abstract_State (Spec_Id)) 19645 then 19646 Error_Msg_NE 19647 ("useless refinement, package & does not define abstract " 19648 & "states", N, Spec_Id); 19649 return; 19650 end if; 19651 end Refined_State; 19652 19653 ----------------------- 19654 -- Relative_Deadline -- 19655 ----------------------- 19656 19657 -- pragma Relative_Deadline (time_span_EXPRESSION); 19658 19659 when Pragma_Relative_Deadline => Relative_Deadline : declare 19660 P : constant Node_Id := Parent (N); 19661 Arg : Node_Id; 19662 19663 begin 19664 Ada_2005_Pragma; 19665 Check_No_Identifiers; 19666 Check_Arg_Count (1); 19667 19668 Arg := Get_Pragma_Arg (Arg1); 19669 19670 -- The expression must be analyzed in the special manner described 19671 -- in "Handling of Default and Per-Object Expressions" in sem.ads. 19672 19673 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); 19674 19675 -- Subprogram case 19676 19677 if Nkind (P) = N_Subprogram_Body then 19678 Check_In_Main_Program; 19679 19680 -- Only Task and subprogram cases allowed 19681 19682 elsif Nkind (P) /= N_Task_Definition then 19683 Pragma_Misplaced; 19684 end if; 19685 19686 -- Check duplicate pragma before we set the corresponding flag 19687 19688 if Has_Relative_Deadline_Pragma (P) then 19689 Error_Pragma ("duplicate pragma% not allowed"); 19690 end if; 19691 19692 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that 19693 -- Relative_Deadline pragma node cannot be inserted in the Rep 19694 -- Item chain of Ent since it is rewritten by the expander as a 19695 -- procedure call statement that will break the chain. 19696 19697 Set_Has_Relative_Deadline_Pragma (P); 19698 end Relative_Deadline; 19699 19700 ------------------------ 19701 -- Remote_Access_Type -- 19702 ------------------------ 19703 19704 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME); 19705 19706 when Pragma_Remote_Access_Type => Remote_Access_Type : declare 19707 E : Entity_Id; 19708 19709 begin 19710 GNAT_Pragma; 19711 Check_Arg_Count (1); 19712 Check_Optional_Identifier (Arg1, Name_Entity); 19713 Check_Arg_Is_Local_Name (Arg1); 19714 19715 E := Entity (Get_Pragma_Arg (Arg1)); 19716 19717 -- A pragma that applies to a Ghost entity becomes Ghost for the 19718 -- purposes of legality checks and removal of ignored Ghost code. 19719 19720 Mark_Pragma_As_Ghost (N, E); 19721 19722 if Nkind (Parent (E)) = N_Formal_Type_Declaration 19723 and then Ekind (E) = E_General_Access_Type 19724 and then Is_Class_Wide_Type (Directly_Designated_Type (E)) 19725 and then Scope (Root_Type (Directly_Designated_Type (E))) 19726 = Scope (E) 19727 and then Is_Valid_Remote_Object_Type 19728 (Root_Type (Directly_Designated_Type (E))) 19729 then 19730 Set_Is_Remote_Types (E); 19731 19732 else 19733 Error_Pragma_Arg 19734 ("pragma% applies only to formal access to classwide types", 19735 Arg1); 19736 end if; 19737 end Remote_Access_Type; 19738 19739 --------------------------- 19740 -- Remote_Call_Interface -- 19741 --------------------------- 19742 19743 -- pragma Remote_Call_Interface [(library_unit_NAME)]; 19744 19745 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare 19746 Cunit_Node : Node_Id; 19747 Cunit_Ent : Entity_Id; 19748 K : Node_Kind; 19749 19750 begin 19751 Check_Ada_83_Warning; 19752 Check_Valid_Library_Unit_Pragma; 19753 19754 if Nkind (N) = N_Null_Statement then 19755 return; 19756 end if; 19757 19758 Cunit_Node := Cunit (Current_Sem_Unit); 19759 K := Nkind (Unit (Cunit_Node)); 19760 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 19761 19762 -- A pragma that applies to a Ghost entity becomes Ghost for the 19763 -- purposes of legality checks and removal of ignored Ghost code. 19764 19765 Mark_Pragma_As_Ghost (N, Cunit_Ent); 19766 19767 if K = N_Package_Declaration 19768 or else K = N_Generic_Package_Declaration 19769 or else K = N_Subprogram_Declaration 19770 or else K = N_Generic_Subprogram_Declaration 19771 or else (K = N_Subprogram_Body 19772 and then Acts_As_Spec (Unit (Cunit_Node))) 19773 then 19774 null; 19775 else 19776 Error_Pragma ( 19777 "pragma% must apply to package or subprogram declaration"); 19778 end if; 19779 19780 Set_Is_Remote_Call_Interface (Cunit_Ent); 19781 end Remote_Call_Interface; 19782 19783 ------------------ 19784 -- Remote_Types -- 19785 ------------------ 19786 19787 -- pragma Remote_Types [(library_unit_NAME)]; 19788 19789 when Pragma_Remote_Types => Remote_Types : declare 19790 Cunit_Node : Node_Id; 19791 Cunit_Ent : Entity_Id; 19792 19793 begin 19794 Check_Ada_83_Warning; 19795 Check_Valid_Library_Unit_Pragma; 19796 19797 if Nkind (N) = N_Null_Statement then 19798 return; 19799 end if; 19800 19801 Cunit_Node := Cunit (Current_Sem_Unit); 19802 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 19803 19804 -- A pragma that applies to a Ghost entity becomes Ghost for the 19805 -- purposes of legality checks and removal of ignored Ghost code. 19806 19807 Mark_Pragma_As_Ghost (N, Cunit_Ent); 19808 19809 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 19810 N_Generic_Package_Declaration) 19811 then 19812 Error_Pragma 19813 ("pragma% can only apply to a package declaration"); 19814 end if; 19815 19816 Set_Is_Remote_Types (Cunit_Ent); 19817 end Remote_Types; 19818 19819 --------------- 19820 -- Ravenscar -- 19821 --------------- 19822 19823 -- pragma Ravenscar; 19824 19825 when Pragma_Ravenscar => 19826 GNAT_Pragma; 19827 Check_Arg_Count (0); 19828 Check_Valid_Configuration_Pragma; 19829 Set_Ravenscar_Profile (Ravenscar, N); 19830 19831 if Warn_On_Obsolescent_Feature then 19832 Error_Msg_N 19833 ("pragma Ravenscar is an obsolescent feature?j?", N); 19834 Error_Msg_N 19835 ("|use pragma Profile (Ravenscar) instead?j?", N); 19836 end if; 19837 19838 ------------------------- 19839 -- Restricted_Run_Time -- 19840 ------------------------- 19841 19842 -- pragma Restricted_Run_Time; 19843 19844 when Pragma_Restricted_Run_Time => 19845 GNAT_Pragma; 19846 Check_Arg_Count (0); 19847 Check_Valid_Configuration_Pragma; 19848 Set_Profile_Restrictions 19849 (Restricted, N, Warn => Treat_Restrictions_As_Warnings); 19850 19851 if Warn_On_Obsolescent_Feature then 19852 Error_Msg_N 19853 ("pragma Restricted_Run_Time is an obsolescent feature?j?", 19854 N); 19855 Error_Msg_N 19856 ("|use pragma Profile (Restricted) instead?j?", N); 19857 end if; 19858 19859 ------------------ 19860 -- Restrictions -- 19861 ------------------ 19862 19863 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 19864 19865 -- RESTRICTION ::= 19866 -- restriction_IDENTIFIER 19867 -- | restriction_parameter_IDENTIFIER => EXPRESSION 19868 19869 when Pragma_Restrictions => 19870 Process_Restrictions_Or_Restriction_Warnings 19871 (Warn => Treat_Restrictions_As_Warnings); 19872 19873 -------------------------- 19874 -- Restriction_Warnings -- 19875 -------------------------- 19876 19877 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 19878 19879 -- RESTRICTION ::= 19880 -- restriction_IDENTIFIER 19881 -- | restriction_parameter_IDENTIFIER => EXPRESSION 19882 19883 when Pragma_Restriction_Warnings => 19884 GNAT_Pragma; 19885 Process_Restrictions_Or_Restriction_Warnings (Warn => True); 19886 19887 ---------------- 19888 -- Reviewable -- 19889 ---------------- 19890 19891 -- pragma Reviewable; 19892 19893 when Pragma_Reviewable => 19894 Check_Ada_83_Warning; 19895 Check_Arg_Count (0); 19896 19897 -- Call dummy debugging function rv. This is done to assist front 19898 -- end debugging. By placing a Reviewable pragma in the source 19899 -- program, a breakpoint on rv catches this place in the source, 19900 -- allowing convenient stepping to the point of interest. 19901 19902 rv; 19903 19904 -------------------------- 19905 -- Short_Circuit_And_Or -- 19906 -------------------------- 19907 19908 -- pragma Short_Circuit_And_Or; 19909 19910 when Pragma_Short_Circuit_And_Or => 19911 GNAT_Pragma; 19912 Check_Arg_Count (0); 19913 Check_Valid_Configuration_Pragma; 19914 Short_Circuit_And_Or := True; 19915 19916 ------------------- 19917 -- Share_Generic -- 19918 ------------------- 19919 19920 -- pragma Share_Generic (GNAME {, GNAME}); 19921 19922 -- GNAME ::= generic_unit_NAME | generic_instance_NAME 19923 19924 when Pragma_Share_Generic => 19925 GNAT_Pragma; 19926 Process_Generic_List; 19927 19928 ------------ 19929 -- Shared -- 19930 ------------ 19931 19932 -- pragma Shared (LOCAL_NAME); 19933 19934 when Pragma_Shared => 19935 GNAT_Pragma; 19936 Process_Atomic_Independent_Shared_Volatile; 19937 19938 -------------------- 19939 -- Shared_Passive -- 19940 -------------------- 19941 19942 -- pragma Shared_Passive [(library_unit_NAME)]; 19943 19944 -- Set the flag Is_Shared_Passive of program unit name entity 19945 19946 when Pragma_Shared_Passive => Shared_Passive : declare 19947 Cunit_Node : Node_Id; 19948 Cunit_Ent : Entity_Id; 19949 19950 begin 19951 Check_Ada_83_Warning; 19952 Check_Valid_Library_Unit_Pragma; 19953 19954 if Nkind (N) = N_Null_Statement then 19955 return; 19956 end if; 19957 19958 Cunit_Node := Cunit (Current_Sem_Unit); 19959 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 19960 19961 -- A pragma that applies to a Ghost entity becomes Ghost for the 19962 -- purposes of legality checks and removal of ignored Ghost code. 19963 19964 Mark_Pragma_As_Ghost (N, Cunit_Ent); 19965 19966 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 19967 N_Generic_Package_Declaration) 19968 then 19969 Error_Pragma 19970 ("pragma% can only apply to a package declaration"); 19971 end if; 19972 19973 Set_Is_Shared_Passive (Cunit_Ent); 19974 end Shared_Passive; 19975 19976 ----------------------- 19977 -- Short_Descriptors -- 19978 ----------------------- 19979 19980 -- pragma Short_Descriptors; 19981 19982 -- Recognize and validate, but otherwise ignore 19983 19984 when Pragma_Short_Descriptors => 19985 GNAT_Pragma; 19986 Check_Arg_Count (0); 19987 Check_Valid_Configuration_Pragma; 19988 19989 ------------------------------ 19990 -- Simple_Storage_Pool_Type -- 19991 ------------------------------ 19992 19993 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME); 19994 19995 when Pragma_Simple_Storage_Pool_Type => 19996 Simple_Storage_Pool_Type : declare 19997 Typ : Entity_Id; 19998 Type_Id : Node_Id; 19999 20000 begin 20001 GNAT_Pragma; 20002 Check_Arg_Count (1); 20003 Check_Arg_Is_Library_Level_Local_Name (Arg1); 20004 20005 Type_Id := Get_Pragma_Arg (Arg1); 20006 Find_Type (Type_Id); 20007 Typ := Entity (Type_Id); 20008 20009 if Typ = Any_Type then 20010 return; 20011 end if; 20012 20013 -- A pragma that applies to a Ghost entity becomes Ghost for the 20014 -- purposes of legality checks and removal of ignored Ghost code. 20015 20016 Mark_Pragma_As_Ghost (N, Typ); 20017 20018 -- We require the pragma to apply to a type declared in a package 20019 -- declaration, but not (immediately) within a package body. 20020 20021 if Ekind (Current_Scope) /= E_Package 20022 or else In_Package_Body (Current_Scope) 20023 then 20024 Error_Pragma 20025 ("pragma% can only apply to type declared immediately " 20026 & "within a package declaration"); 20027 end if; 20028 20029 -- A simple storage pool type must be an immutably limited record 20030 -- or private type. If the pragma is given for a private type, 20031 -- the full type is similarly restricted (which is checked later 20032 -- in Freeze_Entity). 20033 20034 if Is_Record_Type (Typ) 20035 and then not Is_Limited_View (Typ) 20036 then 20037 Error_Pragma 20038 ("pragma% can only apply to explicitly limited record type"); 20039 20040 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then 20041 Error_Pragma 20042 ("pragma% can only apply to a private type that is limited"); 20043 20044 elsif not Is_Record_Type (Typ) 20045 and then not Is_Private_Type (Typ) 20046 then 20047 Error_Pragma 20048 ("pragma% can only apply to limited record or private type"); 20049 end if; 20050 20051 Record_Rep_Item (Typ, N); 20052 end Simple_Storage_Pool_Type; 20053 20054 ---------------------- 20055 -- Source_File_Name -- 20056 ---------------------- 20057 20058 -- There are five forms for this pragma: 20059 20060 -- pragma Source_File_Name ( 20061 -- [UNIT_NAME =>] unit_NAME, 20062 -- BODY_FILE_NAME => STRING_LITERAL 20063 -- [, [INDEX =>] INTEGER_LITERAL]); 20064 20065 -- pragma Source_File_Name ( 20066 -- [UNIT_NAME =>] unit_NAME, 20067 -- SPEC_FILE_NAME => STRING_LITERAL 20068 -- [, [INDEX =>] INTEGER_LITERAL]); 20069 20070 -- pragma Source_File_Name ( 20071 -- BODY_FILE_NAME => STRING_LITERAL 20072 -- [, DOT_REPLACEMENT => STRING_LITERAL] 20073 -- [, CASING => CASING_SPEC]); 20074 20075 -- pragma Source_File_Name ( 20076 -- SPEC_FILE_NAME => STRING_LITERAL 20077 -- [, DOT_REPLACEMENT => STRING_LITERAL] 20078 -- [, CASING => CASING_SPEC]); 20079 20080 -- pragma Source_File_Name ( 20081 -- SUBUNIT_FILE_NAME => STRING_LITERAL 20082 -- [, DOT_REPLACEMENT => STRING_LITERAL] 20083 -- [, CASING => CASING_SPEC]); 20084 20085 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 20086 20087 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 20088 -- Source_File_Name (SFN), however their usage is exclusive: SFN can 20089 -- only be used when no project file is used, while SFNP can only be 20090 -- used when a project file is used. 20091 20092 -- No processing here. Processing was completed during parsing, since 20093 -- we need to have file names set as early as possible. Units are 20094 -- loaded well before semantic processing starts. 20095 20096 -- The only processing we defer to this point is the check for 20097 -- correct placement. 20098 20099 when Pragma_Source_File_Name => 20100 GNAT_Pragma; 20101 Check_Valid_Configuration_Pragma; 20102 20103 ------------------------------ 20104 -- Source_File_Name_Project -- 20105 ------------------------------ 20106 20107 -- See Source_File_Name for syntax 20108 20109 -- No processing here. Processing was completed during parsing, since 20110 -- we need to have file names set as early as possible. Units are 20111 -- loaded well before semantic processing starts. 20112 20113 -- The only processing we defer to this point is the check for 20114 -- correct placement. 20115 20116 when Pragma_Source_File_Name_Project => 20117 GNAT_Pragma; 20118 Check_Valid_Configuration_Pragma; 20119 20120 -- Check that a pragma Source_File_Name_Project is used only in a 20121 -- configuration pragmas file. 20122 20123 -- Pragmas Source_File_Name_Project should only be generated by 20124 -- the Project Manager in configuration pragmas files. 20125 20126 -- This is really an ugly test. It seems to depend on some 20127 -- accidental and undocumented property. At the very least it 20128 -- needs to be documented, but it would be better to have a 20129 -- clean way of testing if we are in a configuration file??? 20130 20131 if Present (Parent (N)) then 20132 Error_Pragma 20133 ("pragma% can only appear in a configuration pragmas file"); 20134 end if; 20135 20136 ---------------------- 20137 -- Source_Reference -- 20138 ---------------------- 20139 20140 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); 20141 20142 -- Nothing to do, all processing completed in Par.Prag, since we need 20143 -- the information for possible parser messages that are output. 20144 20145 when Pragma_Source_Reference => 20146 GNAT_Pragma; 20147 20148 ---------------- 20149 -- SPARK_Mode -- 20150 ---------------- 20151 20152 -- pragma SPARK_Mode [(On | Off)]; 20153 20154 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare 20155 Mode_Id : SPARK_Mode_Type; 20156 20157 procedure Check_Pragma_Conformance 20158 (Context_Pragma : Node_Id; 20159 Entity : Entity_Id; 20160 Entity_Pragma : Node_Id); 20161 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode 20162 -- conformance of pragma N depending the following scenarios: 20163 -- 20164 -- If pragma Context_Pragma is not Empty, verify that pragma N is 20165 -- compatible with the pragma Context_Pragma that was inherited 20166 -- from the context: 20167 -- * If the mode of Context_Pragma is ON, then the new mode can 20168 -- be anything. 20169 -- * If the mode of Context_Pragma is OFF, then the only allowed 20170 -- new mode is also OFF. Emit error if this is not the case. 20171 -- 20172 -- If Entity is not Empty, verify that pragma N is compatible with 20173 -- pragma Entity_Pragma that belongs to Entity. 20174 -- * If Entity_Pragma is Empty, always issue an error as this 20175 -- corresponds to the case where a previous section of Entity 20176 -- has no SPARK_Mode set. 20177 -- * If the mode of Entity_Pragma is ON, then the new mode can 20178 -- be anything. 20179 -- * If the mode of Entity_Pragma is OFF, then the only allowed 20180 -- new mode is also OFF. Emit error if this is not the case. 20181 20182 procedure Check_Library_Level_Entity (E : Entity_Id); 20183 -- Subsidiary to routines Process_xxx. Verify that the related 20184 -- entity E subject to pragma SPARK_Mode is library-level. 20185 20186 procedure Process_Body (Decl : Node_Id); 20187 -- Verify the legality of pragma SPARK_Mode when it appears as the 20188 -- top of the body declarations of entry, package, protected unit, 20189 -- subprogram or task unit body denoted by Decl. 20190 20191 procedure Process_Overloadable (Decl : Node_Id); 20192 -- Verify the legality of pragma SPARK_Mode when it applies to an 20193 -- entry or [generic] subprogram declaration denoted by Decl. 20194 20195 procedure Process_Private_Part (Decl : Node_Id); 20196 -- Verify the legality of pragma SPARK_Mode when it appears at the 20197 -- top of the private declarations of a package spec, protected or 20198 -- task unit declaration denoted by Decl. 20199 20200 procedure Process_Statement_Part (Decl : Node_Id); 20201 -- Verify the legality of pragma SPARK_Mode when it appears at the 20202 -- top of the statement sequence of a package body denoted by node 20203 -- Decl. 20204 20205 procedure Process_Visible_Part (Decl : Node_Id); 20206 -- Verify the legality of pragma SPARK_Mode when it appears at the 20207 -- top of the visible declarations of a package spec, protected or 20208 -- task unit declaration denoted by Decl. The routine is also used 20209 -- on protected or task units declared without a definition. 20210 20211 procedure Set_SPARK_Context; 20212 -- Subsidiary to routines Process_xxx. Set the global variables 20213 -- which represent the mode of the context from pragma N. Ensure 20214 -- that Dynamic_Elaboration_Checks are off if the new mode is On. 20215 20216 ------------------------------ 20217 -- Check_Pragma_Conformance -- 20218 ------------------------------ 20219 20220 procedure Check_Pragma_Conformance 20221 (Context_Pragma : Node_Id; 20222 Entity : Entity_Id; 20223 Entity_Pragma : Node_Id) 20224 is 20225 Err_Id : Entity_Id; 20226 Err_N : Node_Id; 20227 20228 begin 20229 -- The current pragma may appear without an argument. If this 20230 -- is the case, associate all error messages with the pragma 20231 -- itself. 20232 20233 if Present (Arg1) then 20234 Err_N := Arg1; 20235 else 20236 Err_N := N; 20237 end if; 20238 20239 -- The mode of the current pragma is compared against that of 20240 -- an enclosing context. 20241 20242 if Present (Context_Pragma) then 20243 pragma Assert (Nkind (Context_Pragma) = N_Pragma); 20244 20245 -- Issue an error if the new mode is less restrictive than 20246 -- that of the context. 20247 20248 if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off 20249 and then Get_SPARK_Mode_From_Pragma (N) = On 20250 then 20251 Error_Msg_N 20252 ("cannot change SPARK_Mode from Off to On", Err_N); 20253 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); 20254 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N); 20255 raise Pragma_Exit; 20256 end if; 20257 end if; 20258 20259 -- The mode of the current pragma is compared against that of 20260 -- an initial package, protected type, subprogram or task type 20261 -- declaration. 20262 20263 if Present (Entity) then 20264 20265 -- A simple protected or task type is transformed into an 20266 -- anonymous type whose name cannot be used to issue error 20267 -- messages. Recover the original entity of the type. 20268 20269 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then 20270 Err_Id := 20271 Defining_Entity 20272 (Original_Node (Unit_Declaration_Node (Entity))); 20273 else 20274 Err_Id := Entity; 20275 end if; 20276 20277 -- Both the initial declaration and the completion carry 20278 -- SPARK_Mode pragmas. 20279 20280 if Present (Entity_Pragma) then 20281 pragma Assert (Nkind (Entity_Pragma) = N_Pragma); 20282 20283 -- Issue an error if the new mode is less restrictive 20284 -- than that of the initial declaration. 20285 20286 if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off 20287 and then Get_SPARK_Mode_From_Pragma (N) = On 20288 then 20289 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); 20290 Error_Msg_Sloc := Sloc (Entity_Pragma); 20291 Error_Msg_NE 20292 ("\value Off was set for SPARK_Mode on&#", 20293 Err_N, Err_Id); 20294 raise Pragma_Exit; 20295 end if; 20296 20297 -- Otherwise the initial declaration lacks a SPARK_Mode 20298 -- pragma in which case the current pragma is illegal as 20299 -- it cannot "complete". 20300 20301 else 20302 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); 20303 Error_Msg_Sloc := Sloc (Err_Id); 20304 Error_Msg_NE 20305 ("\no value was set for SPARK_Mode on&#", 20306 Err_N, Err_Id); 20307 raise Pragma_Exit; 20308 end if; 20309 end if; 20310 end Check_Pragma_Conformance; 20311 20312 -------------------------------- 20313 -- Check_Library_Level_Entity -- 20314 -------------------------------- 20315 20316 procedure Check_Library_Level_Entity (E : Entity_Id) is 20317 procedure Add_Entity_To_Name_Buffer; 20318 -- Add the E_Kind of entity E to the name buffer 20319 20320 ------------------------------- 20321 -- Add_Entity_To_Name_Buffer -- 20322 ------------------------------- 20323 20324 procedure Add_Entity_To_Name_Buffer is 20325 begin 20326 if Ekind_In (E, E_Entry, E_Entry_Family) then 20327 Add_Str_To_Name_Buffer ("entry"); 20328 20329 elsif Ekind_In (E, E_Generic_Package, 20330 E_Package, 20331 E_Package_Body) 20332 then 20333 Add_Str_To_Name_Buffer ("package"); 20334 20335 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then 20336 Add_Str_To_Name_Buffer ("protected type"); 20337 20338 elsif Ekind_In (E, E_Function, 20339 E_Generic_Function, 20340 E_Generic_Procedure, 20341 E_Procedure, 20342 E_Subprogram_Body) 20343 then 20344 Add_Str_To_Name_Buffer ("subprogram"); 20345 20346 else 20347 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type)); 20348 Add_Str_To_Name_Buffer ("task type"); 20349 end if; 20350 end Add_Entity_To_Name_Buffer; 20351 20352 -- Local variables 20353 20354 Msg_1 : constant String := "incorrect placement of pragma%"; 20355 Msg_2 : Name_Id; 20356 20357 -- Start of processing for Check_Library_Level_Entity 20358 20359 begin 20360 if not Is_Library_Level_Entity (E) then 20361 Error_Msg_Name_1 := Pname; 20362 Error_Msg_N (Fix_Error (Msg_1), N); 20363 20364 Name_Len := 0; 20365 Add_Str_To_Name_Buffer ("\& is not a library-level "); 20366 Add_Entity_To_Name_Buffer; 20367 20368 Msg_2 := Name_Find; 20369 Error_Msg_NE (Get_Name_String (Msg_2), N, E); 20370 20371 raise Pragma_Exit; 20372 end if; 20373 end Check_Library_Level_Entity; 20374 20375 ------------------ 20376 -- Process_Body -- 20377 ------------------ 20378 20379 procedure Process_Body (Decl : Node_Id) is 20380 Body_Id : constant Entity_Id := Defining_Entity (Decl); 20381 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); 20382 20383 begin 20384 -- Ignore pragma when applied to the special body created for 20385 -- inlining, recognized by its internal name _Parent. 20386 20387 if Chars (Body_Id) = Name_uParent then 20388 return; 20389 end if; 20390 20391 Check_Library_Level_Entity (Body_Id); 20392 20393 -- For entry bodies, verify the legality against: 20394 -- * The mode of the context 20395 -- * The mode of the spec (if any) 20396 20397 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then 20398 20399 -- A stand alone subprogram body 20400 20401 if Body_Id = Spec_Id then 20402 Check_Pragma_Conformance 20403 (Context_Pragma => SPARK_Pragma (Body_Id), 20404 Entity => Empty, 20405 Entity_Pragma => Empty); 20406 20407 -- An entry or subprogram body that completes a previous 20408 -- declaration. 20409 20410 else 20411 Check_Pragma_Conformance 20412 (Context_Pragma => SPARK_Pragma (Body_Id), 20413 Entity => Spec_Id, 20414 Entity_Pragma => SPARK_Pragma (Spec_Id)); 20415 end if; 20416 20417 Set_SPARK_Context; 20418 Set_SPARK_Pragma (Body_Id, N); 20419 Set_SPARK_Pragma_Inherited (Body_Id, False); 20420 20421 -- For package bodies, verify the legality against: 20422 -- * The mode of the context 20423 -- * The mode of the private part 20424 20425 -- This case is separated from protected and task bodies 20426 -- because the statement part of the package body inherits 20427 -- the mode of the body declarations. 20428 20429 elsif Nkind (Decl) = N_Package_Body then 20430 Check_Pragma_Conformance 20431 (Context_Pragma => SPARK_Pragma (Body_Id), 20432 Entity => Spec_Id, 20433 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); 20434 20435 Set_SPARK_Context; 20436 Set_SPARK_Pragma (Body_Id, N); 20437 Set_SPARK_Pragma_Inherited (Body_Id, False); 20438 Set_SPARK_Aux_Pragma (Body_Id, N); 20439 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); 20440 20441 -- For protected and task bodies, verify the legality against: 20442 -- * The mode of the context 20443 -- * The mode of the private part 20444 20445 else 20446 pragma Assert 20447 (Nkind_In (Decl, N_Protected_Body, N_Task_Body)); 20448 20449 Check_Pragma_Conformance 20450 (Context_Pragma => SPARK_Pragma (Body_Id), 20451 Entity => Spec_Id, 20452 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); 20453 20454 Set_SPARK_Context; 20455 Set_SPARK_Pragma (Body_Id, N); 20456 Set_SPARK_Pragma_Inherited (Body_Id, False); 20457 end if; 20458 end Process_Body; 20459 20460 -------------------------- 20461 -- Process_Overloadable -- 20462 -------------------------- 20463 20464 procedure Process_Overloadable (Decl : Node_Id) is 20465 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 20466 Spec_Typ : constant Entity_Id := Etype (Spec_Id); 20467 20468 begin 20469 Check_Library_Level_Entity (Spec_Id); 20470 20471 -- Verify the legality against: 20472 -- * The mode of the context 20473 20474 Check_Pragma_Conformance 20475 (Context_Pragma => SPARK_Pragma (Spec_Id), 20476 Entity => Empty, 20477 Entity_Pragma => Empty); 20478 20479 Set_SPARK_Pragma (Spec_Id, N); 20480 Set_SPARK_Pragma_Inherited (Spec_Id, False); 20481 20482 -- When the pragma applies to the anonymous object created for 20483 -- a single task type, decorate the type as well. This scenario 20484 -- arises when the single task type lacks a task definition, 20485 -- therefore there is no issue with respect to a potential 20486 -- pragma SPARK_Mode in the private part. 20487 20488 -- task type Anon_Task_Typ; 20489 -- Obj : Anon_Task_Typ; 20490 -- pragma SPARK_Mode ...; 20491 20492 if Is_Single_Task_Object (Spec_Id) then 20493 Set_SPARK_Pragma (Spec_Typ, N); 20494 Set_SPARK_Pragma_Inherited (Spec_Typ, False); 20495 Set_SPARK_Aux_Pragma (Spec_Typ, N); 20496 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True); 20497 end if; 20498 end Process_Overloadable; 20499 20500 -------------------------- 20501 -- Process_Private_Part -- 20502 -------------------------- 20503 20504 procedure Process_Private_Part (Decl : Node_Id) is 20505 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 20506 20507 begin 20508 Check_Library_Level_Entity (Spec_Id); 20509 20510 -- Verify the legality against: 20511 -- * The mode of the visible declarations 20512 20513 Check_Pragma_Conformance 20514 (Context_Pragma => Empty, 20515 Entity => Spec_Id, 20516 Entity_Pragma => SPARK_Pragma (Spec_Id)); 20517 20518 Set_SPARK_Context; 20519 Set_SPARK_Aux_Pragma (Spec_Id, N); 20520 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); 20521 end Process_Private_Part; 20522 20523 ---------------------------- 20524 -- Process_Statement_Part -- 20525 ---------------------------- 20526 20527 procedure Process_Statement_Part (Decl : Node_Id) is 20528 Body_Id : constant Entity_Id := Defining_Entity (Decl); 20529 20530 begin 20531 Check_Library_Level_Entity (Body_Id); 20532 20533 -- Verify the legality against: 20534 -- * The mode of the body declarations 20535 20536 Check_Pragma_Conformance 20537 (Context_Pragma => Empty, 20538 Entity => Body_Id, 20539 Entity_Pragma => SPARK_Pragma (Body_Id)); 20540 20541 Set_SPARK_Context; 20542 Set_SPARK_Aux_Pragma (Body_Id, N); 20543 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); 20544 end Process_Statement_Part; 20545 20546 -------------------------- 20547 -- Process_Visible_Part -- 20548 -------------------------- 20549 20550 procedure Process_Visible_Part (Decl : Node_Id) is 20551 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 20552 Obj_Id : Entity_Id; 20553 20554 begin 20555 Check_Library_Level_Entity (Spec_Id); 20556 20557 -- Verify the legality against: 20558 -- * The mode of the context 20559 20560 Check_Pragma_Conformance 20561 (Context_Pragma => SPARK_Pragma (Spec_Id), 20562 Entity => Empty, 20563 Entity_Pragma => Empty); 20564 20565 -- A task unit declared without a definition does not set the 20566 -- SPARK_Mode of the context because the task does not have any 20567 -- entries that could inherit the mode. 20568 20569 if not Nkind_In (Decl, N_Single_Task_Declaration, 20570 N_Task_Type_Declaration) 20571 then 20572 Set_SPARK_Context; 20573 end if; 20574 20575 Set_SPARK_Pragma (Spec_Id, N); 20576 Set_SPARK_Pragma_Inherited (Spec_Id, False); 20577 Set_SPARK_Aux_Pragma (Spec_Id, N); 20578 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); 20579 20580 -- When the pragma applies to a single protected or task type, 20581 -- decorate the corresponding anonymous object as well. 20582 20583 -- protected Anon_Prot_Typ is 20584 -- pragma SPARK_Mode ...; 20585 -- ... 20586 -- end Anon_Prot_Typ; 20587 20588 -- Obj : Anon_Prot_Typ; 20589 20590 if Is_Single_Concurrent_Type (Spec_Id) then 20591 Obj_Id := Anonymous_Object (Spec_Id); 20592 20593 Set_SPARK_Pragma (Obj_Id, N); 20594 Set_SPARK_Pragma_Inherited (Obj_Id, False); 20595 end if; 20596 end Process_Visible_Part; 20597 20598 ----------------------- 20599 -- Set_SPARK_Context -- 20600 ----------------------- 20601 20602 procedure Set_SPARK_Context is 20603 begin 20604 SPARK_Mode := Mode_Id; 20605 SPARK_Mode_Pragma := N; 20606 20607 if SPARK_Mode = On then 20608 Dynamic_Elaboration_Checks := False; 20609 end if; 20610 end Set_SPARK_Context; 20611 20612 -- Local variables 20613 20614 Context : Node_Id; 20615 Mode : Name_Id; 20616 Stmt : Node_Id; 20617 20618 -- Start of processing for Do_SPARK_Mode 20619 20620 begin 20621 -- When a SPARK_Mode pragma appears inside an instantiation whose 20622 -- enclosing context has SPARK_Mode set to "off", the pragma has 20623 -- no semantic effect. 20624 20625 if Ignore_Pragma_SPARK_Mode then 20626 Rewrite (N, Make_Null_Statement (Loc)); 20627 Analyze (N); 20628 return; 20629 end if; 20630 20631 GNAT_Pragma; 20632 Check_No_Identifiers; 20633 Check_At_Most_N_Arguments (1); 20634 20635 -- Check the legality of the mode (no argument = ON) 20636 20637 if Arg_Count = 1 then 20638 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 20639 Mode := Chars (Get_Pragma_Arg (Arg1)); 20640 else 20641 Mode := Name_On; 20642 end if; 20643 20644 Mode_Id := Get_SPARK_Mode_Type (Mode); 20645 Context := Parent (N); 20646 20647 -- The pragma appears in a configuration pragmas file 20648 20649 if No (Context) then 20650 Check_Valid_Configuration_Pragma; 20651 20652 if Present (SPARK_Mode_Pragma) then 20653 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); 20654 Error_Msg_N ("pragma% duplicates pragma declared#", N); 20655 raise Pragma_Exit; 20656 end if; 20657 20658 Set_SPARK_Context; 20659 20660 -- The pragma acts as a configuration pragma in a compilation unit 20661 20662 -- pragma SPARK_Mode ...; 20663 -- package Pack is ...; 20664 20665 elsif Nkind (Context) = N_Compilation_Unit 20666 and then List_Containing (N) = Context_Items (Context) 20667 then 20668 Check_Valid_Configuration_Pragma; 20669 Set_SPARK_Context; 20670 20671 -- Otherwise the placement of the pragma within the tree dictates 20672 -- its associated construct. Inspect the declarative list where 20673 -- the pragma resides to find a potential construct. 20674 20675 else 20676 Stmt := Prev (N); 20677 while Present (Stmt) loop 20678 20679 -- Skip prior pragmas, but check for duplicates. Note that 20680 -- this also takes care of pragmas generated for aspects. 20681 20682 if Nkind (Stmt) = N_Pragma then 20683 if Pragma_Name (Stmt) = Pname then 20684 Error_Msg_Name_1 := Pname; 20685 Error_Msg_Sloc := Sloc (Stmt); 20686 Error_Msg_N ("pragma% duplicates pragma declared#", N); 20687 raise Pragma_Exit; 20688 end if; 20689 20690 -- The pragma applies to an expression function that has 20691 -- already been rewritten into a subprogram declaration. 20692 20693 -- function Expr_Func return ... is (...); 20694 -- pragma SPARK_Mode ...; 20695 20696 elsif Nkind (Stmt) = N_Subprogram_Declaration 20697 and then Nkind (Original_Node (Stmt)) = 20698 N_Expression_Function 20699 then 20700 Process_Overloadable (Stmt); 20701 return; 20702 20703 -- The pragma applies to the anonymous object created for a 20704 -- single concurrent type. 20705 20706 -- protected type Anon_Prot_Typ ...; 20707 -- Obj : Anon_Prot_Typ; 20708 -- pragma SPARK_Mode ...; 20709 20710 elsif Nkind (Stmt) = N_Object_Declaration 20711 and then Is_Single_Concurrent_Object 20712 (Defining_Entity (Stmt)) 20713 then 20714 Process_Overloadable (Stmt); 20715 return; 20716 20717 -- Skip internally generated code 20718 20719 elsif not Comes_From_Source (Stmt) then 20720 null; 20721 20722 -- The pragma applies to an entry or [generic] subprogram 20723 -- declaration. 20724 20725 -- entry Ent ...; 20726 -- pragma SPARK_Mode ...; 20727 20728 -- [generic] 20729 -- procedure Proc ...; 20730 -- pragma SPARK_Mode ...; 20731 20732 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, 20733 N_Subprogram_Declaration) 20734 or else (Nkind (Stmt) = N_Entry_Declaration 20735 and then Is_Protected_Type 20736 (Scope (Defining_Entity (Stmt)))) 20737 then 20738 Process_Overloadable (Stmt); 20739 return; 20740 20741 -- Otherwise the pragma does not apply to a legal construct 20742 -- or it does not appear at the top of a declarative or a 20743 -- statement list. Issue an error and stop the analysis. 20744 20745 else 20746 Pragma_Misplaced; 20747 exit; 20748 end if; 20749 20750 Prev (Stmt); 20751 end loop; 20752 20753 -- The pragma applies to a package or a subprogram that acts as 20754 -- a compilation unit. 20755 20756 -- procedure Proc ...; 20757 -- pragma SPARK_Mode ...; 20758 20759 if Nkind (Context) = N_Compilation_Unit_Aux then 20760 Context := Unit (Parent (Context)); 20761 end if; 20762 20763 -- The pragma appears at the top of entry, package, protected 20764 -- unit, subprogram or task unit body declarations. 20765 20766 -- entry Ent when ... is 20767 -- pragma SPARK_Mode ...; 20768 20769 -- package body Pack is 20770 -- pragma SPARK_Mode ...; 20771 20772 -- procedure Proc ... is 20773 -- pragma SPARK_Mode; 20774 20775 -- protected body Prot is 20776 -- pragma SPARK_Mode ...; 20777 20778 if Nkind_In (Context, N_Entry_Body, 20779 N_Package_Body, 20780 N_Protected_Body, 20781 N_Subprogram_Body, 20782 N_Task_Body) 20783 then 20784 Process_Body (Context); 20785 20786 -- The pragma appears at the top of the visible or private 20787 -- declaration of a package spec, protected or task unit. 20788 20789 -- package Pack is 20790 -- pragma SPARK_Mode ...; 20791 -- private 20792 -- pragma SPARK_Mode ...; 20793 20794 -- protected [type] Prot is 20795 -- pragma SPARK_Mode ...; 20796 -- private 20797 -- pragma SPARK_Mode ...; 20798 20799 elsif Nkind_In (Context, N_Package_Specification, 20800 N_Protected_Definition, 20801 N_Task_Definition) 20802 then 20803 if List_Containing (N) = Visible_Declarations (Context) then 20804 Process_Visible_Part (Parent (Context)); 20805 else 20806 Process_Private_Part (Parent (Context)); 20807 end if; 20808 20809 -- The pragma appears at the top of package body statements 20810 20811 -- package body Pack is 20812 -- begin 20813 -- pragma SPARK_Mode; 20814 20815 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements 20816 and then Nkind (Parent (Context)) = N_Package_Body 20817 then 20818 Process_Statement_Part (Parent (Context)); 20819 20820 -- The pragma appeared as an aspect of a [generic] subprogram 20821 -- declaration that acts as a compilation unit. 20822 20823 -- [generic] 20824 -- procedure Proc ...; 20825 -- pragma SPARK_Mode ...; 20826 20827 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration, 20828 N_Subprogram_Declaration) 20829 then 20830 Process_Overloadable (Context); 20831 20832 -- The pragma does not apply to a legal construct, issue error 20833 20834 else 20835 Pragma_Misplaced; 20836 end if; 20837 end if; 20838 end Do_SPARK_Mode; 20839 20840 -------------------------------- 20841 -- Static_Elaboration_Desired -- 20842 -------------------------------- 20843 20844 -- pragma Static_Elaboration_Desired (DIRECT_NAME); 20845 20846 when Pragma_Static_Elaboration_Desired => 20847 GNAT_Pragma; 20848 Check_At_Most_N_Arguments (1); 20849 20850 if Is_Compilation_Unit (Current_Scope) 20851 and then Ekind (Current_Scope) = E_Package 20852 then 20853 Set_Static_Elaboration_Desired (Current_Scope, True); 20854 else 20855 Error_Pragma ("pragma% must apply to a library-level package"); 20856 end if; 20857 20858 ------------------ 20859 -- Storage_Size -- 20860 ------------------ 20861 20862 -- pragma Storage_Size (EXPRESSION); 20863 20864 when Pragma_Storage_Size => Storage_Size : declare 20865 P : constant Node_Id := Parent (N); 20866 Arg : Node_Id; 20867 20868 begin 20869 Check_No_Identifiers; 20870 Check_Arg_Count (1); 20871 20872 -- The expression must be analyzed in the special manner described 20873 -- in "Handling of Default Expressions" in sem.ads. 20874 20875 Arg := Get_Pragma_Arg (Arg1); 20876 Preanalyze_Spec_Expression (Arg, Any_Integer); 20877 20878 if not Is_OK_Static_Expression (Arg) then 20879 Check_Restriction (Static_Storage_Size, Arg); 20880 end if; 20881 20882 if Nkind (P) /= N_Task_Definition then 20883 Pragma_Misplaced; 20884 return; 20885 20886 else 20887 if Has_Storage_Size_Pragma (P) then 20888 Error_Pragma ("duplicate pragma% not allowed"); 20889 else 20890 Set_Has_Storage_Size_Pragma (P, True); 20891 end if; 20892 20893 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 20894 end if; 20895 end Storage_Size; 20896 20897 ------------------ 20898 -- Storage_Unit -- 20899 ------------------ 20900 20901 -- pragma Storage_Unit (NUMERIC_LITERAL); 20902 20903 -- Only permitted argument is System'Storage_Unit value 20904 20905 when Pragma_Storage_Unit => 20906 Check_No_Identifiers; 20907 Check_Arg_Count (1); 20908 Check_Arg_Is_Integer_Literal (Arg1); 20909 20910 if Intval (Get_Pragma_Arg (Arg1)) /= 20911 UI_From_Int (Ttypes.System_Storage_Unit) 20912 then 20913 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); 20914 Error_Pragma_Arg 20915 ("the only allowed argument for pragma% is ^", Arg1); 20916 end if; 20917 20918 -------------------- 20919 -- Stream_Convert -- 20920 -------------------- 20921 20922 -- pragma Stream_Convert ( 20923 -- [Entity =>] type_LOCAL_NAME, 20924 -- [Read =>] function_NAME, 20925 -- [Write =>] function NAME); 20926 20927 when Pragma_Stream_Convert => Stream_Convert : declare 20928 20929 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); 20930 -- Check that the given argument is the name of a local function 20931 -- of one argument that is not overloaded earlier in the current 20932 -- local scope. A check is also made that the argument is a 20933 -- function with one parameter. 20934 20935 -------------------------------------- 20936 -- Check_OK_Stream_Convert_Function -- 20937 -------------------------------------- 20938 20939 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is 20940 Ent : Entity_Id; 20941 20942 begin 20943 Check_Arg_Is_Local_Name (Arg); 20944 Ent := Entity (Get_Pragma_Arg (Arg)); 20945 20946 if Has_Homonym (Ent) then 20947 Error_Pragma_Arg 20948 ("argument for pragma% may not be overloaded", Arg); 20949 end if; 20950 20951 if Ekind (Ent) /= E_Function 20952 or else No (First_Formal (Ent)) 20953 or else Present (Next_Formal (First_Formal (Ent))) 20954 then 20955 Error_Pragma_Arg 20956 ("argument for pragma% must be function of one argument", 20957 Arg); 20958 end if; 20959 end Check_OK_Stream_Convert_Function; 20960 20961 -- Start of processing for Stream_Convert 20962 20963 begin 20964 GNAT_Pragma; 20965 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write)); 20966 Check_Arg_Count (3); 20967 Check_Optional_Identifier (Arg1, Name_Entity); 20968 Check_Optional_Identifier (Arg2, Name_Read); 20969 Check_Optional_Identifier (Arg3, Name_Write); 20970 Check_Arg_Is_Local_Name (Arg1); 20971 Check_OK_Stream_Convert_Function (Arg2); 20972 Check_OK_Stream_Convert_Function (Arg3); 20973 20974 declare 20975 Typ : constant Entity_Id := 20976 Underlying_Type (Entity (Get_Pragma_Arg (Arg1))); 20977 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2)); 20978 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3)); 20979 20980 begin 20981 Check_First_Subtype (Arg1); 20982 20983 -- Check for too early or too late. Note that we don't enforce 20984 -- the rule about primitive operations in this case, since, as 20985 -- is the case for explicit stream attributes themselves, these 20986 -- restrictions are not appropriate. Note that the chaining of 20987 -- the pragma by Rep_Item_Too_Late is actually the critical 20988 -- processing done for this pragma. 20989 20990 if Rep_Item_Too_Early (Typ, N) 20991 or else 20992 Rep_Item_Too_Late (Typ, N, FOnly => True) 20993 then 20994 return; 20995 end if; 20996 20997 -- Return if previous error 20998 20999 if Etype (Typ) = Any_Type 21000 or else 21001 Etype (Read) = Any_Type 21002 or else 21003 Etype (Write) = Any_Type 21004 then 21005 return; 21006 end if; 21007 21008 -- Error checks 21009 21010 if Underlying_Type (Etype (Read)) /= Typ then 21011 Error_Pragma_Arg 21012 ("incorrect return type for function&", Arg2); 21013 end if; 21014 21015 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then 21016 Error_Pragma_Arg 21017 ("incorrect parameter type for function&", Arg3); 21018 end if; 21019 21020 if Underlying_Type (Etype (First_Formal (Read))) /= 21021 Underlying_Type (Etype (Write)) 21022 then 21023 Error_Pragma_Arg 21024 ("result type of & does not match Read parameter type", 21025 Arg3); 21026 end if; 21027 end; 21028 end Stream_Convert; 21029 21030 ------------------ 21031 -- Style_Checks -- 21032 ------------------ 21033 21034 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 21035 21036 -- This is processed by the parser since some of the style checks 21037 -- take place during source scanning and parsing. This means that 21038 -- we don't need to issue error messages here. 21039 21040 when Pragma_Style_Checks => Style_Checks : declare 21041 A : constant Node_Id := Get_Pragma_Arg (Arg1); 21042 S : String_Id; 21043 C : Char_Code; 21044 21045 begin 21046 GNAT_Pragma; 21047 Check_No_Identifiers; 21048 21049 -- Two argument form 21050 21051 if Arg_Count = 2 then 21052 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 21053 21054 declare 21055 E_Id : Node_Id; 21056 E : Entity_Id; 21057 21058 begin 21059 E_Id := Get_Pragma_Arg (Arg2); 21060 Analyze (E_Id); 21061 21062 if not Is_Entity_Name (E_Id) then 21063 Error_Pragma_Arg 21064 ("second argument of pragma% must be entity name", 21065 Arg2); 21066 end if; 21067 21068 E := Entity (E_Id); 21069 21070 if not Ignore_Style_Checks_Pragmas then 21071 if E = Any_Id then 21072 return; 21073 else 21074 loop 21075 Set_Suppress_Style_Checks 21076 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off); 21077 exit when No (Homonym (E)); 21078 E := Homonym (E); 21079 end loop; 21080 end if; 21081 end if; 21082 end; 21083 21084 -- One argument form 21085 21086 else 21087 Check_Arg_Count (1); 21088 21089 if Nkind (A) = N_String_Literal then 21090 S := Strval (A); 21091 21092 declare 21093 Slen : constant Natural := Natural (String_Length (S)); 21094 Options : String (1 .. Slen); 21095 J : Natural; 21096 21097 begin 21098 J := 1; 21099 loop 21100 C := Get_String_Char (S, Int (J)); 21101 exit when not In_Character_Range (C); 21102 Options (J) := Get_Character (C); 21103 21104 -- If at end of string, set options. As per discussion 21105 -- above, no need to check for errors, since we issued 21106 -- them in the parser. 21107 21108 if J = Slen then 21109 if not Ignore_Style_Checks_Pragmas then 21110 Set_Style_Check_Options (Options); 21111 end if; 21112 21113 exit; 21114 end if; 21115 21116 J := J + 1; 21117 end loop; 21118 end; 21119 21120 elsif Nkind (A) = N_Identifier then 21121 if Chars (A) = Name_All_Checks then 21122 if not Ignore_Style_Checks_Pragmas then 21123 if GNAT_Mode then 21124 Set_GNAT_Style_Check_Options; 21125 else 21126 Set_Default_Style_Check_Options; 21127 end if; 21128 end if; 21129 21130 elsif Chars (A) = Name_On then 21131 if not Ignore_Style_Checks_Pragmas then 21132 Style_Check := True; 21133 end if; 21134 21135 elsif Chars (A) = Name_Off then 21136 if not Ignore_Style_Checks_Pragmas then 21137 Style_Check := False; 21138 end if; 21139 end if; 21140 end if; 21141 end if; 21142 end Style_Checks; 21143 21144 -------------- 21145 -- Subtitle -- 21146 -------------- 21147 21148 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL); 21149 21150 when Pragma_Subtitle => 21151 GNAT_Pragma; 21152 Check_Arg_Count (1); 21153 Check_Optional_Identifier (Arg1, Name_Subtitle); 21154 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 21155 Store_Note (N); 21156 21157 -------------- 21158 -- Suppress -- 21159 -------------- 21160 21161 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); 21162 21163 when Pragma_Suppress => 21164 Process_Suppress_Unsuppress (Suppress_Case => True); 21165 21166 ------------------ 21167 -- Suppress_All -- 21168 ------------------ 21169 21170 -- pragma Suppress_All; 21171 21172 -- The only check made here is that the pragma has no arguments. 21173 -- There are no placement rules, and the processing required (setting 21174 -- the Has_Pragma_Suppress_All flag in the compilation unit node was 21175 -- taken care of by the parser). Process_Compilation_Unit_Pragmas 21176 -- then creates and inserts a pragma Suppress (All_Checks). 21177 21178 when Pragma_Suppress_All => 21179 GNAT_Pragma; 21180 Check_Arg_Count (0); 21181 21182 ------------------------- 21183 -- Suppress_Debug_Info -- 21184 ------------------------- 21185 21186 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME); 21187 21188 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare 21189 Nam_Id : Entity_Id; 21190 21191 begin 21192 GNAT_Pragma; 21193 Check_Arg_Count (1); 21194 Check_Optional_Identifier (Arg1, Name_Entity); 21195 Check_Arg_Is_Local_Name (Arg1); 21196 21197 Nam_Id := Entity (Get_Pragma_Arg (Arg1)); 21198 21199 -- A pragma that applies to a Ghost entity becomes Ghost for the 21200 -- purposes of legality checks and removal of ignored Ghost code. 21201 21202 Mark_Pragma_As_Ghost (N, Nam_Id); 21203 Set_Debug_Info_Off (Nam_Id); 21204 end Suppress_Debug_Info; 21205 21206 ---------------------------------- 21207 -- Suppress_Exception_Locations -- 21208 ---------------------------------- 21209 21210 -- pragma Suppress_Exception_Locations; 21211 21212 when Pragma_Suppress_Exception_Locations => 21213 GNAT_Pragma; 21214 Check_Arg_Count (0); 21215 Check_Valid_Configuration_Pragma; 21216 Exception_Locations_Suppressed := True; 21217 21218 ----------------------------- 21219 -- Suppress_Initialization -- 21220 ----------------------------- 21221 21222 -- pragma Suppress_Initialization ([Entity =>] type_Name); 21223 21224 when Pragma_Suppress_Initialization => Suppress_Init : declare 21225 E : Entity_Id; 21226 E_Id : Node_Id; 21227 21228 begin 21229 GNAT_Pragma; 21230 Check_Arg_Count (1); 21231 Check_Optional_Identifier (Arg1, Name_Entity); 21232 Check_Arg_Is_Local_Name (Arg1); 21233 21234 E_Id := Get_Pragma_Arg (Arg1); 21235 21236 if Etype (E_Id) = Any_Type then 21237 return; 21238 end if; 21239 21240 E := Entity (E_Id); 21241 21242 -- A pragma that applies to a Ghost entity becomes Ghost for the 21243 -- purposes of legality checks and removal of ignored Ghost code. 21244 21245 Mark_Pragma_As_Ghost (N, E); 21246 21247 if not Is_Type (E) and then Ekind (E) /= E_Variable then 21248 Error_Pragma_Arg 21249 ("pragma% requires variable, type or subtype", Arg1); 21250 end if; 21251 21252 if Rep_Item_Too_Early (E, N) 21253 or else 21254 Rep_Item_Too_Late (E, N, FOnly => True) 21255 then 21256 return; 21257 end if; 21258 21259 -- For incomplete/private type, set flag on full view 21260 21261 if Is_Incomplete_Or_Private_Type (E) then 21262 if No (Full_View (Base_Type (E))) then 21263 Error_Pragma_Arg 21264 ("argument of pragma% cannot be an incomplete type", Arg1); 21265 else 21266 Set_Suppress_Initialization (Full_View (Base_Type (E))); 21267 end if; 21268 21269 -- For first subtype, set flag on base type 21270 21271 elsif Is_First_Subtype (E) then 21272 Set_Suppress_Initialization (Base_Type (E)); 21273 21274 -- For other than first subtype, set flag on subtype or variable 21275 21276 else 21277 Set_Suppress_Initialization (E); 21278 end if; 21279 end Suppress_Init; 21280 21281 ----------------- 21282 -- System_Name -- 21283 ----------------- 21284 21285 -- pragma System_Name (DIRECT_NAME); 21286 21287 -- Syntax check: one argument, which must be the identifier GNAT or 21288 -- the identifier GCC, no other identifiers are acceptable. 21289 21290 when Pragma_System_Name => 21291 GNAT_Pragma; 21292 Check_No_Identifiers; 21293 Check_Arg_Count (1); 21294 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); 21295 21296 ----------------------------- 21297 -- Task_Dispatching_Policy -- 21298 ----------------------------- 21299 21300 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER); 21301 21302 when Pragma_Task_Dispatching_Policy => declare 21303 DP : Character; 21304 21305 begin 21306 Check_Ada_83_Warning; 21307 Check_Arg_Count (1); 21308 Check_No_Identifiers; 21309 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 21310 Check_Valid_Configuration_Pragma; 21311 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 21312 DP := Fold_Upper (Name_Buffer (1)); 21313 21314 if Task_Dispatching_Policy /= ' ' 21315 and then Task_Dispatching_Policy /= DP 21316 then 21317 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 21318 Error_Pragma 21319 ("task dispatching policy incompatible with policy#"); 21320 21321 -- Set new policy, but always preserve System_Location since we 21322 -- like the error message with the run time name. 21323 21324 else 21325 Task_Dispatching_Policy := DP; 21326 21327 if Task_Dispatching_Policy_Sloc /= System_Location then 21328 Task_Dispatching_Policy_Sloc := Loc; 21329 end if; 21330 end if; 21331 end; 21332 21333 --------------- 21334 -- Task_Info -- 21335 --------------- 21336 21337 -- pragma Task_Info (EXPRESSION); 21338 21339 when Pragma_Task_Info => Task_Info : declare 21340 P : constant Node_Id := Parent (N); 21341 Ent : Entity_Id; 21342 21343 begin 21344 GNAT_Pragma; 21345 21346 if Warn_On_Obsolescent_Feature then 21347 Error_Msg_N 21348 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U " 21349 & "instead?j?", N); 21350 end if; 21351 21352 if Nkind (P) /= N_Task_Definition then 21353 Error_Pragma ("pragma% must appear in task definition"); 21354 end if; 21355 21356 Check_No_Identifiers; 21357 Check_Arg_Count (1); 21358 21359 Analyze_And_Resolve 21360 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type)); 21361 21362 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then 21363 return; 21364 end if; 21365 21366 Ent := Defining_Identifier (Parent (P)); 21367 21368 -- Check duplicate pragma before we chain the pragma in the Rep 21369 -- Item chain of Ent. 21370 21371 if Has_Rep_Pragma 21372 (Ent, Name_Task_Info, Check_Parents => False) 21373 then 21374 Error_Pragma ("duplicate pragma% not allowed"); 21375 end if; 21376 21377 Record_Rep_Item (Ent, N); 21378 end Task_Info; 21379 21380 --------------- 21381 -- Task_Name -- 21382 --------------- 21383 21384 -- pragma Task_Name (string_EXPRESSION); 21385 21386 when Pragma_Task_Name => Task_Name : declare 21387 P : constant Node_Id := Parent (N); 21388 Arg : Node_Id; 21389 Ent : Entity_Id; 21390 21391 begin 21392 Check_No_Identifiers; 21393 Check_Arg_Count (1); 21394 21395 Arg := Get_Pragma_Arg (Arg1); 21396 21397 -- The expression is used in the call to Create_Task, and must be 21398 -- expanded there, not in the context of the current spec. It must 21399 -- however be analyzed to capture global references, in case it 21400 -- appears in a generic context. 21401 21402 Preanalyze_And_Resolve (Arg, Standard_String); 21403 21404 if Nkind (P) /= N_Task_Definition then 21405 Pragma_Misplaced; 21406 end if; 21407 21408 Ent := Defining_Identifier (Parent (P)); 21409 21410 -- Check duplicate pragma before we chain the pragma in the Rep 21411 -- Item chain of Ent. 21412 21413 if Has_Rep_Pragma 21414 (Ent, Name_Task_Name, Check_Parents => False) 21415 then 21416 Error_Pragma ("duplicate pragma% not allowed"); 21417 end if; 21418 21419 Record_Rep_Item (Ent, N); 21420 end Task_Name; 21421 21422 ------------------ 21423 -- Task_Storage -- 21424 ------------------ 21425 21426 -- pragma Task_Storage ( 21427 -- [Task_Type =>] LOCAL_NAME, 21428 -- [Top_Guard =>] static_integer_EXPRESSION); 21429 21430 when Pragma_Task_Storage => Task_Storage : declare 21431 Args : Args_List (1 .. 2); 21432 Names : constant Name_List (1 .. 2) := ( 21433 Name_Task_Type, 21434 Name_Top_Guard); 21435 21436 Task_Type : Node_Id renames Args (1); 21437 Top_Guard : Node_Id renames Args (2); 21438 21439 Ent : Entity_Id; 21440 21441 begin 21442 GNAT_Pragma; 21443 Gather_Associations (Names, Args); 21444 21445 if No (Task_Type) then 21446 Error_Pragma 21447 ("missing task_type argument for pragma%"); 21448 end if; 21449 21450 Check_Arg_Is_Local_Name (Task_Type); 21451 21452 Ent := Entity (Task_Type); 21453 21454 if not Is_Task_Type (Ent) then 21455 Error_Pragma_Arg 21456 ("argument for pragma% must be task type", Task_Type); 21457 end if; 21458 21459 if No (Top_Guard) then 21460 Error_Pragma_Arg 21461 ("pragma% takes two arguments", Task_Type); 21462 else 21463 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer); 21464 end if; 21465 21466 Check_First_Subtype (Task_Type); 21467 21468 if Rep_Item_Too_Late (Ent, N) then 21469 raise Pragma_Exit; 21470 end if; 21471 end Task_Storage; 21472 21473 --------------- 21474 -- Test_Case -- 21475 --------------- 21476 21477 -- pragma Test_Case 21478 -- ([Name =>] Static_String_EXPRESSION 21479 -- ,[Mode =>] MODE_TYPE 21480 -- [, Requires => Boolean_EXPRESSION] 21481 -- [, Ensures => Boolean_EXPRESSION]); 21482 21483 -- MODE_TYPE ::= Nominal | Robustness 21484 21485 -- Characteristics: 21486 21487 -- * Analysis - The annotation undergoes initial checks to verify 21488 -- the legal placement and context. Secondary checks preanalyze the 21489 -- expressions in: 21490 21491 -- Analyze_Test_Case_In_Decl_Part 21492 21493 -- * Expansion - None. 21494 21495 -- * Template - The annotation utilizes the generic template of the 21496 -- related subprogram when it is: 21497 21498 -- aspect on subprogram declaration 21499 21500 -- The annotation must prepare its own template when it is: 21501 21502 -- pragma on subprogram declaration 21503 21504 -- * Globals - Capture of global references must occur after full 21505 -- analysis. 21506 21507 -- * Instance - The annotation is instantiated automatically when 21508 -- the related generic subprogram is instantiated except for the 21509 -- "pragma on subprogram declaration" case. In that scenario the 21510 -- annotation must instantiate itself. 21511 21512 when Pragma_Test_Case => Test_Case : declare 21513 procedure Check_Distinct_Name (Subp_Id : Entity_Id); 21514 -- Ensure that the contract of subprogram Subp_Id does not contain 21515 -- another Test_Case pragma with the same Name as the current one. 21516 21517 ------------------------- 21518 -- Check_Distinct_Name -- 21519 ------------------------- 21520 21521 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is 21522 Items : constant Node_Id := Contract (Subp_Id); 21523 Name : constant String_Id := Get_Name_From_CTC_Pragma (N); 21524 Prag : Node_Id; 21525 21526 begin 21527 -- Inspect all Test_Case pragma of the related subprogram 21528 -- looking for one with a duplicate "Name" argument. 21529 21530 if Present (Items) then 21531 Prag := Contract_Test_Cases (Items); 21532 while Present (Prag) loop 21533 if Pragma_Name (Prag) = Name_Test_Case 21534 and then Prag /= N 21535 and then String_Equal 21536 (Name, Get_Name_From_CTC_Pragma (Prag)) 21537 then 21538 Error_Msg_Sloc := Sloc (Prag); 21539 Error_Pragma ("name for pragma % is already used #"); 21540 end if; 21541 21542 Prag := Next_Pragma (Prag); 21543 end loop; 21544 end if; 21545 end Check_Distinct_Name; 21546 21547 -- Local variables 21548 21549 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); 21550 Asp_Arg : Node_Id; 21551 Context : Node_Id; 21552 Subp_Decl : Node_Id; 21553 Subp_Id : Entity_Id; 21554 21555 -- Start of processing for Test_Case 21556 21557 begin 21558 GNAT_Pragma; 21559 Check_At_Least_N_Arguments (2); 21560 Check_At_Most_N_Arguments (4); 21561 Check_Arg_Order 21562 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); 21563 21564 -- Argument "Name" 21565 21566 Check_Optional_Identifier (Arg1, Name_Name); 21567 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 21568 21569 -- Argument "Mode" 21570 21571 Check_Optional_Identifier (Arg2, Name_Mode); 21572 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); 21573 21574 -- Arguments "Requires" and "Ensures" 21575 21576 if Present (Arg3) then 21577 if Present (Arg4) then 21578 Check_Identifier (Arg3, Name_Requires); 21579 Check_Identifier (Arg4, Name_Ensures); 21580 else 21581 Check_Identifier_Is_One_Of 21582 (Arg3, Name_Requires, Name_Ensures); 21583 end if; 21584 end if; 21585 21586 -- Pragma Test_Case must be associated with a subprogram declared 21587 -- in a library-level package. First determine whether the current 21588 -- compilation unit is a legal context. 21589 21590 if Nkind_In (Pack_Decl, N_Package_Declaration, 21591 N_Generic_Package_Declaration) 21592 then 21593 null; 21594 21595 -- Otherwise the placement is illegal 21596 21597 else 21598 Pragma_Misplaced; 21599 return; 21600 end if; 21601 21602 Subp_Decl := Find_Related_Declaration_Or_Body (N); 21603 21604 -- Find the enclosing context 21605 21606 Context := Parent (Subp_Decl); 21607 21608 if Present (Context) then 21609 Context := Parent (Context); 21610 end if; 21611 21612 -- Verify the placement of the pragma 21613 21614 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 21615 Error_Pragma 21616 ("pragma % cannot be applied to abstract subprogram"); 21617 return; 21618 21619 elsif Nkind (Subp_Decl) = N_Entry_Declaration then 21620 Error_Pragma ("pragma % cannot be applied to entry"); 21621 return; 21622 21623 -- The context is a [generic] subprogram declared at the top level 21624 -- of the [generic] package unit. 21625 21626 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, 21627 N_Subprogram_Declaration) 21628 and then Present (Context) 21629 and then Nkind_In (Context, N_Generic_Package_Declaration, 21630 N_Package_Declaration) 21631 then 21632 null; 21633 21634 -- Otherwise the placement is illegal 21635 21636 else 21637 Pragma_Misplaced; 21638 return; 21639 end if; 21640 21641 Subp_Id := Defining_Entity (Subp_Decl); 21642 21643 -- Chain the pragma on the contract for further processing by 21644 -- Analyze_Test_Case_In_Decl_Part. 21645 21646 Add_Contract_Item (N, Subp_Id); 21647 21648 -- A pragma that applies to a Ghost entity becomes Ghost for the 21649 -- purposes of legality checks and removal of ignored Ghost code. 21650 21651 Mark_Pragma_As_Ghost (N, Subp_Id); 21652 21653 -- Preanalyze the original aspect argument "Name" for ASIS or for 21654 -- a generic subprogram to properly capture global references. 21655 21656 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then 21657 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True); 21658 21659 if Present (Asp_Arg) then 21660 21661 -- The argument appears with an identifier in association 21662 -- form. 21663 21664 if Nkind (Asp_Arg) = N_Component_Association then 21665 Asp_Arg := Expression (Asp_Arg); 21666 end if; 21667 21668 Check_Expr_Is_OK_Static_Expression 21669 (Asp_Arg, Standard_String); 21670 end if; 21671 end if; 21672 21673 -- Ensure that the all Test_Case pragmas of the related subprogram 21674 -- have distinct names. 21675 21676 Check_Distinct_Name (Subp_Id); 21677 21678 -- Fully analyze the pragma when it appears inside an entry 21679 -- or subprogram body because it cannot benefit from forward 21680 -- references. 21681 21682 if Nkind_In (Subp_Decl, N_Entry_Body, 21683 N_Subprogram_Body, 21684 N_Subprogram_Body_Stub) 21685 then 21686 -- The legality checks of pragma Test_Case are affected by the 21687 -- SPARK mode in effect and the volatility of the context. 21688 -- Analyze all pragmas in a specific order. 21689 21690 Analyze_If_Present (Pragma_SPARK_Mode); 21691 Analyze_If_Present (Pragma_Volatile_Function); 21692 Analyze_Test_Case_In_Decl_Part (N); 21693 end if; 21694 end Test_Case; 21695 21696 -------------------------- 21697 -- Thread_Local_Storage -- 21698 -------------------------- 21699 21700 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); 21701 21702 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare 21703 E : Entity_Id; 21704 Id : Node_Id; 21705 21706 begin 21707 GNAT_Pragma; 21708 Check_Arg_Count (1); 21709 Check_Optional_Identifier (Arg1, Name_Entity); 21710 Check_Arg_Is_Library_Level_Local_Name (Arg1); 21711 21712 Id := Get_Pragma_Arg (Arg1); 21713 Analyze (Id); 21714 21715 if not Is_Entity_Name (Id) 21716 or else Ekind (Entity (Id)) /= E_Variable 21717 then 21718 Error_Pragma_Arg ("local variable name required", Arg1); 21719 end if; 21720 21721 E := Entity (Id); 21722 21723 -- A pragma that applies to a Ghost entity becomes Ghost for the 21724 -- purposes of legality checks and removal of ignored Ghost code. 21725 21726 Mark_Pragma_As_Ghost (N, E); 21727 21728 if Rep_Item_Too_Early (E, N) 21729 or else 21730 Rep_Item_Too_Late (E, N) 21731 then 21732 raise Pragma_Exit; 21733 end if; 21734 21735 Set_Has_Pragma_Thread_Local_Storage (E); 21736 Set_Has_Gigi_Rep_Item (E); 21737 end Thread_Local_Storage; 21738 21739 ---------------- 21740 -- Time_Slice -- 21741 ---------------- 21742 21743 -- pragma Time_Slice (static_duration_EXPRESSION); 21744 21745 when Pragma_Time_Slice => Time_Slice : declare 21746 Val : Ureal; 21747 Nod : Node_Id; 21748 21749 begin 21750 GNAT_Pragma; 21751 Check_Arg_Count (1); 21752 Check_No_Identifiers; 21753 Check_In_Main_Program; 21754 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration); 21755 21756 if not Error_Posted (Arg1) then 21757 Nod := Next (N); 21758 while Present (Nod) loop 21759 if Nkind (Nod) = N_Pragma 21760 and then Pragma_Name (Nod) = Name_Time_Slice 21761 then 21762 Error_Msg_Name_1 := Pname; 21763 Error_Msg_N ("duplicate pragma% not permitted", Nod); 21764 end if; 21765 21766 Next (Nod); 21767 end loop; 21768 end if; 21769 21770 -- Process only if in main unit 21771 21772 if Get_Source_Unit (Loc) = Main_Unit then 21773 Opt.Time_Slice_Set := True; 21774 Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); 21775 21776 if Val <= Ureal_0 then 21777 Opt.Time_Slice_Value := 0; 21778 21779 elsif Val > UR_From_Uint (UI_From_Int (1000)) then 21780 Opt.Time_Slice_Value := 1_000_000_000; 21781 21782 else 21783 Opt.Time_Slice_Value := 21784 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000))); 21785 end if; 21786 end if; 21787 end Time_Slice; 21788 21789 ----------- 21790 -- Title -- 21791 ----------- 21792 21793 -- pragma Title (TITLING_OPTION [, TITLING OPTION]); 21794 21795 -- TITLING_OPTION ::= 21796 -- [Title =>] STRING_LITERAL 21797 -- | [Subtitle =>] STRING_LITERAL 21798 21799 when Pragma_Title => Title : declare 21800 Args : Args_List (1 .. 2); 21801 Names : constant Name_List (1 .. 2) := ( 21802 Name_Title, 21803 Name_Subtitle); 21804 21805 begin 21806 GNAT_Pragma; 21807 Gather_Associations (Names, Args); 21808 Store_Note (N); 21809 21810 for J in 1 .. 2 loop 21811 if Present (Args (J)) then 21812 Check_Arg_Is_OK_Static_Expression 21813 (Args (J), Standard_String); 21814 end if; 21815 end loop; 21816 end Title; 21817 21818 ---------------------------- 21819 -- Type_Invariant[_Class] -- 21820 ---------------------------- 21821 21822 -- pragma Type_Invariant[_Class] 21823 -- ([Entity =>] type_LOCAL_NAME, 21824 -- [Check =>] EXPRESSION); 21825 21826 when Pragma_Type_Invariant | 21827 Pragma_Type_Invariant_Class => 21828 Type_Invariant : declare 21829 I_Pragma : Node_Id; 21830 21831 begin 21832 Check_Arg_Count (2); 21833 21834 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma, 21835 -- setting Class_Present for the Type_Invariant_Class case. 21836 21837 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class); 21838 I_Pragma := New_Copy (N); 21839 Set_Pragma_Identifier 21840 (I_Pragma, Make_Identifier (Loc, Name_Invariant)); 21841 Rewrite (N, I_Pragma); 21842 Set_Analyzed (N, False); 21843 Analyze (N); 21844 end Type_Invariant; 21845 21846 --------------------- 21847 -- Unchecked_Union -- 21848 --------------------- 21849 21850 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) 21851 21852 when Pragma_Unchecked_Union => Unchecked_Union : declare 21853 Assoc : constant Node_Id := Arg1; 21854 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 21855 Clist : Node_Id; 21856 Comp : Node_Id; 21857 Tdef : Node_Id; 21858 Typ : Entity_Id; 21859 Variant : Node_Id; 21860 Vpart : Node_Id; 21861 21862 begin 21863 Ada_2005_Pragma; 21864 Check_No_Identifiers; 21865 Check_Arg_Count (1); 21866 Check_Arg_Is_Local_Name (Arg1); 21867 21868 Find_Type (Type_Id); 21869 21870 Typ := Entity (Type_Id); 21871 21872 -- A pragma that applies to a Ghost entity becomes Ghost for the 21873 -- purposes of legality checks and removal of ignored Ghost code. 21874 21875 Mark_Pragma_As_Ghost (N, Typ); 21876 21877 if Typ = Any_Type 21878 or else Rep_Item_Too_Early (Typ, N) 21879 then 21880 return; 21881 else 21882 Typ := Underlying_Type (Typ); 21883 end if; 21884 21885 if Rep_Item_Too_Late (Typ, N) then 21886 return; 21887 end if; 21888 21889 Check_First_Subtype (Arg1); 21890 21891 -- Note remaining cases are references to a type in the current 21892 -- declarative part. If we find an error, we post the error on 21893 -- the relevant type declaration at an appropriate point. 21894 21895 if not Is_Record_Type (Typ) then 21896 Error_Msg_N ("unchecked union must be record type", Typ); 21897 return; 21898 21899 elsif Is_Tagged_Type (Typ) then 21900 Error_Msg_N ("unchecked union must not be tagged", Typ); 21901 return; 21902 21903 elsif not Has_Discriminants (Typ) then 21904 Error_Msg_N 21905 ("unchecked union must have one discriminant", Typ); 21906 return; 21907 21908 -- Note: in previous versions of GNAT we used to check for limited 21909 -- types and give an error, but in fact the standard does allow 21910 -- Unchecked_Union on limited types, so this check was removed. 21911 21912 -- Similarly, GNAT used to require that all discriminants have 21913 -- default values, but this is not mandated by the RM. 21914 21915 -- Proceed with basic error checks completed 21916 21917 else 21918 Tdef := Type_Definition (Declaration_Node (Typ)); 21919 Clist := Component_List (Tdef); 21920 21921 -- Check presence of component list and variant part 21922 21923 if No (Clist) or else No (Variant_Part (Clist)) then 21924 Error_Msg_N 21925 ("unchecked union must have variant part", Tdef); 21926 return; 21927 end if; 21928 21929 -- Check components 21930 21931 Comp := First (Component_Items (Clist)); 21932 while Present (Comp) loop 21933 Check_Component (Comp, Typ); 21934 Next (Comp); 21935 end loop; 21936 21937 -- Check variant part 21938 21939 Vpart := Variant_Part (Clist); 21940 21941 Variant := First (Variants (Vpart)); 21942 while Present (Variant) loop 21943 Check_Variant (Variant, Typ); 21944 Next (Variant); 21945 end loop; 21946 end if; 21947 21948 Set_Is_Unchecked_Union (Typ); 21949 Set_Convention (Typ, Convention_C); 21950 Set_Has_Unchecked_Union (Base_Type (Typ)); 21951 Set_Is_Unchecked_Union (Base_Type (Typ)); 21952 end Unchecked_Union; 21953 21954 ------------------------ 21955 -- Unimplemented_Unit -- 21956 ------------------------ 21957 21958 -- pragma Unimplemented_Unit; 21959 21960 -- Note: this only gives an error if we are generating code, or if 21961 -- we are in a generic library unit (where the pragma appears in the 21962 -- body, not in the spec). 21963 21964 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare 21965 Cunitent : constant Entity_Id := 21966 Cunit_Entity (Get_Source_Unit (Loc)); 21967 Ent_Kind : constant Entity_Kind := 21968 Ekind (Cunitent); 21969 21970 begin 21971 GNAT_Pragma; 21972 Check_Arg_Count (0); 21973 21974 if Operating_Mode = Generate_Code 21975 or else Ent_Kind = E_Generic_Function 21976 or else Ent_Kind = E_Generic_Procedure 21977 or else Ent_Kind = E_Generic_Package 21978 then 21979 Get_Name_String (Chars (Cunitent)); 21980 Set_Casing (Mixed_Case); 21981 Write_Str (Name_Buffer (1 .. Name_Len)); 21982 Write_Str (" is not supported in this configuration"); 21983 Write_Eol; 21984 raise Unrecoverable_Error; 21985 end if; 21986 end Unimplemented_Unit; 21987 21988 ------------------------ 21989 -- Universal_Aliasing -- 21990 ------------------------ 21991 21992 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)]; 21993 21994 when Pragma_Universal_Aliasing => Universal_Alias : declare 21995 E_Id : Entity_Id; 21996 21997 begin 21998 GNAT_Pragma; 21999 Check_Arg_Count (1); 22000 Check_Optional_Identifier (Arg2, Name_Entity); 22001 Check_Arg_Is_Local_Name (Arg1); 22002 E_Id := Entity (Get_Pragma_Arg (Arg1)); 22003 22004 if E_Id = Any_Type then 22005 return; 22006 elsif No (E_Id) or else not Is_Type (E_Id) then 22007 Error_Pragma_Arg ("pragma% requires type", Arg1); 22008 end if; 22009 22010 -- A pragma that applies to a Ghost entity becomes Ghost for the 22011 -- purposes of legality checks and removal of ignored Ghost code. 22012 22013 Mark_Pragma_As_Ghost (N, E_Id); 22014 Set_Universal_Aliasing (Implementation_Base_Type (E_Id)); 22015 Record_Rep_Item (E_Id, N); 22016 end Universal_Alias; 22017 22018 -------------------- 22019 -- Universal_Data -- 22020 -------------------- 22021 22022 -- pragma Universal_Data [(library_unit_NAME)]; 22023 22024 when Pragma_Universal_Data => 22025 GNAT_Pragma; 22026 22027 -- If this is a configuration pragma, then set the universal 22028 -- addressing option, otherwise confirm that the pragma satisfies 22029 -- the requirements of library unit pragma placement and leave it 22030 -- to the GNAAMP back end to detect the pragma (avoids transitive 22031 -- setting of the option due to withed units). 22032 22033 if Is_Configuration_Pragma then 22034 Universal_Addressing_On_AAMP := True; 22035 else 22036 Check_Valid_Library_Unit_Pragma; 22037 end if; 22038 22039 if not AAMP_On_Target then 22040 Error_Pragma ("??pragma% ignored (applies only to AAMP)"); 22041 end if; 22042 22043 ---------------- 22044 -- Unmodified -- 22045 ---------------- 22046 22047 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME}); 22048 22049 when Pragma_Unmodified => Unmodified : declare 22050 Arg : Node_Id; 22051 Arg_Expr : Node_Id; 22052 Arg_Id : Entity_Id; 22053 22054 Ghost_Error_Posted : Boolean := False; 22055 -- Flag set when an error concerning the illegal mix of Ghost and 22056 -- non-Ghost variables is emitted. 22057 22058 Ghost_Id : Entity_Id := Empty; 22059 -- The entity of the first Ghost variable encountered while 22060 -- processing the arguments of the pragma. 22061 22062 begin 22063 GNAT_Pragma; 22064 Check_At_Least_N_Arguments (1); 22065 22066 -- Loop through arguments 22067 22068 Arg := Arg1; 22069 while Present (Arg) loop 22070 Check_No_Identifier (Arg); 22071 22072 -- Note: the analyze call done by Check_Arg_Is_Local_Name will 22073 -- in fact generate reference, so that the entity will have a 22074 -- reference, which will inhibit any warnings about it not 22075 -- being referenced, and also properly show up in the ali file 22076 -- as a reference. But this reference is recorded before the 22077 -- Has_Pragma_Unreferenced flag is set, so that no warning is 22078 -- generated for this reference. 22079 22080 Check_Arg_Is_Local_Name (Arg); 22081 Arg_Expr := Get_Pragma_Arg (Arg); 22082 22083 if Is_Entity_Name (Arg_Expr) then 22084 Arg_Id := Entity (Arg_Expr); 22085 22086 if Is_Assignable (Arg_Id) then 22087 Set_Has_Pragma_Unmodified (Arg_Id); 22088 22089 -- A pragma that applies to a Ghost entity becomes Ghost 22090 -- for the purposes of legality checks and removal of 22091 -- ignored Ghost code. 22092 22093 Mark_Pragma_As_Ghost (N, Arg_Id); 22094 22095 -- Capture the entity of the first Ghost variable being 22096 -- processed for error detection purposes. 22097 22098 if Is_Ghost_Entity (Arg_Id) then 22099 if No (Ghost_Id) then 22100 Ghost_Id := Arg_Id; 22101 end if; 22102 22103 -- Otherwise the variable is non-Ghost. It is illegal 22104 -- to mix references to Ghost and non-Ghost entities 22105 -- (SPARK RM 6.9). 22106 22107 elsif Present (Ghost_Id) 22108 and then not Ghost_Error_Posted 22109 then 22110 Ghost_Error_Posted := True; 22111 22112 Error_Msg_Name_1 := Pname; 22113 Error_Msg_N 22114 ("pragma % cannot mention ghost and non-ghost " 22115 & "variables", N); 22116 22117 Error_Msg_Sloc := Sloc (Ghost_Id); 22118 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 22119 22120 Error_Msg_Sloc := Sloc (Arg_Id); 22121 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id); 22122 end if; 22123 22124 -- Otherwise the pragma referenced an illegal entity 22125 22126 else 22127 Error_Pragma_Arg 22128 ("pragma% can only be applied to a variable", Arg_Expr); 22129 end if; 22130 end if; 22131 22132 Next (Arg); 22133 end loop; 22134 end Unmodified; 22135 22136 ------------------ 22137 -- Unreferenced -- 22138 ------------------ 22139 22140 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME}); 22141 22142 -- or when used in a context clause: 22143 22144 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME} 22145 22146 when Pragma_Unreferenced => Unreferenced : declare 22147 Arg : Node_Id; 22148 Arg_Expr : Node_Id; 22149 Arg_Id : Entity_Id; 22150 Citem : Node_Id; 22151 22152 Ghost_Error_Posted : Boolean := False; 22153 -- Flag set when an error concerning the illegal mix of Ghost and 22154 -- non-Ghost names is emitted. 22155 22156 Ghost_Id : Entity_Id := Empty; 22157 -- The entity of the first Ghost name encountered while processing 22158 -- the arguments of the pragma. 22159 22160 begin 22161 GNAT_Pragma; 22162 Check_At_Least_N_Arguments (1); 22163 22164 -- Check case of appearing within context clause 22165 22166 if Is_In_Context_Clause then 22167 22168 -- The arguments must all be units mentioned in a with clause 22169 -- in the same context clause. Note we already checked (in 22170 -- Par.Prag) that the arguments are either identifiers or 22171 -- selected components. 22172 22173 Arg := Arg1; 22174 while Present (Arg) loop 22175 Citem := First (List_Containing (N)); 22176 while Citem /= N loop 22177 Arg_Expr := Get_Pragma_Arg (Arg); 22178 22179 if Nkind (Citem) = N_With_Clause 22180 and then Same_Name (Name (Citem), Arg_Expr) 22181 then 22182 Set_Has_Pragma_Unreferenced 22183 (Cunit_Entity 22184 (Get_Source_Unit 22185 (Library_Unit (Citem)))); 22186 Set_Elab_Unit_Name (Arg_Expr, Name (Citem)); 22187 exit; 22188 end if; 22189 22190 Next (Citem); 22191 end loop; 22192 22193 if Citem = N then 22194 Error_Pragma_Arg 22195 ("argument of pragma% is not withed unit", Arg); 22196 end if; 22197 22198 Next (Arg); 22199 end loop; 22200 22201 -- Case of not in list of context items 22202 22203 else 22204 Arg := Arg1; 22205 while Present (Arg) loop 22206 Check_No_Identifier (Arg); 22207 22208 -- Note: the analyze call done by Check_Arg_Is_Local_Name 22209 -- will in fact generate reference, so that the entity will 22210 -- have a reference, which will inhibit any warnings about 22211 -- it not being referenced, and also properly show up in the 22212 -- ali file as a reference. But this reference is recorded 22213 -- before the Has_Pragma_Unreferenced flag is set, so that 22214 -- no warning is generated for this reference. 22215 22216 Check_Arg_Is_Local_Name (Arg); 22217 Arg_Expr := Get_Pragma_Arg (Arg); 22218 22219 if Is_Entity_Name (Arg_Expr) then 22220 Arg_Id := Entity (Arg_Expr); 22221 22222 -- If the entity is overloaded, the pragma applies to the 22223 -- most recent overloading, as documented. In this case, 22224 -- name resolution does not generate a reference, so it 22225 -- must be done here explicitly. 22226 22227 if Is_Overloaded (Arg_Expr) then 22228 Generate_Reference (Arg_Id, N); 22229 end if; 22230 22231 Set_Has_Pragma_Unreferenced (Arg_Id); 22232 22233 -- A pragma that applies to a Ghost entity becomes Ghost 22234 -- for the purposes of legality checks and removal of 22235 -- ignored Ghost code. 22236 22237 Mark_Pragma_As_Ghost (N, Arg_Id); 22238 22239 -- Capture the entity of the first Ghost name being 22240 -- processed for error detection purposes. 22241 22242 if Is_Ghost_Entity (Arg_Id) then 22243 if No (Ghost_Id) then 22244 Ghost_Id := Arg_Id; 22245 end if; 22246 22247 -- Otherwise the name is non-Ghost. It is illegal to mix 22248 -- references to Ghost and non-Ghost entities 22249 -- (SPARK RM 6.9). 22250 22251 elsif Present (Ghost_Id) 22252 and then not Ghost_Error_Posted 22253 then 22254 Ghost_Error_Posted := True; 22255 22256 Error_Msg_Name_1 := Pname; 22257 Error_Msg_N 22258 ("pragma % cannot mention ghost and non-ghost names", 22259 N); 22260 22261 Error_Msg_Sloc := Sloc (Ghost_Id); 22262 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 22263 22264 Error_Msg_Sloc := Sloc (Arg_Id); 22265 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id); 22266 end if; 22267 end if; 22268 22269 Next (Arg); 22270 end loop; 22271 end if; 22272 end Unreferenced; 22273 22274 -------------------------- 22275 -- Unreferenced_Objects -- 22276 -------------------------- 22277 22278 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME}); 22279 22280 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare 22281 Arg : Node_Id; 22282 Arg_Expr : Node_Id; 22283 Arg_Id : Entity_Id; 22284 22285 Ghost_Error_Posted : Boolean := False; 22286 -- Flag set when an error concerning the illegal mix of Ghost and 22287 -- non-Ghost types is emitted. 22288 22289 Ghost_Id : Entity_Id := Empty; 22290 -- The entity of the first Ghost type encountered while processing 22291 -- the arguments of the pragma. 22292 22293 begin 22294 GNAT_Pragma; 22295 Check_At_Least_N_Arguments (1); 22296 22297 Arg := Arg1; 22298 while Present (Arg) loop 22299 Check_No_Identifier (Arg); 22300 Check_Arg_Is_Local_Name (Arg); 22301 Arg_Expr := Get_Pragma_Arg (Arg); 22302 22303 if Is_Entity_Name (Arg_Expr) then 22304 Arg_Id := Entity (Arg_Expr); 22305 22306 if Is_Type (Arg_Id) then 22307 Set_Has_Pragma_Unreferenced_Objects (Arg_Id); 22308 22309 -- A pragma that applies to a Ghost entity becomes Ghost 22310 -- for the purposes of legality checks and removal of 22311 -- ignored Ghost code. 22312 22313 Mark_Pragma_As_Ghost (N, Arg_Id); 22314 22315 -- Capture the entity of the first Ghost type being 22316 -- processed for error detection purposes. 22317 22318 if Is_Ghost_Entity (Arg_Id) then 22319 if No (Ghost_Id) then 22320 Ghost_Id := Arg_Id; 22321 end if; 22322 22323 -- Otherwise the type is non-Ghost. It is illegal to mix 22324 -- references to Ghost and non-Ghost entities 22325 -- (SPARK RM 6.9). 22326 22327 elsif Present (Ghost_Id) 22328 and then not Ghost_Error_Posted 22329 then 22330 Ghost_Error_Posted := True; 22331 22332 Error_Msg_Name_1 := Pname; 22333 Error_Msg_N 22334 ("pragma % cannot mention ghost and non-ghost types", 22335 N); 22336 22337 Error_Msg_Sloc := Sloc (Ghost_Id); 22338 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 22339 22340 Error_Msg_Sloc := Sloc (Arg_Id); 22341 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id); 22342 end if; 22343 else 22344 Error_Pragma_Arg 22345 ("argument for pragma% must be type or subtype", Arg); 22346 end if; 22347 else 22348 Error_Pragma_Arg 22349 ("argument for pragma% must be type or subtype", Arg); 22350 end if; 22351 22352 Next (Arg); 22353 end loop; 22354 end Unreferenced_Objects; 22355 22356 ------------------------------ 22357 -- Unreserve_All_Interrupts -- 22358 ------------------------------ 22359 22360 -- pragma Unreserve_All_Interrupts; 22361 22362 when Pragma_Unreserve_All_Interrupts => 22363 GNAT_Pragma; 22364 Check_Arg_Count (0); 22365 22366 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then 22367 Unreserve_All_Interrupts := True; 22368 end if; 22369 22370 ---------------- 22371 -- Unsuppress -- 22372 ---------------- 22373 22374 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); 22375 22376 when Pragma_Unsuppress => 22377 Ada_2005_Pragma; 22378 Process_Suppress_Unsuppress (Suppress_Case => False); 22379 22380 ---------------------------- 22381 -- Unevaluated_Use_Of_Old -- 22382 ---------------------------- 22383 22384 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow); 22385 22386 when Pragma_Unevaluated_Use_Of_Old => 22387 GNAT_Pragma; 22388 Check_Arg_Count (1); 22389 Check_No_Identifiers; 22390 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow); 22391 22392 -- Suppress/Unsuppress can appear as a configuration pragma, or in 22393 -- a declarative part or a package spec. 22394 22395 if not Is_Configuration_Pragma then 22396 Check_Is_In_Decl_Part_Or_Package_Spec; 22397 end if; 22398 22399 -- Store proper setting of Uneval_Old 22400 22401 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 22402 Uneval_Old := Fold_Upper (Name_Buffer (1)); 22403 22404 ------------------- 22405 -- Use_VADS_Size -- 22406 ------------------- 22407 22408 -- pragma Use_VADS_Size; 22409 22410 when Pragma_Use_VADS_Size => 22411 GNAT_Pragma; 22412 Check_Arg_Count (0); 22413 Check_Valid_Configuration_Pragma; 22414 Use_VADS_Size := True; 22415 22416 --------------------- 22417 -- Validity_Checks -- 22418 --------------------- 22419 22420 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 22421 22422 when Pragma_Validity_Checks => Validity_Checks : declare 22423 A : constant Node_Id := Get_Pragma_Arg (Arg1); 22424 S : String_Id; 22425 C : Char_Code; 22426 22427 begin 22428 GNAT_Pragma; 22429 Check_Arg_Count (1); 22430 Check_No_Identifiers; 22431 22432 -- Pragma always active unless in CodePeer or GNATprove modes, 22433 -- which use a fixed configuration of validity checks. 22434 22435 if not (CodePeer_Mode or GNATprove_Mode) then 22436 if Nkind (A) = N_String_Literal then 22437 S := Strval (A); 22438 22439 declare 22440 Slen : constant Natural := Natural (String_Length (S)); 22441 Options : String (1 .. Slen); 22442 J : Natural; 22443 22444 begin 22445 -- Couldn't we use a for loop here over Options'Range??? 22446 22447 J := 1; 22448 loop 22449 C := Get_String_Char (S, Int (J)); 22450 22451 -- This is a weird test, it skips setting validity 22452 -- checks entirely if any element of S is out of 22453 -- range of Character, what is that about ??? 22454 22455 exit when not In_Character_Range (C); 22456 Options (J) := Get_Character (C); 22457 22458 if J = Slen then 22459 Set_Validity_Check_Options (Options); 22460 exit; 22461 else 22462 J := J + 1; 22463 end if; 22464 end loop; 22465 end; 22466 22467 elsif Nkind (A) = N_Identifier then 22468 if Chars (A) = Name_All_Checks then 22469 Set_Validity_Check_Options ("a"); 22470 elsif Chars (A) = Name_On then 22471 Validity_Checks_On := True; 22472 elsif Chars (A) = Name_Off then 22473 Validity_Checks_On := False; 22474 end if; 22475 end if; 22476 end if; 22477 end Validity_Checks; 22478 22479 -------------- 22480 -- Volatile -- 22481 -------------- 22482 22483 -- pragma Volatile (LOCAL_NAME); 22484 22485 when Pragma_Volatile => 22486 Process_Atomic_Independent_Shared_Volatile; 22487 22488 ------------------------- 22489 -- Volatile_Components -- 22490 ------------------------- 22491 22492 -- pragma Volatile_Components (array_LOCAL_NAME); 22493 22494 -- Volatile is handled by the same circuit as Atomic_Components 22495 22496 -------------------------- 22497 -- Volatile_Full_Access -- 22498 -------------------------- 22499 22500 -- pragma Volatile_Full_Access (LOCAL_NAME); 22501 22502 when Pragma_Volatile_Full_Access => 22503 GNAT_Pragma; 22504 Process_Atomic_Independent_Shared_Volatile; 22505 22506 ----------------------- 22507 -- Volatile_Function -- 22508 ----------------------- 22509 22510 -- pragma Volatile_Function [ (boolean_EXPRESSION) ]; 22511 22512 when Pragma_Volatile_Function => Volatile_Function : declare 22513 Over_Id : Entity_Id; 22514 Spec_Id : Entity_Id; 22515 Subp_Decl : Node_Id; 22516 22517 begin 22518 GNAT_Pragma; 22519 Check_No_Identifiers; 22520 Check_At_Most_N_Arguments (1); 22521 22522 Subp_Decl := 22523 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 22524 22525 -- Generic subprogram 22526 22527 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 22528 null; 22529 22530 -- Body acts as spec 22531 22532 elsif Nkind (Subp_Decl) = N_Subprogram_Body 22533 and then No (Corresponding_Spec (Subp_Decl)) 22534 then 22535 null; 22536 22537 -- Body stub acts as spec 22538 22539 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 22540 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 22541 then 22542 null; 22543 22544 -- Subprogram 22545 22546 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 22547 null; 22548 22549 else 22550 Pragma_Misplaced; 22551 return; 22552 end if; 22553 22554 Spec_Id := Unique_Defining_Entity (Subp_Decl); 22555 22556 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 22557 Pragma_Misplaced; 22558 return; 22559 end if; 22560 22561 -- Chain the pragma on the contract for completeness 22562 22563 Add_Contract_Item (N, Spec_Id); 22564 22565 -- The legality checks of pragma Volatile_Function are affected by 22566 -- the SPARK mode in effect. Analyze all pragmas in a specific 22567 -- order. 22568 22569 Analyze_If_Present (Pragma_SPARK_Mode); 22570 22571 -- A pragma that applies to a Ghost entity becomes Ghost for the 22572 -- purposes of legality checks and removal of ignored Ghost code. 22573 22574 Mark_Pragma_As_Ghost (N, Spec_Id); 22575 22576 -- A volatile function cannot override a non-volatile function 22577 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed 22578 -- in New_Overloaded_Entity, however at that point the pragma has 22579 -- not been processed yet. 22580 22581 Over_Id := Overridden_Operation (Spec_Id); 22582 22583 if Present (Over_Id) 22584 and then not Is_Volatile_Function (Over_Id) 22585 then 22586 Error_Msg_N 22587 ("incompatible volatile function values in effect", Spec_Id); 22588 22589 Error_Msg_Sloc := Sloc (Over_Id); 22590 Error_Msg_N 22591 ("\& declared # with Volatile_Function value `False`", 22592 Spec_Id); 22593 22594 Error_Msg_Sloc := Sloc (Spec_Id); 22595 Error_Msg_N 22596 ("\overridden # with Volatile_Function value `True`", 22597 Spec_Id); 22598 end if; 22599 22600 -- Analyze the Boolean expression (if any) 22601 22602 if Present (Arg1) then 22603 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 22604 end if; 22605 end Volatile_Function; 22606 22607 ---------------------- 22608 -- Warning_As_Error -- 22609 ---------------------- 22610 22611 -- pragma Warning_As_Error (static_string_EXPRESSION); 22612 22613 when Pragma_Warning_As_Error => 22614 GNAT_Pragma; 22615 Check_Arg_Count (1); 22616 Check_No_Identifiers; 22617 Check_Valid_Configuration_Pragma; 22618 22619 if not Is_Static_String_Expression (Arg1) then 22620 Error_Pragma_Arg 22621 ("argument of pragma% must be static string expression", 22622 Arg1); 22623 22624 -- OK static string expression 22625 22626 else 22627 Acquire_Warning_Match_String (Arg1); 22628 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1; 22629 Warnings_As_Errors (Warnings_As_Errors_Count) := 22630 new String'(Name_Buffer (1 .. Name_Len)); 22631 end if; 22632 22633 -------------- 22634 -- Warnings -- 22635 -------------- 22636 22637 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); 22638 22639 -- DETAILS ::= On | Off 22640 -- DETAILS ::= On | Off, local_NAME 22641 -- DETAILS ::= static_string_EXPRESSION 22642 -- DETAILS ::= On | Off, static_string_EXPRESSION 22643 22644 -- TOOL_NAME ::= GNAT | GNATProve 22645 22646 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} 22647 22648 -- Note: If the first argument matches an allowed tool name, it is 22649 -- always considered to be a tool name, even if there is a string 22650 -- variable of that name. 22651 22652 -- Note if the second argument of DETAILS is a local_NAME then the 22653 -- second form is always understood. If the intention is to use 22654 -- the fourth form, then you can write NAME & "" to force the 22655 -- intepretation as a static_string_EXPRESSION. 22656 22657 when Pragma_Warnings => Warnings : declare 22658 Reason : String_Id; 22659 22660 begin 22661 GNAT_Pragma; 22662 Check_At_Least_N_Arguments (1); 22663 22664 -- See if last argument is labeled Reason. If so, make sure we 22665 -- have a string literal or a concatenation of string literals, 22666 -- and acquire the REASON string. Then remove the REASON argument 22667 -- by decreasing Num_Args by one; Remaining processing looks only 22668 -- at first Num_Args arguments). 22669 22670 declare 22671 Last_Arg : constant Node_Id := 22672 Last (Pragma_Argument_Associations (N)); 22673 22674 begin 22675 if Nkind (Last_Arg) = N_Pragma_Argument_Association 22676 and then Chars (Last_Arg) = Name_Reason 22677 then 22678 Start_String; 22679 Get_Reason_String (Get_Pragma_Arg (Last_Arg)); 22680 Reason := End_String; 22681 Arg_Count := Arg_Count - 1; 22682 22683 -- Not allowed in compiler units (bootstrap issues) 22684 22685 Check_Compiler_Unit ("Reason for pragma Warnings", N); 22686 22687 -- No REASON string, set null string as reason 22688 22689 else 22690 Reason := Null_String_Id; 22691 end if; 22692 end; 22693 22694 -- Now proceed with REASON taken care of and eliminated 22695 22696 Check_No_Identifiers; 22697 22698 -- If debug flag -gnatd.i is set, pragma is ignored 22699 22700 if Debug_Flag_Dot_I then 22701 return; 22702 end if; 22703 22704 -- Process various forms of the pragma 22705 22706 declare 22707 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 22708 Shifted_Args : List_Id; 22709 22710 begin 22711 -- See if first argument is a tool name, currently either 22712 -- GNAT or GNATprove. If so, either ignore the pragma if the 22713 -- tool used does not match, or continue as if no tool name 22714 -- was given otherwise, by shifting the arguments. 22715 22716 if Nkind (Argx) = N_Identifier 22717 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove) 22718 then 22719 if Chars (Argx) = Name_Gnat then 22720 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then 22721 Rewrite (N, Make_Null_Statement (Loc)); 22722 Analyze (N); 22723 raise Pragma_Exit; 22724 end if; 22725 22726 elsif Chars (Argx) = Name_Gnatprove then 22727 if not GNATprove_Mode then 22728 Rewrite (N, Make_Null_Statement (Loc)); 22729 Analyze (N); 22730 raise Pragma_Exit; 22731 end if; 22732 22733 else 22734 raise Program_Error; 22735 end if; 22736 22737 -- At this point, the pragma Warnings applies to the tool, 22738 -- so continue with shifted arguments. 22739 22740 Arg_Count := Arg_Count - 1; 22741 22742 if Arg_Count = 1 then 22743 Shifted_Args := New_List (New_Copy (Arg2)); 22744 elsif Arg_Count = 2 then 22745 Shifted_Args := New_List (New_Copy (Arg2), 22746 New_Copy (Arg3)); 22747 elsif Arg_Count = 3 then 22748 Shifted_Args := New_List (New_Copy (Arg2), 22749 New_Copy (Arg3), 22750 New_Copy (Arg4)); 22751 else 22752 raise Program_Error; 22753 end if; 22754 22755 Rewrite (N, 22756 Make_Pragma (Loc, 22757 Chars => Name_Warnings, 22758 Pragma_Argument_Associations => Shifted_Args)); 22759 Analyze (N); 22760 raise Pragma_Exit; 22761 end if; 22762 22763 -- One argument case 22764 22765 if Arg_Count = 1 then 22766 22767 -- On/Off one argument case was processed by parser 22768 22769 if Nkind (Argx) = N_Identifier 22770 and then Nam_In (Chars (Argx), Name_On, Name_Off) 22771 then 22772 null; 22773 22774 -- One argument case must be ON/OFF or static string expr 22775 22776 elsif not Is_Static_String_Expression (Arg1) then 22777 Error_Pragma_Arg 22778 ("argument of pragma% must be On/Off or static string " 22779 & "expression", Arg1); 22780 22781 -- One argument string expression case 22782 22783 else 22784 declare 22785 Lit : constant Node_Id := Expr_Value_S (Argx); 22786 Str : constant String_Id := Strval (Lit); 22787 Len : constant Nat := String_Length (Str); 22788 C : Char_Code; 22789 J : Nat; 22790 OK : Boolean; 22791 Chr : Character; 22792 22793 begin 22794 J := 1; 22795 while J <= Len loop 22796 C := Get_String_Char (Str, J); 22797 OK := In_Character_Range (C); 22798 22799 if OK then 22800 Chr := Get_Character (C); 22801 22802 -- Dash case: only -Wxxx is accepted 22803 22804 if J = 1 22805 and then J < Len 22806 and then Chr = '-' 22807 then 22808 J := J + 1; 22809 C := Get_String_Char (Str, J); 22810 Chr := Get_Character (C); 22811 exit when Chr = 'W'; 22812 OK := False; 22813 22814 -- Dot case 22815 22816 elsif J < Len and then Chr = '.' then 22817 J := J + 1; 22818 C := Get_String_Char (Str, J); 22819 Chr := Get_Character (C); 22820 22821 if not Set_Dot_Warning_Switch (Chr) then 22822 Error_Pragma_Arg 22823 ("invalid warning switch character " 22824 & '.' & Chr, Arg1); 22825 end if; 22826 22827 -- Non-Dot case 22828 22829 else 22830 OK := Set_Warning_Switch (Chr); 22831 end if; 22832 end if; 22833 22834 if not OK then 22835 Error_Pragma_Arg 22836 ("invalid warning switch character " & Chr, 22837 Arg1); 22838 end if; 22839 22840 J := J + 1; 22841 end loop; 22842 end; 22843 end if; 22844 22845 -- Two or more arguments (must be two) 22846 22847 else 22848 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 22849 Check_Arg_Count (2); 22850 22851 declare 22852 E_Id : Node_Id; 22853 E : Entity_Id; 22854 Err : Boolean; 22855 22856 begin 22857 E_Id := Get_Pragma_Arg (Arg2); 22858 Analyze (E_Id); 22859 22860 -- In the expansion of an inlined body, a reference to 22861 -- the formal may be wrapped in a conversion if the 22862 -- actual is a conversion. Retrieve the real entity name. 22863 22864 if (In_Instance_Body or In_Inlined_Body) 22865 and then Nkind (E_Id) = N_Unchecked_Type_Conversion 22866 then 22867 E_Id := Expression (E_Id); 22868 end if; 22869 22870 -- Entity name case 22871 22872 if Is_Entity_Name (E_Id) then 22873 E := Entity (E_Id); 22874 22875 if E = Any_Id then 22876 return; 22877 else 22878 loop 22879 Set_Warnings_Off 22880 (E, (Chars (Get_Pragma_Arg (Arg1)) = 22881 Name_Off)); 22882 22883 -- For OFF case, make entry in warnings off 22884 -- pragma table for later processing. But we do 22885 -- not do that within an instance, since these 22886 -- warnings are about what is needed in the 22887 -- template, not an instance of it. 22888 22889 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off 22890 and then Warn_On_Warnings_Off 22891 and then not In_Instance 22892 then 22893 Warnings_Off_Pragmas.Append ((N, E, Reason)); 22894 end if; 22895 22896 if Is_Enumeration_Type (E) then 22897 declare 22898 Lit : Entity_Id; 22899 begin 22900 Lit := First_Literal (E); 22901 while Present (Lit) loop 22902 Set_Warnings_Off (Lit); 22903 Next_Literal (Lit); 22904 end loop; 22905 end; 22906 end if; 22907 22908 exit when No (Homonym (E)); 22909 E := Homonym (E); 22910 end loop; 22911 end if; 22912 22913 -- Error if not entity or static string expression case 22914 22915 elsif not Is_Static_String_Expression (Arg2) then 22916 Error_Pragma_Arg 22917 ("second argument of pragma% must be entity name " 22918 & "or static string expression", Arg2); 22919 22920 -- Static string expression case 22921 22922 else 22923 Acquire_Warning_Match_String (Arg2); 22924 22925 -- Note on configuration pragma case: If this is a 22926 -- configuration pragma, then for an OFF pragma, we 22927 -- just set Config True in the call, which is all 22928 -- that needs to be done. For the case of ON, this 22929 -- is normally an error, unless it is canceling the 22930 -- effect of a previous OFF pragma in the same file. 22931 -- In any other case, an error will be signalled (ON 22932 -- with no matching OFF). 22933 22934 -- Note: We set Used if we are inside a generic to 22935 -- disable the test that the non-config case actually 22936 -- cancels a warning. That's because we can't be sure 22937 -- there isn't an instantiation in some other unit 22938 -- where a warning is suppressed. 22939 22940 -- We could do a little better here by checking if the 22941 -- generic unit we are inside is public, but for now 22942 -- we don't bother with that refinement. 22943 22944 if Chars (Argx) = Name_Off then 22945 Set_Specific_Warning_Off 22946 (Loc, Name_Buffer (1 .. Name_Len), Reason, 22947 Config => Is_Configuration_Pragma, 22948 Used => Inside_A_Generic or else In_Instance); 22949 22950 elsif Chars (Argx) = Name_On then 22951 Set_Specific_Warning_On 22952 (Loc, Name_Buffer (1 .. Name_Len), Err); 22953 22954 if Err then 22955 Error_Msg 22956 ("??pragma Warnings On with no matching " 22957 & "Warnings Off", Loc); 22958 end if; 22959 end if; 22960 end if; 22961 end; 22962 end if; 22963 end; 22964 end Warnings; 22965 22966 ------------------- 22967 -- Weak_External -- 22968 ------------------- 22969 22970 -- pragma Weak_External ([Entity =>] LOCAL_NAME); 22971 22972 when Pragma_Weak_External => Weak_External : declare 22973 Ent : Entity_Id; 22974 22975 begin 22976 GNAT_Pragma; 22977 Check_Arg_Count (1); 22978 Check_Optional_Identifier (Arg1, Name_Entity); 22979 Check_Arg_Is_Library_Level_Local_Name (Arg1); 22980 Ent := Entity (Get_Pragma_Arg (Arg1)); 22981 22982 if Rep_Item_Too_Early (Ent, N) then 22983 return; 22984 else 22985 Ent := Underlying_Type (Ent); 22986 end if; 22987 22988 -- The only processing required is to link this item on to the 22989 -- list of rep items for the given entity. This is accomplished 22990 -- by the call to Rep_Item_Too_Late (when no error is detected 22991 -- and False is returned). 22992 22993 if Rep_Item_Too_Late (Ent, N) then 22994 return; 22995 else 22996 Set_Has_Gigi_Rep_Item (Ent); 22997 end if; 22998 end Weak_External; 22999 23000 ----------------------------- 23001 -- Wide_Character_Encoding -- 23002 ----------------------------- 23003 23004 -- pragma Wide_Character_Encoding (IDENTIFIER); 23005 23006 when Pragma_Wide_Character_Encoding => 23007 GNAT_Pragma; 23008 23009 -- Nothing to do, handled in parser. Note that we do not enforce 23010 -- configuration pragma placement, this pragma can appear at any 23011 -- place in the source, allowing mixed encodings within a single 23012 -- source program. 23013 23014 null; 23015 23016 -------------------- 23017 -- Unknown_Pragma -- 23018 -------------------- 23019 23020 -- Should be impossible, since the case of an unknown pragma is 23021 -- separately processed before the case statement is entered. 23022 23023 when Unknown_Pragma => 23024 raise Program_Error; 23025 end case; 23026 23027 -- AI05-0144: detect dangerous order dependence. Disabled for now, 23028 -- until AI is formally approved. 23029 23030 -- Check_Order_Dependence; 23031 23032 exception 23033 when Pragma_Exit => null; 23034 end Analyze_Pragma; 23035 23036 --------------------------------------------- 23037 -- Analyze_Pre_Post_Condition_In_Decl_Part -- 23038 --------------------------------------------- 23039 23040 procedure Analyze_Pre_Post_Condition_In_Decl_Part 23041 (N : Node_Id; 23042 Freeze_Id : Entity_Id := Empty) 23043 is 23044 procedure Process_Class_Wide_Condition 23045 (Expr : Node_Id; 23046 Spec_Id : Entity_Id; 23047 Subp_Decl : Node_Id); 23048 -- Replace the type of all references to the controlling formal of 23049 -- subprogram Spec_Id found in expression Expr with the corresponding 23050 -- class-wide type. Subp_Decl is the subprogram [body] declaration 23051 -- where the pragma resides. 23052 23053 ---------------------------------- 23054 -- Process_Class_Wide_Condition -- 23055 ---------------------------------- 23056 23057 procedure Process_Class_Wide_Condition 23058 (Expr : Node_Id; 23059 Spec_Id : Entity_Id; 23060 Subp_Decl : Node_Id) 23061 is 23062 Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id); 23063 23064 ACW : Entity_Id := Empty; 23065 -- Access to Disp_Typ'Class, created if there is a controlling formal 23066 -- that is an access parameter. 23067 23068 function Access_Class_Wide_Type return Entity_Id; 23069 -- If expression Expr contains a reference to a controlling access 23070 -- parameter, create an access to Disp_Typ'Class for the necessary 23071 -- conversions if one does not exist. 23072 23073 function Replace_Type (N : Node_Id) return Traverse_Result; 23074 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class 23075 -- aspect for a primitive subprogram of a tagged type Disp_Typ, a 23076 -- name that denotes a formal parameter of type Disp_Typ is treated 23077 -- as having type Disp_Typ'Class. Similarly, a name that denotes a 23078 -- formal access parameter of type access-to-Disp_Typ is interpreted 23079 -- as with type access-to-Disp_Typ'Class. This ensures the expression 23080 -- is well defined for a primitive subprogram of a type descended 23081 -- from Disp_Typ. 23082 23083 ---------------------------- 23084 -- Access_Class_Wide_Type -- 23085 ---------------------------- 23086 23087 function Access_Class_Wide_Type return Entity_Id is 23088 Loc : constant Source_Ptr := Sloc (N); 23089 23090 begin 23091 if No (ACW) then 23092 ACW := Make_Temporary (Loc, 'T'); 23093 23094 Insert_Before_And_Analyze (Subp_Decl, 23095 Make_Full_Type_Declaration (Loc, 23096 Defining_Identifier => ACW, 23097 Type_Definition => 23098 Make_Access_To_Object_Definition (Loc, 23099 Subtype_Indication => 23100 New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc), 23101 All_Present => True))); 23102 23103 Freeze_Before (Subp_Decl, ACW); 23104 end if; 23105 23106 return ACW; 23107 end Access_Class_Wide_Type; 23108 23109 ------------------ 23110 -- Replace_Type -- 23111 ------------------ 23112 23113 function Replace_Type (N : Node_Id) return Traverse_Result is 23114 Context : constant Node_Id := Parent (N); 23115 Loc : constant Source_Ptr := Sloc (N); 23116 CW_Typ : Entity_Id := Empty; 23117 Ent : Entity_Id; 23118 Typ : Entity_Id; 23119 23120 begin 23121 if Is_Entity_Name (N) 23122 and then Present (Entity (N)) 23123 and then Is_Formal (Entity (N)) 23124 then 23125 Ent := Entity (N); 23126 Typ := Etype (Ent); 23127 23128 -- Do not perform the type replacement for selector names in 23129 -- parameter associations. These carry an entity for reference 23130 -- purposes, but semantically they are just identifiers. 23131 23132 if Nkind (Context) = N_Type_Conversion then 23133 null; 23134 23135 elsif Nkind (Context) = N_Parameter_Association 23136 and then Selector_Name (Context) = N 23137 then 23138 null; 23139 23140 elsif Typ = Disp_Typ then 23141 CW_Typ := Class_Wide_Type (Typ); 23142 23143 elsif Is_Access_Type (Typ) 23144 and then Designated_Type (Typ) = Disp_Typ 23145 then 23146 CW_Typ := Access_Class_Wide_Type; 23147 end if; 23148 23149 if Present (CW_Typ) then 23150 Rewrite (N, 23151 Make_Type_Conversion (Loc, 23152 Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc), 23153 Expression => New_Occurrence_Of (Ent, Loc))); 23154 Set_Etype (N, CW_Typ); 23155 end if; 23156 end if; 23157 23158 return OK; 23159 end Replace_Type; 23160 23161 procedure Replace_Types is new Traverse_Proc (Replace_Type); 23162 23163 -- Start of processing for Process_Class_Wide_Condition 23164 23165 begin 23166 -- The subprogram subject to Pre'Class/Post'Class does not have a 23167 -- dispatching type, therefore the aspect/pragma is illegal. 23168 23169 if No (Disp_Typ) then 23170 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N); 23171 23172 if From_Aspect_Specification (N) then 23173 Error_Msg_N 23174 ("aspect % can only be specified for a primitive operation " 23175 & "of a tagged type", Corresponding_Aspect (N)); 23176 23177 -- The pragma is a source construct 23178 23179 else 23180 Error_Msg_N 23181 ("pragma % can only be specified for a primitive operation " 23182 & "of a tagged type", N); 23183 end if; 23184 end if; 23185 23186 Replace_Types (Expr); 23187 end Process_Class_Wide_Condition; 23188 23189 -- Local variables 23190 23191 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 23192 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 23193 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 23194 23195 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; 23196 23197 Errors : Nat; 23198 Restore_Scope : Boolean := False; 23199 23200 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part 23201 23202 begin 23203 -- Do not analyze the pragma multiple times 23204 23205 if Is_Analyzed_Pragma (N) then 23206 return; 23207 end if; 23208 23209 -- Set the Ghost mode in effect from the pragma. Due to the delayed 23210 -- analysis of the pragma, the Ghost mode at point of declaration and 23211 -- point of analysis may not necessarely be the same. Use the mode in 23212 -- effect at the point of declaration. 23213 23214 Set_Ghost_Mode (N); 23215 23216 -- Ensure that the subprogram and its formals are visible when analyzing 23217 -- the expression of the pragma. 23218 23219 if not In_Open_Scopes (Spec_Id) then 23220 Restore_Scope := True; 23221 Push_Scope (Spec_Id); 23222 23223 if Is_Generic_Subprogram (Spec_Id) then 23224 Install_Generic_Formals (Spec_Id); 23225 else 23226 Install_Formals (Spec_Id); 23227 end if; 23228 end if; 23229 23230 Errors := Serious_Errors_Detected; 23231 Preanalyze_Assert_Expression (Expr, Standard_Boolean); 23232 23233 -- Emit a clarification message when the expression contains at least 23234 -- one undefined reference, possibly due to contract "freezing". 23235 23236 if Errors /= Serious_Errors_Detected 23237 and then Present (Freeze_Id) 23238 and then Has_Undefined_Reference (Expr) 23239 then 23240 Contract_Freeze_Error (Spec_Id, Freeze_Id); 23241 end if; 23242 23243 -- For a class-wide condition, a reference to a controlling formal must 23244 -- be interpreted as having the class-wide type (or an access to such) 23245 -- so that the inherited condition can be properly applied to any 23246 -- overriding operation (see ARM12 6.6.1 (7)). 23247 23248 if Class_Present (N) then 23249 Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl); 23250 end if; 23251 23252 if Restore_Scope then 23253 End_Scope; 23254 end if; 23255 23256 -- Currently it is not possible to inline pre/postconditions on a 23257 -- subprogram subject to pragma Inline_Always. 23258 23259 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 23260 Ghost_Mode := Save_Ghost_Mode; 23261 23262 Set_Is_Analyzed_Pragma (N); 23263 end Analyze_Pre_Post_Condition_In_Decl_Part; 23264 23265 ------------------------------------------ 23266 -- Analyze_Refined_Depends_In_Decl_Part -- 23267 ------------------------------------------ 23268 23269 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is 23270 Body_Inputs : Elist_Id := No_Elist; 23271 Body_Outputs : Elist_Id := No_Elist; 23272 -- The inputs and outputs of the subprogram body synthesized from pragma 23273 -- Refined_Depends. 23274 23275 Dependencies : List_Id := No_List; 23276 Depends : Node_Id; 23277 -- The corresponding Depends pragma along with its clauses 23278 23279 Matched_Items : Elist_Id := No_Elist; 23280 -- A list containing the entities of all successfully matched items 23281 -- found in pragma Depends. 23282 23283 Refinements : List_Id := No_List; 23284 -- The clauses of pragma Refined_Depends 23285 23286 Spec_Id : Entity_Id; 23287 -- The entity of the subprogram subject to pragma Refined_Depends 23288 23289 Spec_Inputs : Elist_Id := No_Elist; 23290 Spec_Outputs : Elist_Id := No_Elist; 23291 -- The inputs and outputs of the subprogram spec synthesized from pragma 23292 -- Depends. 23293 23294 procedure Check_Dependency_Clause (Dep_Clause : Node_Id); 23295 -- Try to match a single dependency clause Dep_Clause against one or 23296 -- more refinement clauses found in list Refinements. Each successful 23297 -- match eliminates at least one refinement clause from Refinements. 23298 23299 procedure Check_Output_States; 23300 -- Determine whether pragma Depends contains an output state with a 23301 -- visible refinement and if so, ensure that pragma Refined_Depends 23302 -- mentions all its constituents as outputs. 23303 23304 procedure Normalize_Clauses (Clauses : List_Id); 23305 -- Given a list of dependence or refinement clauses Clauses, normalize 23306 -- each clause by creating multiple dependencies with exactly one input 23307 -- and one output. 23308 23309 procedure Report_Extra_Clauses; 23310 -- Emit an error for each extra clause found in list Refinements 23311 23312 ----------------------------- 23313 -- Check_Dependency_Clause -- 23314 ----------------------------- 23315 23316 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is 23317 Dep_Input : constant Node_Id := Expression (Dep_Clause); 23318 Dep_Output : constant Node_Id := First (Choices (Dep_Clause)); 23319 23320 function Is_In_Out_State_Clause return Boolean; 23321 -- Determine whether dependence clause Dep_Clause denotes an abstract 23322 -- state that depends on itself (State => State). 23323 23324 function Is_Null_Refined_State (Item : Node_Id) return Boolean; 23325 -- Determine whether item Item denotes an abstract state with visible 23326 -- null refinement. 23327 23328 procedure Match_Items 23329 (Dep_Item : Node_Id; 23330 Ref_Item : Node_Id; 23331 Matched : out Boolean); 23332 -- Try to match dependence item Dep_Item against refinement item 23333 -- Ref_Item. To match against a possible null refinement (see 2, 7), 23334 -- set Ref_Item to Empty. Flag Matched is set to True when one of 23335 -- the following conformance scenarios is in effect: 23336 -- 1) Both items denote null 23337 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case) 23338 -- 3) Both items denote attribute 'Result 23339 -- 4) Both items denote the same object 23340 -- 5) Both items denote the same formal parameter 23341 -- 6) Both items denote the same current instance of a type 23342 -- 7) Both items denote the same discriminant 23343 -- 8) Dep_Item is an abstract state with visible null refinement 23344 -- and Ref_Item denotes null. 23345 -- 9) Dep_Item is an abstract state with visible null refinement 23346 -- and Ref_Item is Empty (special case). 23347 -- 10) Dep_Item is an abstract state with visible non-null 23348 -- refinement and Ref_Item denotes one of its constituents. 23349 -- 11) Dep_Item is an abstract state without a visible refinement 23350 -- and Ref_Item denotes the same state. 23351 -- When scenario 10 is in effect, the entity of the abstract state 23352 -- denoted by Dep_Item is added to list Refined_States. 23353 23354 procedure Record_Item (Item_Id : Entity_Id); 23355 -- Store the entity of an item denoted by Item_Id in Matched_Items 23356 23357 ---------------------------- 23358 -- Is_In_Out_State_Clause -- 23359 ---------------------------- 23360 23361 function Is_In_Out_State_Clause return Boolean is 23362 Dep_Input_Id : Entity_Id; 23363 Dep_Output_Id : Entity_Id; 23364 23365 begin 23366 -- Detect the following clause: 23367 -- State => State 23368 23369 if Is_Entity_Name (Dep_Input) 23370 and then Is_Entity_Name (Dep_Output) 23371 then 23372 -- Handle abstract views generated for limited with clauses 23373 23374 Dep_Input_Id := Available_View (Entity_Of (Dep_Input)); 23375 Dep_Output_Id := Available_View (Entity_Of (Dep_Output)); 23376 23377 return 23378 Ekind (Dep_Input_Id) = E_Abstract_State 23379 and then Dep_Input_Id = Dep_Output_Id; 23380 else 23381 return False; 23382 end if; 23383 end Is_In_Out_State_Clause; 23384 23385 --------------------------- 23386 -- Is_Null_Refined_State -- 23387 --------------------------- 23388 23389 function Is_Null_Refined_State (Item : Node_Id) return Boolean is 23390 Item_Id : Entity_Id; 23391 23392 begin 23393 if Is_Entity_Name (Item) then 23394 23395 -- Handle abstract views generated for limited with clauses 23396 23397 Item_Id := Available_View (Entity_Of (Item)); 23398 23399 return 23400 Ekind (Item_Id) = E_Abstract_State 23401 and then Has_Null_Visible_Refinement (Item_Id); 23402 else 23403 return False; 23404 end if; 23405 end Is_Null_Refined_State; 23406 23407 ----------------- 23408 -- Match_Items -- 23409 ----------------- 23410 23411 procedure Match_Items 23412 (Dep_Item : Node_Id; 23413 Ref_Item : Node_Id; 23414 Matched : out Boolean) 23415 is 23416 Dep_Item_Id : Entity_Id; 23417 Ref_Item_Id : Entity_Id; 23418 23419 begin 23420 -- Assume that the two items do not match 23421 23422 Matched := False; 23423 23424 -- A null matches null or Empty (special case) 23425 23426 if Nkind (Dep_Item) = N_Null 23427 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null) 23428 then 23429 Matched := True; 23430 23431 -- Attribute 'Result matches attribute 'Result 23432 23433 elsif Is_Attribute_Result (Dep_Item) 23434 and then Is_Attribute_Result (Dep_Item) 23435 then 23436 Matched := True; 23437 23438 -- Abstract states, current instances of concurrent types, 23439 -- discriminants, formal parameters and objects. 23440 23441 elsif Is_Entity_Name (Dep_Item) then 23442 23443 -- Handle abstract views generated for limited with clauses 23444 23445 Dep_Item_Id := Available_View (Entity_Of (Dep_Item)); 23446 23447 if Ekind (Dep_Item_Id) = E_Abstract_State then 23448 23449 -- An abstract state with visible null refinement matches 23450 -- null or Empty (special case). 23451 23452 if Has_Null_Visible_Refinement (Dep_Item_Id) 23453 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null) 23454 then 23455 Record_Item (Dep_Item_Id); 23456 Matched := True; 23457 23458 -- An abstract state with visible non-null refinement 23459 -- matches one of its constituents. 23460 23461 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then 23462 if Is_Entity_Name (Ref_Item) then 23463 Ref_Item_Id := Entity_Of (Ref_Item); 23464 23465 if Ekind_In (Ref_Item_Id, E_Abstract_State, 23466 E_Constant, 23467 E_Variable) 23468 and then Present (Encapsulating_State (Ref_Item_Id)) 23469 and then Encapsulating_State (Ref_Item_Id) = 23470 Dep_Item_Id 23471 then 23472 Record_Item (Dep_Item_Id); 23473 Matched := True; 23474 end if; 23475 end if; 23476 23477 -- An abstract state without a visible refinement matches 23478 -- itself. 23479 23480 elsif Is_Entity_Name (Ref_Item) 23481 and then Entity_Of (Ref_Item) = Dep_Item_Id 23482 then 23483 Record_Item (Dep_Item_Id); 23484 Matched := True; 23485 end if; 23486 23487 -- A current instance of a concurrent type, discriminant, 23488 -- formal parameter or an object matches itself. 23489 23490 elsif Is_Entity_Name (Ref_Item) 23491 and then Entity_Of (Ref_Item) = Dep_Item_Id 23492 then 23493 Record_Item (Dep_Item_Id); 23494 Matched := True; 23495 end if; 23496 end if; 23497 end Match_Items; 23498 23499 ----------------- 23500 -- Record_Item -- 23501 ----------------- 23502 23503 procedure Record_Item (Item_Id : Entity_Id) is 23504 begin 23505 if not Contains (Matched_Items, Item_Id) then 23506 Append_New_Elmt (Item_Id, Matched_Items); 23507 end if; 23508 end Record_Item; 23509 23510 -- Local variables 23511 23512 Clause_Matched : Boolean := False; 23513 Dummy : Boolean := False; 23514 Inputs_Match : Boolean; 23515 Next_Ref_Clause : Node_Id; 23516 Outputs_Match : Boolean; 23517 Ref_Clause : Node_Id; 23518 Ref_Input : Node_Id; 23519 Ref_Output : Node_Id; 23520 23521 -- Start of processing for Check_Dependency_Clause 23522 23523 begin 23524 -- Do not perform this check in an instance because it was already 23525 -- performed successfully in the generic template. 23526 23527 if Is_Generic_Instance (Spec_Id) then 23528 return; 23529 end if; 23530 23531 -- Examine all refinement clauses and compare them against the 23532 -- dependence clause. 23533 23534 Ref_Clause := First (Refinements); 23535 while Present (Ref_Clause) loop 23536 Next_Ref_Clause := Next (Ref_Clause); 23537 23538 -- Obtain the attributes of the current refinement clause 23539 23540 Ref_Input := Expression (Ref_Clause); 23541 Ref_Output := First (Choices (Ref_Clause)); 23542 23543 -- The current refinement clause matches the dependence clause 23544 -- when both outputs match and both inputs match. See routine 23545 -- Match_Items for all possible conformance scenarios. 23546 23547 -- Depends Dep_Output => Dep_Input 23548 -- ^ ^ 23549 -- match ? match ? 23550 -- v v 23551 -- Refined_Depends Ref_Output => Ref_Input 23552 23553 Match_Items 23554 (Dep_Item => Dep_Input, 23555 Ref_Item => Ref_Input, 23556 Matched => Inputs_Match); 23557 23558 Match_Items 23559 (Dep_Item => Dep_Output, 23560 Ref_Item => Ref_Output, 23561 Matched => Outputs_Match); 23562 23563 -- An In_Out state clause may be matched against a refinement with 23564 -- a null input or null output as long as the non-null side of the 23565 -- relation contains a valid constituent of the In_Out_State. 23566 23567 if Is_In_Out_State_Clause then 23568 23569 -- Depends => (State => State) 23570 -- Refined_Depends => (null => Constit) -- OK 23571 23572 if Inputs_Match 23573 and then not Outputs_Match 23574 and then Nkind (Ref_Output) = N_Null 23575 then 23576 Outputs_Match := True; 23577 end if; 23578 23579 -- Depends => (State => State) 23580 -- Refined_Depends => (Constit => null) -- OK 23581 23582 if not Inputs_Match 23583 and then Outputs_Match 23584 and then Nkind (Ref_Input) = N_Null 23585 then 23586 Inputs_Match := True; 23587 end if; 23588 end if; 23589 23590 -- The current refinement clause is legally constructed following 23591 -- the rules in SPARK RM 7.2.5, therefore it can be removed from 23592 -- the pool of candidates. The seach continues because a single 23593 -- dependence clause may have multiple matching refinements. 23594 23595 if Inputs_Match and then Outputs_Match then 23596 Clause_Matched := True; 23597 Remove (Ref_Clause); 23598 end if; 23599 23600 Ref_Clause := Next_Ref_Clause; 23601 end loop; 23602 23603 -- Depending on the order or composition of refinement clauses, an 23604 -- In_Out state clause may not be directly refinable. 23605 23606 -- Depends => ((Output, State) => (Input, State)) 23607 -- Refined_State => (State => (Constit_1, Constit_2)) 23608 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2) 23609 23610 -- Matching normalized clause (State => State) fails because there is 23611 -- no direct refinement capable of satisfying this relation. Another 23612 -- similar case arises when clauses (Constit_1 => Input) and (Output 23613 -- => Constit_2) are matched first, leaving no candidates for clause 23614 -- (State => State). Both scenarios are legal as long as one of the 23615 -- previous clauses mentioned a valid constituent of State. 23616 23617 if not Clause_Matched 23618 and then Is_In_Out_State_Clause 23619 and then 23620 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input))) 23621 then 23622 Clause_Matched := True; 23623 end if; 23624 23625 -- A clause where the input is an abstract state with visible null 23626 -- refinement is implicitly matched when the output has already been 23627 -- matched in a previous clause. 23628 23629 -- Depends => (Output => State) -- implicitly OK 23630 -- Refined_State => (State => null) 23631 -- Refined_Depends => (Output => ...) 23632 23633 if not Clause_Matched 23634 and then Is_Null_Refined_State (Dep_Input) 23635 and then Is_Entity_Name (Dep_Output) 23636 and then 23637 Contains (Matched_Items, Available_View (Entity_Of (Dep_Output))) 23638 then 23639 Clause_Matched := True; 23640 end if; 23641 23642 -- A clause where the output is an abstract state with visible null 23643 -- refinement is implicitly matched when the input has already been 23644 -- matched in a previous clause. 23645 23646 -- Depends => (State => Input) -- implicitly OK 23647 -- Refined_State => (State => null) 23648 -- Refined_Depends => (... => Input) 23649 23650 if not Clause_Matched 23651 and then Is_Null_Refined_State (Dep_Output) 23652 and then Is_Entity_Name (Dep_Input) 23653 and then 23654 Contains (Matched_Items, Available_View (Entity_Of (Dep_Input))) 23655 then 23656 Clause_Matched := True; 23657 end if; 23658 23659 -- At this point either all refinement clauses have been examined or 23660 -- pragma Refined_Depends contains a solitary null. Only an abstract 23661 -- state with null refinement can possibly match these cases. 23662 23663 -- Depends => (State => null) 23664 -- Refined_State => (State => null) 23665 -- Refined_Depends => null -- OK 23666 23667 if not Clause_Matched then 23668 Match_Items 23669 (Dep_Item => Dep_Input, 23670 Ref_Item => Empty, 23671 Matched => Inputs_Match); 23672 23673 Match_Items 23674 (Dep_Item => Dep_Output, 23675 Ref_Item => Empty, 23676 Matched => Outputs_Match); 23677 23678 Clause_Matched := Inputs_Match and Outputs_Match; 23679 end if; 23680 23681 -- If the contents of Refined_Depends are legal, then the current 23682 -- dependence clause should be satisfied either by an explicit match 23683 -- or by one of the special cases. 23684 23685 if not Clause_Matched then 23686 SPARK_Msg_NE 23687 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no " 23688 & "matching refinement in body"), Dep_Clause, Spec_Id); 23689 end if; 23690 end Check_Dependency_Clause; 23691 23692 ------------------------- 23693 -- Check_Output_States -- 23694 ------------------------- 23695 23696 procedure Check_Output_States is 23697 procedure Check_Constituent_Usage (State_Id : Entity_Id); 23698 -- Determine whether all constituents of state State_Id with visible 23699 -- refinement are used as outputs in pragma Refined_Depends. Emit an 23700 -- error if this is not the case. 23701 23702 ----------------------------- 23703 -- Check_Constituent_Usage -- 23704 ----------------------------- 23705 23706 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 23707 Constit_Elmt : Elmt_Id; 23708 Constit_Id : Entity_Id; 23709 Posted : Boolean := False; 23710 23711 begin 23712 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 23713 while Present (Constit_Elmt) loop 23714 Constit_Id := Node (Constit_Elmt); 23715 23716 -- The constituent acts as an input (SPARK RM 7.2.5(3)) 23717 23718 if Present (Body_Inputs) 23719 and then Appears_In (Body_Inputs, Constit_Id) 23720 then 23721 Error_Msg_Name_1 := Chars (State_Id); 23722 SPARK_Msg_NE 23723 ("constituent & of state % must act as output in " 23724 & "dependence refinement", N, Constit_Id); 23725 23726 -- The constituent is altogether missing (SPARK RM 7.2.5(3)) 23727 23728 elsif No (Body_Outputs) 23729 or else not Appears_In (Body_Outputs, Constit_Id) 23730 then 23731 if not Posted then 23732 Posted := True; 23733 SPARK_Msg_NE 23734 ("output state & must be replaced by all its " 23735 & "constituents in dependence refinement", 23736 N, State_Id); 23737 end if; 23738 23739 SPARK_Msg_NE 23740 ("\constituent & is missing in output list", 23741 N, Constit_Id); 23742 end if; 23743 23744 Next_Elmt (Constit_Elmt); 23745 end loop; 23746 end Check_Constituent_Usage; 23747 23748 -- Local variables 23749 23750 Item : Node_Id; 23751 Item_Elmt : Elmt_Id; 23752 Item_Id : Entity_Id; 23753 23754 -- Start of processing for Check_Output_States 23755 23756 begin 23757 -- Do not perform this check in an instance because it was already 23758 -- performed successfully in the generic template. 23759 23760 if Is_Generic_Instance (Spec_Id) then 23761 null; 23762 23763 -- Inspect the outputs of pragma Depends looking for a state with a 23764 -- visible refinement. 23765 23766 elsif Present (Spec_Outputs) then 23767 Item_Elmt := First_Elmt (Spec_Outputs); 23768 while Present (Item_Elmt) loop 23769 Item := Node (Item_Elmt); 23770 23771 -- Deal with the mixed nature of the input and output lists 23772 23773 if Nkind (Item) = N_Defining_Identifier then 23774 Item_Id := Item; 23775 else 23776 Item_Id := Available_View (Entity_Of (Item)); 23777 end if; 23778 23779 if Ekind (Item_Id) = E_Abstract_State then 23780 23781 -- The state acts as an input-output, skip it 23782 23783 if Present (Spec_Inputs) 23784 and then Appears_In (Spec_Inputs, Item_Id) 23785 then 23786 null; 23787 23788 -- Ensure that all of the constituents are utilized as 23789 -- outputs in pragma Refined_Depends. 23790 23791 elsif Has_Non_Null_Visible_Refinement (Item_Id) then 23792 Check_Constituent_Usage (Item_Id); 23793 end if; 23794 end if; 23795 23796 Next_Elmt (Item_Elmt); 23797 end loop; 23798 end if; 23799 end Check_Output_States; 23800 23801 ----------------------- 23802 -- Normalize_Clauses -- 23803 ----------------------- 23804 23805 procedure Normalize_Clauses (Clauses : List_Id) is 23806 procedure Normalize_Inputs (Clause : Node_Id); 23807 -- Normalize clause Clause by creating multiple clauses for each 23808 -- input item of Clause. It is assumed that Clause has exactly one 23809 -- output. The transformation is as follows: 23810 -- 23811 -- Output => (Input_1, Input_2) -- original 23812 -- 23813 -- Output => Input_1 -- normalizations 23814 -- Output => Input_2 23815 23816 procedure Normalize_Outputs (Clause : Node_Id); 23817 -- Normalize clause Clause by creating multiple clause for each 23818 -- output item of Clause. The transformation is as follows: 23819 -- 23820 -- (Output_1, Output_2) => Input -- original 23821 -- 23822 -- Output_1 => Input -- normalization 23823 -- Output_2 => Input 23824 23825 ---------------------- 23826 -- Normalize_Inputs -- 23827 ---------------------- 23828 23829 procedure Normalize_Inputs (Clause : Node_Id) is 23830 Inputs : constant Node_Id := Expression (Clause); 23831 Loc : constant Source_Ptr := Sloc (Clause); 23832 Output : constant List_Id := Choices (Clause); 23833 Last_Input : Node_Id; 23834 Input : Node_Id; 23835 New_Clause : Node_Id; 23836 Next_Input : Node_Id; 23837 23838 begin 23839 -- Normalization is performed only when the original clause has 23840 -- more than one input. Multiple inputs appear as an aggregate. 23841 23842 if Nkind (Inputs) = N_Aggregate then 23843 Last_Input := Last (Expressions (Inputs)); 23844 23845 -- Create a new clause for each input 23846 23847 Input := First (Expressions (Inputs)); 23848 while Present (Input) loop 23849 Next_Input := Next (Input); 23850 23851 -- Unhook the current input from the original input list 23852 -- because it will be relocated to a new clause. 23853 23854 Remove (Input); 23855 23856 -- Special processing for the last input. At this point the 23857 -- original aggregate has been stripped down to one element. 23858 -- Replace the aggregate by the element itself. 23859 23860 if Input = Last_Input then 23861 Rewrite (Inputs, Input); 23862 23863 -- Generate a clause of the form: 23864 -- Output => Input 23865 23866 else 23867 New_Clause := 23868 Make_Component_Association (Loc, 23869 Choices => New_Copy_List_Tree (Output), 23870 Expression => Input); 23871 23872 -- The new clause contains replicated content that has 23873 -- already been analyzed, mark the clause as analyzed. 23874 23875 Set_Analyzed (New_Clause); 23876 Insert_After (Clause, New_Clause); 23877 end if; 23878 23879 Input := Next_Input; 23880 end loop; 23881 end if; 23882 end Normalize_Inputs; 23883 23884 ----------------------- 23885 -- Normalize_Outputs -- 23886 ----------------------- 23887 23888 procedure Normalize_Outputs (Clause : Node_Id) is 23889 Inputs : constant Node_Id := Expression (Clause); 23890 Loc : constant Source_Ptr := Sloc (Clause); 23891 Outputs : constant Node_Id := First (Choices (Clause)); 23892 Last_Output : Node_Id; 23893 New_Clause : Node_Id; 23894 Next_Output : Node_Id; 23895 Output : Node_Id; 23896 23897 begin 23898 -- Multiple outputs appear as an aggregate. Nothing to do when 23899 -- the clause has exactly one output. 23900 23901 if Nkind (Outputs) = N_Aggregate then 23902 Last_Output := Last (Expressions (Outputs)); 23903 23904 -- Create a clause for each output. Note that each time a new 23905 -- clause is created, the original output list slowly shrinks 23906 -- until there is one item left. 23907 23908 Output := First (Expressions (Outputs)); 23909 while Present (Output) loop 23910 Next_Output := Next (Output); 23911 23912 -- Unhook the output from the original output list as it 23913 -- will be relocated to a new clause. 23914 23915 Remove (Output); 23916 23917 -- Special processing for the last output. At this point 23918 -- the original aggregate has been stripped down to one 23919 -- element. Replace the aggregate by the element itself. 23920 23921 if Output = Last_Output then 23922 Rewrite (Outputs, Output); 23923 23924 else 23925 -- Generate a clause of the form: 23926 -- (Output => Inputs) 23927 23928 New_Clause := 23929 Make_Component_Association (Loc, 23930 Choices => New_List (Output), 23931 Expression => New_Copy_Tree (Inputs)); 23932 23933 -- The new clause contains replicated content that has 23934 -- already been analyzed. There is not need to reanalyze 23935 -- them. 23936 23937 Set_Analyzed (New_Clause); 23938 Insert_After (Clause, New_Clause); 23939 end if; 23940 23941 Output := Next_Output; 23942 end loop; 23943 end if; 23944 end Normalize_Outputs; 23945 23946 -- Local variables 23947 23948 Clause : Node_Id; 23949 23950 -- Start of processing for Normalize_Clauses 23951 23952 begin 23953 Clause := First (Clauses); 23954 while Present (Clause) loop 23955 Normalize_Outputs (Clause); 23956 Next (Clause); 23957 end loop; 23958 23959 Clause := First (Clauses); 23960 while Present (Clause) loop 23961 Normalize_Inputs (Clause); 23962 Next (Clause); 23963 end loop; 23964 end Normalize_Clauses; 23965 23966 -------------------------- 23967 -- Report_Extra_Clauses -- 23968 -------------------------- 23969 23970 procedure Report_Extra_Clauses is 23971 Clause : Node_Id; 23972 23973 begin 23974 -- Do not perform this check in an instance because it was already 23975 -- performed successfully in the generic template. 23976 23977 if Is_Generic_Instance (Spec_Id) then 23978 null; 23979 23980 elsif Present (Refinements) then 23981 Clause := First (Refinements); 23982 while Present (Clause) loop 23983 23984 -- Do not complain about a null input refinement, since a null 23985 -- input legitimately matches anything. 23986 23987 if Nkind (Clause) = N_Component_Association 23988 and then Nkind (Expression (Clause)) = N_Null 23989 then 23990 null; 23991 23992 else 23993 SPARK_Msg_N 23994 ("unmatched or extra clause in dependence refinement", 23995 Clause); 23996 end if; 23997 23998 Next (Clause); 23999 end loop; 24000 end if; 24001 end Report_Extra_Clauses; 24002 24003 -- Local variables 24004 24005 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 24006 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 24007 Errors : constant Nat := Serious_Errors_Detected; 24008 Clause : Node_Id; 24009 Deps : Node_Id; 24010 Dummy : Boolean; 24011 Refs : Node_Id; 24012 24013 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part 24014 24015 begin 24016 -- Do not analyze the pragma multiple times 24017 24018 if Is_Analyzed_Pragma (N) then 24019 return; 24020 end if; 24021 24022 Spec_Id := Unique_Defining_Entity (Body_Decl); 24023 24024 -- Use the anonymous object as the proper spec when Refined_Depends 24025 -- applies to the body of a single task type. The object carries the 24026 -- proper Chars as well as all non-refined versions of pragmas. 24027 24028 if Is_Single_Concurrent_Type (Spec_Id) then 24029 Spec_Id := Anonymous_Object (Spec_Id); 24030 end if; 24031 24032 Depends := Get_Pragma (Spec_Id, Pragma_Depends); 24033 24034 -- Subprogram declarations lacks pragma Depends. Refined_Depends is 24035 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)). 24036 24037 if No (Depends) then 24038 SPARK_Msg_NE 24039 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " 24040 & "& lacks aspect or pragma Depends"), N, Spec_Id); 24041 goto Leave; 24042 end if; 24043 24044 Deps := Expression (Get_Argument (Depends, Spec_Id)); 24045 24046 -- A null dependency relation renders the refinement useless because it 24047 -- cannot possibly mention abstract states with visible refinement. Note 24048 -- that the inverse is not true as states may be refined to null 24049 -- (SPARK RM 7.2.5(2)). 24050 24051 if Nkind (Deps) = N_Null then 24052 SPARK_Msg_NE 24053 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " 24054 & "depend on abstract state with visible refinement"), N, Spec_Id); 24055 goto Leave; 24056 end if; 24057 24058 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends. 24059 -- This ensures that the categorization of all refined dependency items 24060 -- is consistent with their role. 24061 24062 Analyze_Depends_In_Decl_Part (N); 24063 24064 -- Do not match dependencies against refinements if Refined_Depends is 24065 -- illegal to avoid emitting misleading error. 24066 24067 if Serious_Errors_Detected = Errors then 24068 24069 -- The related subprogram lacks pragma [Refined_]Global. Synthesize 24070 -- the inputs and outputs of the subprogram spec and body to verify 24071 -- the use of states with visible refinement and their constituents. 24072 24073 if No (Get_Pragma (Spec_Id, Pragma_Global)) 24074 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global)) 24075 then 24076 Collect_Subprogram_Inputs_Outputs 24077 (Subp_Id => Spec_Id, 24078 Synthesize => True, 24079 Subp_Inputs => Spec_Inputs, 24080 Subp_Outputs => Spec_Outputs, 24081 Global_Seen => Dummy); 24082 24083 Collect_Subprogram_Inputs_Outputs 24084 (Subp_Id => Body_Id, 24085 Synthesize => True, 24086 Subp_Inputs => Body_Inputs, 24087 Subp_Outputs => Body_Outputs, 24088 Global_Seen => Dummy); 24089 24090 -- For an output state with a visible refinement, ensure that all 24091 -- constituents appear as outputs in the dependency refinement. 24092 24093 Check_Output_States; 24094 end if; 24095 24096 -- Matching is disabled in ASIS because clauses are not normalized as 24097 -- this is a tree altering activity similar to expansion. 24098 24099 if ASIS_Mode then 24100 goto Leave; 24101 end if; 24102 24103 -- Multiple dependency clauses appear as component associations of an 24104 -- aggregate. Note that the clauses are copied because the algorithm 24105 -- modifies them and this should not be visible in Depends. 24106 24107 pragma Assert (Nkind (Deps) = N_Aggregate); 24108 Dependencies := New_Copy_List_Tree (Component_Associations (Deps)); 24109 Normalize_Clauses (Dependencies); 24110 24111 Refs := Expression (Get_Argument (N, Spec_Id)); 24112 24113 if Nkind (Refs) = N_Null then 24114 Refinements := No_List; 24115 24116 -- Multiple dependency clauses appear as component associations of an 24117 -- aggregate. Note that the clauses are copied because the algorithm 24118 -- modifies them and this should not be visible in Refined_Depends. 24119 24120 else pragma Assert (Nkind (Refs) = N_Aggregate); 24121 Refinements := New_Copy_List_Tree (Component_Associations (Refs)); 24122 Normalize_Clauses (Refinements); 24123 end if; 24124 24125 -- At this point the clauses of pragmas Depends and Refined_Depends 24126 -- have been normalized into simple dependencies between one output 24127 -- and one input. Examine all clauses of pragma Depends looking for 24128 -- matching clauses in pragma Refined_Depends. 24129 24130 Clause := First (Dependencies); 24131 while Present (Clause) loop 24132 Check_Dependency_Clause (Clause); 24133 Next (Clause); 24134 end loop; 24135 24136 if Serious_Errors_Detected = Errors then 24137 Report_Extra_Clauses; 24138 end if; 24139 end if; 24140 24141 <<Leave>> 24142 Set_Is_Analyzed_Pragma (N); 24143 end Analyze_Refined_Depends_In_Decl_Part; 24144 24145 ----------------------------------------- 24146 -- Analyze_Refined_Global_In_Decl_Part -- 24147 ----------------------------------------- 24148 24149 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is 24150 Global : Node_Id; 24151 -- The corresponding Global pragma 24152 24153 Has_In_State : Boolean := False; 24154 Has_In_Out_State : Boolean := False; 24155 Has_Out_State : Boolean := False; 24156 Has_Proof_In_State : Boolean := False; 24157 -- These flags are set when the corresponding Global pragma has a state 24158 -- of mode Input, In_Out, Output or Proof_In respectively with a visible 24159 -- refinement. 24160 24161 Has_Null_State : Boolean := False; 24162 -- This flag is set when the corresponding Global pragma has at least 24163 -- one state with a null refinement. 24164 24165 In_Constits : Elist_Id := No_Elist; 24166 In_Out_Constits : Elist_Id := No_Elist; 24167 Out_Constits : Elist_Id := No_Elist; 24168 Proof_In_Constits : Elist_Id := No_Elist; 24169 -- These lists contain the entities of all Input, In_Out, Output and 24170 -- Proof_In constituents that appear in Refined_Global and participate 24171 -- in state refinement. 24172 24173 In_Items : Elist_Id := No_Elist; 24174 In_Out_Items : Elist_Id := No_Elist; 24175 Out_Items : Elist_Id := No_Elist; 24176 Proof_In_Items : Elist_Id := No_Elist; 24177 -- These list contain the entities of all Input, In_Out, Output and 24178 -- Proof_In items defined in the corresponding Global pragma. 24179 24180 Spec_Id : Entity_Id; 24181 -- The entity of the subprogram subject to pragma Refined_Global 24182 24183 States : Elist_Id := No_Elist; 24184 -- A list of all states with visible refinement found in pragma Global 24185 24186 procedure Check_In_Out_States; 24187 -- Determine whether the corresponding Global pragma mentions In_Out 24188 -- states with visible refinement and if so, ensure that one of the 24189 -- following completions apply to the constituents of the state: 24190 -- 1) there is at least one constituent of mode In_Out 24191 -- 2) there is at least one Input and one Output constituent 24192 -- 3) not all constituents are present and one of them is of mode 24193 -- Output. 24194 -- This routine may remove elements from In_Constits, In_Out_Constits, 24195 -- Out_Constits and Proof_In_Constits. 24196 24197 procedure Check_Input_States; 24198 -- Determine whether the corresponding Global pragma mentions Input 24199 -- states with visible refinement and if so, ensure that at least one of 24200 -- its constituents appears as an Input item in Refined_Global. 24201 -- This routine may remove elements from In_Constits, In_Out_Constits, 24202 -- Out_Constits and Proof_In_Constits. 24203 24204 procedure Check_Output_States; 24205 -- Determine whether the corresponding Global pragma mentions Output 24206 -- states with visible refinement and if so, ensure that all of its 24207 -- constituents appear as Output items in Refined_Global. 24208 -- This routine may remove elements from In_Constits, In_Out_Constits, 24209 -- Out_Constits and Proof_In_Constits. 24210 24211 procedure Check_Proof_In_States; 24212 -- Determine whether the corresponding Global pragma mentions Proof_In 24213 -- states with visible refinement and if so, ensure that at least one of 24214 -- its constituents appears as a Proof_In item in Refined_Global. 24215 -- This routine may remove elements from In_Constits, In_Out_Constits, 24216 -- Out_Constits and Proof_In_Constits. 24217 24218 procedure Check_Refined_Global_List 24219 (List : Node_Id; 24220 Global_Mode : Name_Id := Name_Input); 24221 -- Verify the legality of a single global list declaration. Global_Mode 24222 -- denotes the current mode in effect. 24223 24224 procedure Collect_Global_Items 24225 (List : Node_Id; 24226 Mode : Name_Id := Name_Input); 24227 -- Gather all input, in out, output and Proof_In items from node List 24228 -- and separate them in lists In_Items, In_Out_Items, Out_Items and 24229 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State 24230 -- and Has_Proof_In_State are set when there is at least one abstract 24231 -- state with visible refinement available in the corresponding mode. 24232 -- Flag Has_Null_State is set when at least state has a null refinement. 24233 -- Mode enotes the current global mode in effect. 24234 24235 function Present_Then_Remove 24236 (List : Elist_Id; 24237 Item : Entity_Id) return Boolean; 24238 -- Search List for a particular entity Item. If Item has been found, 24239 -- remove it from List. This routine is used to strip lists In_Constits, 24240 -- In_Out_Constits and Out_Constits of valid constituents. 24241 24242 procedure Report_Extra_Constituents; 24243 -- Emit an error for each constituent found in lists In_Constits, 24244 -- In_Out_Constits and Out_Constits. 24245 24246 ------------------------- 24247 -- Check_In_Out_States -- 24248 ------------------------- 24249 24250 procedure Check_In_Out_States is 24251 procedure Check_Constituent_Usage (State_Id : Entity_Id); 24252 -- Determine whether one of the following coverage scenarios is in 24253 -- effect: 24254 -- 1) there is at least one constituent of mode In_Out 24255 -- 2) there is at least one Input and one Output constituent 24256 -- 3) not all constituents are present and one of them is of mode 24257 -- Output. 24258 -- If this is not the case, emit an error. 24259 24260 ----------------------------- 24261 -- Check_Constituent_Usage -- 24262 ----------------------------- 24263 24264 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 24265 Constit_Elmt : Elmt_Id; 24266 Constit_Id : Entity_Id; 24267 Has_Missing : Boolean := False; 24268 In_Out_Seen : Boolean := False; 24269 In_Seen : Boolean := False; 24270 Out_Seen : Boolean := False; 24271 24272 begin 24273 -- Process all the constituents of the state and note their modes 24274 -- within the global refinement. 24275 24276 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 24277 while Present (Constit_Elmt) loop 24278 Constit_Id := Node (Constit_Elmt); 24279 24280 if Present_Then_Remove (In_Constits, Constit_Id) then 24281 In_Seen := True; 24282 24283 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then 24284 In_Out_Seen := True; 24285 24286 elsif Present_Then_Remove (Out_Constits, Constit_Id) then 24287 Out_Seen := True; 24288 24289 -- A Proof_In constituent cannot participate in the completion 24290 -- of an Output state (SPARK RM 7.2.4(5)). 24291 24292 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) then 24293 Error_Msg_Name_1 := Chars (State_Id); 24294 SPARK_Msg_NE 24295 ("constituent & of state % must have mode Input, In_Out " 24296 & "or Output in global refinement", N, Constit_Id); 24297 24298 else 24299 Has_Missing := True; 24300 end if; 24301 24302 Next_Elmt (Constit_Elmt); 24303 end loop; 24304 24305 -- A single In_Out constituent is a valid completion 24306 24307 if In_Out_Seen then 24308 null; 24309 24310 -- A pair of one Input and one Output constituent is a valid 24311 -- completion. 24312 24313 elsif In_Seen and Out_Seen then 24314 null; 24315 24316 -- A single Output constituent is a valid completion only when 24317 -- some of the other constituents are missing (SPARK RM 7.2.4(5)). 24318 24319 elsif Out_Seen and Has_Missing then 24320 null; 24321 24322 -- The state lacks a completion 24323 24324 elsif not In_Seen and not In_Out_Seen and not Out_Seen then 24325 SPARK_Msg_NE 24326 ("missing global refinement of state &", N, State_Id); 24327 24328 -- Otherwise the state has a malformed completion where at least 24329 -- one of the constituents has a different mode. 24330 24331 else 24332 SPARK_Msg_NE 24333 ("global refinement of state & redefines the mode of its " 24334 & "constituents", N, State_Id); 24335 end if; 24336 end Check_Constituent_Usage; 24337 24338 -- Local variables 24339 24340 Item_Elmt : Elmt_Id; 24341 Item_Id : Entity_Id; 24342 24343 -- Start of processing for Check_In_Out_States 24344 24345 begin 24346 -- Do not perform this check in an instance because it was already 24347 -- performed successfully in the generic template. 24348 24349 if Is_Generic_Instance (Spec_Id) then 24350 null; 24351 24352 -- Inspect the In_Out items of the corresponding Global pragma 24353 -- looking for a state with a visible refinement. 24354 24355 elsif Has_In_Out_State and then Present (In_Out_Items) then 24356 Item_Elmt := First_Elmt (In_Out_Items); 24357 while Present (Item_Elmt) loop 24358 Item_Id := Node (Item_Elmt); 24359 24360 -- Ensure that one of the three coverage variants is satisfied 24361 24362 if Ekind (Item_Id) = E_Abstract_State 24363 and then Has_Non_Null_Visible_Refinement (Item_Id) 24364 then 24365 Check_Constituent_Usage (Item_Id); 24366 end if; 24367 24368 Next_Elmt (Item_Elmt); 24369 end loop; 24370 end if; 24371 end Check_In_Out_States; 24372 24373 ------------------------ 24374 -- Check_Input_States -- 24375 ------------------------ 24376 24377 procedure Check_Input_States is 24378 procedure Check_Constituent_Usage (State_Id : Entity_Id); 24379 -- Determine whether at least one constituent of state State_Id with 24380 -- visible refinement is used and has mode Input. Ensure that the 24381 -- remaining constituents do not have In_Out, Output or Proof_In 24382 -- modes. 24383 24384 ----------------------------- 24385 -- Check_Constituent_Usage -- 24386 ----------------------------- 24387 24388 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 24389 Constit_Elmt : Elmt_Id; 24390 Constit_Id : Entity_Id; 24391 In_Seen : Boolean := False; 24392 24393 begin 24394 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 24395 while Present (Constit_Elmt) loop 24396 Constit_Id := Node (Constit_Elmt); 24397 24398 -- At least one of the constituents appears as an Input 24399 24400 if Present_Then_Remove (In_Constits, Constit_Id) then 24401 In_Seen := True; 24402 24403 -- The constituent appears in the global refinement, but has 24404 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)). 24405 24406 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) 24407 or else Present_Then_Remove (Out_Constits, Constit_Id) 24408 or else Present_Then_Remove (Proof_In_Constits, Constit_Id) 24409 then 24410 Error_Msg_Name_1 := Chars (State_Id); 24411 SPARK_Msg_NE 24412 ("constituent & of state % must have mode Input in global " 24413 & "refinement", N, Constit_Id); 24414 end if; 24415 24416 Next_Elmt (Constit_Elmt); 24417 end loop; 24418 24419 -- Not one of the constituents appeared as Input 24420 24421 if not In_Seen then 24422 SPARK_Msg_NE 24423 ("global refinement of state & must include at least one " 24424 & "constituent of mode Input", N, State_Id); 24425 end if; 24426 end Check_Constituent_Usage; 24427 24428 -- Local variables 24429 24430 Item_Elmt : Elmt_Id; 24431 Item_Id : Entity_Id; 24432 24433 -- Start of processing for Check_Input_States 24434 24435 begin 24436 -- Do not perform this check in an instance because it was already 24437 -- performed successfully in the generic template. 24438 24439 if Is_Generic_Instance (Spec_Id) then 24440 null; 24441 24442 -- Inspect the Input items of the corresponding Global pragma looking 24443 -- for a state with a visible refinement. 24444 24445 elsif Has_In_State and then Present (In_Items) then 24446 Item_Elmt := First_Elmt (In_Items); 24447 while Present (Item_Elmt) loop 24448 Item_Id := Node (Item_Elmt); 24449 24450 -- Ensure that at least one of the constituents is utilized and 24451 -- is of mode Input. 24452 24453 if Ekind (Item_Id) = E_Abstract_State 24454 and then Has_Non_Null_Visible_Refinement (Item_Id) 24455 then 24456 Check_Constituent_Usage (Item_Id); 24457 end if; 24458 24459 Next_Elmt (Item_Elmt); 24460 end loop; 24461 end if; 24462 end Check_Input_States; 24463 24464 ------------------------- 24465 -- Check_Output_States -- 24466 ------------------------- 24467 24468 procedure Check_Output_States is 24469 procedure Check_Constituent_Usage (State_Id : Entity_Id); 24470 -- Determine whether all constituents of state State_Id with visible 24471 -- refinement are used and have mode Output. Emit an error if this is 24472 -- not the case. 24473 24474 ----------------------------- 24475 -- Check_Constituent_Usage -- 24476 ----------------------------- 24477 24478 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 24479 Constit_Elmt : Elmt_Id; 24480 Constit_Id : Entity_Id; 24481 Posted : Boolean := False; 24482 24483 begin 24484 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 24485 while Present (Constit_Elmt) loop 24486 Constit_Id := Node (Constit_Elmt); 24487 24488 if Present_Then_Remove (Out_Constits, Constit_Id) then 24489 null; 24490 24491 -- The constituent appears in the global refinement, but has 24492 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)). 24493 24494 elsif Present_Then_Remove (In_Constits, Constit_Id) 24495 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 24496 or else Present_Then_Remove (Proof_In_Constits, Constit_Id) 24497 then 24498 Error_Msg_Name_1 := Chars (State_Id); 24499 SPARK_Msg_NE 24500 ("constituent & of state % must have mode Output in " 24501 & "global refinement", N, Constit_Id); 24502 24503 -- The constituent is altogether missing (SPARK RM 7.2.5(3)) 24504 24505 else 24506 if not Posted then 24507 Posted := True; 24508 SPARK_Msg_NE 24509 ("output state & must be replaced by all its " 24510 & "constituents in global refinement", N, State_Id); 24511 end if; 24512 24513 SPARK_Msg_NE 24514 ("\constituent & is missing in output list", 24515 N, Constit_Id); 24516 end if; 24517 24518 Next_Elmt (Constit_Elmt); 24519 end loop; 24520 end Check_Constituent_Usage; 24521 24522 -- Local variables 24523 24524 Item_Elmt : Elmt_Id; 24525 Item_Id : Entity_Id; 24526 24527 -- Start of processing for Check_Output_States 24528 24529 begin 24530 -- Do not perform this check in an instance because it was already 24531 -- performed successfully in the generic template. 24532 24533 if Is_Generic_Instance (Spec_Id) then 24534 null; 24535 24536 -- Inspect the Output items of the corresponding Global pragma 24537 -- looking for a state with a visible refinement. 24538 24539 elsif Has_Out_State and then Present (Out_Items) then 24540 Item_Elmt := First_Elmt (Out_Items); 24541 while Present (Item_Elmt) loop 24542 Item_Id := Node (Item_Elmt); 24543 24544 -- Ensure that all of the constituents are utilized and they 24545 -- have mode Output. 24546 24547 if Ekind (Item_Id) = E_Abstract_State 24548 and then Has_Non_Null_Visible_Refinement (Item_Id) 24549 then 24550 Check_Constituent_Usage (Item_Id); 24551 end if; 24552 24553 Next_Elmt (Item_Elmt); 24554 end loop; 24555 end if; 24556 end Check_Output_States; 24557 24558 --------------------------- 24559 -- Check_Proof_In_States -- 24560 --------------------------- 24561 24562 procedure Check_Proof_In_States is 24563 procedure Check_Constituent_Usage (State_Id : Entity_Id); 24564 -- Determine whether at least one constituent of state State_Id with 24565 -- visible refinement is used and has mode Proof_In. Ensure that the 24566 -- remaining constituents do not have Input, In_Out or Output modes. 24567 24568 ----------------------------- 24569 -- Check_Constituent_Usage -- 24570 ----------------------------- 24571 24572 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 24573 Constit_Elmt : Elmt_Id; 24574 Constit_Id : Entity_Id; 24575 Proof_In_Seen : Boolean := False; 24576 24577 begin 24578 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 24579 while Present (Constit_Elmt) loop 24580 Constit_Id := Node (Constit_Elmt); 24581 24582 -- At least one of the constituents appears as Proof_In 24583 24584 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then 24585 Proof_In_Seen := True; 24586 24587 -- The constituent appears in the global refinement, but has 24588 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)). 24589 24590 elsif Present_Then_Remove (In_Constits, Constit_Id) 24591 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 24592 or else Present_Then_Remove (Out_Constits, Constit_Id) 24593 then 24594 Error_Msg_Name_1 := Chars (State_Id); 24595 SPARK_Msg_NE 24596 ("constituent & of state % must have mode Proof_In in " 24597 & "global refinement", N, Constit_Id); 24598 end if; 24599 24600 Next_Elmt (Constit_Elmt); 24601 end loop; 24602 24603 -- Not one of the constituents appeared as Proof_In 24604 24605 if not Proof_In_Seen then 24606 SPARK_Msg_NE 24607 ("global refinement of state & must include at least one " 24608 & "constituent of mode Proof_In", N, State_Id); 24609 end if; 24610 end Check_Constituent_Usage; 24611 24612 -- Local variables 24613 24614 Item_Elmt : Elmt_Id; 24615 Item_Id : Entity_Id; 24616 24617 -- Start of processing for Check_Proof_In_States 24618 24619 begin 24620 -- Do not perform this check in an instance because it was already 24621 -- performed successfully in the generic template. 24622 24623 if Is_Generic_Instance (Spec_Id) then 24624 null; 24625 24626 -- Inspect the Proof_In items of the corresponding Global pragma 24627 -- looking for a state with a visible refinement. 24628 24629 elsif Has_Proof_In_State and then Present (Proof_In_Items) then 24630 Item_Elmt := First_Elmt (Proof_In_Items); 24631 while Present (Item_Elmt) loop 24632 Item_Id := Node (Item_Elmt); 24633 24634 -- Ensure that at least one of the constituents is utilized and 24635 -- is of mode Proof_In 24636 24637 if Ekind (Item_Id) = E_Abstract_State 24638 and then Has_Non_Null_Visible_Refinement (Item_Id) 24639 then 24640 Check_Constituent_Usage (Item_Id); 24641 end if; 24642 24643 Next_Elmt (Item_Elmt); 24644 end loop; 24645 end if; 24646 end Check_Proof_In_States; 24647 24648 ------------------------------- 24649 -- Check_Refined_Global_List -- 24650 ------------------------------- 24651 24652 procedure Check_Refined_Global_List 24653 (List : Node_Id; 24654 Global_Mode : Name_Id := Name_Input) 24655 is 24656 procedure Check_Refined_Global_Item 24657 (Item : Node_Id; 24658 Global_Mode : Name_Id); 24659 -- Verify the legality of a single global item declaration. Parameter 24660 -- Global_Mode denotes the current mode in effect. 24661 24662 ------------------------------- 24663 -- Check_Refined_Global_Item -- 24664 ------------------------------- 24665 24666 procedure Check_Refined_Global_Item 24667 (Item : Node_Id; 24668 Global_Mode : Name_Id) 24669 is 24670 Item_Id : constant Entity_Id := Entity_Of (Item); 24671 24672 procedure Inconsistent_Mode_Error (Expect : Name_Id); 24673 -- Issue a common error message for all mode mismatches. Expect 24674 -- denotes the expected mode. 24675 24676 ----------------------------- 24677 -- Inconsistent_Mode_Error -- 24678 ----------------------------- 24679 24680 procedure Inconsistent_Mode_Error (Expect : Name_Id) is 24681 begin 24682 SPARK_Msg_NE 24683 ("global item & has inconsistent modes", Item, Item_Id); 24684 24685 Error_Msg_Name_1 := Global_Mode; 24686 Error_Msg_Name_2 := Expect; 24687 SPARK_Msg_N ("\expected mode %, found mode %", Item); 24688 end Inconsistent_Mode_Error; 24689 24690 -- Start of processing for Check_Refined_Global_Item 24691 24692 begin 24693 -- When the state or object acts as a constituent of another 24694 -- state with a visible refinement, collect it for the state 24695 -- completeness checks performed later on. Note that the item 24696 -- acts as a constituent only when the encapsulating state is 24697 -- present in pragma Global. 24698 24699 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable) 24700 and then Present (Encapsulating_State (Item_Id)) 24701 and then Has_Visible_Refinement (Encapsulating_State (Item_Id)) 24702 and then Contains (States, Encapsulating_State (Item_Id)) 24703 then 24704 if Global_Mode = Name_Input then 24705 Append_New_Elmt (Item_Id, In_Constits); 24706 24707 elsif Global_Mode = Name_In_Out then 24708 Append_New_Elmt (Item_Id, In_Out_Constits); 24709 24710 elsif Global_Mode = Name_Output then 24711 Append_New_Elmt (Item_Id, Out_Constits); 24712 24713 elsif Global_Mode = Name_Proof_In then 24714 Append_New_Elmt (Item_Id, Proof_In_Constits); 24715 end if; 24716 24717 -- When not a constituent, ensure that both occurrences of the 24718 -- item in pragmas Global and Refined_Global match. 24719 24720 elsif Contains (In_Items, Item_Id) then 24721 if Global_Mode /= Name_Input then 24722 Inconsistent_Mode_Error (Name_Input); 24723 end if; 24724 24725 elsif Contains (In_Out_Items, Item_Id) then 24726 if Global_Mode /= Name_In_Out then 24727 Inconsistent_Mode_Error (Name_In_Out); 24728 end if; 24729 24730 elsif Contains (Out_Items, Item_Id) then 24731 if Global_Mode /= Name_Output then 24732 Inconsistent_Mode_Error (Name_Output); 24733 end if; 24734 24735 elsif Contains (Proof_In_Items, Item_Id) then 24736 null; 24737 24738 -- The item does not appear in the corresponding Global pragma, 24739 -- it must be an extra (SPARK RM 7.2.4(3)). 24740 24741 else 24742 SPARK_Msg_NE ("extra global item &", Item, Item_Id); 24743 end if; 24744 end Check_Refined_Global_Item; 24745 24746 -- Local variables 24747 24748 Item : Node_Id; 24749 24750 -- Start of processing for Check_Refined_Global_List 24751 24752 begin 24753 -- Do not perform this check in an instance because it was already 24754 -- performed successfully in the generic template. 24755 24756 if Is_Generic_Instance (Spec_Id) then 24757 null; 24758 24759 elsif Nkind (List) = N_Null then 24760 null; 24761 24762 -- Single global item declaration 24763 24764 elsif Nkind_In (List, N_Expanded_Name, 24765 N_Identifier, 24766 N_Selected_Component) 24767 then 24768 Check_Refined_Global_Item (List, Global_Mode); 24769 24770 -- Simple global list or moded global list declaration 24771 24772 elsif Nkind (List) = N_Aggregate then 24773 24774 -- The declaration of a simple global list appear as a collection 24775 -- of expressions. 24776 24777 if Present (Expressions (List)) then 24778 Item := First (Expressions (List)); 24779 while Present (Item) loop 24780 Check_Refined_Global_Item (Item, Global_Mode); 24781 Next (Item); 24782 end loop; 24783 24784 -- The declaration of a moded global list appears as a collection 24785 -- of component associations where individual choices denote 24786 -- modes. 24787 24788 elsif Present (Component_Associations (List)) then 24789 Item := First (Component_Associations (List)); 24790 while Present (Item) loop 24791 Check_Refined_Global_List 24792 (List => Expression (Item), 24793 Global_Mode => Chars (First (Choices (Item)))); 24794 24795 Next (Item); 24796 end loop; 24797 24798 -- Invalid tree 24799 24800 else 24801 raise Program_Error; 24802 end if; 24803 24804 -- Invalid list 24805 24806 else 24807 raise Program_Error; 24808 end if; 24809 end Check_Refined_Global_List; 24810 24811 -------------------------- 24812 -- Collect_Global_Items -- 24813 -------------------------- 24814 24815 procedure Collect_Global_Items 24816 (List : Node_Id; 24817 Mode : Name_Id := Name_Input) 24818 is 24819 procedure Collect_Global_Item 24820 (Item : Node_Id; 24821 Item_Mode : Name_Id); 24822 -- Add a single item to the appropriate list. Item_Mode denotes the 24823 -- current mode in effect. 24824 24825 ------------------------- 24826 -- Collect_Global_Item -- 24827 ------------------------- 24828 24829 procedure Collect_Global_Item 24830 (Item : Node_Id; 24831 Item_Mode : Name_Id) 24832 is 24833 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item)); 24834 -- The above handles abstract views of variables and states built 24835 -- for limited with clauses. 24836 24837 begin 24838 -- Signal that the global list contains at least one abstract 24839 -- state with a visible refinement. Note that the refinement may 24840 -- be null in which case there are no constituents. 24841 24842 if Ekind (Item_Id) = E_Abstract_State then 24843 if Has_Null_Visible_Refinement (Item_Id) then 24844 Has_Null_State := True; 24845 24846 elsif Has_Non_Null_Visible_Refinement (Item_Id) then 24847 Append_New_Elmt (Item_Id, States); 24848 24849 if Item_Mode = Name_Input then 24850 Has_In_State := True; 24851 elsif Item_Mode = Name_In_Out then 24852 Has_In_Out_State := True; 24853 elsif Item_Mode = Name_Output then 24854 Has_Out_State := True; 24855 elsif Item_Mode = Name_Proof_In then 24856 Has_Proof_In_State := True; 24857 end if; 24858 end if; 24859 end if; 24860 24861 -- Add the item to the proper list 24862 24863 if Item_Mode = Name_Input then 24864 Append_New_Elmt (Item_Id, In_Items); 24865 elsif Item_Mode = Name_In_Out then 24866 Append_New_Elmt (Item_Id, In_Out_Items); 24867 elsif Item_Mode = Name_Output then 24868 Append_New_Elmt (Item_Id, Out_Items); 24869 elsif Item_Mode = Name_Proof_In then 24870 Append_New_Elmt (Item_Id, Proof_In_Items); 24871 end if; 24872 end Collect_Global_Item; 24873 24874 -- Local variables 24875 24876 Item : Node_Id; 24877 24878 -- Start of processing for Collect_Global_Items 24879 24880 begin 24881 if Nkind (List) = N_Null then 24882 null; 24883 24884 -- Single global item declaration 24885 24886 elsif Nkind_In (List, N_Expanded_Name, 24887 N_Identifier, 24888 N_Selected_Component) 24889 then 24890 Collect_Global_Item (List, Mode); 24891 24892 -- Single global list or moded global list declaration 24893 24894 elsif Nkind (List) = N_Aggregate then 24895 24896 -- The declaration of a simple global list appear as a collection 24897 -- of expressions. 24898 24899 if Present (Expressions (List)) then 24900 Item := First (Expressions (List)); 24901 while Present (Item) loop 24902 Collect_Global_Item (Item, Mode); 24903 Next (Item); 24904 end loop; 24905 24906 -- The declaration of a moded global list appears as a collection 24907 -- of component associations where individual choices denote mode. 24908 24909 elsif Present (Component_Associations (List)) then 24910 Item := First (Component_Associations (List)); 24911 while Present (Item) loop 24912 Collect_Global_Items 24913 (List => Expression (Item), 24914 Mode => Chars (First (Choices (Item)))); 24915 24916 Next (Item); 24917 end loop; 24918 24919 -- Invalid tree 24920 24921 else 24922 raise Program_Error; 24923 end if; 24924 24925 -- To accomodate partial decoration of disabled SPARK features, this 24926 -- routine may be called with illegal input. If this is the case, do 24927 -- not raise Program_Error. 24928 24929 else 24930 null; 24931 end if; 24932 end Collect_Global_Items; 24933 24934 ------------------------- 24935 -- Present_Then_Remove -- 24936 ------------------------- 24937 24938 function Present_Then_Remove 24939 (List : Elist_Id; 24940 Item : Entity_Id) return Boolean 24941 is 24942 Elmt : Elmt_Id; 24943 24944 begin 24945 if Present (List) then 24946 Elmt := First_Elmt (List); 24947 while Present (Elmt) loop 24948 if Node (Elmt) = Item then 24949 Remove_Elmt (List, Elmt); 24950 return True; 24951 end if; 24952 24953 Next_Elmt (Elmt); 24954 end loop; 24955 end if; 24956 24957 return False; 24958 end Present_Then_Remove; 24959 24960 ------------------------------- 24961 -- Report_Extra_Constituents -- 24962 ------------------------------- 24963 24964 procedure Report_Extra_Constituents is 24965 procedure Report_Extra_Constituents_In_List (List : Elist_Id); 24966 -- Emit an error for every element of List 24967 24968 --------------------------------------- 24969 -- Report_Extra_Constituents_In_List -- 24970 --------------------------------------- 24971 24972 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is 24973 Constit_Elmt : Elmt_Id; 24974 24975 begin 24976 if Present (List) then 24977 Constit_Elmt := First_Elmt (List); 24978 while Present (Constit_Elmt) loop 24979 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt)); 24980 Next_Elmt (Constit_Elmt); 24981 end loop; 24982 end if; 24983 end Report_Extra_Constituents_In_List; 24984 24985 -- Start of processing for Report_Extra_Constituents 24986 24987 begin 24988 -- Do not perform this check in an instance because it was already 24989 -- performed successfully in the generic template. 24990 24991 if Is_Generic_Instance (Spec_Id) then 24992 null; 24993 24994 else 24995 Report_Extra_Constituents_In_List (In_Constits); 24996 Report_Extra_Constituents_In_List (In_Out_Constits); 24997 Report_Extra_Constituents_In_List (Out_Constits); 24998 Report_Extra_Constituents_In_List (Proof_In_Constits); 24999 end if; 25000 end Report_Extra_Constituents; 25001 25002 -- Local variables 25003 25004 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 25005 Errors : constant Nat := Serious_Errors_Detected; 25006 Items : Node_Id; 25007 25008 -- Start of processing for Analyze_Refined_Global_In_Decl_Part 25009 25010 begin 25011 -- Do not analyze the pragma multiple times 25012 25013 if Is_Analyzed_Pragma (N) then 25014 return; 25015 end if; 25016 25017 Spec_Id := Unique_Defining_Entity (Body_Decl); 25018 25019 -- Use the anonymous object as the proper spec when Refined_Global 25020 -- applies to the body of a single task type. The object carries the 25021 -- proper Chars as well as all non-refined versions of pragmas. 25022 25023 if Is_Single_Concurrent_Type (Spec_Id) then 25024 Spec_Id := Anonymous_Object (Spec_Id); 25025 end if; 25026 25027 Global := Get_Pragma (Spec_Id, Pragma_Global); 25028 Items := Expression (Get_Argument (N, Spec_Id)); 25029 25030 -- The subprogram declaration lacks pragma Global. This renders 25031 -- Refined_Global useless as there is nothing to refine. 25032 25033 if No (Global) then 25034 SPARK_Msg_NE 25035 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " 25036 & "& lacks aspect or pragma Global"), N, Spec_Id); 25037 goto Leave; 25038 end if; 25039 25040 -- Extract all relevant items from the corresponding Global pragma 25041 25042 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id))); 25043 25044 -- Package and subprogram bodies are instantiated individually in 25045 -- a separate compiler pass. Due to this mode of instantiation, the 25046 -- refinement of a state may no longer be visible when a subprogram 25047 -- body contract is instantiated. Since the generic template is legal, 25048 -- do not perform this check in the instance to circumvent this oddity. 25049 25050 if Is_Generic_Instance (Spec_Id) then 25051 null; 25052 25053 -- Non-instance case 25054 25055 else 25056 -- The corresponding Global pragma must mention at least one state 25057 -- witha visible refinement at the point Refined_Global is processed. 25058 -- States with null refinements need Refined_Global pragma 25059 -- (SPARK RM 7.2.4(2)). 25060 25061 if not Has_In_State 25062 and then not Has_In_Out_State 25063 and then not Has_Out_State 25064 and then not Has_Proof_In_State 25065 and then not Has_Null_State 25066 then 25067 SPARK_Msg_NE 25068 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " 25069 & "depend on abstract state with visible refinement"), 25070 N, Spec_Id); 25071 goto Leave; 25072 25073 -- The global refinement of inputs and outputs cannot be null when 25074 -- the corresponding Global pragma contains at least one item except 25075 -- in the case where we have states with null refinements. 25076 25077 elsif Nkind (Items) = N_Null 25078 and then 25079 (Present (In_Items) 25080 or else Present (In_Out_Items) 25081 or else Present (Out_Items) 25082 or else Present (Proof_In_Items)) 25083 and then not Has_Null_State 25084 then 25085 SPARK_Msg_NE 25086 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has " 25087 & "global items"), N, Spec_Id); 25088 goto Leave; 25089 end if; 25090 end if; 25091 25092 -- Analyze Refined_Global as if it behaved as a regular pragma Global. 25093 -- This ensures that the categorization of all refined global items is 25094 -- consistent with their role. 25095 25096 Analyze_Global_In_Decl_Part (N); 25097 25098 -- Perform all refinement checks with respect to completeness and mode 25099 -- matching. 25100 25101 if Serious_Errors_Detected = Errors then 25102 Check_Refined_Global_List (Items); 25103 end if; 25104 25105 -- For Input states with visible refinement, at least one constituent 25106 -- must be used as an Input in the global refinement. 25107 25108 if Serious_Errors_Detected = Errors then 25109 Check_Input_States; 25110 end if; 25111 25112 -- Verify all possible completion variants for In_Out states with 25113 -- visible refinement. 25114 25115 if Serious_Errors_Detected = Errors then 25116 Check_In_Out_States; 25117 end if; 25118 25119 -- For Output states with visible refinement, all constituents must be 25120 -- used as Outputs in the global refinement. 25121 25122 if Serious_Errors_Detected = Errors then 25123 Check_Output_States; 25124 end if; 25125 25126 -- For Proof_In states with visible refinement, at least one constituent 25127 -- must be used as Proof_In in the global refinement. 25128 25129 if Serious_Errors_Detected = Errors then 25130 Check_Proof_In_States; 25131 end if; 25132 25133 -- Emit errors for all constituents that belong to other states with 25134 -- visible refinement that do not appear in Global. 25135 25136 if Serious_Errors_Detected = Errors then 25137 Report_Extra_Constituents; 25138 end if; 25139 25140 <<Leave>> 25141 Set_Is_Analyzed_Pragma (N); 25142 end Analyze_Refined_Global_In_Decl_Part; 25143 25144 ---------------------------------------- 25145 -- Analyze_Refined_State_In_Decl_Part -- 25146 ---------------------------------------- 25147 25148 procedure Analyze_Refined_State_In_Decl_Part 25149 (N : Node_Id; 25150 Freeze_Id : Entity_Id := Empty) 25151 is 25152 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 25153 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 25154 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); 25155 25156 Available_States : Elist_Id := No_Elist; 25157 -- A list of all abstract states defined in the package declaration that 25158 -- are available for refinement. The list is used to report unrefined 25159 -- states. 25160 25161 Body_States : Elist_Id := No_Elist; 25162 -- A list of all hidden states that appear in the body of the related 25163 -- package. The list is used to report unused hidden states. 25164 25165 Constituents_Seen : Elist_Id := No_Elist; 25166 -- A list that contains all constituents processed so far. The list is 25167 -- used to detect multiple uses of the same constituent. 25168 25169 Freeze_Posted : Boolean := False; 25170 -- A flag that controls the output of a freezing-related error (see use 25171 -- below). 25172 25173 Refined_States_Seen : Elist_Id := No_Elist; 25174 -- A list that contains all refined states processed so far. The list is 25175 -- used to detect duplicate refinements. 25176 25177 procedure Analyze_Refinement_Clause (Clause : Node_Id); 25178 -- Perform full analysis of a single refinement clause 25179 25180 procedure Report_Unrefined_States (States : Elist_Id); 25181 -- Emit errors for all unrefined abstract states found in list States 25182 25183 ------------------------------- 25184 -- Analyze_Refinement_Clause -- 25185 ------------------------------- 25186 25187 procedure Analyze_Refinement_Clause (Clause : Node_Id) is 25188 AR_Constit : Entity_Id := Empty; 25189 AW_Constit : Entity_Id := Empty; 25190 ER_Constit : Entity_Id := Empty; 25191 EW_Constit : Entity_Id := Empty; 25192 -- The entities of external constituents that contain one of the 25193 -- following enabled properties: Async_Readers, Async_Writers, 25194 -- Effective_Reads and Effective_Writes. 25195 25196 External_Constit_Seen : Boolean := False; 25197 -- Flag used to mark when at least one external constituent is part 25198 -- of the state refinement. 25199 25200 Non_Null_Seen : Boolean := False; 25201 Null_Seen : Boolean := False; 25202 -- Flags used to detect multiple uses of null in a single clause or a 25203 -- mixture of null and non-null constituents. 25204 25205 Part_Of_Constits : Elist_Id := No_Elist; 25206 -- A list of all candidate constituents subject to indicator Part_Of 25207 -- where the encapsulating state is the current state. 25208 25209 State : Node_Id; 25210 State_Id : Entity_Id; 25211 -- The current state being refined 25212 25213 procedure Analyze_Constituent (Constit : Node_Id); 25214 -- Perform full analysis of a single constituent 25215 25216 procedure Check_External_Property 25217 (Prop_Nam : Name_Id; 25218 Enabled : Boolean; 25219 Constit : Entity_Id); 25220 -- Determine whether a property denoted by name Prop_Nam is present 25221 -- in both the refined state and constituent Constit. Flag Enabled 25222 -- should be set when the property applies to the refined state. If 25223 -- this is not the case, emit an error message. 25224 25225 procedure Match_State; 25226 -- Determine whether the state being refined appears in list 25227 -- Available_States. Emit an error when attempting to re-refine the 25228 -- state or when the state is not defined in the package declaration, 25229 -- otherwise remove the state from Available_States. 25230 25231 procedure Report_Unused_Constituents (Constits : Elist_Id); 25232 -- Emit errors for all unused Part_Of constituents in list Constits 25233 25234 ------------------------- 25235 -- Analyze_Constituent -- 25236 ------------------------- 25237 25238 procedure Analyze_Constituent (Constit : Node_Id) is 25239 procedure Match_Constituent (Constit_Id : Entity_Id); 25240 -- Determine whether constituent Constit denoted by its entity 25241 -- Constit_Id appears in Body_States. Emit an error when the 25242 -- constituent is not a valid hidden state of the related package 25243 -- or when it is used more than once. Otherwise remove the 25244 -- constituent from Body_States. 25245 25246 ----------------------- 25247 -- Match_Constituent -- 25248 ----------------------- 25249 25250 procedure Match_Constituent (Constit_Id : Entity_Id) is 25251 procedure Collect_Constituent; 25252 -- Verify the legality of constituent Constit_Id and add it to 25253 -- the refinements of State_Id. 25254 25255 ------------------------- 25256 -- Collect_Constituent -- 25257 ------------------------- 25258 25259 procedure Collect_Constituent is 25260 begin 25261 if Is_Ghost_Entity (State_Id) then 25262 if Is_Ghost_Entity (Constit_Id) then 25263 25264 -- The Ghost policy in effect at the point of abstract 25265 -- state declaration and constituent must match 25266 -- (SPARK RM 6.9(16)). 25267 25268 if Is_Checked_Ghost_Entity (State_Id) 25269 and then Is_Ignored_Ghost_Entity (Constit_Id) 25270 then 25271 Error_Msg_Sloc := Sloc (Constit); 25272 25273 SPARK_Msg_N 25274 ("incompatible ghost policies in effect", State); 25275 SPARK_Msg_NE 25276 ("\abstract state & declared with ghost policy " 25277 & "Check", State, State_Id); 25278 SPARK_Msg_NE 25279 ("\constituent & declared # with ghost policy " 25280 & "Ignore", State, Constit_Id); 25281 25282 elsif Is_Ignored_Ghost_Entity (State_Id) 25283 and then Is_Checked_Ghost_Entity (Constit_Id) 25284 then 25285 Error_Msg_Sloc := Sloc (Constit); 25286 25287 SPARK_Msg_N 25288 ("incompatible ghost policies in effect", State); 25289 SPARK_Msg_NE 25290 ("\abstract state & declared with ghost policy " 25291 & "Ignore", State, State_Id); 25292 SPARK_Msg_NE 25293 ("\constituent & declared # with ghost policy " 25294 & "Check", State, Constit_Id); 25295 end if; 25296 25297 -- A constituent of a Ghost abstract state must be a 25298 -- Ghost entity (SPARK RM 7.2.2(12)). 25299 25300 else 25301 SPARK_Msg_NE 25302 ("constituent of ghost state & must be ghost", 25303 Constit, State_Id); 25304 end if; 25305 end if; 25306 25307 -- A synchronized state must be refined by a synchronized 25308 -- object or another synchronized state (SPARK RM 9.6). 25309 25310 if Is_Synchronized_State (State_Id) 25311 and then not Is_Synchronized_Object (Constit_Id) 25312 and then not Is_Synchronized_State (Constit_Id) 25313 then 25314 SPARK_Msg_NE 25315 ("constituent of synchronized state & must be " 25316 & "synchronized", Constit, State_Id); 25317 end if; 25318 25319 -- Add the constituent to the list of processed items to aid 25320 -- with the detection of duplicates. 25321 25322 Append_New_Elmt (Constit_Id, Constituents_Seen); 25323 25324 -- Collect the constituent in the list of refinement items 25325 -- and establish a relation between the refined state and 25326 -- the item. 25327 25328 Append_Elmt (Constit_Id, Refinement_Constituents (State_Id)); 25329 Set_Encapsulating_State (Constit_Id, State_Id); 25330 25331 -- The state has at least one legal constituent, mark the 25332 -- start of the refinement region. The region ends when the 25333 -- body declarations end (see routine Analyze_Declarations). 25334 25335 Set_Has_Visible_Refinement (State_Id); 25336 25337 -- When the constituent is external, save its relevant 25338 -- property for further checks. 25339 25340 if Async_Readers_Enabled (Constit_Id) then 25341 AR_Constit := Constit_Id; 25342 External_Constit_Seen := True; 25343 end if; 25344 25345 if Async_Writers_Enabled (Constit_Id) then 25346 AW_Constit := Constit_Id; 25347 External_Constit_Seen := True; 25348 end if; 25349 25350 if Effective_Reads_Enabled (Constit_Id) then 25351 ER_Constit := Constit_Id; 25352 External_Constit_Seen := True; 25353 end if; 25354 25355 if Effective_Writes_Enabled (Constit_Id) then 25356 EW_Constit := Constit_Id; 25357 External_Constit_Seen := True; 25358 end if; 25359 end Collect_Constituent; 25360 25361 -- Local variables 25362 25363 State_Elmt : Elmt_Id; 25364 25365 -- Start of processing for Match_Constituent 25366 25367 begin 25368 -- Detect a duplicate use of a constituent 25369 25370 if Contains (Constituents_Seen, Constit_Id) then 25371 SPARK_Msg_NE 25372 ("duplicate use of constituent &", Constit, Constit_Id); 25373 return; 25374 end if; 25375 25376 -- The constituent is subject to a Part_Of indicator 25377 25378 if Present (Encapsulating_State (Constit_Id)) then 25379 if Encapsulating_State (Constit_Id) = State_Id then 25380 Remove (Part_Of_Constits, Constit_Id); 25381 Collect_Constituent; 25382 25383 -- The constituent is part of another state and is used 25384 -- incorrectly in the refinement of the current state. 25385 25386 else 25387 Error_Msg_Name_1 := Chars (State_Id); 25388 SPARK_Msg_NE 25389 ("& cannot act as constituent of state %", 25390 Constit, Constit_Id); 25391 SPARK_Msg_NE 25392 ("\Part_Of indicator specifies encapsulator &", 25393 Constit, Encapsulating_State (Constit_Id)); 25394 end if; 25395 25396 -- The only other source of legal constituents is the body 25397 -- state space of the related package. 25398 25399 else 25400 if Present (Body_States) then 25401 State_Elmt := First_Elmt (Body_States); 25402 while Present (State_Elmt) loop 25403 25404 -- Consume a valid constituent to signal that it has 25405 -- been encountered. 25406 25407 if Node (State_Elmt) = Constit_Id then 25408 Remove_Elmt (Body_States, State_Elmt); 25409 Collect_Constituent; 25410 return; 25411 end if; 25412 25413 Next_Elmt (State_Elmt); 25414 end loop; 25415 end if; 25416 25417 -- Constants are part of the hidden state of a package, but 25418 -- the compiler cannot determine whether they have variable 25419 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a 25420 -- hidden state. Accept the constant quietly even if it is 25421 -- a visible state or lacks a Part_Of indicator. 25422 25423 if Ekind (Constit_Id) = E_Constant then 25424 null; 25425 25426 -- If we get here, then the constituent is not a hidden 25427 -- state of the related package and may not be used in a 25428 -- refinement (SPARK RM 7.2.2(9)). 25429 25430 else 25431 Error_Msg_Name_1 := Chars (Spec_Id); 25432 SPARK_Msg_NE 25433 ("cannot use & in refinement, constituent is not a " 25434 & "hidden state of package %", Constit, Constit_Id); 25435 end if; 25436 end if; 25437 end Match_Constituent; 25438 25439 -- Local variables 25440 25441 Constit_Id : Entity_Id; 25442 25443 -- Start of processing for Analyze_Constituent 25444 25445 begin 25446 -- Detect multiple uses of null in a single refinement clause or a 25447 -- mixture of null and non-null constituents. 25448 25449 if Nkind (Constit) = N_Null then 25450 if Null_Seen then 25451 SPARK_Msg_N 25452 ("multiple null constituents not allowed", Constit); 25453 25454 elsif Non_Null_Seen then 25455 SPARK_Msg_N 25456 ("cannot mix null and non-null constituents", Constit); 25457 25458 else 25459 Null_Seen := True; 25460 25461 -- Collect the constituent in the list of refinement items 25462 25463 Append_Elmt (Constit, Refinement_Constituents (State_Id)); 25464 25465 -- The state has at least one legal constituent, mark the 25466 -- start of the refinement region. The region ends when the 25467 -- body declarations end (see Analyze_Declarations). 25468 25469 Set_Has_Visible_Refinement (State_Id); 25470 end if; 25471 25472 -- Non-null constituents 25473 25474 else 25475 Non_Null_Seen := True; 25476 25477 if Null_Seen then 25478 SPARK_Msg_N 25479 ("cannot mix null and non-null constituents", Constit); 25480 end if; 25481 25482 Analyze (Constit); 25483 Resolve_State (Constit); 25484 25485 -- Ensure that the constituent denotes a valid state or a 25486 -- whole object (SPARK RM 7.2.2(5)). 25487 25488 if Is_Entity_Name (Constit) then 25489 Constit_Id := Entity_Of (Constit); 25490 25491 -- When a constituent is declared after a subprogram body 25492 -- that caused "freezing" of the related contract where 25493 -- pragma Refined_State resides, the constituent appears 25494 -- undefined and carries Any_Id as its entity. 25495 25496 -- package body Pack 25497 -- with Refined_State => (State => Constit) 25498 -- is 25499 -- procedure Proc 25500 -- with Refined_Global => (Input => Constit) 25501 -- is 25502 -- ... 25503 -- end Proc; 25504 25505 -- Constit : ...; 25506 -- end Pack; 25507 25508 if Constit_Id = Any_Id then 25509 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id); 25510 25511 -- Emit a specialized info message when the contract of 25512 -- the related package body was "frozen" by another body. 25513 -- Note that it is not possible to precisely identify why 25514 -- the constituent is undefined because it is not visible 25515 -- when pragma Refined_State is analyzed. This message is 25516 -- a reasonable approximation. 25517 25518 if Present (Freeze_Id) and then not Freeze_Posted then 25519 Freeze_Posted := True; 25520 25521 Error_Msg_Name_1 := Chars (Body_Id); 25522 Error_Msg_Sloc := Sloc (Freeze_Id); 25523 SPARK_Msg_NE 25524 ("body & declared # freezes the contract of %", 25525 N, Freeze_Id); 25526 SPARK_Msg_N 25527 ("\all constituents must be declared before body #", 25528 N); 25529 25530 -- A misplaced constituent is a critical error because 25531 -- pragma Refined_Depends or Refined_Global depends on 25532 -- the proper link between a state and a constituent. 25533 -- Stop the compilation, as this leads to a multitude 25534 -- of misleading cascaded errors. 25535 25536 raise Program_Error; 25537 end if; 25538 25539 -- The constituent is a valid state or object 25540 25541 elsif Ekind_In (Constit_Id, E_Abstract_State, 25542 E_Constant, 25543 E_Variable) 25544 then 25545 Match_Constituent (Constit_Id); 25546 25547 -- The variable may eventually become a constituent of a 25548 -- single protected/task type. Record the reference now 25549 -- and verify its legality when analyzing the contract of 25550 -- the variable (SPARK RM 9.3). 25551 25552 if Ekind (Constit_Id) = E_Variable then 25553 Record_Possible_Part_Of_Reference 25554 (Var_Id => Constit_Id, 25555 Ref => Constit); 25556 end if; 25557 25558 -- Otherwise the constituent is illegal 25559 25560 else 25561 SPARK_Msg_NE 25562 ("constituent & must denote object or state", 25563 Constit, Constit_Id); 25564 end if; 25565 25566 -- The constituent is illegal 25567 25568 else 25569 SPARK_Msg_N ("malformed constituent", Constit); 25570 end if; 25571 end if; 25572 end Analyze_Constituent; 25573 25574 ----------------------------- 25575 -- Check_External_Property -- 25576 ----------------------------- 25577 25578 procedure Check_External_Property 25579 (Prop_Nam : Name_Id; 25580 Enabled : Boolean; 25581 Constit : Entity_Id) 25582 is 25583 begin 25584 Error_Msg_Name_1 := Prop_Nam; 25585 25586 -- The property is enabled in the related Abstract_State pragma 25587 -- that defines the state (SPARK RM 7.2.8(3)). 25588 25589 if Enabled then 25590 if No (Constit) then 25591 SPARK_Msg_NE 25592 ("external state & requires at least one constituent with " 25593 & "property %", State, State_Id); 25594 end if; 25595 25596 -- The property is missing in the declaration of the state, but 25597 -- a constituent is introducing it in the state refinement 25598 -- (SPARK RM 7.2.8(3)). 25599 25600 elsif Present (Constit) then 25601 Error_Msg_Name_2 := Chars (Constit); 25602 SPARK_Msg_NE 25603 ("external state & lacks property % set by constituent %", 25604 State, State_Id); 25605 end if; 25606 end Check_External_Property; 25607 25608 ----------------- 25609 -- Match_State -- 25610 ----------------- 25611 25612 procedure Match_State is 25613 State_Elmt : Elmt_Id; 25614 25615 begin 25616 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8)) 25617 25618 if Contains (Refined_States_Seen, State_Id) then 25619 SPARK_Msg_NE 25620 ("duplicate refinement of state &", State, State_Id); 25621 return; 25622 end if; 25623 25624 -- Inspect the abstract states defined in the package declaration 25625 -- looking for a match. 25626 25627 State_Elmt := First_Elmt (Available_States); 25628 while Present (State_Elmt) loop 25629 25630 -- A valid abstract state is being refined in the body. Add 25631 -- the state to the list of processed refined states to aid 25632 -- with the detection of duplicate refinements. Remove the 25633 -- state from Available_States to signal that it has already 25634 -- been refined. 25635 25636 if Node (State_Elmt) = State_Id then 25637 Append_New_Elmt (State_Id, Refined_States_Seen); 25638 Remove_Elmt (Available_States, State_Elmt); 25639 return; 25640 end if; 25641 25642 Next_Elmt (State_Elmt); 25643 end loop; 25644 25645 -- If we get here, we are refining a state that is not defined in 25646 -- the package declaration. 25647 25648 Error_Msg_Name_1 := Chars (Spec_Id); 25649 SPARK_Msg_NE 25650 ("cannot refine state, & is not defined in package %", 25651 State, State_Id); 25652 end Match_State; 25653 25654 -------------------------------- 25655 -- Report_Unused_Constituents -- 25656 -------------------------------- 25657 25658 procedure Report_Unused_Constituents (Constits : Elist_Id) is 25659 Constit_Elmt : Elmt_Id; 25660 Constit_Id : Entity_Id; 25661 Posted : Boolean := False; 25662 25663 begin 25664 if Present (Constits) then 25665 Constit_Elmt := First_Elmt (Constits); 25666 while Present (Constit_Elmt) loop 25667 Constit_Id := Node (Constit_Elmt); 25668 25669 -- Generate an error message of the form: 25670 25671 -- state ... has unused Part_Of constituents 25672 -- abstract state ... defined at ... 25673 -- constant ... defined at ... 25674 -- variable ... defined at ... 25675 25676 if not Posted then 25677 Posted := True; 25678 SPARK_Msg_NE 25679 ("state & has unused Part_Of constituents", 25680 State, State_Id); 25681 end if; 25682 25683 Error_Msg_Sloc := Sloc (Constit_Id); 25684 25685 if Ekind (Constit_Id) = E_Abstract_State then 25686 SPARK_Msg_NE 25687 ("\abstract state & defined #", State, Constit_Id); 25688 25689 elsif Ekind (Constit_Id) = E_Constant then 25690 SPARK_Msg_NE 25691 ("\constant & defined #", State, Constit_Id); 25692 25693 else 25694 pragma Assert (Ekind (Constit_Id) = E_Variable); 25695 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id); 25696 end if; 25697 25698 Next_Elmt (Constit_Elmt); 25699 end loop; 25700 end if; 25701 end Report_Unused_Constituents; 25702 25703 -- Local declarations 25704 25705 Body_Ref : Node_Id; 25706 Body_Ref_Elmt : Elmt_Id; 25707 Constit : Node_Id; 25708 Extra_State : Node_Id; 25709 25710 -- Start of processing for Analyze_Refinement_Clause 25711 25712 begin 25713 -- A refinement clause appears as a component association where the 25714 -- sole choice is the state and the expressions are the constituents. 25715 -- This is a syntax error, always report. 25716 25717 if Nkind (Clause) /= N_Component_Association then 25718 Error_Msg_N ("malformed state refinement clause", Clause); 25719 return; 25720 end if; 25721 25722 -- Analyze the state name of a refinement clause 25723 25724 State := First (Choices (Clause)); 25725 25726 Analyze (State); 25727 Resolve_State (State); 25728 25729 -- Ensure that the state name denotes a valid abstract state that is 25730 -- defined in the spec of the related package. 25731 25732 if Is_Entity_Name (State) then 25733 State_Id := Entity_Of (State); 25734 25735 -- When the abstract state is undefined, it appears as Any_Id. Do 25736 -- not continue with the analysis of the clause. 25737 25738 if State_Id = Any_Id then 25739 return; 25740 25741 -- Catch any attempts to re-refine a state or refine a state that 25742 -- is not defined in the package declaration. 25743 25744 elsif Ekind (State_Id) = E_Abstract_State then 25745 Match_State; 25746 25747 else 25748 SPARK_Msg_NE ("& must denote abstract state", State, State_Id); 25749 return; 25750 end if; 25751 25752 -- References to a state with visible refinement are illegal. 25753 -- When nested packages are involved, detecting such references is 25754 -- tricky because pragma Refined_State is analyzed later than the 25755 -- offending pragma Depends or Global. References that occur in 25756 -- such nested context are stored in a list. Emit errors for all 25757 -- references found in Body_References (SPARK RM 6.1.4(8)). 25758 25759 if Present (Body_References (State_Id)) then 25760 Body_Ref_Elmt := First_Elmt (Body_References (State_Id)); 25761 while Present (Body_Ref_Elmt) loop 25762 Body_Ref := Node (Body_Ref_Elmt); 25763 25764 SPARK_Msg_N ("reference to & not allowed", Body_Ref); 25765 Error_Msg_Sloc := Sloc (State); 25766 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref); 25767 25768 Next_Elmt (Body_Ref_Elmt); 25769 end loop; 25770 end if; 25771 25772 -- The state name is illegal. This is a syntax error, always report. 25773 25774 else 25775 Error_Msg_N ("malformed state name in refinement clause", State); 25776 return; 25777 end if; 25778 25779 -- A refinement clause may only refine one state at a time 25780 25781 Extra_State := Next (State); 25782 25783 if Present (Extra_State) then 25784 SPARK_Msg_N 25785 ("refinement clause cannot cover multiple states", Extra_State); 25786 end if; 25787 25788 -- Replicate the Part_Of constituents of the refined state because 25789 -- the algorithm will consume items. 25790 25791 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id)); 25792 25793 -- Analyze all constituents of the refinement. Multiple constituents 25794 -- appear as an aggregate. 25795 25796 Constit := Expression (Clause); 25797 25798 if Nkind (Constit) = N_Aggregate then 25799 if Present (Component_Associations (Constit)) then 25800 SPARK_Msg_N 25801 ("constituents of refinement clause must appear in " 25802 & "positional form", Constit); 25803 25804 else pragma Assert (Present (Expressions (Constit))); 25805 Constit := First (Expressions (Constit)); 25806 while Present (Constit) loop 25807 Analyze_Constituent (Constit); 25808 Next (Constit); 25809 end loop; 25810 end if; 25811 25812 -- Various forms of a single constituent. Note that these may include 25813 -- malformed constituents. 25814 25815 else 25816 Analyze_Constituent (Constit); 25817 end if; 25818 25819 -- A refined external state is subject to special rules with respect 25820 -- to its properties and constituents. 25821 25822 if Is_External_State (State_Id) then 25823 25824 -- The set of properties that all external constituents yield must 25825 -- match that of the refined state. There are two cases to detect: 25826 -- the refined state lacks a property or has an extra property. 25827 25828 if External_Constit_Seen then 25829 Check_External_Property 25830 (Prop_Nam => Name_Async_Readers, 25831 Enabled => Async_Readers_Enabled (State_Id), 25832 Constit => AR_Constit); 25833 25834 Check_External_Property 25835 (Prop_Nam => Name_Async_Writers, 25836 Enabled => Async_Writers_Enabled (State_Id), 25837 Constit => AW_Constit); 25838 25839 Check_External_Property 25840 (Prop_Nam => Name_Effective_Reads, 25841 Enabled => Effective_Reads_Enabled (State_Id), 25842 Constit => ER_Constit); 25843 25844 Check_External_Property 25845 (Prop_Nam => Name_Effective_Writes, 25846 Enabled => Effective_Writes_Enabled (State_Id), 25847 Constit => EW_Constit); 25848 25849 -- An external state may be refined to null (SPARK RM 7.2.8(2)) 25850 25851 elsif Null_Seen then 25852 null; 25853 25854 -- The external state has constituents, but none of them are 25855 -- external (SPARK RM 7.2.8(2)). 25856 25857 else 25858 SPARK_Msg_NE 25859 ("external state & requires at least one external " 25860 & "constituent or null refinement", State, State_Id); 25861 end if; 25862 25863 -- When a refined state is not external, it should not have external 25864 -- constituents (SPARK RM 7.2.8(1)). 25865 25866 elsif External_Constit_Seen then 25867 SPARK_Msg_NE 25868 ("non-external state & cannot contain external constituents in " 25869 & "refinement", State, State_Id); 25870 end if; 25871 25872 -- Ensure that all Part_Of candidate constituents have been mentioned 25873 -- in the refinement clause. 25874 25875 Report_Unused_Constituents (Part_Of_Constits); 25876 end Analyze_Refinement_Clause; 25877 25878 ----------------------------- 25879 -- Report_Unrefined_States -- 25880 ----------------------------- 25881 25882 procedure Report_Unrefined_States (States : Elist_Id) is 25883 State_Elmt : Elmt_Id; 25884 25885 begin 25886 if Present (States) then 25887 State_Elmt := First_Elmt (States); 25888 while Present (State_Elmt) loop 25889 SPARK_Msg_N 25890 ("abstract state & must be refined", Node (State_Elmt)); 25891 25892 Next_Elmt (State_Elmt); 25893 end loop; 25894 end if; 25895 end Report_Unrefined_States; 25896 25897 -- Local declarations 25898 25899 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 25900 Clause : Node_Id; 25901 25902 -- Start of processing for Analyze_Refined_State_In_Decl_Part 25903 25904 begin 25905 -- Do not analyze the pragma multiple times 25906 25907 if Is_Analyzed_Pragma (N) then 25908 return; 25909 end if; 25910 25911 -- Replicate the abstract states declared by the package because the 25912 -- matching algorithm will consume states. 25913 25914 Available_States := New_Copy_Elist (Abstract_States (Spec_Id)); 25915 25916 -- Gather all abstract states and objects declared in the visible 25917 -- state space of the package body. These items must be utilized as 25918 -- constituents in a state refinement. 25919 25920 Body_States := Collect_Body_States (Body_Id); 25921 25922 -- Multiple non-null state refinements appear as an aggregate 25923 25924 if Nkind (Clauses) = N_Aggregate then 25925 if Present (Expressions (Clauses)) then 25926 SPARK_Msg_N 25927 ("state refinements must appear as component associations", 25928 Clauses); 25929 25930 else pragma Assert (Present (Component_Associations (Clauses))); 25931 Clause := First (Component_Associations (Clauses)); 25932 while Present (Clause) loop 25933 Analyze_Refinement_Clause (Clause); 25934 Next (Clause); 25935 end loop; 25936 end if; 25937 25938 -- Various forms of a single state refinement. Note that these may 25939 -- include malformed refinements. 25940 25941 else 25942 Analyze_Refinement_Clause (Clauses); 25943 end if; 25944 25945 -- List all abstract states that were left unrefined 25946 25947 Report_Unrefined_States (Available_States); 25948 25949 Set_Is_Analyzed_Pragma (N); 25950 end Analyze_Refined_State_In_Decl_Part; 25951 25952 ------------------------------------ 25953 -- Analyze_Test_Case_In_Decl_Part -- 25954 ------------------------------------ 25955 25956 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is 25957 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 25958 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 25959 25960 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id); 25961 -- Preanalyze one of the optional arguments "Requires" or "Ensures" 25962 -- denoted by Arg_Nam. 25963 25964 ------------------------------ 25965 -- Preanalyze_Test_Case_Arg -- 25966 ------------------------------ 25967 25968 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is 25969 Arg : Node_Id; 25970 25971 begin 25972 -- Preanalyze the original aspect argument for ASIS or for a generic 25973 -- subprogram to properly capture global references. 25974 25975 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then 25976 Arg := 25977 Test_Case_Arg 25978 (Prag => N, 25979 Arg_Nam => Arg_Nam, 25980 From_Aspect => True); 25981 25982 if Present (Arg) then 25983 Preanalyze_Assert_Expression 25984 (Expression (Arg), Standard_Boolean); 25985 end if; 25986 end if; 25987 25988 Arg := Test_Case_Arg (N, Arg_Nam); 25989 25990 if Present (Arg) then 25991 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean); 25992 end if; 25993 end Preanalyze_Test_Case_Arg; 25994 25995 -- Local variables 25996 25997 Restore_Scope : Boolean := False; 25998 25999 -- Start of processing for Analyze_Test_Case_In_Decl_Part 26000 26001 begin 26002 -- Do not analyze the pragma multiple times 26003 26004 if Is_Analyzed_Pragma (N) then 26005 return; 26006 end if; 26007 26008 -- Ensure that the formal parameters are visible when analyzing all 26009 -- clauses. This falls out of the general rule of aspects pertaining 26010 -- to subprogram declarations. 26011 26012 if not In_Open_Scopes (Spec_Id) then 26013 Restore_Scope := True; 26014 Push_Scope (Spec_Id); 26015 26016 if Is_Generic_Subprogram (Spec_Id) then 26017 Install_Generic_Formals (Spec_Id); 26018 else 26019 Install_Formals (Spec_Id); 26020 end if; 26021 end if; 26022 26023 Preanalyze_Test_Case_Arg (Name_Requires); 26024 Preanalyze_Test_Case_Arg (Name_Ensures); 26025 26026 if Restore_Scope then 26027 End_Scope; 26028 end if; 26029 26030 -- Currently it is not possible to inline pre/postconditions on a 26031 -- subprogram subject to pragma Inline_Always. 26032 26033 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 26034 26035 Set_Is_Analyzed_Pragma (N); 26036 end Analyze_Test_Case_In_Decl_Part; 26037 26038 ---------------- 26039 -- Appears_In -- 26040 ---------------- 26041 26042 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is 26043 Elmt : Elmt_Id; 26044 Id : Entity_Id; 26045 26046 begin 26047 if Present (List) then 26048 Elmt := First_Elmt (List); 26049 while Present (Elmt) loop 26050 if Nkind (Node (Elmt)) = N_Defining_Identifier then 26051 Id := Node (Elmt); 26052 else 26053 Id := Entity_Of (Node (Elmt)); 26054 end if; 26055 26056 if Id = Item_Id then 26057 return True; 26058 end if; 26059 26060 Next_Elmt (Elmt); 26061 end loop; 26062 end if; 26063 26064 return False; 26065 end Appears_In; 26066 26067 ----------------------------- 26068 -- Check_Applicable_Policy -- 26069 ----------------------------- 26070 26071 procedure Check_Applicable_Policy (N : Node_Id) is 26072 PP : Node_Id; 26073 Policy : Name_Id; 26074 26075 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N); 26076 26077 begin 26078 -- No effect if not valid assertion kind name 26079 26080 if not Is_Valid_Assertion_Kind (Ename) then 26081 return; 26082 end if; 26083 26084 -- Loop through entries in check policy list 26085 26086 PP := Opt.Check_Policy_List; 26087 while Present (PP) loop 26088 declare 26089 PPA : constant List_Id := Pragma_Argument_Associations (PP); 26090 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 26091 26092 begin 26093 if Ename = Pnm 26094 or else Pnm = Name_Assertion 26095 or else (Pnm = Name_Statement_Assertions 26096 and then Nam_In (Ename, Name_Assert, 26097 Name_Assert_And_Cut, 26098 Name_Assume, 26099 Name_Loop_Invariant, 26100 Name_Loop_Variant)) 26101 then 26102 Policy := Chars (Get_Pragma_Arg (Last (PPA))); 26103 26104 case Policy is 26105 when Name_Off | Name_Ignore => 26106 Set_Is_Ignored (N, True); 26107 Set_Is_Checked (N, False); 26108 26109 when Name_On | Name_Check => 26110 Set_Is_Checked (N, True); 26111 Set_Is_Ignored (N, False); 26112 26113 when Name_Disable => 26114 Set_Is_Ignored (N, True); 26115 Set_Is_Checked (N, False); 26116 Set_Is_Disabled (N, True); 26117 26118 -- That should be exhaustive, the null here is a defence 26119 -- against a malformed tree from previous errors. 26120 26121 when others => 26122 null; 26123 end case; 26124 26125 return; 26126 end if; 26127 26128 PP := Next_Pragma (PP); 26129 end; 26130 end loop; 26131 26132 -- If there are no specific entries that matched, then we let the 26133 -- setting of assertions govern. Note that this provides the needed 26134 -- compatibility with the RM for the cases of assertion, invariant, 26135 -- precondition, predicate, and postcondition. 26136 26137 if Assertions_Enabled then 26138 Set_Is_Checked (N, True); 26139 Set_Is_Ignored (N, False); 26140 else 26141 Set_Is_Checked (N, False); 26142 Set_Is_Ignored (N, True); 26143 end if; 26144 end Check_Applicable_Policy; 26145 26146 ------------------------------- 26147 -- Check_External_Properties -- 26148 ------------------------------- 26149 26150 procedure Check_External_Properties 26151 (Item : Node_Id; 26152 AR : Boolean; 26153 AW : Boolean; 26154 ER : Boolean; 26155 EW : Boolean) 26156 is 26157 begin 26158 -- All properties enabled 26159 26160 if AR and AW and ER and EW then 26161 null; 26162 26163 -- Async_Readers + Effective_Writes 26164 -- Async_Readers + Async_Writers + Effective_Writes 26165 26166 elsif AR and EW and not ER then 26167 null; 26168 26169 -- Async_Writers + Effective_Reads 26170 -- Async_Readers + Async_Writers + Effective_Reads 26171 26172 elsif AW and ER and not EW then 26173 null; 26174 26175 -- Async_Readers + Async_Writers 26176 26177 elsif AR and AW and not ER and not EW then 26178 null; 26179 26180 -- Async_Readers 26181 26182 elsif AR and not AW and not ER and not EW then 26183 null; 26184 26185 -- Async_Writers 26186 26187 elsif AW and not AR and not ER and not EW then 26188 null; 26189 26190 else 26191 SPARK_Msg_N 26192 ("illegal combination of external properties (SPARK RM 7.1.2(6))", 26193 Item); 26194 end if; 26195 end Check_External_Properties; 26196 26197 ---------------- 26198 -- Check_Kind -- 26199 ---------------- 26200 26201 function Check_Kind (Nam : Name_Id) return Name_Id is 26202 PP : Node_Id; 26203 26204 begin 26205 -- Loop through entries in check policy list 26206 26207 PP := Opt.Check_Policy_List; 26208 while Present (PP) loop 26209 declare 26210 PPA : constant List_Id := Pragma_Argument_Associations (PP); 26211 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 26212 26213 begin 26214 if Nam = Pnm 26215 or else (Pnm = Name_Assertion 26216 and then Is_Valid_Assertion_Kind (Nam)) 26217 or else (Pnm = Name_Statement_Assertions 26218 and then Nam_In (Nam, Name_Assert, 26219 Name_Assert_And_Cut, 26220 Name_Assume, 26221 Name_Loop_Invariant, 26222 Name_Loop_Variant)) 26223 then 26224 case (Chars (Get_Pragma_Arg (Last (PPA)))) is 26225 when Name_On | Name_Check => 26226 return Name_Check; 26227 when Name_Off | Name_Ignore => 26228 return Name_Ignore; 26229 when Name_Disable => 26230 return Name_Disable; 26231 when others => 26232 raise Program_Error; 26233 end case; 26234 26235 else 26236 PP := Next_Pragma (PP); 26237 end if; 26238 end; 26239 end loop; 26240 26241 -- If there are no specific entries that matched, then we let the 26242 -- setting of assertions govern. Note that this provides the needed 26243 -- compatibility with the RM for the cases of assertion, invariant, 26244 -- precondition, predicate, and postcondition. 26245 26246 if Assertions_Enabled then 26247 return Name_Check; 26248 else 26249 return Name_Ignore; 26250 end if; 26251 end Check_Kind; 26252 26253 --------------------------- 26254 -- Check_Missing_Part_Of -- 26255 --------------------------- 26256 26257 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is 26258 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean; 26259 -- Determine whether a package denoted by Pack_Id declares at least one 26260 -- visible state. 26261 26262 ----------------------- 26263 -- Has_Visible_State -- 26264 ----------------------- 26265 26266 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is 26267 Item_Id : Entity_Id; 26268 26269 begin 26270 -- Traverse the entity chain of the package trying to find at least 26271 -- one visible abstract state, variable or a package [instantiation] 26272 -- that declares a visible state. 26273 26274 Item_Id := First_Entity (Pack_Id); 26275 while Present (Item_Id) 26276 and then not In_Private_Part (Item_Id) 26277 loop 26278 -- Do not consider internally generated items 26279 26280 if not Comes_From_Source (Item_Id) then 26281 null; 26282 26283 -- A visible state has been found 26284 26285 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 26286 return True; 26287 26288 -- Recursively peek into nested packages and instantiations 26289 26290 elsif Ekind (Item_Id) = E_Package 26291 and then Has_Visible_State (Item_Id) 26292 then 26293 return True; 26294 end if; 26295 26296 Next_Entity (Item_Id); 26297 end loop; 26298 26299 return False; 26300 end Has_Visible_State; 26301 26302 -- Local variables 26303 26304 Pack_Id : Entity_Id; 26305 Placement : State_Space_Kind; 26306 26307 -- Start of processing for Check_Missing_Part_Of 26308 26309 begin 26310 -- Do not consider abstract states, variables or package instantiations 26311 -- coming from an instance as those always inherit the Part_Of indicator 26312 -- of the instance itself. 26313 26314 if In_Instance then 26315 return; 26316 26317 -- Do not consider internally generated entities as these can never 26318 -- have a Part_Of indicator. 26319 26320 elsif not Comes_From_Source (Item_Id) then 26321 return; 26322 26323 -- Perform these checks only when SPARK_Mode is enabled as they will 26324 -- interfere with standard Ada rules and produce false positives. 26325 26326 elsif SPARK_Mode /= On then 26327 return; 26328 26329 -- Do not consider constants, because the compiler cannot accurately 26330 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and 26331 -- act as a hidden state of a package. 26332 26333 elsif Ekind (Item_Id) = E_Constant then 26334 return; 26335 end if; 26336 26337 -- Find where the abstract state, variable or package instantiation 26338 -- lives with respect to the state space. 26339 26340 Find_Placement_In_State_Space 26341 (Item_Id => Item_Id, 26342 Placement => Placement, 26343 Pack_Id => Pack_Id); 26344 26345 -- Items that appear in a non-package construct (subprogram, block, etc) 26346 -- do not require a Part_Of indicator because they can never act as a 26347 -- hidden state. 26348 26349 if Placement = Not_In_Package then 26350 null; 26351 26352 -- An item declared in the body state space of a package always act as a 26353 -- constituent and does not need explicit Part_Of indicator. 26354 26355 elsif Placement = Body_State_Space then 26356 null; 26357 26358 -- In general an item declared in the visible state space of a package 26359 -- does not require a Part_Of indicator. The only exception is when the 26360 -- related package is a private child unit in which case Part_Of must 26361 -- denote a state in the parent unit or in one of its descendants. 26362 26363 elsif Placement = Visible_State_Space then 26364 if Is_Child_Unit (Pack_Id) 26365 and then Is_Private_Descendant (Pack_Id) 26366 then 26367 -- A package instantiation does not need a Part_Of indicator when 26368 -- the related generic template has no visible state. 26369 26370 if Ekind (Item_Id) = E_Package 26371 and then Is_Generic_Instance (Item_Id) 26372 and then not Has_Visible_State (Item_Id) 26373 then 26374 null; 26375 26376 -- All other cases require Part_Of 26377 26378 else 26379 Error_Msg_N 26380 ("indicator Part_Of is required in this context " 26381 & "(SPARK RM 7.2.6(3))", Item_Id); 26382 Error_Msg_Name_1 := Chars (Pack_Id); 26383 Error_Msg_N 26384 ("\& is declared in the visible part of private child " 26385 & "unit %", Item_Id); 26386 end if; 26387 end if; 26388 26389 -- When the item appears in the private state space of a packge, it must 26390 -- be a part of some state declared by the said package. 26391 26392 else pragma Assert (Placement = Private_State_Space); 26393 26394 -- The related package does not declare a state, the item cannot act 26395 -- as a Part_Of constituent. 26396 26397 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then 26398 null; 26399 26400 -- A package instantiation does not need a Part_Of indicator when the 26401 -- related generic template has no visible state. 26402 26403 elsif Ekind (Pack_Id) = E_Package 26404 and then Is_Generic_Instance (Pack_Id) 26405 and then not Has_Visible_State (Pack_Id) 26406 then 26407 null; 26408 26409 -- All other cases require Part_Of 26410 26411 else 26412 Error_Msg_N 26413 ("indicator Part_Of is required in this context " 26414 & "(SPARK RM 7.2.6(2))", Item_Id); 26415 Error_Msg_Name_1 := Chars (Pack_Id); 26416 Error_Msg_N 26417 ("\& is declared in the private part of package %", Item_Id); 26418 end if; 26419 end if; 26420 end Check_Missing_Part_Of; 26421 26422 --------------------------------------------------- 26423 -- Check_Postcondition_Use_In_Inlined_Subprogram -- 26424 --------------------------------------------------- 26425 26426 procedure Check_Postcondition_Use_In_Inlined_Subprogram 26427 (Prag : Node_Id; 26428 Spec_Id : Entity_Id) 26429 is 26430 begin 26431 if Warn_On_Redundant_Constructs 26432 and then Has_Pragma_Inline_Always (Spec_Id) 26433 then 26434 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag); 26435 26436 if From_Aspect_Specification (Prag) then 26437 Error_Msg_NE 26438 ("aspect % not enforced on inlined subprogram &?r?", 26439 Corresponding_Aspect (Prag), Spec_Id); 26440 else 26441 Error_Msg_NE 26442 ("pragma % not enforced on inlined subprogram &?r?", 26443 Prag, Spec_Id); 26444 end if; 26445 end if; 26446 end Check_Postcondition_Use_In_Inlined_Subprogram; 26447 26448 ------------------------------------- 26449 -- Check_State_And_Constituent_Use -- 26450 ------------------------------------- 26451 26452 procedure Check_State_And_Constituent_Use 26453 (States : Elist_Id; 26454 Constits : Elist_Id; 26455 Context : Node_Id) 26456 is 26457 function Find_Encapsulating_State 26458 (Constit_Id : Entity_Id) return Entity_Id; 26459 -- Given the entity of a constituent, try to find a corresponding 26460 -- encapsulating state that appears in the same context. The routine 26461 -- returns Empty is no such state is found. 26462 26463 ------------------------------ 26464 -- Find_Encapsulating_State -- 26465 ------------------------------ 26466 26467 function Find_Encapsulating_State 26468 (Constit_Id : Entity_Id) return Entity_Id 26469 is 26470 State_Id : Entity_Id; 26471 26472 begin 26473 -- Since a constituent may be part of a larger constituent set, climb 26474 -- the encapsulating state chain looking for a state that appears in 26475 -- the same context. 26476 26477 State_Id := Encapsulating_State (Constit_Id); 26478 while Present (State_Id) loop 26479 if Contains (States, State_Id) then 26480 return State_Id; 26481 end if; 26482 26483 State_Id := Encapsulating_State (State_Id); 26484 end loop; 26485 26486 return Empty; 26487 end Find_Encapsulating_State; 26488 26489 -- Local variables 26490 26491 Constit_Elmt : Elmt_Id; 26492 Constit_Id : Entity_Id; 26493 State_Id : Entity_Id; 26494 26495 -- Start of processing for Check_State_And_Constituent_Use 26496 26497 begin 26498 -- Nothing to do if there are no states or constituents 26499 26500 if No (States) or else No (Constits) then 26501 return; 26502 end if; 26503 26504 -- Inspect the list of constituents and try to determine whether its 26505 -- encapsulating state is in list States. 26506 26507 Constit_Elmt := First_Elmt (Constits); 26508 while Present (Constit_Elmt) loop 26509 Constit_Id := Node (Constit_Elmt); 26510 26511 -- Determine whether the constituent is part of an encapsulating 26512 -- state that appears in the same context and if this is the case, 26513 -- emit an error (SPARK RM 7.2.6(7)). 26514 26515 State_Id := Find_Encapsulating_State (Constit_Id); 26516 26517 if Present (State_Id) then 26518 Error_Msg_Name_1 := Chars (Constit_Id); 26519 SPARK_Msg_NE 26520 ("cannot mention state & and its constituent % in the same " 26521 & "context", Context, State_Id); 26522 exit; 26523 end if; 26524 26525 Next_Elmt (Constit_Elmt); 26526 end loop; 26527 end Check_State_And_Constituent_Use; 26528 26529 --------------------------------------- 26530 -- Collect_Subprogram_Inputs_Outputs -- 26531 --------------------------------------- 26532 26533 procedure Collect_Subprogram_Inputs_Outputs 26534 (Subp_Id : Entity_Id; 26535 Synthesize : Boolean := False; 26536 Subp_Inputs : in out Elist_Id; 26537 Subp_Outputs : in out Elist_Id; 26538 Global_Seen : out Boolean) 26539 is 26540 procedure Collect_Dependency_Clause (Clause : Node_Id); 26541 -- Collect all relevant items from a dependency clause 26542 26543 procedure Collect_Global_List 26544 (List : Node_Id; 26545 Mode : Name_Id := Name_Input); 26546 -- Collect all relevant items from a global list 26547 26548 ------------------------------- 26549 -- Collect_Dependency_Clause -- 26550 ------------------------------- 26551 26552 procedure Collect_Dependency_Clause (Clause : Node_Id) is 26553 procedure Collect_Dependency_Item 26554 (Item : Node_Id; 26555 Is_Input : Boolean); 26556 -- Add an item to the proper subprogram input or output collection 26557 26558 ----------------------------- 26559 -- Collect_Dependency_Item -- 26560 ----------------------------- 26561 26562 procedure Collect_Dependency_Item 26563 (Item : Node_Id; 26564 Is_Input : Boolean) 26565 is 26566 Extra : Node_Id; 26567 26568 begin 26569 -- Nothing to collect when the item is null 26570 26571 if Nkind (Item) = N_Null then 26572 null; 26573 26574 -- Ditto for attribute 'Result 26575 26576 elsif Is_Attribute_Result (Item) then 26577 null; 26578 26579 -- Multiple items appear as an aggregate 26580 26581 elsif Nkind (Item) = N_Aggregate then 26582 Extra := First (Expressions (Item)); 26583 while Present (Extra) loop 26584 Collect_Dependency_Item (Extra, Is_Input); 26585 Next (Extra); 26586 end loop; 26587 26588 -- Otherwise this is a solitary item 26589 26590 else 26591 if Is_Input then 26592 Append_New_Elmt (Item, Subp_Inputs); 26593 else 26594 Append_New_Elmt (Item, Subp_Outputs); 26595 end if; 26596 end if; 26597 end Collect_Dependency_Item; 26598 26599 -- Start of processing for Collect_Dependency_Clause 26600 26601 begin 26602 if Nkind (Clause) = N_Null then 26603 null; 26604 26605 -- A dependency cause appears as component association 26606 26607 elsif Nkind (Clause) = N_Component_Association then 26608 Collect_Dependency_Item 26609 (Item => Expression (Clause), 26610 Is_Input => True); 26611 26612 Collect_Dependency_Item 26613 (Item => First (Choices (Clause)), 26614 Is_Input => False); 26615 26616 -- To accomodate partial decoration of disabled SPARK features, this 26617 -- routine may be called with illegal input. If this is the case, do 26618 -- not raise Program_Error. 26619 26620 else 26621 null; 26622 end if; 26623 end Collect_Dependency_Clause; 26624 26625 ------------------------- 26626 -- Collect_Global_List -- 26627 ------------------------- 26628 26629 procedure Collect_Global_List 26630 (List : Node_Id; 26631 Mode : Name_Id := Name_Input) 26632 is 26633 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id); 26634 -- Add an item to the proper subprogram input or output collection 26635 26636 ------------------------- 26637 -- Collect_Global_Item -- 26638 ------------------------- 26639 26640 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is 26641 begin 26642 if Nam_In (Mode, Name_In_Out, Name_Input) then 26643 Append_New_Elmt (Item, Subp_Inputs); 26644 end if; 26645 26646 if Nam_In (Mode, Name_In_Out, Name_Output) then 26647 Append_New_Elmt (Item, Subp_Outputs); 26648 end if; 26649 end Collect_Global_Item; 26650 26651 -- Local variables 26652 26653 Assoc : Node_Id; 26654 Item : Node_Id; 26655 26656 -- Start of processing for Collect_Global_List 26657 26658 begin 26659 if Nkind (List) = N_Null then 26660 null; 26661 26662 -- Single global item declaration 26663 26664 elsif Nkind_In (List, N_Expanded_Name, 26665 N_Identifier, 26666 N_Selected_Component) 26667 then 26668 Collect_Global_Item (List, Mode); 26669 26670 -- Simple global list or moded global list declaration 26671 26672 elsif Nkind (List) = N_Aggregate then 26673 if Present (Expressions (List)) then 26674 Item := First (Expressions (List)); 26675 while Present (Item) loop 26676 Collect_Global_Item (Item, Mode); 26677 Next (Item); 26678 end loop; 26679 26680 else 26681 Assoc := First (Component_Associations (List)); 26682 while Present (Assoc) loop 26683 Collect_Global_List 26684 (List => Expression (Assoc), 26685 Mode => Chars (First (Choices (Assoc)))); 26686 Next (Assoc); 26687 end loop; 26688 end if; 26689 26690 -- To accomodate partial decoration of disabled SPARK features, this 26691 -- routine may be called with illegal input. If this is the case, do 26692 -- not raise Program_Error. 26693 26694 else 26695 null; 26696 end if; 26697 end Collect_Global_List; 26698 26699 -- Local variables 26700 26701 Clause : Node_Id; 26702 Clauses : Node_Id; 26703 Depends : Node_Id; 26704 Formal : Entity_Id; 26705 Global : Node_Id; 26706 Spec_Id : Entity_Id; 26707 Subp_Decl : Node_Id; 26708 Typ : Entity_Id; 26709 26710 -- Start of processing for Collect_Subprogram_Inputs_Outputs 26711 26712 begin 26713 Global_Seen := False; 26714 26715 -- Process all formal parameters of entries, [generic] subprograms, and 26716 -- their bodies. 26717 26718 if Ekind_In (Subp_Id, E_Entry, 26719 E_Entry_Family, 26720 E_Function, 26721 E_Generic_Function, 26722 E_Generic_Procedure, 26723 E_Procedure, 26724 E_Subprogram_Body) 26725 then 26726 Subp_Decl := Unit_Declaration_Node (Subp_Id); 26727 Spec_Id := Unique_Defining_Entity (Subp_Decl); 26728 26729 -- Process all [generic] formal parameters 26730 26731 Formal := First_Entity (Spec_Id); 26732 while Present (Formal) loop 26733 if Ekind_In (Formal, E_Generic_In_Parameter, 26734 E_In_Out_Parameter, 26735 E_In_Parameter) 26736 then 26737 Append_New_Elmt (Formal, Subp_Inputs); 26738 end if; 26739 26740 if Ekind_In (Formal, E_Generic_In_Out_Parameter, 26741 E_In_Out_Parameter, 26742 E_Out_Parameter) 26743 then 26744 Append_New_Elmt (Formal, Subp_Outputs); 26745 26746 -- Out parameters can act as inputs when the related type is 26747 -- tagged, unconstrained array, unconstrained record, or record 26748 -- with unconstrained components. 26749 26750 if Ekind (Formal) = E_Out_Parameter 26751 and then Is_Unconstrained_Or_Tagged_Item (Formal) 26752 then 26753 Append_New_Elmt (Formal, Subp_Inputs); 26754 end if; 26755 end if; 26756 26757 Next_Entity (Formal); 26758 end loop; 26759 26760 -- Otherwise the input denotes a task type, a task body, or the 26761 -- anonymous object created for a single task type. 26762 26763 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body) 26764 or else Is_Single_Task_Object (Subp_Id) 26765 then 26766 Subp_Decl := Declaration_Node (Subp_Id); 26767 Spec_Id := Unique_Defining_Entity (Subp_Decl); 26768 end if; 26769 26770 -- When processing an entry, subprogram or task body, look for pragmas 26771 -- Refined_Depends and Refined_Global as they specify the inputs and 26772 -- outputs. 26773 26774 if Is_Entry_Body (Subp_Id) 26775 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body) 26776 then 26777 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends); 26778 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); 26779 26780 -- Subprogram declaration or stand alone body case, look for pragmas 26781 -- Depends and Global 26782 26783 else 26784 Depends := Get_Pragma (Spec_Id, Pragma_Depends); 26785 Global := Get_Pragma (Spec_Id, Pragma_Global); 26786 end if; 26787 26788 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends 26789 -- because it provides finer granularity of inputs and outputs. 26790 26791 if Present (Global) then 26792 Global_Seen := True; 26793 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id))); 26794 26795 -- When the related subprogram lacks pragma [Refined_]Global, fall back 26796 -- to [Refined_]Depends if the caller requests this behavior. Synthesize 26797 -- the inputs and outputs from [Refined_]Depends. 26798 26799 elsif Synthesize and then Present (Depends) then 26800 Clauses := Expression (Get_Argument (Depends, Spec_Id)); 26801 26802 -- Multiple dependency clauses appear as an aggregate 26803 26804 if Nkind (Clauses) = N_Aggregate then 26805 Clause := First (Component_Associations (Clauses)); 26806 while Present (Clause) loop 26807 Collect_Dependency_Clause (Clause); 26808 Next (Clause); 26809 end loop; 26810 26811 -- Otherwise this is a single dependency clause 26812 26813 else 26814 Collect_Dependency_Clause (Clauses); 26815 end if; 26816 end if; 26817 26818 -- The current instance of a protected type acts as a formal parameter 26819 -- of mode IN for functions and IN OUT for entries and procedures 26820 -- (SPARK RM 6.1.4). 26821 26822 if Ekind (Scope (Spec_Id)) = E_Protected_Type then 26823 Typ := Scope (Spec_Id); 26824 26825 -- Use the anonymous object when the type is single protected 26826 26827 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then 26828 Typ := Anonymous_Object (Typ); 26829 end if; 26830 26831 Append_New_Elmt (Typ, Subp_Inputs); 26832 26833 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then 26834 Append_New_Elmt (Typ, Subp_Outputs); 26835 end if; 26836 26837 -- The current instance of a task type acts as a formal parameter of 26838 -- mode IN OUT (SPARK RM 6.1.4). 26839 26840 elsif Ekind (Spec_Id) = E_Task_Type then 26841 Typ := Spec_Id; 26842 26843 -- Use the anonymous object when the type is single task 26844 26845 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then 26846 Typ := Anonymous_Object (Typ); 26847 end if; 26848 26849 Append_New_Elmt (Typ, Subp_Inputs); 26850 Append_New_Elmt (Typ, Subp_Outputs); 26851 26852 elsif Is_Single_Task_Object (Spec_Id) then 26853 Append_New_Elmt (Spec_Id, Subp_Inputs); 26854 Append_New_Elmt (Spec_Id, Subp_Outputs); 26855 end if; 26856 end Collect_Subprogram_Inputs_Outputs; 26857 26858 --------------------------- 26859 -- Contract_Freeze_Error -- 26860 --------------------------- 26861 26862 procedure Contract_Freeze_Error 26863 (Contract_Id : Entity_Id; 26864 Freeze_Id : Entity_Id) 26865 is 26866 begin 26867 Error_Msg_Name_1 := Chars (Contract_Id); 26868 Error_Msg_Sloc := Sloc (Freeze_Id); 26869 26870 SPARK_Msg_NE 26871 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id); 26872 SPARK_Msg_N 26873 ("\all contractual items must be declared before body #", Contract_Id); 26874 end Contract_Freeze_Error; 26875 26876 --------------------------------- 26877 -- Delay_Config_Pragma_Analyze -- 26878 --------------------------------- 26879 26880 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is 26881 begin 26882 return Nam_In (Pragma_Name (N), Name_Interrupt_State, 26883 Name_Priority_Specific_Dispatching); 26884 end Delay_Config_Pragma_Analyze; 26885 26886 ----------------------- 26887 -- Duplication_Error -- 26888 ----------------------- 26889 26890 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is 26891 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag); 26892 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev); 26893 26894 begin 26895 Error_Msg_Sloc := Sloc (Prev); 26896 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag); 26897 26898 -- Emit a precise message to distinguish between source pragmas and 26899 -- pragmas generated from aspects. The ordering of the two pragmas is 26900 -- the following: 26901 26902 -- Prev -- ok 26903 -- Prag -- duplicate 26904 26905 -- No error is emitted when both pragmas come from aspects because this 26906 -- is already detected by the general aspect analysis mechanism. 26907 26908 if Prag_From_Asp and Prev_From_Asp then 26909 null; 26910 elsif Prag_From_Asp then 26911 Error_Msg_N ("aspect % duplicates pragma declared #", Prag); 26912 elsif Prev_From_Asp then 26913 Error_Msg_N ("pragma % duplicates aspect declared #", Prag); 26914 else 26915 Error_Msg_N ("pragma % duplicates pragma declared #", Prag); 26916 end if; 26917 end Duplication_Error; 26918 26919 -------------------------- 26920 -- Find_Related_Context -- 26921 -------------------------- 26922 26923 function Find_Related_Context 26924 (Prag : Node_Id; 26925 Do_Checks : Boolean := False) return Node_Id 26926 is 26927 Stmt : Node_Id; 26928 26929 begin 26930 Stmt := Prev (Prag); 26931 while Present (Stmt) loop 26932 26933 -- Skip prior pragmas, but check for duplicates 26934 26935 if Nkind (Stmt) = N_Pragma then 26936 if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then 26937 Duplication_Error 26938 (Prag => Prag, 26939 Prev => Stmt); 26940 end if; 26941 26942 -- Skip internally generated code 26943 26944 elsif not Comes_From_Source (Stmt) then 26945 26946 -- The anonymous object created for a single concurrent type is a 26947 -- suitable context. 26948 26949 if Nkind (Stmt) = N_Object_Declaration 26950 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) 26951 then 26952 return Stmt; 26953 end if; 26954 26955 -- Return the current source construct 26956 26957 else 26958 return Stmt; 26959 end if; 26960 26961 Prev (Stmt); 26962 end loop; 26963 26964 return Empty; 26965 end Find_Related_Context; 26966 26967 -------------------------------------- 26968 -- Find_Related_Declaration_Or_Body -- 26969 -------------------------------------- 26970 26971 function Find_Related_Declaration_Or_Body 26972 (Prag : Node_Id; 26973 Do_Checks : Boolean := False) return Node_Id 26974 is 26975 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag); 26976 26977 procedure Expression_Function_Error; 26978 -- Emit an error concerning pragma Prag that illegaly applies to an 26979 -- expression function. 26980 26981 ------------------------------- 26982 -- Expression_Function_Error -- 26983 ------------------------------- 26984 26985 procedure Expression_Function_Error is 26986 begin 26987 Error_Msg_Name_1 := Prag_Nam; 26988 26989 -- Emit a precise message to distinguish between source pragmas and 26990 -- pragmas generated from aspects. 26991 26992 if From_Aspect_Specification (Prag) then 26993 Error_Msg_N 26994 ("aspect % cannot apply to a stand alone expression function", 26995 Prag); 26996 else 26997 Error_Msg_N 26998 ("pragma % cannot apply to a stand alone expression function", 26999 Prag); 27000 end if; 27001 end Expression_Function_Error; 27002 27003 -- Local variables 27004 27005 Context : constant Node_Id := Parent (Prag); 27006 Stmt : Node_Id; 27007 27008 Look_For_Body : constant Boolean := 27009 Nam_In (Prag_Nam, Name_Refined_Depends, 27010 Name_Refined_Global, 27011 Name_Refined_Post); 27012 -- Refinement pragmas must be associated with a subprogram body [stub] 27013 27014 -- Start of processing for Find_Related_Declaration_Or_Body 27015 27016 begin 27017 Stmt := Prev (Prag); 27018 while Present (Stmt) loop 27019 27020 -- Skip prior pragmas, but check for duplicates. Pragmas produced 27021 -- by splitting a complex pre/postcondition are not considered to 27022 -- be duplicates. 27023 27024 if Nkind (Stmt) = N_Pragma then 27025 if Do_Checks 27026 and then not Split_PPC (Stmt) 27027 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam 27028 then 27029 Duplication_Error 27030 (Prag => Prag, 27031 Prev => Stmt); 27032 end if; 27033 27034 -- Emit an error when a refinement pragma appears on an expression 27035 -- function without a completion. 27036 27037 elsif Do_Checks 27038 and then Look_For_Body 27039 and then Nkind (Stmt) = N_Subprogram_Declaration 27040 and then Nkind (Original_Node (Stmt)) = N_Expression_Function 27041 and then not Has_Completion (Defining_Entity (Stmt)) 27042 then 27043 Expression_Function_Error; 27044 return Empty; 27045 27046 -- The refinement pragma applies to a subprogram body stub 27047 27048 elsif Look_For_Body 27049 and then Nkind (Stmt) = N_Subprogram_Body_Stub 27050 then 27051 return Stmt; 27052 27053 -- Skip internally generated code 27054 27055 elsif not Comes_From_Source (Stmt) then 27056 27057 -- The anonymous object created for a single concurrent type is a 27058 -- suitable context. 27059 27060 if Nkind (Stmt) = N_Object_Declaration 27061 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) 27062 then 27063 return Stmt; 27064 27065 elsif Nkind (Stmt) = N_Subprogram_Declaration then 27066 27067 -- The subprogram declaration is an internally generated spec 27068 -- for an expression function. 27069 27070 if Nkind (Original_Node (Stmt)) = N_Expression_Function then 27071 return Stmt; 27072 27073 -- The subprogram is actually an instance housed within an 27074 -- anonymous wrapper package. 27075 27076 elsif Present (Generic_Parent (Specification (Stmt))) then 27077 return Stmt; 27078 end if; 27079 end if; 27080 27081 -- Return the current construct which is either a subprogram body, 27082 -- a subprogram declaration or is illegal. 27083 27084 else 27085 return Stmt; 27086 end if; 27087 27088 Prev (Stmt); 27089 end loop; 27090 27091 -- If we fall through, then the pragma was either the first declaration 27092 -- or it was preceded by other pragmas and no source constructs. 27093 27094 -- The pragma is associated with a library-level subprogram 27095 27096 if Nkind (Context) = N_Compilation_Unit_Aux then 27097 return Unit (Parent (Context)); 27098 27099 -- The pragma appears inside the declarations of an entry body 27100 27101 elsif Nkind (Context) = N_Entry_Body then 27102 return Context; 27103 27104 -- The pragma appears inside the statements of a subprogram body. This 27105 -- placement is the result of subprogram contract expansion. 27106 27107 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 27108 return Parent (Context); 27109 27110 -- The pragma appears inside the declarative part of a subprogram body 27111 27112 elsif Nkind (Context) = N_Subprogram_Body then 27113 return Context; 27114 27115 -- The pragma appears inside the declarative part of a task body 27116 27117 elsif Nkind (Context) = N_Task_Body then 27118 return Context; 27119 27120 -- The pragma is a byproduct of aspect expansion, return the related 27121 -- context of the original aspect. This case has a lower priority as 27122 -- the above circuitry pinpoints precisely the related context. 27123 27124 elsif Present (Corresponding_Aspect (Prag)) then 27125 return Parent (Corresponding_Aspect (Prag)); 27126 27127 -- No candidate subprogram [body] found 27128 27129 else 27130 return Empty; 27131 end if; 27132 end Find_Related_Declaration_Or_Body; 27133 27134 ---------------------------------- 27135 -- Find_Related_Package_Or_Body -- 27136 ---------------------------------- 27137 27138 function Find_Related_Package_Or_Body 27139 (Prag : Node_Id; 27140 Do_Checks : Boolean := False) return Node_Id 27141 is 27142 Context : constant Node_Id := Parent (Prag); 27143 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 27144 Stmt : Node_Id; 27145 27146 begin 27147 Stmt := Prev (Prag); 27148 while Present (Stmt) loop 27149 27150 -- Skip prior pragmas, but check for duplicates 27151 27152 if Nkind (Stmt) = N_Pragma then 27153 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then 27154 Duplication_Error 27155 (Prag => Prag, 27156 Prev => Stmt); 27157 end if; 27158 27159 -- Skip internally generated code 27160 27161 elsif not Comes_From_Source (Stmt) then 27162 if Nkind (Stmt) = N_Subprogram_Declaration then 27163 27164 -- The subprogram declaration is an internally generated spec 27165 -- for an expression function. 27166 27167 if Nkind (Original_Node (Stmt)) = N_Expression_Function then 27168 return Stmt; 27169 27170 -- The subprogram is actually an instance housed within an 27171 -- anonymous wrapper package. 27172 27173 elsif Present (Generic_Parent (Specification (Stmt))) then 27174 return Stmt; 27175 end if; 27176 end if; 27177 27178 -- Return the current source construct which is illegal 27179 27180 else 27181 return Stmt; 27182 end if; 27183 27184 Prev (Stmt); 27185 end loop; 27186 27187 -- If we fall through, then the pragma was either the first declaration 27188 -- or it was preceded by other pragmas and no source constructs. 27189 27190 -- The pragma is associated with a package. The immediate context in 27191 -- this case is the specification of the package. 27192 27193 if Nkind (Context) = N_Package_Specification then 27194 return Parent (Context); 27195 27196 -- The pragma appears in the declarations of a package body 27197 27198 elsif Nkind (Context) = N_Package_Body then 27199 return Context; 27200 27201 -- The pragma appears in the statements of a package body 27202 27203 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements 27204 and then Nkind (Parent (Context)) = N_Package_Body 27205 then 27206 return Parent (Context); 27207 27208 -- The pragma is a byproduct of aspect expansion, return the related 27209 -- context of the original aspect. This case has a lower priority as 27210 -- the above circuitry pinpoints precisely the related context. 27211 27212 elsif Present (Corresponding_Aspect (Prag)) then 27213 return Parent (Corresponding_Aspect (Prag)); 27214 27215 -- No candidate packge [body] found 27216 27217 else 27218 return Empty; 27219 end if; 27220 end Find_Related_Package_Or_Body; 27221 27222 ------------------ 27223 -- Get_Argument -- 27224 ------------------ 27225 27226 function Get_Argument 27227 (Prag : Node_Id; 27228 Context_Id : Entity_Id := Empty) return Node_Id 27229 is 27230 Args : constant List_Id := Pragma_Argument_Associations (Prag); 27231 27232 begin 27233 -- Use the expression of the original aspect when compiling for ASIS or 27234 -- when analyzing the template of a generic unit. In both cases the 27235 -- aspect's tree must be decorated to allow for ASIS queries or to save 27236 -- the global references in the generic context. 27237 27238 if From_Aspect_Specification (Prag) 27239 and then (ASIS_Mode or else (Present (Context_Id) 27240 and then Is_Generic_Unit (Context_Id))) 27241 then 27242 return Corresponding_Aspect (Prag); 27243 27244 -- Otherwise use the expression of the pragma 27245 27246 elsif Present (Args) then 27247 return First (Args); 27248 27249 else 27250 return Empty; 27251 end if; 27252 end Get_Argument; 27253 27254 ------------------------- 27255 -- Get_Base_Subprogram -- 27256 ------------------------- 27257 27258 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is 27259 Result : Entity_Id; 27260 27261 begin 27262 -- Follow subprogram renaming chain 27263 27264 Result := Def_Id; 27265 27266 if Is_Subprogram (Result) 27267 and then 27268 Nkind (Parent (Declaration_Node (Result))) = 27269 N_Subprogram_Renaming_Declaration 27270 and then Present (Alias (Result)) 27271 then 27272 Result := Alias (Result); 27273 end if; 27274 27275 return Result; 27276 end Get_Base_Subprogram; 27277 27278 ----------------------- 27279 -- Get_SPARK_Mode_Type -- 27280 ----------------------- 27281 27282 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is 27283 begin 27284 if N = Name_On then 27285 return On; 27286 elsif N = Name_Off then 27287 return Off; 27288 27289 -- Any other argument is illegal 27290 27291 else 27292 raise Program_Error; 27293 end if; 27294 end Get_SPARK_Mode_Type; 27295 27296 -------------------------------- 27297 -- Get_SPARK_Mode_From_Pragma -- 27298 -------------------------------- 27299 27300 function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type is 27301 Args : List_Id; 27302 Mode : Node_Id; 27303 27304 begin 27305 pragma Assert (Nkind (N) = N_Pragma); 27306 Args := Pragma_Argument_Associations (N); 27307 27308 -- Extract the mode from the argument list 27309 27310 if Present (Args) then 27311 Mode := First (Pragma_Argument_Associations (N)); 27312 return Get_SPARK_Mode_Type (Chars (Get_Pragma_Arg (Mode))); 27313 27314 -- If SPARK_Mode pragma has no argument, default is ON 27315 27316 else 27317 return On; 27318 end if; 27319 end Get_SPARK_Mode_From_Pragma; 27320 27321 --------------------------- 27322 -- Has_Extra_Parentheses -- 27323 --------------------------- 27324 27325 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is 27326 Expr : Node_Id; 27327 27328 begin 27329 -- The aggregate should not have an expression list because a clause 27330 -- is always interpreted as a component association. The only way an 27331 -- expression list can sneak in is by adding extra parentheses around 27332 -- the individual clauses: 27333 27334 -- Depends (Output => Input) -- proper form 27335 -- Depends ((Output => Input)) -- extra parentheses 27336 27337 -- Since the extra parentheses are not allowed by the syntax of the 27338 -- pragma, flag them now to avoid emitting misleading errors down the 27339 -- line. 27340 27341 if Nkind (Clause) = N_Aggregate 27342 and then Present (Expressions (Clause)) 27343 then 27344 Expr := First (Expressions (Clause)); 27345 while Present (Expr) loop 27346 27347 -- A dependency clause surrounded by extra parentheses appears 27348 -- as an aggregate of component associations with an optional 27349 -- Paren_Count set. 27350 27351 if Nkind (Expr) = N_Aggregate 27352 and then Present (Component_Associations (Expr)) 27353 then 27354 SPARK_Msg_N 27355 ("dependency clause contains extra parentheses", Expr); 27356 27357 -- Otherwise the expression is a malformed construct 27358 27359 else 27360 SPARK_Msg_N ("malformed dependency clause", Expr); 27361 end if; 27362 27363 Next (Expr); 27364 end loop; 27365 27366 return True; 27367 end if; 27368 27369 return False; 27370 end Has_Extra_Parentheses; 27371 27372 ---------------- 27373 -- Initialize -- 27374 ---------------- 27375 27376 procedure Initialize is 27377 begin 27378 Externals.Init; 27379 end Initialize; 27380 27381 -------- 27382 -- ip -- 27383 -------- 27384 27385 procedure ip is 27386 begin 27387 Dummy := Dummy + 1; 27388 end ip; 27389 27390 ----------------------------- 27391 -- Is_Config_Static_String -- 27392 ----------------------------- 27393 27394 function Is_Config_Static_String (Arg : Node_Id) return Boolean is 27395 27396 function Add_Config_Static_String (Arg : Node_Id) return Boolean; 27397 -- This is an internal recursive function that is just like the outer 27398 -- function except that it adds the string to the name buffer rather 27399 -- than placing the string in the name buffer. 27400 27401 ------------------------------ 27402 -- Add_Config_Static_String -- 27403 ------------------------------ 27404 27405 function Add_Config_Static_String (Arg : Node_Id) return Boolean is 27406 N : Node_Id; 27407 C : Char_Code; 27408 27409 begin 27410 N := Arg; 27411 27412 if Nkind (N) = N_Op_Concat then 27413 if Add_Config_Static_String (Left_Opnd (N)) then 27414 N := Right_Opnd (N); 27415 else 27416 return False; 27417 end if; 27418 end if; 27419 27420 if Nkind (N) /= N_String_Literal then 27421 Error_Msg_N ("string literal expected for pragma argument", N); 27422 return False; 27423 27424 else 27425 for J in 1 .. String_Length (Strval (N)) loop 27426 C := Get_String_Char (Strval (N), J); 27427 27428 if not In_Character_Range (C) then 27429 Error_Msg 27430 ("string literal contains invalid wide character", 27431 Sloc (N) + 1 + Source_Ptr (J)); 27432 return False; 27433 end if; 27434 27435 Add_Char_To_Name_Buffer (Get_Character (C)); 27436 end loop; 27437 end if; 27438 27439 return True; 27440 end Add_Config_Static_String; 27441 27442 -- Start of processing for Is_Config_Static_String 27443 27444 begin 27445 Name_Len := 0; 27446 27447 return Add_Config_Static_String (Arg); 27448 end Is_Config_Static_String; 27449 27450 --------------------- 27451 -- Is_CCT_Instance -- 27452 --------------------- 27453 27454 function Is_CCT_Instance (Ref : Node_Id) return Boolean is 27455 Ref_Id : constant Entity_Id := Entity (Ref); 27456 S : Entity_Id; 27457 27458 begin 27459 -- Climb the scope chain looking for an enclosing concurrent type that 27460 -- matches the referenced entity. 27461 27462 S := Current_Scope; 27463 while Present (S) and then S /= Standard_Standard loop 27464 if Ekind_In (S, E_Protected_Type, E_Task_Type) and then S = Ref_Id 27465 then 27466 return True; 27467 end if; 27468 27469 S := Scope (S); 27470 end loop; 27471 27472 return False; 27473 end Is_CCT_Instance; 27474 27475 ------------------------------- 27476 -- Is_Elaboration_SPARK_Mode -- 27477 ------------------------------- 27478 27479 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is 27480 begin 27481 pragma Assert 27482 (Nkind (N) = N_Pragma 27483 and then Pragma_Name (N) = Name_SPARK_Mode 27484 and then Is_List_Member (N)); 27485 27486 -- Pragma SPARK_Mode affects the elaboration of a package body when it 27487 -- appears in the statement part of the body. 27488 27489 return 27490 Present (Parent (N)) 27491 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements 27492 and then List_Containing (N) = Statements (Parent (N)) 27493 and then Present (Parent (Parent (N))) 27494 and then Nkind (Parent (Parent (N))) = N_Package_Body; 27495 end Is_Elaboration_SPARK_Mode; 27496 27497 ----------------------- 27498 -- Is_Enabled_Pragma -- 27499 ----------------------- 27500 27501 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is 27502 Arg : Node_Id; 27503 27504 begin 27505 if Present (Prag) then 27506 Arg := First (Pragma_Argument_Associations (Prag)); 27507 27508 if Present (Arg) then 27509 return Is_True (Expr_Value (Get_Pragma_Arg (Arg))); 27510 27511 -- The lack of a Boolean argument automatically enables the pragma 27512 27513 else 27514 return True; 27515 end if; 27516 27517 -- The pragma is missing, therefore it is not enabled 27518 27519 else 27520 return False; 27521 end if; 27522 end Is_Enabled_Pragma; 27523 27524 ----------------------------------------- 27525 -- Is_Non_Significant_Pragma_Reference -- 27526 ----------------------------------------- 27527 27528 -- This function makes use of the following static table which indicates 27529 -- whether appearance of some name in a given pragma is to be considered 27530 -- as a reference for the purposes of warnings about unreferenced objects. 27531 27532 -- -1 indicates that appearence in any argument is significant 27533 -- 0 indicates that appearance in any argument is not significant 27534 -- +n indicates that appearance as argument n is significant, but all 27535 -- other arguments are not significant 27536 -- 9n arguments from n on are significant, before n insignificant 27537 27538 Sig_Flags : constant array (Pragma_Id) of Int := 27539 (Pragma_Abort_Defer => -1, 27540 Pragma_Abstract_State => -1, 27541 Pragma_Ada_83 => -1, 27542 Pragma_Ada_95 => -1, 27543 Pragma_Ada_05 => -1, 27544 Pragma_Ada_2005 => -1, 27545 Pragma_Ada_12 => -1, 27546 Pragma_Ada_2012 => -1, 27547 Pragma_All_Calls_Remote => -1, 27548 Pragma_Allow_Integer_Address => -1, 27549 Pragma_Annotate => 93, 27550 Pragma_Assert => -1, 27551 Pragma_Assert_And_Cut => -1, 27552 Pragma_Assertion_Policy => 0, 27553 Pragma_Assume => -1, 27554 Pragma_Assume_No_Invalid_Values => 0, 27555 Pragma_Async_Readers => 0, 27556 Pragma_Async_Writers => 0, 27557 Pragma_Asynchronous => 0, 27558 Pragma_Atomic => 0, 27559 Pragma_Atomic_Components => 0, 27560 Pragma_Attach_Handler => -1, 27561 Pragma_Attribute_Definition => 92, 27562 Pragma_Check => -1, 27563 Pragma_Check_Float_Overflow => 0, 27564 Pragma_Check_Name => 0, 27565 Pragma_Check_Policy => 0, 27566 Pragma_CPP_Class => 0, 27567 Pragma_CPP_Constructor => 0, 27568 Pragma_CPP_Virtual => 0, 27569 Pragma_CPP_Vtable => 0, 27570 Pragma_CPU => -1, 27571 Pragma_C_Pass_By_Copy => 0, 27572 Pragma_Comment => -1, 27573 Pragma_Common_Object => 0, 27574 Pragma_Compile_Time_Error => -1, 27575 Pragma_Compile_Time_Warning => -1, 27576 Pragma_Compiler_Unit => -1, 27577 Pragma_Compiler_Unit_Warning => -1, 27578 Pragma_Complete_Representation => 0, 27579 Pragma_Complex_Representation => 0, 27580 Pragma_Component_Alignment => 0, 27581 Pragma_Constant_After_Elaboration => 0, 27582 Pragma_Contract_Cases => -1, 27583 Pragma_Controlled => 0, 27584 Pragma_Convention => 0, 27585 Pragma_Convention_Identifier => 0, 27586 Pragma_Debug => -1, 27587 Pragma_Debug_Policy => 0, 27588 Pragma_Detect_Blocking => 0, 27589 Pragma_Default_Initial_Condition => -1, 27590 Pragma_Default_Scalar_Storage_Order => 0, 27591 Pragma_Default_Storage_Pool => 0, 27592 Pragma_Depends => -1, 27593 Pragma_Disable_Atomic_Synchronization => 0, 27594 Pragma_Discard_Names => 0, 27595 Pragma_Dispatching_Domain => -1, 27596 Pragma_Effective_Reads => 0, 27597 Pragma_Effective_Writes => 0, 27598 Pragma_Elaborate => 0, 27599 Pragma_Elaborate_All => 0, 27600 Pragma_Elaborate_Body => 0, 27601 Pragma_Elaboration_Checks => 0, 27602 Pragma_Eliminate => 0, 27603 Pragma_Enable_Atomic_Synchronization => 0, 27604 Pragma_Export => -1, 27605 Pragma_Export_Function => -1, 27606 Pragma_Export_Object => -1, 27607 Pragma_Export_Procedure => -1, 27608 Pragma_Export_Value => -1, 27609 Pragma_Export_Valued_Procedure => -1, 27610 Pragma_Extend_System => -1, 27611 Pragma_Extensions_Allowed => 0, 27612 Pragma_Extensions_Visible => 0, 27613 Pragma_External => -1, 27614 Pragma_Favor_Top_Level => 0, 27615 Pragma_External_Name_Casing => 0, 27616 Pragma_Fast_Math => 0, 27617 Pragma_Finalize_Storage_Only => 0, 27618 Pragma_Ghost => 0, 27619 Pragma_Global => -1, 27620 Pragma_Ident => -1, 27621 Pragma_Ignore_Pragma => 0, 27622 Pragma_Implementation_Defined => -1, 27623 Pragma_Implemented => -1, 27624 Pragma_Implicit_Packing => 0, 27625 Pragma_Import => 93, 27626 Pragma_Import_Function => 0, 27627 Pragma_Import_Object => 0, 27628 Pragma_Import_Procedure => 0, 27629 Pragma_Import_Valued_Procedure => 0, 27630 Pragma_Independent => 0, 27631 Pragma_Independent_Components => 0, 27632 Pragma_Initial_Condition => -1, 27633 Pragma_Initialize_Scalars => 0, 27634 Pragma_Initializes => -1, 27635 Pragma_Inline => 0, 27636 Pragma_Inline_Always => 0, 27637 Pragma_Inline_Generic => 0, 27638 Pragma_Inspection_Point => -1, 27639 Pragma_Interface => 92, 27640 Pragma_Interface_Name => 0, 27641 Pragma_Interrupt_Handler => -1, 27642 Pragma_Interrupt_Priority => -1, 27643 Pragma_Interrupt_State => -1, 27644 Pragma_Invariant => -1, 27645 Pragma_Keep_Names => 0, 27646 Pragma_License => 0, 27647 Pragma_Link_With => -1, 27648 Pragma_Linker_Alias => -1, 27649 Pragma_Linker_Constructor => -1, 27650 Pragma_Linker_Destructor => -1, 27651 Pragma_Linker_Options => -1, 27652 Pragma_Linker_Section => 0, 27653 Pragma_List => 0, 27654 Pragma_Lock_Free => 0, 27655 Pragma_Locking_Policy => 0, 27656 Pragma_Loop_Invariant => -1, 27657 Pragma_Loop_Optimize => 0, 27658 Pragma_Loop_Variant => -1, 27659 Pragma_Machine_Attribute => -1, 27660 Pragma_Main => -1, 27661 Pragma_Main_Storage => -1, 27662 Pragma_Memory_Size => 0, 27663 Pragma_No_Return => 0, 27664 Pragma_No_Body => 0, 27665 Pragma_No_Elaboration_Code_All => 0, 27666 Pragma_No_Inline => 0, 27667 Pragma_No_Run_Time => -1, 27668 Pragma_No_Strict_Aliasing => -1, 27669 Pragma_No_Tagged_Streams => 0, 27670 Pragma_Normalize_Scalars => 0, 27671 Pragma_Obsolescent => 0, 27672 Pragma_Optimize => 0, 27673 Pragma_Optimize_Alignment => 0, 27674 Pragma_Overflow_Mode => 0, 27675 Pragma_Overriding_Renamings => 0, 27676 Pragma_Ordered => 0, 27677 Pragma_Pack => 0, 27678 Pragma_Page => 0, 27679 Pragma_Part_Of => 0, 27680 Pragma_Partition_Elaboration_Policy => 0, 27681 Pragma_Passive => 0, 27682 Pragma_Persistent_BSS => 0, 27683 Pragma_Polling => 0, 27684 Pragma_Prefix_Exception_Messages => 0, 27685 Pragma_Post => -1, 27686 Pragma_Postcondition => -1, 27687 Pragma_Post_Class => -1, 27688 Pragma_Pre => -1, 27689 Pragma_Precondition => -1, 27690 Pragma_Predicate => -1, 27691 Pragma_Predicate_Failure => -1, 27692 Pragma_Preelaborable_Initialization => -1, 27693 Pragma_Preelaborate => 0, 27694 Pragma_Pre_Class => -1, 27695 Pragma_Priority => -1, 27696 Pragma_Priority_Specific_Dispatching => 0, 27697 Pragma_Profile => 0, 27698 Pragma_Profile_Warnings => 0, 27699 Pragma_Propagate_Exceptions => 0, 27700 Pragma_Provide_Shift_Operators => 0, 27701 Pragma_Psect_Object => 0, 27702 Pragma_Pure => 0, 27703 Pragma_Pure_Function => 0, 27704 Pragma_Queuing_Policy => 0, 27705 Pragma_Rational => 0, 27706 Pragma_Ravenscar => 0, 27707 Pragma_Refined_Depends => -1, 27708 Pragma_Refined_Global => -1, 27709 Pragma_Refined_Post => -1, 27710 Pragma_Refined_State => -1, 27711 Pragma_Relative_Deadline => 0, 27712 Pragma_Remote_Access_Type => -1, 27713 Pragma_Remote_Call_Interface => -1, 27714 Pragma_Remote_Types => -1, 27715 Pragma_Restricted_Run_Time => 0, 27716 Pragma_Restriction_Warnings => 0, 27717 Pragma_Restrictions => 0, 27718 Pragma_Reviewable => -1, 27719 Pragma_Short_Circuit_And_Or => 0, 27720 Pragma_Share_Generic => 0, 27721 Pragma_Shared => 0, 27722 Pragma_Shared_Passive => 0, 27723 Pragma_Short_Descriptors => 0, 27724 Pragma_Simple_Storage_Pool_Type => 0, 27725 Pragma_Source_File_Name => 0, 27726 Pragma_Source_File_Name_Project => 0, 27727 Pragma_Source_Reference => 0, 27728 Pragma_SPARK_Mode => 0, 27729 Pragma_Storage_Size => -1, 27730 Pragma_Storage_Unit => 0, 27731 Pragma_Static_Elaboration_Desired => 0, 27732 Pragma_Stream_Convert => 0, 27733 Pragma_Style_Checks => 0, 27734 Pragma_Subtitle => 0, 27735 Pragma_Suppress => 0, 27736 Pragma_Suppress_Exception_Locations => 0, 27737 Pragma_Suppress_All => 0, 27738 Pragma_Suppress_Debug_Info => 0, 27739 Pragma_Suppress_Initialization => 0, 27740 Pragma_System_Name => 0, 27741 Pragma_Task_Dispatching_Policy => 0, 27742 Pragma_Task_Info => -1, 27743 Pragma_Task_Name => -1, 27744 Pragma_Task_Storage => -1, 27745 Pragma_Test_Case => -1, 27746 Pragma_Thread_Local_Storage => -1, 27747 Pragma_Time_Slice => -1, 27748 Pragma_Title => 0, 27749 Pragma_Type_Invariant => -1, 27750 Pragma_Type_Invariant_Class => -1, 27751 Pragma_Unchecked_Union => 0, 27752 Pragma_Unimplemented_Unit => 0, 27753 Pragma_Universal_Aliasing => 0, 27754 Pragma_Universal_Data => 0, 27755 Pragma_Unmodified => 0, 27756 Pragma_Unreferenced => 0, 27757 Pragma_Unreferenced_Objects => 0, 27758 Pragma_Unreserve_All_Interrupts => 0, 27759 Pragma_Unsuppress => 0, 27760 Pragma_Unevaluated_Use_Of_Old => 0, 27761 Pragma_Use_VADS_Size => 0, 27762 Pragma_Validity_Checks => 0, 27763 Pragma_Volatile => 0, 27764 Pragma_Volatile_Components => 0, 27765 Pragma_Volatile_Full_Access => 0, 27766 Pragma_Volatile_Function => 0, 27767 Pragma_Warning_As_Error => 0, 27768 Pragma_Warnings => 0, 27769 Pragma_Weak_External => 0, 27770 Pragma_Wide_Character_Encoding => 0, 27771 Unknown_Pragma => 0); 27772 27773 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is 27774 Id : Pragma_Id; 27775 P : Node_Id; 27776 C : Int; 27777 AN : Nat; 27778 27779 function Arg_No return Nat; 27780 -- Returns an integer showing what argument we are in. A value of 27781 -- zero means we are not in any of the arguments. 27782 27783 ------------ 27784 -- Arg_No -- 27785 ------------ 27786 27787 function Arg_No return Nat is 27788 A : Node_Id; 27789 N : Nat; 27790 27791 begin 27792 A := First (Pragma_Argument_Associations (Parent (P))); 27793 N := 1; 27794 loop 27795 if No (A) then 27796 return 0; 27797 elsif A = P then 27798 return N; 27799 end if; 27800 27801 Next (A); 27802 N := N + 1; 27803 end loop; 27804 end Arg_No; 27805 27806 -- Start of processing for Non_Significant_Pragma_Reference 27807 27808 begin 27809 P := Parent (N); 27810 27811 if Nkind (P) /= N_Pragma_Argument_Association then 27812 return False; 27813 27814 else 27815 Id := Get_Pragma_Id (Parent (P)); 27816 C := Sig_Flags (Id); 27817 AN := Arg_No; 27818 27819 if AN = 0 then 27820 return False; 27821 end if; 27822 27823 case C is 27824 when -1 => 27825 return False; 27826 27827 when 0 => 27828 return True; 27829 27830 when 92 .. 99 => 27831 return AN < (C - 90); 27832 27833 when others => 27834 return AN /= C; 27835 end case; 27836 end if; 27837 end Is_Non_Significant_Pragma_Reference; 27838 27839 ------------------------------ 27840 -- Is_Pragma_String_Literal -- 27841 ------------------------------ 27842 27843 -- This function returns true if the corresponding pragma argument is a 27844 -- static string expression. These are the only cases in which string 27845 -- literals can appear as pragma arguments. We also allow a string literal 27846 -- as the first argument to pragma Assert (although it will of course 27847 -- always generate a type error). 27848 27849 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is 27850 Pragn : constant Node_Id := Parent (Par); 27851 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); 27852 Pname : constant Name_Id := Pragma_Name (Pragn); 27853 Argn : Natural; 27854 N : Node_Id; 27855 27856 begin 27857 Argn := 1; 27858 N := First (Assoc); 27859 loop 27860 exit when N = Par; 27861 Argn := Argn + 1; 27862 Next (N); 27863 end loop; 27864 27865 if Pname = Name_Assert then 27866 return True; 27867 27868 elsif Pname = Name_Export then 27869 return Argn > 2; 27870 27871 elsif Pname = Name_Ident then 27872 return Argn = 1; 27873 27874 elsif Pname = Name_Import then 27875 return Argn > 2; 27876 27877 elsif Pname = Name_Interface_Name then 27878 return Argn > 1; 27879 27880 elsif Pname = Name_Linker_Alias then 27881 return Argn = 2; 27882 27883 elsif Pname = Name_Linker_Section then 27884 return Argn = 2; 27885 27886 elsif Pname = Name_Machine_Attribute then 27887 return Argn = 2; 27888 27889 elsif Pname = Name_Source_File_Name then 27890 return True; 27891 27892 elsif Pname = Name_Source_Reference then 27893 return Argn = 2; 27894 27895 elsif Pname = Name_Title then 27896 return True; 27897 27898 elsif Pname = Name_Subtitle then 27899 return True; 27900 27901 else 27902 return False; 27903 end if; 27904 end Is_Pragma_String_Literal; 27905 27906 --------------------------- 27907 -- Is_Private_SPARK_Mode -- 27908 --------------------------- 27909 27910 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is 27911 begin 27912 pragma Assert 27913 (Nkind (N) = N_Pragma 27914 and then Pragma_Name (N) = Name_SPARK_Mode 27915 and then Is_List_Member (N)); 27916 27917 -- For pragma SPARK_Mode to be private, it has to appear in the private 27918 -- declarations of a package. 27919 27920 return 27921 Present (Parent (N)) 27922 and then Nkind (Parent (N)) = N_Package_Specification 27923 and then List_Containing (N) = Private_Declarations (Parent (N)); 27924 end Is_Private_SPARK_Mode; 27925 27926 ------------------------------------- 27927 -- Is_Unconstrained_Or_Tagged_Item -- 27928 ------------------------------------- 27929 27930 function Is_Unconstrained_Or_Tagged_Item 27931 (Item : Entity_Id) return Boolean 27932 is 27933 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean; 27934 -- Determine whether record type Typ has at least one unconstrained 27935 -- component. 27936 27937 --------------------------------- 27938 -- Has_Unconstrained_Component -- 27939 --------------------------------- 27940 27941 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is 27942 Comp : Entity_Id; 27943 27944 begin 27945 Comp := First_Component (Typ); 27946 while Present (Comp) loop 27947 if Is_Unconstrained_Or_Tagged_Item (Comp) then 27948 return True; 27949 end if; 27950 27951 Next_Component (Comp); 27952 end loop; 27953 27954 return False; 27955 end Has_Unconstrained_Component; 27956 27957 -- Local variables 27958 27959 Typ : constant Entity_Id := Etype (Item); 27960 27961 -- Start of processing for Is_Unconstrained_Or_Tagged_Item 27962 27963 begin 27964 if Is_Tagged_Type (Typ) then 27965 return True; 27966 27967 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then 27968 return True; 27969 27970 elsif Is_Record_Type (Typ) then 27971 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then 27972 return True; 27973 else 27974 return Has_Unconstrained_Component (Typ); 27975 end if; 27976 27977 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then 27978 return True; 27979 27980 else 27981 return False; 27982 end if; 27983 end Is_Unconstrained_Or_Tagged_Item; 27984 27985 ----------------------------- 27986 -- Is_Valid_Assertion_Kind -- 27987 ----------------------------- 27988 27989 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is 27990 begin 27991 case Nam is 27992 when 27993 -- RM defined 27994 27995 Name_Assert | 27996 Name_Static_Predicate | 27997 Name_Dynamic_Predicate | 27998 Name_Pre | 27999 Name_uPre | 28000 Name_Post | 28001 Name_uPost | 28002 Name_Type_Invariant | 28003 Name_uType_Invariant | 28004 28005 -- Impl defined 28006 28007 Name_Assert_And_Cut | 28008 Name_Assume | 28009 Name_Contract_Cases | 28010 Name_Debug | 28011 Name_Default_Initial_Condition | 28012 Name_Ghost | 28013 Name_Initial_Condition | 28014 Name_Invariant | 28015 Name_uInvariant | 28016 Name_Loop_Invariant | 28017 Name_Loop_Variant | 28018 Name_Postcondition | 28019 Name_Precondition | 28020 Name_Predicate | 28021 Name_Refined_Post | 28022 Name_Statement_Assertions => return True; 28023 28024 when others => return False; 28025 end case; 28026 end Is_Valid_Assertion_Kind; 28027 28028 -------------------------------------- 28029 -- Process_Compilation_Unit_Pragmas -- 28030 -------------------------------------- 28031 28032 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is 28033 begin 28034 -- A special check for pragma Suppress_All, a very strange DEC pragma, 28035 -- strange because it comes at the end of the unit. Rational has the 28036 -- same name for a pragma, but treats it as a program unit pragma, In 28037 -- GNAT we just decide to allow it anywhere at all. If it appeared then 28038 -- the flag Has_Pragma_Suppress_All was set on the compilation unit 28039 -- node, and we insert a pragma Suppress (All_Checks) at the start of 28040 -- the context clause to ensure the correct processing. 28041 28042 if Has_Pragma_Suppress_All (N) then 28043 Prepend_To (Context_Items (N), 28044 Make_Pragma (Sloc (N), 28045 Chars => Name_Suppress, 28046 Pragma_Argument_Associations => New_List ( 28047 Make_Pragma_Argument_Association (Sloc (N), 28048 Expression => Make_Identifier (Sloc (N), Name_All_Checks))))); 28049 end if; 28050 28051 -- Nothing else to do at the current time 28052 28053 end Process_Compilation_Unit_Pragmas; 28054 28055 ------------------------------------ 28056 -- Record_Possible_Body_Reference -- 28057 ------------------------------------ 28058 28059 procedure Record_Possible_Body_Reference 28060 (State_Id : Entity_Id; 28061 Ref : Node_Id) 28062 is 28063 Context : Node_Id; 28064 Spec_Id : Entity_Id; 28065 28066 begin 28067 -- Ensure that we are dealing with a reference to a state 28068 28069 pragma Assert (Ekind (State_Id) = E_Abstract_State); 28070 28071 -- Climb the tree starting from the reference looking for a package body 28072 -- whose spec declares the referenced state. This criteria automatically 28073 -- excludes references in package specs which are legal. Note that it is 28074 -- not wise to emit an error now as the package body may lack pragma 28075 -- Refined_State or the referenced state may not be mentioned in the 28076 -- refinement. This approach avoids the generation of misleading errors. 28077 28078 Context := Ref; 28079 while Present (Context) loop 28080 if Nkind (Context) = N_Package_Body then 28081 Spec_Id := Corresponding_Spec (Context); 28082 28083 if Present (Abstract_States (Spec_Id)) 28084 and then Contains (Abstract_States (Spec_Id), State_Id) 28085 then 28086 if No (Body_References (State_Id)) then 28087 Set_Body_References (State_Id, New_Elmt_List); 28088 end if; 28089 28090 Append_Elmt (Ref, To => Body_References (State_Id)); 28091 exit; 28092 end if; 28093 end if; 28094 28095 Context := Parent (Context); 28096 end loop; 28097 end Record_Possible_Body_Reference; 28098 28099 ------------------------------------------ 28100 -- Relocate_Pragmas_To_Anonymous_Object -- 28101 ------------------------------------------ 28102 28103 procedure Relocate_Pragmas_To_Anonymous_Object 28104 (Typ_Decl : Node_Id; 28105 Obj_Decl : Node_Id) 28106 is 28107 Decl : Node_Id; 28108 Def : Node_Id; 28109 Next_Decl : Node_Id; 28110 28111 begin 28112 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then 28113 Def := Protected_Definition (Typ_Decl); 28114 else 28115 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration); 28116 Def := Task_Definition (Typ_Decl); 28117 end if; 28118 28119 -- The concurrent definition has a visible declaration list. Inspect it 28120 -- and relocate all canidate pragmas. 28121 28122 if Present (Def) and then Present (Visible_Declarations (Def)) then 28123 Decl := First (Visible_Declarations (Def)); 28124 while Present (Decl) loop 28125 28126 -- Preserve the following declaration for iteration purposes due 28127 -- to possible relocation of a pragma. 28128 28129 Next_Decl := Next (Decl); 28130 28131 if Nkind (Decl) = N_Pragma 28132 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl)) 28133 then 28134 Remove (Decl); 28135 Insert_After (Obj_Decl, Decl); 28136 28137 -- Skip internally generated code 28138 28139 elsif not Comes_From_Source (Decl) then 28140 null; 28141 28142 -- No candidate pragmas are available for relocation 28143 28144 else 28145 exit; 28146 end if; 28147 28148 Decl := Next_Decl; 28149 end loop; 28150 end if; 28151 end Relocate_Pragmas_To_Anonymous_Object; 28152 28153 ------------------------------ 28154 -- Relocate_Pragmas_To_Body -- 28155 ------------------------------ 28156 28157 procedure Relocate_Pragmas_To_Body 28158 (Subp_Body : Node_Id; 28159 Target_Body : Node_Id := Empty) 28160 is 28161 procedure Relocate_Pragma (Prag : Node_Id); 28162 -- Remove a single pragma from its current list and add it to the 28163 -- declarations of the proper body (either Subp_Body or Target_Body). 28164 28165 --------------------- 28166 -- Relocate_Pragma -- 28167 --------------------- 28168 28169 procedure Relocate_Pragma (Prag : Node_Id) is 28170 Decls : List_Id; 28171 Target : Node_Id; 28172 28173 begin 28174 -- When subprogram stubs or expression functions are involves, the 28175 -- destination declaration list belongs to the proper body. 28176 28177 if Present (Target_Body) then 28178 Target := Target_Body; 28179 else 28180 Target := Subp_Body; 28181 end if; 28182 28183 Decls := Declarations (Target); 28184 28185 if No (Decls) then 28186 Decls := New_List; 28187 Set_Declarations (Target, Decls); 28188 end if; 28189 28190 -- Unhook the pragma from its current list 28191 28192 Remove (Prag); 28193 Prepend (Prag, Decls); 28194 end Relocate_Pragma; 28195 28196 -- Local variables 28197 28198 Body_Id : constant Entity_Id := 28199 Defining_Unit_Name (Specification (Subp_Body)); 28200 Next_Stmt : Node_Id; 28201 Stmt : Node_Id; 28202 28203 -- Start of processing for Relocate_Pragmas_To_Body 28204 28205 begin 28206 -- Do not process a body that comes from a separate unit as no construct 28207 -- can possibly follow it. 28208 28209 if not Is_List_Member (Subp_Body) then 28210 return; 28211 28212 -- Do not relocate pragmas that follow a stub if the stub does not have 28213 -- a proper body. 28214 28215 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub 28216 and then No (Target_Body) 28217 then 28218 return; 28219 28220 -- Do not process internally generated routine _Postconditions 28221 28222 elsif Ekind (Body_Id) = E_Procedure 28223 and then Chars (Body_Id) = Name_uPostconditions 28224 then 28225 return; 28226 end if; 28227 28228 -- Look at what is following the body. We are interested in certain kind 28229 -- of pragmas (either from source or byproducts of expansion) that can 28230 -- apply to a body [stub]. 28231 28232 Stmt := Next (Subp_Body); 28233 while Present (Stmt) loop 28234 28235 -- Preserve the following statement for iteration purposes due to a 28236 -- possible relocation of a pragma. 28237 28238 Next_Stmt := Next (Stmt); 28239 28240 -- Move a candidate pragma following the body to the declarations of 28241 -- the body. 28242 28243 if Nkind (Stmt) = N_Pragma 28244 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt)) 28245 then 28246 Relocate_Pragma (Stmt); 28247 28248 -- Skip internally generated code 28249 28250 elsif not Comes_From_Source (Stmt) then 28251 null; 28252 28253 -- No candidate pragmas are available for relocation 28254 28255 else 28256 exit; 28257 end if; 28258 28259 Stmt := Next_Stmt; 28260 end loop; 28261 end Relocate_Pragmas_To_Body; 28262 28263 ------------------- 28264 -- Resolve_State -- 28265 ------------------- 28266 28267 procedure Resolve_State (N : Node_Id) is 28268 Func : Entity_Id; 28269 State : Entity_Id; 28270 28271 begin 28272 if Is_Entity_Name (N) and then Present (Entity (N)) then 28273 Func := Entity (N); 28274 28275 -- Handle overloading of state names by functions. Traverse the 28276 -- homonym chain looking for an abstract state. 28277 28278 if Ekind (Func) = E_Function and then Has_Homonym (Func) then 28279 State := Homonym (Func); 28280 while Present (State) loop 28281 28282 -- Resolve the overloading by setting the proper entity of the 28283 -- reference to that of the state. 28284 28285 if Ekind (State) = E_Abstract_State then 28286 Set_Etype (N, Standard_Void_Type); 28287 Set_Entity (N, State); 28288 Set_Associated_Node (N, State); 28289 return; 28290 end if; 28291 28292 State := Homonym (State); 28293 end loop; 28294 28295 -- A function can never act as a state. If the homonym chain does 28296 -- not contain a corresponding state, then something went wrong in 28297 -- the overloading mechanism. 28298 28299 raise Program_Error; 28300 end if; 28301 end if; 28302 end Resolve_State; 28303 28304 ---------------------------- 28305 -- Rewrite_Assertion_Kind -- 28306 ---------------------------- 28307 28308 procedure Rewrite_Assertion_Kind (N : Node_Id) is 28309 Nam : Name_Id; 28310 28311 begin 28312 if Nkind (N) = N_Attribute_Reference 28313 and then Attribute_Name (N) = Name_Class 28314 and then Nkind (Prefix (N)) = N_Identifier 28315 then 28316 case Chars (Prefix (N)) is 28317 when Name_Pre => 28318 Nam := Name_uPre; 28319 when Name_Post => 28320 Nam := Name_uPost; 28321 when Name_Type_Invariant => 28322 Nam := Name_uType_Invariant; 28323 when Name_Invariant => 28324 Nam := Name_uInvariant; 28325 when others => 28326 return; 28327 end case; 28328 28329 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam)); 28330 end if; 28331 end Rewrite_Assertion_Kind; 28332 28333 -------- 28334 -- rv -- 28335 -------- 28336 28337 procedure rv is 28338 begin 28339 Dummy := Dummy + 1; 28340 end rv; 28341 28342 -------------------------------- 28343 -- Set_Encoded_Interface_Name -- 28344 -------------------------------- 28345 28346 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is 28347 Str : constant String_Id := Strval (S); 28348 Len : constant Int := String_Length (Str); 28349 CC : Char_Code; 28350 C : Character; 28351 J : Int; 28352 28353 Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; 28354 28355 procedure Encode; 28356 -- Stores encoded value of character code CC. The encoding we use an 28357 -- underscore followed by four lower case hex digits. 28358 28359 ------------ 28360 -- Encode -- 28361 ------------ 28362 28363 procedure Encode is 28364 begin 28365 Store_String_Char (Get_Char_Code ('_')); 28366 Store_String_Char 28367 (Get_Char_Code (Hex (Integer (CC / 2 ** 12)))); 28368 Store_String_Char 28369 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#)))); 28370 Store_String_Char 28371 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#)))); 28372 Store_String_Char 28373 (Get_Char_Code (Hex (Integer (CC and 16#0F#)))); 28374 end Encode; 28375 28376 -- Start of processing for Set_Encoded_Interface_Name 28377 28378 begin 28379 -- If first character is asterisk, this is a link name, and we leave it 28380 -- completely unmodified. We also ignore null strings (the latter case 28381 -- happens only in error cases) and no encoding should occur for AAMP 28382 -- interface names. 28383 28384 if Len = 0 28385 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') 28386 or else AAMP_On_Target 28387 then 28388 Set_Interface_Name (E, S); 28389 28390 else 28391 J := 1; 28392 loop 28393 CC := Get_String_Char (Str, J); 28394 28395 exit when not In_Character_Range (CC); 28396 28397 C := Get_Character (CC); 28398 28399 exit when C /= '_' and then C /= '$' 28400 and then C not in '0' .. '9' 28401 and then C not in 'a' .. 'z' 28402 and then C not in 'A' .. 'Z'; 28403 28404 if J = Len then 28405 Set_Interface_Name (E, S); 28406 return; 28407 28408 else 28409 J := J + 1; 28410 end if; 28411 end loop; 28412 28413 -- Here we need to encode. The encoding we use as follows: 28414 -- three underscores + four hex digits (lower case) 28415 28416 Start_String; 28417 28418 for J in 1 .. String_Length (Str) loop 28419 CC := Get_String_Char (Str, J); 28420 28421 if not In_Character_Range (CC) then 28422 Encode; 28423 else 28424 C := Get_Character (CC); 28425 28426 if C = '_' or else C = '$' 28427 or else C in '0' .. '9' 28428 or else C in 'a' .. 'z' 28429 or else C in 'A' .. 'Z' 28430 then 28431 Store_String_Char (CC); 28432 else 28433 Encode; 28434 end if; 28435 end if; 28436 end loop; 28437 28438 Set_Interface_Name (E, 28439 Make_String_Literal (Sloc (S), 28440 Strval => End_String)); 28441 end if; 28442 end Set_Encoded_Interface_Name; 28443 28444 ------------------------ 28445 -- Set_Elab_Unit_Name -- 28446 ------------------------ 28447 28448 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is 28449 Pref : Node_Id; 28450 Scop : Entity_Id; 28451 28452 begin 28453 if Nkind (N) = N_Identifier 28454 and then Nkind (With_Item) = N_Identifier 28455 then 28456 Set_Entity (N, Entity (With_Item)); 28457 28458 elsif Nkind (N) = N_Selected_Component then 28459 Change_Selected_Component_To_Expanded_Name (N); 28460 Set_Entity (N, Entity (With_Item)); 28461 Set_Entity (Selector_Name (N), Entity (N)); 28462 28463 Pref := Prefix (N); 28464 Scop := Scope (Entity (N)); 28465 while Nkind (Pref) = N_Selected_Component loop 28466 Change_Selected_Component_To_Expanded_Name (Pref); 28467 Set_Entity (Selector_Name (Pref), Scop); 28468 Set_Entity (Pref, Scop); 28469 Pref := Prefix (Pref); 28470 Scop := Scope (Scop); 28471 end loop; 28472 28473 Set_Entity (Pref, Scop); 28474 end if; 28475 28476 Generate_Reference (Entity (With_Item), N, Set_Ref => False); 28477 end Set_Elab_Unit_Name; 28478 28479 ------------------- 28480 -- Test_Case_Arg -- 28481 ------------------- 28482 28483 function Test_Case_Arg 28484 (Prag : Node_Id; 28485 Arg_Nam : Name_Id; 28486 From_Aspect : Boolean := False) return Node_Id 28487 is 28488 Aspect : constant Node_Id := Corresponding_Aspect (Prag); 28489 Arg : Node_Id; 28490 Args : Node_Id; 28491 28492 begin 28493 pragma Assert (Nam_In (Arg_Nam, Name_Ensures, 28494 Name_Mode, 28495 Name_Name, 28496 Name_Requires)); 28497 28498 -- The caller requests the aspect argument 28499 28500 if From_Aspect then 28501 if Present (Aspect) 28502 and then Nkind (Expression (Aspect)) = N_Aggregate 28503 then 28504 Args := Expression (Aspect); 28505 28506 -- "Name" and "Mode" may appear without an identifier as a 28507 -- positional association. 28508 28509 if Present (Expressions (Args)) then 28510 Arg := First (Expressions (Args)); 28511 28512 if Present (Arg) and then Arg_Nam = Name_Name then 28513 return Arg; 28514 end if; 28515 28516 -- Skip "Name" 28517 28518 Arg := Next (Arg); 28519 28520 if Present (Arg) and then Arg_Nam = Name_Mode then 28521 return Arg; 28522 end if; 28523 end if; 28524 28525 -- Some or all arguments may appear as component associatons 28526 28527 if Present (Component_Associations (Args)) then 28528 Arg := First (Component_Associations (Args)); 28529 while Present (Arg) loop 28530 if Chars (First (Choices (Arg))) = Arg_Nam then 28531 return Arg; 28532 end if; 28533 28534 Next (Arg); 28535 end loop; 28536 end if; 28537 end if; 28538 28539 -- Otherwise retrieve the argument directly from the pragma 28540 28541 else 28542 Arg := First (Pragma_Argument_Associations (Prag)); 28543 28544 if Present (Arg) and then Arg_Nam = Name_Name then 28545 return Arg; 28546 end if; 28547 28548 -- Skip argument "Name" 28549 28550 Arg := Next (Arg); 28551 28552 if Present (Arg) and then Arg_Nam = Name_Mode then 28553 return Arg; 28554 end if; 28555 28556 -- Skip argument "Mode" 28557 28558 Arg := Next (Arg); 28559 28560 -- Arguments "Requires" and "Ensures" are optional and may not be 28561 -- present at all. 28562 28563 while Present (Arg) loop 28564 if Chars (Arg) = Arg_Nam then 28565 return Arg; 28566 end if; 28567 28568 Next (Arg); 28569 end loop; 28570 end if; 28571 28572 return Empty; 28573 end Test_Case_Arg; 28574 28575end Sem_Prag; 28576