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-2019, 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 Gnatvsn; use Gnatvsn; 47with Lib; use Lib; 48with Lib.Writ; use Lib.Writ; 49with Lib.Xref; use Lib.Xref; 50with Namet.Sp; use Namet.Sp; 51with Nlists; use Nlists; 52with Nmake; use Nmake; 53with Output; use Output; 54with Par_SCO; use Par_SCO; 55with Restrict; use Restrict; 56with Rident; use Rident; 57with Rtsfind; use Rtsfind; 58with Sem; use Sem; 59with Sem_Aux; use Sem_Aux; 60with Sem_Ch3; use Sem_Ch3; 61with Sem_Ch6; use Sem_Ch6; 62with Sem_Ch8; use Sem_Ch8; 63with Sem_Ch12; use Sem_Ch12; 64with Sem_Ch13; use Sem_Ch13; 65with Sem_Disp; use Sem_Disp; 66with Sem_Dist; use Sem_Dist; 67with Sem_Elab; use Sem_Elab; 68with Sem_Elim; use Sem_Elim; 69with Sem_Eval; use Sem_Eval; 70with Sem_Intr; use Sem_Intr; 71with Sem_Mech; use Sem_Mech; 72with Sem_Res; use Sem_Res; 73with Sem_Type; use Sem_Type; 74with Sem_Util; use Sem_Util; 75with Sem_Warn; use Sem_Warn; 76with Stand; use Stand; 77with Sinfo; use Sinfo; 78with Sinfo.CN; use Sinfo.CN; 79with Sinput; use Sinput; 80with Stringt; use Stringt; 81with Stylesw; use Stylesw; 82with Table; 83with Targparm; use Targparm; 84with Tbuild; use Tbuild; 85with Ttypes; 86with Uintp; use Uintp; 87with Uname; use Uname; 88with Urealp; use Urealp; 89with Validsw; use Validsw; 90with Warnsw; use Warnsw; 91 92with System.Case_Util; 93 94package body Sem_Prag is 95 96 ---------------------------------------------- 97 -- Common Handling of Import-Export Pragmas -- 98 ---------------------------------------------- 99 100 -- In the following section, a number of Import_xxx and Export_xxx pragmas 101 -- are defined by GNAT. These are compatible with the DEC pragmas of the 102 -- same name, and all have the following common form and processing: 103 104 -- pragma Export_xxx 105 -- [Internal =>] LOCAL_NAME 106 -- [, [External =>] EXTERNAL_SYMBOL] 107 -- [, other optional parameters ]); 108 109 -- pragma Import_xxx 110 -- [Internal =>] LOCAL_NAME 111 -- [, [External =>] EXTERNAL_SYMBOL] 112 -- [, other optional parameters ]); 113 114 -- EXTERNAL_SYMBOL ::= 115 -- IDENTIFIER 116 -- | static_string_EXPRESSION 117 118 -- The internal LOCAL_NAME designates the entity that is imported or 119 -- exported, and must refer to an entity in the current declarative 120 -- part (as required by the rules for LOCAL_NAME). 121 122 -- The external linker name is designated by the External parameter if 123 -- given, or the Internal parameter if not (if there is no External 124 -- parameter, the External parameter is a copy of the Internal name). 125 126 -- If the External parameter is given as a string, then this string is 127 -- treated as an external name (exactly as though it had been given as an 128 -- External_Name parameter for a normal Import pragma). 129 130 -- If the External parameter is given as an identifier (or there is no 131 -- External parameter, so that the Internal identifier is used), then 132 -- the external name is the characters of the identifier, translated 133 -- to all lower case letters. 134 135 -- Note: the external name specified or implied by any of these special 136 -- Import_xxx or Export_xxx pragmas override an external or link name 137 -- specified in a previous Import or Export pragma. 138 139 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of 140 -- named notation, following the standard rules for subprogram calls, i.e. 141 -- parameters can be given in any order if named notation is used, and 142 -- positional and named notation can be mixed, subject to the rule that all 143 -- positional parameters must appear first. 144 145 -- Note: All these pragmas are implemented exactly following the DEC design 146 -- and implementation and are intended to be fully compatible with the use 147 -- of these pragmas in the DEC Ada compiler. 148 149 -------------------------------------------- 150 -- Checking for Duplicated External Names -- 151 -------------------------------------------- 152 153 -- It is suspicious if two separate Export pragmas use the same external 154 -- name. The following table is used to diagnose this situation so that 155 -- an appropriate warning can be issued. 156 157 -- The Node_Id stored is for the N_String_Literal node created to hold 158 -- the value of the external name. The Sloc of this node is used to 159 -- cross-reference the location of the duplication. 160 161 package Externals is new Table.Table ( 162 Table_Component_Type => Node_Id, 163 Table_Index_Type => Int, 164 Table_Low_Bound => 0, 165 Table_Initial => 100, 166 Table_Increment => 100, 167 Table_Name => "Name_Externals"); 168 169 ------------------------------------- 170 -- Local Subprograms and Variables -- 171 ------------------------------------- 172 173 function Adjust_External_Name_Case (N : Node_Id) return Node_Id; 174 -- This routine is used for possible casing adjustment of an explicit 175 -- external name supplied as a string literal (the node N), according to 176 -- the casing requirement of Opt.External_Name_Casing. If this is set to 177 -- As_Is, then the string literal is returned unchanged, but if it is set 178 -- to Uppercase or Lowercase, then a new string literal with appropriate 179 -- casing is constructed. 180 181 procedure Analyze_Part_Of 182 (Indic : Node_Id; 183 Item_Id : Entity_Id; 184 Encap : Node_Id; 185 Encap_Id : out Entity_Id; 186 Legal : out Boolean); 187 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and 188 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the 189 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or 190 -- package instantiation. Encap denotes the encapsulating state or single 191 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when 192 -- the indicator is legal. 193 194 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean; 195 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends. 196 -- Query whether a particular item appears in a mixed list of nodes and 197 -- entities. It is assumed that all nodes in the list have entities. 198 199 procedure Check_Postcondition_Use_In_Inlined_Subprogram 200 (Prag : Node_Id; 201 Spec_Id : Entity_Id); 202 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition, 203 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma 204 -- Prag is associated with subprogram Spec_Id subject to Inline_Always, 205 -- and assertions are enabled. 206 207 procedure Check_State_And_Constituent_Use 208 (States : Elist_Id; 209 Constits : Elist_Id; 210 Context : Node_Id); 211 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_] 212 -- Global and Initializes. Determine whether a state from list States and a 213 -- corresponding constituent from list Constits (if any) appear in the same 214 -- context denoted by Context. If this is the case, emit an error. 215 216 procedure Contract_Freeze_Error 217 (Contract_Id : Entity_Id; 218 Freeze_Id : Entity_Id); 219 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and 220 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity 221 -- of a body which caused contract freezing and Contract_Id denotes the 222 -- entity of the affected contstruct. 223 224 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id); 225 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma 226 -- Prag that duplicates previous pragma Prev. 227 228 function Find_Encapsulating_State 229 (States : Elist_Id; 230 Constit_Id : Entity_Id) return Entity_Id; 231 -- Given the entity of a constituent Constit_Id, find the corresponding 232 -- encapsulating state which appears in States. The routine returns Empty 233 -- if no such state is found. 234 235 function Find_Related_Context 236 (Prag : Node_Id; 237 Do_Checks : Boolean := False) return Node_Id; 238 -- Subsidiary to the analysis of pragmas 239 -- Async_Readers 240 -- Async_Writers 241 -- Constant_After_Elaboration 242 -- Effective_Reads 243 -- Effective_Writers 244 -- Part_Of 245 -- Find the first source declaration or statement found while traversing 246 -- the previous node chain starting from pragma Prag. If flag Do_Checks is 247 -- set, the routine reports duplicate pragmas. The routine returns Empty 248 -- when reaching the start of the node chain. 249 250 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; 251 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the 252 -- original one, following the renaming chain) is returned. Otherwise the 253 -- entity is returned unchanged. Should be in Einfo??? 254 255 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type; 256 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram 257 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding 258 -- value of type SPARK_Mode_Type. 259 260 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean; 261 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends. 262 -- Determine whether dependency clause Clause is surrounded by extra 263 -- parentheses. If this is the case, issue an error message. 264 265 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; 266 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of 267 -- pragma Depends. Determine whether the type of dependency item Item is 268 -- tagged, unconstrained array, unconstrained record or a record with at 269 -- least one unconstrained component. 270 271 procedure Record_Possible_Body_Reference 272 (State_Id : Entity_Id; 273 Ref : Node_Id); 274 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] 275 -- Global. Given an abstract state denoted by State_Id and a reference Ref 276 -- to it, determine whether the reference appears in a package body that 277 -- will eventually refine the state. If this is the case, record the 278 -- reference for future checks (see Analyze_Refined_State_In_Decls). 279 280 procedure Resolve_State (N : Node_Id); 281 -- Handle the overloading of state names by functions. When N denotes a 282 -- function, this routine finds the corresponding state and sets the entity 283 -- of N to that of the state. 284 285 procedure Rewrite_Assertion_Kind 286 (N : Node_Id; 287 From_Policy : Boolean := False); 288 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class, 289 -- then it is rewritten as an identifier with the corresponding special 290 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check 291 -- and Check_Policy. If the names are Precondition or Postcondition, this 292 -- combination is deprecated in favor of Assertion_Policy and Ada2012 293 -- Aspect names. The parameter From_Policy indicates that the pragma 294 -- is the old non-standard Check_Policy and not a rewritten pragma. 295 296 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id); 297 -- Place semantic information on the argument of an Elaborate/Elaborate_All 298 -- pragma. Entity name for unit and its parents is taken from item in 299 -- previous with_clause that mentions the unit. 300 301 Dummy : Integer := 0; 302 pragma Volatile (Dummy); 303 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization 304 305 procedure ip; 306 pragma No_Inline (ip); 307 -- A dummy procedure called when pragma Inspection_Point is analyzed. This 308 -- is just to help debugging the front end. If a pragma Inspection_Point 309 -- is added to a source program, then breaking on ip will get you to that 310 -- point in the program. 311 312 procedure rv; 313 pragma No_Inline (rv); 314 -- This is a dummy function called by the processing for pragma Reviewable. 315 -- It is there for assisting front end debugging. By placing a Reviewable 316 -- pragma in the source program, a breakpoint on rv catches this place in 317 -- the source, allowing convenient stepping to the point of interest. 318 319 ------------------------------- 320 -- Adjust_External_Name_Case -- 321 ------------------------------- 322 323 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is 324 CC : Char_Code; 325 326 begin 327 -- Adjust case of literal if required 328 329 if Opt.External_Name_Exp_Casing = As_Is then 330 return N; 331 332 else 333 -- Copy existing string 334 335 Start_String; 336 337 -- Set proper casing 338 339 for J in 1 .. String_Length (Strval (N)) loop 340 CC := Get_String_Char (Strval (N), J); 341 342 if Opt.External_Name_Exp_Casing = Uppercase 343 and then CC >= Get_Char_Code ('a') 344 and then CC <= Get_Char_Code ('z') 345 then 346 Store_String_Char (CC - 32); 347 348 elsif Opt.External_Name_Exp_Casing = Lowercase 349 and then CC >= Get_Char_Code ('A') 350 and then CC <= Get_Char_Code ('Z') 351 then 352 Store_String_Char (CC + 32); 353 354 else 355 Store_String_Char (CC); 356 end if; 357 end loop; 358 359 return 360 Make_String_Literal (Sloc (N), 361 Strval => End_String); 362 end if; 363 end Adjust_External_Name_Case; 364 365 ----------------------------------------- 366 -- Analyze_Contract_Cases_In_Decl_Part -- 367 ----------------------------------------- 368 369 -- WARNING: This routine manages Ghost regions. Return statements must be 370 -- replaced by gotos which jump to the end of the routine and restore the 371 -- Ghost mode. 372 373 procedure Analyze_Contract_Cases_In_Decl_Part 374 (N : Node_Id; 375 Freeze_Id : Entity_Id := Empty) 376 is 377 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 378 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 379 380 Others_Seen : Boolean := False; 381 -- This flag is set when an "others" choice is encountered. It is used 382 -- to detect multiple illegal occurrences of "others". 383 384 procedure Analyze_Contract_Case (CCase : Node_Id); 385 -- Verify the legality of a single contract case 386 387 --------------------------- 388 -- Analyze_Contract_Case -- 389 --------------------------- 390 391 procedure Analyze_Contract_Case (CCase : Node_Id) is 392 Case_Guard : Node_Id; 393 Conseq : Node_Id; 394 Errors : Nat; 395 Extra_Guard : Node_Id; 396 397 begin 398 if Nkind (CCase) = N_Component_Association then 399 Case_Guard := First (Choices (CCase)); 400 Conseq := Expression (CCase); 401 402 -- Each contract case must have exactly one case guard 403 404 Extra_Guard := Next (Case_Guard); 405 406 if Present (Extra_Guard) then 407 Error_Msg_N 408 ("contract case must have exactly one case guard", 409 Extra_Guard); 410 end if; 411 412 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1)) 413 414 if Nkind (Case_Guard) = N_Others_Choice then 415 if Others_Seen then 416 Error_Msg_N 417 ("only one others choice allowed in contract cases", 418 Case_Guard); 419 else 420 Others_Seen := True; 421 end if; 422 423 elsif Others_Seen then 424 Error_Msg_N 425 ("others must be the last choice in contract cases", N); 426 end if; 427 428 -- Preanalyze the case guard and consequence 429 430 if Nkind (Case_Guard) /= N_Others_Choice then 431 Errors := Serious_Errors_Detected; 432 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); 433 434 -- Emit a clarification message when the case guard contains 435 -- at least one undefined reference, possibly due to contract 436 -- freezing. 437 438 if Errors /= Serious_Errors_Detected 439 and then Present (Freeze_Id) 440 and then Has_Undefined_Reference (Case_Guard) 441 then 442 Contract_Freeze_Error (Spec_Id, Freeze_Id); 443 end if; 444 end if; 445 446 Errors := Serious_Errors_Detected; 447 Preanalyze_Assert_Expression (Conseq, Standard_Boolean); 448 449 -- Emit a clarification message when the consequence contains 450 -- at least one undefined reference, possibly due to contract 451 -- freezing. 452 453 if Errors /= Serious_Errors_Detected 454 and then Present (Freeze_Id) 455 and then Has_Undefined_Reference (Conseq) 456 then 457 Contract_Freeze_Error (Spec_Id, Freeze_Id); 458 end if; 459 460 -- The contract case is malformed 461 462 else 463 Error_Msg_N ("wrong syntax in contract case", CCase); 464 end if; 465 end Analyze_Contract_Case; 466 467 -- Local variables 468 469 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 470 471 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 472 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 473 -- Save the Ghost-related attributes to restore on exit 474 475 CCase : Node_Id; 476 Restore_Scope : Boolean := False; 477 478 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part 479 480 begin 481 -- Do not analyze the pragma multiple times 482 483 if Is_Analyzed_Pragma (N) then 484 return; 485 end if; 486 487 -- Set the Ghost mode in effect from the pragma. Due to the delayed 488 -- analysis of the pragma, the Ghost mode at point of declaration and 489 -- point of analysis may not necessarily be the same. Use the mode in 490 -- effect at the point of declaration. 491 492 Set_Ghost_Mode (N); 493 494 -- Single and multiple contract cases must appear in aggregate form. If 495 -- this is not the case, then either the parser of the analysis of the 496 -- pragma failed to produce an aggregate. 497 498 pragma Assert (Nkind (CCases) = N_Aggregate); 499 500 if Present (Component_Associations (CCases)) then 501 502 -- Ensure that the formal parameters are visible when analyzing all 503 -- clauses. This falls out of the general rule of aspects pertaining 504 -- to subprogram declarations. 505 506 if not In_Open_Scopes (Spec_Id) then 507 Restore_Scope := True; 508 Push_Scope (Spec_Id); 509 510 if Is_Generic_Subprogram (Spec_Id) then 511 Install_Generic_Formals (Spec_Id); 512 else 513 Install_Formals (Spec_Id); 514 end if; 515 end if; 516 517 CCase := First (Component_Associations (CCases)); 518 while Present (CCase) loop 519 Analyze_Contract_Case (CCase); 520 Next (CCase); 521 end loop; 522 523 if Restore_Scope then 524 End_Scope; 525 end if; 526 527 -- Currently it is not possible to inline pre/postconditions on a 528 -- subprogram subject to pragma Inline_Always. 529 530 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 531 532 -- Otherwise the pragma is illegal 533 534 else 535 Error_Msg_N ("wrong syntax for constract cases", N); 536 end if; 537 538 Set_Is_Analyzed_Pragma (N); 539 540 Restore_Ghost_Region (Saved_GM, Saved_IGR); 541 end Analyze_Contract_Cases_In_Decl_Part; 542 543 ---------------------------------- 544 -- Analyze_Depends_In_Decl_Part -- 545 ---------------------------------- 546 547 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is 548 Loc : constant Source_Ptr := Sloc (N); 549 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 550 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 551 552 All_Inputs_Seen : Elist_Id := No_Elist; 553 -- A list containing the entities of all the inputs processed so far. 554 -- The list is populated with unique entities because the same input 555 -- may appear in multiple input lists. 556 557 All_Outputs_Seen : Elist_Id := No_Elist; 558 -- A list containing the entities of all the outputs processed so far. 559 -- The list is populated with unique entities because output items are 560 -- unique in a dependence relation. 561 562 Constits_Seen : Elist_Id := No_Elist; 563 -- A list containing the entities of all constituents processed so far. 564 -- It aids in detecting illegal usage of a state and a corresponding 565 -- constituent in pragma [Refinde_]Depends. 566 567 Global_Seen : Boolean := False; 568 -- A flag set when pragma Global has been processed 569 570 Null_Output_Seen : Boolean := False; 571 -- A flag used to track the legality of a null output 572 573 Result_Seen : Boolean := False; 574 -- A flag set when Spec_Id'Result is processed 575 576 States_Seen : Elist_Id := No_Elist; 577 -- A list containing the entities of all states processed so far. It 578 -- helps in detecting illegal usage of a state and a corresponding 579 -- constituent in pragma [Refined_]Depends. 580 581 Subp_Inputs : Elist_Id := No_Elist; 582 Subp_Outputs : Elist_Id := No_Elist; 583 -- Two lists containing the full set of inputs and output of the related 584 -- subprograms. Note that these lists contain both nodes and entities. 585 586 Task_Input_Seen : Boolean := False; 587 Task_Output_Seen : Boolean := False; 588 -- Flags used to track the implicit dependence of a task unit on itself 589 590 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id); 591 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind 592 -- to the name buffer. The individual kinds are as follows: 593 -- E_Abstract_State - "state" 594 -- E_Constant - "constant" 595 -- E_Generic_In_Out_Parameter - "generic parameter" 596 -- E_Generic_In_Parameter - "generic parameter" 597 -- E_In_Parameter - "parameter" 598 -- E_In_Out_Parameter - "parameter" 599 -- E_Loop_Parameter - "loop parameter" 600 -- E_Out_Parameter - "parameter" 601 -- E_Protected_Type - "current instance of protected type" 602 -- E_Task_Type - "current instance of task type" 603 -- E_Variable - "global" 604 605 procedure Analyze_Dependency_Clause 606 (Clause : Node_Id; 607 Is_Last : Boolean); 608 -- Verify the legality of a single dependency clause. Flag Is_Last 609 -- denotes whether Clause is the last clause in the relation. 610 611 procedure Check_Function_Return; 612 -- Verify that Funtion'Result appears as one of the outputs 613 -- (SPARK RM 6.1.5(10)). 614 615 procedure Check_Role 616 (Item : Node_Id; 617 Item_Id : Entity_Id; 618 Is_Input : Boolean; 619 Self_Ref : Boolean); 620 -- Ensure that an item fulfills its designated input and/or output role 621 -- as specified by pragma Global (if any) or the enclosing context. If 622 -- this is not the case, emit an error. Item and Item_Id denote the 623 -- attributes of an item. Flag Is_Input should be set when item comes 624 -- from an input list. Flag Self_Ref should be set when the item is an 625 -- output and the dependency clause has operator "+". 626 627 procedure Check_Usage 628 (Subp_Items : Elist_Id; 629 Used_Items : Elist_Id; 630 Is_Input : Boolean); 631 -- Verify that all items from Subp_Items appear in Used_Items. Emit an 632 -- error if this is not the case. 633 634 procedure Normalize_Clause (Clause : Node_Id); 635 -- Remove a self-dependency "+" from the input list of a clause 636 637 ----------------------------- 638 -- Add_Item_To_Name_Buffer -- 639 ----------------------------- 640 641 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is 642 begin 643 if Ekind (Item_Id) = E_Abstract_State then 644 Add_Str_To_Name_Buffer ("state"); 645 646 elsif Ekind (Item_Id) = E_Constant then 647 Add_Str_To_Name_Buffer ("constant"); 648 649 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, 650 E_Generic_In_Parameter) 651 then 652 Add_Str_To_Name_Buffer ("generic parameter"); 653 654 elsif Is_Formal (Item_Id) then 655 Add_Str_To_Name_Buffer ("parameter"); 656 657 elsif Ekind (Item_Id) = E_Loop_Parameter then 658 Add_Str_To_Name_Buffer ("loop parameter"); 659 660 elsif Ekind (Item_Id) = E_Protected_Type 661 or else Is_Single_Protected_Object (Item_Id) 662 then 663 Add_Str_To_Name_Buffer ("current instance of protected type"); 664 665 elsif Ekind (Item_Id) = E_Task_Type 666 or else Is_Single_Task_Object (Item_Id) 667 then 668 Add_Str_To_Name_Buffer ("current instance of task type"); 669 670 elsif Ekind (Item_Id) = E_Variable then 671 Add_Str_To_Name_Buffer ("global"); 672 673 -- The routine should not be called with non-SPARK items 674 675 else 676 raise Program_Error; 677 end if; 678 end Add_Item_To_Name_Buffer; 679 680 ------------------------------- 681 -- Analyze_Dependency_Clause -- 682 ------------------------------- 683 684 procedure Analyze_Dependency_Clause 685 (Clause : Node_Id; 686 Is_Last : Boolean) 687 is 688 procedure Analyze_Input_List (Inputs : Node_Id); 689 -- Verify the legality of a single input list 690 691 procedure Analyze_Input_Output 692 (Item : Node_Id; 693 Is_Input : Boolean; 694 Self_Ref : Boolean; 695 Top_Level : Boolean; 696 Seen : in out Elist_Id; 697 Null_Seen : in out Boolean; 698 Non_Null_Seen : in out Boolean); 699 -- Verify the legality of a single input or output item. Flag 700 -- Is_Input should be set whenever Item is an input, False when it 701 -- denotes an output. Flag Self_Ref should be set when the item is an 702 -- output and the dependency clause has a "+". Flag Top_Level should 703 -- be set whenever Item appears immediately within an input or output 704 -- list. Seen is a collection of all abstract states, objects and 705 -- formals processed so far. Flag Null_Seen denotes whether a null 706 -- input or output has been encountered. Flag Non_Null_Seen denotes 707 -- whether a non-null input or output has been encountered. 708 709 ------------------------ 710 -- Analyze_Input_List -- 711 ------------------------ 712 713 procedure Analyze_Input_List (Inputs : Node_Id) is 714 Inputs_Seen : Elist_Id := No_Elist; 715 -- A list containing the entities of all inputs that appear in the 716 -- current input list. 717 718 Non_Null_Input_Seen : Boolean := False; 719 Null_Input_Seen : Boolean := False; 720 -- Flags used to check the legality of an input list 721 722 Input : Node_Id; 723 724 begin 725 -- Multiple inputs appear as an aggregate 726 727 if Nkind (Inputs) = N_Aggregate then 728 if Present (Component_Associations (Inputs)) then 729 SPARK_Msg_N 730 ("nested dependency relations not allowed", Inputs); 731 732 elsif Present (Expressions (Inputs)) then 733 Input := First (Expressions (Inputs)); 734 while Present (Input) loop 735 Analyze_Input_Output 736 (Item => Input, 737 Is_Input => True, 738 Self_Ref => False, 739 Top_Level => False, 740 Seen => Inputs_Seen, 741 Null_Seen => Null_Input_Seen, 742 Non_Null_Seen => Non_Null_Input_Seen); 743 744 Next (Input); 745 end loop; 746 747 -- Syntax error, always report 748 749 else 750 Error_Msg_N ("malformed input dependency list", Inputs); 751 end if; 752 753 -- Process a solitary input 754 755 else 756 Analyze_Input_Output 757 (Item => Inputs, 758 Is_Input => True, 759 Self_Ref => False, 760 Top_Level => False, 761 Seen => Inputs_Seen, 762 Null_Seen => Null_Input_Seen, 763 Non_Null_Seen => Non_Null_Input_Seen); 764 end if; 765 766 -- Detect an illegal dependency clause of the form 767 768 -- (null =>[+] null) 769 770 if Null_Output_Seen and then Null_Input_Seen then 771 SPARK_Msg_N 772 ("null dependency clause cannot have a null input list", 773 Inputs); 774 end if; 775 end Analyze_Input_List; 776 777 -------------------------- 778 -- Analyze_Input_Output -- 779 -------------------------- 780 781 procedure Analyze_Input_Output 782 (Item : Node_Id; 783 Is_Input : Boolean; 784 Self_Ref : Boolean; 785 Top_Level : Boolean; 786 Seen : in out Elist_Id; 787 Null_Seen : in out Boolean; 788 Non_Null_Seen : in out Boolean) 789 is 790 procedure Current_Task_Instance_Seen; 791 -- Set the appropriate global flag when the current instance of a 792 -- task unit is encountered. 793 794 -------------------------------- 795 -- Current_Task_Instance_Seen -- 796 -------------------------------- 797 798 procedure Current_Task_Instance_Seen is 799 begin 800 if Is_Input then 801 Task_Input_Seen := True; 802 else 803 Task_Output_Seen := True; 804 end if; 805 end Current_Task_Instance_Seen; 806 807 -- Local variables 808 809 Is_Output : constant Boolean := not Is_Input; 810 Grouped : Node_Id; 811 Item_Id : Entity_Id; 812 813 -- Start of processing for Analyze_Input_Output 814 815 begin 816 -- Multiple input or output items appear as an aggregate 817 818 if Nkind (Item) = N_Aggregate then 819 if not Top_Level then 820 SPARK_Msg_N ("nested grouping of items not allowed", Item); 821 822 elsif Present (Component_Associations (Item)) then 823 SPARK_Msg_N 824 ("nested dependency relations not allowed", Item); 825 826 -- Recursively analyze the grouped items 827 828 elsif Present (Expressions (Item)) then 829 Grouped := First (Expressions (Item)); 830 while Present (Grouped) loop 831 Analyze_Input_Output 832 (Item => Grouped, 833 Is_Input => Is_Input, 834 Self_Ref => Self_Ref, 835 Top_Level => False, 836 Seen => Seen, 837 Null_Seen => Null_Seen, 838 Non_Null_Seen => Non_Null_Seen); 839 840 Next (Grouped); 841 end loop; 842 843 -- Syntax error, always report 844 845 else 846 Error_Msg_N ("malformed dependency list", Item); 847 end if; 848 849 -- Process attribute 'Result in the context of a dependency clause 850 851 elsif Is_Attribute_Result (Item) then 852 Non_Null_Seen := True; 853 854 Analyze (Item); 855 856 -- Attribute 'Result is allowed to appear on the output side of 857 -- a dependency clause (SPARK RM 6.1.5(6)). 858 859 if Is_Input then 860 SPARK_Msg_N ("function result cannot act as input", Item); 861 862 elsif Null_Seen then 863 SPARK_Msg_N 864 ("cannot mix null and non-null dependency items", Item); 865 866 else 867 Result_Seen := True; 868 end if; 869 870 -- Detect multiple uses of null in a single dependency list or 871 -- throughout the whole relation. Verify the placement of a null 872 -- output list relative to the other clauses (SPARK RM 6.1.5(12)). 873 874 elsif Nkind (Item) = N_Null then 875 if Null_Seen then 876 SPARK_Msg_N 877 ("multiple null dependency relations not allowed", Item); 878 879 elsif Non_Null_Seen then 880 SPARK_Msg_N 881 ("cannot mix null and non-null dependency items", Item); 882 883 else 884 Null_Seen := True; 885 886 if Is_Output then 887 if not Is_Last then 888 SPARK_Msg_N 889 ("null output list must be the last clause in a " 890 & "dependency relation", Item); 891 892 -- Catch a useless dependence of the form: 893 -- null =>+ ... 894 895 elsif Self_Ref then 896 SPARK_Msg_N 897 ("useless dependence, null depends on itself", Item); 898 end if; 899 end if; 900 end if; 901 902 -- Default case 903 904 else 905 Non_Null_Seen := True; 906 907 if Null_Seen then 908 SPARK_Msg_N ("cannot mix null and non-null items", Item); 909 end if; 910 911 Analyze (Item); 912 Resolve_State (Item); 913 914 -- Find the entity of the item. If this is a renaming, climb 915 -- the renaming chain to reach the root object. Renamings of 916 -- non-entire objects do not yield an entity (Empty). 917 918 Item_Id := Entity_Of (Item); 919 920 if Present (Item_Id) then 921 922 -- Constants 923 924 if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter) 925 or else 926 927 -- Current instances of concurrent types 928 929 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) 930 or else 931 932 -- Formal parameters 933 934 Ekind_In (Item_Id, E_Generic_In_Out_Parameter, 935 E_Generic_In_Parameter, 936 E_In_Parameter, 937 E_In_Out_Parameter, 938 E_Out_Parameter) 939 or else 940 941 -- States, variables 942 943 Ekind_In (Item_Id, E_Abstract_State, E_Variable) 944 then 945 -- A [generic] function is not allowed to have Output 946 -- items in its dependency relations. Note that "null" 947 -- and attribute 'Result are still valid items. 948 949 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 950 and then not Is_Input 951 then 952 SPARK_Msg_N 953 ("output item is not applicable to function", Item); 954 end if; 955 956 -- The item denotes a concurrent type. Note that single 957 -- protected/task types are not considered here because 958 -- they behave as objects in the context of pragma 959 -- [Refined_]Depends. 960 961 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then 962 963 -- This use is legal as long as the concurrent type is 964 -- the current instance of an enclosing type. 965 966 if Is_CCT_Instance (Item_Id, Spec_Id) then 967 968 -- The dependence of a task unit on itself is 969 -- implicit and may or may not be explicitly 970 -- specified (SPARK RM 6.1.4). 971 972 if Ekind (Item_Id) = E_Task_Type then 973 Current_Task_Instance_Seen; 974 end if; 975 976 -- Otherwise this is not the current instance 977 978 else 979 SPARK_Msg_N 980 ("invalid use of subtype mark in dependency " 981 & "relation", Item); 982 end if; 983 984 -- The dependency of a task unit on itself is implicit 985 -- and may or may not be explicitly specified 986 -- (SPARK RM 6.1.4). 987 988 elsif Is_Single_Task_Object (Item_Id) 989 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id) 990 then 991 Current_Task_Instance_Seen; 992 end if; 993 994 -- Ensure that the item fulfills its role as input and/or 995 -- output as specified by pragma Global or the enclosing 996 -- context. 997 998 Check_Role (Item, Item_Id, Is_Input, Self_Ref); 999 1000 -- Detect multiple uses of the same state, variable or 1001 -- formal parameter. If this is not the case, add the 1002 -- item to the list of processed relations. 1003 1004 if Contains (Seen, Item_Id) then 1005 SPARK_Msg_NE 1006 ("duplicate use of item &", Item, Item_Id); 1007 else 1008 Append_New_Elmt (Item_Id, Seen); 1009 end if; 1010 1011 -- Detect illegal use of an input related to a null 1012 -- output. Such input items cannot appear in other 1013 -- input lists (SPARK RM 6.1.5(13)). 1014 1015 if Is_Input 1016 and then Null_Output_Seen 1017 and then Contains (All_Inputs_Seen, Item_Id) 1018 then 1019 SPARK_Msg_N 1020 ("input of a null output list cannot appear in " 1021 & "multiple input lists", Item); 1022 end if; 1023 1024 -- Add an input or a self-referential output to the list 1025 -- of all processed inputs. 1026 1027 if Is_Input or else Self_Ref then 1028 Append_New_Elmt (Item_Id, All_Inputs_Seen); 1029 end if; 1030 1031 -- State related checks (SPARK RM 6.1.5(3)) 1032 1033 if Ekind (Item_Id) = E_Abstract_State then 1034 1035 -- Package and subprogram bodies are instantiated 1036 -- individually in a separate compiler pass. Due to 1037 -- this mode of instantiation, the refinement of a 1038 -- state may no longer be visible when a subprogram 1039 -- body contract is instantiated. Since the generic 1040 -- template is legal, do not perform this check in 1041 -- the instance to circumvent this oddity. 1042 1043 if Is_Generic_Instance (Spec_Id) then 1044 null; 1045 1046 -- An abstract state with visible refinement cannot 1047 -- appear in pragma [Refined_]Depends as its place 1048 -- must be taken by some of its constituents 1049 -- (SPARK RM 6.1.4(7)). 1050 1051 elsif Has_Visible_Refinement (Item_Id) then 1052 SPARK_Msg_NE 1053 ("cannot mention state & in dependence relation", 1054 Item, Item_Id); 1055 SPARK_Msg_N ("\use its constituents instead", Item); 1056 return; 1057 1058 -- If the reference to the abstract state appears in 1059 -- an enclosing package body that will eventually 1060 -- refine the state, record the reference for future 1061 -- checks. 1062 1063 else 1064 Record_Possible_Body_Reference 1065 (State_Id => Item_Id, 1066 Ref => Item); 1067 end if; 1068 end if; 1069 1070 -- When the item renames an entire object, replace the 1071 -- item with a reference to the object. 1072 1073 if Entity (Item) /= Item_Id then 1074 Rewrite (Item, 1075 New_Occurrence_Of (Item_Id, Sloc (Item))); 1076 Analyze (Item); 1077 end if; 1078 1079 -- Add the entity of the current item to the list of 1080 -- processed items. 1081 1082 if Ekind (Item_Id) = E_Abstract_State then 1083 Append_New_Elmt (Item_Id, States_Seen); 1084 1085 -- The variable may eventually become a constituent of a 1086 -- single protected/task type. Record the reference now 1087 -- and verify its legality when analyzing the contract of 1088 -- the variable (SPARK RM 9.3). 1089 1090 elsif Ekind (Item_Id) = E_Variable then 1091 Record_Possible_Part_Of_Reference 1092 (Var_Id => Item_Id, 1093 Ref => Item); 1094 end if; 1095 1096 if Ekind_In (Item_Id, E_Abstract_State, 1097 E_Constant, 1098 E_Variable) 1099 and then Present (Encapsulating_State (Item_Id)) 1100 then 1101 Append_New_Elmt (Item_Id, Constits_Seen); 1102 end if; 1103 1104 -- All other input/output items are illegal 1105 -- (SPARK RM 6.1.5(1)). 1106 1107 else 1108 SPARK_Msg_N 1109 ("item must denote parameter, variable, state or " 1110 & "current instance of concurrent type", Item); 1111 end if; 1112 1113 -- All other input/output items are illegal 1114 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report. 1115 1116 else 1117 Error_Msg_N 1118 ("item must denote parameter, variable, state or current " 1119 & "instance of concurrent type", Item); 1120 end if; 1121 end if; 1122 end Analyze_Input_Output; 1123 1124 -- Local variables 1125 1126 Inputs : Node_Id; 1127 Output : Node_Id; 1128 Self_Ref : Boolean; 1129 1130 Non_Null_Output_Seen : Boolean := False; 1131 -- Flag used to check the legality of an output list 1132 1133 -- Start of processing for Analyze_Dependency_Clause 1134 1135 begin 1136 Inputs := Expression (Clause); 1137 Self_Ref := False; 1138 1139 -- An input list with a self-dependency appears as operator "+" where 1140 -- the actuals inputs are the right operand. 1141 1142 if Nkind (Inputs) = N_Op_Plus then 1143 Inputs := Right_Opnd (Inputs); 1144 Self_Ref := True; 1145 end if; 1146 1147 -- Process the output_list of a dependency_clause 1148 1149 Output := First (Choices (Clause)); 1150 while Present (Output) loop 1151 Analyze_Input_Output 1152 (Item => Output, 1153 Is_Input => False, 1154 Self_Ref => Self_Ref, 1155 Top_Level => True, 1156 Seen => All_Outputs_Seen, 1157 Null_Seen => Null_Output_Seen, 1158 Non_Null_Seen => Non_Null_Output_Seen); 1159 1160 Next (Output); 1161 end loop; 1162 1163 -- Process the input_list of a dependency_clause 1164 1165 Analyze_Input_List (Inputs); 1166 end Analyze_Dependency_Clause; 1167 1168 --------------------------- 1169 -- Check_Function_Return -- 1170 --------------------------- 1171 1172 procedure Check_Function_Return is 1173 begin 1174 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 1175 and then not Result_Seen 1176 then 1177 SPARK_Msg_NE 1178 ("result of & must appear in exactly one output list", 1179 N, Spec_Id); 1180 end if; 1181 end Check_Function_Return; 1182 1183 ---------------- 1184 -- Check_Role -- 1185 ---------------- 1186 1187 procedure Check_Role 1188 (Item : Node_Id; 1189 Item_Id : Entity_Id; 1190 Is_Input : Boolean; 1191 Self_Ref : Boolean) 1192 is 1193 procedure Find_Role 1194 (Item_Is_Input : out Boolean; 1195 Item_Is_Output : out Boolean); 1196 -- Find the input/output role of Item_Id. Flags Item_Is_Input and 1197 -- Item_Is_Output are set depending on the role. 1198 1199 procedure Role_Error 1200 (Item_Is_Input : Boolean; 1201 Item_Is_Output : Boolean); 1202 -- Emit an error message concerning the incorrect use of Item in 1203 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output 1204 -- denote whether the item is an input and/or an output. 1205 1206 --------------- 1207 -- Find_Role -- 1208 --------------- 1209 1210 procedure Find_Role 1211 (Item_Is_Input : out Boolean; 1212 Item_Is_Output : out Boolean) 1213 is 1214 begin 1215 case Ekind (Item_Id) is 1216 1217 -- Abstract states 1218 1219 when E_Abstract_State => 1220 1221 -- When pragma Global is present it determines the mode of 1222 -- the abstract state. 1223 1224 if Global_Seen then 1225 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id); 1226 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1227 1228 -- Otherwise the state has a default IN OUT mode, because it 1229 -- behaves as a variable. 1230 1231 else 1232 Item_Is_Input := True; 1233 Item_Is_Output := True; 1234 end if; 1235 1236 -- Constants and IN parameters 1237 1238 when E_Constant 1239 | E_Generic_In_Parameter 1240 | E_In_Parameter 1241 | E_Loop_Parameter 1242 => 1243 -- When pragma Global is present it determines the mode 1244 -- of constant objects as inputs (and such objects cannot 1245 -- appear as outputs in the Global contract). 1246 1247 if Global_Seen then 1248 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id); 1249 else 1250 Item_Is_Input := True; 1251 end if; 1252 1253 Item_Is_Output := False; 1254 1255 -- Variables and IN OUT parameters 1256 1257 when E_Generic_In_Out_Parameter 1258 | E_In_Out_Parameter 1259 | E_Variable 1260 => 1261 -- When pragma Global is present it determines the mode of 1262 -- the object. 1263 1264 if Global_Seen then 1265 1266 -- A variable has mode IN when its type is unconstrained 1267 -- or tagged because array bounds, discriminants or tags 1268 -- can be read. 1269 1270 Item_Is_Input := 1271 Appears_In (Subp_Inputs, Item_Id) 1272 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1273 1274 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1275 1276 -- Otherwise the variable has a default IN OUT mode 1277 1278 else 1279 Item_Is_Input := True; 1280 Item_Is_Output := True; 1281 end if; 1282 1283 when E_Out_Parameter => 1284 1285 -- An OUT parameter of the related subprogram; it cannot 1286 -- appear in Global. 1287 1288 if Scope (Item_Id) = Spec_Id then 1289 1290 -- The parameter has mode IN if its type is unconstrained 1291 -- or tagged because array bounds, discriminants or tags 1292 -- can be read. 1293 1294 Item_Is_Input := 1295 Is_Unconstrained_Or_Tagged_Item (Item_Id); 1296 1297 Item_Is_Output := True; 1298 1299 -- An OUT parameter of an enclosing subprogram; it can 1300 -- appear in Global and behaves as a read-write variable. 1301 1302 else 1303 -- When pragma Global is present it determines the mode 1304 -- of the object. 1305 1306 if Global_Seen then 1307 1308 -- A variable has mode IN when its type is 1309 -- unconstrained or tagged because array 1310 -- bounds, discriminants or tags can be read. 1311 1312 Item_Is_Input := 1313 Appears_In (Subp_Inputs, Item_Id) 1314 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1315 1316 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1317 1318 -- Otherwise the variable has a default IN OUT mode 1319 1320 else 1321 Item_Is_Input := True; 1322 Item_Is_Output := True; 1323 end if; 1324 end if; 1325 1326 -- Protected types 1327 1328 when E_Protected_Type => 1329 if Global_Seen then 1330 1331 -- A variable has mode IN when its type is unconstrained 1332 -- or tagged because array bounds, discriminants or tags 1333 -- can be read. 1334 1335 Item_Is_Input := 1336 Appears_In (Subp_Inputs, Item_Id) 1337 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1338 1339 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1340 1341 else 1342 -- A protected type acts as a formal parameter of mode IN 1343 -- when it applies to a protected function. 1344 1345 if Ekind (Spec_Id) = E_Function then 1346 Item_Is_Input := True; 1347 Item_Is_Output := False; 1348 1349 -- Otherwise the protected type acts as a formal of mode 1350 -- IN OUT. 1351 1352 else 1353 Item_Is_Input := True; 1354 Item_Is_Output := True; 1355 end if; 1356 end if; 1357 1358 -- Task types 1359 1360 when E_Task_Type => 1361 1362 -- When pragma Global is present it determines the mode of 1363 -- the object. 1364 1365 if Global_Seen then 1366 Item_Is_Input := 1367 Appears_In (Subp_Inputs, Item_Id) 1368 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1369 1370 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1371 1372 -- Otherwise task types act as IN OUT parameters 1373 1374 else 1375 Item_Is_Input := True; 1376 Item_Is_Output := True; 1377 end if; 1378 1379 when others => 1380 raise Program_Error; 1381 end case; 1382 end Find_Role; 1383 1384 ---------------- 1385 -- Role_Error -- 1386 ---------------- 1387 1388 procedure Role_Error 1389 (Item_Is_Input : Boolean; 1390 Item_Is_Output : Boolean) 1391 is 1392 Error_Msg : Name_Id; 1393 1394 begin 1395 Name_Len := 0; 1396 1397 -- When the item is not part of the input and the output set of 1398 -- the related subprogram, then it appears as extra in pragma 1399 -- [Refined_]Depends. 1400 1401 if not Item_Is_Input and then not Item_Is_Output then 1402 Add_Item_To_Name_Buffer (Item_Id); 1403 Add_Str_To_Name_Buffer 1404 (" & cannot appear in dependence relation"); 1405 1406 Error_Msg := Name_Find; 1407 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1408 1409 Error_Msg_Name_1 := Chars (Spec_Id); 1410 SPARK_Msg_NE 1411 (Fix_Msg (Spec_Id, "\& is not part of the input or output " 1412 & "set of subprogram %"), Item, Item_Id); 1413 1414 -- The mode of the item and its role in pragma [Refined_]Depends 1415 -- are in conflict. Construct a detailed message explaining the 1416 -- illegality (SPARK RM 6.1.5(5-6)). 1417 1418 else 1419 if Item_Is_Input then 1420 Add_Str_To_Name_Buffer ("read-only"); 1421 else 1422 Add_Str_To_Name_Buffer ("write-only"); 1423 end if; 1424 1425 Add_Char_To_Name_Buffer (' '); 1426 Add_Item_To_Name_Buffer (Item_Id); 1427 Add_Str_To_Name_Buffer (" & cannot appear as "); 1428 1429 if Item_Is_Input then 1430 Add_Str_To_Name_Buffer ("output"); 1431 else 1432 Add_Str_To_Name_Buffer ("input"); 1433 end if; 1434 1435 Add_Str_To_Name_Buffer (" in dependence relation"); 1436 Error_Msg := Name_Find; 1437 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1438 end if; 1439 end Role_Error; 1440 1441 -- Local variables 1442 1443 Item_Is_Input : Boolean; 1444 Item_Is_Output : Boolean; 1445 1446 -- Start of processing for Check_Role 1447 1448 begin 1449 Find_Role (Item_Is_Input, Item_Is_Output); 1450 1451 -- Input item 1452 1453 if Is_Input then 1454 if not Item_Is_Input then 1455 Role_Error (Item_Is_Input, Item_Is_Output); 1456 end if; 1457 1458 -- Self-referential item 1459 1460 elsif Self_Ref then 1461 if not Item_Is_Input or else not Item_Is_Output then 1462 Role_Error (Item_Is_Input, Item_Is_Output); 1463 end if; 1464 1465 -- Output item 1466 1467 elsif not Item_Is_Output then 1468 Role_Error (Item_Is_Input, Item_Is_Output); 1469 end if; 1470 end Check_Role; 1471 1472 ----------------- 1473 -- Check_Usage -- 1474 ----------------- 1475 1476 procedure Check_Usage 1477 (Subp_Items : Elist_Id; 1478 Used_Items : Elist_Id; 1479 Is_Input : Boolean) 1480 is 1481 procedure Usage_Error (Item_Id : Entity_Id); 1482 -- Emit an error concerning the illegal usage of an item 1483 1484 ----------------- 1485 -- Usage_Error -- 1486 ----------------- 1487 1488 procedure Usage_Error (Item_Id : Entity_Id) is 1489 Error_Msg : Name_Id; 1490 1491 begin 1492 -- Input case 1493 1494 if Is_Input then 1495 1496 -- Unconstrained and tagged items are not part of the explicit 1497 -- input set of the related subprogram, they do not have to be 1498 -- present in a dependence relation and should not be flagged 1499 -- (SPARK RM 6.1.5(5)). 1500 1501 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then 1502 Name_Len := 0; 1503 1504 Add_Item_To_Name_Buffer (Item_Id); 1505 Add_Str_To_Name_Buffer 1506 (" & is missing from input dependence list"); 1507 1508 Error_Msg := Name_Find; 1509 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); 1510 SPARK_Msg_NE 1511 ("\add `null ='> &` dependency to ignore this input", 1512 N, Item_Id); 1513 end if; 1514 1515 -- Output case (SPARK RM 6.1.5(10)) 1516 1517 else 1518 Name_Len := 0; 1519 1520 Add_Item_To_Name_Buffer (Item_Id); 1521 Add_Str_To_Name_Buffer 1522 (" & is missing from output dependence list"); 1523 1524 Error_Msg := Name_Find; 1525 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); 1526 end if; 1527 end Usage_Error; 1528 1529 -- Local variables 1530 1531 Elmt : Elmt_Id; 1532 Item : Node_Id; 1533 Item_Id : Entity_Id; 1534 1535 -- Start of processing for Check_Usage 1536 1537 begin 1538 if No (Subp_Items) then 1539 return; 1540 end if; 1541 1542 -- Each input or output of the subprogram must appear in a dependency 1543 -- relation. 1544 1545 Elmt := First_Elmt (Subp_Items); 1546 while Present (Elmt) loop 1547 Item := Node (Elmt); 1548 1549 if Nkind (Item) = N_Defining_Identifier then 1550 Item_Id := Item; 1551 else 1552 Item_Id := Entity_Of (Item); 1553 end if; 1554 1555 -- The item does not appear in a dependency 1556 1557 if Present (Item_Id) 1558 and then not Contains (Used_Items, Item_Id) 1559 then 1560 if Is_Formal (Item_Id) then 1561 Usage_Error (Item_Id); 1562 1563 -- The current instance of a protected type behaves as a formal 1564 -- parameter (SPARK RM 6.1.4). 1565 1566 elsif Ekind (Item_Id) = E_Protected_Type 1567 or else Is_Single_Protected_Object (Item_Id) 1568 then 1569 Usage_Error (Item_Id); 1570 1571 -- The current instance of a task type behaves as a formal 1572 -- parameter (SPARK RM 6.1.4). 1573 1574 elsif Ekind (Item_Id) = E_Task_Type 1575 or else Is_Single_Task_Object (Item_Id) 1576 then 1577 -- The dependence of a task unit on itself is implicit and 1578 -- may or may not be explicitly specified (SPARK RM 6.1.4). 1579 -- Emit an error if only one input/output is present. 1580 1581 if Task_Input_Seen /= Task_Output_Seen then 1582 Usage_Error (Item_Id); 1583 end if; 1584 1585 -- States and global objects are not used properly only when 1586 -- the subprogram is subject to pragma Global. 1587 1588 elsif Global_Seen then 1589 Usage_Error (Item_Id); 1590 end if; 1591 end if; 1592 1593 Next_Elmt (Elmt); 1594 end loop; 1595 end Check_Usage; 1596 1597 ---------------------- 1598 -- Normalize_Clause -- 1599 ---------------------- 1600 1601 procedure Normalize_Clause (Clause : Node_Id) is 1602 procedure Create_Or_Modify_Clause 1603 (Output : Node_Id; 1604 Outputs : Node_Id; 1605 Inputs : Node_Id; 1606 After : Node_Id; 1607 In_Place : Boolean; 1608 Multiple : Boolean); 1609 -- Create a brand new clause to represent the self-reference or 1610 -- modify the input and/or output lists of an existing clause. Output 1611 -- denotes a self-referencial output. Outputs is the output list of a 1612 -- clause. Inputs is the input list of a clause. After denotes the 1613 -- clause after which the new clause is to be inserted. Flag In_Place 1614 -- should be set when normalizing the last output of an output list. 1615 -- Flag Multiple should be set when Output comes from a list with 1616 -- multiple items. 1617 1618 ----------------------------- 1619 -- Create_Or_Modify_Clause -- 1620 ----------------------------- 1621 1622 procedure Create_Or_Modify_Clause 1623 (Output : Node_Id; 1624 Outputs : Node_Id; 1625 Inputs : Node_Id; 1626 After : Node_Id; 1627 In_Place : Boolean; 1628 Multiple : Boolean) 1629 is 1630 procedure Propagate_Output 1631 (Output : Node_Id; 1632 Inputs : Node_Id); 1633 -- Handle the various cases of output propagation to the input 1634 -- list. Output denotes a self-referencial output item. Inputs 1635 -- is the input list of a clause. 1636 1637 ---------------------- 1638 -- Propagate_Output -- 1639 ---------------------- 1640 1641 procedure Propagate_Output 1642 (Output : Node_Id; 1643 Inputs : Node_Id) 1644 is 1645 function In_Input_List 1646 (Item : Entity_Id; 1647 Inputs : List_Id) return Boolean; 1648 -- Determine whether a particulat item appears in the input 1649 -- list of a clause. 1650 1651 ------------------- 1652 -- In_Input_List -- 1653 ------------------- 1654 1655 function In_Input_List 1656 (Item : Entity_Id; 1657 Inputs : List_Id) return Boolean 1658 is 1659 Elmt : Node_Id; 1660 1661 begin 1662 Elmt := First (Inputs); 1663 while Present (Elmt) loop 1664 if Entity_Of (Elmt) = Item then 1665 return True; 1666 end if; 1667 1668 Next (Elmt); 1669 end loop; 1670 1671 return False; 1672 end In_Input_List; 1673 1674 -- Local variables 1675 1676 Output_Id : constant Entity_Id := Entity_Of (Output); 1677 Grouped : List_Id; 1678 1679 -- Start of processing for Propagate_Output 1680 1681 begin 1682 -- The clause is of the form: 1683 1684 -- (Output =>+ null) 1685 1686 -- Remove null input and replace it with a copy of the output: 1687 1688 -- (Output => Output) 1689 1690 if Nkind (Inputs) = N_Null then 1691 Rewrite (Inputs, New_Copy_Tree (Output)); 1692 1693 -- The clause is of the form: 1694 1695 -- (Output =>+ (Input1, ..., InputN)) 1696 1697 -- Determine whether the output is not already mentioned in the 1698 -- input list and if not, add it to the list of inputs: 1699 1700 -- (Output => (Output, Input1, ..., InputN)) 1701 1702 elsif Nkind (Inputs) = N_Aggregate then 1703 Grouped := Expressions (Inputs); 1704 1705 if not In_Input_List 1706 (Item => Output_Id, 1707 Inputs => Grouped) 1708 then 1709 Prepend_To (Grouped, New_Copy_Tree (Output)); 1710 end if; 1711 1712 -- The clause is of the form: 1713 1714 -- (Output =>+ Input) 1715 1716 -- If the input does not mention the output, group the two 1717 -- together: 1718 1719 -- (Output => (Output, Input)) 1720 1721 elsif Entity_Of (Inputs) /= Output_Id then 1722 Rewrite (Inputs, 1723 Make_Aggregate (Loc, 1724 Expressions => New_List ( 1725 New_Copy_Tree (Output), 1726 New_Copy_Tree (Inputs)))); 1727 end if; 1728 end Propagate_Output; 1729 1730 -- Local variables 1731 1732 Loc : constant Source_Ptr := Sloc (Clause); 1733 New_Clause : Node_Id; 1734 1735 -- Start of processing for Create_Or_Modify_Clause 1736 1737 begin 1738 -- A null output depending on itself does not require any 1739 -- normalization. 1740 1741 if Nkind (Output) = N_Null then 1742 return; 1743 1744 -- A function result cannot depend on itself because it cannot 1745 -- appear in the input list of a relation (SPARK RM 6.1.5(10)). 1746 1747 elsif Is_Attribute_Result (Output) then 1748 SPARK_Msg_N ("function result cannot depend on itself", Output); 1749 return; 1750 end if; 1751 1752 -- When performing the transformation in place, simply add the 1753 -- output to the list of inputs (if not already there). This 1754 -- case arises when dealing with the last output of an output 1755 -- list. Perform the normalization in place to avoid generating 1756 -- a malformed tree. 1757 1758 if In_Place then 1759 Propagate_Output (Output, Inputs); 1760 1761 -- A list with multiple outputs is slowly trimmed until only 1762 -- one element remains. When this happens, replace aggregate 1763 -- with the element itself. 1764 1765 if Multiple then 1766 Remove (Output); 1767 Rewrite (Outputs, Output); 1768 end if; 1769 1770 -- Default case 1771 1772 else 1773 -- Unchain the output from its output list as it will appear in 1774 -- a new clause. Note that we cannot simply rewrite the output 1775 -- as null because this will violate the semantics of pragma 1776 -- Depends. 1777 1778 Remove (Output); 1779 1780 -- Generate a new clause of the form: 1781 -- (Output => Inputs) 1782 1783 New_Clause := 1784 Make_Component_Association (Loc, 1785 Choices => New_List (Output), 1786 Expression => New_Copy_Tree (Inputs)); 1787 1788 -- The new clause contains replicated content that has already 1789 -- been analyzed. There is not need to reanalyze or renormalize 1790 -- it again. 1791 1792 Set_Analyzed (New_Clause); 1793 1794 Propagate_Output 1795 (Output => First (Choices (New_Clause)), 1796 Inputs => Expression (New_Clause)); 1797 1798 Insert_After (After, New_Clause); 1799 end if; 1800 end Create_Or_Modify_Clause; 1801 1802 -- Local variables 1803 1804 Outputs : constant Node_Id := First (Choices (Clause)); 1805 Inputs : Node_Id; 1806 Last_Output : Node_Id; 1807 Next_Output : Node_Id; 1808 Output : Node_Id; 1809 1810 -- Start of processing for Normalize_Clause 1811 1812 begin 1813 -- A self-dependency appears as operator "+". Remove the "+" from the 1814 -- tree by moving the real inputs to their proper place. 1815 1816 if Nkind (Expression (Clause)) = N_Op_Plus then 1817 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause))); 1818 Inputs := Expression (Clause); 1819 1820 -- Multiple outputs appear as an aggregate 1821 1822 if Nkind (Outputs) = N_Aggregate then 1823 Last_Output := Last (Expressions (Outputs)); 1824 1825 Output := First (Expressions (Outputs)); 1826 while Present (Output) loop 1827 1828 -- Normalization may remove an output from its list, 1829 -- preserve the subsequent output now. 1830 1831 Next_Output := Next (Output); 1832 1833 Create_Or_Modify_Clause 1834 (Output => Output, 1835 Outputs => Outputs, 1836 Inputs => Inputs, 1837 After => Clause, 1838 In_Place => Output = Last_Output, 1839 Multiple => True); 1840 1841 Output := Next_Output; 1842 end loop; 1843 1844 -- Solitary output 1845 1846 else 1847 Create_Or_Modify_Clause 1848 (Output => Outputs, 1849 Outputs => Empty, 1850 Inputs => Inputs, 1851 After => Empty, 1852 In_Place => True, 1853 Multiple => False); 1854 end if; 1855 end if; 1856 end Normalize_Clause; 1857 1858 -- Local variables 1859 1860 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 1861 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 1862 1863 Clause : Node_Id; 1864 Errors : Nat; 1865 Last_Clause : Node_Id; 1866 Restore_Scope : Boolean := False; 1867 1868 -- Start of processing for Analyze_Depends_In_Decl_Part 1869 1870 begin 1871 -- Do not analyze the pragma multiple times 1872 1873 if Is_Analyzed_Pragma (N) then 1874 return; 1875 end if; 1876 1877 -- Empty dependency list 1878 1879 if Nkind (Deps) = N_Null then 1880 1881 -- Gather all states, objects and formal parameters that the 1882 -- subprogram may depend on. These items are obtained from the 1883 -- parameter profile or pragma [Refined_]Global (if available). 1884 1885 Collect_Subprogram_Inputs_Outputs 1886 (Subp_Id => Subp_Id, 1887 Subp_Inputs => Subp_Inputs, 1888 Subp_Outputs => Subp_Outputs, 1889 Global_Seen => Global_Seen); 1890 1891 -- Verify that every input or output of the subprogram appear in a 1892 -- dependency. 1893 1894 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 1895 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 1896 Check_Function_Return; 1897 1898 -- Dependency clauses appear as component associations of an aggregate 1899 1900 elsif Nkind (Deps) = N_Aggregate then 1901 1902 -- Do not attempt to perform analysis of a syntactically illegal 1903 -- clause as this will lead to misleading errors. 1904 1905 if Has_Extra_Parentheses (Deps) then 1906 return; 1907 end if; 1908 1909 if Present (Component_Associations (Deps)) then 1910 Last_Clause := Last (Component_Associations (Deps)); 1911 1912 -- Gather all states, objects and formal parameters that the 1913 -- subprogram may depend on. These items are obtained from the 1914 -- parameter profile or pragma [Refined_]Global (if available). 1915 1916 Collect_Subprogram_Inputs_Outputs 1917 (Subp_Id => Subp_Id, 1918 Subp_Inputs => Subp_Inputs, 1919 Subp_Outputs => Subp_Outputs, 1920 Global_Seen => Global_Seen); 1921 1922 -- When pragma [Refined_]Depends appears on a single concurrent 1923 -- type, it is relocated to the anonymous object. 1924 1925 if Is_Single_Concurrent_Object (Spec_Id) then 1926 null; 1927 1928 -- Ensure that the formal parameters are visible when analyzing 1929 -- all clauses. This falls out of the general rule of aspects 1930 -- pertaining to subprogram declarations. 1931 1932 elsif not In_Open_Scopes (Spec_Id) then 1933 Restore_Scope := True; 1934 Push_Scope (Spec_Id); 1935 1936 if Ekind (Spec_Id) = E_Task_Type then 1937 if Has_Discriminants (Spec_Id) then 1938 Install_Discriminants (Spec_Id); 1939 end if; 1940 1941 elsif Is_Generic_Subprogram (Spec_Id) then 1942 Install_Generic_Formals (Spec_Id); 1943 1944 else 1945 Install_Formals (Spec_Id); 1946 end if; 1947 end if; 1948 1949 Clause := First (Component_Associations (Deps)); 1950 while Present (Clause) loop 1951 Errors := Serious_Errors_Detected; 1952 1953 -- The normalization mechanism may create extra clauses that 1954 -- contain replicated input and output names. There is no need 1955 -- to reanalyze them. 1956 1957 if not Analyzed (Clause) then 1958 Set_Analyzed (Clause); 1959 1960 Analyze_Dependency_Clause 1961 (Clause => Clause, 1962 Is_Last => Clause = Last_Clause); 1963 end if; 1964 1965 -- Do not normalize a clause if errors were detected (count 1966 -- of Serious_Errors has increased) because the inputs and/or 1967 -- outputs may denote illegal items. Normalization is disabled 1968 -- in ASIS mode as it alters the tree by introducing new nodes 1969 -- similar to expansion. 1970 1971 if Serious_Errors_Detected = Errors and then not ASIS_Mode then 1972 Normalize_Clause (Clause); 1973 end if; 1974 1975 Next (Clause); 1976 end loop; 1977 1978 if Restore_Scope then 1979 End_Scope; 1980 end if; 1981 1982 -- Verify that every input or output of the subprogram appear in a 1983 -- dependency. 1984 1985 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 1986 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 1987 Check_Function_Return; 1988 1989 -- The dependency list is malformed. This is a syntax error, always 1990 -- report. 1991 1992 else 1993 Error_Msg_N ("malformed dependency relation", Deps); 1994 return; 1995 end if; 1996 1997 -- The top level dependency relation is malformed. This is a syntax 1998 -- error, always report. 1999 2000 else 2001 Error_Msg_N ("malformed dependency relation", Deps); 2002 goto Leave; 2003 end if; 2004 2005 -- Ensure that a state and a corresponding constituent do not appear 2006 -- together in pragma [Refined_]Depends. 2007 2008 Check_State_And_Constituent_Use 2009 (States => States_Seen, 2010 Constits => Constits_Seen, 2011 Context => N); 2012 2013 <<Leave>> 2014 Set_Is_Analyzed_Pragma (N); 2015 end Analyze_Depends_In_Decl_Part; 2016 2017 -------------------------------------------- 2018 -- Analyze_External_Property_In_Decl_Part -- 2019 -------------------------------------------- 2020 2021 procedure Analyze_External_Property_In_Decl_Part 2022 (N : Node_Id; 2023 Expr_Val : out Boolean) 2024 is 2025 Arg1 : constant Node_Id := 2026 First (Pragma_Argument_Associations (N)); 2027 Obj_Decl : constant Node_Id := Find_Related_Context (N); 2028 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 2029 Expr : Node_Id; 2030 2031 begin 2032 Expr_Val := False; 2033 2034 -- Do not analyze the pragma multiple times 2035 2036 if Is_Analyzed_Pragma (N) then 2037 return; 2038 end if; 2039 2040 Error_Msg_Name_1 := Pragma_Name (N); 2041 2042 -- An external property pragma must apply to an effectively volatile 2043 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)). 2044 -- The check is performed at the end of the declarative region due to a 2045 -- possible out-of-order arrangement of pragmas: 2046 2047 -- Obj : ...; 2048 -- pragma Async_Readers (Obj); 2049 -- pragma Volatile (Obj); 2050 2051 if not Is_Effectively_Volatile (Obj_Id) then 2052 SPARK_Msg_N 2053 ("external property % must apply to a volatile object", N); 2054 end if; 2055 2056 -- Ensure that the Boolean expression (if present) is static. A missing 2057 -- argument defaults the value to True (SPARK RM 7.1.2(5)). 2058 2059 Expr_Val := True; 2060 2061 if Present (Arg1) then 2062 Expr := Get_Pragma_Arg (Arg1); 2063 2064 if Is_OK_Static_Expression (Expr) then 2065 Expr_Val := Is_True (Expr_Value (Expr)); 2066 end if; 2067 end if; 2068 2069 Set_Is_Analyzed_Pragma (N); 2070 end Analyze_External_Property_In_Decl_Part; 2071 2072 --------------------------------- 2073 -- Analyze_Global_In_Decl_Part -- 2074 --------------------------------- 2075 2076 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is 2077 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 2078 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 2079 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 2080 2081 Constits_Seen : Elist_Id := No_Elist; 2082 -- A list containing the entities of all constituents processed so far. 2083 -- It aids in detecting illegal usage of a state and a corresponding 2084 -- constituent in pragma [Refinde_]Global. 2085 2086 Seen : Elist_Id := No_Elist; 2087 -- A list containing the entities of all the items processed so far. It 2088 -- plays a role in detecting distinct entities. 2089 2090 States_Seen : Elist_Id := No_Elist; 2091 -- A list containing the entities of all states processed so far. It 2092 -- helps in detecting illegal usage of a state and a corresponding 2093 -- constituent in pragma [Refined_]Global. 2094 2095 In_Out_Seen : Boolean := False; 2096 Input_Seen : Boolean := False; 2097 Output_Seen : Boolean := False; 2098 Proof_Seen : Boolean := False; 2099 -- Flags used to verify the consistency of modes 2100 2101 procedure Analyze_Global_List 2102 (List : Node_Id; 2103 Global_Mode : Name_Id := Name_Input); 2104 -- Verify the legality of a single global list declaration. Global_Mode 2105 -- denotes the current mode in effect. 2106 2107 ------------------------- 2108 -- Analyze_Global_List -- 2109 ------------------------- 2110 2111 procedure Analyze_Global_List 2112 (List : Node_Id; 2113 Global_Mode : Name_Id := Name_Input) 2114 is 2115 procedure Analyze_Global_Item 2116 (Item : Node_Id; 2117 Global_Mode : Name_Id); 2118 -- Verify the legality of a single global item declaration denoted by 2119 -- Item. Global_Mode denotes the current mode in effect. 2120 2121 procedure Check_Duplicate_Mode 2122 (Mode : Node_Id; 2123 Status : in out Boolean); 2124 -- Flag Status denotes whether a particular mode has been seen while 2125 -- processing a global list. This routine verifies that Mode is not a 2126 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)). 2127 2128 procedure Check_Mode_Restriction_In_Enclosing_Context 2129 (Item : Node_Id; 2130 Item_Id : Entity_Id); 2131 -- Verify that an item of mode In_Out or Output does not appear as 2132 -- an input in the Global aspect of an enclosing subprogram or task 2133 -- unit. If this is the case, emit an error. Item and Item_Id are 2134 -- respectively the item and its entity. 2135 2136 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); 2137 -- Mode denotes either In_Out or Output. Depending on the kind of the 2138 -- related subprogram, emit an error if those two modes apply to a 2139 -- function (SPARK RM 6.1.4(10)). 2140 2141 ------------------------- 2142 -- Analyze_Global_Item -- 2143 ------------------------- 2144 2145 procedure Analyze_Global_Item 2146 (Item : Node_Id; 2147 Global_Mode : Name_Id) 2148 is 2149 Item_Id : Entity_Id; 2150 2151 begin 2152 -- Detect one of the following cases 2153 2154 -- with Global => (null, Name) 2155 -- with Global => (Name_1, null, Name_2) 2156 -- with Global => (Name, null) 2157 2158 if Nkind (Item) = N_Null then 2159 SPARK_Msg_N ("cannot mix null and non-null global items", Item); 2160 return; 2161 end if; 2162 2163 Analyze (Item); 2164 Resolve_State (Item); 2165 2166 -- Find the entity of the item. If this is a renaming, climb the 2167 -- renaming chain to reach the root object. Renamings of non- 2168 -- entire objects do not yield an entity (Empty). 2169 2170 Item_Id := Entity_Of (Item); 2171 2172 if Present (Item_Id) then 2173 2174 -- A global item may denote a formal parameter of an enclosing 2175 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to 2176 -- provide a better error diagnostic. 2177 2178 if Is_Formal (Item_Id) then 2179 if Scope (Item_Id) = Spec_Id then 2180 SPARK_Msg_NE 2181 (Fix_Msg (Spec_Id, "global item cannot reference " 2182 & "parameter of subprogram &"), Item, Spec_Id); 2183 return; 2184 end if; 2185 2186 -- A global item may denote a concurrent type as long as it is 2187 -- the current instance of an enclosing protected or task type 2188 -- (SPARK RM 6.1.4). 2189 2190 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then 2191 if Is_CCT_Instance (Item_Id, Spec_Id) then 2192 2193 -- Pragma [Refined_]Global associated with a protected 2194 -- subprogram cannot mention the current instance of a 2195 -- protected type because the instance behaves as a 2196 -- formal parameter. 2197 2198 if Ekind (Item_Id) = E_Protected_Type then 2199 if Scope (Spec_Id) = Item_Id then 2200 Error_Msg_Name_1 := Chars (Item_Id); 2201 SPARK_Msg_NE 2202 (Fix_Msg (Spec_Id, "global item of subprogram & " 2203 & "cannot reference current instance of " 2204 & "protected type %"), Item, Spec_Id); 2205 return; 2206 end if; 2207 2208 -- Pragma [Refined_]Global associated with a task type 2209 -- cannot mention the current instance of a task type 2210 -- because the instance behaves as a formal parameter. 2211 2212 else pragma Assert (Ekind (Item_Id) = E_Task_Type); 2213 if Spec_Id = Item_Id then 2214 Error_Msg_Name_1 := Chars (Item_Id); 2215 SPARK_Msg_NE 2216 (Fix_Msg (Spec_Id, "global item of subprogram & " 2217 & "cannot reference current instance of task " 2218 & "type %"), Item, Spec_Id); 2219 return; 2220 end if; 2221 end if; 2222 2223 -- Otherwise the global item denotes a subtype mark that is 2224 -- not a current instance. 2225 2226 else 2227 SPARK_Msg_N 2228 ("invalid use of subtype mark in global list", Item); 2229 return; 2230 end if; 2231 2232 -- A global item may denote the anonymous object created for a 2233 -- single protected/task type as long as the current instance 2234 -- is the same single type (SPARK RM 6.1.4). 2235 2236 elsif Is_Single_Concurrent_Object (Item_Id) 2237 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id) 2238 then 2239 -- Pragma [Refined_]Global associated with a protected 2240 -- subprogram cannot mention the current instance of a 2241 -- protected type because the instance behaves as a formal 2242 -- parameter. 2243 2244 if Is_Single_Protected_Object (Item_Id) then 2245 if Scope (Spec_Id) = Etype (Item_Id) then 2246 Error_Msg_Name_1 := Chars (Item_Id); 2247 SPARK_Msg_NE 2248 (Fix_Msg (Spec_Id, "global item of subprogram & " 2249 & "cannot reference current instance of protected " 2250 & "type %"), Item, Spec_Id); 2251 return; 2252 end if; 2253 2254 -- Pragma [Refined_]Global associated with a task type 2255 -- cannot mention the current instance of a task type 2256 -- because the instance behaves as a formal parameter. 2257 2258 else pragma Assert (Is_Single_Task_Object (Item_Id)); 2259 if Spec_Id = Item_Id then 2260 Error_Msg_Name_1 := Chars (Item_Id); 2261 SPARK_Msg_NE 2262 (Fix_Msg (Spec_Id, "global item of subprogram & " 2263 & "cannot reference current instance of task " 2264 & "type %"), Item, Spec_Id); 2265 return; 2266 end if; 2267 end if; 2268 2269 -- A formal object may act as a global item inside a generic 2270 2271 elsif Is_Formal_Object (Item_Id) then 2272 null; 2273 2274 -- The only legal references are those to abstract states, 2275 -- objects and various kinds of constants (SPARK RM 6.1.4(4)). 2276 2277 elsif not Ekind_In (Item_Id, E_Abstract_State, 2278 E_Constant, 2279 E_Loop_Parameter, 2280 E_Variable) 2281 then 2282 SPARK_Msg_N 2283 ("global item must denote object, state or current " 2284 & "instance of concurrent type", Item); 2285 2286 if Ekind (Item_Id) in Named_Kind then 2287 SPARK_Msg_NE 2288 ("\named number & is not an object", Item, Item); 2289 end if; 2290 2291 return; 2292 end if; 2293 2294 -- State related checks 2295 2296 if Ekind (Item_Id) = E_Abstract_State then 2297 2298 -- Package and subprogram bodies are instantiated 2299 -- individually in a separate compiler pass. Due to this 2300 -- mode of instantiation, the refinement of a state may 2301 -- no longer be visible when a subprogram body contract 2302 -- is instantiated. Since the generic template is legal, 2303 -- do not perform this check in the instance to circumvent 2304 -- this oddity. 2305 2306 if Is_Generic_Instance (Spec_Id) then 2307 null; 2308 2309 -- An abstract state with visible refinement cannot appear 2310 -- in pragma [Refined_]Global as its place must be taken by 2311 -- some of its constituents (SPARK RM 6.1.4(7)). 2312 2313 elsif Has_Visible_Refinement (Item_Id) then 2314 SPARK_Msg_NE 2315 ("cannot mention state & in global refinement", 2316 Item, Item_Id); 2317 SPARK_Msg_N ("\use its constituents instead", Item); 2318 return; 2319 2320 -- An external state cannot appear as a global item of a 2321 -- nonvolatile function (SPARK RM 7.1.3(8)). 2322 2323 elsif Is_External_State (Item_Id) 2324 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function) 2325 and then not Is_Volatile_Function (Spec_Id) 2326 then 2327 SPARK_Msg_NE 2328 ("external state & cannot act as global item of " 2329 & "nonvolatile function", Item, Item_Id); 2330 return; 2331 2332 -- If the reference to the abstract state appears in an 2333 -- enclosing package body that will eventually refine the 2334 -- state, record the reference for future checks. 2335 2336 else 2337 Record_Possible_Body_Reference 2338 (State_Id => Item_Id, 2339 Ref => Item); 2340 end if; 2341 2342 -- Constant related checks 2343 2344 elsif Ekind (Item_Id) = E_Constant then 2345 2346 -- A constant is a read-only item, therefore it cannot act 2347 -- as an output. 2348 2349 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2350 SPARK_Msg_NE 2351 ("constant & cannot act as output", Item, Item_Id); 2352 return; 2353 end if; 2354 2355 -- Loop parameter related checks 2356 2357 elsif Ekind (Item_Id) = E_Loop_Parameter then 2358 2359 -- A loop parameter is a read-only item, therefore it cannot 2360 -- act as an output. 2361 2362 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2363 SPARK_Msg_NE 2364 ("loop parameter & cannot act as output", 2365 Item, Item_Id); 2366 return; 2367 end if; 2368 2369 -- Variable related checks. These are only relevant when 2370 -- SPARK_Mode is on as they are not standard Ada legality 2371 -- rules. 2372 2373 elsif SPARK_Mode = On 2374 and then Ekind (Item_Id) = E_Variable 2375 and then Is_Effectively_Volatile (Item_Id) 2376 then 2377 -- An effectively volatile object cannot appear as a global 2378 -- item of a nonvolatile function (SPARK RM 7.1.3(8)). 2379 2380 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 2381 and then not Is_Volatile_Function (Spec_Id) 2382 then 2383 Error_Msg_NE 2384 ("volatile object & cannot act as global item of a " 2385 & "function", Item, Item_Id); 2386 return; 2387 2388 -- An effectively volatile object with external property 2389 -- Effective_Reads set to True must have mode Output or 2390 -- In_Out (SPARK RM 7.1.3(10)). 2391 2392 elsif Effective_Reads_Enabled (Item_Id) 2393 and then Global_Mode = Name_Input 2394 then 2395 Error_Msg_NE 2396 ("volatile object & with property Effective_Reads must " 2397 & "have mode In_Out or Output", Item, Item_Id); 2398 return; 2399 end if; 2400 end if; 2401 2402 -- When the item renames an entire object, replace the item 2403 -- with a reference to the object. 2404 2405 if Entity (Item) /= Item_Id then 2406 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item))); 2407 Analyze (Item); 2408 end if; 2409 2410 -- Some form of illegal construct masquerading as a name 2411 -- (SPARK RM 6.1.4(4)). 2412 2413 else 2414 Error_Msg_N 2415 ("global item must denote object, state or current instance " 2416 & "of concurrent type", Item); 2417 return; 2418 end if; 2419 2420 -- Verify that an output does not appear as an input in an 2421 -- enclosing subprogram. 2422 2423 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2424 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id); 2425 end if; 2426 2427 -- The same entity might be referenced through various way. 2428 -- Check the entity of the item rather than the item itself 2429 -- (SPARK RM 6.1.4(10)). 2430 2431 if Contains (Seen, Item_Id) then 2432 SPARK_Msg_N ("duplicate global item", Item); 2433 2434 -- Add the entity of the current item to the list of processed 2435 -- items. 2436 2437 else 2438 Append_New_Elmt (Item_Id, Seen); 2439 2440 if Ekind (Item_Id) = E_Abstract_State then 2441 Append_New_Elmt (Item_Id, States_Seen); 2442 2443 -- The variable may eventually become a constituent of a single 2444 -- protected/task type. Record the reference now and verify its 2445 -- legality when analyzing the contract of the variable 2446 -- (SPARK RM 9.3). 2447 2448 elsif Ekind (Item_Id) = E_Variable then 2449 Record_Possible_Part_Of_Reference 2450 (Var_Id => Item_Id, 2451 Ref => Item); 2452 end if; 2453 2454 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable) 2455 and then Present (Encapsulating_State (Item_Id)) 2456 then 2457 Append_New_Elmt (Item_Id, Constits_Seen); 2458 end if; 2459 end if; 2460 end Analyze_Global_Item; 2461 2462 -------------------------- 2463 -- Check_Duplicate_Mode -- 2464 -------------------------- 2465 2466 procedure Check_Duplicate_Mode 2467 (Mode : Node_Id; 2468 Status : in out Boolean) 2469 is 2470 begin 2471 if Status then 2472 SPARK_Msg_N ("duplicate global mode", Mode); 2473 end if; 2474 2475 Status := True; 2476 end Check_Duplicate_Mode; 2477 2478 ------------------------------------------------- 2479 -- Check_Mode_Restriction_In_Enclosing_Context -- 2480 ------------------------------------------------- 2481 2482 procedure Check_Mode_Restriction_In_Enclosing_Context 2483 (Item : Node_Id; 2484 Item_Id : Entity_Id) 2485 is 2486 Context : Entity_Id; 2487 Dummy : Boolean; 2488 Inputs : Elist_Id := No_Elist; 2489 Outputs : Elist_Id := No_Elist; 2490 2491 begin 2492 -- Traverse the scope stack looking for enclosing subprograms or 2493 -- tasks subject to pragma [Refined_]Global. 2494 2495 Context := Scope (Subp_Id); 2496 while Present (Context) and then Context /= Standard_Standard loop 2497 2498 -- For a single task type, retrieve the corresponding object to 2499 -- which pragma [Refined_]Global is attached. 2500 2501 if Ekind (Context) = E_Task_Type 2502 and then Is_Single_Concurrent_Type (Context) 2503 then 2504 Context := Anonymous_Object (Context); 2505 end if; 2506 2507 if (Is_Subprogram (Context) 2508 or else Ekind (Context) = E_Task_Type 2509 or else Is_Single_Task_Object (Context)) 2510 and then 2511 (Present (Get_Pragma (Context, Pragma_Global)) 2512 or else 2513 Present (Get_Pragma (Context, Pragma_Refined_Global))) 2514 then 2515 Collect_Subprogram_Inputs_Outputs 2516 (Subp_Id => Context, 2517 Subp_Inputs => Inputs, 2518 Subp_Outputs => Outputs, 2519 Global_Seen => Dummy); 2520 2521 -- The item is classified as In_Out or Output but appears as 2522 -- an Input in an enclosing subprogram or task unit (SPARK 2523 -- RM 6.1.4(12)). 2524 2525 if Appears_In (Inputs, Item_Id) 2526 and then not Appears_In (Outputs, Item_Id) 2527 then 2528 SPARK_Msg_NE 2529 ("global item & cannot have mode In_Out or Output", 2530 Item, Item_Id); 2531 2532 if Is_Subprogram (Context) then 2533 SPARK_Msg_NE 2534 (Fix_Msg (Subp_Id, "\item already appears as input " 2535 & "of subprogram &"), Item, Context); 2536 else 2537 SPARK_Msg_NE 2538 (Fix_Msg (Subp_Id, "\item already appears as input " 2539 & "of task &"), Item, Context); 2540 end if; 2541 2542 -- Stop the traversal once an error has been detected 2543 2544 exit; 2545 end if; 2546 end if; 2547 2548 Context := Scope (Context); 2549 end loop; 2550 end Check_Mode_Restriction_In_Enclosing_Context; 2551 2552 ---------------------------------------- 2553 -- Check_Mode_Restriction_In_Function -- 2554 ---------------------------------------- 2555 2556 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is 2557 begin 2558 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 2559 SPARK_Msg_N 2560 ("global mode & is not applicable to functions", Mode); 2561 end if; 2562 end Check_Mode_Restriction_In_Function; 2563 2564 -- Local variables 2565 2566 Assoc : Node_Id; 2567 Item : Node_Id; 2568 Mode : Node_Id; 2569 2570 -- Start of processing for Analyze_Global_List 2571 2572 begin 2573 if Nkind (List) = N_Null then 2574 Set_Analyzed (List); 2575 2576 -- Single global item declaration 2577 2578 elsif Nkind_In (List, N_Expanded_Name, 2579 N_Identifier, 2580 N_Selected_Component) 2581 then 2582 Analyze_Global_Item (List, Global_Mode); 2583 2584 -- Simple global list or moded global list declaration 2585 2586 elsif Nkind (List) = N_Aggregate then 2587 Set_Analyzed (List); 2588 2589 -- The declaration of a simple global list appear as a collection 2590 -- of expressions. 2591 2592 if Present (Expressions (List)) then 2593 if Present (Component_Associations (List)) then 2594 SPARK_Msg_N 2595 ("cannot mix moded and non-moded global lists", List); 2596 end if; 2597 2598 Item := First (Expressions (List)); 2599 while Present (Item) loop 2600 Analyze_Global_Item (Item, Global_Mode); 2601 Next (Item); 2602 end loop; 2603 2604 -- The declaration of a moded global list appears as a collection 2605 -- of component associations where individual choices denote 2606 -- modes. 2607 2608 elsif Present (Component_Associations (List)) then 2609 if Present (Expressions (List)) then 2610 SPARK_Msg_N 2611 ("cannot mix moded and non-moded global lists", List); 2612 end if; 2613 2614 Assoc := First (Component_Associations (List)); 2615 while Present (Assoc) loop 2616 Mode := First (Choices (Assoc)); 2617 2618 if Nkind (Mode) = N_Identifier then 2619 if Chars (Mode) = Name_In_Out then 2620 Check_Duplicate_Mode (Mode, In_Out_Seen); 2621 Check_Mode_Restriction_In_Function (Mode); 2622 2623 elsif Chars (Mode) = Name_Input then 2624 Check_Duplicate_Mode (Mode, Input_Seen); 2625 2626 elsif Chars (Mode) = Name_Output then 2627 Check_Duplicate_Mode (Mode, Output_Seen); 2628 Check_Mode_Restriction_In_Function (Mode); 2629 2630 elsif Chars (Mode) = Name_Proof_In then 2631 Check_Duplicate_Mode (Mode, Proof_Seen); 2632 2633 else 2634 SPARK_Msg_N ("invalid mode selector", Mode); 2635 end if; 2636 2637 else 2638 SPARK_Msg_N ("invalid mode selector", Mode); 2639 end if; 2640 2641 -- Items in a moded list appear as a collection of 2642 -- expressions. Reuse the existing machinery to analyze 2643 -- them. 2644 2645 Analyze_Global_List 2646 (List => Expression (Assoc), 2647 Global_Mode => Chars (Mode)); 2648 2649 Next (Assoc); 2650 end loop; 2651 2652 -- Invalid tree 2653 2654 else 2655 raise Program_Error; 2656 end if; 2657 2658 -- Any other attempt to declare a global item is illegal. This is a 2659 -- syntax error, always report. 2660 2661 else 2662 Error_Msg_N ("malformed global list", List); 2663 end if; 2664 end Analyze_Global_List; 2665 2666 -- Local variables 2667 2668 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 2669 2670 Restore_Scope : Boolean := False; 2671 2672 -- Start of processing for Analyze_Global_In_Decl_Part 2673 2674 begin 2675 -- Do not analyze the pragma multiple times 2676 2677 if Is_Analyzed_Pragma (N) then 2678 return; 2679 end if; 2680 2681 -- There is nothing to be done for a null global list 2682 2683 if Nkind (Items) = N_Null then 2684 Set_Analyzed (Items); 2685 2686 -- Analyze the various forms of global lists and items. Note that some 2687 -- of these may be malformed in which case the analysis emits error 2688 -- messages. 2689 2690 else 2691 -- When pragma [Refined_]Global appears on a single concurrent type, 2692 -- it is relocated to the anonymous object. 2693 2694 if Is_Single_Concurrent_Object (Spec_Id) then 2695 null; 2696 2697 -- Ensure that the formal parameters are visible when processing an 2698 -- item. This falls out of the general rule of aspects pertaining to 2699 -- subprogram declarations. 2700 2701 elsif not In_Open_Scopes (Spec_Id) then 2702 Restore_Scope := True; 2703 Push_Scope (Spec_Id); 2704 2705 if Ekind (Spec_Id) = E_Task_Type then 2706 if Has_Discriminants (Spec_Id) then 2707 Install_Discriminants (Spec_Id); 2708 end if; 2709 2710 elsif Is_Generic_Subprogram (Spec_Id) then 2711 Install_Generic_Formals (Spec_Id); 2712 2713 else 2714 Install_Formals (Spec_Id); 2715 end if; 2716 end if; 2717 2718 Analyze_Global_List (Items); 2719 2720 if Restore_Scope then 2721 End_Scope; 2722 end if; 2723 end if; 2724 2725 -- Ensure that a state and a corresponding constituent do not appear 2726 -- together in pragma [Refined_]Global. 2727 2728 Check_State_And_Constituent_Use 2729 (States => States_Seen, 2730 Constits => Constits_Seen, 2731 Context => N); 2732 2733 Set_Is_Analyzed_Pragma (N); 2734 end Analyze_Global_In_Decl_Part; 2735 2736 -------------------------------------------- 2737 -- Analyze_Initial_Condition_In_Decl_Part -- 2738 -------------------------------------------- 2739 2740 -- WARNING: This routine manages Ghost regions. Return statements must be 2741 -- replaced by gotos which jump to the end of the routine and restore the 2742 -- Ghost mode. 2743 2744 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is 2745 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 2746 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 2747 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id)); 2748 2749 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 2750 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 2751 -- Save the Ghost-related attributes to restore on exit 2752 2753 begin 2754 -- Do not analyze the pragma multiple times 2755 2756 if Is_Analyzed_Pragma (N) then 2757 return; 2758 end if; 2759 2760 -- Set the Ghost mode in effect from the pragma. Due to the delayed 2761 -- analysis of the pragma, the Ghost mode at point of declaration and 2762 -- point of analysis may not necessarily be the same. Use the mode in 2763 -- effect at the point of declaration. 2764 2765 Set_Ghost_Mode (N); 2766 2767 -- The expression is preanalyzed because it has not been moved to its 2768 -- final place yet. A direct analysis may generate side effects and this 2769 -- is not desired at this point. 2770 2771 Preanalyze_Assert_Expression (Expr, Standard_Boolean); 2772 Set_Is_Analyzed_Pragma (N); 2773 2774 Restore_Ghost_Region (Saved_GM, Saved_IGR); 2775 end Analyze_Initial_Condition_In_Decl_Part; 2776 2777 -------------------------------------- 2778 -- Analyze_Initializes_In_Decl_Part -- 2779 -------------------------------------- 2780 2781 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is 2782 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 2783 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 2784 2785 Constits_Seen : Elist_Id := No_Elist; 2786 -- A list containing the entities of all constituents processed so far. 2787 -- It aids in detecting illegal usage of a state and a corresponding 2788 -- constituent in pragma Initializes. 2789 2790 Items_Seen : Elist_Id := No_Elist; 2791 -- A list of all initialization items processed so far. This list is 2792 -- used to detect duplicate items. 2793 2794 States_And_Objs : Elist_Id := No_Elist; 2795 -- A list of all abstract states and objects declared in the visible 2796 -- declarations of the related package. This list is used to detect the 2797 -- legality of initialization items. 2798 2799 States_Seen : Elist_Id := No_Elist; 2800 -- A list containing the entities of all states processed so far. It 2801 -- helps in detecting illegal usage of a state and a corresponding 2802 -- constituent in pragma Initializes. 2803 2804 procedure Analyze_Initialization_Item (Item : Node_Id); 2805 -- Verify the legality of a single initialization item 2806 2807 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id); 2808 -- Verify the legality of a single initialization item followed by a 2809 -- list of input items. 2810 2811 procedure Collect_States_And_Objects; 2812 -- Inspect the visible declarations of the related package and gather 2813 -- the entities of all abstract states and objects in States_And_Objs. 2814 2815 --------------------------------- 2816 -- Analyze_Initialization_Item -- 2817 --------------------------------- 2818 2819 procedure Analyze_Initialization_Item (Item : Node_Id) is 2820 Item_Id : Entity_Id; 2821 2822 begin 2823 Analyze (Item); 2824 Resolve_State (Item); 2825 2826 if Is_Entity_Name (Item) then 2827 Item_Id := Entity_Of (Item); 2828 2829 if Present (Item_Id) 2830 and then Ekind_In (Item_Id, E_Abstract_State, 2831 E_Constant, 2832 E_Variable) 2833 then 2834 -- When the initialization item is undefined, it appears as 2835 -- Any_Id. Do not continue with the analysis of the item. 2836 2837 if Item_Id = Any_Id then 2838 null; 2839 2840 -- The state or variable must be declared in the visible 2841 -- declarations of the package (SPARK RM 7.1.5(7)). 2842 2843 elsif not Contains (States_And_Objs, Item_Id) then 2844 Error_Msg_Name_1 := Chars (Pack_Id); 2845 SPARK_Msg_NE 2846 ("initialization item & must appear in the visible " 2847 & "declarations of package %", Item, Item_Id); 2848 2849 -- Detect a duplicate use of the same initialization item 2850 -- (SPARK RM 7.1.5(5)). 2851 2852 elsif Contains (Items_Seen, Item_Id) then 2853 SPARK_Msg_N ("duplicate initialization item", Item); 2854 2855 -- The item is legal, add it to the list of processed states 2856 -- and variables. 2857 2858 else 2859 Append_New_Elmt (Item_Id, Items_Seen); 2860 2861 if Ekind (Item_Id) = E_Abstract_State then 2862 Append_New_Elmt (Item_Id, States_Seen); 2863 end if; 2864 2865 if Present (Encapsulating_State (Item_Id)) then 2866 Append_New_Elmt (Item_Id, Constits_Seen); 2867 end if; 2868 end if; 2869 2870 -- The item references something that is not a state or object 2871 -- (SPARK RM 7.1.5(3)). 2872 2873 else 2874 SPARK_Msg_N 2875 ("initialization item must denote object or state", Item); 2876 end if; 2877 2878 -- Some form of illegal construct masquerading as a name 2879 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. 2880 2881 else 2882 Error_Msg_N 2883 ("initialization item must denote object or state", Item); 2884 end if; 2885 end Analyze_Initialization_Item; 2886 2887 --------------------------------------------- 2888 -- Analyze_Initialization_Item_With_Inputs -- 2889 --------------------------------------------- 2890 2891 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is 2892 Inputs_Seen : Elist_Id := No_Elist; 2893 -- A list of all inputs processed so far. This list is used to detect 2894 -- duplicate uses of an input. 2895 2896 Non_Null_Seen : Boolean := False; 2897 Null_Seen : Boolean := False; 2898 -- Flags used to check the legality of an input list 2899 2900 procedure Analyze_Input_Item (Input : Node_Id); 2901 -- Verify the legality of a single input item 2902 2903 ------------------------ 2904 -- Analyze_Input_Item -- 2905 ------------------------ 2906 2907 procedure Analyze_Input_Item (Input : Node_Id) is 2908 Input_Id : Entity_Id; 2909 2910 begin 2911 -- Null input list 2912 2913 if Nkind (Input) = N_Null then 2914 if Null_Seen then 2915 SPARK_Msg_N 2916 ("multiple null initializations not allowed", Item); 2917 2918 elsif Non_Null_Seen then 2919 SPARK_Msg_N 2920 ("cannot mix null and non-null initialization item", Item); 2921 else 2922 Null_Seen := True; 2923 end if; 2924 2925 -- Input item 2926 2927 else 2928 Non_Null_Seen := True; 2929 2930 if Null_Seen then 2931 SPARK_Msg_N 2932 ("cannot mix null and non-null initialization item", Item); 2933 end if; 2934 2935 Analyze (Input); 2936 Resolve_State (Input); 2937 2938 if Is_Entity_Name (Input) then 2939 Input_Id := Entity_Of (Input); 2940 2941 if Present (Input_Id) 2942 and then Ekind_In (Input_Id, E_Abstract_State, 2943 E_Constant, 2944 E_Generic_In_Out_Parameter, 2945 E_Generic_In_Parameter, 2946 E_In_Parameter, 2947 E_In_Out_Parameter, 2948 E_Out_Parameter, 2949 E_Protected_Type, 2950 E_Task_Type, 2951 E_Variable) 2952 then 2953 -- The input cannot denote states or objects declared 2954 -- within the related package (SPARK RM 7.1.5(4)). 2955 2956 if Within_Scope (Input_Id, Current_Scope) then 2957 2958 -- Do not consider generic formal parameters or their 2959 -- respective mappings to generic formals. Even though 2960 -- the formals appear within the scope of the package, 2961 -- it is allowed for an initialization item to depend 2962 -- on an input item. 2963 2964 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter, 2965 E_Generic_In_Parameter) 2966 then 2967 null; 2968 2969 elsif Ekind_In (Input_Id, E_Constant, E_Variable) 2970 and then Present (Corresponding_Generic_Association 2971 (Declaration_Node (Input_Id))) 2972 then 2973 null; 2974 2975 else 2976 Error_Msg_Name_1 := Chars (Pack_Id); 2977 SPARK_Msg_NE 2978 ("input item & cannot denote a visible object or " 2979 & "state of package %", Input, Input_Id); 2980 return; 2981 end if; 2982 end if; 2983 2984 -- Detect a duplicate use of the same input item 2985 -- (SPARK RM 7.1.5(5)). 2986 2987 if Contains (Inputs_Seen, Input_Id) then 2988 SPARK_Msg_N ("duplicate input item", Input); 2989 return; 2990 end if; 2991 2992 -- At this point it is known that the input is legal. Add 2993 -- it to the list of processed inputs. 2994 2995 Append_New_Elmt (Input_Id, Inputs_Seen); 2996 2997 if Ekind (Input_Id) = E_Abstract_State then 2998 Append_New_Elmt (Input_Id, States_Seen); 2999 end if; 3000 3001 if Ekind_In (Input_Id, E_Abstract_State, 3002 E_Constant, 3003 E_Variable) 3004 and then Present (Encapsulating_State (Input_Id)) 3005 then 3006 Append_New_Elmt (Input_Id, Constits_Seen); 3007 end if; 3008 3009 -- The input references something that is not a state or an 3010 -- object (SPARK RM 7.1.5(3)). 3011 3012 else 3013 SPARK_Msg_N 3014 ("input item must denote object or state", Input); 3015 end if; 3016 3017 -- Some form of illegal construct masquerading as a name 3018 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. 3019 3020 else 3021 Error_Msg_N 3022 ("input item must denote object or state", Input); 3023 end if; 3024 end if; 3025 end Analyze_Input_Item; 3026 3027 -- Local variables 3028 3029 Inputs : constant Node_Id := Expression (Item); 3030 Elmt : Node_Id; 3031 Input : Node_Id; 3032 3033 Name_Seen : Boolean := False; 3034 -- A flag used to detect multiple item names 3035 3036 -- Start of processing for Analyze_Initialization_Item_With_Inputs 3037 3038 begin 3039 -- Inspect the name of an item with inputs 3040 3041 Elmt := First (Choices (Item)); 3042 while Present (Elmt) loop 3043 if Name_Seen then 3044 SPARK_Msg_N ("only one item allowed in initialization", Elmt); 3045 else 3046 Name_Seen := True; 3047 Analyze_Initialization_Item (Elmt); 3048 end if; 3049 3050 Next (Elmt); 3051 end loop; 3052 3053 -- Multiple input items appear as an aggregate 3054 3055 if Nkind (Inputs) = N_Aggregate then 3056 if Present (Expressions (Inputs)) then 3057 Input := First (Expressions (Inputs)); 3058 while Present (Input) loop 3059 Analyze_Input_Item (Input); 3060 Next (Input); 3061 end loop; 3062 end if; 3063 3064 if Present (Component_Associations (Inputs)) then 3065 SPARK_Msg_N 3066 ("inputs must appear in named association form", Inputs); 3067 end if; 3068 3069 -- Single input item 3070 3071 else 3072 Analyze_Input_Item (Inputs); 3073 end if; 3074 end Analyze_Initialization_Item_With_Inputs; 3075 3076 -------------------------------- 3077 -- Collect_States_And_Objects -- 3078 -------------------------------- 3079 3080 procedure Collect_States_And_Objects is 3081 Pack_Spec : constant Node_Id := Specification (Pack_Decl); 3082 Decl : Node_Id; 3083 3084 begin 3085 -- Collect the abstract states defined in the package (if any) 3086 3087 if Present (Abstract_States (Pack_Id)) then 3088 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id)); 3089 end if; 3090 3091 -- Collect all objects that appear in the visible declarations of the 3092 -- related package. 3093 3094 if Present (Visible_Declarations (Pack_Spec)) then 3095 Decl := First (Visible_Declarations (Pack_Spec)); 3096 while Present (Decl) loop 3097 if Comes_From_Source (Decl) 3098 and then Nkind_In (Decl, N_Object_Declaration, 3099 N_Object_Renaming_Declaration) 3100 then 3101 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); 3102 3103 elsif Is_Single_Concurrent_Type_Declaration (Decl) then 3104 Append_New_Elmt 3105 (Anonymous_Object (Defining_Entity (Decl)), 3106 States_And_Objs); 3107 end if; 3108 3109 Next (Decl); 3110 end loop; 3111 end if; 3112 end Collect_States_And_Objects; 3113 3114 -- Local variables 3115 3116 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id)); 3117 Init : Node_Id; 3118 3119 -- Start of processing for Analyze_Initializes_In_Decl_Part 3120 3121 begin 3122 -- Do not analyze the pragma multiple times 3123 3124 if Is_Analyzed_Pragma (N) then 3125 return; 3126 end if; 3127 3128 -- Nothing to do when the initialization list is empty 3129 3130 if Nkind (Inits) = N_Null then 3131 return; 3132 end if; 3133 3134 -- Single and multiple initialization clauses appear as an aggregate. If 3135 -- this is not the case, then either the parser or the analysis of the 3136 -- pragma failed to produce an aggregate. 3137 3138 pragma Assert (Nkind (Inits) = N_Aggregate); 3139 3140 -- Initialize the various lists used during analysis 3141 3142 Collect_States_And_Objects; 3143 3144 if Present (Expressions (Inits)) then 3145 Init := First (Expressions (Inits)); 3146 while Present (Init) loop 3147 Analyze_Initialization_Item (Init); 3148 Next (Init); 3149 end loop; 3150 end if; 3151 3152 if Present (Component_Associations (Inits)) then 3153 Init := First (Component_Associations (Inits)); 3154 while Present (Init) loop 3155 Analyze_Initialization_Item_With_Inputs (Init); 3156 Next (Init); 3157 end loop; 3158 end if; 3159 3160 -- Ensure that a state and a corresponding constituent do not appear 3161 -- together in pragma Initializes. 3162 3163 Check_State_And_Constituent_Use 3164 (States => States_Seen, 3165 Constits => Constits_Seen, 3166 Context => N); 3167 3168 Set_Is_Analyzed_Pragma (N); 3169 end Analyze_Initializes_In_Decl_Part; 3170 3171 --------------------- 3172 -- Analyze_Part_Of -- 3173 --------------------- 3174 3175 procedure Analyze_Part_Of 3176 (Indic : Node_Id; 3177 Item_Id : Entity_Id; 3178 Encap : Node_Id; 3179 Encap_Id : out Entity_Id; 3180 Legal : out Boolean) 3181 is 3182 procedure Check_Part_Of_Abstract_State; 3183 pragma Inline (Check_Part_Of_Abstract_State); 3184 -- Verify the legality of indicator Part_Of when the encapsulator is an 3185 -- abstract state. 3186 3187 procedure Check_Part_Of_Concurrent_Type; 3188 pragma Inline (Check_Part_Of_Concurrent_Type); 3189 -- Verify the legality of indicator Part_Of when the encapsulator is a 3190 -- single concurrent type. 3191 3192 ---------------------------------- 3193 -- Check_Part_Of_Abstract_State -- 3194 ---------------------------------- 3195 3196 procedure Check_Part_Of_Abstract_State is 3197 Pack_Id : Entity_Id; 3198 Placement : State_Space_Kind; 3199 Parent_Unit : Entity_Id; 3200 3201 begin 3202 -- Determine where the object, package instantiation or state lives 3203 -- with respect to the enclosing packages or package bodies. 3204 3205 Find_Placement_In_State_Space 3206 (Item_Id => Item_Id, 3207 Placement => Placement, 3208 Pack_Id => Pack_Id); 3209 3210 -- The item appears in a non-package construct with a declarative 3211 -- part (subprogram, block, etc). As such, the item is not allowed 3212 -- to be a part of an encapsulating state because the item is not 3213 -- visible. 3214 3215 if Placement = Not_In_Package then 3216 SPARK_Msg_N 3217 ("indicator Part_Of cannot appear in this context " 3218 & "(SPARK RM 7.2.6(5))", Indic); 3219 3220 Error_Msg_Name_1 := Chars (Scope (Encap_Id)); 3221 SPARK_Msg_NE 3222 ("\& is not part of the hidden state of package %", 3223 Indic, Item_Id); 3224 return; 3225 3226 -- The item appears in the visible state space of some package. In 3227 -- general this scenario does not warrant Part_Of except when the 3228 -- package is a nongeneric private child unit and the encapsulating 3229 -- state is declared in a parent unit or a public descendant of that 3230 -- parent unit. 3231 3232 elsif Placement = Visible_State_Space then 3233 if Is_Child_Unit (Pack_Id) 3234 and then not Is_Generic_Unit (Pack_Id) 3235 and then Is_Private_Descendant (Pack_Id) 3236 then 3237 -- A variable or state abstraction which is part of the visible 3238 -- state of a nongeneric private child unit or its public 3239 -- descendants must have its Part_Of indicator specified. The 3240 -- Part_Of indicator must denote a state declared by either the 3241 -- parent unit of the private unit or by a public descendant of 3242 -- that parent unit. 3243 3244 -- Find the nearest private ancestor (which can be the current 3245 -- unit itself). 3246 3247 Parent_Unit := Pack_Id; 3248 while Present (Parent_Unit) loop 3249 exit when 3250 Private_Present 3251 (Parent (Unit_Declaration_Node (Parent_Unit))); 3252 Parent_Unit := Scope (Parent_Unit); 3253 end loop; 3254 3255 Parent_Unit := Scope (Parent_Unit); 3256 3257 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then 3258 SPARK_Msg_NE 3259 ("indicator Part_Of must denote abstract state of & or of " 3260 & "its public descendant (SPARK RM 7.2.6(3))", 3261 Indic, Parent_Unit); 3262 return; 3263 3264 elsif Scope (Encap_Id) = Parent_Unit 3265 or else 3266 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id)) 3267 and then not Is_Private_Descendant (Scope (Encap_Id))) 3268 then 3269 null; 3270 3271 else 3272 SPARK_Msg_NE 3273 ("indicator Part_Of must denote abstract state of & or of " 3274 & "its public descendant (SPARK RM 7.2.6(3))", 3275 Indic, Parent_Unit); 3276 return; 3277 end if; 3278 3279 -- Indicator Part_Of is not needed when the related package is 3280 -- not a nongeneric private child unit or a public descendant 3281 -- thereof. 3282 3283 else 3284 SPARK_Msg_N 3285 ("indicator Part_Of cannot appear in this context " 3286 & "(SPARK RM 7.2.6(5))", Indic); 3287 3288 Error_Msg_Name_1 := Chars (Pack_Id); 3289 SPARK_Msg_NE 3290 ("\& is declared in the visible part of package %", 3291 Indic, Item_Id); 3292 return; 3293 end if; 3294 3295 -- When the item appears in the private state space of a package, the 3296 -- encapsulating state must be declared in the same package. 3297 3298 elsif Placement = Private_State_Space then 3299 if Scope (Encap_Id) /= Pack_Id then 3300 SPARK_Msg_NE 3301 ("indicator Part_Of must denote an abstract state of " 3302 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id); 3303 3304 Error_Msg_Name_1 := Chars (Pack_Id); 3305 SPARK_Msg_NE 3306 ("\& is declared in the private part of package %", 3307 Indic, Item_Id); 3308 return; 3309 end if; 3310 3311 -- Items declared in the body state space of a package do not need 3312 -- Part_Of indicators as the refinement has already been seen. 3313 3314 else 3315 SPARK_Msg_N 3316 ("indicator Part_Of cannot appear in this context " 3317 & "(SPARK RM 7.2.6(5))", Indic); 3318 3319 if Scope (Encap_Id) = Pack_Id then 3320 Error_Msg_Name_1 := Chars (Pack_Id); 3321 SPARK_Msg_NE 3322 ("\& is declared in the body of package %", Indic, Item_Id); 3323 end if; 3324 3325 return; 3326 end if; 3327 3328 -- At this point it is known that the Part_Of indicator is legal 3329 3330 Legal := True; 3331 end Check_Part_Of_Abstract_State; 3332 3333 ----------------------------------- 3334 -- Check_Part_Of_Concurrent_Type -- 3335 ----------------------------------- 3336 3337 procedure Check_Part_Of_Concurrent_Type is 3338 function In_Proper_Order 3339 (First : Node_Id; 3340 Second : Node_Id) return Boolean; 3341 pragma Inline (In_Proper_Order); 3342 -- Determine whether node First precedes node Second 3343 3344 procedure Placement_Error; 3345 pragma Inline (Placement_Error); 3346 -- Emit an error concerning the illegal placement of the item with 3347 -- respect to the single concurrent type. 3348 3349 --------------------- 3350 -- In_Proper_Order -- 3351 --------------------- 3352 3353 function In_Proper_Order 3354 (First : Node_Id; 3355 Second : Node_Id) return Boolean 3356 is 3357 N : Node_Id; 3358 3359 begin 3360 if List_Containing (First) = List_Containing (Second) then 3361 N := First; 3362 while Present (N) loop 3363 if N = Second then 3364 return True; 3365 end if; 3366 3367 Next (N); 3368 end loop; 3369 end if; 3370 3371 return False; 3372 end In_Proper_Order; 3373 3374 --------------------- 3375 -- Placement_Error -- 3376 --------------------- 3377 3378 procedure Placement_Error is 3379 begin 3380 SPARK_Msg_N 3381 ("indicator Part_Of must denote a previously declared single " 3382 & "protected type or single task type", Encap); 3383 end Placement_Error; 3384 3385 -- Local variables 3386 3387 Conc_Typ : constant Entity_Id := Etype (Encap_Id); 3388 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id); 3389 Encap_Context : constant Node_Id := Parent (Encap_Decl); 3390 3391 Item_Context : Node_Id; 3392 Item_Decl : Node_Id; 3393 Prv_Decls : List_Id; 3394 Vis_Decls : List_Id; 3395 3396 -- Start of processing for Check_Part_Of_Concurrent_Type 3397 3398 begin 3399 -- Only abstract states and variables can act as constituents of an 3400 -- encapsulating single concurrent type. 3401 3402 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 3403 null; 3404 3405 -- The constituent is a constant 3406 3407 elsif Ekind (Item_Id) = E_Constant then 3408 Error_Msg_Name_1 := Chars (Encap_Id); 3409 SPARK_Msg_NE 3410 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of " 3411 & "single protected type %"), Indic, Item_Id); 3412 return; 3413 3414 -- The constituent is a package instantiation 3415 3416 else 3417 Error_Msg_Name_1 := Chars (Encap_Id); 3418 SPARK_Msg_NE 3419 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as " 3420 & "constituent of single protected type %"), Indic, Item_Id); 3421 return; 3422 end if; 3423 3424 -- When the item denotes an abstract state of a nested package, use 3425 -- the declaration of the package to detect proper placement. 3426 3427 -- package Pack is 3428 -- task T; 3429 -- package Nested 3430 -- with Abstract_State => (State with Part_Of => T) 3431 3432 if Ekind (Item_Id) = E_Abstract_State then 3433 Item_Decl := Unit_Declaration_Node (Scope (Item_Id)); 3434 else 3435 Item_Decl := Declaration_Node (Item_Id); 3436 end if; 3437 3438 Item_Context := Parent (Item_Decl); 3439 3440 -- The item and the single concurrent type must appear in the same 3441 -- declarative region, with the item following the declaration of 3442 -- the single concurrent type (SPARK RM 9(3)). 3443 3444 if Item_Context = Encap_Context then 3445 if Nkind_In (Item_Context, N_Package_Specification, 3446 N_Protected_Definition, 3447 N_Task_Definition) 3448 then 3449 Prv_Decls := Private_Declarations (Item_Context); 3450 Vis_Decls := Visible_Declarations (Item_Context); 3451 3452 -- The placement is OK when the single concurrent type appears 3453 -- within the visible declarations and the item in the private 3454 -- declarations. 3455 -- 3456 -- package Pack is 3457 -- protected PO ... 3458 -- private 3459 -- Constit : ... with Part_Of => PO; 3460 -- end Pack; 3461 3462 if List_Containing (Encap_Decl) = Vis_Decls 3463 and then List_Containing (Item_Decl) = Prv_Decls 3464 then 3465 null; 3466 3467 -- The placement is illegal when the item appears within the 3468 -- visible declarations and the single concurrent type is in 3469 -- the private declarations. 3470 -- 3471 -- package Pack is 3472 -- Constit : ... with Part_Of => PO; 3473 -- private 3474 -- protected PO ... 3475 -- end Pack; 3476 3477 elsif List_Containing (Item_Decl) = Vis_Decls 3478 and then List_Containing (Encap_Decl) = Prv_Decls 3479 then 3480 Placement_Error; 3481 return; 3482 3483 -- Otherwise both the item and the single concurrent type are 3484 -- in the same list. Ensure that the declaration of the single 3485 -- concurrent type precedes that of the item. 3486 3487 elsif not In_Proper_Order 3488 (First => Encap_Decl, 3489 Second => Item_Decl) 3490 then 3491 Placement_Error; 3492 return; 3493 end if; 3494 3495 -- Otherwise both the item and the single concurrent type are 3496 -- in the same list. Ensure that the declaration of the single 3497 -- concurrent type precedes that of the item. 3498 3499 elsif not In_Proper_Order 3500 (First => Encap_Decl, 3501 Second => Item_Decl) 3502 then 3503 Placement_Error; 3504 return; 3505 end if; 3506 3507 -- Otherwise the item and the single concurrent type reside within 3508 -- unrelated regions. 3509 3510 else 3511 Error_Msg_Name_1 := Chars (Encap_Id); 3512 SPARK_Msg_NE 3513 (Fix_Msg (Conc_Typ, "constituent & must be declared " 3514 & "immediately within the same region as single protected " 3515 & "type %"), Indic, Item_Id); 3516 return; 3517 end if; 3518 3519 -- At this point it is known that the Part_Of indicator is legal 3520 3521 Legal := True; 3522 end Check_Part_Of_Concurrent_Type; 3523 3524 -- Start of processing for Analyze_Part_Of 3525 3526 begin 3527 -- Assume that the indicator is illegal 3528 3529 Encap_Id := Empty; 3530 Legal := False; 3531 3532 if Nkind_In (Encap, N_Expanded_Name, 3533 N_Identifier, 3534 N_Selected_Component) 3535 then 3536 Analyze (Encap); 3537 Resolve_State (Encap); 3538 3539 Encap_Id := Entity (Encap); 3540 3541 -- The encapsulator is an abstract state 3542 3543 if Ekind (Encap_Id) = E_Abstract_State then 3544 null; 3545 3546 -- The encapsulator is a single concurrent type (SPARK RM 9.3) 3547 3548 elsif Is_Single_Concurrent_Object (Encap_Id) then 3549 null; 3550 3551 -- Otherwise the encapsulator is not a legal choice 3552 3553 else 3554 SPARK_Msg_N 3555 ("indicator Part_Of must denote abstract state, single " 3556 & "protected type or single task type", Encap); 3557 return; 3558 end if; 3559 3560 -- This is a syntax error, always report 3561 3562 else 3563 Error_Msg_N 3564 ("indicator Part_Of must denote abstract state, single protected " 3565 & "type or single task type", Encap); 3566 return; 3567 end if; 3568 3569 -- Catch a case where indicator Part_Of denotes the abstract view of a 3570 -- variable which appears as an abstract state (SPARK RM 10.1.2 2). 3571 3572 if From_Limited_With (Encap_Id) 3573 and then Present (Non_Limited_View (Encap_Id)) 3574 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable 3575 then 3576 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap); 3577 SPARK_Msg_N ("\& denotes abstract view of object", Encap); 3578 return; 3579 end if; 3580 3581 -- The encapsulator is an abstract state 3582 3583 if Ekind (Encap_Id) = E_Abstract_State then 3584 Check_Part_Of_Abstract_State; 3585 3586 -- The encapsulator is a single concurrent type 3587 3588 else 3589 Check_Part_Of_Concurrent_Type; 3590 end if; 3591 end Analyze_Part_Of; 3592 3593 ---------------------------------- 3594 -- Analyze_Part_Of_In_Decl_Part -- 3595 ---------------------------------- 3596 3597 procedure Analyze_Part_Of_In_Decl_Part 3598 (N : Node_Id; 3599 Freeze_Id : Entity_Id := Empty) 3600 is 3601 Encap : constant Node_Id := 3602 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 3603 Errors : constant Nat := Serious_Errors_Detected; 3604 Var_Decl : constant Node_Id := Find_Related_Context (N); 3605 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl); 3606 Constits : Elist_Id; 3607 Encap_Id : Entity_Id; 3608 Legal : Boolean; 3609 3610 begin 3611 -- Detect any discrepancies between the placement of the variable with 3612 -- respect to general state space and the encapsulating state or single 3613 -- concurrent type. 3614 3615 Analyze_Part_Of 3616 (Indic => N, 3617 Item_Id => Var_Id, 3618 Encap => Encap, 3619 Encap_Id => Encap_Id, 3620 Legal => Legal); 3621 3622 -- The Part_Of indicator turns the variable into a constituent of the 3623 -- encapsulating state or single concurrent type. 3624 3625 if Legal then 3626 pragma Assert (Present (Encap_Id)); 3627 Constits := Part_Of_Constituents (Encap_Id); 3628 3629 if No (Constits) then 3630 Constits := New_Elmt_List; 3631 Set_Part_Of_Constituents (Encap_Id, Constits); 3632 end if; 3633 3634 Append_Elmt (Var_Id, Constits); 3635 Set_Encapsulating_State (Var_Id, Encap_Id); 3636 3637 -- A Part_Of constituent partially refines an abstract state. This 3638 -- property does not apply to protected or task units. 3639 3640 if Ekind (Encap_Id) = E_Abstract_State then 3641 Set_Has_Partial_Visible_Refinement (Encap_Id); 3642 end if; 3643 end if; 3644 3645 -- Emit a clarification message when the encapsulator is undefined, 3646 -- possibly due to contract freezing. 3647 3648 if Errors /= Serious_Errors_Detected 3649 and then Present (Freeze_Id) 3650 and then Has_Undefined_Reference (Encap) 3651 then 3652 Contract_Freeze_Error (Var_Id, Freeze_Id); 3653 end if; 3654 end Analyze_Part_Of_In_Decl_Part; 3655 3656 -------------------- 3657 -- Analyze_Pragma -- 3658 -------------------- 3659 3660 procedure Analyze_Pragma (N : Node_Id) is 3661 Loc : constant Source_Ptr := Sloc (N); 3662 3663 Pname : Name_Id := Pragma_Name (N); 3664 -- Name of the source pragma, or name of the corresponding aspect for 3665 -- pragmas which originate in a source aspect. In the latter case, the 3666 -- name may be different from the pragma name. 3667 3668 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); 3669 3670 Pragma_Exit : exception; 3671 -- This exception is used to exit pragma processing completely. It 3672 -- is used when an error is detected, and no further processing is 3673 -- required. It is also used if an earlier error has left the tree in 3674 -- a state where the pragma should not be processed. 3675 3676 Arg_Count : Nat; 3677 -- Number of pragma argument associations 3678 3679 Arg1 : Node_Id; 3680 Arg2 : Node_Id; 3681 Arg3 : Node_Id; 3682 Arg4 : Node_Id; 3683 -- First four pragma arguments (pragma argument association nodes, or 3684 -- Empty if the corresponding argument does not exist). 3685 3686 type Name_List is array (Natural range <>) of Name_Id; 3687 type Args_List is array (Natural range <>) of Node_Id; 3688 -- Types used for arguments to Check_Arg_Order and Gather_Associations 3689 3690 ----------------------- 3691 -- Local Subprograms -- 3692 ----------------------- 3693 3694 function Acc_First (N : Node_Id) return Node_Id; 3695 -- Helper function to iterate over arguments given to OpenAcc pragmas 3696 3697 function Acc_Next (N : Node_Id) return Node_Id; 3698 -- Helper function to iterate over arguments given to OpenAcc pragmas 3699 3700 procedure Acquire_Warning_Match_String (Arg : Node_Id); 3701 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to 3702 -- get the given string argument, and place it in Name_Buffer, adding 3703 -- leading and trailing asterisks if they are not already present. The 3704 -- caller has already checked that Arg is a static string expression. 3705 3706 procedure Ada_2005_Pragma; 3707 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In 3708 -- Ada 95 mode, these are implementation defined pragmas, so should be 3709 -- caught by the No_Implementation_Pragmas restriction. 3710 3711 procedure Ada_2012_Pragma; 3712 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. 3713 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so 3714 -- should be caught by the No_Implementation_Pragmas restriction. 3715 3716 procedure Analyze_Depends_Global 3717 (Spec_Id : out Entity_Id; 3718 Subp_Decl : out Node_Id; 3719 Legal : out Boolean); 3720 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the 3721 -- legality of the placement and related context of the pragma. Spec_Id 3722 -- is the entity of the related subprogram. Subp_Decl is the declaration 3723 -- of the related subprogram. Sets flag Legal when the pragma is legal. 3724 3725 procedure Analyze_If_Present (Id : Pragma_Id); 3726 -- Inspect the remainder of the list containing pragma N and look for 3727 -- a pragma that matches Id. If found, analyze the pragma. 3728 3729 procedure Analyze_Pre_Post_Condition; 3730 -- Subsidiary to the analysis of pragmas Precondition and Postcondition 3731 3732 procedure Analyze_Refined_Depends_Global_Post 3733 (Spec_Id : out Entity_Id; 3734 Body_Id : out Entity_Id; 3735 Legal : out Boolean); 3736 -- Subsidiary routine to the analysis of body pragmas Refined_Depends, 3737 -- Refined_Global and Refined_Post. Verify the legality of the placement 3738 -- and related context of the pragma. Spec_Id is the entity of the 3739 -- related subprogram. Body_Id is the entity of the subprogram body. 3740 -- Flag Legal is set when the pragma is legal. 3741 3742 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False); 3743 -- Perform full analysis of pragma Unmodified and the write aspect of 3744 -- pragma Unused. Flag Is_Unused should be set when verifying the 3745 -- semantics of pragma Unused. 3746 3747 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False); 3748 -- Perform full analysis of pragma Unreferenced and the read aspect of 3749 -- pragma Unused. Flag Is_Unused should be set when verifying the 3750 -- semantics of pragma Unused. 3751 3752 procedure Check_Ada_83_Warning; 3753 -- Issues a warning message for the current pragma if operating in Ada 3754 -- 83 mode (used for language pragmas that are not a standard part of 3755 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use 3756 -- of 95 pragma. 3757 3758 procedure Check_Arg_Count (Required : Nat); 3759 -- Check argument count for pragma is equal to given parameter. If not, 3760 -- then issue an error message and raise Pragma_Exit. 3761 3762 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument 3763 -- Arg which can either be a pragma argument association, in which case 3764 -- the check is applied to the expression of the association or an 3765 -- expression directly. 3766 3767 procedure Check_Arg_Is_External_Name (Arg : Node_Id); 3768 -- Check that an argument has the right form for an EXTERNAL_NAME 3769 -- parameter of an extended import/export pragma. The rule is that the 3770 -- name must be an identifier or string literal (in Ada 83 mode) or a 3771 -- static string expression (in Ada 95 mode). 3772 3773 procedure Check_Arg_Is_Identifier (Arg : Node_Id); 3774 -- Check the specified argument Arg to make sure that it is an 3775 -- identifier. If not give error and raise Pragma_Exit. 3776 3777 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); 3778 -- Check the specified argument Arg to make sure that it is an integer 3779 -- literal. If not give error and raise Pragma_Exit. 3780 3781 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); 3782 -- Check the specified argument Arg to make sure that it has the proper 3783 -- syntactic form for a local name and meets the semantic requirements 3784 -- for a local name. The local name is analyzed as part of the 3785 -- processing for this call. In addition, the local name is required 3786 -- to represent an entity at the library level. 3787 3788 procedure Check_Arg_Is_Local_Name (Arg : Node_Id); 3789 -- Check the specified argument Arg to make sure that it has the proper 3790 -- syntactic form for a local name and meets the semantic requirements 3791 -- for a local name. The local name is analyzed as part of the 3792 -- processing for this call. 3793 3794 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); 3795 -- Check the specified argument Arg to make sure that it is a valid 3796 -- locking policy name. If not give error and raise Pragma_Exit. 3797 3798 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); 3799 -- Check the specified argument Arg to make sure that it is a valid 3800 -- elaboration policy name. If not give error and raise Pragma_Exit. 3801 3802 procedure Check_Arg_Is_One_Of 3803 (Arg : Node_Id; 3804 N1, N2 : Name_Id); 3805 procedure Check_Arg_Is_One_Of 3806 (Arg : Node_Id; 3807 N1, N2, N3 : Name_Id); 3808 procedure Check_Arg_Is_One_Of 3809 (Arg : Node_Id; 3810 N1, N2, N3, N4 : Name_Id); 3811 procedure Check_Arg_Is_One_Of 3812 (Arg : Node_Id; 3813 N1, N2, N3, N4, N5 : Name_Id); 3814 -- Check the specified argument Arg to make sure that it is an 3815 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if 3816 -- present). If not then give error and raise Pragma_Exit. 3817 3818 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); 3819 -- Check the specified argument Arg to make sure that it is a valid 3820 -- queuing policy name. If not give error and raise Pragma_Exit. 3821 3822 procedure Check_Arg_Is_OK_Static_Expression 3823 (Arg : Node_Id; 3824 Typ : Entity_Id := Empty); 3825 -- Check the specified argument Arg to make sure that it is a static 3826 -- expression of the given type (i.e. it will be analyzed and resolved 3827 -- using this type, which can be any valid argument to Resolve, e.g. 3828 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 3829 -- Typ is left Empty, then any static expression is allowed. Includes 3830 -- checking that the argument does not raise Constraint_Error. 3831 3832 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); 3833 -- Check the specified argument Arg to make sure that it is a valid task 3834 -- dispatching policy name. If not give error and raise Pragma_Exit. 3835 3836 procedure Check_Arg_Order (Names : Name_List); 3837 -- Checks for an instance of two arguments with identifiers for the 3838 -- current pragma which are not in the sequence indicated by Names, 3839 -- and if so, generates a fatal message about bad order of arguments. 3840 3841 procedure Check_At_Least_N_Arguments (N : Nat); 3842 -- Check there are at least N arguments present 3843 3844 procedure Check_At_Most_N_Arguments (N : Nat); 3845 -- Check there are no more than N arguments present 3846 3847 procedure Check_Component 3848 (Comp : Node_Id; 3849 UU_Typ : Entity_Id; 3850 In_Variant_Part : Boolean := False); 3851 -- Examine an Unchecked_Union component for correct use of per-object 3852 -- constrained subtypes, and for restrictions on finalizable components. 3853 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part 3854 -- should be set when Comp comes from a record variant. 3855 3856 procedure Check_Duplicate_Pragma (E : Entity_Id); 3857 -- Check if a rep item of the same name as the current pragma is already 3858 -- chained as a rep pragma to the given entity. If so give a message 3859 -- about the duplicate, and then raise Pragma_Exit so does not return. 3860 -- Note that if E is a type, then this routine avoids flagging a pragma 3861 -- which applies to a parent type from which E is derived. 3862 3863 procedure Check_Duplicated_Export_Name (Nam : Node_Id); 3864 -- Nam is an N_String_Literal node containing the external name set by 3865 -- an Import or Export pragma (or extended Import or Export pragma). 3866 -- This procedure checks for possible duplications if this is the export 3867 -- case, and if found, issues an appropriate error message. 3868 3869 procedure Check_Expr_Is_OK_Static_Expression 3870 (Expr : Node_Id; 3871 Typ : Entity_Id := Empty); 3872 -- Check the specified expression Expr to make sure that it is a static 3873 -- expression of the given type (i.e. it will be analyzed and resolved 3874 -- using this type, which can be any valid argument to Resolve, e.g. 3875 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 3876 -- Typ is left Empty, then any static expression is allowed. Includes 3877 -- checking that the expression does not raise Constraint_Error. 3878 3879 procedure Check_First_Subtype (Arg : Node_Id); 3880 -- Checks that Arg, whose expression is an entity name, references a 3881 -- first subtype. 3882 3883 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id); 3884 -- Checks that the given argument has an identifier, and if so, requires 3885 -- it to match the given identifier name. If there is no identifier, or 3886 -- a non-matching identifier, then an error message is given and 3887 -- Pragma_Exit is raised. 3888 3889 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); 3890 -- Checks that the given argument has an identifier, and if so, requires 3891 -- it to match one of the given identifier names. If there is no 3892 -- identifier, or a non-matching identifier, then an error message is 3893 -- given and Pragma_Exit is raised. 3894 3895 procedure Check_In_Main_Program; 3896 -- Common checks for pragmas that appear within a main program 3897 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). 3898 3899 procedure Check_Interrupt_Or_Attach_Handler; 3900 -- Common processing for first argument of pragma Interrupt_Handler or 3901 -- pragma Attach_Handler. 3902 3903 procedure Check_Loop_Pragma_Placement; 3904 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant 3905 -- appear immediately within a construct restricted to loops, and that 3906 -- pragmas Loop_Invariant and Loop_Variant are grouped together. 3907 3908 procedure Check_Is_In_Decl_Part_Or_Package_Spec; 3909 -- Check that pragma appears in a declarative part, or in a package 3910 -- specification, i.e. that it does not occur in a statement sequence 3911 -- in a body. 3912 3913 procedure Check_No_Identifier (Arg : Node_Id); 3914 -- Checks that the given argument does not have an identifier. If 3915 -- an identifier is present, then an error message is issued, and 3916 -- Pragma_Exit is raised. 3917 3918 procedure Check_No_Identifiers; 3919 -- Checks that none of the arguments to the pragma has an identifier. 3920 -- If any argument has an identifier, then an error message is issued, 3921 -- and Pragma_Exit is raised. 3922 3923 procedure Check_No_Link_Name; 3924 -- Checks that no link name is specified 3925 3926 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 3927 -- Checks if the given argument has an identifier, and if so, requires 3928 -- it to match the given identifier name. If there is a non-matching 3929 -- identifier, then an error message is given and Pragma_Exit is raised. 3930 3931 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); 3932 -- Checks if the given argument has an identifier, and if so, requires 3933 -- it to match the given identifier name. If there is a non-matching 3934 -- identifier, then an error message is given and Pragma_Exit is raised. 3935 -- In this version of the procedure, the identifier name is given as 3936 -- a string with lower case letters. 3937 3938 procedure Check_Static_Boolean_Expression (Expr : Node_Id); 3939 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers, 3940 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes, 3941 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr 3942 -- is an OK static boolean expression. Emit an error if this is not the 3943 -- case. 3944 3945 procedure Check_Static_Constraint (Constr : Node_Id); 3946 -- Constr is a constraint from an N_Subtype_Indication node from a 3947 -- component constraint in an Unchecked_Union type. This routine checks 3948 -- that the constraint is static as required by the restrictions for 3949 -- Unchecked_Union. 3950 3951 procedure Check_Valid_Configuration_Pragma; 3952 -- Legality checks for placement of a configuration pragma 3953 3954 procedure Check_Valid_Library_Unit_Pragma; 3955 -- Legality checks for library unit pragmas. A special case arises for 3956 -- pragmas in generic instances that come from copies of the original 3957 -- library unit pragmas in the generic templates. In the case of other 3958 -- than library level instantiations these can appear in contexts which 3959 -- would normally be invalid (they only apply to the original template 3960 -- and to library level instantiations), and they are simply ignored, 3961 -- which is implemented by rewriting them as null statements. 3962 3963 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); 3964 -- Check an Unchecked_Union variant for lack of nested variants and 3965 -- presence of at least one component. UU_Typ is the related Unchecked_ 3966 -- Union type. 3967 3968 procedure Ensure_Aggregate_Form (Arg : Node_Id); 3969 -- Subsidiary routine to the processing of pragmas Abstract_State, 3970 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends, 3971 -- Refined_Global and Refined_State. Transform argument Arg into 3972 -- an aggregate if not one already. N_Null is never transformed. 3973 -- Arg may denote an aspect specification or a pragma argument 3974 -- association. 3975 3976 procedure Error_Pragma (Msg : String); 3977 pragma No_Return (Error_Pragma); 3978 -- Outputs error message for current pragma. The message contains a % 3979 -- that will be replaced with the pragma name, and the flag is placed 3980 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine 3981 -- calls Fix_Error (see spec of that procedure for details). 3982 3983 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); 3984 pragma No_Return (Error_Pragma_Arg); 3985 -- Outputs error message for current pragma. The message may contain 3986 -- a % that will be replaced with the pragma name. The parameter Arg 3987 -- may either be a pragma argument association, in which case the flag 3988 -- is placed on the expression of this association, or an expression, 3989 -- in which case the flag is placed directly on the expression. The 3990 -- message is placed using Error_Msg_N, so the message may also contain 3991 -- an & insertion character which will reference the given Arg value. 3992 -- After placing the message, Pragma_Exit is raised. Note: this routine 3993 -- calls Fix_Error (see spec of that procedure for details). 3994 3995 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); 3996 pragma No_Return (Error_Pragma_Arg); 3997 -- Similar to above form of Error_Pragma_Arg except that two messages 3998 -- are provided, the second is a continuation comment starting with \. 3999 4000 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); 4001 pragma No_Return (Error_Pragma_Arg_Ident); 4002 -- Outputs error message for current pragma. The message may contain a % 4003 -- that will be replaced with the pragma name. The parameter Arg must be 4004 -- a pragma argument association with a non-empty identifier (i.e. its 4005 -- Chars field must be set), and the error message is placed on the 4006 -- identifier. The message is placed using Error_Msg_N so the message 4007 -- may also contain an & insertion character which will reference 4008 -- the identifier. After placing the message, Pragma_Exit is raised. 4009 -- Note: this routine calls Fix_Error (see spec of that procedure for 4010 -- details). 4011 4012 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); 4013 pragma No_Return (Error_Pragma_Ref); 4014 -- Outputs error message for current pragma. The message may contain 4015 -- a % that will be replaced with the pragma name. The parameter Ref 4016 -- must be an entity whose name can be referenced by & and sloc by #. 4017 -- After placing the message, Pragma_Exit is raised. Note: this routine 4018 -- calls Fix_Error (see spec of that procedure for details). 4019 4020 function Find_Lib_Unit_Name return Entity_Id; 4021 -- Used for a library unit pragma to find the entity to which the 4022 -- library unit pragma applies, returns the entity found. 4023 4024 procedure Find_Program_Unit_Name (Id : Node_Id); 4025 -- If the pragma is a compilation unit pragma, the id must denote the 4026 -- compilation unit in the same compilation, and the pragma must appear 4027 -- in the list of preceding or trailing pragmas. If it is a program 4028 -- unit pragma that is not a compilation unit pragma, then the 4029 -- identifier must be visible. 4030 4031 function Find_Unique_Parameterless_Procedure 4032 (Name : Entity_Id; 4033 Arg : Node_Id) return Entity_Id; 4034 -- Used for a procedure pragma to find the unique parameterless 4035 -- procedure identified by Name, returns it if it exists, otherwise 4036 -- errors out and uses Arg as the pragma argument for the message. 4037 4038 function Fix_Error (Msg : String) return String; 4039 -- This is called prior to issuing an error message. Msg is the normal 4040 -- error message issued in the pragma case. This routine checks for the 4041 -- case of a pragma coming from an aspect in the source, and returns a 4042 -- message suitable for the aspect case as follows: 4043 -- 4044 -- Each substring "pragma" is replaced by "aspect" 4045 -- 4046 -- If "argument of" is at the start of the error message text, it is 4047 -- replaced by "entity for". 4048 -- 4049 -- If "argument" is at the start of the error message text, it is 4050 -- replaced by "entity". 4051 -- 4052 -- So for example, "argument of pragma X must be discrete type" 4053 -- returns "entity for aspect X must be a discrete type". 4054 4055 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may 4056 -- be different from the pragma name). If the current pragma results 4057 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the 4058 -- original pragma name. 4059 4060 procedure Gather_Associations 4061 (Names : Name_List; 4062 Args : out Args_List); 4063 -- This procedure is used to gather the arguments for a pragma that 4064 -- permits arbitrary ordering of parameters using the normal rules 4065 -- for named and positional parameters. The Names argument is a list 4066 -- of Name_Id values that corresponds to the allowed pragma argument 4067 -- association identifiers in order. The result returned in Args is 4068 -- a list of corresponding expressions that are the pragma arguments. 4069 -- Note that this is a list of expressions, not of pragma argument 4070 -- associations (Gather_Associations has completely checked all the 4071 -- optional identifiers when it returns). An entry in Args is Empty 4072 -- on return if the corresponding argument is not present. 4073 4074 procedure GNAT_Pragma; 4075 -- Called for all GNAT defined pragmas to check the relevant restriction 4076 -- (No_Implementation_Pragmas). 4077 4078 function Is_Before_First_Decl 4079 (Pragma_Node : Node_Id; 4080 Decls : List_Id) return Boolean; 4081 -- Return True if Pragma_Node is before the first declarative item in 4082 -- Decls where Decls is the list of declarative items. 4083 4084 function Is_Configuration_Pragma return Boolean; 4085 -- Determines if the placement of the current pragma is appropriate 4086 -- for a configuration pragma. 4087 4088 function Is_In_Context_Clause return Boolean; 4089 -- Returns True if pragma appears within the context clause of a unit, 4090 -- and False for any other placement (does not generate any messages). 4091 4092 function Is_Static_String_Expression (Arg : Node_Id) return Boolean; 4093 -- Analyzes the argument, and determines if it is a static string 4094 -- expression, returns True if so, False if non-static or not String. 4095 -- A special case is that a string literal returns True in Ada 83 mode 4096 -- (which has no such thing as static string expressions). Note that 4097 -- the call analyzes its argument, so this cannot be used for the case 4098 -- where an identifier might not be declared. 4099 4100 procedure Pragma_Misplaced; 4101 pragma No_Return (Pragma_Misplaced); 4102 -- Issue fatal error message for misplaced pragma 4103 4104 procedure Process_Atomic_Independent_Shared_Volatile; 4105 -- Common processing for pragmas Atomic, Independent, Shared, Volatile, 4106 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma 4107 -- and treated as being identical in effect to pragma Atomic. 4108 4109 procedure Process_Compile_Time_Warning_Or_Error; 4110 -- Common processing for Compile_Time_Error and Compile_Time_Warning 4111 4112 procedure Process_Convention 4113 (C : out Convention_Id; 4114 Ent : out Entity_Id); 4115 -- Common processing for Convention, Interface, Import and Export. 4116 -- Checks first two arguments of pragma, and sets the appropriate 4117 -- convention value in the specified entity or entities. On return 4118 -- C is the convention, Ent is the referenced entity. 4119 4120 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); 4121 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is 4122 -- Name_Suppress for Disable and Name_Unsuppress for Enable. 4123 4124 procedure Process_Extended_Import_Export_Object_Pragma 4125 (Arg_Internal : Node_Id; 4126 Arg_External : Node_Id; 4127 Arg_Size : Node_Id); 4128 -- Common processing for the pragmas Import/Export_Object. The three 4129 -- arguments correspond to the three named parameters of the pragmas. An 4130 -- argument is empty if the corresponding parameter is not present in 4131 -- the pragma. 4132 4133 procedure Process_Extended_Import_Export_Internal_Arg 4134 (Arg_Internal : Node_Id := Empty); 4135 -- Common processing for all extended Import and Export pragmas. The 4136 -- argument is the pragma parameter for the Internal argument. If 4137 -- Arg_Internal is empty or inappropriate, an error message is posted. 4138 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is 4139 -- set to identify the referenced entity. 4140 4141 procedure Process_Extended_Import_Export_Subprogram_Pragma 4142 (Arg_Internal : Node_Id; 4143 Arg_External : Node_Id; 4144 Arg_Parameter_Types : Node_Id; 4145 Arg_Result_Type : Node_Id := Empty; 4146 Arg_Mechanism : Node_Id; 4147 Arg_Result_Mechanism : Node_Id := Empty); 4148 -- Common processing for all extended Import and Export pragmas applying 4149 -- to subprograms. The caller omits any arguments that do not apply to 4150 -- the pragma in question (for example, Arg_Result_Type can be non-Empty 4151 -- only in the Import_Function and Export_Function cases). The argument 4152 -- names correspond to the allowed pragma association identifiers. 4153 4154 procedure Process_Generic_List; 4155 -- Common processing for Share_Generic and Inline_Generic 4156 4157 procedure Process_Import_Or_Interface; 4158 -- Common processing for Import or Interface 4159 4160 procedure Process_Import_Predefined_Type; 4161 -- Processing for completing a type with pragma Import. This is used 4162 -- to declare types that match predefined C types, especially for cases 4163 -- without corresponding Ada predefined type. 4164 4165 type Inline_Status is (Suppressed, Disabled, Enabled); 4166 -- Inline status of a subprogram, indicated as follows: 4167 -- Suppressed: inlining is suppressed for the subprogram 4168 -- Disabled: no inlining is requested for the subprogram 4169 -- Enabled: inlining is requested/required for the subprogram 4170 4171 procedure Process_Inline (Status : Inline_Status); 4172 -- Common processing for No_Inline, Inline and Inline_Always. Parameter 4173 -- indicates the inline status specified by the pragma. 4174 4175 procedure Process_Interface_Name 4176 (Subprogram_Def : Entity_Id; 4177 Ext_Arg : Node_Id; 4178 Link_Arg : Node_Id; 4179 Prag : Node_Id); 4180 -- Given the last two arguments of pragma Import, pragma Export, or 4181 -- pragma Interface_Name, performs validity checks and sets the 4182 -- Interface_Name field of the given subprogram entity to the 4183 -- appropriate external or link name, depending on the arguments given. 4184 -- Ext_Arg is always present, but Link_Arg may be missing. Note that 4185 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and 4186 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg 4187 -- nor Link_Arg is present, the interface name is set to the default 4188 -- from the subprogram name. In addition, the pragma itself is passed 4189 -- to analyze any expressions in the case the pragma came from an aspect 4190 -- specification. 4191 4192 procedure Process_Interrupt_Or_Attach_Handler; 4193 -- Common processing for Interrupt and Attach_Handler pragmas 4194 4195 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); 4196 -- Common processing for Restrictions and Restriction_Warnings pragmas. 4197 -- Warn is True for Restriction_Warnings, or for Restrictions if the 4198 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag 4199 -- is not set in the Restrictions case. 4200 4201 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); 4202 -- Common processing for Suppress and Unsuppress. The boolean parameter 4203 -- Suppress_Case is True for the Suppress case, and False for the 4204 -- Unsuppress case. 4205 4206 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id); 4207 -- Subsidiary to the analysis of pragmas Independent[_Components]. 4208 -- Record such a pragma N applied to entity E for future checks. 4209 4210 procedure Set_Exported (E : Entity_Id; Arg : Node_Id); 4211 -- This procedure sets the Is_Exported flag for the given entity, 4212 -- checking that the entity was not previously imported. Arg is 4213 -- the argument that specified the entity. A check is also made 4214 -- for exporting inappropriate entities. 4215 4216 procedure Set_Extended_Import_Export_External_Name 4217 (Internal_Ent : Entity_Id; 4218 Arg_External : Node_Id); 4219 -- Common processing for all extended import export pragmas. The first 4220 -- argument, Internal_Ent, is the internal entity, which has already 4221 -- been checked for validity by the caller. Arg_External is from the 4222 -- Import or Export pragma, and may be null if no External parameter 4223 -- was present. If Arg_External is present and is a non-null string 4224 -- (a null string is treated as the default), then the Interface_Name 4225 -- field of Internal_Ent is set appropriately. 4226 4227 procedure Set_Imported (E : Entity_Id); 4228 -- This procedure sets the Is_Imported flag for the given entity, 4229 -- checking that it is not previously exported or imported. 4230 4231 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); 4232 -- Mech is a parameter passing mechanism (see Import_Function syntax 4233 -- for MECHANISM_NAME). This routine checks that the mechanism argument 4234 -- has the right form, and if not issues an error message. If the 4235 -- argument has the right form then the Mechanism field of Ent is 4236 -- set appropriately. 4237 4238 procedure Set_Rational_Profile; 4239 -- Activate the set of configuration pragmas and permissions that make 4240 -- up the Rational profile. 4241 4242 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id); 4243 -- Activate the set of configuration pragmas and restrictions that make 4244 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar, 4245 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node, 4246 -- which is used for error messages on any constructs violating the 4247 -- profile. 4248 4249 procedure Validate_Acc_Condition_Clause (Clause : Node_Id); 4250 -- Make sure the argument of a given Acc_If clause is a Boolean 4251 4252 procedure Validate_Acc_Data_Clause (Clause : Node_Id); 4253 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin, 4254 -- Copyout...) is an identifier or an aggregate of identifiers. 4255 4256 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id); 4257 -- Make sure the argument of an OpenAcc clause is an Integer expression 4258 4259 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id); 4260 -- Make sure the argument of an OpenAcc clause is an Integer expression 4261 -- or a list of Integer expressions. 4262 4263 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id); 4264 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma 4265 -- contains at least N-1 nested loops. 4266 4267 procedure Validate_Acc_Loop_Gang (Clause : Node_Id); 4268 -- Make sure the argument of the Gang clause of a Loop directive is 4269 -- either an integer expression or a (Static => integer expressions) 4270 -- aggregate. 4271 4272 procedure Validate_Acc_Loop_Vector (Clause : Node_Id); 4273 -- When this procedure is called in a construct offloaded by an 4274 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does 4275 -- not exist on said pragma. In all cases, make sure the argument 4276 -- is an Integer expression. 4277 4278 procedure Validate_Acc_Loop_Worker (Clause : Node_Id); 4279 -- When this procedure is called in a construct offloaded by an 4280 -- Acc_Parallel pragma, makes sure that no argument has been given. 4281 -- When this procedure is called in a construct offloaded by an 4282 -- Acc_Kernels pragma and if Loop_Worker was given an argument, 4283 -- makes sure that the Num_Workers clause does not appear on the 4284 -- Acc_Kernels pragma and that the argument is an integer. 4285 4286 procedure Validate_Acc_Name_Reduction (Clause : Node_Id); 4287 -- Make sure the reduction clause is an aggregate made of a string 4288 -- representing a supported reduction operation (i.e. "+", "*", "and", 4289 -- "or", "min" or "max") and either an identifier or aggregate of 4290 -- identifiers. 4291 4292 procedure Validate_Acc_Size_Expressions (Clause : Node_Id); 4293 -- Makes sure that Clause is either an integer expression or an 4294 -- association with a Static as name and a list of integer expressions 4295 -- or "*" strings on the right hand side. 4296 4297 --------------- 4298 -- Acc_First -- 4299 --------------- 4300 4301 function Acc_First (N : Node_Id) return Node_Id is 4302 begin 4303 if Nkind (N) = N_Aggregate then 4304 if Present (Expressions (N)) then 4305 return First (Expressions (N)); 4306 4307 elsif Present (Component_Associations (N)) then 4308 return Expression (First (Component_Associations (N))); 4309 end if; 4310 end if; 4311 4312 return N; 4313 end Acc_First; 4314 4315 -------------- 4316 -- Acc_Next -- 4317 -------------- 4318 4319 function Acc_Next (N : Node_Id) return Node_Id is 4320 begin 4321 if Nkind (Parent (N)) = N_Component_Association then 4322 return Expression (Next (Parent (N))); 4323 4324 elsif Nkind (Parent (N)) = N_Aggregate then 4325 return Next (N); 4326 4327 else 4328 return Empty; 4329 end if; 4330 end Acc_Next; 4331 4332 ---------------------------------- 4333 -- Acquire_Warning_Match_String -- 4334 ---------------------------------- 4335 4336 procedure Acquire_Warning_Match_String (Arg : Node_Id) is 4337 begin 4338 String_To_Name_Buffer 4339 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); 4340 4341 -- Add asterisk at start if not already there 4342 4343 if Name_Len > 0 and then Name_Buffer (1) /= '*' then 4344 Name_Buffer (2 .. Name_Len + 1) := 4345 Name_Buffer (1 .. Name_Len); 4346 Name_Buffer (1) := '*'; 4347 Name_Len := Name_Len + 1; 4348 end if; 4349 4350 -- Add asterisk at end if not already there 4351 4352 if Name_Buffer (Name_Len) /= '*' then 4353 Name_Len := Name_Len + 1; 4354 Name_Buffer (Name_Len) := '*'; 4355 end if; 4356 end Acquire_Warning_Match_String; 4357 4358 --------------------- 4359 -- Ada_2005_Pragma -- 4360 --------------------- 4361 4362 procedure Ada_2005_Pragma is 4363 begin 4364 if Ada_Version <= Ada_95 then 4365 Check_Restriction (No_Implementation_Pragmas, N); 4366 end if; 4367 end Ada_2005_Pragma; 4368 4369 --------------------- 4370 -- Ada_2012_Pragma -- 4371 --------------------- 4372 4373 procedure Ada_2012_Pragma is 4374 begin 4375 if Ada_Version <= Ada_2005 then 4376 Check_Restriction (No_Implementation_Pragmas, N); 4377 end if; 4378 end Ada_2012_Pragma; 4379 4380 ---------------------------- 4381 -- Analyze_Depends_Global -- 4382 ---------------------------- 4383 4384 procedure Analyze_Depends_Global 4385 (Spec_Id : out Entity_Id; 4386 Subp_Decl : out Node_Id; 4387 Legal : out Boolean) 4388 is 4389 begin 4390 -- Assume that the pragma is illegal 4391 4392 Spec_Id := Empty; 4393 Subp_Decl := Empty; 4394 Legal := False; 4395 4396 GNAT_Pragma; 4397 Check_Arg_Count (1); 4398 4399 -- Ensure the proper placement of the pragma. Depends/Global must be 4400 -- associated with a subprogram declaration or a body that acts as a 4401 -- spec. 4402 4403 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); 4404 4405 -- Entry 4406 4407 if Nkind (Subp_Decl) = N_Entry_Declaration then 4408 null; 4409 4410 -- Generic subprogram 4411 4412 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 4413 null; 4414 4415 -- Object declaration of a single concurrent type 4416 4417 elsif Nkind (Subp_Decl) = N_Object_Declaration 4418 and then Is_Single_Concurrent_Object 4419 (Unique_Defining_Entity (Subp_Decl)) 4420 then 4421 null; 4422 4423 -- Single task type 4424 4425 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then 4426 null; 4427 4428 -- Subprogram body acts as spec 4429 4430 elsif Nkind (Subp_Decl) = N_Subprogram_Body 4431 and then No (Corresponding_Spec (Subp_Decl)) 4432 then 4433 null; 4434 4435 -- Subprogram body stub acts as spec 4436 4437 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4438 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 4439 then 4440 null; 4441 4442 -- Subprogram declaration 4443 4444 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 4445 null; 4446 4447 -- Task type 4448 4449 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then 4450 null; 4451 4452 else 4453 Pragma_Misplaced; 4454 return; 4455 end if; 4456 4457 -- If we get here, then the pragma is legal 4458 4459 Legal := True; 4460 Spec_Id := Unique_Defining_Entity (Subp_Decl); 4461 4462 -- When the related context is an entry, the entry must belong to a 4463 -- protected unit (SPARK RM 6.1.4(6)). 4464 4465 if Is_Entry_Declaration (Spec_Id) 4466 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type 4467 then 4468 Pragma_Misplaced; 4469 return; 4470 4471 -- When the related context is an anonymous object created for a 4472 -- simple concurrent type, the type must be a task 4473 -- (SPARK RM 6.1.4(6)). 4474 4475 elsif Is_Single_Concurrent_Object (Spec_Id) 4476 and then Ekind (Etype (Spec_Id)) /= E_Task_Type 4477 then 4478 Pragma_Misplaced; 4479 return; 4480 end if; 4481 4482 -- A pragma that applies to a Ghost entity becomes Ghost for the 4483 -- purposes of legality checks and removal of ignored Ghost code. 4484 4485 Mark_Ghost_Pragma (N, Spec_Id); 4486 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 4487 end Analyze_Depends_Global; 4488 4489 ------------------------ 4490 -- Analyze_If_Present -- 4491 ------------------------ 4492 4493 procedure Analyze_If_Present (Id : Pragma_Id) is 4494 Stmt : Node_Id; 4495 4496 begin 4497 pragma Assert (Is_List_Member (N)); 4498 4499 -- Inspect the declarations or statements following pragma N looking 4500 -- for another pragma whose Id matches the caller's request. If it is 4501 -- available, analyze it. 4502 4503 Stmt := Next (N); 4504 while Present (Stmt) loop 4505 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then 4506 Analyze_Pragma (Stmt); 4507 exit; 4508 4509 -- The first source declaration or statement immediately following 4510 -- N ends the region where a pragma may appear. 4511 4512 elsif Comes_From_Source (Stmt) then 4513 exit; 4514 end if; 4515 4516 Next (Stmt); 4517 end loop; 4518 end Analyze_If_Present; 4519 4520 -------------------------------- 4521 -- Analyze_Pre_Post_Condition -- 4522 -------------------------------- 4523 4524 procedure Analyze_Pre_Post_Condition is 4525 Prag_Iden : constant Node_Id := Pragma_Identifier (N); 4526 Subp_Decl : Node_Id; 4527 Subp_Id : Entity_Id; 4528 4529 Duplicates_OK : Boolean := False; 4530 -- Flag set when a pre/postcondition allows multiple pragmas of the 4531 -- same kind. 4532 4533 In_Body_OK : Boolean := False; 4534 -- Flag set when a pre/postcondition is allowed to appear on a body 4535 -- even though the subprogram may have a spec. 4536 4537 Is_Pre_Post : Boolean := False; 4538 -- Flag set when the pragma is one of Pre, Pre_Class, Post or 4539 -- Post_Class. 4540 4541 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean; 4542 -- Implement rules in AI12-0131: an overriding operation can have 4543 -- a class-wide precondition only if one of its ancestors has an 4544 -- explicit class-wide precondition. 4545 4546 ----------------------------- 4547 -- Inherits_Class_Wide_Pre -- 4548 ----------------------------- 4549 4550 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is 4551 Typ : constant Entity_Id := Find_Dispatching_Type (E); 4552 Cont : Node_Id; 4553 Prag : Node_Id; 4554 Prev : Entity_Id := Overridden_Operation (E); 4555 4556 begin 4557 -- Check ancestors on the overriding operation to examine the 4558 -- preconditions that may apply to them. 4559 4560 while Present (Prev) loop 4561 Cont := Contract (Prev); 4562 if Present (Cont) then 4563 Prag := Pre_Post_Conditions (Cont); 4564 while Present (Prag) loop 4565 if Pragma_Name (Prag) = Name_Precondition 4566 and then Class_Present (Prag) 4567 then 4568 return True; 4569 end if; 4570 4571 Prag := Next_Pragma (Prag); 4572 end loop; 4573 end if; 4574 4575 -- For a type derived from a generic formal type, the operation 4576 -- inheriting the condition is a renaming, not an overriding of 4577 -- the operation of the formal. Ditto for an inherited 4578 -- operation which has no explicit contracts. 4579 4580 if Is_Generic_Type (Find_Dispatching_Type (Prev)) 4581 or else not Comes_From_Source (Prev) 4582 then 4583 Prev := Alias (Prev); 4584 else 4585 Prev := Overridden_Operation (Prev); 4586 end if; 4587 end loop; 4588 4589 -- If the controlling type of the subprogram has progenitors, an 4590 -- interface operation implemented by the current operation may 4591 -- have a class-wide precondition. 4592 4593 if Has_Interfaces (Typ) then 4594 declare 4595 Elmt : Elmt_Id; 4596 Ints : Elist_Id; 4597 Prim : Entity_Id; 4598 Prim_Elmt : Elmt_Id; 4599 Prim_List : Elist_Id; 4600 4601 begin 4602 Collect_Interfaces (Typ, Ints); 4603 Elmt := First_Elmt (Ints); 4604 4605 -- Iterate over the primitive operations of each interface 4606 4607 while Present (Elmt) loop 4608 Prim_List := Direct_Primitive_Operations (Node (Elmt)); 4609 Prim_Elmt := First_Elmt (Prim_List); 4610 while Present (Prim_Elmt) loop 4611 Prim := Node (Prim_Elmt); 4612 if Chars (Prim) = Chars (E) 4613 and then Present (Contract (Prim)) 4614 and then Class_Present 4615 (Pre_Post_Conditions (Contract (Prim))) 4616 then 4617 return True; 4618 end if; 4619 4620 Next_Elmt (Prim_Elmt); 4621 end loop; 4622 4623 Next_Elmt (Elmt); 4624 end loop; 4625 end; 4626 end if; 4627 4628 return False; 4629 end Inherits_Class_Wide_Pre; 4630 4631 -- Start of processing for Analyze_Pre_Post_Condition 4632 4633 begin 4634 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to 4635 -- offer uniformity among the various kinds of pre/postconditions by 4636 -- rewriting the pragma identifier. This allows the retrieval of the 4637 -- original pragma name by routine Original_Aspect_Pragma_Name. 4638 4639 if Comes_From_Source (N) then 4640 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then 4641 Is_Pre_Post := True; 4642 Set_Class_Present (N, Pname = Name_Pre_Class); 4643 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition)); 4644 4645 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then 4646 Is_Pre_Post := True; 4647 Set_Class_Present (N, Pname = Name_Post_Class); 4648 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition)); 4649 end if; 4650 end if; 4651 4652 -- Determine the semantics with respect to duplicates and placement 4653 -- in a body. Pragmas Precondition and Postcondition were introduced 4654 -- before aspects and are not subject to the same aspect-like rules. 4655 4656 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then 4657 Duplicates_OK := True; 4658 In_Body_OK := True; 4659 end if; 4660 4661 GNAT_Pragma; 4662 4663 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single 4664 -- argument without an identifier. 4665 4666 if Is_Pre_Post then 4667 Check_Arg_Count (1); 4668 Check_No_Identifiers; 4669 4670 -- Pragmas Precondition and Postcondition have complex argument 4671 -- profile. 4672 4673 else 4674 Check_At_Least_N_Arguments (1); 4675 Check_At_Most_N_Arguments (2); 4676 Check_Optional_Identifier (Arg1, Name_Check); 4677 4678 if Present (Arg2) then 4679 Check_Optional_Identifier (Arg2, Name_Message); 4680 Preanalyze_Spec_Expression 4681 (Get_Pragma_Arg (Arg2), Standard_String); 4682 end if; 4683 end if; 4684 4685 -- For a pragma PPC in the extended main source unit, record enabled 4686 -- status in SCO. 4687 -- ??? nothing checks that the pragma is in the main source unit 4688 4689 if Is_Checked (N) and then not Split_PPC (N) then 4690 Set_SCO_Pragma_Enabled (Loc); 4691 end if; 4692 4693 -- Ensure the proper placement of the pragma 4694 4695 Subp_Decl := 4696 Find_Related_Declaration_Or_Body 4697 (N, Do_Checks => not Duplicates_OK); 4698 4699 -- When a pre/postcondition pragma applies to an abstract subprogram, 4700 -- its original form must be an aspect with 'Class. 4701 4702 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 4703 if not From_Aspect_Specification (N) then 4704 Error_Pragma 4705 ("pragma % cannot be applied to abstract subprogram"); 4706 4707 elsif not Class_Present (N) then 4708 Error_Pragma 4709 ("aspect % requires ''Class for abstract subprogram"); 4710 end if; 4711 4712 -- Entry declaration 4713 4714 elsif Nkind (Subp_Decl) = N_Entry_Declaration then 4715 null; 4716 4717 -- Generic subprogram declaration 4718 4719 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 4720 null; 4721 4722 -- Subprogram body 4723 4724 elsif Nkind (Subp_Decl) = N_Subprogram_Body 4725 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK) 4726 then 4727 null; 4728 4729 -- Subprogram body stub 4730 4731 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4732 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK) 4733 then 4734 null; 4735 4736 -- Subprogram declaration 4737 4738 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 4739 4740 -- AI05-0230: When a pre/postcondition pragma applies to a null 4741 -- procedure, its original form must be an aspect with 'Class. 4742 4743 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification 4744 and then Null_Present (Specification (Subp_Decl)) 4745 and then From_Aspect_Specification (N) 4746 and then not Class_Present (N) 4747 then 4748 Error_Pragma ("aspect % requires ''Class for null procedure"); 4749 end if; 4750 4751 -- Implement the legality checks mandated by AI12-0131: 4752 -- Pre'Class shall not be specified for an overriding primitive 4753 -- subprogram of a tagged type T unless the Pre'Class aspect is 4754 -- specified for the corresponding primitive subprogram of some 4755 -- ancestor of T. 4756 4757 declare 4758 E : constant Entity_Id := Defining_Entity (Subp_Decl); 4759 4760 begin 4761 if Class_Present (N) 4762 and then Pragma_Name (N) = Name_Precondition 4763 and then Present (Overridden_Operation (E)) 4764 and then not Inherits_Class_Wide_Pre (E) 4765 then 4766 Error_Msg_N 4767 ("illegal class-wide precondition on overriding operation", 4768 Corresponding_Aspect (N)); 4769 end if; 4770 end; 4771 4772 -- A renaming declaration may inherit a generated pragma, its 4773 -- placement comes from expansion, not from source. 4774 4775 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 4776 and then not Comes_From_Source (N) 4777 then 4778 null; 4779 4780 -- Otherwise the placement is illegal 4781 4782 else 4783 Pragma_Misplaced; 4784 return; 4785 end if; 4786 4787 Subp_Id := Defining_Entity (Subp_Decl); 4788 4789 -- A pragma that applies to a Ghost entity becomes Ghost for the 4790 -- purposes of legality checks and removal of ignored Ghost code. 4791 4792 Mark_Ghost_Pragma (N, Subp_Id); 4793 4794 -- Chain the pragma on the contract for further processing by 4795 -- Analyze_Pre_Post_Condition_In_Decl_Part. 4796 4797 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 4798 4799 -- Fully analyze the pragma when it appears inside an entry or 4800 -- subprogram body because it cannot benefit from forward references. 4801 4802 if Nkind_In (Subp_Decl, N_Entry_Body, 4803 N_Subprogram_Body, 4804 N_Subprogram_Body_Stub) 4805 then 4806 -- The legality checks of pragmas Precondition and Postcondition 4807 -- are affected by the SPARK mode in effect and the volatility of 4808 -- the context. Analyze all pragmas in a specific order. 4809 4810 Analyze_If_Present (Pragma_SPARK_Mode); 4811 Analyze_If_Present (Pragma_Volatile_Function); 4812 Analyze_Pre_Post_Condition_In_Decl_Part (N); 4813 end if; 4814 end Analyze_Pre_Post_Condition; 4815 4816 ----------------------------------------- 4817 -- Analyze_Refined_Depends_Global_Post -- 4818 ----------------------------------------- 4819 4820 procedure Analyze_Refined_Depends_Global_Post 4821 (Spec_Id : out Entity_Id; 4822 Body_Id : out Entity_Id; 4823 Legal : out Boolean) 4824 is 4825 Body_Decl : Node_Id; 4826 Spec_Decl : Node_Id; 4827 4828 begin 4829 -- Assume that the pragma is illegal 4830 4831 Spec_Id := Empty; 4832 Body_Id := Empty; 4833 Legal := False; 4834 4835 GNAT_Pragma; 4836 Check_Arg_Count (1); 4837 Check_No_Identifiers; 4838 4839 -- Verify the placement of the pragma and check for duplicates. The 4840 -- pragma must apply to a subprogram body [stub]. 4841 4842 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); 4843 4844 if not Nkind_In (Body_Decl, N_Entry_Body, 4845 N_Subprogram_Body, 4846 N_Subprogram_Body_Stub, 4847 N_Task_Body, 4848 N_Task_Body_Stub) 4849 then 4850 Pragma_Misplaced; 4851 return; 4852 end if; 4853 4854 Body_Id := Defining_Entity (Body_Decl); 4855 Spec_Id := Unique_Defining_Entity (Body_Decl); 4856 4857 -- The pragma must apply to the second declaration of a subprogram. 4858 -- In other words, the body [stub] cannot acts as a spec. 4859 4860 if No (Spec_Id) then 4861 Error_Pragma ("pragma % cannot apply to a stand alone body"); 4862 return; 4863 4864 -- Catch the case where the subprogram body is a subunit and acts as 4865 -- the third declaration of the subprogram. 4866 4867 elsif Nkind (Parent (Body_Decl)) = N_Subunit then 4868 Error_Pragma ("pragma % cannot apply to a subunit"); 4869 return; 4870 end if; 4871 4872 -- A refined pragma can only apply to the body [stub] of a subprogram 4873 -- declared in the visible part of a package. Retrieve the context of 4874 -- the subprogram declaration. 4875 4876 Spec_Decl := Unit_Declaration_Node (Spec_Id); 4877 4878 -- When dealing with protected entries or protected subprograms, use 4879 -- the enclosing protected type as the proper context. 4880 4881 if Ekind_In (Spec_Id, E_Entry, 4882 E_Entry_Family, 4883 E_Function, 4884 E_Procedure) 4885 and then Ekind (Scope (Spec_Id)) = E_Protected_Type 4886 then 4887 Spec_Decl := Declaration_Node (Scope (Spec_Id)); 4888 end if; 4889 4890 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then 4891 Error_Pragma 4892 (Fix_Msg (Spec_Id, "pragma % must apply to the body of " 4893 & "subprogram declared in a package specification")); 4894 return; 4895 end if; 4896 4897 -- If we get here, then the pragma is legal 4898 4899 Legal := True; 4900 4901 -- A pragma that applies to a Ghost entity becomes Ghost for the 4902 -- purposes of legality checks and removal of ignored Ghost code. 4903 4904 Mark_Ghost_Pragma (N, Spec_Id); 4905 4906 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then 4907 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 4908 end if; 4909 end Analyze_Refined_Depends_Global_Post; 4910 4911 ---------------------------------- 4912 -- Analyze_Unmodified_Or_Unused -- 4913 ---------------------------------- 4914 4915 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is 4916 Arg : Node_Id; 4917 Arg_Expr : Node_Id; 4918 Arg_Id : Entity_Id; 4919 4920 Ghost_Error_Posted : Boolean := False; 4921 -- Flag set when an error concerning the illegal mix of Ghost and 4922 -- non-Ghost variables is emitted. 4923 4924 Ghost_Id : Entity_Id := Empty; 4925 -- The entity of the first Ghost variable encountered while 4926 -- processing the arguments of the pragma. 4927 4928 begin 4929 GNAT_Pragma; 4930 Check_At_Least_N_Arguments (1); 4931 4932 -- Loop through arguments 4933 4934 Arg := Arg1; 4935 while Present (Arg) loop 4936 Check_No_Identifier (Arg); 4937 4938 -- Note: the analyze call done by Check_Arg_Is_Local_Name will 4939 -- in fact generate reference, so that the entity will have a 4940 -- reference, which will inhibit any warnings about it not 4941 -- being referenced, and also properly show up in the ali file 4942 -- as a reference. But this reference is recorded before the 4943 -- Has_Pragma_Unreferenced flag is set, so that no warning is 4944 -- generated for this reference. 4945 4946 Check_Arg_Is_Local_Name (Arg); 4947 Arg_Expr := Get_Pragma_Arg (Arg); 4948 4949 if Is_Entity_Name (Arg_Expr) then 4950 Arg_Id := Entity (Arg_Expr); 4951 4952 -- Skip processing the argument if already flagged 4953 4954 if Is_Assignable (Arg_Id) 4955 and then not Has_Pragma_Unmodified (Arg_Id) 4956 and then not Has_Pragma_Unused (Arg_Id) 4957 then 4958 Set_Has_Pragma_Unmodified (Arg_Id); 4959 4960 if Is_Unused then 4961 Set_Has_Pragma_Unused (Arg_Id); 4962 end if; 4963 4964 -- A pragma that applies to a Ghost entity becomes Ghost for 4965 -- the purposes of legality checks and removal of ignored 4966 -- Ghost code. 4967 4968 Mark_Ghost_Pragma (N, Arg_Id); 4969 4970 -- Capture the entity of the first Ghost variable being 4971 -- processed for error detection purposes. 4972 4973 if Is_Ghost_Entity (Arg_Id) then 4974 if No (Ghost_Id) then 4975 Ghost_Id := Arg_Id; 4976 end if; 4977 4978 -- Otherwise the variable is non-Ghost. It is illegal to mix 4979 -- references to Ghost and non-Ghost entities 4980 -- (SPARK RM 6.9). 4981 4982 elsif Present (Ghost_Id) 4983 and then not Ghost_Error_Posted 4984 then 4985 Ghost_Error_Posted := True; 4986 4987 Error_Msg_Name_1 := Pname; 4988 Error_Msg_N 4989 ("pragma % cannot mention ghost and non-ghost " 4990 & "variables", N); 4991 4992 Error_Msg_Sloc := Sloc (Ghost_Id); 4993 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 4994 4995 Error_Msg_Sloc := Sloc (Arg_Id); 4996 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id); 4997 end if; 4998 4999 -- Warn if already flagged as Unused or Unmodified 5000 5001 elsif Has_Pragma_Unmodified (Arg_Id) then 5002 if Has_Pragma_Unused (Arg_Id) then 5003 Error_Msg_NE 5004 ("??pragma Unused already given for &!", Arg_Expr, 5005 Arg_Id); 5006 else 5007 Error_Msg_NE 5008 ("??pragma Unmodified already given for &!", Arg_Expr, 5009 Arg_Id); 5010 end if; 5011 5012 -- Otherwise the pragma referenced an illegal entity 5013 5014 else 5015 Error_Pragma_Arg 5016 ("pragma% can only be applied to a variable", Arg_Expr); 5017 end if; 5018 end if; 5019 5020 Next (Arg); 5021 end loop; 5022 end Analyze_Unmodified_Or_Unused; 5023 5024 ------------------------------------ 5025 -- Analyze_Unreferenced_Or_Unused -- 5026 ------------------------------------ 5027 5028 procedure Analyze_Unreferenced_Or_Unused 5029 (Is_Unused : Boolean := False) 5030 is 5031 Arg : Node_Id; 5032 Arg_Expr : Node_Id; 5033 Arg_Id : Entity_Id; 5034 Citem : Node_Id; 5035 5036 Ghost_Error_Posted : Boolean := False; 5037 -- Flag set when an error concerning the illegal mix of Ghost and 5038 -- non-Ghost names is emitted. 5039 5040 Ghost_Id : Entity_Id := Empty; 5041 -- The entity of the first Ghost name encountered while processing 5042 -- the arguments of the pragma. 5043 5044 begin 5045 GNAT_Pragma; 5046 Check_At_Least_N_Arguments (1); 5047 5048 -- Check case of appearing within context clause 5049 5050 if not Is_Unused and then Is_In_Context_Clause then 5051 5052 -- The arguments must all be units mentioned in a with clause in 5053 -- the same context clause. Note that Par.Prag already checked 5054 -- that the arguments are either identifiers or selected 5055 -- components. 5056 5057 Arg := Arg1; 5058 while Present (Arg) loop 5059 Citem := First (List_Containing (N)); 5060 while Citem /= N loop 5061 Arg_Expr := Get_Pragma_Arg (Arg); 5062 5063 if Nkind (Citem) = N_With_Clause 5064 and then Same_Name (Name (Citem), Arg_Expr) 5065 then 5066 Set_Has_Pragma_Unreferenced 5067 (Cunit_Entity 5068 (Get_Source_Unit 5069 (Library_Unit (Citem)))); 5070 Set_Elab_Unit_Name (Arg_Expr, Name (Citem)); 5071 exit; 5072 end if; 5073 5074 Next (Citem); 5075 end loop; 5076 5077 if Citem = N then 5078 Error_Pragma_Arg 5079 ("argument of pragma% is not withed unit", Arg); 5080 end if; 5081 5082 Next (Arg); 5083 end loop; 5084 5085 -- Case of not in list of context items 5086 5087 else 5088 Arg := Arg1; 5089 while Present (Arg) loop 5090 Check_No_Identifier (Arg); 5091 5092 -- Note: the analyze call done by Check_Arg_Is_Local_Name will 5093 -- in fact generate reference, so that the entity will have a 5094 -- reference, which will inhibit any warnings about it not 5095 -- being referenced, and also properly show up in the ali file 5096 -- as a reference. But this reference is recorded before the 5097 -- Has_Pragma_Unreferenced flag is set, so that no warning is 5098 -- generated for this reference. 5099 5100 Check_Arg_Is_Local_Name (Arg); 5101 Arg_Expr := Get_Pragma_Arg (Arg); 5102 5103 if Is_Entity_Name (Arg_Expr) then 5104 Arg_Id := Entity (Arg_Expr); 5105 5106 -- Warn if already flagged as Unused or Unreferenced and 5107 -- skip processing the argument. 5108 5109 if Has_Pragma_Unreferenced (Arg_Id) then 5110 if Has_Pragma_Unused (Arg_Id) then 5111 Error_Msg_NE 5112 ("??pragma Unused already given for &!", Arg_Expr, 5113 Arg_Id); 5114 else 5115 Error_Msg_NE 5116 ("??pragma Unreferenced already given for &!", 5117 Arg_Expr, Arg_Id); 5118 end if; 5119 5120 -- Apply Unreferenced to the entity 5121 5122 else 5123 -- If the entity is overloaded, the pragma applies to the 5124 -- most recent overloading, as documented. In this case, 5125 -- name resolution does not generate a reference, so it 5126 -- must be done here explicitly. 5127 5128 if Is_Overloaded (Arg_Expr) then 5129 Generate_Reference (Arg_Id, N); 5130 end if; 5131 5132 Set_Has_Pragma_Unreferenced (Arg_Id); 5133 5134 if Is_Unused then 5135 Set_Has_Pragma_Unused (Arg_Id); 5136 end if; 5137 5138 -- A pragma that applies to a Ghost entity becomes Ghost 5139 -- for the purposes of legality checks and removal of 5140 -- ignored Ghost code. 5141 5142 Mark_Ghost_Pragma (N, Arg_Id); 5143 5144 -- Capture the entity of the first Ghost name being 5145 -- processed for error detection purposes. 5146 5147 if Is_Ghost_Entity (Arg_Id) then 5148 if No (Ghost_Id) then 5149 Ghost_Id := Arg_Id; 5150 end if; 5151 5152 -- Otherwise the name is non-Ghost. It is illegal to mix 5153 -- references to Ghost and non-Ghost entities 5154 -- (SPARK RM 6.9). 5155 5156 elsif Present (Ghost_Id) 5157 and then not Ghost_Error_Posted 5158 then 5159 Ghost_Error_Posted := True; 5160 5161 Error_Msg_Name_1 := Pname; 5162 Error_Msg_N 5163 ("pragma % cannot mention ghost and non-ghost " 5164 & "names", N); 5165 5166 Error_Msg_Sloc := Sloc (Ghost_Id); 5167 Error_Msg_NE 5168 ("\& # declared as ghost", N, Ghost_Id); 5169 5170 Error_Msg_Sloc := Sloc (Arg_Id); 5171 Error_Msg_NE 5172 ("\& # declared as non-ghost", N, Arg_Id); 5173 end if; 5174 end if; 5175 end if; 5176 5177 Next (Arg); 5178 end loop; 5179 end if; 5180 end Analyze_Unreferenced_Or_Unused; 5181 5182 -------------------------- 5183 -- Check_Ada_83_Warning -- 5184 -------------------------- 5185 5186 procedure Check_Ada_83_Warning is 5187 begin 5188 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 5189 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N); 5190 end if; 5191 end Check_Ada_83_Warning; 5192 5193 --------------------- 5194 -- Check_Arg_Count -- 5195 --------------------- 5196 5197 procedure Check_Arg_Count (Required : Nat) is 5198 begin 5199 if Arg_Count /= Required then 5200 Error_Pragma ("wrong number of arguments for pragma%"); 5201 end if; 5202 end Check_Arg_Count; 5203 5204 -------------------------------- 5205 -- Check_Arg_Is_External_Name -- 5206 -------------------------------- 5207 5208 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is 5209 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5210 5211 begin 5212 if Nkind (Argx) = N_Identifier then 5213 return; 5214 5215 else 5216 Analyze_And_Resolve (Argx, Standard_String); 5217 5218 if Is_OK_Static_Expression (Argx) then 5219 return; 5220 5221 elsif Etype (Argx) = Any_Type then 5222 raise Pragma_Exit; 5223 5224 -- An interesting special case, if we have a string literal and 5225 -- we are in Ada 83 mode, then we allow it even though it will 5226 -- not be flagged as static. This allows expected Ada 83 mode 5227 -- use of external names which are string literals, even though 5228 -- technically these are not static in Ada 83. 5229 5230 elsif Ada_Version = Ada_83 5231 and then Nkind (Argx) = N_String_Literal 5232 then 5233 return; 5234 5235 -- Here we have a real error (non-static expression) 5236 5237 else 5238 Error_Msg_Name_1 := Pname; 5239 Flag_Non_Static_Expr 5240 (Fix_Error ("argument for pragma% must be a identifier or " 5241 & "static string expression!"), Argx); 5242 5243 raise Pragma_Exit; 5244 end if; 5245 end if; 5246 end Check_Arg_Is_External_Name; 5247 5248 ----------------------------- 5249 -- Check_Arg_Is_Identifier -- 5250 ----------------------------- 5251 5252 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is 5253 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5254 begin 5255 if Nkind (Argx) /= N_Identifier then 5256 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx); 5257 end if; 5258 end Check_Arg_Is_Identifier; 5259 5260 ---------------------------------- 5261 -- Check_Arg_Is_Integer_Literal -- 5262 ---------------------------------- 5263 5264 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is 5265 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5266 begin 5267 if Nkind (Argx) /= N_Integer_Literal then 5268 Error_Pragma_Arg 5269 ("argument for pragma% must be integer literal", Argx); 5270 end if; 5271 end Check_Arg_Is_Integer_Literal; 5272 5273 ------------------------------------------- 5274 -- Check_Arg_Is_Library_Level_Local_Name -- 5275 ------------------------------------------- 5276 5277 -- LOCAL_NAME ::= 5278 -- DIRECT_NAME 5279 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 5280 -- | library_unit_NAME 5281 5282 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is 5283 begin 5284 Check_Arg_Is_Local_Name (Arg); 5285 5286 -- If it came from an aspect, we want to give the error just as if it 5287 -- came from source. 5288 5289 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) 5290 and then (Comes_From_Source (N) 5291 or else Present (Corresponding_Aspect (Parent (Arg)))) 5292 then 5293 Error_Pragma_Arg 5294 ("argument for pragma% must be library level entity", Arg); 5295 end if; 5296 end Check_Arg_Is_Library_Level_Local_Name; 5297 5298 ----------------------------- 5299 -- Check_Arg_Is_Local_Name -- 5300 ----------------------------- 5301 5302 -- LOCAL_NAME ::= 5303 -- DIRECT_NAME 5304 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 5305 -- | library_unit_NAME 5306 5307 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is 5308 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5309 5310 begin 5311 -- If this pragma came from an aspect specification, we don't want to 5312 -- check for this error, because that would cause spurious errors, in 5313 -- case a type is frozen in a scope more nested than the type. The 5314 -- aspect itself of course can't be anywhere but on the declaration 5315 -- itself. 5316 5317 if Nkind (Arg) = N_Pragma_Argument_Association then 5318 if From_Aspect_Specification (Parent (Arg)) then 5319 return; 5320 end if; 5321 5322 -- Arg is the Expression of an N_Pragma_Argument_Association 5323 5324 else 5325 if From_Aspect_Specification (Parent (Parent (Arg))) then 5326 return; 5327 end if; 5328 end if; 5329 5330 Analyze (Argx); 5331 5332 if Nkind (Argx) not in N_Direct_Name 5333 and then (Nkind (Argx) /= N_Attribute_Reference 5334 or else Present (Expressions (Argx)) 5335 or else Nkind (Prefix (Argx)) /= N_Identifier) 5336 and then (not Is_Entity_Name (Argx) 5337 or else not Is_Compilation_Unit (Entity (Argx))) 5338 then 5339 Error_Pragma_Arg ("argument for pragma% must be local name", Argx); 5340 end if; 5341 5342 -- No further check required if not an entity name 5343 5344 if not Is_Entity_Name (Argx) then 5345 null; 5346 5347 else 5348 declare 5349 OK : Boolean; 5350 Ent : constant Entity_Id := Entity (Argx); 5351 Scop : constant Entity_Id := Scope (Ent); 5352 5353 begin 5354 -- Case of a pragma applied to a compilation unit: pragma must 5355 -- occur immediately after the program unit in the compilation. 5356 5357 if Is_Compilation_Unit (Ent) then 5358 declare 5359 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 5360 5361 begin 5362 -- Case of pragma placed immediately after spec 5363 5364 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then 5365 OK := True; 5366 5367 -- Case of pragma placed immediately after body 5368 5369 elsif Nkind (Decl) = N_Subprogram_Declaration 5370 and then Present (Corresponding_Body (Decl)) 5371 then 5372 OK := Parent (N) = 5373 Aux_Decls_Node 5374 (Parent (Unit_Declaration_Node 5375 (Corresponding_Body (Decl)))); 5376 5377 -- All other cases are illegal 5378 5379 else 5380 OK := False; 5381 end if; 5382 end; 5383 5384 -- Special restricted placement rule from 10.2.1(11.8/2) 5385 5386 elsif Is_Generic_Formal (Ent) 5387 and then Prag_Id = Pragma_Preelaborable_Initialization 5388 then 5389 OK := List_Containing (N) = 5390 Generic_Formal_Declarations 5391 (Unit_Declaration_Node (Scop)); 5392 5393 -- If this is an aspect applied to a subprogram body, the 5394 -- pragma is inserted in its declarative part. 5395 5396 elsif From_Aspect_Specification (N) 5397 and then Ent = Current_Scope 5398 and then 5399 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body 5400 then 5401 OK := True; 5402 5403 -- If the aspect is a predicate (possibly others ???) and the 5404 -- context is a record type, this is a discriminant expression 5405 -- within a type declaration, that freezes the predicated 5406 -- subtype. 5407 5408 elsif From_Aspect_Specification (N) 5409 and then Prag_Id = Pragma_Predicate 5410 and then Ekind (Current_Scope) = E_Record_Type 5411 and then Scop = Scope (Current_Scope) 5412 then 5413 OK := True; 5414 5415 -- Default case, just check that the pragma occurs in the scope 5416 -- of the entity denoted by the name. 5417 5418 else 5419 OK := Current_Scope = Scop; 5420 end if; 5421 5422 if not OK then 5423 Error_Pragma_Arg 5424 ("pragma% argument must be in same declarative part", Arg); 5425 end if; 5426 end; 5427 end if; 5428 end Check_Arg_Is_Local_Name; 5429 5430 --------------------------------- 5431 -- Check_Arg_Is_Locking_Policy -- 5432 --------------------------------- 5433 5434 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is 5435 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5436 5437 begin 5438 Check_Arg_Is_Identifier (Argx); 5439 5440 if not Is_Locking_Policy_Name (Chars (Argx)) then 5441 Error_Pragma_Arg ("& is not a valid locking policy name", Argx); 5442 end if; 5443 end Check_Arg_Is_Locking_Policy; 5444 5445 ----------------------------------------------- 5446 -- Check_Arg_Is_Partition_Elaboration_Policy -- 5447 ----------------------------------------------- 5448 5449 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is 5450 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5451 5452 begin 5453 Check_Arg_Is_Identifier (Argx); 5454 5455 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then 5456 Error_Pragma_Arg 5457 ("& is not a valid partition elaboration policy name", Argx); 5458 end if; 5459 end Check_Arg_Is_Partition_Elaboration_Policy; 5460 5461 ------------------------- 5462 -- Check_Arg_Is_One_Of -- 5463 ------------------------- 5464 5465 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 5466 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5467 5468 begin 5469 Check_Arg_Is_Identifier (Argx); 5470 5471 if not Nam_In (Chars (Argx), N1, N2) then 5472 Error_Msg_Name_2 := N1; 5473 Error_Msg_Name_3 := N2; 5474 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); 5475 end if; 5476 end Check_Arg_Is_One_Of; 5477 5478 procedure Check_Arg_Is_One_Of 5479 (Arg : Node_Id; 5480 N1, N2, N3 : Name_Id) 5481 is 5482 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5483 5484 begin 5485 Check_Arg_Is_Identifier (Argx); 5486 5487 if not Nam_In (Chars (Argx), N1, N2, N3) then 5488 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 5489 end if; 5490 end Check_Arg_Is_One_Of; 5491 5492 procedure Check_Arg_Is_One_Of 5493 (Arg : Node_Id; 5494 N1, N2, N3, N4 : Name_Id) 5495 is 5496 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5497 5498 begin 5499 Check_Arg_Is_Identifier (Argx); 5500 5501 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then 5502 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 5503 end if; 5504 end Check_Arg_Is_One_Of; 5505 5506 procedure Check_Arg_Is_One_Of 5507 (Arg : Node_Id; 5508 N1, N2, N3, N4, N5 : Name_Id) 5509 is 5510 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5511 5512 begin 5513 Check_Arg_Is_Identifier (Argx); 5514 5515 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then 5516 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 5517 end if; 5518 end Check_Arg_Is_One_Of; 5519 5520 --------------------------------- 5521 -- Check_Arg_Is_Queuing_Policy -- 5522 --------------------------------- 5523 5524 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is 5525 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5526 5527 begin 5528 Check_Arg_Is_Identifier (Argx); 5529 5530 if not Is_Queuing_Policy_Name (Chars (Argx)) then 5531 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); 5532 end if; 5533 end Check_Arg_Is_Queuing_Policy; 5534 5535 --------------------------------------- 5536 -- Check_Arg_Is_OK_Static_Expression -- 5537 --------------------------------------- 5538 5539 procedure Check_Arg_Is_OK_Static_Expression 5540 (Arg : Node_Id; 5541 Typ : Entity_Id := Empty) 5542 is 5543 begin 5544 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ); 5545 end Check_Arg_Is_OK_Static_Expression; 5546 5547 ------------------------------------------ 5548 -- Check_Arg_Is_Task_Dispatching_Policy -- 5549 ------------------------------------------ 5550 5551 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is 5552 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5553 5554 begin 5555 Check_Arg_Is_Identifier (Argx); 5556 5557 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then 5558 Error_Pragma_Arg 5559 ("& is not an allowed task dispatching policy name", Argx); 5560 end if; 5561 end Check_Arg_Is_Task_Dispatching_Policy; 5562 5563 --------------------- 5564 -- Check_Arg_Order -- 5565 --------------------- 5566 5567 procedure Check_Arg_Order (Names : Name_List) is 5568 Arg : Node_Id; 5569 5570 Highest_So_Far : Natural := 0; 5571 -- Highest index in Names seen do far 5572 5573 begin 5574 Arg := Arg1; 5575 for J in 1 .. Arg_Count loop 5576 if Chars (Arg) /= No_Name then 5577 for K in Names'Range loop 5578 if Chars (Arg) = Names (K) then 5579 if K < Highest_So_Far then 5580 Error_Msg_Name_1 := Pname; 5581 Error_Msg_N 5582 ("parameters out of order for pragma%", Arg); 5583 Error_Msg_Name_1 := Names (K); 5584 Error_Msg_Name_2 := Names (Highest_So_Far); 5585 Error_Msg_N ("\% must appear before %", Arg); 5586 raise Pragma_Exit; 5587 5588 else 5589 Highest_So_Far := K; 5590 end if; 5591 end if; 5592 end loop; 5593 end if; 5594 5595 Arg := Next (Arg); 5596 end loop; 5597 end Check_Arg_Order; 5598 5599 -------------------------------- 5600 -- Check_At_Least_N_Arguments -- 5601 -------------------------------- 5602 5603 procedure Check_At_Least_N_Arguments (N : Nat) is 5604 begin 5605 if Arg_Count < N then 5606 Error_Pragma ("too few arguments for pragma%"); 5607 end if; 5608 end Check_At_Least_N_Arguments; 5609 5610 ------------------------------- 5611 -- Check_At_Most_N_Arguments -- 5612 ------------------------------- 5613 5614 procedure Check_At_Most_N_Arguments (N : Nat) is 5615 Arg : Node_Id; 5616 begin 5617 if Arg_Count > N then 5618 Arg := Arg1; 5619 for J in 1 .. N loop 5620 Next (Arg); 5621 Error_Pragma_Arg ("too many arguments for pragma%", Arg); 5622 end loop; 5623 end if; 5624 end Check_At_Most_N_Arguments; 5625 5626 --------------------- 5627 -- Check_Component -- 5628 --------------------- 5629 5630 procedure Check_Component 5631 (Comp : Node_Id; 5632 UU_Typ : Entity_Id; 5633 In_Variant_Part : Boolean := False) 5634 is 5635 Comp_Id : constant Entity_Id := Defining_Identifier (Comp); 5636 Sindic : constant Node_Id := 5637 Subtype_Indication (Component_Definition (Comp)); 5638 Typ : constant Entity_Id := Etype (Comp_Id); 5639 5640 begin 5641 -- Ada 2005 (AI-216): If a component subtype is subject to a per- 5642 -- object constraint, then the component type shall be an Unchecked_ 5643 -- Union. 5644 5645 if Nkind (Sindic) = N_Subtype_Indication 5646 and then Has_Per_Object_Constraint (Comp_Id) 5647 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) 5648 then 5649 Error_Msg_N 5650 ("component subtype subject to per-object constraint " 5651 & "must be an Unchecked_Union", Comp); 5652 5653 -- Ada 2012 (AI05-0026): For an unchecked union type declared within 5654 -- the body of a generic unit, or within the body of any of its 5655 -- descendant library units, no part of the type of a component 5656 -- declared in a variant_part of the unchecked union type shall be of 5657 -- a formal private type or formal private extension declared within 5658 -- the formal part of the generic unit. 5659 5660 elsif Ada_Version >= Ada_2012 5661 and then In_Generic_Body (UU_Typ) 5662 and then In_Variant_Part 5663 and then Is_Private_Type (Typ) 5664 and then Is_Generic_Type (Typ) 5665 then 5666 Error_Msg_N 5667 ("component of unchecked union cannot be of generic type", Comp); 5668 5669 elsif Needs_Finalization (Typ) then 5670 Error_Msg_N 5671 ("component of unchecked union cannot be controlled", Comp); 5672 5673 elsif Has_Task (Typ) then 5674 Error_Msg_N 5675 ("component of unchecked union cannot have tasks", Comp); 5676 end if; 5677 end Check_Component; 5678 5679 ---------------------------- 5680 -- Check_Duplicate_Pragma -- 5681 ---------------------------- 5682 5683 procedure Check_Duplicate_Pragma (E : Entity_Id) is 5684 Id : Entity_Id := E; 5685 P : Node_Id; 5686 5687 begin 5688 -- Nothing to do if this pragma comes from an aspect specification, 5689 -- since we could not be duplicating a pragma, and we dealt with the 5690 -- case of duplicated aspects in Analyze_Aspect_Specifications. 5691 5692 if From_Aspect_Specification (N) then 5693 return; 5694 end if; 5695 5696 -- Otherwise current pragma may duplicate previous pragma or a 5697 -- previously given aspect specification or attribute definition 5698 -- clause for the same pragma. 5699 5700 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False); 5701 5702 if Present (P) then 5703 5704 -- If the entity is a type, then we have to make sure that the 5705 -- ostensible duplicate is not for a parent type from which this 5706 -- type is derived. 5707 5708 if Is_Type (E) then 5709 if Nkind (P) = N_Pragma then 5710 declare 5711 Args : constant List_Id := 5712 Pragma_Argument_Associations (P); 5713 begin 5714 if Present (Args) 5715 and then Is_Entity_Name (Expression (First (Args))) 5716 and then Is_Type (Entity (Expression (First (Args)))) 5717 and then Entity (Expression (First (Args))) /= E 5718 then 5719 return; 5720 end if; 5721 end; 5722 5723 elsif Nkind (P) = N_Aspect_Specification 5724 and then Is_Type (Entity (P)) 5725 and then Entity (P) /= E 5726 then 5727 return; 5728 end if; 5729 end if; 5730 5731 -- Here we have a definite duplicate 5732 5733 Error_Msg_Name_1 := Pragma_Name (N); 5734 Error_Msg_Sloc := Sloc (P); 5735 5736 -- For a single protected or a single task object, the error is 5737 -- issued on the original entity. 5738 5739 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then 5740 Id := Defining_Identifier (Original_Node (Parent (Id))); 5741 end if; 5742 5743 if Nkind (P) = N_Aspect_Specification 5744 or else From_Aspect_Specification (P) 5745 then 5746 Error_Msg_NE ("aspect% for & previously given#", N, Id); 5747 else 5748 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); 5749 end if; 5750 5751 raise Pragma_Exit; 5752 end if; 5753 end Check_Duplicate_Pragma; 5754 5755 ---------------------------------- 5756 -- Check_Duplicated_Export_Name -- 5757 ---------------------------------- 5758 5759 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is 5760 String_Val : constant String_Id := Strval (Nam); 5761 5762 begin 5763 -- We are only interested in the export case, and in the case of 5764 -- generics, it is the instance, not the template, that is the 5765 -- problem (the template will generate a warning in any case). 5766 5767 if not Inside_A_Generic 5768 and then (Prag_Id = Pragma_Export 5769 or else 5770 Prag_Id = Pragma_Export_Procedure 5771 or else 5772 Prag_Id = Pragma_Export_Valued_Procedure 5773 or else 5774 Prag_Id = Pragma_Export_Function) 5775 then 5776 for J in Externals.First .. Externals.Last loop 5777 if String_Equal (String_Val, Strval (Externals.Table (J))) then 5778 Error_Msg_Sloc := Sloc (Externals.Table (J)); 5779 Error_Msg_N ("external name duplicates name given#", Nam); 5780 exit; 5781 end if; 5782 end loop; 5783 5784 Externals.Append (Nam); 5785 end if; 5786 end Check_Duplicated_Export_Name; 5787 5788 ---------------------------------------- 5789 -- Check_Expr_Is_OK_Static_Expression -- 5790 ---------------------------------------- 5791 5792 procedure Check_Expr_Is_OK_Static_Expression 5793 (Expr : Node_Id; 5794 Typ : Entity_Id := Empty) 5795 is 5796 begin 5797 if Present (Typ) then 5798 Analyze_And_Resolve (Expr, Typ); 5799 else 5800 Analyze_And_Resolve (Expr); 5801 end if; 5802 5803 -- An expression cannot be considered static if its resolution failed 5804 -- or if it's erroneous. Stop the analysis of the related pragma. 5805 5806 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then 5807 raise Pragma_Exit; 5808 5809 elsif Is_OK_Static_Expression (Expr) then 5810 return; 5811 5812 -- An interesting special case, if we have a string literal and we 5813 -- are in Ada 83 mode, then we allow it even though it will not be 5814 -- flagged as static. This allows the use of Ada 95 pragmas like 5815 -- Import in Ada 83 mode. They will of course be flagged with 5816 -- warnings as usual, but will not cause errors. 5817 5818 elsif Ada_Version = Ada_83 5819 and then Nkind (Expr) = N_String_Literal 5820 then 5821 return; 5822 5823 -- Finally, we have a real error 5824 5825 else 5826 Error_Msg_Name_1 := Pname; 5827 Flag_Non_Static_Expr 5828 (Fix_Error ("argument for pragma% must be a static expression!"), 5829 Expr); 5830 raise Pragma_Exit; 5831 end if; 5832 end Check_Expr_Is_OK_Static_Expression; 5833 5834 ------------------------- 5835 -- Check_First_Subtype -- 5836 ------------------------- 5837 5838 procedure Check_First_Subtype (Arg : Node_Id) is 5839 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5840 Ent : constant Entity_Id := Entity (Argx); 5841 5842 begin 5843 if Is_First_Subtype (Ent) then 5844 null; 5845 5846 elsif Is_Type (Ent) then 5847 Error_Pragma_Arg 5848 ("pragma% cannot apply to subtype", Argx); 5849 5850 elsif Is_Object (Ent) then 5851 Error_Pragma_Arg 5852 ("pragma% cannot apply to object, requires a type", Argx); 5853 5854 else 5855 Error_Pragma_Arg 5856 ("pragma% cannot apply to&, requires a type", Argx); 5857 end if; 5858 end Check_First_Subtype; 5859 5860 ---------------------- 5861 -- Check_Identifier -- 5862 ---------------------- 5863 5864 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is 5865 begin 5866 if Present (Arg) 5867 and then Nkind (Arg) = N_Pragma_Argument_Association 5868 then 5869 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then 5870 Error_Msg_Name_1 := Pname; 5871 Error_Msg_Name_2 := Id; 5872 Error_Msg_N ("pragma% argument expects identifier%", Arg); 5873 raise Pragma_Exit; 5874 end if; 5875 end if; 5876 end Check_Identifier; 5877 5878 -------------------------------- 5879 -- Check_Identifier_Is_One_Of -- 5880 -------------------------------- 5881 5882 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 5883 begin 5884 if Present (Arg) 5885 and then Nkind (Arg) = N_Pragma_Argument_Association 5886 then 5887 if Chars (Arg) = No_Name then 5888 Error_Msg_Name_1 := Pname; 5889 Error_Msg_N ("pragma% argument expects an identifier", Arg); 5890 raise Pragma_Exit; 5891 5892 elsif Chars (Arg) /= N1 5893 and then Chars (Arg) /= N2 5894 then 5895 Error_Msg_Name_1 := Pname; 5896 Error_Msg_N ("invalid identifier for pragma% argument", Arg); 5897 raise Pragma_Exit; 5898 end if; 5899 end if; 5900 end Check_Identifier_Is_One_Of; 5901 5902 --------------------------- 5903 -- Check_In_Main_Program -- 5904 --------------------------- 5905 5906 procedure Check_In_Main_Program is 5907 P : constant Node_Id := Parent (N); 5908 5909 begin 5910 -- Must be in subprogram body 5911 5912 if Nkind (P) /= N_Subprogram_Body then 5913 Error_Pragma ("% pragma allowed only in subprogram"); 5914 5915 -- Otherwise warn if obviously not main program 5916 5917 elsif Present (Parameter_Specifications (Specification (P))) 5918 or else not Is_Compilation_Unit (Defining_Entity (P)) 5919 then 5920 Error_Msg_Name_1 := Pname; 5921 Error_Msg_N 5922 ("??pragma% is only effective in main program", N); 5923 end if; 5924 end Check_In_Main_Program; 5925 5926 --------------------------------------- 5927 -- Check_Interrupt_Or_Attach_Handler -- 5928 --------------------------------------- 5929 5930 procedure Check_Interrupt_Or_Attach_Handler is 5931 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); 5932 Handler_Proc, Proc_Scope : Entity_Id; 5933 5934 begin 5935 Analyze (Arg1_X); 5936 5937 if Prag_Id = Pragma_Interrupt_Handler then 5938 Check_Restriction (No_Dynamic_Attachment, N); 5939 end if; 5940 5941 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 5942 Proc_Scope := Scope (Handler_Proc); 5943 5944 if Ekind (Proc_Scope) /= E_Protected_Type then 5945 Error_Pragma_Arg 5946 ("argument of pragma% must be protected procedure", Arg1); 5947 end if; 5948 5949 -- For pragma case (as opposed to access case), check placement. 5950 -- We don't need to do that for aspects, because we have the 5951 -- check that they aspect applies an appropriate procedure. 5952 5953 if not From_Aspect_Specification (N) 5954 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope)) 5955 then 5956 Error_Pragma ("pragma% must be in protected definition"); 5957 end if; 5958 5959 if not Is_Library_Level_Entity (Proc_Scope) then 5960 Error_Pragma_Arg 5961 ("argument for pragma% must be library level entity", Arg1); 5962 end if; 5963 5964 -- AI05-0033: A pragma cannot appear within a generic body, because 5965 -- instance can be in a nested scope. The check that protected type 5966 -- is itself a library-level declaration is done elsewhere. 5967 5968 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly 5969 -- handle code prior to AI-0033. Analysis tools typically are not 5970 -- interested in this pragma in any case, so no need to worry too 5971 -- much about its placement. 5972 5973 if Inside_A_Generic then 5974 if Ekind (Scope (Current_Scope)) = E_Generic_Package 5975 and then In_Package_Body (Scope (Current_Scope)) 5976 and then not Relaxed_RM_Semantics 5977 then 5978 Error_Pragma ("pragma% cannot be used inside a generic"); 5979 end if; 5980 end if; 5981 end Check_Interrupt_Or_Attach_Handler; 5982 5983 --------------------------------- 5984 -- Check_Loop_Pragma_Placement -- 5985 --------------------------------- 5986 5987 procedure Check_Loop_Pragma_Placement is 5988 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id); 5989 -- Verify whether the current pragma is properly grouped with other 5990 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the 5991 -- related loop where the pragma appears. 5992 5993 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean; 5994 -- Determine whether an arbitrary statement Stmt denotes pragma 5995 -- Loop_Invariant or Loop_Variant. 5996 5997 procedure Placement_Error (Constr : Node_Id); 5998 pragma No_Return (Placement_Error); 5999 -- Node Constr denotes the last loop restricted construct before we 6000 -- encountered an illegal relation between enclosing constructs. Emit 6001 -- an error depending on what Constr was. 6002 6003 -------------------------------- 6004 -- Check_Loop_Pragma_Grouping -- 6005 -------------------------------- 6006 6007 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is 6008 Stop_Search : exception; 6009 -- This exception is used to terminate the recursive descent of 6010 -- routine Check_Grouping. 6011 6012 procedure Check_Grouping (L : List_Id); 6013 -- Find the first group of pragmas in list L and if successful, 6014 -- ensure that the current pragma is part of that group. The 6015 -- routine raises Stop_Search once such a check is performed to 6016 -- halt the recursive descent. 6017 6018 procedure Grouping_Error (Prag : Node_Id); 6019 pragma No_Return (Grouping_Error); 6020 -- Emit an error concerning the current pragma indicating that it 6021 -- should be placed after pragma Prag. 6022 6023 -------------------- 6024 -- Check_Grouping -- 6025 -------------------- 6026 6027 procedure Check_Grouping (L : List_Id) is 6028 HSS : Node_Id; 6029 Stmt : Node_Id; 6030 Prag : Node_Id := Empty; -- init to avoid warning 6031 6032 begin 6033 -- Inspect the list of declarations or statements looking for 6034 -- the first grouping of pragmas: 6035 6036 -- loop 6037 -- pragma Loop_Invariant ...; 6038 -- pragma Loop_Variant ...; 6039 -- . . . -- (1) 6040 -- pragma Loop_Variant ...; -- current pragma 6041 6042 -- If the current pragma is not in the grouping, then it must 6043 -- either appear in a different declarative or statement list 6044 -- or the construct at (1) is separating the pragma from the 6045 -- grouping. 6046 6047 Stmt := First (L); 6048 while Present (Stmt) loop 6049 6050 -- First pragma of the first topmost grouping has been found 6051 6052 if Is_Loop_Pragma (Stmt) then 6053 6054 -- The group and the current pragma are not in the same 6055 -- declarative or statement list. 6056 6057 if List_Containing (Stmt) /= List_Containing (N) then 6058 Grouping_Error (Stmt); 6059 6060 -- Try to reach the current pragma from the first pragma 6061 -- of the grouping while skipping other members: 6062 6063 -- pragma Loop_Invariant ...; -- first pragma 6064 -- pragma Loop_Variant ...; -- member 6065 -- . . . 6066 -- pragma Loop_Variant ...; -- current pragma 6067 6068 else 6069 while Present (Stmt) loop 6070 -- The current pragma is either the first pragma 6071 -- of the group or is a member of the group. 6072 -- Stop the search as the placement is legal. 6073 6074 if Stmt = N then 6075 raise Stop_Search; 6076 6077 -- Skip group members, but keep track of the 6078 -- last pragma in the group. 6079 6080 elsif Is_Loop_Pragma (Stmt) then 6081 Prag := Stmt; 6082 6083 -- Skip declarations and statements generated by 6084 -- the compiler during expansion. Note that some 6085 -- source statements (e.g. pragma Assert) may have 6086 -- been transformed so that they do not appear as 6087 -- coming from source anymore, so we instead look 6088 -- at their Original_Node. 6089 6090 elsif not Comes_From_Source (Original_Node (Stmt)) 6091 then 6092 null; 6093 6094 -- A non-pragma is separating the group from the 6095 -- current pragma, the placement is illegal. 6096 6097 else 6098 Grouping_Error (Prag); 6099 end if; 6100 6101 Next (Stmt); 6102 end loop; 6103 6104 -- If the traversal did not reach the current pragma, 6105 -- then the list must be malformed. 6106 6107 raise Program_Error; 6108 end if; 6109 6110 -- Pragmas Loop_Invariant and Loop_Variant may only appear 6111 -- inside a loop or a block housed inside a loop. Inspect 6112 -- the declarations and statements of the block as they may 6113 -- contain the first grouping. This case follows the one for 6114 -- loop pragmas, as block statements which originate in a 6115 -- loop pragma (and so Is_Loop_Pragma will return True on 6116 -- that block statement) should be treated in the previous 6117 -- case. 6118 6119 elsif Nkind (Stmt) = N_Block_Statement then 6120 HSS := Handled_Statement_Sequence (Stmt); 6121 6122 Check_Grouping (Declarations (Stmt)); 6123 6124 if Present (HSS) then 6125 Check_Grouping (Statements (HSS)); 6126 end if; 6127 end if; 6128 6129 Next (Stmt); 6130 end loop; 6131 end Check_Grouping; 6132 6133 -------------------- 6134 -- Grouping_Error -- 6135 -------------------- 6136 6137 procedure Grouping_Error (Prag : Node_Id) is 6138 begin 6139 Error_Msg_Sloc := Sloc (Prag); 6140 Error_Pragma ("pragma% must appear next to pragma#"); 6141 end Grouping_Error; 6142 6143 -- Start of processing for Check_Loop_Pragma_Grouping 6144 6145 begin 6146 -- Inspect the statements of the loop or nested blocks housed 6147 -- within to determine whether the current pragma is part of the 6148 -- first topmost grouping of Loop_Invariant and Loop_Variant. 6149 6150 Check_Grouping (Statements (Loop_Stmt)); 6151 6152 exception 6153 when Stop_Search => null; 6154 end Check_Loop_Pragma_Grouping; 6155 6156 -------------------- 6157 -- Is_Loop_Pragma -- 6158 -------------------- 6159 6160 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is 6161 begin 6162 -- Inspect the original node as Loop_Invariant and Loop_Variant 6163 -- pragmas are rewritten to null when assertions are disabled. 6164 6165 if Nkind (Original_Node (Stmt)) = N_Pragma then 6166 return 6167 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)), 6168 Name_Loop_Invariant, 6169 Name_Loop_Variant); 6170 else 6171 return False; 6172 end if; 6173 end Is_Loop_Pragma; 6174 6175 --------------------- 6176 -- Placement_Error -- 6177 --------------------- 6178 6179 procedure Placement_Error (Constr : Node_Id) is 6180 LA : constant String := " with Loop_Entry"; 6181 6182 begin 6183 if Prag_Id = Pragma_Assert then 6184 Error_Msg_String (1 .. LA'Length) := LA; 6185 Error_Msg_Strlen := LA'Length; 6186 else 6187 Error_Msg_Strlen := 0; 6188 end if; 6189 6190 if Nkind (Constr) = N_Pragma then 6191 Error_Pragma 6192 ("pragma %~ must appear immediately within the statements " 6193 & "of a loop"); 6194 else 6195 Error_Pragma_Arg 6196 ("block containing pragma %~ must appear immediately within " 6197 & "the statements of a loop", Constr); 6198 end if; 6199 end Placement_Error; 6200 6201 -- Local declarations 6202 6203 Prev : Node_Id; 6204 Stmt : Node_Id; 6205 6206 -- Start of processing for Check_Loop_Pragma_Placement 6207 6208 begin 6209 -- Check that pragma appears immediately within a loop statement, 6210 -- ignoring intervening block statements. 6211 6212 Prev := N; 6213 Stmt := Parent (N); 6214 while Present (Stmt) loop 6215 6216 -- The pragma or previous block must appear immediately within the 6217 -- current block's declarative or statement part. 6218 6219 if Nkind (Stmt) = N_Block_Statement then 6220 if (No (Declarations (Stmt)) 6221 or else List_Containing (Prev) /= Declarations (Stmt)) 6222 and then 6223 List_Containing (Prev) /= 6224 Statements (Handled_Statement_Sequence (Stmt)) 6225 then 6226 Placement_Error (Prev); 6227 return; 6228 6229 -- Keep inspecting the parents because we are now within a 6230 -- chain of nested blocks. 6231 6232 else 6233 Prev := Stmt; 6234 Stmt := Parent (Stmt); 6235 end if; 6236 6237 -- The pragma or previous block must appear immediately within the 6238 -- statements of the loop. 6239 6240 elsif Nkind (Stmt) = N_Loop_Statement then 6241 if List_Containing (Prev) /= Statements (Stmt) then 6242 Placement_Error (Prev); 6243 end if; 6244 6245 -- Stop the traversal because we reached the innermost loop 6246 -- regardless of whether we encountered an error or not. 6247 6248 exit; 6249 6250 -- Ignore a handled statement sequence. Note that this node may 6251 -- be related to a subprogram body in which case we will emit an 6252 -- error on the next iteration of the search. 6253 6254 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then 6255 Stmt := Parent (Stmt); 6256 6257 -- Any other statement breaks the chain from the pragma to the 6258 -- loop. 6259 6260 else 6261 Placement_Error (Prev); 6262 return; 6263 end if; 6264 end loop; 6265 6266 -- Check that the current pragma Loop_Invariant or Loop_Variant is 6267 -- grouped together with other such pragmas. 6268 6269 if Is_Loop_Pragma (N) then 6270 6271 -- The previous check should have located the related loop 6272 6273 pragma Assert (Nkind (Stmt) = N_Loop_Statement); 6274 Check_Loop_Pragma_Grouping (Stmt); 6275 end if; 6276 end Check_Loop_Pragma_Placement; 6277 6278 ------------------------------------------- 6279 -- Check_Is_In_Decl_Part_Or_Package_Spec -- 6280 ------------------------------------------- 6281 6282 procedure Check_Is_In_Decl_Part_Or_Package_Spec is 6283 P : Node_Id; 6284 6285 begin 6286 P := Parent (N); 6287 loop 6288 if No (P) then 6289 exit; 6290 6291 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then 6292 exit; 6293 6294 elsif Nkind_In (P, N_Package_Specification, 6295 N_Block_Statement) 6296 then 6297 return; 6298 6299 -- Note: the following tests seem a little peculiar, because 6300 -- they test for bodies, but if we were in the statement part 6301 -- of the body, we would already have hit the handled statement 6302 -- sequence, so the only way we get here is by being in the 6303 -- declarative part of the body. 6304 6305 elsif Nkind_In (P, N_Subprogram_Body, 6306 N_Package_Body, 6307 N_Task_Body, 6308 N_Entry_Body) 6309 then 6310 return; 6311 end if; 6312 6313 P := Parent (P); 6314 end loop; 6315 6316 Error_Pragma ("pragma% is not in declarative part or package spec"); 6317 end Check_Is_In_Decl_Part_Or_Package_Spec; 6318 6319 ------------------------- 6320 -- Check_No_Identifier -- 6321 ------------------------- 6322 6323 procedure Check_No_Identifier (Arg : Node_Id) is 6324 begin 6325 if Nkind (Arg) = N_Pragma_Argument_Association 6326 and then Chars (Arg) /= No_Name 6327 then 6328 Error_Pragma_Arg_Ident 6329 ("pragma% does not permit identifier& here", Arg); 6330 end if; 6331 end Check_No_Identifier; 6332 6333 -------------------------- 6334 -- Check_No_Identifiers -- 6335 -------------------------- 6336 6337 procedure Check_No_Identifiers is 6338 Arg_Node : Node_Id; 6339 begin 6340 Arg_Node := Arg1; 6341 for J in 1 .. Arg_Count loop 6342 Check_No_Identifier (Arg_Node); 6343 Next (Arg_Node); 6344 end loop; 6345 end Check_No_Identifiers; 6346 6347 ------------------------ 6348 -- Check_No_Link_Name -- 6349 ------------------------ 6350 6351 procedure Check_No_Link_Name is 6352 begin 6353 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then 6354 Arg4 := Arg3; 6355 end if; 6356 6357 if Present (Arg4) then 6358 Error_Pragma_Arg 6359 ("Link_Name argument not allowed for Import Intrinsic", Arg4); 6360 end if; 6361 end Check_No_Link_Name; 6362 6363 ------------------------------- 6364 -- Check_Optional_Identifier -- 6365 ------------------------------- 6366 6367 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 6368 begin 6369 if Present (Arg) 6370 and then Nkind (Arg) = N_Pragma_Argument_Association 6371 and then Chars (Arg) /= No_Name 6372 then 6373 if Chars (Arg) /= Id then 6374 Error_Msg_Name_1 := Pname; 6375 Error_Msg_Name_2 := Id; 6376 Error_Msg_N ("pragma% argument expects identifier%", Arg); 6377 raise Pragma_Exit; 6378 end if; 6379 end if; 6380 end Check_Optional_Identifier; 6381 6382 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is 6383 begin 6384 Check_Optional_Identifier (Arg, Name_Find (Id)); 6385 end Check_Optional_Identifier; 6386 6387 ------------------------------------- 6388 -- Check_Static_Boolean_Expression -- 6389 ------------------------------------- 6390 6391 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is 6392 begin 6393 if Present (Expr) then 6394 Analyze_And_Resolve (Expr, Standard_Boolean); 6395 6396 if not Is_OK_Static_Expression (Expr) then 6397 Error_Pragma_Arg 6398 ("expression of pragma % must be static", Expr); 6399 end if; 6400 end if; 6401 end Check_Static_Boolean_Expression; 6402 6403 ----------------------------- 6404 -- Check_Static_Constraint -- 6405 ----------------------------- 6406 6407 -- Note: for convenience in writing this procedure, in addition to 6408 -- the officially (i.e. by spec) allowed argument which is always a 6409 -- constraint, it also allows ranges and discriminant associations. 6410 -- Above is not clear ??? 6411 6412 procedure Check_Static_Constraint (Constr : Node_Id) is 6413 6414 procedure Require_Static (E : Node_Id); 6415 -- Require given expression to be static expression 6416 6417 -------------------- 6418 -- Require_Static -- 6419 -------------------- 6420 6421 procedure Require_Static (E : Node_Id) is 6422 begin 6423 if not Is_OK_Static_Expression (E) then 6424 Flag_Non_Static_Expr 6425 ("non-static constraint not allowed in Unchecked_Union!", E); 6426 raise Pragma_Exit; 6427 end if; 6428 end Require_Static; 6429 6430 -- Start of processing for Check_Static_Constraint 6431 6432 begin 6433 case Nkind (Constr) is 6434 when N_Discriminant_Association => 6435 Require_Static (Expression (Constr)); 6436 6437 when N_Range => 6438 Require_Static (Low_Bound (Constr)); 6439 Require_Static (High_Bound (Constr)); 6440 6441 when N_Attribute_Reference => 6442 Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); 6443 Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); 6444 6445 when N_Range_Constraint => 6446 Check_Static_Constraint (Range_Expression (Constr)); 6447 6448 when N_Index_Or_Discriminant_Constraint => 6449 declare 6450 IDC : Entity_Id; 6451 begin 6452 IDC := First (Constraints (Constr)); 6453 while Present (IDC) loop 6454 Check_Static_Constraint (IDC); 6455 Next (IDC); 6456 end loop; 6457 end; 6458 6459 when others => 6460 null; 6461 end case; 6462 end Check_Static_Constraint; 6463 6464 -------------------------------------- 6465 -- Check_Valid_Configuration_Pragma -- 6466 -------------------------------------- 6467 6468 -- A configuration pragma must appear in the context clause of a 6469 -- compilation unit, and only other pragmas may precede it. Note that 6470 -- the test also allows use in a configuration pragma file. 6471 6472 procedure Check_Valid_Configuration_Pragma is 6473 begin 6474 if not Is_Configuration_Pragma then 6475 Error_Pragma ("incorrect placement for configuration pragma%"); 6476 end if; 6477 end Check_Valid_Configuration_Pragma; 6478 6479 ------------------------------------- 6480 -- Check_Valid_Library_Unit_Pragma -- 6481 ------------------------------------- 6482 6483 procedure Check_Valid_Library_Unit_Pragma is 6484 Plist : List_Id; 6485 Parent_Node : Node_Id; 6486 Unit_Name : Entity_Id; 6487 Unit_Kind : Node_Kind; 6488 Unit_Node : Node_Id; 6489 Sindex : Source_File_Index; 6490 6491 begin 6492 if not Is_List_Member (N) then 6493 Pragma_Misplaced; 6494 6495 else 6496 Plist := List_Containing (N); 6497 Parent_Node := Parent (Plist); 6498 6499 if Parent_Node = Empty then 6500 Pragma_Misplaced; 6501 6502 -- Case of pragma appearing after a compilation unit. In this case 6503 -- it must have an argument with the corresponding name and must 6504 -- be part of the following pragmas of its parent. 6505 6506 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then 6507 if Plist /= Pragmas_After (Parent_Node) then 6508 Pragma_Misplaced; 6509 6510 elsif Arg_Count = 0 then 6511 Error_Pragma 6512 ("argument required if outside compilation unit"); 6513 6514 else 6515 Check_No_Identifiers; 6516 Check_Arg_Count (1); 6517 Unit_Node := Unit (Parent (Parent_Node)); 6518 Unit_Kind := Nkind (Unit_Node); 6519 6520 Analyze (Get_Pragma_Arg (Arg1)); 6521 6522 if Unit_Kind = N_Generic_Subprogram_Declaration 6523 or else Unit_Kind = N_Subprogram_Declaration 6524 then 6525 Unit_Name := Defining_Entity (Unit_Node); 6526 6527 elsif Unit_Kind in N_Generic_Instantiation then 6528 Unit_Name := Defining_Entity (Unit_Node); 6529 6530 else 6531 Unit_Name := Cunit_Entity (Current_Sem_Unit); 6532 end if; 6533 6534 if Chars (Unit_Name) /= 6535 Chars (Entity (Get_Pragma_Arg (Arg1))) 6536 then 6537 Error_Pragma_Arg 6538 ("pragma% argument is not current unit name", Arg1); 6539 end if; 6540 6541 if Ekind (Unit_Name) = E_Package 6542 and then Present (Renamed_Entity (Unit_Name)) 6543 then 6544 Error_Pragma ("pragma% not allowed for renamed package"); 6545 end if; 6546 end if; 6547 6548 -- Pragma appears other than after a compilation unit 6549 6550 else 6551 -- Here we check for the generic instantiation case and also 6552 -- for the case of processing a generic formal package. We 6553 -- detect these cases by noting that the Sloc on the node 6554 -- does not belong to the current compilation unit. 6555 6556 Sindex := Source_Index (Current_Sem_Unit); 6557 6558 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then 6559 Rewrite (N, Make_Null_Statement (Loc)); 6560 return; 6561 6562 -- If before first declaration, the pragma applies to the 6563 -- enclosing unit, and the name if present must be this name. 6564 6565 elsif Is_Before_First_Decl (N, Plist) then 6566 Unit_Node := Unit_Declaration_Node (Current_Scope); 6567 Unit_Kind := Nkind (Unit_Node); 6568 6569 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then 6570 Pragma_Misplaced; 6571 6572 elsif Unit_Kind = N_Subprogram_Body 6573 and then not Acts_As_Spec (Unit_Node) 6574 then 6575 Pragma_Misplaced; 6576 6577 elsif Nkind (Parent_Node) = N_Package_Body then 6578 Pragma_Misplaced; 6579 6580 elsif Nkind (Parent_Node) = N_Package_Specification 6581 and then Plist = Private_Declarations (Parent_Node) 6582 then 6583 Pragma_Misplaced; 6584 6585 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration 6586 or else Nkind (Parent_Node) = 6587 N_Generic_Subprogram_Declaration) 6588 and then Plist = Generic_Formal_Declarations (Parent_Node) 6589 then 6590 Pragma_Misplaced; 6591 6592 elsif Arg_Count > 0 then 6593 Analyze (Get_Pragma_Arg (Arg1)); 6594 6595 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then 6596 Error_Pragma_Arg 6597 ("name in pragma% must be enclosing unit", Arg1); 6598 end if; 6599 6600 -- It is legal to have no argument in this context 6601 6602 else 6603 return; 6604 end if; 6605 6606 -- Error if not before first declaration. This is because a 6607 -- library unit pragma argument must be the name of a library 6608 -- unit (RM 10.1.5(7)), but the only names permitted in this 6609 -- context are (RM 10.1.5(6)) names of subprogram declarations, 6610 -- generic subprogram declarations or generic instantiations. 6611 6612 else 6613 Error_Pragma 6614 ("pragma% misplaced, must be before first declaration"); 6615 end if; 6616 end if; 6617 end if; 6618 end Check_Valid_Library_Unit_Pragma; 6619 6620 ------------------- 6621 -- Check_Variant -- 6622 ------------------- 6623 6624 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is 6625 Clist : constant Node_Id := Component_List (Variant); 6626 Comp : Node_Id; 6627 6628 begin 6629 Comp := First_Non_Pragma (Component_Items (Clist)); 6630 while Present (Comp) loop 6631 Check_Component (Comp, UU_Typ, In_Variant_Part => True); 6632 Next_Non_Pragma (Comp); 6633 end loop; 6634 end Check_Variant; 6635 6636 --------------------------- 6637 -- Ensure_Aggregate_Form -- 6638 --------------------------- 6639 6640 procedure Ensure_Aggregate_Form (Arg : Node_Id) is 6641 CFSD : constant Boolean := Get_Comes_From_Source_Default; 6642 Expr : constant Node_Id := Expression (Arg); 6643 Loc : constant Source_Ptr := Sloc (Expr); 6644 Comps : List_Id := No_List; 6645 Exprs : List_Id := No_List; 6646 Nam : Name_Id := No_Name; 6647 Nam_Loc : Source_Ptr; 6648 6649 begin 6650 -- The pragma argument is in positional form: 6651 6652 -- pragma Depends (Nam => ...) 6653 -- ^ 6654 -- Chars field 6655 6656 -- Note that the Sloc of the Chars field is the Sloc of the pragma 6657 -- argument association. 6658 6659 if Nkind (Arg) = N_Pragma_Argument_Association then 6660 Nam := Chars (Arg); 6661 Nam_Loc := Sloc (Arg); 6662 6663 -- Remove the pragma argument name as this will be captured in the 6664 -- aggregate. 6665 6666 Set_Chars (Arg, No_Name); 6667 end if; 6668 6669 -- The argument is already in aggregate form, but the presence of a 6670 -- name causes this to be interpreted as named association which in 6671 -- turn must be converted into an aggregate. 6672 6673 -- pragma Global (In_Out => (A, B, C)) 6674 -- ^ ^ 6675 -- name aggregate 6676 6677 -- pragma Global ((In_Out => (A, B, C))) 6678 -- ^ ^ 6679 -- aggregate aggregate 6680 6681 if Nkind (Expr) = N_Aggregate then 6682 if Nam = No_Name then 6683 return; 6684 end if; 6685 6686 -- Do not transform a null argument into an aggregate as N_Null has 6687 -- special meaning in formal verification pragmas. 6688 6689 elsif Nkind (Expr) = N_Null then 6690 return; 6691 end if; 6692 6693 -- Everything comes from source if the original comes from source 6694 6695 Set_Comes_From_Source_Default (Comes_From_Source (Arg)); 6696 6697 -- Positional argument is transformed into an aggregate with an 6698 -- Expressions list. 6699 6700 if Nam = No_Name then 6701 Exprs := New_List (Relocate_Node (Expr)); 6702 6703 -- An associative argument is transformed into an aggregate with 6704 -- Component_Associations. 6705 6706 else 6707 Comps := New_List ( 6708 Make_Component_Association (Loc, 6709 Choices => New_List (Make_Identifier (Nam_Loc, Nam)), 6710 Expression => Relocate_Node (Expr))); 6711 end if; 6712 6713 Set_Expression (Arg, 6714 Make_Aggregate (Loc, 6715 Component_Associations => Comps, 6716 Expressions => Exprs)); 6717 6718 -- Restore Comes_From_Source default 6719 6720 Set_Comes_From_Source_Default (CFSD); 6721 end Ensure_Aggregate_Form; 6722 6723 ------------------ 6724 -- Error_Pragma -- 6725 ------------------ 6726 6727 procedure Error_Pragma (Msg : String) is 6728 begin 6729 Error_Msg_Name_1 := Pname; 6730 Error_Msg_N (Fix_Error (Msg), N); 6731 raise Pragma_Exit; 6732 end Error_Pragma; 6733 6734 ---------------------- 6735 -- Error_Pragma_Arg -- 6736 ---------------------- 6737 6738 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is 6739 begin 6740 Error_Msg_Name_1 := Pname; 6741 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg)); 6742 raise Pragma_Exit; 6743 end Error_Pragma_Arg; 6744 6745 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is 6746 begin 6747 Error_Msg_Name_1 := Pname; 6748 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg)); 6749 Error_Pragma_Arg (Msg2, Arg); 6750 end Error_Pragma_Arg; 6751 6752 ---------------------------- 6753 -- Error_Pragma_Arg_Ident -- 6754 ---------------------------- 6755 6756 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is 6757 begin 6758 Error_Msg_Name_1 := Pname; 6759 Error_Msg_N (Fix_Error (Msg), Arg); 6760 raise Pragma_Exit; 6761 end Error_Pragma_Arg_Ident; 6762 6763 ---------------------- 6764 -- Error_Pragma_Ref -- 6765 ---------------------- 6766 6767 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is 6768 begin 6769 Error_Msg_Name_1 := Pname; 6770 Error_Msg_Sloc := Sloc (Ref); 6771 Error_Msg_NE (Fix_Error (Msg), N, Ref); 6772 raise Pragma_Exit; 6773 end Error_Pragma_Ref; 6774 6775 ------------------------ 6776 -- Find_Lib_Unit_Name -- 6777 ------------------------ 6778 6779 function Find_Lib_Unit_Name return Entity_Id is 6780 begin 6781 -- Return inner compilation unit entity, for case of nested 6782 -- categorization pragmas. This happens in generic unit. 6783 6784 if Nkind (Parent (N)) = N_Package_Specification 6785 and then Defining_Entity (Parent (N)) /= Current_Scope 6786 then 6787 return Defining_Entity (Parent (N)); 6788 else 6789 return Current_Scope; 6790 end if; 6791 end Find_Lib_Unit_Name; 6792 6793 ---------------------------- 6794 -- Find_Program_Unit_Name -- 6795 ---------------------------- 6796 6797 procedure Find_Program_Unit_Name (Id : Node_Id) is 6798 Unit_Name : Entity_Id; 6799 Unit_Kind : Node_Kind; 6800 P : constant Node_Id := Parent (N); 6801 6802 begin 6803 if Nkind (P) = N_Compilation_Unit then 6804 Unit_Kind := Nkind (Unit (P)); 6805 6806 if Nkind_In (Unit_Kind, N_Subprogram_Declaration, 6807 N_Package_Declaration) 6808 or else Unit_Kind in N_Generic_Declaration 6809 then 6810 Unit_Name := Defining_Entity (Unit (P)); 6811 6812 if Chars (Id) = Chars (Unit_Name) then 6813 Set_Entity (Id, Unit_Name); 6814 Set_Etype (Id, Etype (Unit_Name)); 6815 else 6816 Set_Etype (Id, Any_Type); 6817 Error_Pragma 6818 ("cannot find program unit referenced by pragma%"); 6819 end if; 6820 6821 else 6822 Set_Etype (Id, Any_Type); 6823 Error_Pragma ("pragma% inapplicable to this unit"); 6824 end if; 6825 6826 else 6827 Analyze (Id); 6828 end if; 6829 end Find_Program_Unit_Name; 6830 6831 ----------------------------------------- 6832 -- Find_Unique_Parameterless_Procedure -- 6833 ----------------------------------------- 6834 6835 function Find_Unique_Parameterless_Procedure 6836 (Name : Entity_Id; 6837 Arg : Node_Id) return Entity_Id 6838 is 6839 Proc : Entity_Id := Empty; 6840 6841 begin 6842 -- The body of this procedure needs some comments ??? 6843 6844 if not Is_Entity_Name (Name) then 6845 Error_Pragma_Arg 6846 ("argument of pragma% must be entity name", Arg); 6847 6848 elsif not Is_Overloaded (Name) then 6849 Proc := Entity (Name); 6850 6851 if Ekind (Proc) /= E_Procedure 6852 or else Present (First_Formal (Proc)) 6853 then 6854 Error_Pragma_Arg 6855 ("argument of pragma% must be parameterless procedure", Arg); 6856 end if; 6857 6858 else 6859 declare 6860 Found : Boolean := False; 6861 It : Interp; 6862 Index : Interp_Index; 6863 6864 begin 6865 Get_First_Interp (Name, Index, It); 6866 while Present (It.Nam) loop 6867 Proc := It.Nam; 6868 6869 if Ekind (Proc) = E_Procedure 6870 and then No (First_Formal (Proc)) 6871 then 6872 if not Found then 6873 Found := True; 6874 Set_Entity (Name, Proc); 6875 Set_Is_Overloaded (Name, False); 6876 else 6877 Error_Pragma_Arg 6878 ("ambiguous handler name for pragma% ", Arg); 6879 end if; 6880 end if; 6881 6882 Get_Next_Interp (Index, It); 6883 end loop; 6884 6885 if not Found then 6886 Error_Pragma_Arg 6887 ("argument of pragma% must be parameterless procedure", 6888 Arg); 6889 else 6890 Proc := Entity (Name); 6891 end if; 6892 end; 6893 end if; 6894 6895 return Proc; 6896 end Find_Unique_Parameterless_Procedure; 6897 6898 --------------- 6899 -- Fix_Error -- 6900 --------------- 6901 6902 function Fix_Error (Msg : String) return String is 6903 Res : String (Msg'Range) := Msg; 6904 Res_Last : Natural := Msg'Last; 6905 J : Natural; 6906 6907 begin 6908 -- If we have a rewriting of another pragma, go to that pragma 6909 6910 if Is_Rewrite_Substitution (N) 6911 and then Nkind (Original_Node (N)) = N_Pragma 6912 then 6913 Error_Msg_Name_1 := Pragma_Name (Original_Node (N)); 6914 end if; 6915 6916 -- Case where pragma comes from an aspect specification 6917 6918 if From_Aspect_Specification (N) then 6919 6920 -- Change appearence of "pragma" in message to "aspect" 6921 6922 J := Res'First; 6923 while J <= Res_Last - 5 loop 6924 if Res (J .. J + 5) = "pragma" then 6925 Res (J .. J + 5) := "aspect"; 6926 J := J + 6; 6927 6928 else 6929 J := J + 1; 6930 end if; 6931 end loop; 6932 6933 -- Change "argument of" at start of message to "entity for" 6934 6935 if Res'Length > 11 6936 and then Res (Res'First .. Res'First + 10) = "argument of" 6937 then 6938 Res (Res'First .. Res'First + 9) := "entity for"; 6939 Res (Res'First + 10 .. Res_Last - 1) := 6940 Res (Res'First + 11 .. Res_Last); 6941 Res_Last := Res_Last - 1; 6942 end if; 6943 6944 -- Change "argument" at start of message to "entity" 6945 6946 if Res'Length > 8 6947 and then Res (Res'First .. Res'First + 7) = "argument" 6948 then 6949 Res (Res'First .. Res'First + 5) := "entity"; 6950 Res (Res'First + 6 .. Res_Last - 2) := 6951 Res (Res'First + 8 .. Res_Last); 6952 Res_Last := Res_Last - 2; 6953 end if; 6954 6955 -- Get name from corresponding aspect 6956 6957 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N); 6958 end if; 6959 6960 -- Return possibly modified message 6961 6962 return Res (Res'First .. Res_Last); 6963 end Fix_Error; 6964 6965 ------------------------- 6966 -- Gather_Associations -- 6967 ------------------------- 6968 6969 procedure Gather_Associations 6970 (Names : Name_List; 6971 Args : out Args_List) 6972 is 6973 Arg : Node_Id; 6974 6975 begin 6976 -- Initialize all parameters to Empty 6977 6978 for J in Args'Range loop 6979 Args (J) := Empty; 6980 end loop; 6981 6982 -- That's all we have to do if there are no argument associations 6983 6984 if No (Pragma_Argument_Associations (N)) then 6985 return; 6986 end if; 6987 6988 -- Otherwise first deal with any positional parameters present 6989 6990 Arg := First (Pragma_Argument_Associations (N)); 6991 for Index in Args'Range loop 6992 exit when No (Arg) or else Chars (Arg) /= No_Name; 6993 Args (Index) := Get_Pragma_Arg (Arg); 6994 Next (Arg); 6995 end loop; 6996 6997 -- Positional parameters all processed, if any left, then we 6998 -- have too many positional parameters. 6999 7000 if Present (Arg) and then Chars (Arg) = No_Name then 7001 Error_Pragma_Arg 7002 ("too many positional associations for pragma%", Arg); 7003 end if; 7004 7005 -- Process named parameters if any are present 7006 7007 while Present (Arg) loop 7008 if Chars (Arg) = No_Name then 7009 Error_Pragma_Arg 7010 ("positional association cannot follow named association", 7011 Arg); 7012 7013 else 7014 for Index in Names'Range loop 7015 if Names (Index) = Chars (Arg) then 7016 if Present (Args (Index)) then 7017 Error_Pragma_Arg 7018 ("duplicate argument association for pragma%", Arg); 7019 else 7020 Args (Index) := Get_Pragma_Arg (Arg); 7021 exit; 7022 end if; 7023 end if; 7024 7025 if Index = Names'Last then 7026 Error_Msg_Name_1 := Pname; 7027 Error_Msg_N ("pragma% does not allow & argument", Arg); 7028 7029 -- Check for possible misspelling 7030 7031 for Index1 in Names'Range loop 7032 if Is_Bad_Spelling_Of 7033 (Chars (Arg), Names (Index1)) 7034 then 7035 Error_Msg_Name_1 := Names (Index1); 7036 Error_Msg_N -- CODEFIX 7037 ("\possible misspelling of%", Arg); 7038 exit; 7039 end if; 7040 end loop; 7041 7042 raise Pragma_Exit; 7043 end if; 7044 end loop; 7045 end if; 7046 7047 Next (Arg); 7048 end loop; 7049 end Gather_Associations; 7050 7051 ----------------- 7052 -- GNAT_Pragma -- 7053 ----------------- 7054 7055 procedure GNAT_Pragma is 7056 begin 7057 -- We need to check the No_Implementation_Pragmas restriction for 7058 -- the case of a pragma from source. Note that the case of aspects 7059 -- generating corresponding pragmas marks these pragmas as not being 7060 -- from source, so this test also catches that case. 7061 7062 if Comes_From_Source (N) then 7063 Check_Restriction (No_Implementation_Pragmas, N); 7064 end if; 7065 end GNAT_Pragma; 7066 7067 -------------------------- 7068 -- Is_Before_First_Decl -- 7069 -------------------------- 7070 7071 function Is_Before_First_Decl 7072 (Pragma_Node : Node_Id; 7073 Decls : List_Id) return Boolean 7074 is 7075 Item : Node_Id := First (Decls); 7076 7077 begin 7078 -- Only other pragmas can come before this pragma 7079 7080 loop 7081 if No (Item) or else Nkind (Item) /= N_Pragma then 7082 return False; 7083 7084 elsif Item = Pragma_Node then 7085 return True; 7086 end if; 7087 7088 Next (Item); 7089 end loop; 7090 end Is_Before_First_Decl; 7091 7092 ----------------------------- 7093 -- Is_Configuration_Pragma -- 7094 ----------------------------- 7095 7096 -- A configuration pragma must appear in the context clause of a 7097 -- compilation unit, and only other pragmas may precede it. Note that 7098 -- the test below also permits use in a configuration pragma file. 7099 7100 function Is_Configuration_Pragma return Boolean is 7101 Lis : constant List_Id := List_Containing (N); 7102 Par : constant Node_Id := Parent (N); 7103 Prg : Node_Id; 7104 7105 begin 7106 -- If no parent, then we are in the configuration pragma file, 7107 -- so the placement is definitely appropriate. 7108 7109 if No (Par) then 7110 return True; 7111 7112 -- Otherwise we must be in the context clause of a compilation unit 7113 -- and the only thing allowed before us in the context list is more 7114 -- configuration pragmas. 7115 7116 elsif Nkind (Par) = N_Compilation_Unit 7117 and then Context_Items (Par) = Lis 7118 then 7119 Prg := First (Lis); 7120 7121 loop 7122 if Prg = N then 7123 return True; 7124 elsif Nkind (Prg) /= N_Pragma then 7125 return False; 7126 end if; 7127 7128 Next (Prg); 7129 end loop; 7130 7131 else 7132 return False; 7133 end if; 7134 end Is_Configuration_Pragma; 7135 7136 -------------------------- 7137 -- Is_In_Context_Clause -- 7138 -------------------------- 7139 7140 function Is_In_Context_Clause return Boolean is 7141 Plist : List_Id; 7142 Parent_Node : Node_Id; 7143 7144 begin 7145 if not Is_List_Member (N) then 7146 return False; 7147 7148 else 7149 Plist := List_Containing (N); 7150 Parent_Node := Parent (Plist); 7151 7152 if Parent_Node = Empty 7153 or else Nkind (Parent_Node) /= N_Compilation_Unit 7154 or else Context_Items (Parent_Node) /= Plist 7155 then 7156 return False; 7157 end if; 7158 end if; 7159 7160 return True; 7161 end Is_In_Context_Clause; 7162 7163 --------------------------------- 7164 -- Is_Static_String_Expression -- 7165 --------------------------------- 7166 7167 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is 7168 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 7169 Lit : constant Boolean := Nkind (Argx) = N_String_Literal; 7170 7171 begin 7172 Analyze_And_Resolve (Argx); 7173 7174 -- Special case Ada 83, where the expression will never be static, 7175 -- but we will return true if we had a string literal to start with. 7176 7177 if Ada_Version = Ada_83 then 7178 return Lit; 7179 7180 -- Normal case, true only if we end up with a string literal that 7181 -- is marked as being the result of evaluating a static expression. 7182 7183 else 7184 return Is_OK_Static_Expression (Argx) 7185 and then Nkind (Argx) = N_String_Literal; 7186 end if; 7187 7188 end Is_Static_String_Expression; 7189 7190 ---------------------- 7191 -- Pragma_Misplaced -- 7192 ---------------------- 7193 7194 procedure Pragma_Misplaced is 7195 begin 7196 Error_Pragma ("incorrect placement of pragma%"); 7197 end Pragma_Misplaced; 7198 7199 ------------------------------------------------ 7200 -- Process_Atomic_Independent_Shared_Volatile -- 7201 ------------------------------------------------ 7202 7203 procedure Process_Atomic_Independent_Shared_Volatile is 7204 procedure Check_VFA_Conflicts (Ent : Entity_Id); 7205 -- Apply additional checks for the GNAT pragma Volatile_Full_Access 7206 7207 procedure Mark_Component_Or_Object (Ent : Entity_Id); 7208 -- Appropriately set flags on the given entity (either an array or 7209 -- record component, or an object declaration) according to the 7210 -- current pragma. 7211 7212 procedure Set_Atomic_VFA (Ent : Entity_Id); 7213 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if 7214 -- no explicit alignment was given, set alignment to unknown, since 7215 -- back end knows what the alignment requirements are for atomic and 7216 -- full access arrays. Note: this is necessary for derived types. 7217 7218 ------------------------- 7219 -- Check_VFA_Conflicts -- 7220 ------------------------- 7221 7222 procedure Check_VFA_Conflicts (Ent : Entity_Id) is 7223 Comp : Entity_Id; 7224 Typ : Entity_Id; 7225 7226 VFA_And_Atomic : Boolean := False; 7227 -- Set True if atomic component present 7228 7229 VFA_And_Aliased : Boolean := False; 7230 -- Set True if aliased component present 7231 7232 begin 7233 -- Fetch the type in case we are dealing with an object or 7234 -- component. 7235 7236 if Is_Type (Ent) then 7237 Typ := Ent; 7238 else 7239 pragma Assert (Is_Object (Ent) 7240 or else 7241 Nkind (Declaration_Node (Ent)) = N_Component_Declaration); 7242 7243 Typ := Etype (Ent); 7244 end if; 7245 7246 -- Check Atomic and VFA used together 7247 7248 if Prag_Id = Pragma_Volatile_Full_Access 7249 or else Is_Volatile_Full_Access (Ent) 7250 then 7251 if Prag_Id = Pragma_Atomic 7252 or else Prag_Id = Pragma_Shared 7253 or else Is_Atomic (Ent) 7254 then 7255 VFA_And_Atomic := True; 7256 7257 elsif Is_Array_Type (Typ) then 7258 VFA_And_Atomic := Has_Atomic_Components (Typ); 7259 7260 -- Note: Has_Atomic_Components is not used below, as this flag 7261 -- represents the pragma of the same name, Atomic_Components, 7262 -- which only applies to arrays. 7263 7264 elsif Is_Record_Type (Typ) then 7265 -- Attributes cannot be applied to discriminants, only 7266 -- regular record components. 7267 7268 Comp := First_Component (Typ); 7269 while Present (Comp) loop 7270 if Is_Atomic (Comp) 7271 or else Is_Atomic (Typ) 7272 then 7273 VFA_And_Atomic := True; 7274 7275 exit; 7276 end if; 7277 7278 Next_Component (Comp); 7279 end loop; 7280 end if; 7281 7282 if VFA_And_Atomic then 7283 Error_Pragma 7284 ("cannot have Volatile_Full_Access and Atomic for same " 7285 & "entity"); 7286 end if; 7287 end if; 7288 7289 -- Check for the application of VFA to an entity that has aliased 7290 -- components. 7291 7292 if Prag_Id = Pragma_Volatile_Full_Access then 7293 if Is_Array_Type (Typ) 7294 and then Has_Aliased_Components (Typ) 7295 then 7296 VFA_And_Aliased := True; 7297 7298 -- Note: Has_Aliased_Components, like Has_Atomic_Components, 7299 -- and Has_Independent_Components, applies only to arrays. 7300 -- However, this flag does not have a corresponding pragma, so 7301 -- perhaps it should be possible to apply it to record types as 7302 -- well. Should this be done ??? 7303 7304 elsif Is_Record_Type (Typ) then 7305 -- It is possible to have an aliased discriminant, so they 7306 -- must be checked along with normal components. 7307 7308 Comp := First_Component_Or_Discriminant (Typ); 7309 while Present (Comp) loop 7310 if Is_Aliased (Comp) 7311 or else Is_Aliased (Etype (Comp)) 7312 then 7313 VFA_And_Aliased := True; 7314 Check_SPARK_05_Restriction 7315 ("aliased is not allowed", Comp); 7316 7317 exit; 7318 end if; 7319 7320 Next_Component_Or_Discriminant (Comp); 7321 end loop; 7322 end if; 7323 7324 if VFA_And_Aliased then 7325 Error_Pragma 7326 ("cannot apply Volatile_Full_Access (aliased component " 7327 & "present)"); 7328 end if; 7329 end if; 7330 end Check_VFA_Conflicts; 7331 7332 ------------------------------ 7333 -- Mark_Component_Or_Object -- 7334 ------------------------------ 7335 7336 procedure Mark_Component_Or_Object (Ent : Entity_Id) is 7337 begin 7338 if Prag_Id = Pragma_Atomic 7339 or else Prag_Id = Pragma_Shared 7340 or else Prag_Id = Pragma_Volatile_Full_Access 7341 then 7342 if Prag_Id = Pragma_Volatile_Full_Access then 7343 Set_Is_Volatile_Full_Access (Ent); 7344 else 7345 Set_Is_Atomic (Ent); 7346 end if; 7347 7348 -- If the object declaration has an explicit initialization, a 7349 -- temporary may have to be created to hold the expression, to 7350 -- ensure that access to the object remains atomic. 7351 7352 if Nkind (Parent (Ent)) = N_Object_Declaration 7353 and then Present (Expression (Parent (Ent))) 7354 then 7355 Set_Has_Delayed_Freeze (Ent); 7356 end if; 7357 end if; 7358 7359 -- Atomic/Shared/Volatile_Full_Access imply Independent 7360 7361 if Prag_Id /= Pragma_Volatile then 7362 Set_Is_Independent (Ent); 7363 7364 if Prag_Id = Pragma_Independent then 7365 Record_Independence_Check (N, Ent); 7366 end if; 7367 end if; 7368 7369 -- Atomic/Shared/Volatile_Full_Access imply Volatile 7370 7371 if Prag_Id /= Pragma_Independent then 7372 Set_Is_Volatile (Ent); 7373 Set_Treat_As_Volatile (Ent); 7374 end if; 7375 end Mark_Component_Or_Object; 7376 7377 -------------------- 7378 -- Set_Atomic_VFA -- 7379 -------------------- 7380 7381 procedure Set_Atomic_VFA (Ent : Entity_Id) is 7382 begin 7383 if Prag_Id = Pragma_Volatile_Full_Access then 7384 Set_Is_Volatile_Full_Access (Ent); 7385 else 7386 Set_Is_Atomic (Ent); 7387 end if; 7388 7389 if not Has_Alignment_Clause (Ent) then 7390 Set_Alignment (Ent, Uint_0); 7391 end if; 7392 end Set_Atomic_VFA; 7393 7394 -- Local variables 7395 7396 Decl : Node_Id; 7397 E : Entity_Id; 7398 E_Arg : Node_Id; 7399 7400 -- Start of processing for Process_Atomic_Independent_Shared_Volatile 7401 7402 begin 7403 Check_Ada_83_Warning; 7404 Check_No_Identifiers; 7405 Check_Arg_Count (1); 7406 Check_Arg_Is_Local_Name (Arg1); 7407 E_Arg := Get_Pragma_Arg (Arg1); 7408 7409 if Etype (E_Arg) = Any_Type then 7410 return; 7411 end if; 7412 7413 E := Entity (E_Arg); 7414 7415 -- A pragma that applies to a Ghost entity becomes Ghost for the 7416 -- purposes of legality checks and removal of ignored Ghost code. 7417 7418 Mark_Ghost_Pragma (N, E); 7419 7420 -- Check duplicate before we chain ourselves 7421 7422 Check_Duplicate_Pragma (E); 7423 7424 -- Check appropriateness of the entity 7425 7426 Decl := Declaration_Node (E); 7427 7428 -- Deal with the case where the pragma/attribute is applied to a type 7429 7430 if Is_Type (E) then 7431 if Rep_Item_Too_Early (E, N) 7432 or else Rep_Item_Too_Late (E, N) 7433 then 7434 return; 7435 else 7436 Check_First_Subtype (Arg1); 7437 end if; 7438 7439 -- Attribute belongs on the base type. If the view of the type is 7440 -- currently private, it also belongs on the underlying type. 7441 7442 if Prag_Id = Pragma_Atomic 7443 or else Prag_Id = Pragma_Shared 7444 or else Prag_Id = Pragma_Volatile_Full_Access 7445 then 7446 Set_Atomic_VFA (E); 7447 Set_Atomic_VFA (Base_Type (E)); 7448 Set_Atomic_VFA (Underlying_Type (E)); 7449 end if; 7450 7451 -- Atomic/Shared/Volatile_Full_Access imply Independent 7452 7453 if Prag_Id /= Pragma_Volatile then 7454 Set_Is_Independent (E); 7455 Set_Is_Independent (Base_Type (E)); 7456 Set_Is_Independent (Underlying_Type (E)); 7457 7458 if Prag_Id = Pragma_Independent then 7459 Record_Independence_Check (N, Base_Type (E)); 7460 end if; 7461 end if; 7462 7463 -- Atomic/Shared/Volatile_Full_Access imply Volatile 7464 7465 if Prag_Id /= Pragma_Independent then 7466 Set_Is_Volatile (E); 7467 Set_Is_Volatile (Base_Type (E)); 7468 Set_Is_Volatile (Underlying_Type (E)); 7469 7470 Set_Treat_As_Volatile (E); 7471 Set_Treat_As_Volatile (Underlying_Type (E)); 7472 end if; 7473 7474 -- Apply Volatile to the composite type's individual components, 7475 -- (RM C.6(8/3)). 7476 7477 if Prag_Id = Pragma_Volatile 7478 and then Is_Record_Type (Etype (E)) 7479 then 7480 declare 7481 Comp : Entity_Id; 7482 begin 7483 Comp := First_Component (E); 7484 while Present (Comp) loop 7485 Mark_Component_Or_Object (Comp); 7486 7487 Next_Component (Comp); 7488 end loop; 7489 end; 7490 end if; 7491 7492 -- Deal with the case where the pragma/attribute applies to a 7493 -- component or object declaration. 7494 7495 elsif Nkind (Decl) = N_Object_Declaration 7496 or else (Nkind (Decl) = N_Component_Declaration 7497 and then Original_Record_Component (E) = E) 7498 then 7499 if Rep_Item_Too_Late (E, N) then 7500 return; 7501 end if; 7502 7503 Mark_Component_Or_Object (E); 7504 else 7505 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 7506 end if; 7507 7508 -- Perform the checks needed to assure the proper use of the GNAT 7509 -- pragma Volatile_Full_Access. 7510 7511 Check_VFA_Conflicts (E); 7512 7513 -- The following check is only relevant when SPARK_Mode is on as 7514 -- this is not a standard Ada legality rule. Pragma Volatile can 7515 -- only apply to a full type declaration or an object declaration 7516 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for 7517 -- untagged derived types that are rewritten as subtypes of their 7518 -- respective root types. 7519 7520 if SPARK_Mode = On 7521 and then Prag_Id = Pragma_Volatile 7522 and then not Nkind_In (Original_Node (Decl), 7523 N_Full_Type_Declaration, 7524 N_Object_Declaration, 7525 N_Single_Protected_Declaration, 7526 N_Single_Task_Declaration) 7527 then 7528 Error_Pragma_Arg 7529 ("argument of pragma % must denote a full type or object " 7530 & "declaration", Arg1); 7531 end if; 7532 end Process_Atomic_Independent_Shared_Volatile; 7533 7534 ------------------------------------------- 7535 -- Process_Compile_Time_Warning_Or_Error -- 7536 ------------------------------------------- 7537 7538 procedure Process_Compile_Time_Warning_Or_Error is 7539 Validation_Needed : Boolean := False; 7540 7541 function Check_Node (N : Node_Id) return Traverse_Result; 7542 -- Tree visitor that checks if N is an attribute reference that can 7543 -- be statically computed by the back end. Validation_Needed is set 7544 -- to True if found. 7545 7546 ---------------- 7547 -- Check_Node -- 7548 ---------------- 7549 7550 function Check_Node (N : Node_Id) return Traverse_Result is 7551 begin 7552 if Nkind (N) = N_Attribute_Reference 7553 and then Is_Entity_Name (Prefix (N)) 7554 and then not Is_Generic_Unit (Scope (Entity (Prefix (N)))) 7555 then 7556 declare 7557 Attr_Id : constant Attribute_Id := 7558 Get_Attribute_Id (Attribute_Name (N)); 7559 begin 7560 if Attr_Id = Attribute_Alignment 7561 or else Attr_Id = Attribute_Size 7562 then 7563 Validation_Needed := True; 7564 end if; 7565 end; 7566 end if; 7567 7568 return OK; 7569 end Check_Node; 7570 7571 procedure Check_Expression is new Traverse_Proc (Check_Node); 7572 7573 -- Local variables 7574 7575 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 7576 7577 -- Start of processing for Process_Compile_Time_Warning_Or_Error 7578 7579 begin 7580 -- In GNATprove mode, pragmas Compile_Time_Error and 7581 -- Compile_Time_Warning are ignored, as the analyzer may not have the 7582 -- same information as the compiler (in particular regarding size of 7583 -- objects decided in gigi) so it makes no sense to issue an error or 7584 -- warning in GNATprove. 7585 7586 if GNATprove_Mode then 7587 Rewrite (N, Make_Null_Statement (Loc)); 7588 return; 7589 end if; 7590 7591 Check_Arg_Count (2); 7592 Check_No_Identifiers; 7593 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 7594 Analyze_And_Resolve (Arg1x, Standard_Boolean); 7595 7596 if Compile_Time_Known_Value (Arg1x) then 7597 Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1)); 7598 7599 -- Register the expression for its validation after the back end has 7600 -- been called if it has occurrences of attributes Size or Alignment 7601 -- (because they may be statically computed by the back end and hence 7602 -- the whole expression needs to be reevaluated). 7603 7604 else 7605 Check_Expression (Arg1x); 7606 7607 if Validation_Needed then 7608 Sem_Ch13.Validate_Compile_Time_Warning_Error (N); 7609 end if; 7610 end if; 7611 end Process_Compile_Time_Warning_Or_Error; 7612 7613 ------------------------ 7614 -- Process_Convention -- 7615 ------------------------ 7616 7617 procedure Process_Convention 7618 (C : out Convention_Id; 7619 Ent : out Entity_Id) 7620 is 7621 Cname : Name_Id; 7622 7623 procedure Diagnose_Multiple_Pragmas (S : Entity_Id); 7624 -- Called if we have more than one Export/Import/Convention pragma. 7625 -- This is generally illegal, but we have a special case of allowing 7626 -- Import and Interface to coexist if they specify the convention in 7627 -- a consistent manner. We are allowed to do this, since Interface is 7628 -- an implementation defined pragma, and we choose to do it since we 7629 -- know Rational allows this combination. S is the entity id of the 7630 -- subprogram in question. This procedure also sets the special flag 7631 -- Import_Interface_Present in both pragmas in the case where we do 7632 -- have matching Import and Interface pragmas. 7633 7634 procedure Set_Convention_From_Pragma (E : Entity_Id); 7635 -- Set convention in entity E, and also flag that the entity has a 7636 -- convention pragma. If entity is for a private or incomplete type, 7637 -- also set convention and flag on underlying type. This procedure 7638 -- also deals with the special case of C_Pass_By_Copy convention, 7639 -- and error checks for inappropriate convention specification. 7640 7641 ------------------------------- 7642 -- Diagnose_Multiple_Pragmas -- 7643 ------------------------------- 7644 7645 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is 7646 Pdec : constant Node_Id := Declaration_Node (S); 7647 Decl : Node_Id; 7648 Err : Boolean; 7649 7650 function Same_Convention (Decl : Node_Id) return Boolean; 7651 -- Decl is a pragma node. This function returns True if this 7652 -- pragma has a first argument that is an identifier with a 7653 -- Chars field corresponding to the Convention_Id C. 7654 7655 function Same_Name (Decl : Node_Id) return Boolean; 7656 -- Decl is a pragma node. This function returns True if this 7657 -- pragma has a second argument that is an identifier with a 7658 -- Chars field that matches the Chars of the current subprogram. 7659 7660 --------------------- 7661 -- Same_Convention -- 7662 --------------------- 7663 7664 function Same_Convention (Decl : Node_Id) return Boolean is 7665 Arg1 : constant Node_Id := 7666 First (Pragma_Argument_Associations (Decl)); 7667 7668 begin 7669 if Present (Arg1) then 7670 declare 7671 Arg : constant Node_Id := Get_Pragma_Arg (Arg1); 7672 begin 7673 if Nkind (Arg) = N_Identifier 7674 and then Is_Convention_Name (Chars (Arg)) 7675 and then Get_Convention_Id (Chars (Arg)) = C 7676 then 7677 return True; 7678 end if; 7679 end; 7680 end if; 7681 7682 return False; 7683 end Same_Convention; 7684 7685 --------------- 7686 -- Same_Name -- 7687 --------------- 7688 7689 function Same_Name (Decl : Node_Id) return Boolean is 7690 Arg1 : constant Node_Id := 7691 First (Pragma_Argument_Associations (Decl)); 7692 Arg2 : Node_Id; 7693 7694 begin 7695 if No (Arg1) then 7696 return False; 7697 end if; 7698 7699 Arg2 := Next (Arg1); 7700 7701 if No (Arg2) then 7702 return False; 7703 end if; 7704 7705 declare 7706 Arg : constant Node_Id := Get_Pragma_Arg (Arg2); 7707 begin 7708 if Nkind (Arg) = N_Identifier 7709 and then Chars (Arg) = Chars (S) 7710 then 7711 return True; 7712 end if; 7713 end; 7714 7715 return False; 7716 end Same_Name; 7717 7718 -- Start of processing for Diagnose_Multiple_Pragmas 7719 7720 begin 7721 Err := True; 7722 7723 -- Definitely give message if we have Convention/Export here 7724 7725 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then 7726 null; 7727 7728 -- If we have an Import or Export, scan back from pragma to 7729 -- find any previous pragma applying to the same procedure. 7730 -- The scan will be terminated by the start of the list, or 7731 -- hitting the subprogram declaration. This won't allow one 7732 -- pragma to appear in the public part and one in the private 7733 -- part, but that seems very unlikely in practice. 7734 7735 else 7736 Decl := Prev (N); 7737 while Present (Decl) and then Decl /= Pdec loop 7738 7739 -- Look for pragma with same name as us 7740 7741 if Nkind (Decl) = N_Pragma 7742 and then Same_Name (Decl) 7743 then 7744 -- Give error if same as our pragma or Export/Convention 7745 7746 if Nam_In (Pragma_Name_Unmapped (Decl), 7747 Name_Export, 7748 Name_Convention, 7749 Pragma_Name_Unmapped (N)) 7750 then 7751 exit; 7752 7753 -- Case of Import/Interface or the other way round 7754 7755 elsif Nam_In (Pragma_Name_Unmapped (Decl), 7756 Name_Interface, Name_Import) 7757 then 7758 -- Here we know that we have Import and Interface. It 7759 -- doesn't matter which way round they are. See if 7760 -- they specify the same convention. If so, all OK, 7761 -- and set special flags to stop other messages 7762 7763 if Same_Convention (Decl) then 7764 Set_Import_Interface_Present (N); 7765 Set_Import_Interface_Present (Decl); 7766 Err := False; 7767 7768 -- If different conventions, special message 7769 7770 else 7771 Error_Msg_Sloc := Sloc (Decl); 7772 Error_Pragma_Arg 7773 ("convention differs from that given#", Arg1); 7774 return; 7775 end if; 7776 end if; 7777 end if; 7778 7779 Next (Decl); 7780 end loop; 7781 end if; 7782 7783 -- Give message if needed if we fall through those tests 7784 -- except on Relaxed_RM_Semantics where we let go: either this 7785 -- is a case accepted/ignored by other Ada compilers (e.g. 7786 -- a mix of Convention and Import), or another error will be 7787 -- generated later (e.g. using both Import and Export). 7788 7789 if Err and not Relaxed_RM_Semantics then 7790 Error_Pragma_Arg 7791 ("at most one Convention/Export/Import pragma is allowed", 7792 Arg2); 7793 end if; 7794 end Diagnose_Multiple_Pragmas; 7795 7796 -------------------------------- 7797 -- Set_Convention_From_Pragma -- 7798 -------------------------------- 7799 7800 procedure Set_Convention_From_Pragma (E : Entity_Id) is 7801 begin 7802 -- Ada 2005 (AI-430): Check invalid attempt to change convention 7803 -- for an overridden dispatching operation. Technically this is 7804 -- an amendment and should only be done in Ada 2005 mode. However, 7805 -- this is clearly a mistake, since the problem that is addressed 7806 -- by this AI is that there is a clear gap in the RM. 7807 7808 if Is_Dispatching_Operation (E) 7809 and then Present (Overridden_Operation (E)) 7810 and then C /= Convention (Overridden_Operation (E)) 7811 then 7812 Error_Pragma_Arg 7813 ("cannot change convention for overridden dispatching " 7814 & "operation", Arg1); 7815 end if; 7816 7817 -- Special checks for Convention_Stdcall 7818 7819 if C = Convention_Stdcall then 7820 7821 -- A dispatching call is not allowed. A dispatching subprogram 7822 -- cannot be used to interface to the Win32 API, so in fact 7823 -- this check does not impose any effective restriction. 7824 7825 if Is_Dispatching_Operation (E) then 7826 Error_Msg_Sloc := Sloc (E); 7827 7828 -- Note: make this unconditional so that if there is more 7829 -- than one call to which the pragma applies, we get a 7830 -- message for each call. Also don't use Error_Pragma, 7831 -- so that we get multiple messages. 7832 7833 Error_Msg_N 7834 ("dispatching subprogram# cannot use Stdcall convention!", 7835 Arg1); 7836 7837 -- Several allowed cases 7838 7839 elsif Is_Subprogram_Or_Generic_Subprogram (E) 7840 7841 -- A variable is OK 7842 7843 or else Ekind (E) = E_Variable 7844 7845 -- A component as well. The entity does not have its Ekind 7846 -- set until the enclosing record declaration is fully 7847 -- analyzed. 7848 7849 or else Nkind (Parent (E)) = N_Component_Declaration 7850 7851 -- An access to subprogram is also allowed 7852 7853 or else 7854 (Is_Access_Type (E) 7855 and then Ekind (Designated_Type (E)) = E_Subprogram_Type) 7856 7857 -- Allow internal call to set convention of subprogram type 7858 7859 or else Ekind (E) = E_Subprogram_Type 7860 then 7861 null; 7862 7863 else 7864 Error_Pragma_Arg 7865 ("second argument of pragma% must be subprogram (type)", 7866 Arg2); 7867 end if; 7868 end if; 7869 7870 -- Set the convention 7871 7872 Set_Convention (E, C); 7873 Set_Has_Convention_Pragma (E); 7874 7875 -- For the case of a record base type, also set the convention of 7876 -- any anonymous access types declared in the record which do not 7877 -- currently have a specified convention. 7878 7879 if Is_Record_Type (E) and then Is_Base_Type (E) then 7880 declare 7881 Comp : Node_Id; 7882 7883 begin 7884 Comp := First_Component (E); 7885 while Present (Comp) loop 7886 if Present (Etype (Comp)) 7887 and then Ekind_In (Etype (Comp), 7888 E_Anonymous_Access_Type, 7889 E_Anonymous_Access_Subprogram_Type) 7890 and then not Has_Convention_Pragma (Comp) 7891 then 7892 Set_Convention (Comp, C); 7893 end if; 7894 7895 Next_Component (Comp); 7896 end loop; 7897 end; 7898 end if; 7899 7900 -- Deal with incomplete/private type case, where underlying type 7901 -- is available, so set convention of that underlying type. 7902 7903 if Is_Incomplete_Or_Private_Type (E) 7904 and then Present (Underlying_Type (E)) 7905 then 7906 Set_Convention (Underlying_Type (E), C); 7907 Set_Has_Convention_Pragma (Underlying_Type (E), True); 7908 end if; 7909 7910 -- A class-wide type should inherit the convention of the specific 7911 -- root type (although this isn't specified clearly by the RM). 7912 7913 if Is_Type (E) and then Present (Class_Wide_Type (E)) then 7914 Set_Convention (Class_Wide_Type (E), C); 7915 end if; 7916 7917 -- If the entity is a record type, then check for special case of 7918 -- C_Pass_By_Copy, which is treated the same as C except that the 7919 -- special record flag is set. This convention is only permitted 7920 -- on record types (see AI95-00131). 7921 7922 if Cname = Name_C_Pass_By_Copy then 7923 if Is_Record_Type (E) then 7924 Set_C_Pass_By_Copy (Base_Type (E)); 7925 elsif Is_Incomplete_Or_Private_Type (E) 7926 and then Is_Record_Type (Underlying_Type (E)) 7927 then 7928 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); 7929 else 7930 Error_Pragma_Arg 7931 ("C_Pass_By_Copy convention allowed only for record type", 7932 Arg2); 7933 end if; 7934 end if; 7935 7936 -- If the entity is a derived boolean type, check for the special 7937 -- case of convention C, C++, or Fortran, where we consider any 7938 -- nonzero value to represent true. 7939 7940 if Is_Discrete_Type (E) 7941 and then Root_Type (Etype (E)) = Standard_Boolean 7942 and then 7943 (C = Convention_C 7944 or else 7945 C = Convention_CPP 7946 or else 7947 C = Convention_Fortran) 7948 then 7949 Set_Nonzero_Is_True (Base_Type (E)); 7950 end if; 7951 end Set_Convention_From_Pragma; 7952 7953 -- Local variables 7954 7955 Comp_Unit : Unit_Number_Type; 7956 E : Entity_Id; 7957 E1 : Entity_Id; 7958 Id : Node_Id; 7959 7960 -- Start of processing for Process_Convention 7961 7962 begin 7963 Check_At_Least_N_Arguments (2); 7964 Check_Optional_Identifier (Arg1, Name_Convention); 7965 Check_Arg_Is_Identifier (Arg1); 7966 Cname := Chars (Get_Pragma_Arg (Arg1)); 7967 7968 -- C_Pass_By_Copy is treated as a synonym for convention C (this is 7969 -- tested again below to set the critical flag). 7970 7971 if Cname = Name_C_Pass_By_Copy then 7972 C := Convention_C; 7973 7974 -- Otherwise we must have something in the standard convention list 7975 7976 elsif Is_Convention_Name (Cname) then 7977 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); 7978 7979 -- Otherwise warn on unrecognized convention 7980 7981 else 7982 if Warn_On_Export_Import then 7983 Error_Msg_N 7984 ("??unrecognized convention name, C assumed", 7985 Get_Pragma_Arg (Arg1)); 7986 end if; 7987 7988 C := Convention_C; 7989 end if; 7990 7991 Check_Optional_Identifier (Arg2, Name_Entity); 7992 Check_Arg_Is_Local_Name (Arg2); 7993 7994 Id := Get_Pragma_Arg (Arg2); 7995 Analyze (Id); 7996 7997 if not Is_Entity_Name (Id) then 7998 Error_Pragma_Arg ("entity name required", Arg2); 7999 end if; 8000 8001 E := Entity (Id); 8002 8003 -- Set entity to return 8004 8005 Ent := E; 8006 8007 -- Ada_Pass_By_Copy special checking 8008 8009 if C = Convention_Ada_Pass_By_Copy then 8010 if not Is_First_Subtype (E) then 8011 Error_Pragma_Arg 8012 ("convention `Ada_Pass_By_Copy` only allowed for types", 8013 Arg2); 8014 end if; 8015 8016 if Is_By_Reference_Type (E) then 8017 Error_Pragma_Arg 8018 ("convention `Ada_Pass_By_Copy` not allowed for by-reference " 8019 & "type", Arg1); 8020 end if; 8021 8022 -- Ada_Pass_By_Reference special checking 8023 8024 elsif C = Convention_Ada_Pass_By_Reference then 8025 if not Is_First_Subtype (E) then 8026 Error_Pragma_Arg 8027 ("convention `Ada_Pass_By_Reference` only allowed for types", 8028 Arg2); 8029 end if; 8030 8031 if Is_By_Copy_Type (E) then 8032 Error_Pragma_Arg 8033 ("convention `Ada_Pass_By_Reference` not allowed for by-copy " 8034 & "type", Arg1); 8035 end if; 8036 end if; 8037 8038 -- Go to renamed subprogram if present, since convention applies to 8039 -- the actual renamed entity, not to the renaming entity. If the 8040 -- subprogram is inherited, go to parent subprogram. 8041 8042 if Is_Subprogram (E) 8043 and then Present (Alias (E)) 8044 then 8045 if Nkind (Parent (Declaration_Node (E))) = 8046 N_Subprogram_Renaming_Declaration 8047 then 8048 if Scope (E) /= Scope (Alias (E)) then 8049 Error_Pragma_Ref 8050 ("cannot apply pragma% to non-local entity&#", E); 8051 end if; 8052 8053 E := Alias (E); 8054 8055 elsif Nkind_In (Parent (E), N_Full_Type_Declaration, 8056 N_Private_Extension_Declaration) 8057 and then Scope (E) = Scope (Alias (E)) 8058 then 8059 E := Alias (E); 8060 8061 -- Return the parent subprogram the entity was inherited from 8062 8063 Ent := E; 8064 end if; 8065 end if; 8066 8067 -- Check that we are not applying this to a specless body. Relax this 8068 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers. 8069 8070 if Is_Subprogram (E) 8071 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body 8072 and then not Relaxed_RM_Semantics 8073 then 8074 Error_Pragma 8075 ("pragma% requires separate spec and must come before body"); 8076 end if; 8077 8078 -- Check that we are not applying this to a named constant 8079 8080 if Ekind_In (E, E_Named_Integer, E_Named_Real) then 8081 Error_Msg_Name_1 := Pname; 8082 Error_Msg_N 8083 ("cannot apply pragma% to named constant!", 8084 Get_Pragma_Arg (Arg2)); 8085 Error_Pragma_Arg 8086 ("\supply appropriate type for&!", Arg2); 8087 end if; 8088 8089 if Ekind (E) = E_Enumeration_Literal then 8090 Error_Pragma ("enumeration literal not allowed for pragma%"); 8091 end if; 8092 8093 -- Check for rep item appearing too early or too late 8094 8095 if Etype (E) = Any_Type 8096 or else Rep_Item_Too_Early (E, N) 8097 then 8098 raise Pragma_Exit; 8099 8100 elsif Present (Underlying_Type (E)) then 8101 E := Underlying_Type (E); 8102 end if; 8103 8104 if Rep_Item_Too_Late (E, N) then 8105 raise Pragma_Exit; 8106 end if; 8107 8108 if Has_Convention_Pragma (E) then 8109 Diagnose_Multiple_Pragmas (E); 8110 8111 elsif Convention (E) = Convention_Protected 8112 or else Ekind (Scope (E)) = E_Protected_Type 8113 then 8114 Error_Pragma_Arg 8115 ("a protected operation cannot be given a different convention", 8116 Arg2); 8117 end if; 8118 8119 -- For Intrinsic, a subprogram is required 8120 8121 if C = Convention_Intrinsic 8122 and then not Is_Subprogram_Or_Generic_Subprogram (E) 8123 then 8124 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics 8125 8126 if not (Is_Type (E) and then Relaxed_RM_Semantics) then 8127 Error_Pragma_Arg 8128 ("second argument of pragma% must be a subprogram", Arg2); 8129 end if; 8130 end if; 8131 8132 -- Deal with non-subprogram cases 8133 8134 if not Is_Subprogram_Or_Generic_Subprogram (E) then 8135 Set_Convention_From_Pragma (E); 8136 8137 if Is_Type (E) then 8138 8139 -- The pragma must apply to a first subtype, but it can also 8140 -- apply to a generic type in a generic formal part, in which 8141 -- case it will also appear in the corresponding instance. 8142 8143 if Is_Generic_Type (E) or else In_Instance then 8144 null; 8145 else 8146 Check_First_Subtype (Arg2); 8147 end if; 8148 8149 Set_Convention_From_Pragma (Base_Type (E)); 8150 8151 -- For access subprograms, we must set the convention on the 8152 -- internally generated directly designated type as well. 8153 8154 if Ekind (E) = E_Access_Subprogram_Type then 8155 Set_Convention_From_Pragma (Directly_Designated_Type (E)); 8156 end if; 8157 end if; 8158 8159 -- For the subprogram case, set proper convention for all homonyms 8160 -- in same scope and the same declarative part, i.e. the same 8161 -- compilation unit. 8162 8163 else 8164 Comp_Unit := Get_Source_Unit (E); 8165 Set_Convention_From_Pragma (E); 8166 8167 -- Treat a pragma Import as an implicit body, and pragma import 8168 -- as implicit reference (for navigation in GPS). 8169 8170 if Prag_Id = Pragma_Import then 8171 Generate_Reference (E, Id, 'b'); 8172 8173 -- For exported entities we restrict the generation of references 8174 -- to entities exported to foreign languages since entities 8175 -- exported to Ada do not provide further information to GPS and 8176 -- add undesired references to the output of the gnatxref tool. 8177 8178 elsif Prag_Id = Pragma_Export 8179 and then Convention (E) /= Convention_Ada 8180 then 8181 Generate_Reference (E, Id, 'i'); 8182 end if; 8183 8184 -- If the pragma comes from an aspect, it only applies to the 8185 -- given entity, not its homonyms. 8186 8187 if From_Aspect_Specification (N) then 8188 if C = Convention_Intrinsic 8189 and then Nkind (Ent) = N_Defining_Operator_Symbol 8190 then 8191 if Is_Fixed_Point_Type (Etype (Ent)) 8192 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent))) 8193 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent))) 8194 then 8195 Error_Msg_N 8196 ("no intrinsic operator available for this fixed-point " 8197 & "operation", N); 8198 Error_Msg_N 8199 ("\use expression functions with the desired " 8200 & "conversions made explicit", N); 8201 end if; 8202 end if; 8203 8204 return; 8205 end if; 8206 8207 -- Otherwise Loop through the homonyms of the pragma argument's 8208 -- entity, an apply convention to those in the current scope. 8209 8210 E1 := Ent; 8211 8212 loop 8213 E1 := Homonym (E1); 8214 exit when No (E1) or else Scope (E1) /= Current_Scope; 8215 8216 -- Ignore entry for which convention is already set 8217 8218 if Has_Convention_Pragma (E1) then 8219 goto Continue; 8220 end if; 8221 8222 if Is_Subprogram (E1) 8223 and then Nkind (Parent (Declaration_Node (E1))) = 8224 N_Subprogram_Body 8225 and then not Relaxed_RM_Semantics 8226 then 8227 Set_Has_Completion (E); -- to prevent cascaded error 8228 Error_Pragma_Ref 8229 ("pragma% requires separate spec and must come before " 8230 & "body#", E1); 8231 end if; 8232 8233 -- Do not set the pragma on inherited operations or on formal 8234 -- subprograms. 8235 8236 if Comes_From_Source (E1) 8237 and then Comp_Unit = Get_Source_Unit (E1) 8238 and then not Is_Formal_Subprogram (E1) 8239 and then Nkind (Original_Node (Parent (E1))) /= 8240 N_Full_Type_Declaration 8241 then 8242 if Present (Alias (E1)) 8243 and then Scope (E1) /= Scope (Alias (E1)) 8244 then 8245 Error_Pragma_Ref 8246 ("cannot apply pragma% to non-local entity& declared#", 8247 E1); 8248 end if; 8249 8250 Set_Convention_From_Pragma (E1); 8251 8252 if Prag_Id = Pragma_Import then 8253 Generate_Reference (E1, Id, 'b'); 8254 end if; 8255 end if; 8256 8257 <<Continue>> 8258 null; 8259 end loop; 8260 end if; 8261 end Process_Convention; 8262 8263 ---------------------------------------- 8264 -- Process_Disable_Enable_Atomic_Sync -- 8265 ---------------------------------------- 8266 8267 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is 8268 begin 8269 Check_No_Identifiers; 8270 Check_At_Most_N_Arguments (1); 8271 8272 -- Modeled internally as 8273 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity]) 8274 8275 Rewrite (N, 8276 Make_Pragma (Loc, 8277 Chars => Nam, 8278 Pragma_Argument_Associations => New_List ( 8279 Make_Pragma_Argument_Association (Loc, 8280 Expression => 8281 Make_Identifier (Loc, Name_Atomic_Synchronization))))); 8282 8283 if Present (Arg1) then 8284 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); 8285 end if; 8286 8287 Analyze (N); 8288 end Process_Disable_Enable_Atomic_Sync; 8289 8290 ------------------------------------------------- 8291 -- Process_Extended_Import_Export_Internal_Arg -- 8292 ------------------------------------------------- 8293 8294 procedure Process_Extended_Import_Export_Internal_Arg 8295 (Arg_Internal : Node_Id := Empty) 8296 is 8297 begin 8298 if No (Arg_Internal) then 8299 Error_Pragma ("Internal parameter required for pragma%"); 8300 end if; 8301 8302 if Nkind (Arg_Internal) = N_Identifier then 8303 null; 8304 8305 elsif Nkind (Arg_Internal) = N_Operator_Symbol 8306 and then (Prag_Id = Pragma_Import_Function 8307 or else 8308 Prag_Id = Pragma_Export_Function) 8309 then 8310 null; 8311 8312 else 8313 Error_Pragma_Arg 8314 ("wrong form for Internal parameter for pragma%", Arg_Internal); 8315 end if; 8316 8317 Check_Arg_Is_Local_Name (Arg_Internal); 8318 end Process_Extended_Import_Export_Internal_Arg; 8319 8320 -------------------------------------------------- 8321 -- Process_Extended_Import_Export_Object_Pragma -- 8322 -------------------------------------------------- 8323 8324 procedure Process_Extended_Import_Export_Object_Pragma 8325 (Arg_Internal : Node_Id; 8326 Arg_External : Node_Id; 8327 Arg_Size : Node_Id) 8328 is 8329 Def_Id : Entity_Id; 8330 8331 begin 8332 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 8333 Def_Id := Entity (Arg_Internal); 8334 8335 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 8336 Error_Pragma_Arg 8337 ("pragma% must designate an object", Arg_Internal); 8338 end if; 8339 8340 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 8341 or else 8342 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 8343 then 8344 Error_Pragma_Arg 8345 ("previous Common/Psect_Object applies, pragma % not permitted", 8346 Arg_Internal); 8347 end if; 8348 8349 if Rep_Item_Too_Late (Def_Id, N) then 8350 raise Pragma_Exit; 8351 end if; 8352 8353 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 8354 8355 if Present (Arg_Size) then 8356 Check_Arg_Is_External_Name (Arg_Size); 8357 end if; 8358 8359 -- Export_Object case 8360 8361 if Prag_Id = Pragma_Export_Object then 8362 if not Is_Library_Level_Entity (Def_Id) then 8363 Error_Pragma_Arg 8364 ("argument for pragma% must be library level entity", 8365 Arg_Internal); 8366 end if; 8367 8368 if Ekind (Current_Scope) = E_Generic_Package then 8369 Error_Pragma ("pragma& cannot appear in a generic unit"); 8370 end if; 8371 8372 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then 8373 Error_Pragma_Arg 8374 ("exported object must have compile time known size", 8375 Arg_Internal); 8376 end if; 8377 8378 if Warn_On_Export_Import and then Is_Exported (Def_Id) then 8379 Error_Msg_N ("??duplicate Export_Object pragma", N); 8380 else 8381 Set_Exported (Def_Id, Arg_Internal); 8382 end if; 8383 8384 -- Import_Object case 8385 8386 else 8387 if Is_Concurrent_Type (Etype (Def_Id)) then 8388 Error_Pragma_Arg 8389 ("cannot use pragma% for task/protected object", 8390 Arg_Internal); 8391 end if; 8392 8393 if Ekind (Def_Id) = E_Constant then 8394 Error_Pragma_Arg 8395 ("cannot import a constant", Arg_Internal); 8396 end if; 8397 8398 if Warn_On_Export_Import 8399 and then Has_Discriminants (Etype (Def_Id)) 8400 then 8401 Error_Msg_N 8402 ("imported value must be initialized??", Arg_Internal); 8403 end if; 8404 8405 if Warn_On_Export_Import 8406 and then Is_Access_Type (Etype (Def_Id)) 8407 then 8408 Error_Pragma_Arg 8409 ("cannot import object of an access type??", Arg_Internal); 8410 end if; 8411 8412 if Warn_On_Export_Import 8413 and then Is_Imported (Def_Id) 8414 then 8415 Error_Msg_N ("??duplicate Import_Object pragma", N); 8416 8417 -- Check for explicit initialization present. Note that an 8418 -- initialization generated by the code generator, e.g. for an 8419 -- access type, does not count here. 8420 8421 elsif Present (Expression (Parent (Def_Id))) 8422 and then 8423 Comes_From_Source 8424 (Original_Node (Expression (Parent (Def_Id)))) 8425 then 8426 Error_Msg_Sloc := Sloc (Def_Id); 8427 Error_Pragma_Arg 8428 ("imported entities cannot be initialized (RM B.1(24))", 8429 "\no initialization allowed for & declared#", Arg1); 8430 else 8431 Set_Imported (Def_Id); 8432 Note_Possible_Modification (Arg_Internal, Sure => False); 8433 end if; 8434 end if; 8435 end Process_Extended_Import_Export_Object_Pragma; 8436 8437 ------------------------------------------------------ 8438 -- Process_Extended_Import_Export_Subprogram_Pragma -- 8439 ------------------------------------------------------ 8440 8441 procedure Process_Extended_Import_Export_Subprogram_Pragma 8442 (Arg_Internal : Node_Id; 8443 Arg_External : Node_Id; 8444 Arg_Parameter_Types : Node_Id; 8445 Arg_Result_Type : Node_Id := Empty; 8446 Arg_Mechanism : Node_Id; 8447 Arg_Result_Mechanism : Node_Id := Empty) 8448 is 8449 Ent : Entity_Id; 8450 Def_Id : Entity_Id; 8451 Hom_Id : Entity_Id; 8452 Formal : Entity_Id; 8453 Ambiguous : Boolean; 8454 Match : Boolean; 8455 8456 function Same_Base_Type 8457 (Ptype : Node_Id; 8458 Formal : Entity_Id) return Boolean; 8459 -- Determines if Ptype references the type of Formal. Note that only 8460 -- the base types need to match according to the spec. Ptype here is 8461 -- the argument from the pragma, which is either a type name, or an 8462 -- access attribute. 8463 8464 -------------------- 8465 -- Same_Base_Type -- 8466 -------------------- 8467 8468 function Same_Base_Type 8469 (Ptype : Node_Id; 8470 Formal : Entity_Id) return Boolean 8471 is 8472 Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); 8473 Pref : Node_Id; 8474 8475 begin 8476 -- Case where pragma argument is typ'Access 8477 8478 if Nkind (Ptype) = N_Attribute_Reference 8479 and then Attribute_Name (Ptype) = Name_Access 8480 then 8481 Pref := Prefix (Ptype); 8482 Find_Type (Pref); 8483 8484 if not Is_Entity_Name (Pref) 8485 or else Entity (Pref) = Any_Type 8486 then 8487 raise Pragma_Exit; 8488 end if; 8489 8490 -- We have a match if the corresponding argument is of an 8491 -- anonymous access type, and its designated type matches the 8492 -- type of the prefix of the access attribute 8493 8494 return Ekind (Ftyp) = E_Anonymous_Access_Type 8495 and then Base_Type (Entity (Pref)) = 8496 Base_Type (Etype (Designated_Type (Ftyp))); 8497 8498 -- Case where pragma argument is a type name 8499 8500 else 8501 Find_Type (Ptype); 8502 8503 if not Is_Entity_Name (Ptype) 8504 or else Entity (Ptype) = Any_Type 8505 then 8506 raise Pragma_Exit; 8507 end if; 8508 8509 -- We have a match if the corresponding argument is of the type 8510 -- given in the pragma (comparing base types) 8511 8512 return Base_Type (Entity (Ptype)) = Ftyp; 8513 end if; 8514 end Same_Base_Type; 8515 8516 -- Start of processing for 8517 -- Process_Extended_Import_Export_Subprogram_Pragma 8518 8519 begin 8520 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 8521 Ent := Empty; 8522 Ambiguous := False; 8523 8524 -- Loop through homonyms (overloadings) of the entity 8525 8526 Hom_Id := Entity (Arg_Internal); 8527 while Present (Hom_Id) loop 8528 Def_Id := Get_Base_Subprogram (Hom_Id); 8529 8530 -- We need a subprogram in the current scope 8531 8532 if not Is_Subprogram (Def_Id) 8533 or else Scope (Def_Id) /= Current_Scope 8534 then 8535 null; 8536 8537 else 8538 Match := True; 8539 8540 -- Pragma cannot apply to subprogram body 8541 8542 if Is_Subprogram (Def_Id) 8543 and then Nkind (Parent (Declaration_Node (Def_Id))) = 8544 N_Subprogram_Body 8545 then 8546 Error_Pragma 8547 ("pragma% requires separate spec and must come before " 8548 & "body"); 8549 end if; 8550 8551 -- Test result type if given, note that the result type 8552 -- parameter can only be present for the function cases. 8553 8554 if Present (Arg_Result_Type) 8555 and then not Same_Base_Type (Arg_Result_Type, Def_Id) 8556 then 8557 Match := False; 8558 8559 elsif Etype (Def_Id) /= Standard_Void_Type 8560 and then Nam_In (Pname, Name_Export_Procedure, 8561 Name_Import_Procedure) 8562 then 8563 Match := False; 8564 8565 -- Test parameter types if given. Note that this parameter has 8566 -- not been analyzed (and must not be, since it is semantic 8567 -- nonsense), so we get it as the parser left it. 8568 8569 elsif Present (Arg_Parameter_Types) then 8570 Check_Matching_Types : declare 8571 Formal : Entity_Id; 8572 Ptype : Node_Id; 8573 8574 begin 8575 Formal := First_Formal (Def_Id); 8576 8577 if Nkind (Arg_Parameter_Types) = N_Null then 8578 if Present (Formal) then 8579 Match := False; 8580 end if; 8581 8582 -- A list of one type, e.g. (List) is parsed as a 8583 -- parenthesized expression. 8584 8585 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate 8586 and then Paren_Count (Arg_Parameter_Types) = 1 8587 then 8588 if No (Formal) 8589 or else Present (Next_Formal (Formal)) 8590 then 8591 Match := False; 8592 else 8593 Match := 8594 Same_Base_Type (Arg_Parameter_Types, Formal); 8595 end if; 8596 8597 -- A list of more than one type is parsed as a aggregate 8598 8599 elsif Nkind (Arg_Parameter_Types) = N_Aggregate 8600 and then Paren_Count (Arg_Parameter_Types) = 0 8601 then 8602 Ptype := First (Expressions (Arg_Parameter_Types)); 8603 while Present (Ptype) or else Present (Formal) loop 8604 if No (Ptype) 8605 or else No (Formal) 8606 or else not Same_Base_Type (Ptype, Formal) 8607 then 8608 Match := False; 8609 exit; 8610 else 8611 Next_Formal (Formal); 8612 Next (Ptype); 8613 end if; 8614 end loop; 8615 8616 -- Anything else is of the wrong form 8617 8618 else 8619 Error_Pragma_Arg 8620 ("wrong form for Parameter_Types parameter", 8621 Arg_Parameter_Types); 8622 end if; 8623 end Check_Matching_Types; 8624 end if; 8625 8626 -- Match is now False if the entry we found did not match 8627 -- either a supplied Parameter_Types or Result_Types argument 8628 8629 if Match then 8630 if No (Ent) then 8631 Ent := Def_Id; 8632 8633 -- Ambiguous case, the flag Ambiguous shows if we already 8634 -- detected this and output the initial messages. 8635 8636 else 8637 if not Ambiguous then 8638 Ambiguous := True; 8639 Error_Msg_Name_1 := Pname; 8640 Error_Msg_N 8641 ("pragma% does not uniquely identify subprogram!", 8642 N); 8643 Error_Msg_Sloc := Sloc (Ent); 8644 Error_Msg_N ("matching subprogram #!", N); 8645 Ent := Empty; 8646 end if; 8647 8648 Error_Msg_Sloc := Sloc (Def_Id); 8649 Error_Msg_N ("matching subprogram #!", N); 8650 end if; 8651 end if; 8652 end if; 8653 8654 Hom_Id := Homonym (Hom_Id); 8655 end loop; 8656 8657 -- See if we found an entry 8658 8659 if No (Ent) then 8660 if not Ambiguous then 8661 if Is_Generic_Subprogram (Entity (Arg_Internal)) then 8662 Error_Pragma 8663 ("pragma% cannot be given for generic subprogram"); 8664 else 8665 Error_Pragma 8666 ("pragma% does not identify local subprogram"); 8667 end if; 8668 end if; 8669 8670 return; 8671 end if; 8672 8673 -- Import pragmas must be for imported entities 8674 8675 if Prag_Id = Pragma_Import_Function 8676 or else 8677 Prag_Id = Pragma_Import_Procedure 8678 or else 8679 Prag_Id = Pragma_Import_Valued_Procedure 8680 then 8681 if not Is_Imported (Ent) then 8682 Error_Pragma 8683 ("pragma Import or Interface must precede pragma%"); 8684 end if; 8685 8686 -- Here we have the Export case which can set the entity as exported 8687 8688 -- But does not do so if the specified external name is null, since 8689 -- that is taken as a signal in DEC Ada 83 (with which we want to be 8690 -- compatible) to request no external name. 8691 8692 elsif Nkind (Arg_External) = N_String_Literal 8693 and then String_Length (Strval (Arg_External)) = 0 8694 then 8695 null; 8696 8697 -- In all other cases, set entity as exported 8698 8699 else 8700 Set_Exported (Ent, Arg_Internal); 8701 end if; 8702 8703 -- Special processing for Valued_Procedure cases 8704 8705 if Prag_Id = Pragma_Import_Valued_Procedure 8706 or else 8707 Prag_Id = Pragma_Export_Valued_Procedure 8708 then 8709 Formal := First_Formal (Ent); 8710 8711 if No (Formal) then 8712 Error_Pragma ("at least one parameter required for pragma%"); 8713 8714 elsif Ekind (Formal) /= E_Out_Parameter then 8715 Error_Pragma ("first parameter must have mode out for pragma%"); 8716 8717 else 8718 Set_Is_Valued_Procedure (Ent); 8719 end if; 8720 end if; 8721 8722 Set_Extended_Import_Export_External_Name (Ent, Arg_External); 8723 8724 -- Process Result_Mechanism argument if present. We have already 8725 -- checked that this is only allowed for the function case. 8726 8727 if Present (Arg_Result_Mechanism) then 8728 Set_Mechanism_Value (Ent, Arg_Result_Mechanism); 8729 end if; 8730 8731 -- Process Mechanism parameter if present. Note that this parameter 8732 -- is not analyzed, and must not be analyzed since it is semantic 8733 -- nonsense, so we get it in exactly as the parser left it. 8734 8735 if Present (Arg_Mechanism) then 8736 declare 8737 Formal : Entity_Id; 8738 Massoc : Node_Id; 8739 Mname : Node_Id; 8740 Choice : Node_Id; 8741 8742 begin 8743 -- A single mechanism association without a formal parameter 8744 -- name is parsed as a parenthesized expression. All other 8745 -- cases are parsed as aggregates, so we rewrite the single 8746 -- parameter case as an aggregate for consistency. 8747 8748 if Nkind (Arg_Mechanism) /= N_Aggregate 8749 and then Paren_Count (Arg_Mechanism) = 1 8750 then 8751 Rewrite (Arg_Mechanism, 8752 Make_Aggregate (Sloc (Arg_Mechanism), 8753 Expressions => New_List ( 8754 Relocate_Node (Arg_Mechanism)))); 8755 end if; 8756 8757 -- Case of only mechanism name given, applies to all formals 8758 8759 if Nkind (Arg_Mechanism) /= N_Aggregate then 8760 Formal := First_Formal (Ent); 8761 while Present (Formal) loop 8762 Set_Mechanism_Value (Formal, Arg_Mechanism); 8763 Next_Formal (Formal); 8764 end loop; 8765 8766 -- Case of list of mechanism associations given 8767 8768 else 8769 if Null_Record_Present (Arg_Mechanism) then 8770 Error_Pragma_Arg 8771 ("inappropriate form for Mechanism parameter", 8772 Arg_Mechanism); 8773 end if; 8774 8775 -- Deal with positional ones first 8776 8777 Formal := First_Formal (Ent); 8778 8779 if Present (Expressions (Arg_Mechanism)) then 8780 Mname := First (Expressions (Arg_Mechanism)); 8781 while Present (Mname) loop 8782 if No (Formal) then 8783 Error_Pragma_Arg 8784 ("too many mechanism associations", Mname); 8785 end if; 8786 8787 Set_Mechanism_Value (Formal, Mname); 8788 Next_Formal (Formal); 8789 Next (Mname); 8790 end loop; 8791 end if; 8792 8793 -- Deal with named entries 8794 8795 if Present (Component_Associations (Arg_Mechanism)) then 8796 Massoc := First (Component_Associations (Arg_Mechanism)); 8797 while Present (Massoc) loop 8798 Choice := First (Choices (Massoc)); 8799 8800 if Nkind (Choice) /= N_Identifier 8801 or else Present (Next (Choice)) 8802 then 8803 Error_Pragma_Arg 8804 ("incorrect form for mechanism association", 8805 Massoc); 8806 end if; 8807 8808 Formal := First_Formal (Ent); 8809 loop 8810 if No (Formal) then 8811 Error_Pragma_Arg 8812 ("parameter name & not present", Choice); 8813 end if; 8814 8815 if Chars (Choice) = Chars (Formal) then 8816 Set_Mechanism_Value 8817 (Formal, Expression (Massoc)); 8818 8819 -- Set entity on identifier (needed by ASIS) 8820 8821 Set_Entity (Choice, Formal); 8822 8823 exit; 8824 end if; 8825 8826 Next_Formal (Formal); 8827 end loop; 8828 8829 Next (Massoc); 8830 end loop; 8831 end if; 8832 end if; 8833 end; 8834 end if; 8835 end Process_Extended_Import_Export_Subprogram_Pragma; 8836 8837 -------------------------- 8838 -- Process_Generic_List -- 8839 -------------------------- 8840 8841 procedure Process_Generic_List is 8842 Arg : Node_Id; 8843 Exp : Node_Id; 8844 8845 begin 8846 Check_No_Identifiers; 8847 Check_At_Least_N_Arguments (1); 8848 8849 -- Check all arguments are names of generic units or instances 8850 8851 Arg := Arg1; 8852 while Present (Arg) loop 8853 Exp := Get_Pragma_Arg (Arg); 8854 Analyze (Exp); 8855 8856 if not Is_Entity_Name (Exp) 8857 or else 8858 (not Is_Generic_Instance (Entity (Exp)) 8859 and then 8860 not Is_Generic_Unit (Entity (Exp))) 8861 then 8862 Error_Pragma_Arg 8863 ("pragma% argument must be name of generic unit/instance", 8864 Arg); 8865 end if; 8866 8867 Next (Arg); 8868 end loop; 8869 end Process_Generic_List; 8870 8871 ------------------------------------ 8872 -- Process_Import_Predefined_Type -- 8873 ------------------------------------ 8874 8875 procedure Process_Import_Predefined_Type is 8876 Loc : constant Source_Ptr := Sloc (N); 8877 Elmt : Elmt_Id; 8878 Ftyp : Node_Id := Empty; 8879 Decl : Node_Id; 8880 Def : Node_Id; 8881 Nam : Name_Id; 8882 8883 begin 8884 Nam := String_To_Name (Strval (Expression (Arg3))); 8885 8886 Elmt := First_Elmt (Predefined_Float_Types); 8887 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop 8888 Next_Elmt (Elmt); 8889 end loop; 8890 8891 Ftyp := Node (Elmt); 8892 8893 if Present (Ftyp) then 8894 8895 -- Don't build a derived type declaration, because predefined C 8896 -- types have no declaration anywhere, so cannot really be named. 8897 -- Instead build a full type declaration, starting with an 8898 -- appropriate type definition is built 8899 8900 if Is_Floating_Point_Type (Ftyp) then 8901 Def := Make_Floating_Point_Definition (Loc, 8902 Make_Integer_Literal (Loc, Digits_Value (Ftyp)), 8903 Make_Real_Range_Specification (Loc, 8904 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))), 8905 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp))))); 8906 8907 -- Should never have a predefined type we cannot handle 8908 8909 else 8910 raise Program_Error; 8911 end if; 8912 8913 -- Build and insert a Full_Type_Declaration, which will be 8914 -- analyzed as soon as this list entry has been analyzed. 8915 8916 Decl := Make_Full_Type_Declaration (Loc, 8917 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))), 8918 Type_Definition => Def); 8919 8920 Insert_After (N, Decl); 8921 Mark_Rewrite_Insertion (Decl); 8922 8923 else 8924 Error_Pragma_Arg ("no matching type found for pragma%", 8925 Arg2); 8926 end if; 8927 end Process_Import_Predefined_Type; 8928 8929 --------------------------------- 8930 -- Process_Import_Or_Interface -- 8931 --------------------------------- 8932 8933 procedure Process_Import_Or_Interface is 8934 C : Convention_Id; 8935 Def_Id : Entity_Id; 8936 Hom_Id : Entity_Id; 8937 8938 begin 8939 -- In Relaxed_RM_Semantics, support old Ada 83 style: 8940 -- pragma Import (Entity, "external name"); 8941 8942 if Relaxed_RM_Semantics 8943 and then Arg_Count = 2 8944 and then Prag_Id = Pragma_Import 8945 and then Nkind (Expression (Arg2)) = N_String_Literal 8946 then 8947 C := Convention_C; 8948 Def_Id := Get_Pragma_Arg (Arg1); 8949 Analyze (Def_Id); 8950 8951 if not Is_Entity_Name (Def_Id) then 8952 Error_Pragma_Arg ("entity name required", Arg1); 8953 end if; 8954 8955 Def_Id := Entity (Def_Id); 8956 Kill_Size_Check_Code (Def_Id); 8957 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False); 8958 8959 else 8960 Process_Convention (C, Def_Id); 8961 8962 -- A pragma that applies to a Ghost entity becomes Ghost for the 8963 -- purposes of legality checks and removal of ignored Ghost code. 8964 8965 Mark_Ghost_Pragma (N, Def_Id); 8966 Kill_Size_Check_Code (Def_Id); 8967 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); 8968 end if; 8969 8970 -- Various error checks 8971 8972 if Ekind_In (Def_Id, E_Variable, E_Constant) then 8973 8974 -- We do not permit Import to apply to a renaming declaration 8975 8976 if Present (Renamed_Object (Def_Id)) then 8977 Error_Pragma_Arg 8978 ("pragma% not allowed for object renaming", Arg2); 8979 8980 -- User initialization is not allowed for imported object, but 8981 -- the object declaration may contain a default initialization, 8982 -- that will be discarded. Note that an explicit initialization 8983 -- only counts if it comes from source, otherwise it is simply 8984 -- the code generator making an implicit initialization explicit. 8985 8986 elsif Present (Expression (Parent (Def_Id))) 8987 and then Comes_From_Source 8988 (Original_Node (Expression (Parent (Def_Id)))) 8989 then 8990 -- Set imported flag to prevent cascaded errors 8991 8992 Set_Is_Imported (Def_Id); 8993 8994 Error_Msg_Sloc := Sloc (Def_Id); 8995 Error_Pragma_Arg 8996 ("no initialization allowed for declaration of& #", 8997 "\imported entities cannot be initialized (RM B.1(24))", 8998 Arg2); 8999 9000 else 9001 -- If the pragma comes from an aspect specification the 9002 -- Is_Imported flag has already been set. 9003 9004 if not From_Aspect_Specification (N) then 9005 Set_Imported (Def_Id); 9006 end if; 9007 9008 Process_Interface_Name (Def_Id, Arg3, Arg4, N); 9009 9010 -- Note that we do not set Is_Public here. That's because we 9011 -- only want to set it if there is no address clause, and we 9012 -- don't know that yet, so we delay that processing till 9013 -- freeze time. 9014 9015 -- pragma Import completes deferred constants 9016 9017 if Ekind (Def_Id) = E_Constant then 9018 Set_Has_Completion (Def_Id); 9019 end if; 9020 9021 -- It is not possible to import a constant of an unconstrained 9022 -- array type (e.g. string) because there is no simple way to 9023 -- write a meaningful subtype for it. 9024 9025 if Is_Array_Type (Etype (Def_Id)) 9026 and then not Is_Constrained (Etype (Def_Id)) 9027 then 9028 Error_Msg_NE 9029 ("imported constant& must have a constrained subtype", 9030 N, Def_Id); 9031 end if; 9032 end if; 9033 9034 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then 9035 9036 -- If the name is overloaded, pragma applies to all of the denoted 9037 -- entities in the same declarative part, unless the pragma comes 9038 -- from an aspect specification or was generated by the compiler 9039 -- (such as for pragma Provide_Shift_Operators). 9040 9041 Hom_Id := Def_Id; 9042 while Present (Hom_Id) loop 9043 9044 Def_Id := Get_Base_Subprogram (Hom_Id); 9045 9046 -- Ignore inherited subprograms because the pragma will apply 9047 -- to the parent operation, which is the one called. 9048 9049 if Is_Overloadable (Def_Id) 9050 and then Present (Alias (Def_Id)) 9051 then 9052 null; 9053 9054 -- If it is not a subprogram, it must be in an outer scope and 9055 -- pragma does not apply. 9056 9057 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then 9058 null; 9059 9060 -- The pragma does not apply to primitives of interfaces 9061 9062 elsif Is_Dispatching_Operation (Def_Id) 9063 and then Present (Find_Dispatching_Type (Def_Id)) 9064 and then Is_Interface (Find_Dispatching_Type (Def_Id)) 9065 then 9066 null; 9067 9068 -- Verify that the homonym is in the same declarative part (not 9069 -- just the same scope). If the pragma comes from an aspect 9070 -- specification we know that it is part of the declaration. 9071 9072 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) 9073 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux 9074 and then not From_Aspect_Specification (N) 9075 then 9076 exit; 9077 9078 else 9079 -- If the pragma comes from an aspect specification the 9080 -- Is_Imported flag has already been set. 9081 9082 if not From_Aspect_Specification (N) then 9083 Set_Imported (Def_Id); 9084 end if; 9085 9086 -- Reject an Import applied to an abstract subprogram 9087 9088 if Is_Subprogram (Def_Id) 9089 and then Is_Abstract_Subprogram (Def_Id) 9090 then 9091 Error_Msg_Sloc := Sloc (Def_Id); 9092 Error_Msg_NE 9093 ("cannot import abstract subprogram& declared#", 9094 Arg2, Def_Id); 9095 end if; 9096 9097 -- Special processing for Convention_Intrinsic 9098 9099 if C = Convention_Intrinsic then 9100 9101 -- Link_Name argument not allowed for intrinsic 9102 9103 Check_No_Link_Name; 9104 9105 Set_Is_Intrinsic_Subprogram (Def_Id); 9106 9107 -- If no external name is present, then check that this 9108 -- is a valid intrinsic subprogram. If an external name 9109 -- is present, then this is handled by the back end. 9110 9111 if No (Arg3) then 9112 Check_Intrinsic_Subprogram 9113 (Def_Id, Get_Pragma_Arg (Arg2)); 9114 end if; 9115 end if; 9116 9117 -- Verify that the subprogram does not have a completion 9118 -- through a renaming declaration. For other completions the 9119 -- pragma appears as a too late representation. 9120 9121 declare 9122 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); 9123 9124 begin 9125 if Present (Decl) 9126 and then Nkind (Decl) = N_Subprogram_Declaration 9127 and then Present (Corresponding_Body (Decl)) 9128 and then Nkind (Unit_Declaration_Node 9129 (Corresponding_Body (Decl))) = 9130 N_Subprogram_Renaming_Declaration 9131 then 9132 Error_Msg_Sloc := Sloc (Def_Id); 9133 Error_Msg_NE 9134 ("cannot import&, renaming already provided for " 9135 & "declaration #", N, Def_Id); 9136 end if; 9137 end; 9138 9139 -- If the pragma comes from an aspect specification, there 9140 -- must be an Import aspect specified as well. In the rare 9141 -- case where Import is set to False, the suprogram needs to 9142 -- have a local completion. 9143 9144 declare 9145 Imp_Aspect : constant Node_Id := 9146 Find_Aspect (Def_Id, Aspect_Import); 9147 Expr : Node_Id; 9148 9149 begin 9150 if Present (Imp_Aspect) 9151 and then Present (Expression (Imp_Aspect)) 9152 then 9153 Expr := Expression (Imp_Aspect); 9154 Analyze_And_Resolve (Expr, Standard_Boolean); 9155 9156 if Is_Entity_Name (Expr) 9157 and then Entity (Expr) = Standard_True 9158 then 9159 Set_Has_Completion (Def_Id); 9160 end if; 9161 9162 -- If there is no expression, the default is True, as for 9163 -- all boolean aspects. Same for the older pragma. 9164 9165 else 9166 Set_Has_Completion (Def_Id); 9167 end if; 9168 end; 9169 9170 Process_Interface_Name (Def_Id, Arg3, Arg4, N); 9171 end if; 9172 9173 if Is_Compilation_Unit (Hom_Id) then 9174 9175 -- Its possible homonyms are not affected by the pragma. 9176 -- Such homonyms might be present in the context of other 9177 -- units being compiled. 9178 9179 exit; 9180 9181 elsif From_Aspect_Specification (N) then 9182 exit; 9183 9184 -- If the pragma was created by the compiler, then we don't 9185 -- want it to apply to other homonyms. This kind of case can 9186 -- occur when using pragma Provide_Shift_Operators, which 9187 -- generates implicit shift and rotate operators with Import 9188 -- pragmas that might apply to earlier explicit or implicit 9189 -- declarations marked with Import (for example, coming from 9190 -- an earlier pragma Provide_Shift_Operators for another type), 9191 -- and we don't generally want other homonyms being treated 9192 -- as imported or the pragma flagged as an illegal duplicate. 9193 9194 elsif not Comes_From_Source (N) then 9195 exit; 9196 9197 else 9198 Hom_Id := Homonym (Hom_Id); 9199 end if; 9200 end loop; 9201 9202 -- Import a CPP class 9203 9204 elsif C = Convention_CPP 9205 and then (Is_Record_Type (Def_Id) 9206 or else Ekind (Def_Id) = E_Incomplete_Type) 9207 then 9208 if Ekind (Def_Id) = E_Incomplete_Type then 9209 if Present (Full_View (Def_Id)) then 9210 Def_Id := Full_View (Def_Id); 9211 9212 else 9213 Error_Msg_N 9214 ("cannot import 'C'P'P type before full declaration seen", 9215 Get_Pragma_Arg (Arg2)); 9216 9217 -- Although we have reported the error we decorate it as 9218 -- CPP_Class to avoid reporting spurious errors 9219 9220 Set_Is_CPP_Class (Def_Id); 9221 return; 9222 end if; 9223 end if; 9224 9225 -- Types treated as CPP classes must be declared limited (note: 9226 -- this used to be a warning but there is no real benefit to it 9227 -- since we did effectively intend to treat the type as limited 9228 -- anyway). 9229 9230 if not Is_Limited_Type (Def_Id) then 9231 Error_Msg_N 9232 ("imported 'C'P'P type must be limited", 9233 Get_Pragma_Arg (Arg2)); 9234 end if; 9235 9236 if Etype (Def_Id) /= Def_Id 9237 and then not Is_CPP_Class (Root_Type (Def_Id)) 9238 then 9239 Error_Msg_N ("root type must be a 'C'P'P type", Arg1); 9240 end if; 9241 9242 Set_Is_CPP_Class (Def_Id); 9243 9244 -- Imported CPP types must not have discriminants (because C++ 9245 -- classes do not have discriminants). 9246 9247 if Has_Discriminants (Def_Id) then 9248 Error_Msg_N 9249 ("imported 'C'P'P type cannot have discriminants", 9250 First (Discriminant_Specifications 9251 (Declaration_Node (Def_Id)))); 9252 end if; 9253 9254 -- Check that components of imported CPP types do not have default 9255 -- expressions. For private types this check is performed when the 9256 -- full view is analyzed (see Process_Full_View). 9257 9258 if not Is_Private_Type (Def_Id) then 9259 Check_CPP_Type_Has_No_Defaults (Def_Id); 9260 end if; 9261 9262 -- Import a CPP exception 9263 9264 elsif C = Convention_CPP 9265 and then Ekind (Def_Id) = E_Exception 9266 then 9267 if No (Arg3) then 9268 Error_Pragma_Arg 9269 ("'External_'Name arguments is required for 'Cpp exception", 9270 Arg3); 9271 else 9272 -- As only a string is allowed, Check_Arg_Is_External_Name 9273 -- isn't called. 9274 9275 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 9276 end if; 9277 9278 if Present (Arg4) then 9279 Error_Pragma_Arg 9280 ("Link_Name argument not allowed for imported Cpp exception", 9281 Arg4); 9282 end if; 9283 9284 -- Do not call Set_Interface_Name as the name of the exception 9285 -- shouldn't be modified (and in particular it shouldn't be 9286 -- the External_Name). For exceptions, the External_Name is the 9287 -- name of the RTTI structure. 9288 9289 -- ??? Emit an error if pragma Import/Export_Exception is present 9290 9291 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then 9292 Check_No_Link_Name; 9293 Check_Arg_Count (3); 9294 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 9295 9296 Process_Import_Predefined_Type; 9297 9298 else 9299 Error_Pragma_Arg 9300 ("second argument of pragma% must be object, subprogram " 9301 & "or incomplete type", 9302 Arg2); 9303 end if; 9304 9305 -- If this pragma applies to a compilation unit, then the unit, which 9306 -- is a subprogram, does not require (or allow) a body. We also do 9307 -- not need to elaborate imported procedures. 9308 9309 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 9310 declare 9311 Cunit : constant Node_Id := Parent (Parent (N)); 9312 begin 9313 Set_Body_Required (Cunit, False); 9314 end; 9315 end if; 9316 end Process_Import_Or_Interface; 9317 9318 -------------------- 9319 -- Process_Inline -- 9320 -------------------- 9321 9322 procedure Process_Inline (Status : Inline_Status) is 9323 Applies : Boolean; 9324 Assoc : Node_Id; 9325 Decl : Node_Id; 9326 Subp : Entity_Id; 9327 Subp_Id : Node_Id; 9328 9329 Ghost_Error_Posted : Boolean := False; 9330 -- Flag set when an error concerning the illegal mix of Ghost and 9331 -- non-Ghost subprograms is emitted. 9332 9333 Ghost_Id : Entity_Id := Empty; 9334 -- The entity of the first Ghost subprogram encountered while 9335 -- processing the arguments of the pragma. 9336 9337 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id); 9338 -- Verify the placement of pragma Inline_Always with respect to the 9339 -- initial declaration of subprogram Spec_Id. 9340 9341 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; 9342 -- Returns True if it can be determined at this stage that inlining 9343 -- is not possible, for example if the body is available and contains 9344 -- exception handlers, we prevent inlining, since otherwise we can 9345 -- get undefined symbols at link time. This function also emits a 9346 -- warning if the pragma appears too late. 9347 -- 9348 -- ??? is business with link symbols still valid, or does it relate 9349 -- to front end ZCX which is being phased out ??? 9350 9351 procedure Make_Inline (Subp : Entity_Id); 9352 -- Subp is the defining unit name of the subprogram declaration. If 9353 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on 9354 -- the corresponding body, if there is one present. 9355 9356 procedure Set_Inline_Flags (Subp : Entity_Id); 9357 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp. 9358 -- Also set or clear Is_Inlined flag on Subp depending on Status. 9359 9360 ----------------------------------- 9361 -- Check_Inline_Always_Placement -- 9362 ----------------------------------- 9363 9364 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is 9365 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 9366 9367 function Compilation_Unit_OK return Boolean; 9368 pragma Inline (Compilation_Unit_OK); 9369 -- Determine whether pragma Inline_Always applies to a compatible 9370 -- compilation unit denoted by Spec_Id. 9371 9372 function Declarative_List_OK return Boolean; 9373 pragma Inline (Declarative_List_OK); 9374 -- Determine whether the initial declaration of subprogram Spec_Id 9375 -- and the pragma appear in compatible declarative lists. 9376 9377 function Subprogram_Body_OK return Boolean; 9378 pragma Inline (Subprogram_Body_OK); 9379 -- Determine whether pragma Inline_Always applies to a compatible 9380 -- subprogram body denoted by Spec_Id. 9381 9382 ------------------------- 9383 -- Compilation_Unit_OK -- 9384 ------------------------- 9385 9386 function Compilation_Unit_OK return Boolean is 9387 Comp_Unit : constant Node_Id := Parent (Spec_Decl); 9388 9389 begin 9390 -- The pragma appears after the initial declaration of a 9391 -- compilation unit. 9392 9393 -- procedure Comp_Unit; 9394 -- pragma Inline_Always (Comp_Unit); 9395 9396 -- Note that for compatibility reasons, the following case is 9397 -- also accepted. 9398 9399 -- procedure Stand_Alone_Body_Comp_Unit is 9400 -- ... 9401 -- end Stand_Alone_Body_Comp_Unit; 9402 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit); 9403 9404 return 9405 Nkind (Comp_Unit) = N_Compilation_Unit 9406 and then Present (Aux_Decls_Node (Comp_Unit)) 9407 and then Is_List_Member (N) 9408 and then List_Containing (N) = 9409 Pragmas_After (Aux_Decls_Node (Comp_Unit)); 9410 end Compilation_Unit_OK; 9411 9412 ------------------------- 9413 -- Declarative_List_OK -- 9414 ------------------------- 9415 9416 function Declarative_List_OK return Boolean is 9417 Context : constant Node_Id := Parent (Spec_Decl); 9418 9419 Init_Decl : Node_Id; 9420 Init_List : List_Id; 9421 Prag_List : List_Id; 9422 9423 begin 9424 -- Determine the proper initial declaration. In general this is 9425 -- the declaration node of the subprogram except when the input 9426 -- denotes a generic instantiation. 9427 9428 -- procedure Inst is new Gen; 9429 -- pragma Inline_Always (Inst); 9430 9431 -- In this case the original subprogram is moved inside an 9432 -- anonymous package while pragma Inline_Always remains at the 9433 -- level of the anonymous package. Use the declaration of the 9434 -- package because it reflects the placement of the original 9435 -- instantiation. 9436 9437 -- package Anon_Pack is 9438 -- procedure Inst is ... end Inst; -- original 9439 -- end Anon_Pack; 9440 9441 -- procedure Inst renames Anon_Pack.Inst; 9442 -- pragma Inline_Always (Inst); 9443 9444 if Is_Generic_Instance (Spec_Id) then 9445 Init_Decl := Parent (Parent (Spec_Decl)); 9446 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration); 9447 else 9448 Init_Decl := Spec_Decl; 9449 end if; 9450 9451 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then 9452 Init_List := List_Containing (Init_Decl); 9453 Prag_List := List_Containing (N); 9454 9455 -- The pragma and then initial declaration appear within the 9456 -- same declarative list. 9457 9458 if Init_List = Prag_List then 9459 return True; 9460 9461 -- A special case of the above is when both the pragma and 9462 -- the initial declaration appear in different lists of a 9463 -- package spec, protected definition, or a task definition. 9464 9465 -- package Pack is 9466 -- procedure Proc; 9467 -- private 9468 -- pragma Inline_Always (Proc); 9469 -- end Pack; 9470 9471 elsif Nkind_In (Context, N_Package_Specification, 9472 N_Protected_Definition, 9473 N_Task_Definition) 9474 and then Init_List = Visible_Declarations (Context) 9475 and then Prag_List = Private_Declarations (Context) 9476 then 9477 return True; 9478 end if; 9479 end if; 9480 9481 return False; 9482 end Declarative_List_OK; 9483 9484 ------------------------ 9485 -- Subprogram_Body_OK -- 9486 ------------------------ 9487 9488 function Subprogram_Body_OK return Boolean is 9489 Body_Decl : Node_Id; 9490 9491 begin 9492 -- The pragma appears within the declarative list of a stand- 9493 -- alone subprogram body. 9494 9495 -- procedure Stand_Alone_Body is 9496 -- pragma Inline_Always (Stand_Alone_Body); 9497 -- begin 9498 -- ... 9499 -- end Stand_Alone_Body; 9500 9501 -- The compiler creates a dummy spec in this case, however the 9502 -- pragma remains within the declarative list of the body. 9503 9504 if Nkind (Spec_Decl) = N_Subprogram_Declaration 9505 and then not Comes_From_Source (Spec_Decl) 9506 and then Present (Corresponding_Body (Spec_Decl)) 9507 then 9508 Body_Decl := 9509 Unit_Declaration_Node (Corresponding_Body (Spec_Decl)); 9510 9511 if Present (Declarations (Body_Decl)) 9512 and then Is_List_Member (N) 9513 and then List_Containing (N) = Declarations (Body_Decl) 9514 then 9515 return True; 9516 end if; 9517 end if; 9518 9519 return False; 9520 end Subprogram_Body_OK; 9521 9522 -- Start of processing for Check_Inline_Always_Placement 9523 9524 begin 9525 -- This check is relevant only for pragma Inline_Always 9526 9527 if Pname /= Name_Inline_Always then 9528 return; 9529 9530 -- Nothing to do when the pragma is internally generated on the 9531 -- assumption that it is properly placed. 9532 9533 elsif not Comes_From_Source (N) then 9534 return; 9535 9536 -- Nothing to do for internally generated subprograms that act 9537 -- as accidental homonyms of a source subprogram being inlined. 9538 9539 elsif not Comes_From_Source (Spec_Id) then 9540 return; 9541 9542 -- Nothing to do for generic formal subprograms that act as 9543 -- homonyms of another source subprogram being inlined. 9544 9545 elsif Is_Formal_Subprogram (Spec_Id) then 9546 return; 9547 9548 elsif Compilation_Unit_OK 9549 or else Declarative_List_OK 9550 or else Subprogram_Body_OK 9551 then 9552 return; 9553 end if; 9554 9555 -- At this point it is known that the pragma applies to or appears 9556 -- within a completing body, a completing stub, or a subunit. 9557 9558 Error_Msg_Name_1 := Pname; 9559 Error_Msg_Name_2 := Chars (Spec_Id); 9560 Error_Msg_Sloc := Sloc (Spec_Id); 9561 9562 Error_Msg_N 9563 ("pragma % must appear on initial declaration of subprogram " 9564 & "% defined #", N); 9565 end Check_Inline_Always_Placement; 9566 9567 --------------------------- 9568 -- Inlining_Not_Possible -- 9569 --------------------------- 9570 9571 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is 9572 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 9573 Stats : Node_Id; 9574 9575 begin 9576 if Nkind (Decl) = N_Subprogram_Body then 9577 Stats := Handled_Statement_Sequence (Decl); 9578 return Present (Exception_Handlers (Stats)) 9579 or else Present (At_End_Proc (Stats)); 9580 9581 elsif Nkind (Decl) = N_Subprogram_Declaration 9582 and then Present (Corresponding_Body (Decl)) 9583 then 9584 if Analyzed (Corresponding_Body (Decl)) then 9585 Error_Msg_N ("pragma appears too late, ignored??", N); 9586 return True; 9587 9588 -- If the subprogram is a renaming as body, the body is just a 9589 -- call to the renamed subprogram, and inlining is trivially 9590 -- possible. 9591 9592 elsif 9593 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = 9594 N_Subprogram_Renaming_Declaration 9595 then 9596 return False; 9597 9598 else 9599 Stats := 9600 Handled_Statement_Sequence 9601 (Unit_Declaration_Node (Corresponding_Body (Decl))); 9602 9603 return 9604 Present (Exception_Handlers (Stats)) 9605 or else Present (At_End_Proc (Stats)); 9606 end if; 9607 9608 else 9609 -- If body is not available, assume the best, the check is 9610 -- performed again when compiling enclosing package bodies. 9611 9612 return False; 9613 end if; 9614 end Inlining_Not_Possible; 9615 9616 ----------------- 9617 -- Make_Inline -- 9618 ----------------- 9619 9620 procedure Make_Inline (Subp : Entity_Id) is 9621 Kind : constant Entity_Kind := Ekind (Subp); 9622 Inner_Subp : Entity_Id := Subp; 9623 9624 begin 9625 -- Ignore if bad type, avoid cascaded error 9626 9627 if Etype (Subp) = Any_Type then 9628 Applies := True; 9629 return; 9630 9631 -- If inlining is not possible, for now do not treat as an error 9632 9633 elsif Status /= Suppressed 9634 and then Front_End_Inlining 9635 and then Inlining_Not_Possible (Subp) 9636 then 9637 Applies := True; 9638 return; 9639 9640 -- Here we have a candidate for inlining, but we must exclude 9641 -- derived operations. Otherwise we would end up trying to inline 9642 -- a phantom declaration, and the result would be to drag in a 9643 -- body which has no direct inlining associated with it. That 9644 -- would not only be inefficient but would also result in the 9645 -- backend doing cross-unit inlining in cases where it was 9646 -- definitely inappropriate to do so. 9647 9648 -- However, a simple Comes_From_Source test is insufficient, since 9649 -- we do want to allow inlining of generic instances which also do 9650 -- not come from source. We also need to recognize specs generated 9651 -- by the front-end for bodies that carry the pragma. Finally, 9652 -- predefined operators do not come from source but are not 9653 -- inlineable either. 9654 9655 elsif Is_Generic_Instance (Subp) 9656 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration 9657 then 9658 null; 9659 9660 elsif not Comes_From_Source (Subp) 9661 and then Scope (Subp) /= Standard_Standard 9662 then 9663 Applies := True; 9664 return; 9665 end if; 9666 9667 -- The referenced entity must either be the enclosing entity, or 9668 -- an entity declared within the current open scope. 9669 9670 if Present (Scope (Subp)) 9671 and then Scope (Subp) /= Current_Scope 9672 and then Subp /= Current_Scope 9673 then 9674 Error_Pragma_Arg 9675 ("argument of% must be entity in current scope", Assoc); 9676 return; 9677 end if; 9678 9679 -- Processing for procedure, operator or function. If subprogram 9680 -- is aliased (as for an instance) indicate that the renamed 9681 -- entity (if declared in the same unit) is inlined. 9682 -- If this is the anonymous subprogram created for a subprogram 9683 -- instance, the inlining applies to it directly. Otherwise we 9684 -- retrieve it as the alias of the visible subprogram instance. 9685 9686 if Is_Subprogram (Subp) then 9687 9688 -- Ensure that pragma Inline_Always is associated with the 9689 -- initial declaration of the subprogram. 9690 9691 Check_Inline_Always_Placement (Subp); 9692 9693 if Is_Wrapper_Package (Scope (Subp)) then 9694 Inner_Subp := Subp; 9695 else 9696 Inner_Subp := Ultimate_Alias (Inner_Subp); 9697 end if; 9698 9699 if In_Same_Source_Unit (Subp, Inner_Subp) then 9700 Set_Inline_Flags (Inner_Subp); 9701 9702 Decl := Parent (Parent (Inner_Subp)); 9703 9704 if Nkind (Decl) = N_Subprogram_Declaration 9705 and then Present (Corresponding_Body (Decl)) 9706 then 9707 Set_Inline_Flags (Corresponding_Body (Decl)); 9708 9709 elsif Is_Generic_Instance (Subp) 9710 and then Comes_From_Source (Subp) 9711 then 9712 -- Indicate that the body needs to be created for 9713 -- inlining subsequent calls. The instantiation node 9714 -- follows the declaration of the wrapper package 9715 -- created for it. The subprogram that requires the 9716 -- body is the anonymous one in the wrapper package. 9717 9718 if Scope (Subp) /= Standard_Standard 9719 and then 9720 Need_Subprogram_Instance_Body 9721 (Next (Unit_Declaration_Node 9722 (Scope (Alias (Subp)))), Subp) 9723 then 9724 null; 9725 end if; 9726 9727 -- Inline is a program unit pragma (RM 10.1.5) and cannot 9728 -- appear in a formal part to apply to a formal subprogram. 9729 -- Do not apply check within an instance or a formal package 9730 -- the test will have been applied to the original generic. 9731 9732 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration 9733 and then List_Containing (Decl) = List_Containing (N) 9734 and then not In_Instance 9735 then 9736 Error_Msg_N 9737 ("Inline cannot apply to a formal subprogram", N); 9738 9739 -- If Subp is a renaming, it is the renamed entity that 9740 -- will appear in any call, and be inlined. However, for 9741 -- ASIS uses it is convenient to indicate that the renaming 9742 -- itself is an inlined subprogram, so that some gnatcheck 9743 -- rules can be applied in the absence of expansion. 9744 9745 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then 9746 Set_Inline_Flags (Subp); 9747 end if; 9748 end if; 9749 9750 Applies := True; 9751 9752 -- For a generic subprogram set flag as well, for use at the point 9753 -- of instantiation, to determine whether the body should be 9754 -- generated. 9755 9756 elsif Is_Generic_Subprogram (Subp) then 9757 Set_Inline_Flags (Subp); 9758 Applies := True; 9759 9760 -- Literals are by definition inlined 9761 9762 elsif Kind = E_Enumeration_Literal then 9763 null; 9764 9765 -- Anything else is an error 9766 9767 else 9768 Error_Pragma_Arg 9769 ("expect subprogram name for pragma%", Assoc); 9770 end if; 9771 end Make_Inline; 9772 9773 ---------------------- 9774 -- Set_Inline_Flags -- 9775 ---------------------- 9776 9777 procedure Set_Inline_Flags (Subp : Entity_Id) is 9778 begin 9779 -- First set the Has_Pragma_XXX flags and issue the appropriate 9780 -- errors and warnings for suspicious combinations. 9781 9782 if Prag_Id = Pragma_No_Inline then 9783 if Has_Pragma_Inline_Always (Subp) then 9784 Error_Msg_N 9785 ("Inline_Always and No_Inline are mutually exclusive", N); 9786 elsif Has_Pragma_Inline (Subp) then 9787 Error_Msg_NE 9788 ("Inline and No_Inline both specified for& ??", 9789 N, Entity (Subp_Id)); 9790 end if; 9791 9792 Set_Has_Pragma_No_Inline (Subp); 9793 else 9794 if Prag_Id = Pragma_Inline_Always then 9795 if Has_Pragma_No_Inline (Subp) then 9796 Error_Msg_N 9797 ("Inline_Always and No_Inline are mutually exclusive", 9798 N); 9799 end if; 9800 9801 Set_Has_Pragma_Inline_Always (Subp); 9802 else 9803 if Has_Pragma_No_Inline (Subp) then 9804 Error_Msg_NE 9805 ("Inline and No_Inline both specified for& ??", 9806 N, Entity (Subp_Id)); 9807 end if; 9808 end if; 9809 9810 Set_Has_Pragma_Inline (Subp); 9811 end if; 9812 9813 -- Then adjust the Is_Inlined flag. It can never be set if the 9814 -- subprogram is subject to pragma No_Inline. 9815 9816 case Status is 9817 when Suppressed => 9818 Set_Is_Inlined (Subp, False); 9819 9820 when Disabled => 9821 null; 9822 9823 when Enabled => 9824 if not Has_Pragma_No_Inline (Subp) then 9825 Set_Is_Inlined (Subp, True); 9826 end if; 9827 end case; 9828 9829 -- A pragma that applies to a Ghost entity becomes Ghost for the 9830 -- purposes of legality checks and removal of ignored Ghost code. 9831 9832 Mark_Ghost_Pragma (N, Subp); 9833 9834 -- Capture the entity of the first Ghost subprogram being 9835 -- processed for error detection purposes. 9836 9837 if Is_Ghost_Entity (Subp) then 9838 if No (Ghost_Id) then 9839 Ghost_Id := Subp; 9840 end if; 9841 9842 -- Otherwise the subprogram is non-Ghost. It is illegal to mix 9843 -- references to Ghost and non-Ghost entities (SPARK RM 6.9). 9844 9845 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then 9846 Ghost_Error_Posted := True; 9847 9848 Error_Msg_Name_1 := Pname; 9849 Error_Msg_N 9850 ("pragma % cannot mention ghost and non-ghost subprograms", 9851 N); 9852 9853 Error_Msg_Sloc := Sloc (Ghost_Id); 9854 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 9855 9856 Error_Msg_Sloc := Sloc (Subp); 9857 Error_Msg_NE ("\& # declared as non-ghost", N, Subp); 9858 end if; 9859 end Set_Inline_Flags; 9860 9861 -- Start of processing for Process_Inline 9862 9863 begin 9864 Check_No_Identifiers; 9865 Check_At_Least_N_Arguments (1); 9866 9867 if Status = Enabled then 9868 Inline_Processing_Required := True; 9869 end if; 9870 9871 Assoc := Arg1; 9872 while Present (Assoc) loop 9873 Subp_Id := Get_Pragma_Arg (Assoc); 9874 Analyze (Subp_Id); 9875 Applies := False; 9876 9877 if Is_Entity_Name (Subp_Id) then 9878 Subp := Entity (Subp_Id); 9879 9880 if Subp = Any_Id then 9881 9882 -- If previous error, avoid cascaded errors 9883 9884 Check_Error_Detected; 9885 Applies := True; 9886 9887 else 9888 Make_Inline (Subp); 9889 9890 -- For the pragma case, climb homonym chain. This is 9891 -- what implements allowing the pragma in the renaming 9892 -- case, with the result applying to the ancestors, and 9893 -- also allows Inline to apply to all previous homonyms. 9894 9895 if not From_Aspect_Specification (N) then 9896 while Present (Homonym (Subp)) 9897 and then Scope (Homonym (Subp)) = Current_Scope 9898 loop 9899 Make_Inline (Homonym (Subp)); 9900 Subp := Homonym (Subp); 9901 end loop; 9902 end if; 9903 end if; 9904 end if; 9905 9906 if not Applies then 9907 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc); 9908 end if; 9909 9910 Next (Assoc); 9911 end loop; 9912 9913 -- If the context is a package declaration, the pragma indicates 9914 -- that inlining will require the presence of the corresponding 9915 -- body. (this may be further refined). 9916 9917 if not In_Instance 9918 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 9919 N_Package_Declaration 9920 then 9921 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit)); 9922 end if; 9923 end Process_Inline; 9924 9925 ---------------------------- 9926 -- Process_Interface_Name -- 9927 ---------------------------- 9928 9929 procedure Process_Interface_Name 9930 (Subprogram_Def : Entity_Id; 9931 Ext_Arg : Node_Id; 9932 Link_Arg : Node_Id; 9933 Prag : Node_Id) 9934 is 9935 Ext_Nam : Node_Id; 9936 Link_Nam : Node_Id; 9937 String_Val : String_Id; 9938 9939 procedure Check_Form_Of_Interface_Name (SN : Node_Id); 9940 -- SN is a string literal node for an interface name. This routine 9941 -- performs some minimal checks that the name is reasonable. In 9942 -- particular that no spaces or other obviously incorrect characters 9943 -- appear. This is only a warning, since any characters are allowed. 9944 9945 ---------------------------------- 9946 -- Check_Form_Of_Interface_Name -- 9947 ---------------------------------- 9948 9949 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is 9950 S : constant String_Id := Strval (Expr_Value_S (SN)); 9951 SL : constant Nat := String_Length (S); 9952 C : Char_Code; 9953 9954 begin 9955 if SL = 0 then 9956 Error_Msg_N ("interface name cannot be null string", SN); 9957 end if; 9958 9959 for J in 1 .. SL loop 9960 C := Get_String_Char (S, J); 9961 9962 -- Look for dubious character and issue unconditional warning. 9963 -- Definitely dubious if not in character range. 9964 9965 if not In_Character_Range (C) 9966 9967 -- Commas, spaces and (back)slashes are dubious 9968 9969 or else Get_Character (C) = ',' 9970 or else Get_Character (C) = '\' 9971 or else Get_Character (C) = ' ' 9972 or else Get_Character (C) = '/' 9973 then 9974 Error_Msg 9975 ("??interface name contains illegal character", 9976 Sloc (SN) + Source_Ptr (J)); 9977 end if; 9978 end loop; 9979 end Check_Form_Of_Interface_Name; 9980 9981 -- Start of processing for Process_Interface_Name 9982 9983 begin 9984 -- If we are looking at a pragma that comes from an aspect then it 9985 -- needs to have its corresponding aspect argument expressions 9986 -- analyzed in addition to the generated pragma so that aspects 9987 -- within generic units get properly resolved. 9988 9989 if Present (Prag) and then From_Aspect_Specification (Prag) then 9990 declare 9991 Asp : constant Node_Id := Corresponding_Aspect (Prag); 9992 Dummy_1 : Node_Id; 9993 Dummy_2 : Node_Id; 9994 Dummy_3 : Node_Id; 9995 EN : Node_Id; 9996 LN : Node_Id; 9997 9998 begin 9999 -- Obtain all interfacing aspects used to construct the pragma 10000 10001 Get_Interfacing_Aspects 10002 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN); 10003 10004 -- Analyze the expression of aspect External_Name 10005 10006 if Present (EN) then 10007 Analyze (Expression (EN)); 10008 end if; 10009 10010 -- Analyze the expressio of aspect Link_Name 10011 10012 if Present (LN) then 10013 Analyze (Expression (LN)); 10014 end if; 10015 end; 10016 end if; 10017 10018 if No (Link_Arg) then 10019 if No (Ext_Arg) then 10020 return; 10021 10022 elsif Chars (Ext_Arg) = Name_Link_Name then 10023 Ext_Nam := Empty; 10024 Link_Nam := Expression (Ext_Arg); 10025 10026 else 10027 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 10028 Ext_Nam := Expression (Ext_Arg); 10029 Link_Nam := Empty; 10030 end if; 10031 10032 else 10033 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 10034 Check_Optional_Identifier (Link_Arg, Name_Link_Name); 10035 Ext_Nam := Expression (Ext_Arg); 10036 Link_Nam := Expression (Link_Arg); 10037 end if; 10038 10039 -- Check expressions for external name and link name are static 10040 10041 if Present (Ext_Nam) then 10042 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String); 10043 Check_Form_Of_Interface_Name (Ext_Nam); 10044 10045 -- Verify that external name is not the name of a local entity, 10046 -- which would hide the imported one and could lead to run-time 10047 -- surprises. The problem can only arise for entities declared in 10048 -- a package body (otherwise the external name is fully qualified 10049 -- and will not conflict). 10050 10051 declare 10052 Nam : Name_Id; 10053 E : Entity_Id; 10054 Par : Node_Id; 10055 10056 begin 10057 if Prag_Id = Pragma_Import then 10058 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam))); 10059 E := Entity_Id (Get_Name_Table_Int (Nam)); 10060 10061 if Nam /= Chars (Subprogram_Def) 10062 and then Present (E) 10063 and then not Is_Overloadable (E) 10064 and then Is_Immediately_Visible (E) 10065 and then not Is_Imported (E) 10066 and then Ekind (Scope (E)) = E_Package 10067 then 10068 Par := Parent (E); 10069 while Present (Par) loop 10070 if Nkind (Par) = N_Package_Body then 10071 Error_Msg_Sloc := Sloc (E); 10072 Error_Msg_NE 10073 ("imported entity is hidden by & declared#", 10074 Ext_Arg, E); 10075 exit; 10076 end if; 10077 10078 Par := Parent (Par); 10079 end loop; 10080 end if; 10081 end if; 10082 end; 10083 end if; 10084 10085 if Present (Link_Nam) then 10086 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String); 10087 Check_Form_Of_Interface_Name (Link_Nam); 10088 end if; 10089 10090 -- If there is no link name, just set the external name 10091 10092 if No (Link_Nam) then 10093 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); 10094 10095 -- For the Link_Name case, the given literal is preceded by an 10096 -- asterisk, which indicates to GCC that the given name should be 10097 -- taken literally, and in particular that no prepending of 10098 -- underlines should occur, even in systems where this is the 10099 -- normal default. 10100 10101 else 10102 Start_String; 10103 Store_String_Char (Get_Char_Code ('*')); 10104 String_Val := Strval (Expr_Value_S (Link_Nam)); 10105 Store_String_Chars (String_Val); 10106 Link_Nam := 10107 Make_String_Literal (Sloc (Link_Nam), 10108 Strval => End_String); 10109 end if; 10110 10111 -- Set the interface name. If the entity is a generic instance, use 10112 -- its alias, which is the callable entity. 10113 10114 if Is_Generic_Instance (Subprogram_Def) then 10115 Set_Encoded_Interface_Name 10116 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); 10117 else 10118 Set_Encoded_Interface_Name 10119 (Get_Base_Subprogram (Subprogram_Def), Link_Nam); 10120 end if; 10121 10122 Check_Duplicated_Export_Name (Link_Nam); 10123 end Process_Interface_Name; 10124 10125 ----------------------------------------- 10126 -- Process_Interrupt_Or_Attach_Handler -- 10127 ----------------------------------------- 10128 10129 procedure Process_Interrupt_Or_Attach_Handler is 10130 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1)); 10131 Prot_Typ : constant Entity_Id := Scope (Handler); 10132 10133 begin 10134 -- A pragma that applies to a Ghost entity becomes Ghost for the 10135 -- purposes of legality checks and removal of ignored Ghost code. 10136 10137 Mark_Ghost_Pragma (N, Handler); 10138 Set_Is_Interrupt_Handler (Handler); 10139 10140 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type); 10141 10142 Record_Rep_Item (Prot_Typ, N); 10143 10144 -- Chain the pragma on the contract for completeness 10145 10146 Add_Contract_Item (N, Handler); 10147 end Process_Interrupt_Or_Attach_Handler; 10148 10149 -------------------------------------------------- 10150 -- Process_Restrictions_Or_Restriction_Warnings -- 10151 -------------------------------------------------- 10152 10153 -- Note: some of the simple identifier cases were handled in par-prag, 10154 -- but it is harmless (and more straightforward) to simply handle all 10155 -- cases here, even if it means we repeat a bit of work in some cases. 10156 10157 procedure Process_Restrictions_Or_Restriction_Warnings 10158 (Warn : Boolean) 10159 is 10160 Arg : Node_Id; 10161 R_Id : Restriction_Id; 10162 Id : Name_Id; 10163 Expr : Node_Id; 10164 Val : Uint; 10165 10166 begin 10167 -- Ignore all Restrictions pragmas in CodePeer mode 10168 10169 if CodePeer_Mode then 10170 return; 10171 end if; 10172 10173 Check_Ada_83_Warning; 10174 Check_At_Least_N_Arguments (1); 10175 Check_Valid_Configuration_Pragma; 10176 10177 Arg := Arg1; 10178 while Present (Arg) loop 10179 Id := Chars (Arg); 10180 Expr := Get_Pragma_Arg (Arg); 10181 10182 -- Case of no restriction identifier present 10183 10184 if Id = No_Name then 10185 if Nkind (Expr) /= N_Identifier then 10186 Error_Pragma_Arg 10187 ("invalid form for restriction", Arg); 10188 end if; 10189 10190 R_Id := 10191 Get_Restriction_Id 10192 (Process_Restriction_Synonyms (Expr)); 10193 10194 if R_Id not in All_Boolean_Restrictions then 10195 Error_Msg_Name_1 := Pname; 10196 Error_Msg_N 10197 ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); 10198 10199 -- Check for possible misspelling 10200 10201 for J in Restriction_Id loop 10202 declare 10203 Rnm : constant String := Restriction_Id'Image (J); 10204 10205 begin 10206 Name_Buffer (1 .. Rnm'Length) := Rnm; 10207 Name_Len := Rnm'Length; 10208 Set_Casing (All_Lower_Case); 10209 10210 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then 10211 Set_Casing 10212 (Identifier_Casing 10213 (Source_Index (Current_Sem_Unit))); 10214 Error_Msg_String (1 .. Rnm'Length) := 10215 Name_Buffer (1 .. Name_Len); 10216 Error_Msg_Strlen := Rnm'Length; 10217 Error_Msg_N -- CODEFIX 10218 ("\possible misspelling of ""~""", 10219 Get_Pragma_Arg (Arg)); 10220 exit; 10221 end if; 10222 end; 10223 end loop; 10224 10225 raise Pragma_Exit; 10226 end if; 10227 10228 if Implementation_Restriction (R_Id) then 10229 Check_Restriction (No_Implementation_Restrictions, Arg); 10230 end if; 10231 10232 -- Special processing for No_Elaboration_Code restriction 10233 10234 if R_Id = No_Elaboration_Code then 10235 10236 -- Restriction is only recognized within a configuration 10237 -- pragma file, or within a unit of the main extended 10238 -- program. Note: the test for Main_Unit is needed to 10239 -- properly include the case of configuration pragma files. 10240 10241 if not (Current_Sem_Unit = Main_Unit 10242 or else In_Extended_Main_Source_Unit (N)) 10243 then 10244 return; 10245 10246 -- Don't allow in a subunit unless already specified in 10247 -- body or spec. 10248 10249 elsif Nkind (Parent (N)) = N_Compilation_Unit 10250 and then Nkind (Unit (Parent (N))) = N_Subunit 10251 and then not Restriction_Active (No_Elaboration_Code) 10252 then 10253 Error_Msg_N 10254 ("invalid specification of ""No_Elaboration_Code""", 10255 N); 10256 Error_Msg_N 10257 ("\restriction cannot be specified in a subunit", N); 10258 Error_Msg_N 10259 ("\unless also specified in body or spec", N); 10260 return; 10261 10262 -- If we accept a No_Elaboration_Code restriction, then it 10263 -- needs to be added to the configuration restriction set so 10264 -- that we get proper application to other units in the main 10265 -- extended source as required. 10266 10267 else 10268 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 10269 end if; 10270 end if; 10271 10272 -- If this is a warning, then set the warning unless we already 10273 -- have a real restriction active (we never want a warning to 10274 -- override a real restriction). 10275 10276 if Warn then 10277 if not Restriction_Active (R_Id) then 10278 Set_Restriction (R_Id, N); 10279 Restriction_Warnings (R_Id) := True; 10280 end if; 10281 10282 -- If real restriction case, then set it and make sure that the 10283 -- restriction warning flag is off, since a real restriction 10284 -- always overrides a warning. 10285 10286 else 10287 Set_Restriction (R_Id, N); 10288 Restriction_Warnings (R_Id) := False; 10289 end if; 10290 10291 -- Check for obsolescent restrictions in Ada 2005 mode 10292 10293 if not Warn 10294 and then Ada_Version >= Ada_2005 10295 and then (R_Id = No_Asynchronous_Control 10296 or else 10297 R_Id = No_Unchecked_Deallocation 10298 or else 10299 R_Id = No_Unchecked_Conversion) 10300 then 10301 Check_Restriction (No_Obsolescent_Features, N); 10302 end if; 10303 10304 -- A very special case that must be processed here: pragma 10305 -- Restrictions (No_Exceptions) turns off all run-time 10306 -- checking. This is a bit dubious in terms of the formal 10307 -- language definition, but it is what is intended by RM 10308 -- H.4(12). Restriction_Warnings never affects generated code 10309 -- so this is done only in the real restriction case. 10310 10311 -- Atomic_Synchronization is not a real check, so it is not 10312 -- affected by this processing). 10313 10314 -- Ignore the effect of pragma Restrictions (No_Exceptions) on 10315 -- run-time checks in CodePeer and GNATprove modes: we want to 10316 -- generate checks for analysis purposes, as set respectively 10317 -- by -gnatC and -gnatd.F 10318 10319 if not Warn 10320 and then not (CodePeer_Mode or GNATprove_Mode) 10321 and then R_Id = No_Exceptions 10322 then 10323 for J in Scope_Suppress.Suppress'Range loop 10324 if J /= Atomic_Synchronization then 10325 Scope_Suppress.Suppress (J) := True; 10326 end if; 10327 end loop; 10328 end if; 10329 10330 -- Case of No_Dependence => unit-name. Note that the parser 10331 -- already made the necessary entry in the No_Dependence table. 10332 10333 elsif Id = Name_No_Dependence then 10334 if not OK_No_Dependence_Unit_Name (Expr) then 10335 raise Pragma_Exit; 10336 end if; 10337 10338 -- Case of No_Specification_Of_Aspect => aspect-identifier 10339 10340 elsif Id = Name_No_Specification_Of_Aspect then 10341 declare 10342 A_Id : Aspect_Id; 10343 10344 begin 10345 if Nkind (Expr) /= N_Identifier then 10346 A_Id := No_Aspect; 10347 else 10348 A_Id := Get_Aspect_Id (Chars (Expr)); 10349 end if; 10350 10351 if A_Id = No_Aspect then 10352 Error_Pragma_Arg ("invalid restriction name", Arg); 10353 else 10354 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); 10355 end if; 10356 end; 10357 10358 -- Case of No_Use_Of_Attribute => attribute-identifier 10359 10360 elsif Id = Name_No_Use_Of_Attribute then 10361 if Nkind (Expr) /= N_Identifier 10362 or else not Is_Attribute_Name (Chars (Expr)) 10363 then 10364 Error_Msg_N ("unknown attribute name??", Expr); 10365 10366 else 10367 Set_Restriction_No_Use_Of_Attribute (Expr, Warn); 10368 end if; 10369 10370 -- Case of No_Use_Of_Entity => fully-qualified-name 10371 10372 elsif Id = Name_No_Use_Of_Entity then 10373 10374 -- Restriction is only recognized within a configuration 10375 -- pragma file, or within a unit of the main extended 10376 -- program. Note: the test for Main_Unit is needed to 10377 -- properly include the case of configuration pragma files. 10378 10379 if Current_Sem_Unit = Main_Unit 10380 or else In_Extended_Main_Source_Unit (N) 10381 then 10382 if not OK_No_Dependence_Unit_Name (Expr) then 10383 Error_Msg_N ("wrong form for entity name", Expr); 10384 else 10385 Set_Restriction_No_Use_Of_Entity 10386 (Expr, Warn, No_Profile); 10387 end if; 10388 end if; 10389 10390 -- Case of No_Use_Of_Pragma => pragma-identifier 10391 10392 elsif Id = Name_No_Use_Of_Pragma then 10393 if Nkind (Expr) /= N_Identifier 10394 or else not Is_Pragma_Name (Chars (Expr)) 10395 then 10396 Error_Msg_N ("unknown pragma name??", Expr); 10397 else 10398 Set_Restriction_No_Use_Of_Pragma (Expr, Warn); 10399 end if; 10400 10401 -- All other cases of restriction identifier present 10402 10403 else 10404 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); 10405 Analyze_And_Resolve (Expr, Any_Integer); 10406 10407 if R_Id not in All_Parameter_Restrictions then 10408 Error_Pragma_Arg 10409 ("invalid restriction parameter identifier", Arg); 10410 10411 elsif not Is_OK_Static_Expression (Expr) then 10412 Flag_Non_Static_Expr 10413 ("value must be static expression!", Expr); 10414 raise Pragma_Exit; 10415 10416 elsif not Is_Integer_Type (Etype (Expr)) 10417 or else Expr_Value (Expr) < 0 10418 then 10419 Error_Pragma_Arg 10420 ("value must be non-negative integer", Arg); 10421 end if; 10422 10423 -- Restriction pragma is active 10424 10425 Val := Expr_Value (Expr); 10426 10427 if not UI_Is_In_Int_Range (Val) then 10428 Error_Pragma_Arg 10429 ("pragma ignored, value too large??", Arg); 10430 end if; 10431 10432 -- Warning case. If the real restriction is active, then we 10433 -- ignore the request, since warning never overrides a real 10434 -- restriction. Otherwise we set the proper warning. Note that 10435 -- this circuit sets the warning again if it is already set, 10436 -- which is what we want, since the constant may have changed. 10437 10438 if Warn then 10439 if not Restriction_Active (R_Id) then 10440 Set_Restriction 10441 (R_Id, N, Integer (UI_To_Int (Val))); 10442 Restriction_Warnings (R_Id) := True; 10443 end if; 10444 10445 -- Real restriction case, set restriction and make sure warning 10446 -- flag is off since real restriction always overrides warning. 10447 10448 else 10449 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); 10450 Restriction_Warnings (R_Id) := False; 10451 end if; 10452 end if; 10453 10454 Next (Arg); 10455 end loop; 10456 end Process_Restrictions_Or_Restriction_Warnings; 10457 10458 --------------------------------- 10459 -- Process_Suppress_Unsuppress -- 10460 --------------------------------- 10461 10462 -- Note: this procedure makes entries in the check suppress data 10463 -- structures managed by Sem. See spec of package Sem for full 10464 -- details on how we handle recording of check suppression. 10465 10466 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is 10467 C : Check_Id; 10468 E : Entity_Id; 10469 E_Id : Node_Id; 10470 10471 In_Package_Spec : constant Boolean := 10472 Is_Package_Or_Generic_Package (Current_Scope) 10473 and then not In_Package_Body (Current_Scope); 10474 10475 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); 10476 -- Used to suppress a single check on the given entity 10477 10478 -------------------------------- 10479 -- Suppress_Unsuppress_Echeck -- 10480 -------------------------------- 10481 10482 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is 10483 begin 10484 -- Check for error of trying to set atomic synchronization for 10485 -- a non-atomic variable. 10486 10487 if C = Atomic_Synchronization 10488 and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) 10489 then 10490 Error_Msg_N 10491 ("pragma & requires atomic type or variable", 10492 Pragma_Identifier (Original_Node (N))); 10493 end if; 10494 10495 Set_Checks_May_Be_Suppressed (E); 10496 10497 if In_Package_Spec then 10498 Push_Global_Suppress_Stack_Entry 10499 (Entity => E, 10500 Check => C, 10501 Suppress => Suppress_Case); 10502 else 10503 Push_Local_Suppress_Stack_Entry 10504 (Entity => E, 10505 Check => C, 10506 Suppress => Suppress_Case); 10507 end if; 10508 10509 -- If this is a first subtype, and the base type is distinct, 10510 -- then also set the suppress flags on the base type. 10511 10512 if Is_First_Subtype (E) and then Etype (E) /= E then 10513 Suppress_Unsuppress_Echeck (Etype (E), C); 10514 end if; 10515 end Suppress_Unsuppress_Echeck; 10516 10517 -- Start of processing for Process_Suppress_Unsuppress 10518 10519 begin 10520 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes 10521 -- on user code: we want to generate checks for analysis purposes, as 10522 -- set respectively by -gnatC and -gnatd.F 10523 10524 if Comes_From_Source (N) 10525 and then (CodePeer_Mode or GNATprove_Mode) 10526 then 10527 return; 10528 end if; 10529 10530 -- Suppress/Unsuppress can appear as a configuration pragma, or in a 10531 -- declarative part or a package spec (RM 11.5(5)). 10532 10533 if not Is_Configuration_Pragma then 10534 Check_Is_In_Decl_Part_Or_Package_Spec; 10535 end if; 10536 10537 Check_At_Least_N_Arguments (1); 10538 Check_At_Most_N_Arguments (2); 10539 Check_No_Identifier (Arg1); 10540 Check_Arg_Is_Identifier (Arg1); 10541 10542 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); 10543 10544 if C = No_Check_Id then 10545 Error_Pragma_Arg 10546 ("argument of pragma% is not valid check name", Arg1); 10547 end if; 10548 10549 -- Warn that suppress of Elaboration_Check has no effect in SPARK 10550 10551 if C = Elaboration_Check and then SPARK_Mode = On then 10552 Error_Pragma_Arg 10553 ("Suppress of Elaboration_Check ignored in SPARK??", 10554 "\elaboration checking rules are statically enforced " 10555 & "(SPARK RM 7.7)", Arg1); 10556 end if; 10557 10558 -- One-argument case 10559 10560 if Arg_Count = 1 then 10561 10562 -- Make an entry in the local scope suppress table. This is the 10563 -- table that directly shows the current value of the scope 10564 -- suppress check for any check id value. 10565 10566 if C = All_Checks then 10567 10568 -- For All_Checks, we set all specific predefined checks with 10569 -- the exception of Elaboration_Check, which is handled 10570 -- specially because of not wanting All_Checks to have the 10571 -- effect of deactivating static elaboration order processing. 10572 -- Atomic_Synchronization is also not affected, since this is 10573 -- not a real check. 10574 10575 for J in Scope_Suppress.Suppress'Range loop 10576 if J /= Elaboration_Check 10577 and then 10578 J /= Atomic_Synchronization 10579 then 10580 Scope_Suppress.Suppress (J) := Suppress_Case; 10581 end if; 10582 end loop; 10583 10584 -- If not All_Checks, and predefined check, then set appropriate 10585 -- scope entry. Note that we will set Elaboration_Check if this 10586 -- is explicitly specified. Atomic_Synchronization is allowed 10587 -- only if internally generated and entity is atomic. 10588 10589 elsif C in Predefined_Check_Id 10590 and then (not Comes_From_Source (N) 10591 or else C /= Atomic_Synchronization) 10592 then 10593 Scope_Suppress.Suppress (C) := Suppress_Case; 10594 end if; 10595 10596 -- Also make an entry in the Local_Entity_Suppress table 10597 10598 Push_Local_Suppress_Stack_Entry 10599 (Entity => Empty, 10600 Check => C, 10601 Suppress => Suppress_Case); 10602 10603 -- Case of two arguments present, where the check is suppressed for 10604 -- a specified entity (given as the second argument of the pragma) 10605 10606 else 10607 -- This is obsolescent in Ada 2005 mode 10608 10609 if Ada_Version >= Ada_2005 then 10610 Check_Restriction (No_Obsolescent_Features, Arg2); 10611 end if; 10612 10613 Check_Optional_Identifier (Arg2, Name_On); 10614 E_Id := Get_Pragma_Arg (Arg2); 10615 Analyze (E_Id); 10616 10617 if not Is_Entity_Name (E_Id) then 10618 Error_Pragma_Arg 10619 ("second argument of pragma% must be entity name", Arg2); 10620 end if; 10621 10622 E := Entity (E_Id); 10623 10624 if E = Any_Id then 10625 return; 10626 end if; 10627 10628 -- A pragma that applies to a Ghost entity becomes Ghost for the 10629 -- purposes of legality checks and removal of ignored Ghost code. 10630 10631 Mark_Ghost_Pragma (N, E); 10632 10633 -- Enforce RM 11.5(7) which requires that for a pragma that 10634 -- appears within a package spec, the named entity must be 10635 -- within the package spec. We allow the package name itself 10636 -- to be mentioned since that makes sense, although it is not 10637 -- strictly allowed by 11.5(7). 10638 10639 if In_Package_Spec 10640 and then E /= Current_Scope 10641 and then Scope (E) /= Current_Scope 10642 then 10643 Error_Pragma_Arg 10644 ("entity in pragma% is not in package spec (RM 11.5(7))", 10645 Arg2); 10646 end if; 10647 10648 -- Loop through homonyms. As noted below, in the case of a package 10649 -- spec, only homonyms within the package spec are considered. 10650 10651 loop 10652 Suppress_Unsuppress_Echeck (E, C); 10653 10654 if Is_Generic_Instance (E) 10655 and then Is_Subprogram (E) 10656 and then Present (Alias (E)) 10657 then 10658 Suppress_Unsuppress_Echeck (Alias (E), C); 10659 end if; 10660 10661 -- Move to next homonym if not aspect spec case 10662 10663 exit when From_Aspect_Specification (N); 10664 E := Homonym (E); 10665 exit when No (E); 10666 10667 -- If we are within a package specification, the pragma only 10668 -- applies to homonyms in the same scope. 10669 10670 exit when In_Package_Spec 10671 and then Scope (E) /= Current_Scope; 10672 end loop; 10673 end if; 10674 end Process_Suppress_Unsuppress; 10675 10676 ------------------------------- 10677 -- Record_Independence_Check -- 10678 ------------------------------- 10679 10680 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is 10681 pragma Unreferenced (N, E); 10682 begin 10683 -- For GCC back ends the validation is done a priori 10684 -- ??? This code is dead, might be useful in the future 10685 10686 -- if not AAMP_On_Target then 10687 -- return; 10688 -- end if; 10689 10690 -- Independence_Checks.Append ((N, E)); 10691 10692 return; 10693 end Record_Independence_Check; 10694 10695 ------------------ 10696 -- Set_Exported -- 10697 ------------------ 10698 10699 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is 10700 begin 10701 if Is_Imported (E) then 10702 Error_Pragma_Arg 10703 ("cannot export entity& that was previously imported", Arg); 10704 10705 elsif Present (Address_Clause (E)) 10706 and then not Relaxed_RM_Semantics 10707 then 10708 Error_Pragma_Arg 10709 ("cannot export entity& that has an address clause", Arg); 10710 end if; 10711 10712 Set_Is_Exported (E); 10713 10714 -- Generate a reference for entity explicitly, because the 10715 -- identifier may be overloaded and name resolution will not 10716 -- generate one. 10717 10718 Generate_Reference (E, Arg); 10719 10720 -- Deal with exporting non-library level entity 10721 10722 if not Is_Library_Level_Entity (E) then 10723 10724 -- Not allowed at all for subprograms 10725 10726 if Is_Subprogram (E) then 10727 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); 10728 10729 -- Otherwise set public and statically allocated 10730 10731 else 10732 Set_Is_Public (E); 10733 Set_Is_Statically_Allocated (E); 10734 10735 -- Warn if the corresponding W flag is set 10736 10737 if Warn_On_Export_Import 10738 10739 -- Only do this for something that was in the source. Not 10740 -- clear if this can be False now (there used for sure to be 10741 -- cases on some systems where it was False), but anyway the 10742 -- test is harmless if not needed, so it is retained. 10743 10744 and then Comes_From_Source (Arg) 10745 then 10746 Error_Msg_NE 10747 ("?x?& has been made static as a result of Export", 10748 Arg, E); 10749 Error_Msg_N 10750 ("\?x?this usage is non-standard and non-portable", 10751 Arg); 10752 end if; 10753 end if; 10754 end if; 10755 10756 if Warn_On_Export_Import and then Is_Type (E) then 10757 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); 10758 end if; 10759 10760 if Warn_On_Export_Import and Inside_A_Generic then 10761 Error_Msg_NE 10762 ("all instances of& will have the same external name?x?", 10763 Arg, E); 10764 end if; 10765 end Set_Exported; 10766 10767 ---------------------------------------------- 10768 -- Set_Extended_Import_Export_External_Name -- 10769 ---------------------------------------------- 10770 10771 procedure Set_Extended_Import_Export_External_Name 10772 (Internal_Ent : Entity_Id; 10773 Arg_External : Node_Id) 10774 is 10775 Old_Name : constant Node_Id := Interface_Name (Internal_Ent); 10776 New_Name : Node_Id; 10777 10778 begin 10779 if No (Arg_External) then 10780 return; 10781 end if; 10782 10783 Check_Arg_Is_External_Name (Arg_External); 10784 10785 if Nkind (Arg_External) = N_String_Literal then 10786 if String_Length (Strval (Arg_External)) = 0 then 10787 return; 10788 else 10789 New_Name := Adjust_External_Name_Case (Arg_External); 10790 end if; 10791 10792 elsif Nkind (Arg_External) = N_Identifier then 10793 New_Name := Get_Default_External_Name (Arg_External); 10794 10795 -- Check_Arg_Is_External_Name should let through only identifiers and 10796 -- string literals or static string expressions (which are folded to 10797 -- string literals). 10798 10799 else 10800 raise Program_Error; 10801 end if; 10802 10803 -- If we already have an external name set (by a prior normal Import 10804 -- or Export pragma), then the external names must match 10805 10806 if Present (Interface_Name (Internal_Ent)) then 10807 10808 -- Ignore mismatching names in CodePeer mode, to support some 10809 -- old compilers which would export the same procedure under 10810 -- different names, e.g: 10811 -- procedure P; 10812 -- pragma Export_Procedure (P, "a"); 10813 -- pragma Export_Procedure (P, "b"); 10814 10815 if CodePeer_Mode then 10816 return; 10817 end if; 10818 10819 Check_Matching_Internal_Names : declare 10820 S1 : constant String_Id := Strval (Old_Name); 10821 S2 : constant String_Id := Strval (New_Name); 10822 10823 procedure Mismatch; 10824 pragma No_Return (Mismatch); 10825 -- Called if names do not match 10826 10827 -------------- 10828 -- Mismatch -- 10829 -------------- 10830 10831 procedure Mismatch is 10832 begin 10833 Error_Msg_Sloc := Sloc (Old_Name); 10834 Error_Pragma_Arg 10835 ("external name does not match that given #", 10836 Arg_External); 10837 end Mismatch; 10838 10839 -- Start of processing for Check_Matching_Internal_Names 10840 10841 begin 10842 if String_Length (S1) /= String_Length (S2) then 10843 Mismatch; 10844 10845 else 10846 for J in 1 .. String_Length (S1) loop 10847 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then 10848 Mismatch; 10849 end if; 10850 end loop; 10851 end if; 10852 end Check_Matching_Internal_Names; 10853 10854 -- Otherwise set the given name 10855 10856 else 10857 Set_Encoded_Interface_Name (Internal_Ent, New_Name); 10858 Check_Duplicated_Export_Name (New_Name); 10859 end if; 10860 end Set_Extended_Import_Export_External_Name; 10861 10862 ------------------ 10863 -- Set_Imported -- 10864 ------------------ 10865 10866 procedure Set_Imported (E : Entity_Id) is 10867 begin 10868 -- Error message if already imported or exported 10869 10870 if Is_Exported (E) or else Is_Imported (E) then 10871 10872 -- Error if being set Exported twice 10873 10874 if Is_Exported (E) then 10875 Error_Msg_NE ("entity& was previously exported", N, E); 10876 10877 -- Ignore error in CodePeer mode where we treat all imported 10878 -- subprograms as unknown. 10879 10880 elsif CodePeer_Mode then 10881 goto OK; 10882 10883 -- OK if Import/Interface case 10884 10885 elsif Import_Interface_Present (N) then 10886 goto OK; 10887 10888 -- Error if being set Imported twice 10889 10890 else 10891 Error_Msg_NE ("entity& was previously imported", N, E); 10892 end if; 10893 10894 Error_Msg_Name_1 := Pname; 10895 Error_Msg_N 10896 ("\(pragma% applies to all previous entities)", N); 10897 10898 Error_Msg_Sloc := Sloc (E); 10899 Error_Msg_NE ("\import not allowed for& declared#", N, E); 10900 10901 -- Here if not previously imported or exported, OK to import 10902 10903 else 10904 Set_Is_Imported (E); 10905 10906 -- For subprogram, set Import_Pragma field 10907 10908 if Is_Subprogram (E) then 10909 Set_Import_Pragma (E, N); 10910 end if; 10911 10912 -- If the entity is an object that is not at the library level, 10913 -- then it is statically allocated. We do not worry about objects 10914 -- with address clauses in this context since they are not really 10915 -- imported in the linker sense. 10916 10917 if Is_Object (E) 10918 and then not Is_Library_Level_Entity (E) 10919 and then No (Address_Clause (E)) 10920 then 10921 Set_Is_Statically_Allocated (E); 10922 end if; 10923 end if; 10924 10925 <<OK>> null; 10926 end Set_Imported; 10927 10928 ------------------------- 10929 -- Set_Mechanism_Value -- 10930 ------------------------- 10931 10932 -- Note: the mechanism name has not been analyzed (and cannot indeed be 10933 -- analyzed, since it is semantic nonsense), so we get it in the exact 10934 -- form created by the parser. 10935 10936 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is 10937 procedure Bad_Mechanism; 10938 pragma No_Return (Bad_Mechanism); 10939 -- Signal bad mechanism name 10940 10941 ------------------- 10942 -- Bad_Mechanism -- 10943 ------------------- 10944 10945 procedure Bad_Mechanism is 10946 begin 10947 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); 10948 end Bad_Mechanism; 10949 10950 -- Start of processing for Set_Mechanism_Value 10951 10952 begin 10953 if Mechanism (Ent) /= Default_Mechanism then 10954 Error_Msg_NE 10955 ("mechanism for & has already been set", Mech_Name, Ent); 10956 end if; 10957 10958 -- MECHANISM_NAME ::= value | reference 10959 10960 if Nkind (Mech_Name) = N_Identifier then 10961 if Chars (Mech_Name) = Name_Value then 10962 Set_Mechanism (Ent, By_Copy); 10963 return; 10964 10965 elsif Chars (Mech_Name) = Name_Reference then 10966 Set_Mechanism (Ent, By_Reference); 10967 return; 10968 10969 elsif Chars (Mech_Name) = Name_Copy then 10970 Error_Pragma_Arg 10971 ("bad mechanism name, Value assumed", Mech_Name); 10972 10973 else 10974 Bad_Mechanism; 10975 end if; 10976 10977 else 10978 Bad_Mechanism; 10979 end if; 10980 end Set_Mechanism_Value; 10981 10982 -------------------------- 10983 -- Set_Rational_Profile -- 10984 -------------------------- 10985 10986 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and 10987 -- extension to the semantics of renaming declarations. 10988 10989 procedure Set_Rational_Profile is 10990 begin 10991 Implicit_Packing := True; 10992 Overriding_Renamings := True; 10993 Use_VADS_Size := True; 10994 end Set_Rational_Profile; 10995 10996 --------------------------- 10997 -- Set_Ravenscar_Profile -- 10998 --------------------------- 10999 11000 -- The tasks to be done here are 11001 11002 -- Set required policies 11003 11004 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 11005 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles) 11006 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities) 11007 -- (For GNAT_Ravenscar_EDF profile) 11008 -- pragma Locking_Policy (Ceiling_Locking) 11009 11010 -- Set Detect_Blocking mode 11011 11012 -- Set required restrictions (see System.Rident for detailed list) 11013 11014 -- Set the No_Dependence rules 11015 -- No_Dependence => Ada.Asynchronous_Task_Control 11016 -- No_Dependence => Ada.Calendar 11017 -- No_Dependence => Ada.Execution_Time.Group_Budget 11018 -- No_Dependence => Ada.Execution_Time.Timers 11019 -- No_Dependence => Ada.Task_Attributes 11020 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 11021 11022 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is 11023 procedure Set_Error_Msg_To_Profile_Name; 11024 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the 11025 -- profile. 11026 11027 ----------------------------------- 11028 -- Set_Error_Msg_To_Profile_Name -- 11029 ----------------------------------- 11030 11031 procedure Set_Error_Msg_To_Profile_Name is 11032 Prof_Nam : constant Node_Id := 11033 Get_Pragma_Arg 11034 (First (Pragma_Argument_Associations (N))); 11035 11036 begin 11037 Get_Name_String (Chars (Prof_Nam)); 11038 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam)); 11039 Error_Msg_Strlen := Name_Len; 11040 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); 11041 end Set_Error_Msg_To_Profile_Name; 11042 11043 -- Local variables 11044 11045 Nod : Node_Id; 11046 Pref : Node_Id; 11047 Pref_Id : Node_Id; 11048 Sel_Id : Node_Id; 11049 11050 Profile_Dispatching_Policy : Character; 11051 11052 -- Start of processing for Set_Ravenscar_Profile 11053 11054 begin 11055 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities) 11056 11057 if Profile = GNAT_Ravenscar_EDF then 11058 Profile_Dispatching_Policy := 'E'; 11059 11060 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 11061 11062 else 11063 Profile_Dispatching_Policy := 'F'; 11064 end if; 11065 11066 if Task_Dispatching_Policy /= ' ' 11067 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy 11068 then 11069 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 11070 Set_Error_Msg_To_Profile_Name; 11071 Error_Pragma ("Profile (~) incompatible with policy#"); 11072 11073 -- Set the FIFO_Within_Priorities policy, but always preserve 11074 -- System_Location since we like the error message with the run time 11075 -- name. 11076 11077 else 11078 Task_Dispatching_Policy := Profile_Dispatching_Policy; 11079 11080 if Task_Dispatching_Policy_Sloc /= System_Location then 11081 Task_Dispatching_Policy_Sloc := Loc; 11082 end if; 11083 end if; 11084 11085 -- pragma Locking_Policy (Ceiling_Locking) 11086 11087 if Locking_Policy /= ' ' 11088 and then Locking_Policy /= 'C' 11089 then 11090 Error_Msg_Sloc := Locking_Policy_Sloc; 11091 Set_Error_Msg_To_Profile_Name; 11092 Error_Pragma ("Profile (~) incompatible with policy#"); 11093 11094 -- Set the Ceiling_Locking policy, but preserve System_Location since 11095 -- we like the error message with the run time name. 11096 11097 else 11098 Locking_Policy := 'C'; 11099 11100 if Locking_Policy_Sloc /= System_Location then 11101 Locking_Policy_Sloc := Loc; 11102 end if; 11103 end if; 11104 11105 -- pragma Detect_Blocking 11106 11107 Detect_Blocking := True; 11108 11109 -- Set the corresponding restrictions 11110 11111 Set_Profile_Restrictions 11112 (Profile, N, Warn => Treat_Restrictions_As_Warnings); 11113 11114 -- Set the No_Dependence restrictions 11115 11116 -- The following No_Dependence restrictions: 11117 -- No_Dependence => Ada.Asynchronous_Task_Control 11118 -- No_Dependence => Ada.Calendar 11119 -- No_Dependence => Ada.Task_Attributes 11120 -- are already set by previous call to Set_Profile_Restrictions. 11121 11122 -- Set the following restrictions which were added to Ada 2005: 11123 -- No_Dependence => Ada.Execution_Time.Group_Budget 11124 -- No_Dependence => Ada.Execution_Time.Timers 11125 11126 if Ada_Version >= Ada_2005 then 11127 Pref_Id := Make_Identifier (Loc, Name_Find ("ada")); 11128 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time")); 11129 11130 Pref := 11131 Make_Selected_Component 11132 (Sloc => Loc, 11133 Prefix => Pref_Id, 11134 Selector_Name => Sel_Id); 11135 11136 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets")); 11137 11138 Nod := 11139 Make_Selected_Component 11140 (Sloc => Loc, 11141 Prefix => Pref, 11142 Selector_Name => Sel_Id); 11143 11144 Set_Restriction_No_Dependence 11145 (Unit => Nod, 11146 Warn => Treat_Restrictions_As_Warnings, 11147 Profile => Ravenscar); 11148 11149 Sel_Id := Make_Identifier (Loc, Name_Find ("timers")); 11150 11151 Nod := 11152 Make_Selected_Component 11153 (Sloc => Loc, 11154 Prefix => Pref, 11155 Selector_Name => Sel_Id); 11156 11157 Set_Restriction_No_Dependence 11158 (Unit => Nod, 11159 Warn => Treat_Restrictions_As_Warnings, 11160 Profile => Ravenscar); 11161 end if; 11162 11163 -- Set the following restriction which was added to Ada 2012 (see 11164 -- AI-0171): 11165 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 11166 11167 if Ada_Version >= Ada_2012 then 11168 Pref_Id := Make_Identifier (Loc, Name_Find ("system")); 11169 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors")); 11170 11171 Pref := 11172 Make_Selected_Component 11173 (Sloc => Loc, 11174 Prefix => Pref_Id, 11175 Selector_Name => Sel_Id); 11176 11177 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains")); 11178 11179 Nod := 11180 Make_Selected_Component 11181 (Sloc => Loc, 11182 Prefix => Pref, 11183 Selector_Name => Sel_Id); 11184 11185 Set_Restriction_No_Dependence 11186 (Unit => Nod, 11187 Warn => Treat_Restrictions_As_Warnings, 11188 Profile => Ravenscar); 11189 end if; 11190 end Set_Ravenscar_Profile; 11191 11192 ----------------------------------- 11193 -- Validate_Acc_Condition_Clause -- 11194 ----------------------------------- 11195 11196 procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is 11197 begin 11198 Analyze_And_Resolve (Clause); 11199 11200 if not Is_Boolean_Type (Etype (Clause)) then 11201 Error_Pragma ("expected a boolean"); 11202 end if; 11203 end Validate_Acc_Condition_Clause; 11204 11205 ------------------------------ 11206 -- Validate_Acc_Data_Clause -- 11207 ------------------------------ 11208 11209 procedure Validate_Acc_Data_Clause (Clause : Node_Id) is 11210 Expr : Node_Id; 11211 11212 begin 11213 Expr := Acc_First (Clause); 11214 while Present (Expr) loop 11215 if Nkind (Expr) /= N_Identifier then 11216 Error_Pragma ("expected an identifer"); 11217 end if; 11218 11219 Analyze_And_Resolve (Expr); 11220 11221 Expr := Acc_Next (Expr); 11222 end loop; 11223 end Validate_Acc_Data_Clause; 11224 11225 ---------------------------------- 11226 -- Validate_Acc_Int_Expr_Clause -- 11227 ---------------------------------- 11228 11229 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is 11230 begin 11231 Analyze_And_Resolve (Clause); 11232 11233 if not Is_Integer_Type (Etype (Clause)) then 11234 Error_Pragma_Arg ("expected an integer", Clause); 11235 end if; 11236 end Validate_Acc_Int_Expr_Clause; 11237 11238 --------------------------------------- 11239 -- Validate_Acc_Int_Expr_List_Clause -- 11240 --------------------------------------- 11241 11242 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is 11243 Expr : Node_Id; 11244 11245 begin 11246 Expr := Acc_First (Clause); 11247 while Present (Expr) loop 11248 Analyze_And_Resolve (Expr); 11249 11250 if not Is_Integer_Type (Etype (Expr)) then 11251 Error_Pragma ("expected an integer"); 11252 end if; 11253 11254 Expr := Acc_Next (Expr); 11255 end loop; 11256 end Validate_Acc_Int_Expr_List_Clause; 11257 11258 -------------------------------- 11259 -- Validate_Acc_Loop_Collapse -- 11260 -------------------------------- 11261 11262 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is 11263 Count : Uint; 11264 Par_Loop : Node_Id; 11265 Stmt : Node_Id; 11266 11267 begin 11268 -- Make sure the argument is a positive integer 11269 11270 Analyze_And_Resolve (Clause); 11271 11272 Count := Static_Integer (Clause); 11273 if Count = No_Uint or else Count < 1 then 11274 Error_Pragma_Arg ("expected a positive integer", Clause); 11275 end if; 11276 11277 -- Then, make sure we have at least Count-1 tightly-nested loops 11278 -- (i.e. loops with no statements in between). 11279 11280 Par_Loop := Parent (Parent (Parent (Clause))); 11281 Stmt := First (Statements (Par_Loop)); 11282 11283 -- Skip first pragmas in the parent loop 11284 11285 while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop 11286 Next (Stmt); 11287 end loop; 11288 11289 if not Present (Next (Stmt)) then 11290 while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop 11291 Stmt := First (Statements (Stmt)); 11292 exit when Present (Next (Stmt)); 11293 11294 Count := Count - 1; 11295 end loop; 11296 end if; 11297 11298 if Count > 1 then 11299 Error_Pragma_Arg 11300 ("Collapse argument too high or loops not tightly nested", 11301 Clause); 11302 end if; 11303 end Validate_Acc_Loop_Collapse; 11304 11305 ---------------------------- 11306 -- Validate_Acc_Loop_Gang -- 11307 ---------------------------- 11308 11309 procedure Validate_Acc_Loop_Gang (Clause : Node_Id) is 11310 begin 11311 Error_Pragma_Arg ("Loop_Gang not implemented", Clause); 11312 end Validate_Acc_Loop_Gang; 11313 11314 ------------------------------ 11315 -- Validate_Acc_Loop_Vector -- 11316 ------------------------------ 11317 11318 procedure Validate_Acc_Loop_Vector (Clause : Node_Id) is 11319 begin 11320 Error_Pragma_Arg ("Loop_Vector not implemented", Clause); 11321 end Validate_Acc_Loop_Vector; 11322 11323 ------------------------------- 11324 -- Validate_Acc_Loop_Worker -- 11325 ------------------------------- 11326 11327 procedure Validate_Acc_Loop_Worker (Clause : Node_Id) is 11328 begin 11329 Error_Pragma_Arg ("Loop_Worker not implemented", Clause); 11330 end Validate_Acc_Loop_Worker; 11331 11332 --------------------------------- 11333 -- Validate_Acc_Name_Reduction -- 11334 --------------------------------- 11335 11336 procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is 11337 11338 -- ??? On top of the following operations, the OpenAcc spec adds the 11339 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and 11340 -- ".neqv" for Fortran. Can we, should we and how do we support them 11341 -- in Ada? 11342 11343 type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op); 11344 11345 function To_Reduction_Op (Op : String) return Reduction_Op; 11346 -- Convert operator Op described by a String into its corresponding 11347 -- enumeration value. 11348 11349 --------------------- 11350 -- To_Reduction_Op -- 11351 --------------------- 11352 11353 function To_Reduction_Op (Op : String) return Reduction_Op is 11354 begin 11355 if Op = "+" then 11356 return Add_Op; 11357 11358 elsif Op = "*" then 11359 return Mul_Op; 11360 11361 elsif Op = "max" then 11362 return Max_Op; 11363 11364 elsif Op = "min" then 11365 return Min_Op; 11366 11367 elsif Op = "and" then 11368 return And_Op; 11369 11370 elsif Op = "or" then 11371 return Or_Op; 11372 11373 else 11374 Error_Pragma ("unsuported reduction operation"); 11375 end if; 11376 end To_Reduction_Op; 11377 11378 -- Local variables 11379 11380 Seen : constant Elist_Id := New_Elmt_List; 11381 11382 Expr : Node_Id; 11383 Reduc_Op : Node_Id; 11384 Reduc_Var : Node_Id; 11385 11386 -- Start of processing for Validate_Acc_Name_Reduction 11387 11388 begin 11389 -- Reduction operations appear in the following form: 11390 -- ("+" => (a, b), "*" => c) 11391 11392 Expr := First (Component_Associations (Clause)); 11393 while Present (Expr) loop 11394 Reduc_Op := First (Choices (Expr)); 11395 String_To_Name_Buffer (Strval (Reduc_Op)); 11396 11397 case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is 11398 when Add_Op 11399 | Mul_Op 11400 | Max_Op 11401 | Min_Op 11402 => 11403 Reduc_Var := Acc_First (Expression (Expr)); 11404 while Present (Reduc_Var) loop 11405 Analyze_And_Resolve (Reduc_Var); 11406 11407 if Contains (Seen, Entity (Reduc_Var)) then 11408 Error_Pragma ("variable used in multiple reductions"); 11409 11410 else 11411 if Nkind (Reduc_Var) /= N_Identifier 11412 or not Is_Numeric_Type (Etype (Reduc_Var)) 11413 then 11414 Error_Pragma 11415 ("expected an identifier for a Numeric"); 11416 end if; 11417 11418 Append_Elmt (Entity (Reduc_Var), Seen); 11419 end if; 11420 11421 Reduc_Var := Acc_Next (Reduc_Var); 11422 end loop; 11423 11424 when And_Op 11425 | Or_Op 11426 => 11427 Reduc_Var := Acc_First (Expression (Expr)); 11428 while Present (Reduc_Var) loop 11429 Analyze_And_Resolve (Reduc_Var); 11430 11431 if Contains (Seen, Entity (Reduc_Var)) then 11432 Error_Pragma ("variable used in multiple reductions"); 11433 11434 else 11435 if Nkind (Reduc_Var) /= N_Identifier 11436 or not Is_Boolean_Type (Etype (Reduc_Var)) 11437 then 11438 Error_Pragma 11439 ("expected a variable of type boolean"); 11440 end if; 11441 11442 Append_Elmt (Entity (Reduc_Var), Seen); 11443 end if; 11444 11445 Reduc_Var := Acc_Next (Reduc_Var); 11446 end loop; 11447 end case; 11448 11449 Next (Expr); 11450 end loop; 11451 end Validate_Acc_Name_Reduction; 11452 11453 ----------------------------------- 11454 -- Validate_Acc_Size_Expressions -- 11455 ----------------------------------- 11456 11457 procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is 11458 function Validate_Size_Expr (Expr : Node_Id) return Boolean; 11459 -- A size expr is either an integer expression or "*" 11460 11461 ------------------------ 11462 -- Validate_Size_Expr -- 11463 ------------------------ 11464 11465 function Validate_Size_Expr (Expr : Node_Id) return Boolean is 11466 begin 11467 if Nkind (Expr) = N_Operator_Symbol then 11468 return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*'); 11469 end if; 11470 11471 Analyze_And_Resolve (Expr); 11472 11473 return Is_Integer_Type (Etype (Expr)); 11474 end Validate_Size_Expr; 11475 11476 -- Local variables 11477 11478 Expr : Node_Id; 11479 11480 -- Start of processing for Validate_Acc_Size_Expressions 11481 11482 begin 11483 Expr := Acc_First (Clause); 11484 while Present (Expr) loop 11485 if not Validate_Size_Expr (Expr) then 11486 Error_Pragma 11487 ("Size expressions should be either integers or '*'"); 11488 end if; 11489 11490 Expr := Acc_Next (Expr); 11491 end loop; 11492 end Validate_Acc_Size_Expressions; 11493 11494 -- Start of processing for Analyze_Pragma 11495 11496 begin 11497 -- The following code is a defense against recursion. Not clear that 11498 -- this can happen legitimately, but perhaps some error situations can 11499 -- cause it, and we did see this recursion during testing. 11500 11501 if Analyzed (N) then 11502 return; 11503 else 11504 Set_Analyzed (N); 11505 end if; 11506 11507 Check_Restriction_No_Use_Of_Pragma (N); 11508 11509 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma 11510 -- Default_Scalar_Storage_Order if the -gnatI switch was given. 11511 11512 if Should_Ignore_Pragma_Sem (N) 11513 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order 11514 and then Ignore_Rep_Clauses) 11515 then 11516 return; 11517 end if; 11518 11519 -- Deal with unrecognized pragma 11520 11521 if not Is_Pragma_Name (Pname) then 11522 if Warn_On_Unrecognized_Pragma then 11523 Error_Msg_Name_1 := Pname; 11524 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N)); 11525 11526 for PN in First_Pragma_Name .. Last_Pragma_Name loop 11527 if Is_Bad_Spelling_Of (Pname, PN) then 11528 Error_Msg_Name_1 := PN; 11529 Error_Msg_N -- CODEFIX 11530 ("\?g?possible misspelling of %!", Pragma_Identifier (N)); 11531 exit; 11532 end if; 11533 end loop; 11534 end if; 11535 11536 return; 11537 end if; 11538 11539 -- Here to start processing for recognized pragma 11540 11541 Pname := Original_Aspect_Pragma_Name (N); 11542 11543 -- Capture setting of Opt.Uneval_Old 11544 11545 case Opt.Uneval_Old is 11546 when 'A' => 11547 Set_Uneval_Old_Accept (N); 11548 11549 when 'E' => 11550 null; 11551 11552 when 'W' => 11553 Set_Uneval_Old_Warn (N); 11554 11555 when others => 11556 raise Program_Error; 11557 end case; 11558 11559 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored 11560 -- is already set, indicating that we have already checked the policy 11561 -- at the right point. This happens for example in the case of a pragma 11562 -- that is derived from an Aspect. 11563 11564 if Is_Ignored (N) or else Is_Checked (N) then 11565 null; 11566 11567 -- For a pragma that is a rewriting of another pragma, copy the 11568 -- Is_Checked/Is_Ignored status from the rewritten pragma. 11569 11570 elsif Is_Rewrite_Substitution (N) 11571 and then Nkind (Original_Node (N)) = N_Pragma 11572 then 11573 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 11574 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 11575 11576 -- Otherwise query the applicable policy at this point 11577 11578 else 11579 Check_Applicable_Policy (N); 11580 11581 -- If pragma is disabled, rewrite as NULL and skip analysis 11582 11583 if Is_Disabled (N) then 11584 Rewrite (N, Make_Null_Statement (Loc)); 11585 Analyze (N); 11586 raise Pragma_Exit; 11587 end if; 11588 end if; 11589 11590 -- Preset arguments 11591 11592 Arg_Count := 0; 11593 Arg1 := Empty; 11594 Arg2 := Empty; 11595 Arg3 := Empty; 11596 Arg4 := Empty; 11597 11598 if Present (Pragma_Argument_Associations (N)) then 11599 Arg_Count := List_Length (Pragma_Argument_Associations (N)); 11600 Arg1 := First (Pragma_Argument_Associations (N)); 11601 11602 if Present (Arg1) then 11603 Arg2 := Next (Arg1); 11604 11605 if Present (Arg2) then 11606 Arg3 := Next (Arg2); 11607 11608 if Present (Arg3) then 11609 Arg4 := Next (Arg3); 11610 end if; 11611 end if; 11612 end if; 11613 end if; 11614 11615 -- An enumeration type defines the pragmas that are supported by the 11616 -- implementation. Get_Pragma_Id (in package Prag) transforms a name 11617 -- into the corresponding enumeration value for the following case. 11618 11619 case Prag_Id is 11620 11621 ----------------- 11622 -- Abort_Defer -- 11623 ----------------- 11624 11625 -- pragma Abort_Defer; 11626 11627 when Pragma_Abort_Defer => 11628 GNAT_Pragma; 11629 Check_Arg_Count (0); 11630 11631 -- The only required semantic processing is to check the 11632 -- placement. This pragma must appear at the start of the 11633 -- statement sequence of a handled sequence of statements. 11634 11635 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 11636 or else N /= First (Statements (Parent (N))) 11637 then 11638 Pragma_Misplaced; 11639 end if; 11640 11641 -------------------- 11642 -- Abstract_State -- 11643 -------------------- 11644 11645 -- pragma Abstract_State (ABSTRACT_STATE_LIST); 11646 11647 -- ABSTRACT_STATE_LIST ::= 11648 -- null 11649 -- | STATE_NAME_WITH_OPTIONS 11650 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS}) 11651 11652 -- STATE_NAME_WITH_OPTIONS ::= 11653 -- STATE_NAME 11654 -- | (STATE_NAME with OPTION_LIST) 11655 11656 -- OPTION_LIST ::= OPTION {, OPTION} 11657 11658 -- OPTION ::= 11659 -- SIMPLE_OPTION 11660 -- | NAME_VALUE_OPTION 11661 11662 -- SIMPLE_OPTION ::= Ghost | Synchronous 11663 11664 -- NAME_VALUE_OPTION ::= 11665 -- Part_Of => ABSTRACT_STATE 11666 -- | External [=> EXTERNAL_PROPERTY_LIST] 11667 11668 -- EXTERNAL_PROPERTY_LIST ::= 11669 -- EXTERNAL_PROPERTY 11670 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY}) 11671 11672 -- EXTERNAL_PROPERTY ::= 11673 -- Async_Readers [=> boolean_EXPRESSION] 11674 -- | Async_Writers [=> boolean_EXPRESSION] 11675 -- | Effective_Reads [=> boolean_EXPRESSION] 11676 -- | Effective_Writes [=> boolean_EXPRESSION] 11677 -- others => boolean_EXPRESSION 11678 11679 -- STATE_NAME ::= defining_identifier 11680 11681 -- ABSTRACT_STATE ::= name 11682 11683 -- Characteristics: 11684 11685 -- * Analysis - The annotation is fully analyzed immediately upon 11686 -- elaboration as it cannot forward reference entities. 11687 11688 -- * Expansion - None. 11689 11690 -- * Template - The annotation utilizes the generic template of the 11691 -- related package declaration. 11692 11693 -- * Globals - The annotation cannot reference global entities. 11694 11695 -- * Instance - The annotation is instantiated automatically when 11696 -- the related generic package is instantiated. 11697 11698 when Pragma_Abstract_State => Abstract_State : declare 11699 Missing_Parentheses : Boolean := False; 11700 -- Flag set when a state declaration with options is not properly 11701 -- parenthesized. 11702 11703 -- Flags used to verify the consistency of states 11704 11705 Non_Null_Seen : Boolean := False; 11706 Null_Seen : Boolean := False; 11707 11708 procedure Analyze_Abstract_State 11709 (State : Node_Id; 11710 Pack_Id : Entity_Id); 11711 -- Verify the legality of a single state declaration. Create and 11712 -- decorate a state abstraction entity and introduce it into the 11713 -- visibility chain. Pack_Id denotes the entity or the related 11714 -- package where pragma Abstract_State appears. 11715 11716 procedure Malformed_State_Error (State : Node_Id); 11717 -- Emit an error concerning the illegal declaration of abstract 11718 -- state State. This routine diagnoses syntax errors that lead to 11719 -- a different parse tree. The error is issued regardless of the 11720 -- SPARK mode in effect. 11721 11722 ---------------------------- 11723 -- Analyze_Abstract_State -- 11724 ---------------------------- 11725 11726 procedure Analyze_Abstract_State 11727 (State : Node_Id; 11728 Pack_Id : Entity_Id) 11729 is 11730 -- Flags used to verify the consistency of options 11731 11732 AR_Seen : Boolean := False; 11733 AW_Seen : Boolean := False; 11734 ER_Seen : Boolean := False; 11735 EW_Seen : Boolean := False; 11736 External_Seen : Boolean := False; 11737 Ghost_Seen : Boolean := False; 11738 Others_Seen : Boolean := False; 11739 Part_Of_Seen : Boolean := False; 11740 Synchronous_Seen : Boolean := False; 11741 11742 -- Flags used to store the static value of all external states' 11743 -- expressions. 11744 11745 AR_Val : Boolean := False; 11746 AW_Val : Boolean := False; 11747 ER_Val : Boolean := False; 11748 EW_Val : Boolean := False; 11749 11750 State_Id : Entity_Id := Empty; 11751 -- The entity to be generated for the current state declaration 11752 11753 procedure Analyze_External_Option (Opt : Node_Id); 11754 -- Verify the legality of option External 11755 11756 procedure Analyze_External_Property 11757 (Prop : Node_Id; 11758 Expr : Node_Id := Empty); 11759 -- Verify the legailty of a single external property. Prop 11760 -- denotes the external property. Expr is the expression used 11761 -- to set the property. 11762 11763 procedure Analyze_Part_Of_Option (Opt : Node_Id); 11764 -- Verify the legality of option Part_Of 11765 11766 procedure Check_Duplicate_Option 11767 (Opt : Node_Id; 11768 Status : in out Boolean); 11769 -- Flag Status denotes whether a particular option has been 11770 -- seen while processing a state. This routine verifies that 11771 -- Opt is not a duplicate option and sets the flag Status 11772 -- (SPARK RM 7.1.4(1)). 11773 11774 procedure Check_Duplicate_Property 11775 (Prop : Node_Id; 11776 Status : in out Boolean); 11777 -- Flag Status denotes whether a particular property has been 11778 -- seen while processing option External. This routine verifies 11779 -- that Prop is not a duplicate property and sets flag Status. 11780 -- Opt is not a duplicate property and sets the flag Status. 11781 -- (SPARK RM 7.1.4(2)) 11782 11783 procedure Check_Ghost_Synchronous; 11784 -- Ensure that the abstract state is not subject to both Ghost 11785 -- and Synchronous simple options. Emit an error if this is the 11786 -- case. 11787 11788 procedure Create_Abstract_State 11789 (Nam : Name_Id; 11790 Decl : Node_Id; 11791 Loc : Source_Ptr; 11792 Is_Null : Boolean); 11793 -- Generate an abstract state entity with name Nam and enter it 11794 -- into visibility. Decl is the "declaration" of the state as 11795 -- it appears in pragma Abstract_State. Loc is the location of 11796 -- the related state "declaration". Flag Is_Null should be set 11797 -- when the associated Abstract_State pragma defines a null 11798 -- state. 11799 11800 ----------------------------- 11801 -- Analyze_External_Option -- 11802 ----------------------------- 11803 11804 procedure Analyze_External_Option (Opt : Node_Id) is 11805 Errors : constant Nat := Serious_Errors_Detected; 11806 Prop : Node_Id; 11807 Props : Node_Id := Empty; 11808 11809 begin 11810 if Nkind (Opt) = N_Component_Association then 11811 Props := Expression (Opt); 11812 end if; 11813 11814 -- External state with properties 11815 11816 if Present (Props) then 11817 11818 -- Multiple properties appear as an aggregate 11819 11820 if Nkind (Props) = N_Aggregate then 11821 11822 -- Simple property form 11823 11824 Prop := First (Expressions (Props)); 11825 while Present (Prop) loop 11826 Analyze_External_Property (Prop); 11827 Next (Prop); 11828 end loop; 11829 11830 -- Property with expression form 11831 11832 Prop := First (Component_Associations (Props)); 11833 while Present (Prop) loop 11834 Analyze_External_Property 11835 (Prop => First (Choices (Prop)), 11836 Expr => Expression (Prop)); 11837 11838 Next (Prop); 11839 end loop; 11840 11841 -- Single property 11842 11843 else 11844 Analyze_External_Property (Props); 11845 end if; 11846 11847 -- An external state defined without any properties defaults 11848 -- all properties to True. 11849 11850 else 11851 AR_Val := True; 11852 AW_Val := True; 11853 ER_Val := True; 11854 EW_Val := True; 11855 end if; 11856 11857 -- Once all external properties have been processed, verify 11858 -- their mutual interaction. Do not perform the check when 11859 -- at least one of the properties is illegal as this will 11860 -- produce a bogus error. 11861 11862 if Errors = Serious_Errors_Detected then 11863 Check_External_Properties 11864 (State, AR_Val, AW_Val, ER_Val, EW_Val); 11865 end if; 11866 end Analyze_External_Option; 11867 11868 ------------------------------- 11869 -- Analyze_External_Property -- 11870 ------------------------------- 11871 11872 procedure Analyze_External_Property 11873 (Prop : Node_Id; 11874 Expr : Node_Id := Empty) 11875 is 11876 Expr_Val : Boolean; 11877 11878 begin 11879 -- Check the placement of "others" (if available) 11880 11881 if Nkind (Prop) = N_Others_Choice then 11882 if Others_Seen then 11883 SPARK_Msg_N 11884 ("only one others choice allowed in option External", 11885 Prop); 11886 else 11887 Others_Seen := True; 11888 end if; 11889 11890 elsif Others_Seen then 11891 SPARK_Msg_N 11892 ("others must be the last property in option External", 11893 Prop); 11894 11895 -- The only remaining legal options are the four predefined 11896 -- external properties. 11897 11898 elsif Nkind (Prop) = N_Identifier 11899 and then Nam_In (Chars (Prop), Name_Async_Readers, 11900 Name_Async_Writers, 11901 Name_Effective_Reads, 11902 Name_Effective_Writes) 11903 then 11904 null; 11905 11906 -- Otherwise the construct is not a valid property 11907 11908 else 11909 SPARK_Msg_N ("invalid external state property", Prop); 11910 return; 11911 end if; 11912 11913 -- Ensure that the expression of the external state property 11914 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)). 11915 11916 if Present (Expr) then 11917 Analyze_And_Resolve (Expr, Standard_Boolean); 11918 11919 if Is_OK_Static_Expression (Expr) then 11920 Expr_Val := Is_True (Expr_Value (Expr)); 11921 else 11922 SPARK_Msg_N 11923 ("expression of external state property must be " 11924 & "static", Expr); 11925 return; 11926 end if; 11927 11928 -- The lack of expression defaults the property to True 11929 11930 else 11931 Expr_Val := True; 11932 end if; 11933 11934 -- Named properties 11935 11936 if Nkind (Prop) = N_Identifier then 11937 if Chars (Prop) = Name_Async_Readers then 11938 Check_Duplicate_Property (Prop, AR_Seen); 11939 AR_Val := Expr_Val; 11940 11941 elsif Chars (Prop) = Name_Async_Writers then 11942 Check_Duplicate_Property (Prop, AW_Seen); 11943 AW_Val := Expr_Val; 11944 11945 elsif Chars (Prop) = Name_Effective_Reads then 11946 Check_Duplicate_Property (Prop, ER_Seen); 11947 ER_Val := Expr_Val; 11948 11949 else 11950 Check_Duplicate_Property (Prop, EW_Seen); 11951 EW_Val := Expr_Val; 11952 end if; 11953 11954 -- The handling of property "others" must take into account 11955 -- all other named properties that have been encountered so 11956 -- far. Only those that have not been seen are affected by 11957 -- "others". 11958 11959 else 11960 if not AR_Seen then 11961 AR_Val := Expr_Val; 11962 end if; 11963 11964 if not AW_Seen then 11965 AW_Val := Expr_Val; 11966 end if; 11967 11968 if not ER_Seen then 11969 ER_Val := Expr_Val; 11970 end if; 11971 11972 if not EW_Seen then 11973 EW_Val := Expr_Val; 11974 end if; 11975 end if; 11976 end Analyze_External_Property; 11977 11978 ---------------------------- 11979 -- Analyze_Part_Of_Option -- 11980 ---------------------------- 11981 11982 procedure Analyze_Part_Of_Option (Opt : Node_Id) is 11983 Encap : constant Node_Id := Expression (Opt); 11984 Constits : Elist_Id; 11985 Encap_Id : Entity_Id; 11986 Legal : Boolean; 11987 11988 begin 11989 Check_Duplicate_Option (Opt, Part_Of_Seen); 11990 11991 Analyze_Part_Of 11992 (Indic => First (Choices (Opt)), 11993 Item_Id => State_Id, 11994 Encap => Encap, 11995 Encap_Id => Encap_Id, 11996 Legal => Legal); 11997 11998 -- The Part_Of indicator transforms the abstract state into 11999 -- a constituent of the encapsulating state or single 12000 -- concurrent type. 12001 12002 if Legal then 12003 pragma Assert (Present (Encap_Id)); 12004 Constits := Part_Of_Constituents (Encap_Id); 12005 12006 if No (Constits) then 12007 Constits := New_Elmt_List; 12008 Set_Part_Of_Constituents (Encap_Id, Constits); 12009 end if; 12010 12011 Append_Elmt (State_Id, Constits); 12012 Set_Encapsulating_State (State_Id, Encap_Id); 12013 end if; 12014 end Analyze_Part_Of_Option; 12015 12016 ---------------------------- 12017 -- Check_Duplicate_Option -- 12018 ---------------------------- 12019 12020 procedure Check_Duplicate_Option 12021 (Opt : Node_Id; 12022 Status : in out Boolean) 12023 is 12024 begin 12025 if Status then 12026 SPARK_Msg_N ("duplicate state option", Opt); 12027 end if; 12028 12029 Status := True; 12030 end Check_Duplicate_Option; 12031 12032 ------------------------------ 12033 -- Check_Duplicate_Property -- 12034 ------------------------------ 12035 12036 procedure Check_Duplicate_Property 12037 (Prop : Node_Id; 12038 Status : in out Boolean) 12039 is 12040 begin 12041 if Status then 12042 SPARK_Msg_N ("duplicate external property", Prop); 12043 end if; 12044 12045 Status := True; 12046 end Check_Duplicate_Property; 12047 12048 ----------------------------- 12049 -- Check_Ghost_Synchronous -- 12050 ----------------------------- 12051 12052 procedure Check_Ghost_Synchronous is 12053 begin 12054 -- A synchronized abstract state cannot be Ghost and vice 12055 -- versa (SPARK RM 6.9(19)). 12056 12057 if Ghost_Seen and Synchronous_Seen then 12058 SPARK_Msg_N ("synchronized state cannot be ghost", State); 12059 end if; 12060 end Check_Ghost_Synchronous; 12061 12062 --------------------------- 12063 -- Create_Abstract_State -- 12064 --------------------------- 12065 12066 procedure Create_Abstract_State 12067 (Nam : Name_Id; 12068 Decl : Node_Id; 12069 Loc : Source_Ptr; 12070 Is_Null : Boolean) 12071 is 12072 begin 12073 -- The abstract state may be semi-declared when the related 12074 -- package was withed through a limited with clause. In that 12075 -- case reuse the entity to fully declare the state. 12076 12077 if Present (Decl) and then Present (Entity (Decl)) then 12078 State_Id := Entity (Decl); 12079 12080 -- Otherwise the elaboration of pragma Abstract_State 12081 -- declares the state. 12082 12083 else 12084 State_Id := Make_Defining_Identifier (Loc, Nam); 12085 12086 if Present (Decl) then 12087 Set_Entity (Decl, State_Id); 12088 end if; 12089 end if; 12090 12091 -- Null states never come from source 12092 12093 Set_Comes_From_Source (State_Id, not Is_Null); 12094 Set_Parent (State_Id, State); 12095 Set_Ekind (State_Id, E_Abstract_State); 12096 Set_Etype (State_Id, Standard_Void_Type); 12097 Set_Encapsulating_State (State_Id, Empty); 12098 12099 -- Set the SPARK mode from the current context 12100 12101 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma); 12102 Set_SPARK_Pragma_Inherited (State_Id); 12103 12104 -- An abstract state declared within a Ghost region becomes 12105 -- Ghost (SPARK RM 6.9(2)). 12106 12107 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then 12108 Set_Is_Ghost_Entity (State_Id); 12109 end if; 12110 12111 -- Establish a link between the state declaration and the 12112 -- abstract state entity. Note that a null state remains as 12113 -- N_Null and does not carry any linkages. 12114 12115 if not Is_Null then 12116 if Present (Decl) then 12117 Set_Entity (Decl, State_Id); 12118 Set_Etype (Decl, Standard_Void_Type); 12119 end if; 12120 12121 -- Every non-null state must be defined, nameable and 12122 -- resolvable. 12123 12124 Push_Scope (Pack_Id); 12125 Generate_Definition (State_Id); 12126 Enter_Name (State_Id); 12127 Pop_Scope; 12128 end if; 12129 end Create_Abstract_State; 12130 12131 -- Local variables 12132 12133 Opt : Node_Id; 12134 Opt_Nam : Node_Id; 12135 12136 -- Start of processing for Analyze_Abstract_State 12137 12138 begin 12139 -- A package with a null abstract state is not allowed to 12140 -- declare additional states. 12141 12142 if Null_Seen then 12143 SPARK_Msg_NE 12144 ("package & has null abstract state", State, Pack_Id); 12145 12146 -- Null states appear as internally generated entities 12147 12148 elsif Nkind (State) = N_Null then 12149 Create_Abstract_State 12150 (Nam => New_Internal_Name ('S'), 12151 Decl => Empty, 12152 Loc => Sloc (State), 12153 Is_Null => True); 12154 Null_Seen := True; 12155 12156 -- Catch a case where a null state appears in a list of 12157 -- non-null states. 12158 12159 if Non_Null_Seen then 12160 SPARK_Msg_NE 12161 ("package & has non-null abstract state", 12162 State, Pack_Id); 12163 end if; 12164 12165 -- Simple state declaration 12166 12167 elsif Nkind (State) = N_Identifier then 12168 Create_Abstract_State 12169 (Nam => Chars (State), 12170 Decl => State, 12171 Loc => Sloc (State), 12172 Is_Null => False); 12173 Non_Null_Seen := True; 12174 12175 -- State declaration with various options. This construct 12176 -- appears as an extension aggregate in the tree. 12177 12178 elsif Nkind (State) = N_Extension_Aggregate then 12179 if Nkind (Ancestor_Part (State)) = N_Identifier then 12180 Create_Abstract_State 12181 (Nam => Chars (Ancestor_Part (State)), 12182 Decl => Ancestor_Part (State), 12183 Loc => Sloc (Ancestor_Part (State)), 12184 Is_Null => False); 12185 Non_Null_Seen := True; 12186 else 12187 SPARK_Msg_N 12188 ("state name must be an identifier", 12189 Ancestor_Part (State)); 12190 end if; 12191 12192 -- Options External, Ghost and Synchronous appear as 12193 -- expressions. 12194 12195 Opt := First (Expressions (State)); 12196 while Present (Opt) loop 12197 if Nkind (Opt) = N_Identifier then 12198 12199 -- External 12200 12201 if Chars (Opt) = Name_External then 12202 Check_Duplicate_Option (Opt, External_Seen); 12203 Analyze_External_Option (Opt); 12204 12205 -- Ghost 12206 12207 elsif Chars (Opt) = Name_Ghost then 12208 Check_Duplicate_Option (Opt, Ghost_Seen); 12209 Check_Ghost_Synchronous; 12210 12211 if Present (State_Id) then 12212 Set_Is_Ghost_Entity (State_Id); 12213 end if; 12214 12215 -- Synchronous 12216 12217 elsif Chars (Opt) = Name_Synchronous then 12218 Check_Duplicate_Option (Opt, Synchronous_Seen); 12219 Check_Ghost_Synchronous; 12220 12221 -- Option Part_Of without an encapsulating state is 12222 -- illegal (SPARK RM 7.1.4(9)). 12223 12224 elsif Chars (Opt) = Name_Part_Of then 12225 SPARK_Msg_N 12226 ("indicator Part_Of must denote abstract state, " 12227 & "single protected type or single task type", 12228 Opt); 12229 12230 -- Do not emit an error message when a previous state 12231 -- declaration with options was not parenthesized as 12232 -- the option is actually another state declaration. 12233 -- 12234 -- with Abstract_State 12235 -- (State_1 with ..., -- missing parentheses 12236 -- (State_2 with ...), 12237 -- State_3) -- ok state declaration 12238 12239 elsif Missing_Parentheses then 12240 null; 12241 12242 -- Otherwise the option is not allowed. Note that it 12243 -- is not possible to distinguish between an option 12244 -- and a state declaration when a previous state with 12245 -- options not properly parentheses. 12246 -- 12247 -- with Abstract_State 12248 -- (State_1 with ..., -- missing parentheses 12249 -- State_2); -- could be an option 12250 12251 else 12252 SPARK_Msg_N 12253 ("simple option not allowed in state declaration", 12254 Opt); 12255 end if; 12256 12257 -- Catch a case where missing parentheses around a state 12258 -- declaration with options cause a subsequent state 12259 -- declaration with options to be treated as an option. 12260 -- 12261 -- with Abstract_State 12262 -- (State_1 with ..., -- missing parentheses 12263 -- (State_2 with ...)) 12264 12265 elsif Nkind (Opt) = N_Extension_Aggregate then 12266 Missing_Parentheses := True; 12267 SPARK_Msg_N 12268 ("state declaration must be parenthesized", 12269 Ancestor_Part (State)); 12270 12271 -- Otherwise the option is malformed 12272 12273 else 12274 SPARK_Msg_N ("malformed option", Opt); 12275 end if; 12276 12277 Next (Opt); 12278 end loop; 12279 12280 -- Options External and Part_Of appear as component 12281 -- associations. 12282 12283 Opt := First (Component_Associations (State)); 12284 while Present (Opt) loop 12285 Opt_Nam := First (Choices (Opt)); 12286 12287 if Nkind (Opt_Nam) = N_Identifier then 12288 if Chars (Opt_Nam) = Name_External then 12289 Analyze_External_Option (Opt); 12290 12291 elsif Chars (Opt_Nam) = Name_Part_Of then 12292 Analyze_Part_Of_Option (Opt); 12293 12294 else 12295 SPARK_Msg_N ("invalid state option", Opt); 12296 end if; 12297 else 12298 SPARK_Msg_N ("invalid state option", Opt); 12299 end if; 12300 12301 Next (Opt); 12302 end loop; 12303 12304 -- Any other attempt to declare a state is illegal 12305 12306 else 12307 Malformed_State_Error (State); 12308 return; 12309 end if; 12310 12311 -- Guard against a junk state. In such cases no entity is 12312 -- generated and the subsequent checks cannot be applied. 12313 12314 if Present (State_Id) then 12315 12316 -- Verify whether the state does not introduce an illegal 12317 -- hidden state within a package subject to a null abstract 12318 -- state. 12319 12320 Check_No_Hidden_State (State_Id); 12321 12322 -- Check whether the lack of option Part_Of agrees with the 12323 -- placement of the abstract state with respect to the state 12324 -- space. 12325 12326 if not Part_Of_Seen then 12327 Check_Missing_Part_Of (State_Id); 12328 end if; 12329 12330 -- Associate the state with its related package 12331 12332 if No (Abstract_States (Pack_Id)) then 12333 Set_Abstract_States (Pack_Id, New_Elmt_List); 12334 end if; 12335 12336 Append_Elmt (State_Id, Abstract_States (Pack_Id)); 12337 end if; 12338 end Analyze_Abstract_State; 12339 12340 --------------------------- 12341 -- Malformed_State_Error -- 12342 --------------------------- 12343 12344 procedure Malformed_State_Error (State : Node_Id) is 12345 begin 12346 Error_Msg_N ("malformed abstract state declaration", State); 12347 12348 -- An abstract state with a simple option is being declared 12349 -- with "=>" rather than the legal "with". The state appears 12350 -- as a component association. 12351 12352 if Nkind (State) = N_Component_Association then 12353 Error_Msg_N ("\use WITH to specify simple option", State); 12354 end if; 12355 end Malformed_State_Error; 12356 12357 -- Local variables 12358 12359 Pack_Decl : Node_Id; 12360 Pack_Id : Entity_Id; 12361 State : Node_Id; 12362 States : Node_Id; 12363 12364 -- Start of processing for Abstract_State 12365 12366 begin 12367 GNAT_Pragma; 12368 Check_No_Identifiers; 12369 Check_Arg_Count (1); 12370 12371 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 12372 12373 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 12374 N_Package_Declaration) 12375 then 12376 Pragma_Misplaced; 12377 return; 12378 end if; 12379 12380 Pack_Id := Defining_Entity (Pack_Decl); 12381 12382 -- A pragma that applies to a Ghost entity becomes Ghost for the 12383 -- purposes of legality checks and removal of ignored Ghost code. 12384 12385 Mark_Ghost_Pragma (N, Pack_Id); 12386 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id)); 12387 12388 -- Chain the pragma on the contract for completeness 12389 12390 Add_Contract_Item (N, Pack_Id); 12391 12392 -- The legality checks of pragmas Abstract_State, Initializes, and 12393 -- Initial_Condition are affected by the SPARK mode in effect. In 12394 -- addition, these three pragmas are subject to an inherent order: 12395 12396 -- 1) Abstract_State 12397 -- 2) Initializes 12398 -- 3) Initial_Condition 12399 12400 -- Analyze all these pragmas in the order outlined above 12401 12402 Analyze_If_Present (Pragma_SPARK_Mode); 12403 States := Expression (Get_Argument (N, Pack_Id)); 12404 12405 -- Multiple non-null abstract states appear as an aggregate 12406 12407 if Nkind (States) = N_Aggregate then 12408 State := First (Expressions (States)); 12409 while Present (State) loop 12410 Analyze_Abstract_State (State, Pack_Id); 12411 Next (State); 12412 end loop; 12413 12414 -- An abstract state with a simple option is being illegaly 12415 -- declared with "=>" rather than "with". In this case the 12416 -- state declaration appears as a component association. 12417 12418 if Present (Component_Associations (States)) then 12419 State := First (Component_Associations (States)); 12420 while Present (State) loop 12421 Malformed_State_Error (State); 12422 Next (State); 12423 end loop; 12424 end if; 12425 12426 -- Various forms of a single abstract state. Note that these may 12427 -- include malformed state declarations. 12428 12429 else 12430 Analyze_Abstract_State (States, Pack_Id); 12431 end if; 12432 12433 Analyze_If_Present (Pragma_Initializes); 12434 Analyze_If_Present (Pragma_Initial_Condition); 12435 end Abstract_State; 12436 12437 -------------- 12438 -- Acc_Data -- 12439 -------------- 12440 12441 when Pragma_Acc_Data => Acc_Data : declare 12442 Clause_Names : constant Name_List := 12443 (Name_Attach, 12444 Name_Copy, 12445 Name_Copy_In, 12446 Name_Copy_Out, 12447 Name_Create, 12448 Name_Delete, 12449 Name_Detach, 12450 Name_Device_Ptr, 12451 Name_No_Create, 12452 Name_Present); 12453 12454 Clause : Node_Id; 12455 Clauses : Args_List (Clause_Names'Range); 12456 12457 begin 12458 if not OpenAcc_Enabled then 12459 return; 12460 end if; 12461 12462 GNAT_Pragma; 12463 12464 if Nkind (Parent (N)) /= N_Loop_Statement then 12465 Error_Pragma 12466 ("Acc_Data pragma should be placed in loop or block " 12467 & "statements"); 12468 end if; 12469 12470 Gather_Associations (Clause_Names, Clauses); 12471 12472 for Id in Clause_Names'First .. Clause_Names'Last loop 12473 Clause := Clauses (Id); 12474 12475 if Present (Clause) then 12476 case Clause_Names (Id) is 12477 when Name_Copy 12478 | Name_Copy_In 12479 | Name_Copy_Out 12480 | Name_Create 12481 | Name_Device_Ptr 12482 | Name_Present 12483 => 12484 Validate_Acc_Data_Clause (Clause); 12485 12486 when Name_Attach 12487 | Name_Detach 12488 | Name_Delete 12489 | Name_No_Create 12490 => 12491 Error_Pragma ("unsupported pragma clause"); 12492 12493 when others => 12494 raise Program_Error; 12495 end case; 12496 end if; 12497 end loop; 12498 12499 Set_Is_OpenAcc_Environment (Parent (N)); 12500 end Acc_Data; 12501 12502 -------------- 12503 -- Acc_Loop -- 12504 -------------- 12505 12506 when Pragma_Acc_Loop => Acc_Loop : declare 12507 Clause_Names : constant Name_List := 12508 (Name_Auto, 12509 Name_Collapse, 12510 Name_Gang, 12511 Name_Independent, 12512 Name_Acc_Private, 12513 Name_Reduction, 12514 Name_Seq, 12515 Name_Tile, 12516 Name_Vector, 12517 Name_Worker); 12518 12519 Clause : Node_Id; 12520 Clauses : Args_List (Clause_Names'Range); 12521 Par : Node_Id; 12522 12523 begin 12524 if not OpenAcc_Enabled then 12525 return; 12526 end if; 12527 12528 GNAT_Pragma; 12529 12530 -- Make sure the pragma is in an openacc construct 12531 12532 Check_Loop_Pragma_Placement; 12533 12534 Par := Parent (N); 12535 while Present (Par) 12536 and then (Nkind (Par) /= N_Loop_Statement 12537 or else not Is_OpenAcc_Environment (Par)) 12538 loop 12539 Par := Parent (Par); 12540 end loop; 12541 12542 if not Is_OpenAcc_Environment (Par) then 12543 Error_Pragma 12544 ("Acc_Loop directive must be associated with an OpenAcc " 12545 & "construct region"); 12546 end if; 12547 12548 Gather_Associations (Clause_Names, Clauses); 12549 12550 for Id in Clause_Names'First .. Clause_Names'Last loop 12551 Clause := Clauses (Id); 12552 12553 if Present (Clause) then 12554 case Clause_Names (Id) is 12555 when Name_Auto 12556 | Name_Independent 12557 | Name_Seq 12558 => 12559 null; 12560 12561 when Name_Collapse => 12562 Validate_Acc_Loop_Collapse (Clause); 12563 12564 when Name_Gang => 12565 Validate_Acc_Loop_Gang (Clause); 12566 12567 when Name_Acc_Private => 12568 Validate_Acc_Data_Clause (Clause); 12569 12570 when Name_Reduction => 12571 Validate_Acc_Name_Reduction (Clause); 12572 12573 when Name_Tile => 12574 Validate_Acc_Size_Expressions (Clause); 12575 12576 when Name_Vector => 12577 Validate_Acc_Loop_Vector (Clause); 12578 12579 when Name_Worker => 12580 Validate_Acc_Loop_Worker (Clause); 12581 12582 when others => 12583 raise Program_Error; 12584 end case; 12585 end if; 12586 end loop; 12587 12588 Set_Is_OpenAcc_Loop (Parent (N)); 12589 end Acc_Loop; 12590 12591 ---------------------------------- 12592 -- Acc_Parallel and Acc_Kernels -- 12593 ---------------------------------- 12594 12595 when Pragma_Acc_Parallel 12596 | Pragma_Acc_Kernels 12597 => 12598 Acc_Kernels_Or_Parallel : declare 12599 Clause_Names : constant Name_List := 12600 (Name_Acc_If, 12601 Name_Async, 12602 Name_Copy, 12603 Name_Copy_In, 12604 Name_Copy_Out, 12605 Name_Create, 12606 Name_Default, 12607 Name_Device_Ptr, 12608 Name_Device_Type, 12609 Name_Num_Gangs, 12610 Name_Num_Workers, 12611 Name_Present, 12612 Name_Vector_Length, 12613 Name_Wait, 12614 12615 -- Parallel only 12616 12617 Name_Acc_Private, 12618 Name_First_Private, 12619 Name_Reduction, 12620 12621 -- Kernels only 12622 12623 Name_Attach, 12624 Name_No_Create); 12625 12626 Clause : Node_Id; 12627 Clauses : Args_List (Clause_Names'Range); 12628 12629 begin 12630 if not OpenAcc_Enabled then 12631 return; 12632 end if; 12633 12634 GNAT_Pragma; 12635 Check_Loop_Pragma_Placement; 12636 12637 if Nkind (Parent (N)) /= N_Loop_Statement then 12638 Error_Pragma 12639 ("pragma should be placed in loop or block statements"); 12640 end if; 12641 12642 Gather_Associations (Clause_Names, Clauses); 12643 12644 for Id in Clause_Names'First .. Clause_Names'Last loop 12645 Clause := Clauses (Id); 12646 12647 if Present (Clause) then 12648 if Chars (Parent (Clause)) = No_Name then 12649 Error_Pragma ("all arguments should be associations"); 12650 else 12651 case Clause_Names (Id) is 12652 12653 -- Note: According to the OpenAcc Standard v2.6, 12654 -- Async's argument should be optional. Because this 12655 -- complicates parsing the clause, the argument is 12656 -- made mandatory. The standard defines two negative 12657 -- values, acc_async_noval and acc_async_sync. When 12658 -- given acc_async_noval as value, the clause should 12659 -- behave as if no argument was given. According to 12660 -- the standard, acc_async_noval is defined in header 12661 -- files for C and Fortran, thus this value should 12662 -- probably be defined in the OpenAcc Ada library once 12663 -- it is implemented. 12664 12665 when Name_Async 12666 | Name_Num_Gangs 12667 | Name_Num_Workers 12668 | Name_Vector_Length 12669 => 12670 Validate_Acc_Int_Expr_Clause (Clause); 12671 12672 when Name_Acc_If => 12673 Validate_Acc_Condition_Clause (Clause); 12674 12675 -- Unsupported by GCC 12676 12677 when Name_Attach 12678 | Name_No_Create 12679 => 12680 Error_Pragma ("unsupported clause"); 12681 12682 when Name_Acc_Private 12683 | Name_First_Private 12684 => 12685 if Prag_Id /= Pragma_Acc_Parallel then 12686 Error_Pragma 12687 ("argument is only available for 'Parallel' " 12688 & "construct"); 12689 else 12690 Validate_Acc_Data_Clause (Clause); 12691 end if; 12692 12693 when Name_Copy 12694 | Name_Copy_In 12695 | Name_Copy_Out 12696 | Name_Create 12697 | Name_Device_Ptr 12698 | Name_Present 12699 => 12700 Validate_Acc_Data_Clause (Clause); 12701 12702 when Name_Reduction => 12703 if Prag_Id /= Pragma_Acc_Parallel then 12704 Error_Pragma 12705 ("argument is only available for 'Parallel' " 12706 & "construct"); 12707 else 12708 Validate_Acc_Name_Reduction (Clause); 12709 end if; 12710 12711 when Name_Default => 12712 if Chars (Clause) /= Name_None then 12713 Error_Pragma ("expected none"); 12714 end if; 12715 12716 when Name_Device_Type => 12717 Error_Pragma ("unsupported pragma clause"); 12718 12719 -- Similar to Name_Async, Name_Wait's arguments should 12720 -- be optional. However, this can be simulated using 12721 -- acc_async_noval, hence, we do not bother making the 12722 -- argument optional for now. 12723 12724 when Name_Wait => 12725 Validate_Acc_Int_Expr_List_Clause (Clause); 12726 12727 when others => 12728 raise Program_Error; 12729 end case; 12730 end if; 12731 end if; 12732 end loop; 12733 12734 Set_Is_OpenAcc_Environment (Parent (N)); 12735 end Acc_Kernels_Or_Parallel; 12736 12737 ------------ 12738 -- Ada_83 -- 12739 ------------ 12740 12741 -- pragma Ada_83; 12742 12743 -- Note: this pragma also has some specific processing in Par.Prag 12744 -- because we want to set the Ada version mode during parsing. 12745 12746 when Pragma_Ada_83 => 12747 GNAT_Pragma; 12748 Check_Arg_Count (0); 12749 12750 -- We really should check unconditionally for proper configuration 12751 -- pragma placement, since we really don't want mixed Ada modes 12752 -- within a single unit, and the GNAT reference manual has always 12753 -- said this was a configuration pragma, but we did not check and 12754 -- are hesitant to add the check now. 12755 12756 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 12757 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 12758 -- or Ada 2012 mode. 12759 12760 if Ada_Version >= Ada_2005 then 12761 Check_Valid_Configuration_Pragma; 12762 end if; 12763 12764 -- Now set Ada 83 mode 12765 12766 if Latest_Ada_Only then 12767 Error_Pragma ("??pragma% ignored"); 12768 else 12769 Ada_Version := Ada_83; 12770 Ada_Version_Explicit := Ada_83; 12771 Ada_Version_Pragma := N; 12772 end if; 12773 12774 ------------ 12775 -- Ada_95 -- 12776 ------------ 12777 12778 -- pragma Ada_95; 12779 12780 -- Note: this pragma also has some specific processing in Par.Prag 12781 -- because we want to set the Ada 83 version mode during parsing. 12782 12783 when Pragma_Ada_95 => 12784 GNAT_Pragma; 12785 Check_Arg_Count (0); 12786 12787 -- We really should check unconditionally for proper configuration 12788 -- pragma placement, since we really don't want mixed Ada modes 12789 -- within a single unit, and the GNAT reference manual has always 12790 -- said this was a configuration pragma, but we did not check and 12791 -- are hesitant to add the check now. 12792 12793 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 12794 -- or Ada 95, so we must check if we are in Ada 2005 mode. 12795 12796 if Ada_Version >= Ada_2005 then 12797 Check_Valid_Configuration_Pragma; 12798 end if; 12799 12800 -- Now set Ada 95 mode 12801 12802 if Latest_Ada_Only then 12803 Error_Pragma ("??pragma% ignored"); 12804 else 12805 Ada_Version := Ada_95; 12806 Ada_Version_Explicit := Ada_95; 12807 Ada_Version_Pragma := N; 12808 end if; 12809 12810 --------------------- 12811 -- Ada_05/Ada_2005 -- 12812 --------------------- 12813 12814 -- pragma Ada_05; 12815 -- pragma Ada_05 (LOCAL_NAME); 12816 12817 -- pragma Ada_2005; 12818 -- pragma Ada_2005 (LOCAL_NAME): 12819 12820 -- Note: these pragmas also have some specific processing in Par.Prag 12821 -- because we want to set the Ada 2005 version mode during parsing. 12822 12823 -- The one argument form is used for managing the transition from 12824 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked 12825 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95 12826 -- mode will generate a warning. In addition, in Ada_83 or Ada_95 12827 -- mode, a preference rule is established which does not choose 12828 -- such an entity unless it is unambiguously specified. This avoids 12829 -- extra subprograms marked this way from generating ambiguities in 12830 -- otherwise legal pre-Ada_2005 programs. The one argument form is 12831 -- intended for exclusive use in the GNAT run-time library. 12832 12833 when Pragma_Ada_05 12834 | Pragma_Ada_2005 12835 => 12836 declare 12837 E_Id : Node_Id; 12838 12839 begin 12840 GNAT_Pragma; 12841 12842 if Arg_Count = 1 then 12843 Check_Arg_Is_Local_Name (Arg1); 12844 E_Id := Get_Pragma_Arg (Arg1); 12845 12846 if Etype (E_Id) = Any_Type then 12847 return; 12848 end if; 12849 12850 Set_Is_Ada_2005_Only (Entity (E_Id)); 12851 Record_Rep_Item (Entity (E_Id), N); 12852 12853 else 12854 Check_Arg_Count (0); 12855 12856 -- For Ada_2005 we unconditionally enforce the documented 12857 -- configuration pragma placement, since we do not want to 12858 -- tolerate mixed modes in a unit involving Ada 2005. That 12859 -- would cause real difficulties for those cases where there 12860 -- are incompatibilities between Ada 95 and Ada 2005. 12861 12862 Check_Valid_Configuration_Pragma; 12863 12864 -- Now set appropriate Ada mode 12865 12866 if Latest_Ada_Only then 12867 Error_Pragma ("??pragma% ignored"); 12868 else 12869 Ada_Version := Ada_2005; 12870 Ada_Version_Explicit := Ada_2005; 12871 Ada_Version_Pragma := N; 12872 end if; 12873 end if; 12874 end; 12875 12876 --------------------- 12877 -- Ada_12/Ada_2012 -- 12878 --------------------- 12879 12880 -- pragma Ada_12; 12881 -- pragma Ada_12 (LOCAL_NAME); 12882 12883 -- pragma Ada_2012; 12884 -- pragma Ada_2012 (LOCAL_NAME): 12885 12886 -- Note: these pragmas also have some specific processing in Par.Prag 12887 -- because we want to set the Ada 2012 version mode during parsing. 12888 12889 -- The one argument form is used for managing the transition from Ada 12890 -- 2005 to Ada 2012 in the run-time library. If an entity is marked 12891 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012 12892 -- mode will generate a warning. In addition, in any pre-Ada_2012 12893 -- mode, a preference rule is established which does not choose 12894 -- such an entity unless it is unambiguously specified. This avoids 12895 -- extra subprograms marked this way from generating ambiguities in 12896 -- otherwise legal pre-Ada_2012 programs. The one argument form is 12897 -- intended for exclusive use in the GNAT run-time library. 12898 12899 when Pragma_Ada_12 12900 | Pragma_Ada_2012 12901 => 12902 declare 12903 E_Id : Node_Id; 12904 12905 begin 12906 GNAT_Pragma; 12907 12908 if Arg_Count = 1 then 12909 Check_Arg_Is_Local_Name (Arg1); 12910 E_Id := Get_Pragma_Arg (Arg1); 12911 12912 if Etype (E_Id) = Any_Type then 12913 return; 12914 end if; 12915 12916 Set_Is_Ada_2012_Only (Entity (E_Id)); 12917 Record_Rep_Item (Entity (E_Id), N); 12918 12919 else 12920 Check_Arg_Count (0); 12921 12922 -- For Ada_2012 we unconditionally enforce the documented 12923 -- configuration pragma placement, since we do not want to 12924 -- tolerate mixed modes in a unit involving Ada 2012. That 12925 -- would cause real difficulties for those cases where there 12926 -- are incompatibilities between Ada 95 and Ada 2012. We could 12927 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. 12928 12929 Check_Valid_Configuration_Pragma; 12930 12931 -- Now set appropriate Ada mode 12932 12933 Ada_Version := Ada_2012; 12934 Ada_Version_Explicit := Ada_2012; 12935 Ada_Version_Pragma := N; 12936 end if; 12937 end; 12938 12939 -------------- 12940 -- Ada_2020 -- 12941 -------------- 12942 12943 -- pragma Ada_2020; 12944 12945 -- Note: this pragma also has some specific processing in Par.Prag 12946 -- because we want to set the Ada 2020 version mode during parsing. 12947 12948 when Pragma_Ada_2020 => 12949 GNAT_Pragma; 12950 12951 Check_Arg_Count (0); 12952 12953 Check_Valid_Configuration_Pragma; 12954 12955 -- Now set appropriate Ada mode 12956 12957 Ada_Version := Ada_2020; 12958 Ada_Version_Explicit := Ada_2020; 12959 Ada_Version_Pragma := N; 12960 12961 ---------------------- 12962 -- All_Calls_Remote -- 12963 ---------------------- 12964 12965 -- pragma All_Calls_Remote [(library_package_NAME)]; 12966 12967 when Pragma_All_Calls_Remote => All_Calls_Remote : declare 12968 Lib_Entity : Entity_Id; 12969 12970 begin 12971 Check_Ada_83_Warning; 12972 Check_Valid_Library_Unit_Pragma; 12973 12974 if Nkind (N) = N_Null_Statement then 12975 return; 12976 end if; 12977 12978 Lib_Entity := Find_Lib_Unit_Name; 12979 12980 -- A pragma that applies to a Ghost entity becomes Ghost for the 12981 -- purposes of legality checks and removal of ignored Ghost code. 12982 12983 Mark_Ghost_Pragma (N, Lib_Entity); 12984 12985 -- This pragma should only apply to a RCI unit (RM E.2.3(23)) 12986 12987 if Present (Lib_Entity) and then not Debug_Flag_U then 12988 if not Is_Remote_Call_Interface (Lib_Entity) then 12989 Error_Pragma ("pragma% only apply to rci unit"); 12990 12991 -- Set flag for entity of the library unit 12992 12993 else 12994 Set_Has_All_Calls_Remote (Lib_Entity); 12995 end if; 12996 end if; 12997 end All_Calls_Remote; 12998 12999 --------------------------- 13000 -- Allow_Integer_Address -- 13001 --------------------------- 13002 13003 -- pragma Allow_Integer_Address; 13004 13005 when Pragma_Allow_Integer_Address => 13006 GNAT_Pragma; 13007 Check_Valid_Configuration_Pragma; 13008 Check_Arg_Count (0); 13009 13010 -- If Address is a private type, then set the flag to allow 13011 -- integer address values. If Address is not private, then this 13012 -- pragma has no purpose, so it is simply ignored. Not clear if 13013 -- there are any such targets now. 13014 13015 if Opt.Address_Is_Private then 13016 Opt.Allow_Integer_Address := True; 13017 end if; 13018 13019 -------------- 13020 -- Annotate -- 13021 -------------- 13022 13023 -- pragma Annotate 13024 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]); 13025 -- ARG ::= NAME | EXPRESSION 13026 13027 -- The first two arguments are by convention intended to refer to an 13028 -- external tool and a tool-specific function. These arguments are 13029 -- not analyzed. 13030 13031 when Pragma_Annotate => Annotate : declare 13032 Arg : Node_Id; 13033 Expr : Node_Id; 13034 Nam_Arg : Node_Id; 13035 13036 begin 13037 GNAT_Pragma; 13038 Check_At_Least_N_Arguments (1); 13039 13040 Nam_Arg := Last (Pragma_Argument_Associations (N)); 13041 13042 -- Determine whether the last argument is "Entity => local_NAME" 13043 -- and if it is, perform the required semantic checks. Remove the 13044 -- argument from further processing. 13045 13046 if Nkind (Nam_Arg) = N_Pragma_Argument_Association 13047 and then Chars (Nam_Arg) = Name_Entity 13048 then 13049 Check_Arg_Is_Local_Name (Nam_Arg); 13050 Arg_Count := Arg_Count - 1; 13051 13052 -- A pragma that applies to a Ghost entity becomes Ghost for 13053 -- the purposes of legality checks and removal of ignored Ghost 13054 -- code. 13055 13056 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg)) 13057 and then Present (Entity (Get_Pragma_Arg (Nam_Arg))) 13058 then 13059 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg))); 13060 end if; 13061 13062 -- Not allowed in compiler units (bootstrap issues) 13063 13064 Check_Compiler_Unit ("Entity for pragma Annotate", N); 13065 end if; 13066 13067 -- Continue the processing with last argument removed for now 13068 13069 Check_Arg_Is_Identifier (Arg1); 13070 Check_No_Identifiers; 13071 Store_Note (N); 13072 13073 -- The second parameter is optional, it is never analyzed 13074 13075 if No (Arg2) then 13076 null; 13077 13078 -- Otherwise there is a second parameter 13079 13080 else 13081 -- The second parameter must be an identifier 13082 13083 Check_Arg_Is_Identifier (Arg2); 13084 13085 -- Process the remaining parameters (if any) 13086 13087 Arg := Next (Arg2); 13088 while Present (Arg) loop 13089 Expr := Get_Pragma_Arg (Arg); 13090 Analyze (Expr); 13091 13092 if Is_Entity_Name (Expr) then 13093 null; 13094 13095 -- For string literals, we assume Standard_String as the 13096 -- type, unless the string contains wide or wide_wide 13097 -- characters. 13098 13099 elsif Nkind (Expr) = N_String_Literal then 13100 if Has_Wide_Wide_Character (Expr) then 13101 Resolve (Expr, Standard_Wide_Wide_String); 13102 elsif Has_Wide_Character (Expr) then 13103 Resolve (Expr, Standard_Wide_String); 13104 else 13105 Resolve (Expr, Standard_String); 13106 end if; 13107 13108 elsif Is_Overloaded (Expr) then 13109 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr); 13110 13111 else 13112 Resolve (Expr); 13113 end if; 13114 13115 Next (Arg); 13116 end loop; 13117 end if; 13118 end Annotate; 13119 13120 ------------------------------------------------- 13121 -- Assert/Assert_And_Cut/Assume/Loop_Invariant -- 13122 ------------------------------------------------- 13123 13124 -- pragma Assert 13125 -- ( [Check => ] Boolean_EXPRESSION 13126 -- [, [Message =>] Static_String_EXPRESSION]); 13127 13128 -- pragma Assert_And_Cut 13129 -- ( [Check => ] Boolean_EXPRESSION 13130 -- [, [Message =>] Static_String_EXPRESSION]); 13131 13132 -- pragma Assume 13133 -- ( [Check => ] Boolean_EXPRESSION 13134 -- [, [Message =>] Static_String_EXPRESSION]); 13135 13136 -- pragma Loop_Invariant 13137 -- ( [Check => ] Boolean_EXPRESSION 13138 -- [, [Message =>] Static_String_EXPRESSION]); 13139 13140 when Pragma_Assert 13141 | Pragma_Assert_And_Cut 13142 | Pragma_Assume 13143 | Pragma_Loop_Invariant 13144 => 13145 Assert : declare 13146 function Contains_Loop_Entry (Expr : Node_Id) return Boolean; 13147 -- Determine whether expression Expr contains a Loop_Entry 13148 -- attribute reference. 13149 13150 ------------------------- 13151 -- Contains_Loop_Entry -- 13152 ------------------------- 13153 13154 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is 13155 Has_Loop_Entry : Boolean := False; 13156 13157 function Process (N : Node_Id) return Traverse_Result; 13158 -- Process function for traversal to look for Loop_Entry 13159 13160 ------------- 13161 -- Process -- 13162 ------------- 13163 13164 function Process (N : Node_Id) return Traverse_Result is 13165 begin 13166 if Nkind (N) = N_Attribute_Reference 13167 and then Attribute_Name (N) = Name_Loop_Entry 13168 then 13169 Has_Loop_Entry := True; 13170 return Abandon; 13171 else 13172 return OK; 13173 end if; 13174 end Process; 13175 13176 procedure Traverse is new Traverse_Proc (Process); 13177 13178 -- Start of processing for Contains_Loop_Entry 13179 13180 begin 13181 Traverse (Expr); 13182 return Has_Loop_Entry; 13183 end Contains_Loop_Entry; 13184 13185 -- Local variables 13186 13187 Expr : Node_Id; 13188 New_Args : List_Id; 13189 13190 -- Start of processing for Assert 13191 13192 begin 13193 -- Assert is an Ada 2005 RM-defined pragma 13194 13195 if Prag_Id = Pragma_Assert then 13196 Ada_2005_Pragma; 13197 13198 -- The remaining ones are GNAT pragmas 13199 13200 else 13201 GNAT_Pragma; 13202 end if; 13203 13204 Check_At_Least_N_Arguments (1); 13205 Check_At_Most_N_Arguments (2); 13206 Check_Arg_Order ((Name_Check, Name_Message)); 13207 Check_Optional_Identifier (Arg1, Name_Check); 13208 Expr := Get_Pragma_Arg (Arg1); 13209 13210 -- Special processing for Loop_Invariant, Loop_Variant or for 13211 -- other cases where a Loop_Entry attribute is present. If the 13212 -- assertion pragma contains attribute Loop_Entry, ensure that 13213 -- the related pragma is within a loop. 13214 13215 if Prag_Id = Pragma_Loop_Invariant 13216 or else Prag_Id = Pragma_Loop_Variant 13217 or else Contains_Loop_Entry (Expr) 13218 then 13219 Check_Loop_Pragma_Placement; 13220 13221 -- Perform preanalysis to deal with embedded Loop_Entry 13222 -- attributes. 13223 13224 Preanalyze_Assert_Expression (Expr, Any_Boolean); 13225 end if; 13226 13227 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating 13228 -- a corresponding Check pragma: 13229 13230 -- pragma Check (name, condition [, msg]); 13231 13232 -- Where name is the identifier matching the pragma name. So 13233 -- rewrite pragma in this manner, transfer the message argument 13234 -- if present, and analyze the result 13235 13236 -- Note: When dealing with a semantically analyzed tree, the 13237 -- information that a Check node N corresponds to a source Assert, 13238 -- Assume, or Assert_And_Cut pragma can be retrieved from the 13239 -- pragma kind of Original_Node(N). 13240 13241 New_Args := New_List ( 13242 Make_Pragma_Argument_Association (Loc, 13243 Expression => Make_Identifier (Loc, Pname)), 13244 Make_Pragma_Argument_Association (Sloc (Expr), 13245 Expression => Expr)); 13246 13247 if Arg_Count > 1 then 13248 Check_Optional_Identifier (Arg2, Name_Message); 13249 13250 -- Provide semantic annnotations for optional argument, for 13251 -- ASIS use, before rewriting. 13252 13253 Preanalyze_And_Resolve (Expression (Arg2), Standard_String); 13254 Append_To (New_Args, New_Copy_Tree (Arg2)); 13255 end if; 13256 13257 -- Rewrite as Check pragma 13258 13259 Rewrite (N, 13260 Make_Pragma (Loc, 13261 Chars => Name_Check, 13262 Pragma_Argument_Associations => New_Args)); 13263 13264 Analyze (N); 13265 end Assert; 13266 13267 ---------------------- 13268 -- Assertion_Policy -- 13269 ---------------------- 13270 13271 -- pragma Assertion_Policy (POLICY_IDENTIFIER); 13272 13273 -- The following form is Ada 2012 only, but we allow it in all modes 13274 13275 -- Pragma Assertion_Policy ( 13276 -- ASSERTION_KIND => POLICY_IDENTIFIER 13277 -- {, ASSERTION_KIND => POLICY_IDENTIFIER}); 13278 13279 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND 13280 13281 -- RM_ASSERTION_KIND ::= Assert | 13282 -- Static_Predicate | 13283 -- Dynamic_Predicate | 13284 -- Pre | 13285 -- Pre'Class | 13286 -- Post | 13287 -- Post'Class | 13288 -- Type_Invariant | 13289 -- Type_Invariant'Class 13290 13291 -- ID_ASSERTION_KIND ::= Assert_And_Cut | 13292 -- Assume | 13293 -- Contract_Cases | 13294 -- Debug | 13295 -- Default_Initial_Condition | 13296 -- Ghost | 13297 -- Initial_Condition | 13298 -- Loop_Invariant | 13299 -- Loop_Variant | 13300 -- Postcondition | 13301 -- Precondition | 13302 -- Predicate | 13303 -- Refined_Post | 13304 -- Statement_Assertions 13305 13306 -- Note: The RM_ASSERTION_KIND list is language-defined, and the 13307 -- ID_ASSERTION_KIND list contains implementation-defined additions 13308 -- recognized by GNAT. The effect is to control the behavior of 13309 -- identically named aspects and pragmas, depending on the specified 13310 -- policy identifier: 13311 13312 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible 13313 13314 -- Note: Check and Ignore are language-defined. Disable is a GNAT 13315 -- implementation-defined addition that results in totally ignoring 13316 -- the corresponding assertion. If Disable is specified, then the 13317 -- argument of the assertion is not even analyzed. This is useful 13318 -- when the aspect/pragma argument references entities in a with'ed 13319 -- package that is replaced by a dummy package in the final build. 13320 13321 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class, 13322 -- and Type_Invariant'Class were recognized by the parser and 13323 -- transformed into references to the special internal identifiers 13324 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special 13325 -- processing is required here. 13326 13327 when Pragma_Assertion_Policy => Assertion_Policy : declare 13328 procedure Resolve_Suppressible (Policy : Node_Id); 13329 -- Converts the assertion policy 'Suppressible' to either Check or 13330 -- Ignore based on whether checks are suppressed via -gnatp. 13331 13332 -------------------------- 13333 -- Resolve_Suppressible -- 13334 -------------------------- 13335 13336 procedure Resolve_Suppressible (Policy : Node_Id) is 13337 Arg : constant Node_Id := Get_Pragma_Arg (Policy); 13338 Nam : Name_Id; 13339 13340 begin 13341 -- Transform policy argument Suppressible into either Ignore or 13342 -- Check depending on whether checks are enabled or suppressed. 13343 13344 if Chars (Arg) = Name_Suppressible then 13345 if Suppress_Checks then 13346 Nam := Name_Ignore; 13347 else 13348 Nam := Name_Check; 13349 end if; 13350 13351 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam)); 13352 end if; 13353 end Resolve_Suppressible; 13354 13355 -- Local variables 13356 13357 Arg : Node_Id; 13358 Kind : Name_Id; 13359 LocP : Source_Ptr; 13360 Policy : Node_Id; 13361 13362 begin 13363 Ada_2005_Pragma; 13364 13365 -- This can always appear as a configuration pragma 13366 13367 if Is_Configuration_Pragma then 13368 null; 13369 13370 -- It can also appear in a declarative part or package spec in Ada 13371 -- 2012 mode. We allow this in other modes, but in that case we 13372 -- consider that we have an Ada 2012 pragma on our hands. 13373 13374 else 13375 Check_Is_In_Decl_Part_Or_Package_Spec; 13376 Ada_2012_Pragma; 13377 end if; 13378 13379 -- One argument case with no identifier (first form above) 13380 13381 if Arg_Count = 1 13382 and then (Nkind (Arg1) /= N_Pragma_Argument_Association 13383 or else Chars (Arg1) = No_Name) 13384 then 13385 Check_Arg_Is_One_Of (Arg1, 13386 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible); 13387 13388 Resolve_Suppressible (Arg1); 13389 13390 -- Treat one argument Assertion_Policy as equivalent to: 13391 13392 -- pragma Check_Policy (Assertion, policy) 13393 13394 -- So rewrite pragma in that manner and link on to the chain 13395 -- of Check_Policy pragmas, marking the pragma as analyzed. 13396 13397 Policy := Get_Pragma_Arg (Arg1); 13398 13399 Rewrite (N, 13400 Make_Pragma (Loc, 13401 Chars => Name_Check_Policy, 13402 Pragma_Argument_Associations => New_List ( 13403 Make_Pragma_Argument_Association (Loc, 13404 Expression => Make_Identifier (Loc, Name_Assertion)), 13405 13406 Make_Pragma_Argument_Association (Loc, 13407 Expression => 13408 Make_Identifier (Sloc (Policy), Chars (Policy)))))); 13409 Analyze (N); 13410 13411 -- Here if we have two or more arguments 13412 13413 else 13414 Check_At_Least_N_Arguments (1); 13415 Ada_2012_Pragma; 13416 13417 -- Loop through arguments 13418 13419 Arg := Arg1; 13420 while Present (Arg) loop 13421 LocP := Sloc (Arg); 13422 13423 -- Kind must be specified 13424 13425 if Nkind (Arg) /= N_Pragma_Argument_Association 13426 or else Chars (Arg) = No_Name 13427 then 13428 Error_Pragma_Arg 13429 ("missing assertion kind for pragma%", Arg); 13430 end if; 13431 13432 -- Check Kind and Policy have allowed forms 13433 13434 Kind := Chars (Arg); 13435 Policy := Get_Pragma_Arg (Arg); 13436 13437 if not Is_Valid_Assertion_Kind (Kind) then 13438 Error_Pragma_Arg 13439 ("invalid assertion kind for pragma%", Arg); 13440 end if; 13441 13442 Check_Arg_Is_One_Of (Arg, 13443 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible); 13444 13445 Resolve_Suppressible (Arg); 13446 13447 if Kind = Name_Ghost then 13448 13449 -- The Ghost policy must be either Check or Ignore 13450 -- (SPARK RM 6.9(6)). 13451 13452 if not Nam_In (Chars (Policy), Name_Check, 13453 Name_Ignore) 13454 then 13455 Error_Pragma_Arg 13456 ("argument of pragma % Ghost must be Check or " 13457 & "Ignore", Policy); 13458 end if; 13459 13460 -- Pragma Assertion_Policy specifying a Ghost policy 13461 -- cannot occur within a Ghost subprogram or package 13462 -- (SPARK RM 6.9(14)). 13463 13464 if Ghost_Mode > None then 13465 Error_Pragma 13466 ("pragma % cannot appear within ghost subprogram or " 13467 & "package"); 13468 end if; 13469 end if; 13470 13471 -- Rewrite the Assertion_Policy pragma as a series of 13472 -- Check_Policy pragmas of the form: 13473 13474 -- Check_Policy (Kind, Policy); 13475 13476 -- Note: the insertion of the pragmas cannot be done with 13477 -- Insert_Action because in the configuration case, there 13478 -- are no scopes on the scope stack and the mechanism will 13479 -- fail. 13480 13481 Insert_Before_And_Analyze (N, 13482 Make_Pragma (LocP, 13483 Chars => Name_Check_Policy, 13484 Pragma_Argument_Associations => New_List ( 13485 Make_Pragma_Argument_Association (LocP, 13486 Expression => Make_Identifier (LocP, Kind)), 13487 Make_Pragma_Argument_Association (LocP, 13488 Expression => Policy)))); 13489 13490 Arg := Next (Arg); 13491 end loop; 13492 13493 -- Rewrite the Assertion_Policy pragma as null since we have 13494 -- now inserted all the equivalent Check pragmas. 13495 13496 Rewrite (N, Make_Null_Statement (Loc)); 13497 Analyze (N); 13498 end if; 13499 end Assertion_Policy; 13500 13501 ------------------------------ 13502 -- Assume_No_Invalid_Values -- 13503 ------------------------------ 13504 13505 -- pragma Assume_No_Invalid_Values (On | Off); 13506 13507 when Pragma_Assume_No_Invalid_Values => 13508 GNAT_Pragma; 13509 Check_Valid_Configuration_Pragma; 13510 Check_Arg_Count (1); 13511 Check_No_Identifiers; 13512 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 13513 13514 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 13515 Assume_No_Invalid_Values := True; 13516 else 13517 Assume_No_Invalid_Values := False; 13518 end if; 13519 13520 -------------------------- 13521 -- Attribute_Definition -- 13522 -------------------------- 13523 13524 -- pragma Attribute_Definition 13525 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, 13526 -- [Entity =>] LOCAL_NAME, 13527 -- [Expression =>] EXPRESSION | NAME); 13528 13529 when Pragma_Attribute_Definition => Attribute_Definition : declare 13530 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); 13531 Aname : Name_Id; 13532 13533 begin 13534 GNAT_Pragma; 13535 Check_Arg_Count (3); 13536 Check_Optional_Identifier (Arg1, "attribute"); 13537 Check_Optional_Identifier (Arg2, "entity"); 13538 Check_Optional_Identifier (Arg3, "expression"); 13539 13540 if Nkind (Attribute_Designator) /= N_Identifier then 13541 Error_Msg_N ("attribute name expected", Attribute_Designator); 13542 return; 13543 end if; 13544 13545 Check_Arg_Is_Local_Name (Arg2); 13546 13547 -- If the attribute is not recognized, then issue a warning (not 13548 -- an error), and ignore the pragma. 13549 13550 Aname := Chars (Attribute_Designator); 13551 13552 if not Is_Attribute_Name (Aname) then 13553 Bad_Attribute (Attribute_Designator, Aname, Warn => True); 13554 return; 13555 end if; 13556 13557 -- Otherwise, rewrite the pragma as an attribute definition clause 13558 13559 Rewrite (N, 13560 Make_Attribute_Definition_Clause (Loc, 13561 Name => Get_Pragma_Arg (Arg2), 13562 Chars => Aname, 13563 Expression => Get_Pragma_Arg (Arg3))); 13564 Analyze (N); 13565 end Attribute_Definition; 13566 13567 ------------------------------------------------------------------ 13568 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- 13569 ------------------------------------------------------------------ 13570 13571 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ]; 13572 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ]; 13573 -- pragma Effective_Reads [ (boolean_EXPRESSION) ]; 13574 -- pragma Effective_Writes [ (boolean_EXPRESSION) ]; 13575 13576 when Pragma_Async_Readers 13577 | Pragma_Async_Writers 13578 | Pragma_Effective_Reads 13579 | Pragma_Effective_Writes 13580 => 13581 Async_Effective : declare 13582 Obj_Decl : Node_Id; 13583 Obj_Id : Entity_Id; 13584 13585 begin 13586 GNAT_Pragma; 13587 Check_No_Identifiers; 13588 Check_At_Most_N_Arguments (1); 13589 13590 Obj_Decl := Find_Related_Context (N, Do_Checks => True); 13591 13592 -- Object declaration 13593 13594 if Nkind (Obj_Decl) /= N_Object_Declaration then 13595 Pragma_Misplaced; 13596 return; 13597 end if; 13598 13599 Obj_Id := Defining_Entity (Obj_Decl); 13600 13601 -- Perform minimal verification to ensure that the argument is at 13602 -- least a variable. Subsequent finer grained checks will be done 13603 -- at the end of the declarative region the contains the pragma. 13604 13605 if Ekind (Obj_Id) = E_Variable then 13606 13607 -- A pragma that applies to a Ghost entity becomes Ghost for 13608 -- the purposes of legality checks and removal of ignored Ghost 13609 -- code. 13610 13611 Mark_Ghost_Pragma (N, Obj_Id); 13612 13613 -- Chain the pragma on the contract for further processing by 13614 -- Analyze_External_Property_In_Decl_Part. 13615 13616 Add_Contract_Item (N, Obj_Id); 13617 13618 -- Analyze the Boolean expression (if any) 13619 13620 if Present (Arg1) then 13621 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 13622 end if; 13623 13624 -- Otherwise the external property applies to a constant 13625 13626 else 13627 Error_Pragma ("pragma % must apply to a volatile object"); 13628 end if; 13629 end Async_Effective; 13630 13631 ------------------ 13632 -- Asynchronous -- 13633 ------------------ 13634 13635 -- pragma Asynchronous (LOCAL_NAME); 13636 13637 when Pragma_Asynchronous => Asynchronous : declare 13638 C_Ent : Entity_Id; 13639 Decl : Node_Id; 13640 Formal : Entity_Id; 13641 L : List_Id; 13642 Nm : Entity_Id; 13643 S : Node_Id; 13644 13645 procedure Process_Async_Pragma; 13646 -- Common processing for procedure and access-to-procedure case 13647 13648 -------------------------- 13649 -- Process_Async_Pragma -- 13650 -------------------------- 13651 13652 procedure Process_Async_Pragma is 13653 begin 13654 if No (L) then 13655 Set_Is_Asynchronous (Nm); 13656 return; 13657 end if; 13658 13659 -- The formals should be of mode IN (RM E.4.1(6)) 13660 13661 S := First (L); 13662 while Present (S) loop 13663 Formal := Defining_Identifier (S); 13664 13665 if Nkind (Formal) = N_Defining_Identifier 13666 and then Ekind (Formal) /= E_In_Parameter 13667 then 13668 Error_Pragma_Arg 13669 ("pragma% procedure can only have IN parameter", 13670 Arg1); 13671 end if; 13672 13673 Next (S); 13674 end loop; 13675 13676 Set_Is_Asynchronous (Nm); 13677 end Process_Async_Pragma; 13678 13679 -- Start of processing for pragma Asynchronous 13680 13681 begin 13682 Check_Ada_83_Warning; 13683 Check_No_Identifiers; 13684 Check_Arg_Count (1); 13685 Check_Arg_Is_Local_Name (Arg1); 13686 13687 if Debug_Flag_U then 13688 return; 13689 end if; 13690 13691 C_Ent := Cunit_Entity (Current_Sem_Unit); 13692 Analyze (Get_Pragma_Arg (Arg1)); 13693 Nm := Entity (Get_Pragma_Arg (Arg1)); 13694 13695 -- A pragma that applies to a Ghost entity becomes Ghost for the 13696 -- purposes of legality checks and removal of ignored Ghost code. 13697 13698 Mark_Ghost_Pragma (N, Nm); 13699 13700 if not Is_Remote_Call_Interface (C_Ent) 13701 and then not Is_Remote_Types (C_Ent) 13702 then 13703 -- This pragma should only appear in an RCI or Remote Types 13704 -- unit (RM E.4.1(4)). 13705 13706 Error_Pragma 13707 ("pragma% not in Remote_Call_Interface or Remote_Types unit"); 13708 end if; 13709 13710 if Ekind (Nm) = E_Procedure 13711 and then Nkind (Parent (Nm)) = N_Procedure_Specification 13712 then 13713 if not Is_Remote_Call_Interface (Nm) then 13714 Error_Pragma_Arg 13715 ("pragma% cannot be applied on non-remote procedure", 13716 Arg1); 13717 end if; 13718 13719 L := Parameter_Specifications (Parent (Nm)); 13720 Process_Async_Pragma; 13721 return; 13722 13723 elsif Ekind (Nm) = E_Function then 13724 Error_Pragma_Arg 13725 ("pragma% cannot be applied to function", Arg1); 13726 13727 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then 13728 if Is_Record_Type (Nm) then 13729 13730 -- A record type that is the Equivalent_Type for a remote 13731 -- access-to-subprogram type. 13732 13733 Decl := Declaration_Node (Corresponding_Remote_Type (Nm)); 13734 13735 else 13736 -- A non-expanded RAS type (distribution is not enabled) 13737 13738 Decl := Declaration_Node (Nm); 13739 end if; 13740 13741 if Nkind (Decl) = N_Full_Type_Declaration 13742 and then Nkind (Type_Definition (Decl)) = 13743 N_Access_Procedure_Definition 13744 then 13745 L := Parameter_Specifications (Type_Definition (Decl)); 13746 Process_Async_Pragma; 13747 13748 if Is_Asynchronous (Nm) 13749 and then Expander_Active 13750 and then Get_PCS_Name /= Name_No_DSA 13751 then 13752 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); 13753 end if; 13754 13755 else 13756 Error_Pragma_Arg 13757 ("pragma% cannot reference access-to-function type", 13758 Arg1); 13759 end if; 13760 13761 -- Only other possibility is Access-to-class-wide type 13762 13763 elsif Is_Access_Type (Nm) 13764 and then Is_Class_Wide_Type (Designated_Type (Nm)) 13765 then 13766 Check_First_Subtype (Arg1); 13767 Set_Is_Asynchronous (Nm); 13768 if Expander_Active then 13769 RACW_Type_Is_Asynchronous (Nm); 13770 end if; 13771 13772 else 13773 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); 13774 end if; 13775 end Asynchronous; 13776 13777 ------------ 13778 -- Atomic -- 13779 ------------ 13780 13781 -- pragma Atomic (LOCAL_NAME); 13782 13783 when Pragma_Atomic => 13784 Process_Atomic_Independent_Shared_Volatile; 13785 13786 ----------------------- 13787 -- Atomic_Components -- 13788 ----------------------- 13789 13790 -- pragma Atomic_Components (array_LOCAL_NAME); 13791 13792 -- This processing is shared by Volatile_Components 13793 13794 when Pragma_Atomic_Components 13795 | Pragma_Volatile_Components 13796 => 13797 Atomic_Components : declare 13798 D : Node_Id; 13799 E : Entity_Id; 13800 E_Id : Node_Id; 13801 K : Node_Kind; 13802 13803 begin 13804 Check_Ada_83_Warning; 13805 Check_No_Identifiers; 13806 Check_Arg_Count (1); 13807 Check_Arg_Is_Local_Name (Arg1); 13808 E_Id := Get_Pragma_Arg (Arg1); 13809 13810 if Etype (E_Id) = Any_Type then 13811 return; 13812 end if; 13813 13814 E := Entity (E_Id); 13815 13816 -- A pragma that applies to a Ghost entity becomes Ghost for the 13817 -- purposes of legality checks and removal of ignored Ghost code. 13818 13819 Mark_Ghost_Pragma (N, E); 13820 Check_Duplicate_Pragma (E); 13821 13822 if Rep_Item_Too_Early (E, N) 13823 or else 13824 Rep_Item_Too_Late (E, N) 13825 then 13826 return; 13827 end if; 13828 13829 D := Declaration_Node (E); 13830 K := Nkind (D); 13831 13832 if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) 13833 or else 13834 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 13835 and then Nkind (D) = N_Object_Declaration 13836 and then Nkind (Object_Definition (D)) = 13837 N_Constrained_Array_Definition) 13838 then 13839 -- The flag is set on the object, or on the base type 13840 13841 if Nkind (D) /= N_Object_Declaration then 13842 E := Base_Type (E); 13843 end if; 13844 13845 -- Atomic implies both Independent and Volatile 13846 13847 if Prag_Id = Pragma_Atomic_Components then 13848 Set_Has_Atomic_Components (E); 13849 Set_Has_Independent_Components (E); 13850 end if; 13851 13852 Set_Has_Volatile_Components (E); 13853 13854 else 13855 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 13856 end if; 13857 end Atomic_Components; 13858 13859 -------------------- 13860 -- Attach_Handler -- 13861 -------------------- 13862 13863 -- pragma Attach_Handler (handler_NAME, EXPRESSION); 13864 13865 when Pragma_Attach_Handler => 13866 Check_Ada_83_Warning; 13867 Check_No_Identifiers; 13868 Check_Arg_Count (2); 13869 13870 if No_Run_Time_Mode then 13871 Error_Msg_CRT ("Attach_Handler pragma", N); 13872 else 13873 Check_Interrupt_Or_Attach_Handler; 13874 13875 -- The expression that designates the attribute may depend on a 13876 -- discriminant, and is therefore a per-object expression, to 13877 -- be expanded in the init proc. If expansion is enabled, then 13878 -- perform semantic checks on a copy only. 13879 13880 declare 13881 Temp : Node_Id; 13882 Typ : Node_Id; 13883 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2); 13884 13885 begin 13886 -- In Relaxed_RM_Semantics mode, we allow any static 13887 -- integer value, for compatibility with other compilers. 13888 13889 if Relaxed_RM_Semantics 13890 and then Nkind (Parg2) = N_Integer_Literal 13891 then 13892 Typ := Standard_Integer; 13893 else 13894 Typ := RTE (RE_Interrupt_ID); 13895 end if; 13896 13897 if Expander_Active then 13898 Temp := New_Copy_Tree (Parg2); 13899 Set_Parent (Temp, N); 13900 Preanalyze_And_Resolve (Temp, Typ); 13901 else 13902 Analyze (Parg2); 13903 Resolve (Parg2, Typ); 13904 end if; 13905 end; 13906 13907 Process_Interrupt_Or_Attach_Handler; 13908 end if; 13909 13910 -------------------- 13911 -- C_Pass_By_Copy -- 13912 -------------------- 13913 13914 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); 13915 13916 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare 13917 Arg : Node_Id; 13918 Val : Uint; 13919 13920 begin 13921 GNAT_Pragma; 13922 Check_Valid_Configuration_Pragma; 13923 Check_Arg_Count (1); 13924 Check_Optional_Identifier (Arg1, "max_size"); 13925 13926 Arg := Get_Pragma_Arg (Arg1); 13927 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer); 13928 13929 Val := Expr_Value (Arg); 13930 13931 if Val <= 0 then 13932 Error_Pragma_Arg 13933 ("maximum size for pragma% must be positive", Arg1); 13934 13935 elsif UI_Is_In_Int_Range (Val) then 13936 Default_C_Record_Mechanism := UI_To_Int (Val); 13937 13938 -- If a giant value is given, Int'Last will do well enough. 13939 -- If sometime someone complains that a record larger than 13940 -- two gigabytes is not copied, we will worry about it then. 13941 13942 else 13943 Default_C_Record_Mechanism := Mechanism_Type'Last; 13944 end if; 13945 end C_Pass_By_Copy; 13946 13947 ----------- 13948 -- Check -- 13949 ----------- 13950 13951 -- pragma Check ([Name =>] CHECK_KIND, 13952 -- [Check =>] Boolean_EXPRESSION 13953 -- [,[Message =>] String_EXPRESSION]); 13954 13955 -- CHECK_KIND ::= IDENTIFIER | 13956 -- Pre'Class | 13957 -- Post'Class | 13958 -- Invariant'Class | 13959 -- Type_Invariant'Class 13960 13961 -- The identifiers Assertions and Statement_Assertions are not 13962 -- allowed, since they have special meaning for Check_Policy. 13963 13964 -- WARNING: The code below manages Ghost regions. Return statements 13965 -- must be replaced by gotos which jump to the end of the code and 13966 -- restore the Ghost mode. 13967 13968 when Pragma_Check => Check : declare 13969 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 13970 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 13971 -- Save the Ghost-related attributes to restore on exit 13972 13973 Cname : Name_Id; 13974 Eloc : Source_Ptr; 13975 Expr : Node_Id; 13976 Str : Node_Id; 13977 pragma Warnings (Off, Str); 13978 13979 begin 13980 -- Pragma Check is Ghost when it applies to a Ghost entity. Set 13981 -- the mode now to ensure that any nodes generated during analysis 13982 -- and expansion are marked as Ghost. 13983 13984 Set_Ghost_Mode (N); 13985 13986 GNAT_Pragma; 13987 Check_At_Least_N_Arguments (2); 13988 Check_At_Most_N_Arguments (3); 13989 Check_Optional_Identifier (Arg1, Name_Name); 13990 Check_Optional_Identifier (Arg2, Name_Check); 13991 13992 if Arg_Count = 3 then 13993 Check_Optional_Identifier (Arg3, Name_Message); 13994 Str := Get_Pragma_Arg (Arg3); 13995 end if; 13996 13997 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1)); 13998 Check_Arg_Is_Identifier (Arg1); 13999 Cname := Chars (Get_Pragma_Arg (Arg1)); 14000 14001 -- Check forbidden name Assertions or Statement_Assertions 14002 14003 case Cname is 14004 when Name_Assertions => 14005 Error_Pragma_Arg 14006 ("""Assertions"" is not allowed as a check kind for " 14007 & "pragma%", Arg1); 14008 14009 when Name_Statement_Assertions => 14010 Error_Pragma_Arg 14011 ("""Statement_Assertions"" is not allowed as a check kind " 14012 & "for pragma%", Arg1); 14013 14014 when others => 14015 null; 14016 end case; 14017 14018 -- Check applicable policy. We skip this if Checked/Ignored status 14019 -- is already set (e.g. in the case of a pragma from an aspect). 14020 14021 if Is_Checked (N) or else Is_Ignored (N) then 14022 null; 14023 14024 -- For a non-source pragma that is a rewriting of another pragma, 14025 -- copy the Is_Checked/Ignored status from the rewritten pragma. 14026 14027 elsif Is_Rewrite_Substitution (N) 14028 and then Nkind (Original_Node (N)) = N_Pragma 14029 then 14030 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 14031 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 14032 14033 -- Otherwise query the applicable policy at this point 14034 14035 else 14036 case Check_Kind (Cname) is 14037 when Name_Ignore => 14038 Set_Is_Ignored (N, True); 14039 Set_Is_Checked (N, False); 14040 14041 when Name_Check => 14042 Set_Is_Ignored (N, False); 14043 Set_Is_Checked (N, True); 14044 14045 -- For disable, rewrite pragma as null statement and skip 14046 -- rest of the analysis of the pragma. 14047 14048 when Name_Disable => 14049 Rewrite (N, Make_Null_Statement (Loc)); 14050 Analyze (N); 14051 raise Pragma_Exit; 14052 14053 -- No other possibilities 14054 14055 when others => 14056 raise Program_Error; 14057 end case; 14058 end if; 14059 14060 -- If check kind was not Disable, then continue pragma analysis 14061 14062 Expr := Get_Pragma_Arg (Arg2); 14063 14064 -- Deal with SCO generation 14065 14066 if Is_Checked (N) and then not Split_PPC (N) then 14067 Set_SCO_Pragma_Enabled (Loc); 14068 end if; 14069 14070 -- Deal with analyzing the string argument. If checks are not 14071 -- on we don't want any expansion (since such expansion would 14072 -- not get properly deleted) but we do want to analyze (to get 14073 -- proper references). The Preanalyze_And_Resolve routine does 14074 -- just what we want. Ditto if pragma is active, because it will 14075 -- be rewritten as an if-statement whose analysis will complete 14076 -- analysis and expansion of the string message. This makes a 14077 -- difference in the unusual case where the expression for the 14078 -- string may have a side effect, such as raising an exception. 14079 -- This is mandated by RM 11.4.2, which specifies that the string 14080 -- expression is only evaluated if the check fails and 14081 -- Assertion_Error is to be raised. 14082 14083 if Arg_Count = 3 then 14084 Preanalyze_And_Resolve (Str, Standard_String); 14085 end if; 14086 14087 -- Now you might think we could just do the same with the Boolean 14088 -- expression if checks are off (and expansion is on) and then 14089 -- rewrite the check as a null statement. This would work but we 14090 -- would lose the useful warnings about an assertion being bound 14091 -- to fail even if assertions are turned off. 14092 14093 -- So instead we wrap the boolean expression in an if statement 14094 -- that looks like: 14095 14096 -- if False and then condition then 14097 -- null; 14098 -- end if; 14099 14100 -- The reason we do this rewriting during semantic analysis rather 14101 -- than as part of normal expansion is that we cannot analyze and 14102 -- expand the code for the boolean expression directly, or it may 14103 -- cause insertion of actions that would escape the attempt to 14104 -- suppress the check code. 14105 14106 -- Note that the Sloc for the if statement corresponds to the 14107 -- argument condition, not the pragma itself. The reason for 14108 -- this is that we may generate a warning if the condition is 14109 -- False at compile time, and we do not want to delete this 14110 -- warning when we delete the if statement. 14111 14112 if Expander_Active and Is_Ignored (N) then 14113 Eloc := Sloc (Expr); 14114 14115 Rewrite (N, 14116 Make_If_Statement (Eloc, 14117 Condition => 14118 Make_And_Then (Eloc, 14119 Left_Opnd => Make_Identifier (Eloc, Name_False), 14120 Right_Opnd => Expr), 14121 Then_Statements => New_List ( 14122 Make_Null_Statement (Eloc)))); 14123 14124 -- Now go ahead and analyze the if statement 14125 14126 In_Assertion_Expr := In_Assertion_Expr + 1; 14127 14128 -- One rather special treatment. If we are now in Eliminated 14129 -- overflow mode, then suppress overflow checking since we do 14130 -- not want to drag in the bignum stuff if we are in Ignore 14131 -- mode anyway. This is particularly important if we are using 14132 -- a configurable run time that does not support bignum ops. 14133 14134 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then 14135 declare 14136 Svo : constant Boolean := 14137 Scope_Suppress.Suppress (Overflow_Check); 14138 begin 14139 Scope_Suppress.Overflow_Mode_Assertions := Strict; 14140 Scope_Suppress.Suppress (Overflow_Check) := True; 14141 Analyze (N); 14142 Scope_Suppress.Suppress (Overflow_Check) := Svo; 14143 Scope_Suppress.Overflow_Mode_Assertions := Eliminated; 14144 end; 14145 14146 -- Not that special case 14147 14148 else 14149 Analyze (N); 14150 end if; 14151 14152 -- All done with this check 14153 14154 In_Assertion_Expr := In_Assertion_Expr - 1; 14155 14156 -- Check is active or expansion not active. In these cases we can 14157 -- just go ahead and analyze the boolean with no worries. 14158 14159 else 14160 In_Assertion_Expr := In_Assertion_Expr + 1; 14161 Analyze_And_Resolve (Expr, Any_Boolean); 14162 In_Assertion_Expr := In_Assertion_Expr - 1; 14163 end if; 14164 14165 Restore_Ghost_Region (Saved_GM, Saved_IGR); 14166 end Check; 14167 14168 -------------------------- 14169 -- Check_Float_Overflow -- 14170 -------------------------- 14171 14172 -- pragma Check_Float_Overflow; 14173 14174 when Pragma_Check_Float_Overflow => 14175 GNAT_Pragma; 14176 Check_Valid_Configuration_Pragma; 14177 Check_Arg_Count (0); 14178 Check_Float_Overflow := not Machine_Overflows_On_Target; 14179 14180 ---------------- 14181 -- Check_Name -- 14182 ---------------- 14183 14184 -- pragma Check_Name (check_IDENTIFIER); 14185 14186 when Pragma_Check_Name => 14187 GNAT_Pragma; 14188 Check_No_Identifiers; 14189 Check_Valid_Configuration_Pragma; 14190 Check_Arg_Count (1); 14191 Check_Arg_Is_Identifier (Arg1); 14192 14193 declare 14194 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 14195 14196 begin 14197 for J in Check_Names.First .. Check_Names.Last loop 14198 if Check_Names.Table (J) = Nam then 14199 return; 14200 end if; 14201 end loop; 14202 14203 Check_Names.Append (Nam); 14204 end; 14205 14206 ------------------ 14207 -- Check_Policy -- 14208 ------------------ 14209 14210 -- This is the old style syntax, which is still allowed in all modes: 14211 14212 -- pragma Check_Policy ([Name =>] CHECK_KIND 14213 -- [Policy =>] POLICY_IDENTIFIER); 14214 14215 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore 14216 14217 -- CHECK_KIND ::= IDENTIFIER | 14218 -- Pre'Class | 14219 -- Post'Class | 14220 -- Type_Invariant'Class | 14221 -- Invariant'Class 14222 14223 -- This is the new style syntax, compatible with Assertion_Policy 14224 -- and also allowed in all modes. 14225 14226 -- Pragma Check_Policy ( 14227 -- CHECK_KIND => POLICY_IDENTIFIER 14228 -- {, CHECK_KIND => POLICY_IDENTIFIER}); 14229 14230 -- Note: the identifiers Name and Policy are not allowed as 14231 -- Check_Kind values. This avoids ambiguities between the old and 14232 -- new form syntax. 14233 14234 when Pragma_Check_Policy => Check_Policy : declare 14235 Kind : Node_Id; 14236 14237 begin 14238 GNAT_Pragma; 14239 Check_At_Least_N_Arguments (1); 14240 14241 -- A Check_Policy pragma can appear either as a configuration 14242 -- pragma, or in a declarative part or a package spec (see RM 14243 -- 11.5(5) for rules for Suppress/Unsuppress which are also 14244 -- followed for Check_Policy). 14245 14246 if not Is_Configuration_Pragma then 14247 Check_Is_In_Decl_Part_Or_Package_Spec; 14248 end if; 14249 14250 -- Figure out if we have the old or new syntax. We have the 14251 -- old syntax if the first argument has no identifier, or the 14252 -- identifier is Name. 14253 14254 if Nkind (Arg1) /= N_Pragma_Argument_Association 14255 or else Nam_In (Chars (Arg1), No_Name, Name_Name) 14256 then 14257 -- Old syntax 14258 14259 Check_Arg_Count (2); 14260 Check_Optional_Identifier (Arg1, Name_Name); 14261 Kind := Get_Pragma_Arg (Arg1); 14262 Rewrite_Assertion_Kind (Kind, 14263 From_Policy => Comes_From_Source (N)); 14264 Check_Arg_Is_Identifier (Arg1); 14265 14266 -- Check forbidden check kind 14267 14268 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then 14269 Error_Msg_Name_2 := Chars (Kind); 14270 Error_Pragma_Arg 14271 ("pragma% does not allow% as check name", Arg1); 14272 end if; 14273 14274 -- Check policy 14275 14276 Check_Optional_Identifier (Arg2, Name_Policy); 14277 Check_Arg_Is_One_Of 14278 (Arg2, 14279 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); 14280 14281 -- And chain pragma on the Check_Policy_List for search 14282 14283 Set_Next_Pragma (N, Opt.Check_Policy_List); 14284 Opt.Check_Policy_List := N; 14285 14286 -- For the new syntax, what we do is to convert each argument to 14287 -- an old syntax equivalent. We do that because we want to chain 14288 -- old style Check_Policy pragmas for the search (we don't want 14289 -- to have to deal with multiple arguments in the search). 14290 14291 else 14292 declare 14293 Arg : Node_Id; 14294 Argx : Node_Id; 14295 LocP : Source_Ptr; 14296 New_P : Node_Id; 14297 14298 begin 14299 Arg := Arg1; 14300 while Present (Arg) loop 14301 LocP := Sloc (Arg); 14302 Argx := Get_Pragma_Arg (Arg); 14303 14304 -- Kind must be specified 14305 14306 if Nkind (Arg) /= N_Pragma_Argument_Association 14307 or else Chars (Arg) = No_Name 14308 then 14309 Error_Pragma_Arg 14310 ("missing assertion kind for pragma%", Arg); 14311 end if; 14312 14313 -- Construct equivalent old form syntax Check_Policy 14314 -- pragma and insert it to get remaining checks. 14315 14316 New_P := 14317 Make_Pragma (LocP, 14318 Chars => Name_Check_Policy, 14319 Pragma_Argument_Associations => New_List ( 14320 Make_Pragma_Argument_Association (LocP, 14321 Expression => 14322 Make_Identifier (LocP, Chars (Arg))), 14323 Make_Pragma_Argument_Association (Sloc (Argx), 14324 Expression => Argx))); 14325 14326 Arg := Next (Arg); 14327 14328 -- For a configuration pragma, insert old form in 14329 -- the corresponding file. 14330 14331 if Is_Configuration_Pragma then 14332 Insert_After (N, New_P); 14333 Analyze (New_P); 14334 14335 else 14336 Insert_Action (N, New_P); 14337 end if; 14338 end loop; 14339 14340 -- Rewrite original Check_Policy pragma to null, since we 14341 -- have converted it into a series of old syntax pragmas. 14342 14343 Rewrite (N, Make_Null_Statement (Loc)); 14344 Analyze (N); 14345 end; 14346 end if; 14347 end Check_Policy; 14348 14349 ------------- 14350 -- Comment -- 14351 ------------- 14352 14353 -- pragma Comment (static_string_EXPRESSION) 14354 14355 -- Processing for pragma Comment shares the circuitry for pragma 14356 -- Ident. The only differences are that Ident enforces a limit of 31 14357 -- characters on its argument, and also enforces limitations on 14358 -- placement for DEC compatibility. Pragma Comment shares neither of 14359 -- these restrictions. 14360 14361 ------------------- 14362 -- Common_Object -- 14363 ------------------- 14364 14365 -- pragma Common_Object ( 14366 -- [Internal =>] LOCAL_NAME 14367 -- [, [External =>] EXTERNAL_SYMBOL] 14368 -- [, [Size =>] EXTERNAL_SYMBOL]); 14369 14370 -- Processing for this pragma is shared with Psect_Object 14371 14372 ------------------------ 14373 -- Compile_Time_Error -- 14374 ------------------------ 14375 14376 -- pragma Compile_Time_Error 14377 -- (boolean_EXPRESSION, static_string_EXPRESSION); 14378 14379 when Pragma_Compile_Time_Error => 14380 GNAT_Pragma; 14381 Process_Compile_Time_Warning_Or_Error; 14382 14383 -------------------------- 14384 -- Compile_Time_Warning -- 14385 -------------------------- 14386 14387 -- pragma Compile_Time_Warning 14388 -- (boolean_EXPRESSION, static_string_EXPRESSION); 14389 14390 when Pragma_Compile_Time_Warning => 14391 GNAT_Pragma; 14392 Process_Compile_Time_Warning_Or_Error; 14393 14394 --------------------------- 14395 -- Compiler_Unit_Warning -- 14396 --------------------------- 14397 14398 -- pragma Compiler_Unit_Warning; 14399 14400 -- Historical note 14401 14402 -- Originally, we had only pragma Compiler_Unit, and it resulted in 14403 -- errors not warnings. This means that we had introduced a big extra 14404 -- inertia to compiler changes, since even if we implemented a new 14405 -- feature, and even if all versions to be used for bootstrapping 14406 -- implemented this new feature, we could not use it, since old 14407 -- compilers would give errors for using this feature in units 14408 -- having Compiler_Unit pragmas. 14409 14410 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the 14411 -- problem. We no longer have any units mentioning Compiler_Unit, 14412 -- so old compilers see Compiler_Unit_Warning which is unrecognized, 14413 -- and thus generates a warning which can be ignored. So that deals 14414 -- with the problem of old compilers not implementing the newer form 14415 -- of the pragma. 14416 14417 -- Newer compilers recognize the new pragma, but generate warning 14418 -- messages instead of errors, which again can be ignored in the 14419 -- case of an old compiler which implements a wanted new feature 14420 -- but at the time felt like warning about it for older compilers. 14421 14422 -- We retain Compiler_Unit so that new compilers can be used to build 14423 -- older run-times that use this pragma. That's an unusual case, but 14424 -- it's easy enough to handle, so why not? 14425 14426 when Pragma_Compiler_Unit 14427 | Pragma_Compiler_Unit_Warning 14428 => 14429 GNAT_Pragma; 14430 Check_Arg_Count (0); 14431 14432 -- Only recognized in main unit 14433 14434 if Current_Sem_Unit = Main_Unit then 14435 Compiler_Unit := True; 14436 end if; 14437 14438 ----------------------------- 14439 -- Complete_Representation -- 14440 ----------------------------- 14441 14442 -- pragma Complete_Representation; 14443 14444 when Pragma_Complete_Representation => 14445 GNAT_Pragma; 14446 Check_Arg_Count (0); 14447 14448 if Nkind (Parent (N)) /= N_Record_Representation_Clause then 14449 Error_Pragma 14450 ("pragma & must appear within record representation clause"); 14451 end if; 14452 14453 ---------------------------- 14454 -- Complex_Representation -- 14455 ---------------------------- 14456 14457 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); 14458 14459 when Pragma_Complex_Representation => Complex_Representation : declare 14460 E_Id : Entity_Id; 14461 E : Entity_Id; 14462 Ent : Entity_Id; 14463 14464 begin 14465 GNAT_Pragma; 14466 Check_Arg_Count (1); 14467 Check_Optional_Identifier (Arg1, Name_Entity); 14468 Check_Arg_Is_Local_Name (Arg1); 14469 E_Id := Get_Pragma_Arg (Arg1); 14470 14471 if Etype (E_Id) = Any_Type then 14472 return; 14473 end if; 14474 14475 E := Entity (E_Id); 14476 14477 if not Is_Record_Type (E) then 14478 Error_Pragma_Arg 14479 ("argument for pragma% must be record type", Arg1); 14480 end if; 14481 14482 Ent := First_Entity (E); 14483 14484 if No (Ent) 14485 or else No (Next_Entity (Ent)) 14486 or else Present (Next_Entity (Next_Entity (Ent))) 14487 or else not Is_Floating_Point_Type (Etype (Ent)) 14488 or else Etype (Ent) /= Etype (Next_Entity (Ent)) 14489 then 14490 Error_Pragma_Arg 14491 ("record for pragma% must have two fields of the same " 14492 & "floating-point type", Arg1); 14493 14494 else 14495 Set_Has_Complex_Representation (Base_Type (E)); 14496 14497 -- We need to treat the type has having a non-standard 14498 -- representation, for back-end purposes, even though in 14499 -- general a complex will have the default representation 14500 -- of a record with two real components. 14501 14502 Set_Has_Non_Standard_Rep (Base_Type (E)); 14503 end if; 14504 end Complex_Representation; 14505 14506 ------------------------- 14507 -- Component_Alignment -- 14508 ------------------------- 14509 14510 -- pragma Component_Alignment ( 14511 -- [Form =>] ALIGNMENT_CHOICE 14512 -- [, [Name =>] type_LOCAL_NAME]); 14513 -- 14514 -- ALIGNMENT_CHOICE ::= 14515 -- Component_Size 14516 -- | Component_Size_4 14517 -- | Storage_Unit 14518 -- | Default 14519 14520 when Pragma_Component_Alignment => Component_AlignmentP : declare 14521 Args : Args_List (1 .. 2); 14522 Names : constant Name_List (1 .. 2) := ( 14523 Name_Form, 14524 Name_Name); 14525 14526 Form : Node_Id renames Args (1); 14527 Name : Node_Id renames Args (2); 14528 14529 Atype : Component_Alignment_Kind; 14530 Typ : Entity_Id; 14531 14532 begin 14533 GNAT_Pragma; 14534 Gather_Associations (Names, Args); 14535 14536 if No (Form) then 14537 Error_Pragma ("missing Form argument for pragma%"); 14538 end if; 14539 14540 Check_Arg_Is_Identifier (Form); 14541 14542 -- Get proper alignment, note that Default = Component_Size on all 14543 -- machines we have so far, and we want to set this value rather 14544 -- than the default value to indicate that it has been explicitly 14545 -- set (and thus will not get overridden by the default component 14546 -- alignment for the current scope) 14547 14548 if Chars (Form) = Name_Component_Size then 14549 Atype := Calign_Component_Size; 14550 14551 elsif Chars (Form) = Name_Component_Size_4 then 14552 Atype := Calign_Component_Size_4; 14553 14554 elsif Chars (Form) = Name_Default then 14555 Atype := Calign_Component_Size; 14556 14557 elsif Chars (Form) = Name_Storage_Unit then 14558 Atype := Calign_Storage_Unit; 14559 14560 else 14561 Error_Pragma_Arg 14562 ("invalid Form parameter for pragma%", Form); 14563 end if; 14564 14565 -- The pragma appears in a configuration file 14566 14567 if No (Parent (N)) then 14568 Check_Valid_Configuration_Pragma; 14569 14570 -- Capture the component alignment in a global variable when 14571 -- the pragma appears in a configuration file. Note that the 14572 -- scope stack is empty at this point and cannot be used to 14573 -- store the alignment value. 14574 14575 Configuration_Component_Alignment := Atype; 14576 14577 -- Case with no name, supplied, affects scope table entry 14578 14579 elsif No (Name) then 14580 Scope_Stack.Table 14581 (Scope_Stack.Last).Component_Alignment_Default := Atype; 14582 14583 -- Case of name supplied 14584 14585 else 14586 Check_Arg_Is_Local_Name (Name); 14587 Find_Type (Name); 14588 Typ := Entity (Name); 14589 14590 if Typ = Any_Type 14591 or else Rep_Item_Too_Early (Typ, N) 14592 then 14593 return; 14594 else 14595 Typ := Underlying_Type (Typ); 14596 end if; 14597 14598 if not Is_Record_Type (Typ) 14599 and then not Is_Array_Type (Typ) 14600 then 14601 Error_Pragma_Arg 14602 ("Name parameter of pragma% must identify record or " 14603 & "array type", Name); 14604 end if; 14605 14606 -- An explicit Component_Alignment pragma overrides an 14607 -- implicit pragma Pack, but not an explicit one. 14608 14609 if not Has_Pragma_Pack (Base_Type (Typ)) then 14610 Set_Is_Packed (Base_Type (Typ), False); 14611 Set_Component_Alignment (Base_Type (Typ), Atype); 14612 end if; 14613 end if; 14614 end Component_AlignmentP; 14615 14616 -------------------------------- 14617 -- Constant_After_Elaboration -- 14618 -------------------------------- 14619 14620 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ]; 14621 14622 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration : 14623 declare 14624 Obj_Decl : Node_Id; 14625 Obj_Id : Entity_Id; 14626 14627 begin 14628 GNAT_Pragma; 14629 Check_No_Identifiers; 14630 Check_At_Most_N_Arguments (1); 14631 14632 Obj_Decl := Find_Related_Context (N, Do_Checks => True); 14633 14634 if Nkind (Obj_Decl) /= N_Object_Declaration then 14635 Pragma_Misplaced; 14636 return; 14637 end if; 14638 14639 Obj_Id := Defining_Entity (Obj_Decl); 14640 14641 -- The object declaration must be a library-level variable which 14642 -- is either explicitly initialized or obtains a value during the 14643 -- elaboration of a package body (SPARK RM 3.3.1). 14644 14645 if Ekind (Obj_Id) = E_Variable then 14646 if not Is_Library_Level_Entity (Obj_Id) then 14647 Error_Pragma 14648 ("pragma % must apply to a library level variable"); 14649 return; 14650 end if; 14651 14652 -- Otherwise the pragma applies to a constant, which is illegal 14653 14654 else 14655 Error_Pragma ("pragma % must apply to a variable declaration"); 14656 return; 14657 end if; 14658 14659 -- A pragma that applies to a Ghost entity becomes Ghost for the 14660 -- purposes of legality checks and removal of ignored Ghost code. 14661 14662 Mark_Ghost_Pragma (N, Obj_Id); 14663 14664 -- Chain the pragma on the contract for completeness 14665 14666 Add_Contract_Item (N, Obj_Id); 14667 14668 -- Analyze the Boolean expression (if any) 14669 14670 if Present (Arg1) then 14671 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 14672 end if; 14673 end Constant_After_Elaboration; 14674 14675 -------------------- 14676 -- Contract_Cases -- 14677 -------------------- 14678 14679 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE)); 14680 14681 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE 14682 14683 -- CASE_GUARD ::= boolean_EXPRESSION | others 14684 14685 -- CONSEQUENCE ::= boolean_EXPRESSION 14686 14687 -- Characteristics: 14688 14689 -- * Analysis - The annotation undergoes initial checks to verify 14690 -- the legal placement and context. Secondary checks preanalyze the 14691 -- expressions in: 14692 14693 -- Analyze_Contract_Cases_In_Decl_Part 14694 14695 -- * Expansion - The annotation is expanded during the expansion of 14696 -- the related subprogram [body] contract as performed in: 14697 14698 -- Expand_Subprogram_Contract 14699 14700 -- * Template - The annotation utilizes the generic template of the 14701 -- related subprogram [body] when it is: 14702 14703 -- aspect on subprogram declaration 14704 -- aspect on stand-alone subprogram body 14705 -- pragma on stand-alone subprogram body 14706 14707 -- The annotation must prepare its own template when it is: 14708 14709 -- pragma on subprogram declaration 14710 14711 -- * Globals - Capture of global references must occur after full 14712 -- analysis. 14713 14714 -- * Instance - The annotation is instantiated automatically when 14715 -- the related generic subprogram [body] is instantiated except for 14716 -- the "pragma on subprogram declaration" case. In that scenario 14717 -- the annotation must instantiate itself. 14718 14719 when Pragma_Contract_Cases => Contract_Cases : declare 14720 Spec_Id : Entity_Id; 14721 Subp_Decl : Node_Id; 14722 Subp_Spec : Node_Id; 14723 14724 begin 14725 GNAT_Pragma; 14726 Check_No_Identifiers; 14727 Check_Arg_Count (1); 14728 14729 -- Ensure the proper placement of the pragma. Contract_Cases must 14730 -- be associated with a subprogram declaration or a body that acts 14731 -- as a spec. 14732 14733 Subp_Decl := 14734 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 14735 14736 -- Entry 14737 14738 if Nkind (Subp_Decl) = N_Entry_Declaration then 14739 null; 14740 14741 -- Generic subprogram 14742 14743 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 14744 null; 14745 14746 -- Body acts as spec 14747 14748 elsif Nkind (Subp_Decl) = N_Subprogram_Body 14749 and then No (Corresponding_Spec (Subp_Decl)) 14750 then 14751 null; 14752 14753 -- Body stub acts as spec 14754 14755 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 14756 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 14757 then 14758 null; 14759 14760 -- Subprogram 14761 14762 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 14763 Subp_Spec := Specification (Subp_Decl); 14764 14765 -- Pragma Contract_Cases is forbidden on null procedures, as 14766 -- this may lead to potential ambiguities in behavior when 14767 -- interface null procedures are involved. 14768 14769 if Nkind (Subp_Spec) = N_Procedure_Specification 14770 and then Null_Present (Subp_Spec) 14771 then 14772 Error_Msg_N (Fix_Error 14773 ("pragma % cannot apply to null procedure"), N); 14774 return; 14775 end if; 14776 14777 else 14778 Pragma_Misplaced; 14779 return; 14780 end if; 14781 14782 Spec_Id := Unique_Defining_Entity (Subp_Decl); 14783 14784 -- A pragma that applies to a Ghost entity becomes Ghost for the 14785 -- purposes of legality checks and removal of ignored Ghost code. 14786 14787 Mark_Ghost_Pragma (N, Spec_Id); 14788 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 14789 14790 -- Chain the pragma on the contract for further processing by 14791 -- Analyze_Contract_Cases_In_Decl_Part. 14792 14793 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 14794 14795 -- Fully analyze the pragma when it appears inside an entry 14796 -- or subprogram body because it cannot benefit from forward 14797 -- references. 14798 14799 if Nkind_In (Subp_Decl, N_Entry_Body, 14800 N_Subprogram_Body, 14801 N_Subprogram_Body_Stub) 14802 then 14803 -- The legality checks of pragma Contract_Cases are affected by 14804 -- the SPARK mode in effect and the volatility of the context. 14805 -- Analyze all pragmas in a specific order. 14806 14807 Analyze_If_Present (Pragma_SPARK_Mode); 14808 Analyze_If_Present (Pragma_Volatile_Function); 14809 Analyze_Contract_Cases_In_Decl_Part (N); 14810 end if; 14811 end Contract_Cases; 14812 14813 ---------------- 14814 -- Controlled -- 14815 ---------------- 14816 14817 -- pragma Controlled (first_subtype_LOCAL_NAME); 14818 14819 when Pragma_Controlled => Controlled : declare 14820 Arg : Node_Id; 14821 14822 begin 14823 Check_No_Identifiers; 14824 Check_Arg_Count (1); 14825 Check_Arg_Is_Local_Name (Arg1); 14826 Arg := Get_Pragma_Arg (Arg1); 14827 14828 if not Is_Entity_Name (Arg) 14829 or else not Is_Access_Type (Entity (Arg)) 14830 then 14831 Error_Pragma_Arg ("pragma% requires access type", Arg1); 14832 else 14833 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); 14834 end if; 14835 end Controlled; 14836 14837 ---------------- 14838 -- Convention -- 14839 ---------------- 14840 14841 -- pragma Convention ([Convention =>] convention_IDENTIFIER, 14842 -- [Entity =>] LOCAL_NAME); 14843 14844 when Pragma_Convention => Convention : declare 14845 C : Convention_Id; 14846 E : Entity_Id; 14847 pragma Warnings (Off, C); 14848 pragma Warnings (Off, E); 14849 14850 begin 14851 Check_Arg_Order ((Name_Convention, Name_Entity)); 14852 Check_Ada_83_Warning; 14853 Check_Arg_Count (2); 14854 Process_Convention (C, E); 14855 14856 -- A pragma that applies to a Ghost entity becomes Ghost for the 14857 -- purposes of legality checks and removal of ignored Ghost code. 14858 14859 Mark_Ghost_Pragma (N, E); 14860 end Convention; 14861 14862 --------------------------- 14863 -- Convention_Identifier -- 14864 --------------------------- 14865 14866 -- pragma Convention_Identifier ([Name =>] IDENTIFIER, 14867 -- [Convention =>] convention_IDENTIFIER); 14868 14869 when Pragma_Convention_Identifier => Convention_Identifier : declare 14870 Idnam : Name_Id; 14871 Cname : Name_Id; 14872 14873 begin 14874 GNAT_Pragma; 14875 Check_Arg_Order ((Name_Name, Name_Convention)); 14876 Check_Arg_Count (2); 14877 Check_Optional_Identifier (Arg1, Name_Name); 14878 Check_Optional_Identifier (Arg2, Name_Convention); 14879 Check_Arg_Is_Identifier (Arg1); 14880 Check_Arg_Is_Identifier (Arg2); 14881 Idnam := Chars (Get_Pragma_Arg (Arg1)); 14882 Cname := Chars (Get_Pragma_Arg (Arg2)); 14883 14884 if Is_Convention_Name (Cname) then 14885 Record_Convention_Identifier 14886 (Idnam, Get_Convention_Id (Cname)); 14887 else 14888 Error_Pragma_Arg 14889 ("second arg for % pragma must be convention", Arg2); 14890 end if; 14891 end Convention_Identifier; 14892 14893 --------------- 14894 -- CPP_Class -- 14895 --------------- 14896 14897 -- pragma CPP_Class ([Entity =>] LOCAL_NAME) 14898 14899 when Pragma_CPP_Class => 14900 GNAT_Pragma; 14901 14902 if Warn_On_Obsolescent_Feature then 14903 Error_Msg_N 14904 ("'G'N'A'T pragma cpp'_class is now obsolete and has no " 14905 & "effect; replace it by pragma import?j?", N); 14906 end if; 14907 14908 Check_Arg_Count (1); 14909 14910 Rewrite (N, 14911 Make_Pragma (Loc, 14912 Chars => Name_Import, 14913 Pragma_Argument_Associations => New_List ( 14914 Make_Pragma_Argument_Association (Loc, 14915 Expression => Make_Identifier (Loc, Name_CPP)), 14916 New_Copy (First (Pragma_Argument_Associations (N)))))); 14917 Analyze (N); 14918 14919 --------------------- 14920 -- CPP_Constructor -- 14921 --------------------- 14922 14923 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME 14924 -- [, [External_Name =>] static_string_EXPRESSION ] 14925 -- [, [Link_Name =>] static_string_EXPRESSION ]); 14926 14927 when Pragma_CPP_Constructor => CPP_Constructor : declare 14928 Elmt : Elmt_Id; 14929 Id : Entity_Id; 14930 Def_Id : Entity_Id; 14931 Tag_Typ : Entity_Id; 14932 14933 begin 14934 GNAT_Pragma; 14935 Check_At_Least_N_Arguments (1); 14936 Check_At_Most_N_Arguments (3); 14937 Check_Optional_Identifier (Arg1, Name_Entity); 14938 Check_Arg_Is_Local_Name (Arg1); 14939 14940 Id := Get_Pragma_Arg (Arg1); 14941 Find_Program_Unit_Name (Id); 14942 14943 -- If we did not find the name, we are done 14944 14945 if Etype (Id) = Any_Type then 14946 return; 14947 end if; 14948 14949 Def_Id := Entity (Id); 14950 14951 -- Check if already defined as constructor 14952 14953 if Is_Constructor (Def_Id) then 14954 Error_Msg_N 14955 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1); 14956 return; 14957 end if; 14958 14959 if Ekind (Def_Id) = E_Function 14960 and then (Is_CPP_Class (Etype (Def_Id)) 14961 or else (Is_Class_Wide_Type (Etype (Def_Id)) 14962 and then 14963 Is_CPP_Class (Root_Type (Etype (Def_Id))))) 14964 then 14965 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then 14966 Error_Msg_N 14967 ("'C'P'P constructor must be defined in the scope of " 14968 & "its returned type", Arg1); 14969 end if; 14970 14971 if Arg_Count >= 2 then 14972 Set_Imported (Def_Id); 14973 Set_Is_Public (Def_Id); 14974 Process_Interface_Name (Def_Id, Arg2, Arg3, N); 14975 end if; 14976 14977 Set_Has_Completion (Def_Id); 14978 Set_Is_Constructor (Def_Id); 14979 Set_Convention (Def_Id, Convention_CPP); 14980 14981 -- Imported C++ constructors are not dispatching primitives 14982 -- because in C++ they don't have a dispatch table slot. 14983 -- However, in Ada the constructor has the profile of a 14984 -- function that returns a tagged type and therefore it has 14985 -- been treated as a primitive operation during semantic 14986 -- analysis. We now remove it from the list of primitive 14987 -- operations of the type. 14988 14989 if Is_Tagged_Type (Etype (Def_Id)) 14990 and then not Is_Class_Wide_Type (Etype (Def_Id)) 14991 and then Is_Dispatching_Operation (Def_Id) 14992 then 14993 Tag_Typ := Etype (Def_Id); 14994 14995 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 14996 while Present (Elmt) and then Node (Elmt) /= Def_Id loop 14997 Next_Elmt (Elmt); 14998 end loop; 14999 15000 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); 15001 Set_Is_Dispatching_Operation (Def_Id, False); 15002 end if; 15003 15004 -- For backward compatibility, if the constructor returns a 15005 -- class wide type, and we internally change the return type to 15006 -- the corresponding root type. 15007 15008 if Is_Class_Wide_Type (Etype (Def_Id)) then 15009 Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); 15010 end if; 15011 else 15012 Error_Pragma_Arg 15013 ("pragma% requires function returning a 'C'P'P_Class type", 15014 Arg1); 15015 end if; 15016 end CPP_Constructor; 15017 15018 ----------------- 15019 -- CPP_Virtual -- 15020 ----------------- 15021 15022 when Pragma_CPP_Virtual => 15023 GNAT_Pragma; 15024 15025 if Warn_On_Obsolescent_Feature then 15026 Error_Msg_N 15027 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no " 15028 & "effect?j?", N); 15029 end if; 15030 15031 ---------------- 15032 -- CPP_Vtable -- 15033 ---------------- 15034 15035 when Pragma_CPP_Vtable => 15036 GNAT_Pragma; 15037 15038 if Warn_On_Obsolescent_Feature then 15039 Error_Msg_N 15040 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no " 15041 & "effect?j?", N); 15042 end if; 15043 15044 --------- 15045 -- CPU -- 15046 --------- 15047 15048 -- pragma CPU (EXPRESSION); 15049 15050 when Pragma_CPU => CPU : declare 15051 P : constant Node_Id := Parent (N); 15052 Arg : Node_Id; 15053 Ent : Entity_Id; 15054 15055 begin 15056 Ada_2012_Pragma; 15057 Check_No_Identifiers; 15058 Check_Arg_Count (1); 15059 15060 -- Subprogram case 15061 15062 if Nkind (P) = N_Subprogram_Body then 15063 Check_In_Main_Program; 15064 15065 Arg := Get_Pragma_Arg (Arg1); 15066 Analyze_And_Resolve (Arg, Any_Integer); 15067 15068 Ent := Defining_Unit_Name (Specification (P)); 15069 15070 if Nkind (Ent) = N_Defining_Program_Unit_Name then 15071 Ent := Defining_Identifier (Ent); 15072 end if; 15073 15074 -- Must be static 15075 15076 if not Is_OK_Static_Expression (Arg) then 15077 Flag_Non_Static_Expr 15078 ("main subprogram affinity is not static!", Arg); 15079 raise Pragma_Exit; 15080 15081 -- If constraint error, then we already signalled an error 15082 15083 elsif Raises_Constraint_Error (Arg) then 15084 null; 15085 15086 -- Otherwise check in range 15087 15088 else 15089 declare 15090 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); 15091 -- This is the entity System.Multiprocessors.CPU_Range; 15092 15093 Val : constant Uint := Expr_Value (Arg); 15094 15095 begin 15096 if Val < Expr_Value (Type_Low_Bound (CPU_Id)) 15097 or else 15098 Val > Expr_Value (Type_High_Bound (CPU_Id)) 15099 then 15100 Error_Pragma_Arg 15101 ("main subprogram CPU is out of range", Arg1); 15102 end if; 15103 end; 15104 end if; 15105 15106 Set_Main_CPU 15107 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 15108 15109 -- Task case 15110 15111 elsif Nkind (P) = N_Task_Definition then 15112 Arg := Get_Pragma_Arg (Arg1); 15113 Ent := Defining_Identifier (Parent (P)); 15114 15115 -- The expression must be analyzed in the special manner 15116 -- described in "Handling of Default and Per-Object 15117 -- Expressions" in sem.ads. 15118 15119 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); 15120 15121 -- Anything else is incorrect 15122 15123 else 15124 Pragma_Misplaced; 15125 end if; 15126 15127 -- Check duplicate pragma before we chain the pragma in the Rep 15128 -- Item chain of Ent. 15129 15130 Check_Duplicate_Pragma (Ent); 15131 Record_Rep_Item (Ent, N); 15132 end CPU; 15133 15134 -------------------- 15135 -- Deadline_Floor -- 15136 -------------------- 15137 15138 -- pragma Deadline_Floor (time_span_EXPRESSION); 15139 15140 when Pragma_Deadline_Floor => Deadline_Floor : declare 15141 P : constant Node_Id := Parent (N); 15142 Arg : Node_Id; 15143 Ent : Entity_Id; 15144 15145 begin 15146 GNAT_Pragma; 15147 Check_No_Identifiers; 15148 Check_Arg_Count (1); 15149 15150 Arg := Get_Pragma_Arg (Arg1); 15151 15152 -- The expression must be analyzed in the special manner described 15153 -- in "Handling of Default and Per-Object Expressions" in sem.ads. 15154 15155 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); 15156 15157 -- Only protected types allowed 15158 15159 if Nkind (P) /= N_Protected_Definition then 15160 Pragma_Misplaced; 15161 15162 else 15163 Ent := Defining_Identifier (Parent (P)); 15164 15165 -- Check duplicate pragma before we chain the pragma in the Rep 15166 -- Item chain of Ent. 15167 15168 Check_Duplicate_Pragma (Ent); 15169 Record_Rep_Item (Ent, N); 15170 end if; 15171 end Deadline_Floor; 15172 15173 ----------- 15174 -- Debug -- 15175 ----------- 15176 15177 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); 15178 15179 when Pragma_Debug => Debug : declare 15180 Cond : Node_Id; 15181 Call : Node_Id; 15182 15183 begin 15184 GNAT_Pragma; 15185 15186 -- The condition for executing the call is that the expander 15187 -- is active and that we are not ignoring this debug pragma. 15188 15189 Cond := 15190 New_Occurrence_Of 15191 (Boolean_Literals 15192 (Expander_Active and then not Is_Ignored (N)), 15193 Loc); 15194 15195 if not Is_Ignored (N) then 15196 Set_SCO_Pragma_Enabled (Loc); 15197 end if; 15198 15199 if Arg_Count = 2 then 15200 Cond := 15201 Make_And_Then (Loc, 15202 Left_Opnd => Relocate_Node (Cond), 15203 Right_Opnd => Get_Pragma_Arg (Arg1)); 15204 Call := Get_Pragma_Arg (Arg2); 15205 else 15206 Call := Get_Pragma_Arg (Arg1); 15207 end if; 15208 15209 if Nkind_In (Call, N_Expanded_Name, 15210 N_Function_Call, 15211 N_Identifier, 15212 N_Indexed_Component, 15213 N_Selected_Component) 15214 then 15215 -- If this pragma Debug comes from source, its argument was 15216 -- parsed as a name form (which is syntactically identical). 15217 -- In a generic context a parameterless call will be left as 15218 -- an expanded name (if global) or selected_component if local. 15219 -- Change it to a procedure call statement now. 15220 15221 Change_Name_To_Procedure_Call_Statement (Call); 15222 15223 elsif Nkind (Call) = N_Procedure_Call_Statement then 15224 15225 -- Already in the form of a procedure call statement: nothing 15226 -- to do (could happen in case of an internally generated 15227 -- pragma Debug). 15228 15229 null; 15230 15231 else 15232 -- All other cases: diagnose error 15233 15234 Error_Msg 15235 ("argument of pragma ""Debug"" is not procedure call", 15236 Sloc (Call)); 15237 return; 15238 end if; 15239 15240 -- Rewrite into a conditional with an appropriate condition. We 15241 -- wrap the procedure call in a block so that overhead from e.g. 15242 -- use of the secondary stack does not generate execution overhead 15243 -- for suppressed conditions. 15244 15245 -- Normally the analysis that follows will freeze the subprogram 15246 -- being called. However, if the call is to a null procedure, 15247 -- we want to freeze it before creating the block, because the 15248 -- analysis that follows may be done with expansion disabled, in 15249 -- which case the body will not be generated, leading to spurious 15250 -- errors. 15251 15252 if Nkind (Call) = N_Procedure_Call_Statement 15253 and then Is_Entity_Name (Name (Call)) 15254 then 15255 Analyze (Name (Call)); 15256 Freeze_Before (N, Entity (Name (Call))); 15257 end if; 15258 15259 Rewrite (N, 15260 Make_Implicit_If_Statement (N, 15261 Condition => Cond, 15262 Then_Statements => New_List ( 15263 Make_Block_Statement (Loc, 15264 Handled_Statement_Sequence => 15265 Make_Handled_Sequence_Of_Statements (Loc, 15266 Statements => New_List (Relocate_Node (Call))))))); 15267 Analyze (N); 15268 15269 -- Ignore pragma Debug in GNATprove mode. Do this rewriting 15270 -- after analysis of the normally rewritten node, to capture all 15271 -- references to entities, which avoids issuing wrong warnings 15272 -- about unused entities. 15273 15274 if GNATprove_Mode then 15275 Rewrite (N, Make_Null_Statement (Loc)); 15276 end if; 15277 end Debug; 15278 15279 ------------------ 15280 -- Debug_Policy -- 15281 ------------------ 15282 15283 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore) 15284 15285 when Pragma_Debug_Policy => 15286 GNAT_Pragma; 15287 Check_Arg_Count (1); 15288 Check_No_Identifiers; 15289 Check_Arg_Is_Identifier (Arg1); 15290 15291 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so 15292 -- rewrite it that way, and let the rest of the checking come 15293 -- from analyzing the rewritten pragma. 15294 15295 Rewrite (N, 15296 Make_Pragma (Loc, 15297 Chars => Name_Check_Policy, 15298 Pragma_Argument_Associations => New_List ( 15299 Make_Pragma_Argument_Association (Loc, 15300 Expression => Make_Identifier (Loc, Name_Debug)), 15301 15302 Make_Pragma_Argument_Association (Loc, 15303 Expression => Get_Pragma_Arg (Arg1))))); 15304 Analyze (N); 15305 15306 ------------------------------- 15307 -- Default_Initial_Condition -- 15308 ------------------------------- 15309 15310 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ]; 15311 15312 when Pragma_Default_Initial_Condition => DIC : declare 15313 Discard : Boolean; 15314 Stmt : Node_Id; 15315 Typ : Entity_Id; 15316 15317 begin 15318 GNAT_Pragma; 15319 Check_No_Identifiers; 15320 Check_At_Most_N_Arguments (1); 15321 15322 Typ := Empty; 15323 Stmt := Prev (N); 15324 while Present (Stmt) loop 15325 15326 -- Skip prior pragmas, but check for duplicates 15327 15328 if Nkind (Stmt) = N_Pragma then 15329 if Pragma_Name (Stmt) = Pname then 15330 Duplication_Error 15331 (Prag => N, 15332 Prev => Stmt); 15333 raise Pragma_Exit; 15334 end if; 15335 15336 -- Skip internally generated code. Note that derived type 15337 -- declarations of untagged types with discriminants are 15338 -- rewritten as private type declarations. 15339 15340 elsif not Comes_From_Source (Stmt) 15341 and then Nkind (Stmt) /= N_Private_Type_Declaration 15342 then 15343 null; 15344 15345 -- The associated private type [extension] has been found, stop 15346 -- the search. 15347 15348 elsif Nkind_In (Stmt, N_Private_Extension_Declaration, 15349 N_Private_Type_Declaration) 15350 then 15351 Typ := Defining_Entity (Stmt); 15352 exit; 15353 15354 -- The pragma does not apply to a legal construct, issue an 15355 -- error and stop the analysis. 15356 15357 else 15358 Pragma_Misplaced; 15359 return; 15360 end if; 15361 15362 Stmt := Prev (Stmt); 15363 end loop; 15364 15365 -- The pragma does not apply to a legal construct, issue an error 15366 -- and stop the analysis. 15367 15368 if No (Typ) then 15369 Pragma_Misplaced; 15370 return; 15371 end if; 15372 15373 -- A pragma that applies to a Ghost entity becomes Ghost for the 15374 -- purposes of legality checks and removal of ignored Ghost code. 15375 15376 Mark_Ghost_Pragma (N, Typ); 15377 15378 -- The pragma signals that the type defines its own DIC assertion 15379 -- expression. 15380 15381 Set_Has_Own_DIC (Typ); 15382 15383 -- Chain the pragma on the rep item chain for further processing 15384 15385 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 15386 15387 -- Create the declaration of the procedure which verifies the 15388 -- assertion expression of pragma DIC at runtime. 15389 15390 Build_DIC_Procedure_Declaration (Typ); 15391 end DIC; 15392 15393 ---------------------------------- 15394 -- Default_Scalar_Storage_Order -- 15395 ---------------------------------- 15396 15397 -- pragma Default_Scalar_Storage_Order 15398 -- (High_Order_First | Low_Order_First); 15399 15400 when Pragma_Default_Scalar_Storage_Order => DSSO : declare 15401 Default : Character; 15402 15403 begin 15404 GNAT_Pragma; 15405 Check_Arg_Count (1); 15406 15407 -- Default_Scalar_Storage_Order can appear as a configuration 15408 -- pragma, or in a declarative part of a package spec. 15409 15410 if not Is_Configuration_Pragma then 15411 Check_Is_In_Decl_Part_Or_Package_Spec; 15412 end if; 15413 15414 Check_No_Identifiers; 15415 Check_Arg_Is_One_Of 15416 (Arg1, Name_High_Order_First, Name_Low_Order_First); 15417 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 15418 Default := Fold_Upper (Name_Buffer (1)); 15419 15420 if not Support_Nondefault_SSO_On_Target 15421 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H')) 15422 then 15423 if Warn_On_Unrecognized_Pragma then 15424 Error_Msg_N 15425 ("non-default Scalar_Storage_Order not supported " 15426 & "on target?g?", N); 15427 Error_Msg_N 15428 ("\pragma Default_Scalar_Storage_Order ignored?g?", N); 15429 end if; 15430 15431 -- Here set the specified default 15432 15433 else 15434 Opt.Default_SSO := Default; 15435 end if; 15436 end DSSO; 15437 15438 -------------------------- 15439 -- Default_Storage_Pool -- 15440 -------------------------- 15441 15442 -- pragma Default_Storage_Pool (storage_pool_NAME | null); 15443 15444 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare 15445 Pool : Node_Id; 15446 15447 begin 15448 Ada_2012_Pragma; 15449 Check_Arg_Count (1); 15450 15451 -- Default_Storage_Pool can appear as a configuration pragma, or 15452 -- in a declarative part of a package spec. 15453 15454 if not Is_Configuration_Pragma then 15455 Check_Is_In_Decl_Part_Or_Package_Spec; 15456 end if; 15457 15458 if From_Aspect_Specification (N) then 15459 declare 15460 E : constant Entity_Id := Entity (Corresponding_Aspect (N)); 15461 begin 15462 if not In_Open_Scopes (E) then 15463 Error_Msg_N 15464 ("aspect must apply to package or subprogram", N); 15465 end if; 15466 end; 15467 end if; 15468 15469 if Present (Arg1) then 15470 Pool := Get_Pragma_Arg (Arg1); 15471 15472 -- Case of Default_Storage_Pool (null); 15473 15474 if Nkind (Pool) = N_Null then 15475 Analyze (Pool); 15476 15477 -- This is an odd case, this is not really an expression, 15478 -- so we don't have a type for it. So just set the type to 15479 -- Empty. 15480 15481 Set_Etype (Pool, Empty); 15482 15483 -- Case of Default_Storage_Pool (storage_pool_NAME); 15484 15485 else 15486 -- If it's a configuration pragma, then the only allowed 15487 -- argument is "null". 15488 15489 if Is_Configuration_Pragma then 15490 Error_Pragma_Arg ("NULL expected", Arg1); 15491 end if; 15492 15493 -- The expected type for a non-"null" argument is 15494 -- Root_Storage_Pool'Class, and the pool must be a variable. 15495 15496 Analyze_And_Resolve 15497 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 15498 15499 if Is_Variable (Pool) then 15500 15501 -- A pragma that applies to a Ghost entity becomes Ghost 15502 -- for the purposes of legality checks and removal of 15503 -- ignored Ghost code. 15504 15505 Mark_Ghost_Pragma (N, Entity (Pool)); 15506 15507 else 15508 Error_Pragma_Arg 15509 ("default storage pool must be a variable", Arg1); 15510 end if; 15511 end if; 15512 15513 -- Record the pool name (or null). Freeze.Freeze_Entity for an 15514 -- access type will use this information to set the appropriate 15515 -- attributes of the access type. If the pragma appears in a 15516 -- generic unit it is ignored, given that it may refer to a 15517 -- local entity. 15518 15519 if not Inside_A_Generic then 15520 Default_Pool := Pool; 15521 end if; 15522 end if; 15523 end Default_Storage_Pool; 15524 15525 ------------- 15526 -- Depends -- 15527 ------------- 15528 15529 -- pragma Depends (DEPENDENCY_RELATION); 15530 15531 -- DEPENDENCY_RELATION ::= 15532 -- null 15533 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}) 15534 15535 -- DEPENDENCY_CLAUSE ::= 15536 -- OUTPUT_LIST =>[+] INPUT_LIST 15537 -- | NULL_DEPENDENCY_CLAUSE 15538 15539 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 15540 15541 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 15542 15543 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 15544 15545 -- OUTPUT ::= NAME | FUNCTION_RESULT 15546 -- INPUT ::= NAME 15547 15548 -- where FUNCTION_RESULT is a function Result attribute_reference 15549 15550 -- Characteristics: 15551 15552 -- * Analysis - The annotation undergoes initial checks to verify 15553 -- the legal placement and context. Secondary checks fully analyze 15554 -- the dependency clauses in: 15555 15556 -- Analyze_Depends_In_Decl_Part 15557 15558 -- * Expansion - None. 15559 15560 -- * Template - The annotation utilizes the generic template of the 15561 -- related subprogram [body] when it is: 15562 15563 -- aspect on subprogram declaration 15564 -- aspect on stand-alone subprogram body 15565 -- pragma on stand-alone subprogram body 15566 15567 -- The annotation must prepare its own template when it is: 15568 15569 -- pragma on subprogram declaration 15570 15571 -- * Globals - Capture of global references must occur after full 15572 -- analysis. 15573 15574 -- * Instance - The annotation is instantiated automatically when 15575 -- the related generic subprogram [body] is instantiated except for 15576 -- the "pragma on subprogram declaration" case. In that scenario 15577 -- the annotation must instantiate itself. 15578 15579 when Pragma_Depends => Depends : declare 15580 Legal : Boolean; 15581 Spec_Id : Entity_Id; 15582 Subp_Decl : Node_Id; 15583 15584 begin 15585 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); 15586 15587 if Legal then 15588 15589 -- Chain the pragma on the contract for further processing by 15590 -- Analyze_Depends_In_Decl_Part. 15591 15592 Add_Contract_Item (N, Spec_Id); 15593 15594 -- Fully analyze the pragma when it appears inside an entry 15595 -- or subprogram body because it cannot benefit from forward 15596 -- references. 15597 15598 if Nkind_In (Subp_Decl, N_Entry_Body, 15599 N_Subprogram_Body, 15600 N_Subprogram_Body_Stub) 15601 then 15602 -- The legality checks of pragmas Depends and Global are 15603 -- affected by the SPARK mode in effect and the volatility 15604 -- of the context. In addition these two pragmas are subject 15605 -- to an inherent order: 15606 15607 -- 1) Global 15608 -- 2) Depends 15609 15610 -- Analyze all these pragmas in the order outlined above 15611 15612 Analyze_If_Present (Pragma_SPARK_Mode); 15613 Analyze_If_Present (Pragma_Volatile_Function); 15614 Analyze_If_Present (Pragma_Global); 15615 Analyze_Depends_In_Decl_Part (N); 15616 end if; 15617 end if; 15618 end Depends; 15619 15620 --------------------- 15621 -- Detect_Blocking -- 15622 --------------------- 15623 15624 -- pragma Detect_Blocking; 15625 15626 when Pragma_Detect_Blocking => 15627 Ada_2005_Pragma; 15628 Check_Arg_Count (0); 15629 Check_Valid_Configuration_Pragma; 15630 Detect_Blocking := True; 15631 15632 ------------------------------------ 15633 -- Disable_Atomic_Synchronization -- 15634 ------------------------------------ 15635 15636 -- pragma Disable_Atomic_Synchronization [(Entity)]; 15637 15638 when Pragma_Disable_Atomic_Synchronization => 15639 GNAT_Pragma; 15640 Process_Disable_Enable_Atomic_Sync (Name_Suppress); 15641 15642 ------------------- 15643 -- Discard_Names -- 15644 ------------------- 15645 15646 -- pragma Discard_Names [([On =>] LOCAL_NAME)]; 15647 15648 when Pragma_Discard_Names => Discard_Names : declare 15649 E : Entity_Id; 15650 E_Id : Node_Id; 15651 15652 begin 15653 Check_Ada_83_Warning; 15654 15655 -- Deal with configuration pragma case 15656 15657 if Arg_Count = 0 and then Is_Configuration_Pragma then 15658 Global_Discard_Names := True; 15659 return; 15660 15661 -- Otherwise, check correct appropriate context 15662 15663 else 15664 Check_Is_In_Decl_Part_Or_Package_Spec; 15665 15666 if Arg_Count = 0 then 15667 15668 -- If there is no parameter, then from now on this pragma 15669 -- applies to any enumeration, exception or tagged type 15670 -- defined in the current declarative part, and recursively 15671 -- to any nested scope. 15672 15673 Set_Discard_Names (Current_Scope); 15674 return; 15675 15676 else 15677 Check_Arg_Count (1); 15678 Check_Optional_Identifier (Arg1, Name_On); 15679 Check_Arg_Is_Local_Name (Arg1); 15680 15681 E_Id := Get_Pragma_Arg (Arg1); 15682 15683 if Etype (E_Id) = Any_Type then 15684 return; 15685 end if; 15686 15687 E := Entity (E_Id); 15688 15689 -- A pragma that applies to a Ghost entity becomes Ghost for 15690 -- the purposes of legality checks and removal of ignored 15691 -- Ghost code. 15692 15693 Mark_Ghost_Pragma (N, E); 15694 15695 if (Is_First_Subtype (E) 15696 and then 15697 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) 15698 or else Ekind (E) = E_Exception 15699 then 15700 Set_Discard_Names (E); 15701 Record_Rep_Item (E, N); 15702 15703 else 15704 Error_Pragma_Arg 15705 ("inappropriate entity for pragma%", Arg1); 15706 end if; 15707 end if; 15708 end if; 15709 end Discard_Names; 15710 15711 ------------------------ 15712 -- Dispatching_Domain -- 15713 ------------------------ 15714 15715 -- pragma Dispatching_Domain (EXPRESSION); 15716 15717 when Pragma_Dispatching_Domain => Dispatching_Domain : declare 15718 P : constant Node_Id := Parent (N); 15719 Arg : Node_Id; 15720 Ent : Entity_Id; 15721 15722 begin 15723 Ada_2012_Pragma; 15724 Check_No_Identifiers; 15725 Check_Arg_Count (1); 15726 15727 -- This pragma is born obsolete, but not the aspect 15728 15729 if not From_Aspect_Specification (N) then 15730 Check_Restriction 15731 (No_Obsolescent_Features, Pragma_Identifier (N)); 15732 end if; 15733 15734 if Nkind (P) = N_Task_Definition then 15735 Arg := Get_Pragma_Arg (Arg1); 15736 Ent := Defining_Identifier (Parent (P)); 15737 15738 -- A pragma that applies to a Ghost entity becomes Ghost for 15739 -- the purposes of legality checks and removal of ignored Ghost 15740 -- code. 15741 15742 Mark_Ghost_Pragma (N, Ent); 15743 15744 -- The expression must be analyzed in the special manner 15745 -- described in "Handling of Default and Per-Object 15746 -- Expressions" in sem.ads. 15747 15748 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); 15749 15750 -- Check duplicate pragma before we chain the pragma in the Rep 15751 -- Item chain of Ent. 15752 15753 Check_Duplicate_Pragma (Ent); 15754 Record_Rep_Item (Ent, N); 15755 15756 -- Anything else is incorrect 15757 15758 else 15759 Pragma_Misplaced; 15760 end if; 15761 end Dispatching_Domain; 15762 15763 --------------- 15764 -- Elaborate -- 15765 --------------- 15766 15767 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); 15768 15769 when Pragma_Elaborate => Elaborate : declare 15770 Arg : Node_Id; 15771 Citem : Node_Id; 15772 15773 begin 15774 -- Pragma must be in context items list of a compilation unit 15775 15776 if not Is_In_Context_Clause then 15777 Pragma_Misplaced; 15778 end if; 15779 15780 -- Must be at least one argument 15781 15782 if Arg_Count = 0 then 15783 Error_Pragma ("pragma% requires at least one argument"); 15784 end if; 15785 15786 -- In Ada 83 mode, there can be no items following it in the 15787 -- context list except other pragmas and implicit with clauses 15788 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this 15789 -- placement rule does not apply. 15790 15791 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 15792 Citem := Next (N); 15793 while Present (Citem) loop 15794 if Nkind (Citem) = N_Pragma 15795 or else (Nkind (Citem) = N_With_Clause 15796 and then Implicit_With (Citem)) 15797 then 15798 null; 15799 else 15800 Error_Pragma 15801 ("(Ada 83) pragma% must be at end of context clause"); 15802 end if; 15803 15804 Next (Citem); 15805 end loop; 15806 end if; 15807 15808 -- Finally, the arguments must all be units mentioned in a with 15809 -- clause in the same context clause. Note we already checked (in 15810 -- Par.Prag) that the arguments are all identifiers or selected 15811 -- components. 15812 15813 Arg := Arg1; 15814 Outer : while Present (Arg) loop 15815 Citem := First (List_Containing (N)); 15816 Inner : while Citem /= N loop 15817 if Nkind (Citem) = N_With_Clause 15818 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 15819 then 15820 Set_Elaborate_Present (Citem, True); 15821 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 15822 15823 -- With the pragma present, elaboration calls on 15824 -- subprograms from the named unit need no further 15825 -- checks, as long as the pragma appears in the current 15826 -- compilation unit. If the pragma appears in some unit 15827 -- in the context, there might still be a need for an 15828 -- Elaborate_All_Desirable from the current compilation 15829 -- to the named unit, so we keep the check enabled. This 15830 -- does not apply in SPARK mode, where we allow pragma 15831 -- Elaborate, but we don't trust it to be right so we 15832 -- will still insist on the Elaborate_All. 15833 15834 if Legacy_Elaboration_Checks 15835 and then In_Extended_Main_Source_Unit (N) 15836 and then SPARK_Mode /= On 15837 then 15838 Set_Suppress_Elaboration_Warnings 15839 (Entity (Name (Citem))); 15840 end if; 15841 15842 exit Inner; 15843 end if; 15844 15845 Next (Citem); 15846 end loop Inner; 15847 15848 if Citem = N then 15849 Error_Pragma_Arg 15850 ("argument of pragma% is not withed unit", Arg); 15851 end if; 15852 15853 Next (Arg); 15854 end loop Outer; 15855 end Elaborate; 15856 15857 ------------------- 15858 -- Elaborate_All -- 15859 ------------------- 15860 15861 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); 15862 15863 when Pragma_Elaborate_All => Elaborate_All : declare 15864 Arg : Node_Id; 15865 Citem : Node_Id; 15866 15867 begin 15868 Check_Ada_83_Warning; 15869 15870 -- Pragma must be in context items list of a compilation unit 15871 15872 if not Is_In_Context_Clause then 15873 Pragma_Misplaced; 15874 end if; 15875 15876 -- Must be at least one argument 15877 15878 if Arg_Count = 0 then 15879 Error_Pragma ("pragma% requires at least one argument"); 15880 end if; 15881 15882 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not 15883 -- have to appear at the end of the context clause, but may 15884 -- appear mixed in with other items, even in Ada 83 mode. 15885 15886 -- Final check: the arguments must all be units mentioned in 15887 -- a with clause in the same context clause. Note that we 15888 -- already checked (in Par.Prag) that all the arguments are 15889 -- either identifiers or selected components. 15890 15891 Arg := Arg1; 15892 Outr : while Present (Arg) loop 15893 Citem := First (List_Containing (N)); 15894 Innr : while Citem /= N loop 15895 if Nkind (Citem) = N_With_Clause 15896 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 15897 then 15898 Set_Elaborate_All_Present (Citem, True); 15899 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 15900 15901 -- Suppress warnings and elaboration checks on the named 15902 -- unit if the pragma is in the current compilation, as 15903 -- for pragma Elaborate. 15904 15905 if Legacy_Elaboration_Checks 15906 and then In_Extended_Main_Source_Unit (N) 15907 then 15908 Set_Suppress_Elaboration_Warnings 15909 (Entity (Name (Citem))); 15910 end if; 15911 15912 exit Innr; 15913 end if; 15914 15915 Next (Citem); 15916 end loop Innr; 15917 15918 if Citem = N then 15919 Set_Error_Posted (N); 15920 Error_Pragma_Arg 15921 ("argument of pragma% is not withed unit", Arg); 15922 end if; 15923 15924 Next (Arg); 15925 end loop Outr; 15926 end Elaborate_All; 15927 15928 -------------------- 15929 -- Elaborate_Body -- 15930 -------------------- 15931 15932 -- pragma Elaborate_Body [( library_unit_NAME )]; 15933 15934 when Pragma_Elaborate_Body => Elaborate_Body : declare 15935 Cunit_Node : Node_Id; 15936 Cunit_Ent : Entity_Id; 15937 15938 begin 15939 Check_Ada_83_Warning; 15940 Check_Valid_Library_Unit_Pragma; 15941 15942 if Nkind (N) = N_Null_Statement then 15943 return; 15944 end if; 15945 15946 Cunit_Node := Cunit (Current_Sem_Unit); 15947 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 15948 15949 -- A pragma that applies to a Ghost entity becomes Ghost for the 15950 -- purposes of legality checks and removal of ignored Ghost code. 15951 15952 Mark_Ghost_Pragma (N, Cunit_Ent); 15953 15954 if Nkind_In (Unit (Cunit_Node), N_Package_Body, 15955 N_Subprogram_Body) 15956 then 15957 Error_Pragma ("pragma% must refer to a spec, not a body"); 15958 else 15959 Set_Body_Required (Cunit_Node); 15960 Set_Has_Pragma_Elaborate_Body (Cunit_Ent); 15961 15962 -- If we are in dynamic elaboration mode, then we suppress 15963 -- elaboration warnings for the unit, since it is definitely 15964 -- fine NOT to do dynamic checks at the first level (and such 15965 -- checks will be suppressed because no elaboration boolean 15966 -- is created for Elaborate_Body packages). 15967 -- 15968 -- But in the static model of elaboration, Elaborate_Body is 15969 -- definitely NOT good enough to ensure elaboration safety on 15970 -- its own, since the body may WITH other units that are not 15971 -- safe from an elaboration point of view, so a client must 15972 -- still do an Elaborate_All on such units. 15973 -- 15974 -- Debug flag -gnatdD restores the old behavior of 3.13, where 15975 -- Elaborate_Body always suppressed elab warnings. 15976 15977 if Legacy_Elaboration_Checks 15978 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD) 15979 then 15980 Set_Suppress_Elaboration_Warnings (Cunit_Ent); 15981 end if; 15982 end if; 15983 end Elaborate_Body; 15984 15985 ------------------------ 15986 -- Elaboration_Checks -- 15987 ------------------------ 15988 15989 -- pragma Elaboration_Checks (Static | Dynamic); 15990 15991 when Pragma_Elaboration_Checks => Elaboration_Checks : declare 15992 procedure Check_Duplicate_Elaboration_Checks_Pragma; 15993 -- Emit an error if the current context list already contains 15994 -- a previous Elaboration_Checks pragma. This routine raises 15995 -- Pragma_Exit if a duplicate is found. 15996 15997 procedure Ignore_Elaboration_Checks_Pragma; 15998 -- Warn that the effects of the pragma are ignored. This routine 15999 -- raises Pragma_Exit. 16000 16001 ----------------------------------------------- 16002 -- Check_Duplicate_Elaboration_Checks_Pragma -- 16003 ----------------------------------------------- 16004 16005 procedure Check_Duplicate_Elaboration_Checks_Pragma is 16006 Item : Node_Id; 16007 16008 begin 16009 Item := Prev (N); 16010 while Present (Item) loop 16011 if Nkind (Item) = N_Pragma 16012 and then Pragma_Name (Item) = Name_Elaboration_Checks 16013 then 16014 Duplication_Error 16015 (Prag => N, 16016 Prev => Item); 16017 raise Pragma_Exit; 16018 end if; 16019 16020 Prev (Item); 16021 end loop; 16022 end Check_Duplicate_Elaboration_Checks_Pragma; 16023 16024 -------------------------------------- 16025 -- Ignore_Elaboration_Checks_Pragma -- 16026 -------------------------------------- 16027 16028 procedure Ignore_Elaboration_Checks_Pragma is 16029 begin 16030 Error_Msg_Name_1 := Pname; 16031 Error_Msg_N ("??effects of pragma % are ignored", N); 16032 Error_Msg_N 16033 ("\place pragma on initial declaration of library unit", N); 16034 16035 raise Pragma_Exit; 16036 end Ignore_Elaboration_Checks_Pragma; 16037 16038 -- Local variables 16039 16040 Context : constant Node_Id := Parent (N); 16041 Unt : Node_Id; 16042 16043 -- Start of processing for Elaboration_Checks 16044 16045 begin 16046 GNAT_Pragma; 16047 Check_Arg_Count (1); 16048 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); 16049 16050 -- The pragma appears in a configuration file 16051 16052 if No (Context) then 16053 Check_Valid_Configuration_Pragma; 16054 Check_Duplicate_Elaboration_Checks_Pragma; 16055 16056 -- The pragma acts as a configuration pragma in a compilation unit 16057 16058 -- pragma Elaboration_Checks (...); 16059 -- package Pack is ...; 16060 16061 elsif Nkind (Context) = N_Compilation_Unit 16062 and then List_Containing (N) = Context_Items (Context) 16063 then 16064 Check_Valid_Configuration_Pragma; 16065 Check_Duplicate_Elaboration_Checks_Pragma; 16066 16067 Unt := Unit (Context); 16068 16069 -- The pragma must appear on the initial declaration of a unit. 16070 -- If this is not the case, warn that the effects of the pragma 16071 -- are ignored. 16072 16073 if Nkind (Unt) = N_Package_Body then 16074 Ignore_Elaboration_Checks_Pragma; 16075 16076 -- Check the Acts_As_Spec flag of the compilation units itself 16077 -- to determine whether the subprogram body completes since it 16078 -- has not been analyzed yet. This is safe because compilation 16079 -- units are not overloadable. 16080 16081 elsif Nkind (Unt) = N_Subprogram_Body 16082 and then not Acts_As_Spec (Context) 16083 then 16084 Ignore_Elaboration_Checks_Pragma; 16085 16086 elsif Nkind (Unt) = N_Subunit then 16087 Ignore_Elaboration_Checks_Pragma; 16088 end if; 16089 16090 -- Otherwise the pragma does not appear at the configuration level 16091 -- and is illegal. 16092 16093 else 16094 Pragma_Misplaced; 16095 end if; 16096 16097 -- At this point the pragma is not a duplicate, and appears in the 16098 -- proper context. Set the elaboration model in effect. 16099 16100 Dynamic_Elaboration_Checks := 16101 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic; 16102 end Elaboration_Checks; 16103 16104 --------------- 16105 -- Eliminate -- 16106 --------------- 16107 16108 -- pragma Eliminate ( 16109 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, 16110 -- [Entity =>] IDENTIFIER | 16111 -- SELECTED_COMPONENT | 16112 -- STRING_LITERAL] 16113 -- [, Source_Location => SOURCE_TRACE]); 16114 16115 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE 16116 -- SOURCE_TRACE ::= STRING_LITERAL 16117 16118 when Pragma_Eliminate => Eliminate : declare 16119 Args : Args_List (1 .. 5); 16120 Names : constant Name_List (1 .. 5) := ( 16121 Name_Unit_Name, 16122 Name_Entity, 16123 Name_Parameter_Types, 16124 Name_Result_Type, 16125 Name_Source_Location); 16126 16127 -- Note : Parameter_Types and Result_Type are leftovers from 16128 -- prior implementations of the pragma. They are not generated 16129 -- by the gnatelim tool, and play no role in selecting which 16130 -- of a set of overloaded names is chosen for elimination. 16131 16132 Unit_Name : Node_Id renames Args (1); 16133 Entity : Node_Id renames Args (2); 16134 Parameter_Types : Node_Id renames Args (3); 16135 Result_Type : Node_Id renames Args (4); 16136 Source_Location : Node_Id renames Args (5); 16137 16138 begin 16139 GNAT_Pragma; 16140 Check_Valid_Configuration_Pragma; 16141 Gather_Associations (Names, Args); 16142 16143 if No (Unit_Name) then 16144 Error_Pragma ("missing Unit_Name argument for pragma%"); 16145 end if; 16146 16147 if No (Entity) 16148 and then (Present (Parameter_Types) 16149 or else 16150 Present (Result_Type) 16151 or else 16152 Present (Source_Location)) 16153 then 16154 Error_Pragma ("missing Entity argument for pragma%"); 16155 end if; 16156 16157 if (Present (Parameter_Types) 16158 or else 16159 Present (Result_Type)) 16160 and then 16161 Present (Source_Location) 16162 then 16163 Error_Pragma 16164 ("parameter profile and source location cannot be used " 16165 & "together in pragma%"); 16166 end if; 16167 16168 Process_Eliminate_Pragma 16169 (N, 16170 Unit_Name, 16171 Entity, 16172 Parameter_Types, 16173 Result_Type, 16174 Source_Location); 16175 end Eliminate; 16176 16177 ----------------------------------- 16178 -- Enable_Atomic_Synchronization -- 16179 ----------------------------------- 16180 16181 -- pragma Enable_Atomic_Synchronization [(Entity)]; 16182 16183 when Pragma_Enable_Atomic_Synchronization => 16184 GNAT_Pragma; 16185 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress); 16186 16187 ------------ 16188 -- Export -- 16189 ------------ 16190 16191 -- pragma Export ( 16192 -- [ Convention =>] convention_IDENTIFIER, 16193 -- [ Entity =>] LOCAL_NAME 16194 -- [, [External_Name =>] static_string_EXPRESSION ] 16195 -- [, [Link_Name =>] static_string_EXPRESSION ]); 16196 16197 when Pragma_Export => Export : declare 16198 C : Convention_Id; 16199 Def_Id : Entity_Id; 16200 16201 pragma Warnings (Off, C); 16202 16203 begin 16204 Check_Ada_83_Warning; 16205 Check_Arg_Order 16206 ((Name_Convention, 16207 Name_Entity, 16208 Name_External_Name, 16209 Name_Link_Name)); 16210 16211 Check_At_Least_N_Arguments (2); 16212 Check_At_Most_N_Arguments (4); 16213 16214 -- In Relaxed_RM_Semantics, support old Ada 83 style: 16215 -- pragma Export (Entity, "external name"); 16216 16217 if Relaxed_RM_Semantics 16218 and then Arg_Count = 2 16219 and then Nkind (Expression (Arg2)) = N_String_Literal 16220 then 16221 C := Convention_C; 16222 Def_Id := Get_Pragma_Arg (Arg1); 16223 Analyze (Def_Id); 16224 16225 if not Is_Entity_Name (Def_Id) then 16226 Error_Pragma_Arg ("entity name required", Arg1); 16227 end if; 16228 16229 Def_Id := Entity (Def_Id); 16230 Set_Exported (Def_Id, Arg1); 16231 16232 else 16233 Process_Convention (C, Def_Id); 16234 16235 -- A pragma that applies to a Ghost entity becomes Ghost for 16236 -- the purposes of legality checks and removal of ignored Ghost 16237 -- code. 16238 16239 Mark_Ghost_Pragma (N, Def_Id); 16240 16241 if Ekind (Def_Id) /= E_Constant then 16242 Note_Possible_Modification 16243 (Get_Pragma_Arg (Arg2), Sure => False); 16244 end if; 16245 16246 Process_Interface_Name (Def_Id, Arg3, Arg4, N); 16247 Set_Exported (Def_Id, Arg2); 16248 end if; 16249 16250 -- If the entity is a deferred constant, propagate the information 16251 -- to the full view, because gigi elaborates the full view only. 16252 16253 if Ekind (Def_Id) = E_Constant 16254 and then Present (Full_View (Def_Id)) 16255 then 16256 declare 16257 Id2 : constant Entity_Id := Full_View (Def_Id); 16258 begin 16259 Set_Is_Exported (Id2, Is_Exported (Def_Id)); 16260 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); 16261 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); 16262 end; 16263 end if; 16264 end Export; 16265 16266 --------------------- 16267 -- Export_Function -- 16268 --------------------- 16269 16270 -- pragma Export_Function ( 16271 -- [Internal =>] LOCAL_NAME 16272 -- [, [External =>] EXTERNAL_SYMBOL] 16273 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 16274 -- [, [Result_Type =>] TYPE_DESIGNATOR] 16275 -- [, [Mechanism =>] MECHANISM] 16276 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 16277 16278 -- EXTERNAL_SYMBOL ::= 16279 -- IDENTIFIER 16280 -- | static_string_EXPRESSION 16281 16282 -- PARAMETER_TYPES ::= 16283 -- null 16284 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16285 16286 -- TYPE_DESIGNATOR ::= 16287 -- subtype_NAME 16288 -- | subtype_Name ' Access 16289 16290 -- MECHANISM ::= 16291 -- MECHANISM_NAME 16292 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16293 16294 -- MECHANISM_ASSOCIATION ::= 16295 -- [formal_parameter_NAME =>] MECHANISM_NAME 16296 16297 -- MECHANISM_NAME ::= 16298 -- Value 16299 -- | Reference 16300 16301 when Pragma_Export_Function => Export_Function : declare 16302 Args : Args_List (1 .. 6); 16303 Names : constant Name_List (1 .. 6) := ( 16304 Name_Internal, 16305 Name_External, 16306 Name_Parameter_Types, 16307 Name_Result_Type, 16308 Name_Mechanism, 16309 Name_Result_Mechanism); 16310 16311 Internal : Node_Id renames Args (1); 16312 External : Node_Id renames Args (2); 16313 Parameter_Types : Node_Id renames Args (3); 16314 Result_Type : Node_Id renames Args (4); 16315 Mechanism : Node_Id renames Args (5); 16316 Result_Mechanism : Node_Id renames Args (6); 16317 16318 begin 16319 GNAT_Pragma; 16320 Gather_Associations (Names, Args); 16321 Process_Extended_Import_Export_Subprogram_Pragma ( 16322 Arg_Internal => Internal, 16323 Arg_External => External, 16324 Arg_Parameter_Types => Parameter_Types, 16325 Arg_Result_Type => Result_Type, 16326 Arg_Mechanism => Mechanism, 16327 Arg_Result_Mechanism => Result_Mechanism); 16328 end Export_Function; 16329 16330 ------------------- 16331 -- Export_Object -- 16332 ------------------- 16333 16334 -- pragma Export_Object ( 16335 -- [Internal =>] LOCAL_NAME 16336 -- [, [External =>] EXTERNAL_SYMBOL] 16337 -- [, [Size =>] EXTERNAL_SYMBOL]); 16338 16339 -- EXTERNAL_SYMBOL ::= 16340 -- IDENTIFIER 16341 -- | static_string_EXPRESSION 16342 16343 -- PARAMETER_TYPES ::= 16344 -- null 16345 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16346 16347 -- TYPE_DESIGNATOR ::= 16348 -- subtype_NAME 16349 -- | subtype_Name ' Access 16350 16351 -- MECHANISM ::= 16352 -- MECHANISM_NAME 16353 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16354 16355 -- MECHANISM_ASSOCIATION ::= 16356 -- [formal_parameter_NAME =>] MECHANISM_NAME 16357 16358 -- MECHANISM_NAME ::= 16359 -- Value 16360 -- | Reference 16361 16362 when Pragma_Export_Object => Export_Object : declare 16363 Args : Args_List (1 .. 3); 16364 Names : constant Name_List (1 .. 3) := ( 16365 Name_Internal, 16366 Name_External, 16367 Name_Size); 16368 16369 Internal : Node_Id renames Args (1); 16370 External : Node_Id renames Args (2); 16371 Size : Node_Id renames Args (3); 16372 16373 begin 16374 GNAT_Pragma; 16375 Gather_Associations (Names, Args); 16376 Process_Extended_Import_Export_Object_Pragma ( 16377 Arg_Internal => Internal, 16378 Arg_External => External, 16379 Arg_Size => Size); 16380 end Export_Object; 16381 16382 ---------------------- 16383 -- Export_Procedure -- 16384 ---------------------- 16385 16386 -- pragma Export_Procedure ( 16387 -- [Internal =>] LOCAL_NAME 16388 -- [, [External =>] EXTERNAL_SYMBOL] 16389 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 16390 -- [, [Mechanism =>] MECHANISM]); 16391 16392 -- EXTERNAL_SYMBOL ::= 16393 -- IDENTIFIER 16394 -- | static_string_EXPRESSION 16395 16396 -- PARAMETER_TYPES ::= 16397 -- null 16398 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16399 16400 -- TYPE_DESIGNATOR ::= 16401 -- subtype_NAME 16402 -- | subtype_Name ' Access 16403 16404 -- MECHANISM ::= 16405 -- MECHANISM_NAME 16406 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16407 16408 -- MECHANISM_ASSOCIATION ::= 16409 -- [formal_parameter_NAME =>] MECHANISM_NAME 16410 16411 -- MECHANISM_NAME ::= 16412 -- Value 16413 -- | Reference 16414 16415 when Pragma_Export_Procedure => Export_Procedure : declare 16416 Args : Args_List (1 .. 4); 16417 Names : constant Name_List (1 .. 4) := ( 16418 Name_Internal, 16419 Name_External, 16420 Name_Parameter_Types, 16421 Name_Mechanism); 16422 16423 Internal : Node_Id renames Args (1); 16424 External : Node_Id renames Args (2); 16425 Parameter_Types : Node_Id renames Args (3); 16426 Mechanism : Node_Id renames Args (4); 16427 16428 begin 16429 GNAT_Pragma; 16430 Gather_Associations (Names, Args); 16431 Process_Extended_Import_Export_Subprogram_Pragma ( 16432 Arg_Internal => Internal, 16433 Arg_External => External, 16434 Arg_Parameter_Types => Parameter_Types, 16435 Arg_Mechanism => Mechanism); 16436 end Export_Procedure; 16437 16438 ------------------ 16439 -- Export_Value -- 16440 ------------------ 16441 16442 -- pragma Export_Value ( 16443 -- [Value =>] static_integer_EXPRESSION, 16444 -- [Link_Name =>] static_string_EXPRESSION); 16445 16446 when Pragma_Export_Value => 16447 GNAT_Pragma; 16448 Check_Arg_Order ((Name_Value, Name_Link_Name)); 16449 Check_Arg_Count (2); 16450 16451 Check_Optional_Identifier (Arg1, Name_Value); 16452 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); 16453 16454 Check_Optional_Identifier (Arg2, Name_Link_Name); 16455 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 16456 16457 ----------------------------- 16458 -- Export_Valued_Procedure -- 16459 ----------------------------- 16460 16461 -- pragma Export_Valued_Procedure ( 16462 -- [Internal =>] LOCAL_NAME 16463 -- [, [External =>] EXTERNAL_SYMBOL,] 16464 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 16465 -- [, [Mechanism =>] MECHANISM]); 16466 16467 -- EXTERNAL_SYMBOL ::= 16468 -- IDENTIFIER 16469 -- | static_string_EXPRESSION 16470 16471 -- PARAMETER_TYPES ::= 16472 -- null 16473 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16474 16475 -- TYPE_DESIGNATOR ::= 16476 -- subtype_NAME 16477 -- | subtype_Name ' Access 16478 16479 -- MECHANISM ::= 16480 -- MECHANISM_NAME 16481 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16482 16483 -- MECHANISM_ASSOCIATION ::= 16484 -- [formal_parameter_NAME =>] MECHANISM_NAME 16485 16486 -- MECHANISM_NAME ::= 16487 -- Value 16488 -- | Reference 16489 16490 when Pragma_Export_Valued_Procedure => 16491 Export_Valued_Procedure : declare 16492 Args : Args_List (1 .. 4); 16493 Names : constant Name_List (1 .. 4) := ( 16494 Name_Internal, 16495 Name_External, 16496 Name_Parameter_Types, 16497 Name_Mechanism); 16498 16499 Internal : Node_Id renames Args (1); 16500 External : Node_Id renames Args (2); 16501 Parameter_Types : Node_Id renames Args (3); 16502 Mechanism : Node_Id renames Args (4); 16503 16504 begin 16505 GNAT_Pragma; 16506 Gather_Associations (Names, Args); 16507 Process_Extended_Import_Export_Subprogram_Pragma ( 16508 Arg_Internal => Internal, 16509 Arg_External => External, 16510 Arg_Parameter_Types => Parameter_Types, 16511 Arg_Mechanism => Mechanism); 16512 end Export_Valued_Procedure; 16513 16514 ------------------- 16515 -- Extend_System -- 16516 ------------------- 16517 16518 -- pragma Extend_System ([Name =>] Identifier); 16519 16520 when Pragma_Extend_System => 16521 GNAT_Pragma; 16522 Check_Valid_Configuration_Pragma; 16523 Check_Arg_Count (1); 16524 Check_Optional_Identifier (Arg1, Name_Name); 16525 Check_Arg_Is_Identifier (Arg1); 16526 16527 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 16528 16529 if Name_Len > 4 16530 and then Name_Buffer (1 .. 4) = "aux_" 16531 then 16532 if Present (System_Extend_Pragma_Arg) then 16533 if Chars (Get_Pragma_Arg (Arg1)) = 16534 Chars (Expression (System_Extend_Pragma_Arg)) 16535 then 16536 null; 16537 else 16538 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg); 16539 Error_Pragma ("pragma% conflicts with that #"); 16540 end if; 16541 16542 else 16543 System_Extend_Pragma_Arg := Arg1; 16544 16545 if not GNAT_Mode then 16546 System_Extend_Unit := Arg1; 16547 end if; 16548 end if; 16549 else 16550 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); 16551 end if; 16552 16553 ------------------------ 16554 -- Extensions_Allowed -- 16555 ------------------------ 16556 16557 -- pragma Extensions_Allowed (ON | OFF); 16558 16559 when Pragma_Extensions_Allowed => 16560 GNAT_Pragma; 16561 Check_Arg_Count (1); 16562 Check_No_Identifiers; 16563 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 16564 16565 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 16566 Extensions_Allowed := True; 16567 Ada_Version := Ada_Version_Type'Last; 16568 16569 else 16570 Extensions_Allowed := False; 16571 Ada_Version := Ada_Version_Explicit; 16572 Ada_Version_Pragma := Empty; 16573 end if; 16574 16575 ------------------------ 16576 -- Extensions_Visible -- 16577 ------------------------ 16578 16579 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ]; 16580 16581 -- Characteristics: 16582 16583 -- * Analysis - The annotation is fully analyzed immediately upon 16584 -- elaboration as its expression must be static. 16585 16586 -- * Expansion - None. 16587 16588 -- * Template - The annotation utilizes the generic template of the 16589 -- related subprogram [body] when it is: 16590 16591 -- aspect on subprogram declaration 16592 -- aspect on stand-alone subprogram body 16593 -- pragma on stand-alone subprogram body 16594 16595 -- The annotation must prepare its own template when it is: 16596 16597 -- pragma on subprogram declaration 16598 16599 -- * Globals - Capture of global references must occur after full 16600 -- analysis. 16601 16602 -- * Instance - The annotation is instantiated automatically when 16603 -- the related generic subprogram [body] is instantiated except for 16604 -- the "pragma on subprogram declaration" case. In that scenario 16605 -- the annotation must instantiate itself. 16606 16607 when Pragma_Extensions_Visible => Extensions_Visible : declare 16608 Formal : Entity_Id; 16609 Has_OK_Formal : Boolean := False; 16610 Spec_Id : Entity_Id; 16611 Subp_Decl : Node_Id; 16612 16613 begin 16614 GNAT_Pragma; 16615 Check_No_Identifiers; 16616 Check_At_Most_N_Arguments (1); 16617 16618 Subp_Decl := 16619 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 16620 16621 -- Abstract subprogram declaration 16622 16623 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 16624 null; 16625 16626 -- Generic subprogram declaration 16627 16628 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 16629 null; 16630 16631 -- Body acts as spec 16632 16633 elsif Nkind (Subp_Decl) = N_Subprogram_Body 16634 and then No (Corresponding_Spec (Subp_Decl)) 16635 then 16636 null; 16637 16638 -- Body stub acts as spec 16639 16640 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 16641 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 16642 then 16643 null; 16644 16645 -- Subprogram declaration 16646 16647 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 16648 null; 16649 16650 -- Otherwise the pragma is associated with an illegal construct 16651 16652 else 16653 Error_Pragma ("pragma % must apply to a subprogram"); 16654 return; 16655 end if; 16656 16657 -- Mark the pragma as Ghost if the related subprogram is also 16658 -- Ghost. This also ensures that any expansion performed further 16659 -- below will produce Ghost nodes. 16660 16661 Spec_Id := Unique_Defining_Entity (Subp_Decl); 16662 Mark_Ghost_Pragma (N, Spec_Id); 16663 16664 -- Chain the pragma on the contract for completeness 16665 16666 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 16667 16668 -- The legality checks of pragma Extension_Visible are affected 16669 -- by the SPARK mode in effect. Analyze all pragmas in specific 16670 -- order. 16671 16672 Analyze_If_Present (Pragma_SPARK_Mode); 16673 16674 -- Examine the formals of the related subprogram 16675 16676 Formal := First_Formal (Spec_Id); 16677 while Present (Formal) loop 16678 16679 -- At least one of the formals is of a specific tagged type, 16680 -- the pragma is legal. 16681 16682 if Is_Specific_Tagged_Type (Etype (Formal)) then 16683 Has_OK_Formal := True; 16684 exit; 16685 16686 -- A generic subprogram with at least one formal of a private 16687 -- type ensures the legality of the pragma because the actual 16688 -- may be specifically tagged. Note that this is verified by 16689 -- the check above at instantiation time. 16690 16691 elsif Is_Private_Type (Etype (Formal)) 16692 and then Is_Generic_Type (Etype (Formal)) 16693 then 16694 Has_OK_Formal := True; 16695 exit; 16696 end if; 16697 16698 Next_Formal (Formal); 16699 end loop; 16700 16701 if not Has_OK_Formal then 16702 Error_Msg_Name_1 := Pname; 16703 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N); 16704 Error_Msg_NE 16705 ("\subprogram & lacks parameter of specific tagged or " 16706 & "generic private type", N, Spec_Id); 16707 16708 return; 16709 end if; 16710 16711 -- Analyze the Boolean expression (if any) 16712 16713 if Present (Arg1) then 16714 Check_Static_Boolean_Expression 16715 (Expression (Get_Argument (N, Spec_Id))); 16716 end if; 16717 end Extensions_Visible; 16718 16719 -------------- 16720 -- External -- 16721 -------------- 16722 16723 -- pragma External ( 16724 -- [ Convention =>] convention_IDENTIFIER, 16725 -- [ Entity =>] LOCAL_NAME 16726 -- [, [External_Name =>] static_string_EXPRESSION ] 16727 -- [, [Link_Name =>] static_string_EXPRESSION ]); 16728 16729 when Pragma_External => External : declare 16730 C : Convention_Id; 16731 E : Entity_Id; 16732 pragma Warnings (Off, C); 16733 16734 begin 16735 GNAT_Pragma; 16736 Check_Arg_Order 16737 ((Name_Convention, 16738 Name_Entity, 16739 Name_External_Name, 16740 Name_Link_Name)); 16741 Check_At_Least_N_Arguments (2); 16742 Check_At_Most_N_Arguments (4); 16743 Process_Convention (C, E); 16744 16745 -- A pragma that applies to a Ghost entity becomes Ghost for the 16746 -- purposes of legality checks and removal of ignored Ghost code. 16747 16748 Mark_Ghost_Pragma (N, E); 16749 16750 Note_Possible_Modification 16751 (Get_Pragma_Arg (Arg2), Sure => False); 16752 Process_Interface_Name (E, Arg3, Arg4, N); 16753 Set_Exported (E, Arg2); 16754 end External; 16755 16756 -------------------------- 16757 -- External_Name_Casing -- 16758 -------------------------- 16759 16760 -- pragma External_Name_Casing ( 16761 -- UPPERCASE | LOWERCASE 16762 -- [, AS_IS | UPPERCASE | LOWERCASE]); 16763 16764 when Pragma_External_Name_Casing => 16765 GNAT_Pragma; 16766 Check_No_Identifiers; 16767 16768 if Arg_Count = 2 then 16769 Check_Arg_Is_One_Of 16770 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase); 16771 16772 case Chars (Get_Pragma_Arg (Arg2)) is 16773 when Name_As_Is => 16774 Opt.External_Name_Exp_Casing := As_Is; 16775 16776 when Name_Uppercase => 16777 Opt.External_Name_Exp_Casing := Uppercase; 16778 16779 when Name_Lowercase => 16780 Opt.External_Name_Exp_Casing := Lowercase; 16781 16782 when others => 16783 null; 16784 end case; 16785 16786 else 16787 Check_Arg_Count (1); 16788 end if; 16789 16790 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase); 16791 16792 case Chars (Get_Pragma_Arg (Arg1)) is 16793 when Name_Uppercase => 16794 Opt.External_Name_Imp_Casing := Uppercase; 16795 16796 when Name_Lowercase => 16797 Opt.External_Name_Imp_Casing := Lowercase; 16798 16799 when others => 16800 null; 16801 end case; 16802 16803 --------------- 16804 -- Fast_Math -- 16805 --------------- 16806 16807 -- pragma Fast_Math; 16808 16809 when Pragma_Fast_Math => 16810 GNAT_Pragma; 16811 Check_No_Identifiers; 16812 Check_Valid_Configuration_Pragma; 16813 Fast_Math := True; 16814 16815 -------------------------- 16816 -- Favor_Top_Level -- 16817 -------------------------- 16818 16819 -- pragma Favor_Top_Level (type_NAME); 16820 16821 when Pragma_Favor_Top_Level => Favor_Top_Level : declare 16822 Typ : Entity_Id; 16823 16824 begin 16825 GNAT_Pragma; 16826 Check_No_Identifiers; 16827 Check_Arg_Count (1); 16828 Check_Arg_Is_Local_Name (Arg1); 16829 Typ := Entity (Get_Pragma_Arg (Arg1)); 16830 16831 -- A pragma that applies to a Ghost entity becomes Ghost for the 16832 -- purposes of legality checks and removal of ignored Ghost code. 16833 16834 Mark_Ghost_Pragma (N, Typ); 16835 16836 -- If it's an access-to-subprogram type (in particular, not a 16837 -- subtype), set the flag on that type. 16838 16839 if Is_Access_Subprogram_Type (Typ) then 16840 Set_Can_Use_Internal_Rep (Typ, False); 16841 16842 -- Otherwise it's an error (name denotes the wrong sort of entity) 16843 16844 else 16845 Error_Pragma_Arg 16846 ("access-to-subprogram type expected", 16847 Get_Pragma_Arg (Arg1)); 16848 end if; 16849 end Favor_Top_Level; 16850 16851 --------------------------- 16852 -- Finalize_Storage_Only -- 16853 --------------------------- 16854 16855 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); 16856 16857 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare 16858 Assoc : constant Node_Id := Arg1; 16859 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 16860 Typ : Entity_Id; 16861 16862 begin 16863 GNAT_Pragma; 16864 Check_No_Identifiers; 16865 Check_Arg_Count (1); 16866 Check_Arg_Is_Local_Name (Arg1); 16867 16868 Find_Type (Type_Id); 16869 Typ := Entity (Type_Id); 16870 16871 if Typ = Any_Type 16872 or else Rep_Item_Too_Early (Typ, N) 16873 then 16874 return; 16875 else 16876 Typ := Underlying_Type (Typ); 16877 end if; 16878 16879 if not Is_Controlled (Typ) then 16880 Error_Pragma ("pragma% must specify controlled type"); 16881 end if; 16882 16883 Check_First_Subtype (Arg1); 16884 16885 if Finalize_Storage_Only (Typ) then 16886 Error_Pragma ("duplicate pragma%, only one allowed"); 16887 16888 elsif not Rep_Item_Too_Late (Typ, N) then 16889 Set_Finalize_Storage_Only (Base_Type (Typ), True); 16890 end if; 16891 end Finalize_Storage; 16892 16893 ----------- 16894 -- Ghost -- 16895 ----------- 16896 16897 -- pragma Ghost [ (boolean_EXPRESSION) ]; 16898 16899 when Pragma_Ghost => Ghost : declare 16900 Context : Node_Id; 16901 Expr : Node_Id; 16902 Id : Entity_Id; 16903 Orig_Stmt : Node_Id; 16904 Prev_Id : Entity_Id; 16905 Stmt : Node_Id; 16906 16907 begin 16908 GNAT_Pragma; 16909 Check_No_Identifiers; 16910 Check_At_Most_N_Arguments (1); 16911 16912 Id := Empty; 16913 Stmt := Prev (N); 16914 while Present (Stmt) loop 16915 16916 -- Skip prior pragmas, but check for duplicates 16917 16918 if Nkind (Stmt) = N_Pragma then 16919 if Pragma_Name (Stmt) = Pname then 16920 Duplication_Error 16921 (Prag => N, 16922 Prev => Stmt); 16923 raise Pragma_Exit; 16924 end if; 16925 16926 -- Task unit declared without a definition cannot be subject to 16927 -- pragma Ghost (SPARK RM 6.9(19)). 16928 16929 elsif Nkind_In (Stmt, N_Single_Task_Declaration, 16930 N_Task_Type_Declaration) 16931 then 16932 Error_Pragma ("pragma % cannot apply to a task type"); 16933 return; 16934 16935 -- Skip internally generated code 16936 16937 elsif not Comes_From_Source (Stmt) then 16938 Orig_Stmt := Original_Node (Stmt); 16939 16940 -- When pragma Ghost applies to an untagged derivation, the 16941 -- derivation is transformed into a [sub]type declaration. 16942 16943 if Nkind_In (Stmt, N_Full_Type_Declaration, 16944 N_Subtype_Declaration) 16945 and then Comes_From_Source (Orig_Stmt) 16946 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration 16947 and then Nkind (Type_Definition (Orig_Stmt)) = 16948 N_Derived_Type_Definition 16949 then 16950 Id := Defining_Entity (Stmt); 16951 exit; 16952 16953 -- When pragma Ghost applies to an object declaration which 16954 -- is initialized by means of a function call that returns 16955 -- on the secondary stack, the object declaration becomes a 16956 -- renaming. 16957 16958 elsif Nkind (Stmt) = N_Object_Renaming_Declaration 16959 and then Comes_From_Source (Orig_Stmt) 16960 and then Nkind (Orig_Stmt) = N_Object_Declaration 16961 then 16962 Id := Defining_Entity (Stmt); 16963 exit; 16964 16965 -- When pragma Ghost applies to an expression function, the 16966 -- expression function is transformed into a subprogram. 16967 16968 elsif Nkind (Stmt) = N_Subprogram_Declaration 16969 and then Comes_From_Source (Orig_Stmt) 16970 and then Nkind (Orig_Stmt) = N_Expression_Function 16971 then 16972 Id := Defining_Entity (Stmt); 16973 exit; 16974 end if; 16975 16976 -- The pragma applies to a legal construct, stop the traversal 16977 16978 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration, 16979 N_Full_Type_Declaration, 16980 N_Generic_Subprogram_Declaration, 16981 N_Object_Declaration, 16982 N_Private_Extension_Declaration, 16983 N_Private_Type_Declaration, 16984 N_Subprogram_Declaration, 16985 N_Subtype_Declaration) 16986 then 16987 Id := Defining_Entity (Stmt); 16988 exit; 16989 16990 -- The pragma does not apply to a legal construct, issue an 16991 -- error and stop the analysis. 16992 16993 else 16994 Error_Pragma 16995 ("pragma % must apply to an object, package, subprogram " 16996 & "or type"); 16997 return; 16998 end if; 16999 17000 Stmt := Prev (Stmt); 17001 end loop; 17002 17003 Context := Parent (N); 17004 17005 -- Handle compilation units 17006 17007 if Nkind (Context) = N_Compilation_Unit_Aux then 17008 Context := Unit (Parent (Context)); 17009 end if; 17010 17011 -- Protected and task types cannot be subject to pragma Ghost 17012 -- (SPARK RM 6.9(19)). 17013 17014 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition) 17015 then 17016 Error_Pragma ("pragma % cannot apply to a protected type"); 17017 return; 17018 17019 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then 17020 Error_Pragma ("pragma % cannot apply to a task type"); 17021 return; 17022 end if; 17023 17024 if No (Id) then 17025 17026 -- When pragma Ghost is associated with a [generic] package, it 17027 -- appears in the visible declarations. 17028 17029 if Nkind (Context) = N_Package_Specification 17030 and then Present (Visible_Declarations (Context)) 17031 and then List_Containing (N) = Visible_Declarations (Context) 17032 then 17033 Id := Defining_Entity (Context); 17034 17035 -- Pragma Ghost applies to a stand-alone subprogram body 17036 17037 elsif Nkind (Context) = N_Subprogram_Body 17038 and then No (Corresponding_Spec (Context)) 17039 then 17040 Id := Defining_Entity (Context); 17041 17042 -- Pragma Ghost applies to a subprogram declaration that acts 17043 -- as a compilation unit. 17044 17045 elsif Nkind (Context) = N_Subprogram_Declaration then 17046 Id := Defining_Entity (Context); 17047 17048 -- Pragma Ghost applies to a generic subprogram 17049 17050 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then 17051 Id := Defining_Entity (Specification (Context)); 17052 end if; 17053 end if; 17054 17055 if No (Id) then 17056 Error_Pragma 17057 ("pragma % must apply to an object, package, subprogram or " 17058 & "type"); 17059 return; 17060 end if; 17061 17062 -- Handle completions of types and constants that are subject to 17063 -- pragma Ghost. 17064 17065 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then 17066 Prev_Id := Incomplete_Or_Partial_View (Id); 17067 17068 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then 17069 Error_Msg_Name_1 := Pname; 17070 17071 -- The full declaration of a deferred constant cannot be 17072 -- subject to pragma Ghost unless the deferred declaration 17073 -- is also Ghost (SPARK RM 6.9(9)). 17074 17075 if Ekind (Prev_Id) = E_Constant then 17076 Error_Msg_Name_1 := Pname; 17077 Error_Msg_NE (Fix_Error 17078 ("pragma % must apply to declaration of deferred " 17079 & "constant &"), N, Id); 17080 return; 17081 17082 -- Pragma Ghost may appear on the full view of an incomplete 17083 -- type because the incomplete declaration lacks aspects and 17084 -- cannot be subject to pragma Ghost. 17085 17086 elsif Ekind (Prev_Id) = E_Incomplete_Type then 17087 null; 17088 17089 -- The full declaration of a type cannot be subject to 17090 -- pragma Ghost unless the partial view is also Ghost 17091 -- (SPARK RM 6.9(9)). 17092 17093 else 17094 Error_Msg_NE (Fix_Error 17095 ("pragma % must apply to partial view of type &"), 17096 N, Id); 17097 return; 17098 end if; 17099 end if; 17100 17101 -- A synchronized object cannot be subject to pragma Ghost 17102 -- (SPARK RM 6.9(19)). 17103 17104 elsif Ekind (Id) = E_Variable then 17105 if Is_Protected_Type (Etype (Id)) then 17106 Error_Pragma ("pragma % cannot apply to a protected object"); 17107 return; 17108 17109 elsif Is_Task_Type (Etype (Id)) then 17110 Error_Pragma ("pragma % cannot apply to a task object"); 17111 return; 17112 end if; 17113 end if; 17114 17115 -- Analyze the Boolean expression (if any) 17116 17117 if Present (Arg1) then 17118 Expr := Get_Pragma_Arg (Arg1); 17119 17120 Analyze_And_Resolve (Expr, Standard_Boolean); 17121 17122 if Is_OK_Static_Expression (Expr) then 17123 17124 -- "Ghostness" cannot be turned off once enabled within a 17125 -- region (SPARK RM 6.9(6)). 17126 17127 if Is_False (Expr_Value (Expr)) 17128 and then Ghost_Mode > None 17129 then 17130 Error_Pragma 17131 ("pragma % with value False cannot appear in enabled " 17132 & "ghost region"); 17133 return; 17134 end if; 17135 17136 -- Otherwie the expression is not static 17137 17138 else 17139 Error_Pragma_Arg 17140 ("expression of pragma % must be static", Expr); 17141 return; 17142 end if; 17143 end if; 17144 17145 Set_Is_Ghost_Entity (Id); 17146 end Ghost; 17147 17148 ------------ 17149 -- Global -- 17150 ------------ 17151 17152 -- pragma Global (GLOBAL_SPECIFICATION); 17153 17154 -- GLOBAL_SPECIFICATION ::= 17155 -- null 17156 -- | (GLOBAL_LIST) 17157 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}) 17158 17159 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 17160 17161 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 17162 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 17163 -- GLOBAL_ITEM ::= NAME 17164 17165 -- Characteristics: 17166 17167 -- * Analysis - The annotation undergoes initial checks to verify 17168 -- the legal placement and context. Secondary checks fully analyze 17169 -- the dependency clauses in: 17170 17171 -- Analyze_Global_In_Decl_Part 17172 17173 -- * Expansion - None. 17174 17175 -- * Template - The annotation utilizes the generic template of the 17176 -- related subprogram [body] when it is: 17177 17178 -- aspect on subprogram declaration 17179 -- aspect on stand-alone subprogram body 17180 -- pragma on stand-alone subprogram body 17181 17182 -- The annotation must prepare its own template when it is: 17183 17184 -- pragma on subprogram declaration 17185 17186 -- * Globals - Capture of global references must occur after full 17187 -- analysis. 17188 17189 -- * Instance - The annotation is instantiated automatically when 17190 -- the related generic subprogram [body] is instantiated except for 17191 -- the "pragma on subprogram declaration" case. In that scenario 17192 -- the annotation must instantiate itself. 17193 17194 when Pragma_Global => Global : declare 17195 Legal : Boolean; 17196 Spec_Id : Entity_Id; 17197 Subp_Decl : Node_Id; 17198 17199 begin 17200 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); 17201 17202 if Legal then 17203 17204 -- Chain the pragma on the contract for further processing by 17205 -- Analyze_Global_In_Decl_Part. 17206 17207 Add_Contract_Item (N, Spec_Id); 17208 17209 -- Fully analyze the pragma when it appears inside an entry 17210 -- or subprogram body because it cannot benefit from forward 17211 -- references. 17212 17213 if Nkind_In (Subp_Decl, N_Entry_Body, 17214 N_Subprogram_Body, 17215 N_Subprogram_Body_Stub) 17216 then 17217 -- The legality checks of pragmas Depends and Global are 17218 -- affected by the SPARK mode in effect and the volatility 17219 -- of the context. In addition these two pragmas are subject 17220 -- to an inherent order: 17221 17222 -- 1) Global 17223 -- 2) Depends 17224 17225 -- Analyze all these pragmas in the order outlined above 17226 17227 Analyze_If_Present (Pragma_SPARK_Mode); 17228 Analyze_If_Present (Pragma_Volatile_Function); 17229 Analyze_Global_In_Decl_Part (N); 17230 Analyze_If_Present (Pragma_Depends); 17231 end if; 17232 end if; 17233 end Global; 17234 17235 ----------- 17236 -- Ident -- 17237 ----------- 17238 17239 -- pragma Ident (static_string_EXPRESSION) 17240 17241 -- Note: pragma Comment shares this processing. Pragma Ident is 17242 -- identical in effect to pragma Commment. 17243 17244 when Pragma_Comment 17245 | Pragma_Ident 17246 => 17247 Ident : declare 17248 Str : Node_Id; 17249 17250 begin 17251 GNAT_Pragma; 17252 Check_Arg_Count (1); 17253 Check_No_Identifiers; 17254 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 17255 Store_Note (N); 17256 17257 Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); 17258 17259 declare 17260 CS : Node_Id; 17261 GP : Node_Id; 17262 17263 begin 17264 GP := Parent (Parent (N)); 17265 17266 if Nkind_In (GP, N_Package_Declaration, 17267 N_Generic_Package_Declaration) 17268 then 17269 GP := Parent (GP); 17270 end if; 17271 17272 -- If we have a compilation unit, then record the ident value, 17273 -- checking for improper duplication. 17274 17275 if Nkind (GP) = N_Compilation_Unit then 17276 CS := Ident_String (Current_Sem_Unit); 17277 17278 if Present (CS) then 17279 17280 -- If we have multiple instances, concatenate them, but 17281 -- not in ASIS, where we want the original tree. 17282 17283 if not ASIS_Mode then 17284 Start_String (Strval (CS)); 17285 Store_String_Char (' '); 17286 Store_String_Chars (Strval (Str)); 17287 Set_Strval (CS, End_String); 17288 end if; 17289 17290 else 17291 Set_Ident_String (Current_Sem_Unit, Str); 17292 end if; 17293 17294 -- For subunits, we just ignore the Ident, since in GNAT these 17295 -- are not separate object files, and hence not separate units 17296 -- in the unit table. 17297 17298 elsif Nkind (GP) = N_Subunit then 17299 null; 17300 end if; 17301 end; 17302 end Ident; 17303 17304 ------------------- 17305 -- Ignore_Pragma -- 17306 ------------------- 17307 17308 -- pragma Ignore_Pragma (pragma_IDENTIFIER); 17309 17310 -- Entirely handled in the parser, nothing to do here 17311 17312 when Pragma_Ignore_Pragma => 17313 null; 17314 17315 ---------------------------- 17316 -- Implementation_Defined -- 17317 ---------------------------- 17318 17319 -- pragma Implementation_Defined (LOCAL_NAME); 17320 17321 -- Marks previously declared entity as implementation defined. For 17322 -- an overloaded entity, applies to the most recent homonym. 17323 17324 -- pragma Implementation_Defined; 17325 17326 -- The form with no arguments appears anywhere within a scope, most 17327 -- typically a package spec, and indicates that all entities that are 17328 -- defined within the package spec are Implementation_Defined. 17329 17330 when Pragma_Implementation_Defined => Implementation_Defined : declare 17331 Ent : Entity_Id; 17332 17333 begin 17334 GNAT_Pragma; 17335 Check_No_Identifiers; 17336 17337 -- Form with no arguments 17338 17339 if Arg_Count = 0 then 17340 Set_Is_Implementation_Defined (Current_Scope); 17341 17342 -- Form with one argument 17343 17344 else 17345 Check_Arg_Count (1); 17346 Check_Arg_Is_Local_Name (Arg1); 17347 Ent := Entity (Get_Pragma_Arg (Arg1)); 17348 Set_Is_Implementation_Defined (Ent); 17349 end if; 17350 end Implementation_Defined; 17351 17352 ----------------- 17353 -- Implemented -- 17354 ----------------- 17355 17356 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND); 17357 17358 -- IMPLEMENTATION_KIND ::= 17359 -- By_Entry | By_Protected_Procedure | By_Any | Optional 17360 17361 -- "By_Any" and "Optional" are treated as synonyms in order to 17362 -- support Ada 2012 aspect Synchronization. 17363 17364 when Pragma_Implemented => Implemented : declare 17365 Proc_Id : Entity_Id; 17366 Typ : Entity_Id; 17367 17368 begin 17369 Ada_2012_Pragma; 17370 Check_Arg_Count (2); 17371 Check_No_Identifiers; 17372 Check_Arg_Is_Identifier (Arg1); 17373 Check_Arg_Is_Local_Name (Arg1); 17374 Check_Arg_Is_One_Of (Arg2, 17375 Name_By_Any, 17376 Name_By_Entry, 17377 Name_By_Protected_Procedure, 17378 Name_Optional); 17379 17380 -- Extract the name of the local procedure 17381 17382 Proc_Id := Entity (Get_Pragma_Arg (Arg1)); 17383 17384 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a 17385 -- primitive procedure of a synchronized tagged type. 17386 17387 if Ekind (Proc_Id) = E_Procedure 17388 and then Is_Primitive (Proc_Id) 17389 and then Present (First_Formal (Proc_Id)) 17390 then 17391 Typ := Etype (First_Formal (Proc_Id)); 17392 17393 if Is_Tagged_Type (Typ) 17394 and then 17395 17396 -- Check for a protected, a synchronized or a task interface 17397 17398 ((Is_Interface (Typ) 17399 and then Is_Synchronized_Interface (Typ)) 17400 17401 -- Check for a protected type or a task type that implements 17402 -- an interface. 17403 17404 or else 17405 (Is_Concurrent_Record_Type (Typ) 17406 and then Present (Interfaces (Typ))) 17407 17408 -- In analysis-only mode, examine original protected type 17409 17410 or else 17411 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration 17412 and then Present (Interface_List (Parent (Typ)))) 17413 17414 -- Check for a private record extension with keyword 17415 -- "synchronized". 17416 17417 or else 17418 (Ekind_In (Typ, E_Record_Type_With_Private, 17419 E_Record_Subtype_With_Private) 17420 and then Synchronized_Present (Parent (Typ)))) 17421 then 17422 null; 17423 else 17424 Error_Pragma_Arg 17425 ("controlling formal must be of synchronized tagged type", 17426 Arg1); 17427 return; 17428 end if; 17429 17430 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind 17431 -- By_Protected_Procedure to the primitive procedure of a task 17432 -- interface. 17433 17434 if Chars (Arg2) = Name_By_Protected_Procedure 17435 and then Is_Interface (Typ) 17436 and then Is_Task_Interface (Typ) 17437 then 17438 Error_Pragma_Arg 17439 ("implementation kind By_Protected_Procedure cannot be " 17440 & "applied to a task interface primitive", Arg2); 17441 return; 17442 end if; 17443 17444 -- Procedures declared inside a protected type must be accepted 17445 17446 elsif Ekind (Proc_Id) = E_Procedure 17447 and then Is_Protected_Type (Scope (Proc_Id)) 17448 then 17449 null; 17450 17451 -- The first argument is not a primitive procedure 17452 17453 else 17454 Error_Pragma_Arg 17455 ("pragma % must be applied to a primitive procedure", Arg1); 17456 return; 17457 end if; 17458 17459 Record_Rep_Item (Proc_Id, N); 17460 end Implemented; 17461 17462 ---------------------- 17463 -- Implicit_Packing -- 17464 ---------------------- 17465 17466 -- pragma Implicit_Packing; 17467 17468 when Pragma_Implicit_Packing => 17469 GNAT_Pragma; 17470 Check_Arg_Count (0); 17471 Implicit_Packing := True; 17472 17473 ------------ 17474 -- Import -- 17475 ------------ 17476 17477 -- pragma Import ( 17478 -- [Convention =>] convention_IDENTIFIER, 17479 -- [Entity =>] LOCAL_NAME 17480 -- [, [External_Name =>] static_string_EXPRESSION ] 17481 -- [, [Link_Name =>] static_string_EXPRESSION ]); 17482 17483 when Pragma_Import => 17484 Check_Ada_83_Warning; 17485 Check_Arg_Order 17486 ((Name_Convention, 17487 Name_Entity, 17488 Name_External_Name, 17489 Name_Link_Name)); 17490 17491 Check_At_Least_N_Arguments (2); 17492 Check_At_Most_N_Arguments (4); 17493 Process_Import_Or_Interface; 17494 17495 --------------------- 17496 -- Import_Function -- 17497 --------------------- 17498 17499 -- pragma Import_Function ( 17500 -- [Internal =>] LOCAL_NAME, 17501 -- [, [External =>] EXTERNAL_SYMBOL] 17502 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 17503 -- [, [Result_Type =>] SUBTYPE_MARK] 17504 -- [, [Mechanism =>] MECHANISM] 17505 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 17506 17507 -- EXTERNAL_SYMBOL ::= 17508 -- IDENTIFIER 17509 -- | static_string_EXPRESSION 17510 17511 -- PARAMETER_TYPES ::= 17512 -- null 17513 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 17514 17515 -- TYPE_DESIGNATOR ::= 17516 -- subtype_NAME 17517 -- | subtype_Name ' Access 17518 17519 -- MECHANISM ::= 17520 -- MECHANISM_NAME 17521 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 17522 17523 -- MECHANISM_ASSOCIATION ::= 17524 -- [formal_parameter_NAME =>] MECHANISM_NAME 17525 17526 -- MECHANISM_NAME ::= 17527 -- Value 17528 -- | Reference 17529 17530 when Pragma_Import_Function => Import_Function : declare 17531 Args : Args_List (1 .. 6); 17532 Names : constant Name_List (1 .. 6) := ( 17533 Name_Internal, 17534 Name_External, 17535 Name_Parameter_Types, 17536 Name_Result_Type, 17537 Name_Mechanism, 17538 Name_Result_Mechanism); 17539 17540 Internal : Node_Id renames Args (1); 17541 External : Node_Id renames Args (2); 17542 Parameter_Types : Node_Id renames Args (3); 17543 Result_Type : Node_Id renames Args (4); 17544 Mechanism : Node_Id renames Args (5); 17545 Result_Mechanism : Node_Id renames Args (6); 17546 17547 begin 17548 GNAT_Pragma; 17549 Gather_Associations (Names, Args); 17550 Process_Extended_Import_Export_Subprogram_Pragma ( 17551 Arg_Internal => Internal, 17552 Arg_External => External, 17553 Arg_Parameter_Types => Parameter_Types, 17554 Arg_Result_Type => Result_Type, 17555 Arg_Mechanism => Mechanism, 17556 Arg_Result_Mechanism => Result_Mechanism); 17557 end Import_Function; 17558 17559 ------------------- 17560 -- Import_Object -- 17561 ------------------- 17562 17563 -- pragma Import_Object ( 17564 -- [Internal =>] LOCAL_NAME 17565 -- [, [External =>] EXTERNAL_SYMBOL] 17566 -- [, [Size =>] EXTERNAL_SYMBOL]); 17567 17568 -- EXTERNAL_SYMBOL ::= 17569 -- IDENTIFIER 17570 -- | static_string_EXPRESSION 17571 17572 when Pragma_Import_Object => Import_Object : declare 17573 Args : Args_List (1 .. 3); 17574 Names : constant Name_List (1 .. 3) := ( 17575 Name_Internal, 17576 Name_External, 17577 Name_Size); 17578 17579 Internal : Node_Id renames Args (1); 17580 External : Node_Id renames Args (2); 17581 Size : Node_Id renames Args (3); 17582 17583 begin 17584 GNAT_Pragma; 17585 Gather_Associations (Names, Args); 17586 Process_Extended_Import_Export_Object_Pragma ( 17587 Arg_Internal => Internal, 17588 Arg_External => External, 17589 Arg_Size => Size); 17590 end Import_Object; 17591 17592 ---------------------- 17593 -- Import_Procedure -- 17594 ---------------------- 17595 17596 -- pragma Import_Procedure ( 17597 -- [Internal =>] LOCAL_NAME 17598 -- [, [External =>] EXTERNAL_SYMBOL] 17599 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 17600 -- [, [Mechanism =>] MECHANISM]); 17601 17602 -- EXTERNAL_SYMBOL ::= 17603 -- IDENTIFIER 17604 -- | static_string_EXPRESSION 17605 17606 -- PARAMETER_TYPES ::= 17607 -- null 17608 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 17609 17610 -- TYPE_DESIGNATOR ::= 17611 -- subtype_NAME 17612 -- | subtype_Name ' Access 17613 17614 -- MECHANISM ::= 17615 -- MECHANISM_NAME 17616 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 17617 17618 -- MECHANISM_ASSOCIATION ::= 17619 -- [formal_parameter_NAME =>] MECHANISM_NAME 17620 17621 -- MECHANISM_NAME ::= 17622 -- Value 17623 -- | Reference 17624 17625 when Pragma_Import_Procedure => Import_Procedure : declare 17626 Args : Args_List (1 .. 4); 17627 Names : constant Name_List (1 .. 4) := ( 17628 Name_Internal, 17629 Name_External, 17630 Name_Parameter_Types, 17631 Name_Mechanism); 17632 17633 Internal : Node_Id renames Args (1); 17634 External : Node_Id renames Args (2); 17635 Parameter_Types : Node_Id renames Args (3); 17636 Mechanism : Node_Id renames Args (4); 17637 17638 begin 17639 GNAT_Pragma; 17640 Gather_Associations (Names, Args); 17641 Process_Extended_Import_Export_Subprogram_Pragma ( 17642 Arg_Internal => Internal, 17643 Arg_External => External, 17644 Arg_Parameter_Types => Parameter_Types, 17645 Arg_Mechanism => Mechanism); 17646 end Import_Procedure; 17647 17648 ----------------------------- 17649 -- Import_Valued_Procedure -- 17650 ----------------------------- 17651 17652 -- pragma Import_Valued_Procedure ( 17653 -- [Internal =>] LOCAL_NAME 17654 -- [, [External =>] EXTERNAL_SYMBOL] 17655 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 17656 -- [, [Mechanism =>] MECHANISM]); 17657 17658 -- EXTERNAL_SYMBOL ::= 17659 -- IDENTIFIER 17660 -- | static_string_EXPRESSION 17661 17662 -- PARAMETER_TYPES ::= 17663 -- null 17664 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 17665 17666 -- TYPE_DESIGNATOR ::= 17667 -- subtype_NAME 17668 -- | subtype_Name ' Access 17669 17670 -- MECHANISM ::= 17671 -- MECHANISM_NAME 17672 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 17673 17674 -- MECHANISM_ASSOCIATION ::= 17675 -- [formal_parameter_NAME =>] MECHANISM_NAME 17676 17677 -- MECHANISM_NAME ::= 17678 -- Value 17679 -- | Reference 17680 17681 when Pragma_Import_Valued_Procedure => 17682 Import_Valued_Procedure : declare 17683 Args : Args_List (1 .. 4); 17684 Names : constant Name_List (1 .. 4) := ( 17685 Name_Internal, 17686 Name_External, 17687 Name_Parameter_Types, 17688 Name_Mechanism); 17689 17690 Internal : Node_Id renames Args (1); 17691 External : Node_Id renames Args (2); 17692 Parameter_Types : Node_Id renames Args (3); 17693 Mechanism : Node_Id renames Args (4); 17694 17695 begin 17696 GNAT_Pragma; 17697 Gather_Associations (Names, Args); 17698 Process_Extended_Import_Export_Subprogram_Pragma ( 17699 Arg_Internal => Internal, 17700 Arg_External => External, 17701 Arg_Parameter_Types => Parameter_Types, 17702 Arg_Mechanism => Mechanism); 17703 end Import_Valued_Procedure; 17704 17705 ----------------- 17706 -- Independent -- 17707 ----------------- 17708 17709 -- pragma Independent (LOCAL_NAME); 17710 17711 when Pragma_Independent => 17712 Process_Atomic_Independent_Shared_Volatile; 17713 17714 ---------------------------- 17715 -- Independent_Components -- 17716 ---------------------------- 17717 17718 -- pragma Independent_Components (array_or_record_LOCAL_NAME); 17719 17720 when Pragma_Independent_Components => Independent_Components : declare 17721 C : Node_Id; 17722 D : Node_Id; 17723 E_Id : Node_Id; 17724 E : Entity_Id; 17725 K : Node_Kind; 17726 17727 begin 17728 Check_Ada_83_Warning; 17729 Ada_2012_Pragma; 17730 Check_No_Identifiers; 17731 Check_Arg_Count (1); 17732 Check_Arg_Is_Local_Name (Arg1); 17733 E_Id := Get_Pragma_Arg (Arg1); 17734 17735 if Etype (E_Id) = Any_Type then 17736 return; 17737 end if; 17738 17739 E := Entity (E_Id); 17740 17741 -- A record type with a self-referential component of anonymous 17742 -- access type is given an incomplete view in order to handle the 17743 -- self reference: 17744 -- 17745 -- type Rec is record 17746 -- Self : access Rec; 17747 -- end record; 17748 -- 17749 -- becomes 17750 -- 17751 -- type Rec; 17752 -- type Ptr is access Rec; 17753 -- type Rec is record 17754 -- Self : Ptr; 17755 -- end record; 17756 -- 17757 -- Since the incomplete view is now the initial view of the type, 17758 -- the argument of the pragma will reference the incomplete view, 17759 -- but this view is illegal according to the semantics of the 17760 -- pragma. 17761 -- 17762 -- Obtain the full view of an internally-generated incomplete type 17763 -- only. This way an attempt to associate the pragma with a source 17764 -- incomplete type is still caught. 17765 17766 if Ekind (E) = E_Incomplete_Type 17767 and then not Comes_From_Source (E) 17768 and then Present (Full_View (E)) 17769 then 17770 E := Full_View (E); 17771 end if; 17772 17773 -- A pragma that applies to a Ghost entity becomes Ghost for the 17774 -- purposes of legality checks and removal of ignored Ghost code. 17775 17776 Mark_Ghost_Pragma (N, E); 17777 17778 -- Check duplicate before we chain ourselves 17779 17780 Check_Duplicate_Pragma (E); 17781 17782 -- Check appropriate entity 17783 17784 if Rep_Item_Too_Early (E, N) 17785 or else 17786 Rep_Item_Too_Late (E, N) 17787 then 17788 return; 17789 end if; 17790 17791 D := Declaration_Node (E); 17792 K := Nkind (D); 17793 17794 -- The flag is set on the base type, or on the object 17795 17796 if K = N_Full_Type_Declaration 17797 and then (Is_Array_Type (E) or else Is_Record_Type (E)) 17798 then 17799 Set_Has_Independent_Components (Base_Type (E)); 17800 Record_Independence_Check (N, Base_Type (E)); 17801 17802 -- For record type, set all components independent 17803 17804 if Is_Record_Type (E) then 17805 C := First_Component (E); 17806 while Present (C) loop 17807 Set_Is_Independent (C); 17808 Next_Component (C); 17809 end loop; 17810 end if; 17811 17812 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 17813 and then Nkind (D) = N_Object_Declaration 17814 and then Nkind (Object_Definition (D)) = 17815 N_Constrained_Array_Definition 17816 then 17817 Set_Has_Independent_Components (E); 17818 Record_Independence_Check (N, E); 17819 17820 else 17821 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 17822 end if; 17823 end Independent_Components; 17824 17825 ----------------------- 17826 -- Initial_Condition -- 17827 ----------------------- 17828 17829 -- pragma Initial_Condition (boolean_EXPRESSION); 17830 17831 -- Characteristics: 17832 17833 -- * Analysis - The annotation undergoes initial checks to verify 17834 -- the legal placement and context. Secondary checks preanalyze the 17835 -- expression in: 17836 17837 -- Analyze_Initial_Condition_In_Decl_Part 17838 17839 -- * Expansion - The annotation is expanded during the expansion of 17840 -- the package body whose declaration is subject to the annotation 17841 -- as done in: 17842 17843 -- Expand_Pragma_Initial_Condition 17844 17845 -- * Template - The annotation utilizes the generic template of the 17846 -- related package declaration. 17847 17848 -- * Globals - Capture of global references must occur after full 17849 -- analysis. 17850 17851 -- * Instance - The annotation is instantiated automatically when 17852 -- the related generic package is instantiated. 17853 17854 when Pragma_Initial_Condition => Initial_Condition : declare 17855 Pack_Decl : Node_Id; 17856 Pack_Id : Entity_Id; 17857 17858 begin 17859 GNAT_Pragma; 17860 Check_No_Identifiers; 17861 Check_Arg_Count (1); 17862 17863 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 17864 17865 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 17866 N_Package_Declaration) 17867 then 17868 Pragma_Misplaced; 17869 return; 17870 end if; 17871 17872 Pack_Id := Defining_Entity (Pack_Decl); 17873 17874 -- A pragma that applies to a Ghost entity becomes Ghost for the 17875 -- purposes of legality checks and removal of ignored Ghost code. 17876 17877 Mark_Ghost_Pragma (N, Pack_Id); 17878 17879 -- Chain the pragma on the contract for further processing by 17880 -- Analyze_Initial_Condition_In_Decl_Part. 17881 17882 Add_Contract_Item (N, Pack_Id); 17883 17884 -- The legality checks of pragmas Abstract_State, Initializes, and 17885 -- Initial_Condition are affected by the SPARK mode in effect. In 17886 -- addition, these three pragmas are subject to an inherent order: 17887 17888 -- 1) Abstract_State 17889 -- 2) Initializes 17890 -- 3) Initial_Condition 17891 17892 -- Analyze all these pragmas in the order outlined above 17893 17894 Analyze_If_Present (Pragma_SPARK_Mode); 17895 Analyze_If_Present (Pragma_Abstract_State); 17896 Analyze_If_Present (Pragma_Initializes); 17897 end Initial_Condition; 17898 17899 ------------------------ 17900 -- Initialize_Scalars -- 17901 ------------------------ 17902 17903 -- pragma Initialize_Scalars 17904 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ]; 17905 17906 -- TYPE_VALUE_PAIR ::= 17907 -- SCALAR_TYPE => static_EXPRESSION 17908 17909 -- SCALAR_TYPE := 17910 -- Short_Float 17911 -- | Float 17912 -- | Long_Float 17913 -- | Long_Long_Flat 17914 -- | Signed_8 17915 -- | Signed_16 17916 -- | Signed_32 17917 -- | Signed_64 17918 -- | Unsigned_8 17919 -- | Unsigned_16 17920 -- | Unsigned_32 17921 -- | Unsigned_64 17922 17923 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare 17924 Seen : array (Scalar_Id) of Node_Id := (others => Empty); 17925 -- This collection holds the individual pairs which specify the 17926 -- invalid values of their respective scalar types. 17927 17928 procedure Analyze_Float_Value 17929 (Scal_Typ : Float_Scalar_Id; 17930 Val_Expr : Node_Id); 17931 -- Analyze a type value pair associated with float type Scal_Typ 17932 -- and expression Val_Expr. 17933 17934 procedure Analyze_Integer_Value 17935 (Scal_Typ : Integer_Scalar_Id; 17936 Val_Expr : Node_Id); 17937 -- Analyze a type value pair associated with integer type Scal_Typ 17938 -- and expression Val_Expr. 17939 17940 procedure Analyze_Type_Value_Pair (Pair : Node_Id); 17941 -- Analyze type value pair Pair 17942 17943 ------------------------- 17944 -- Analyze_Float_Value -- 17945 ------------------------- 17946 17947 procedure Analyze_Float_Value 17948 (Scal_Typ : Float_Scalar_Id; 17949 Val_Expr : Node_Id) 17950 is 17951 begin 17952 Analyze_And_Resolve (Val_Expr, Any_Real); 17953 17954 if Is_OK_Static_Expression (Val_Expr) then 17955 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr)); 17956 17957 else 17958 Error_Msg_Name_1 := Scal_Typ; 17959 Error_Msg_N ("value for type % must be static", Val_Expr); 17960 end if; 17961 end Analyze_Float_Value; 17962 17963 --------------------------- 17964 -- Analyze_Integer_Value -- 17965 --------------------------- 17966 17967 procedure Analyze_Integer_Value 17968 (Scal_Typ : Integer_Scalar_Id; 17969 Val_Expr : Node_Id) 17970 is 17971 begin 17972 Analyze_And_Resolve (Val_Expr, Any_Integer); 17973 17974 if Is_OK_Static_Expression (Val_Expr) then 17975 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr)); 17976 17977 else 17978 Error_Msg_Name_1 := Scal_Typ; 17979 Error_Msg_N ("value for type % must be static", Val_Expr); 17980 end if; 17981 end Analyze_Integer_Value; 17982 17983 ----------------------------- 17984 -- Analyze_Type_Value_Pair -- 17985 ----------------------------- 17986 17987 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is 17988 Scal_Typ : constant Name_Id := Chars (Pair); 17989 Val_Expr : constant Node_Id := Expression (Pair); 17990 Prev_Pair : Node_Id; 17991 17992 begin 17993 if Scal_Typ in Scalar_Id then 17994 Prev_Pair := Seen (Scal_Typ); 17995 17996 -- Prevent multiple attempts to set a value for a scalar 17997 -- type. 17998 17999 if Present (Prev_Pair) then 18000 Error_Msg_Name_1 := Scal_Typ; 18001 Error_Msg_N 18002 ("cannot specify multiple invalid values for type %", 18003 Pair); 18004 18005 Error_Msg_Sloc := Sloc (Prev_Pair); 18006 Error_Msg_N ("previous value set #", Pair); 18007 18008 -- Ignore the effects of the pair, but do not halt the 18009 -- analysis of the pragma altogether. 18010 18011 return; 18012 18013 -- Otherwise capture the first pair for this scalar type 18014 18015 else 18016 Seen (Scal_Typ) := Pair; 18017 end if; 18018 18019 if Scal_Typ in Float_Scalar_Id then 18020 Analyze_Float_Value (Scal_Typ, Val_Expr); 18021 18022 else pragma Assert (Scal_Typ in Integer_Scalar_Id); 18023 Analyze_Integer_Value (Scal_Typ, Val_Expr); 18024 end if; 18025 18026 -- Otherwise the scalar family is illegal 18027 18028 else 18029 Error_Msg_Name_1 := Pname; 18030 Error_Msg_N 18031 ("argument of pragma % must denote valid scalar family", 18032 Pair); 18033 end if; 18034 end Analyze_Type_Value_Pair; 18035 18036 -- Local variables 18037 18038 Pairs : constant List_Id := Pragma_Argument_Associations (N); 18039 Pair : Node_Id; 18040 18041 -- Start of processing for Do_Initialize_Scalars 18042 18043 begin 18044 GNAT_Pragma; 18045 Check_Valid_Configuration_Pragma; 18046 Check_Restriction (No_Initialize_Scalars, N); 18047 18048 -- Ignore the effects of the pragma when No_Initialize_Scalars is 18049 -- in effect. 18050 18051 if Restriction_Active (No_Initialize_Scalars) then 18052 null; 18053 18054 -- Initialize_Scalars creates false positives in CodePeer, and 18055 -- incorrect negative results in GNATprove mode, so ignore this 18056 -- pragma in these modes. 18057 18058 elsif CodePeer_Mode or GNATprove_Mode then 18059 null; 18060 18061 -- Otherwise analyze the pragma 18062 18063 else 18064 if Present (Pairs) then 18065 18066 -- Install Standard in order to provide access to primitive 18067 -- types in case the expressions contain attributes such as 18068 -- Integer'Last. 18069 18070 Push_Scope (Standard_Standard); 18071 18072 Pair := First (Pairs); 18073 while Present (Pair) loop 18074 Analyze_Type_Value_Pair (Pair); 18075 Next (Pair); 18076 end loop; 18077 18078 -- Remove Standard 18079 18080 Pop_Scope; 18081 end if; 18082 18083 Init_Or_Norm_Scalars := True; 18084 Initialize_Scalars := True; 18085 end if; 18086 end Do_Initialize_Scalars; 18087 18088 ----------------- 18089 -- Initializes -- 18090 ----------------- 18091 18092 -- pragma Initializes (INITIALIZATION_LIST); 18093 18094 -- INITIALIZATION_LIST ::= 18095 -- null 18096 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM}) 18097 18098 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST] 18099 18100 -- INPUT_LIST ::= 18101 -- null 18102 -- | INPUT 18103 -- | (INPUT {, INPUT}) 18104 18105 -- INPUT ::= name 18106 18107 -- Characteristics: 18108 18109 -- * Analysis - The annotation undergoes initial checks to verify 18110 -- the legal placement and context. Secondary checks preanalyze the 18111 -- expression in: 18112 18113 -- Analyze_Initializes_In_Decl_Part 18114 18115 -- * Expansion - None. 18116 18117 -- * Template - The annotation utilizes the generic template of the 18118 -- related package declaration. 18119 18120 -- * Globals - Capture of global references must occur after full 18121 -- analysis. 18122 18123 -- * Instance - The annotation is instantiated automatically when 18124 -- the related generic package is instantiated. 18125 18126 when Pragma_Initializes => Initializes : declare 18127 Pack_Decl : Node_Id; 18128 Pack_Id : Entity_Id; 18129 18130 begin 18131 GNAT_Pragma; 18132 Check_No_Identifiers; 18133 Check_Arg_Count (1); 18134 18135 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 18136 18137 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 18138 N_Package_Declaration) 18139 then 18140 Pragma_Misplaced; 18141 return; 18142 end if; 18143 18144 Pack_Id := Defining_Entity (Pack_Decl); 18145 18146 -- A pragma that applies to a Ghost entity becomes Ghost for the 18147 -- purposes of legality checks and removal of ignored Ghost code. 18148 18149 Mark_Ghost_Pragma (N, Pack_Id); 18150 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id)); 18151 18152 -- Chain the pragma on the contract for further processing by 18153 -- Analyze_Initializes_In_Decl_Part. 18154 18155 Add_Contract_Item (N, Pack_Id); 18156 18157 -- The legality checks of pragmas Abstract_State, Initializes, and 18158 -- Initial_Condition are affected by the SPARK mode in effect. In 18159 -- addition, these three pragmas are subject to an inherent order: 18160 18161 -- 1) Abstract_State 18162 -- 2) Initializes 18163 -- 3) Initial_Condition 18164 18165 -- Analyze all these pragmas in the order outlined above 18166 18167 Analyze_If_Present (Pragma_SPARK_Mode); 18168 Analyze_If_Present (Pragma_Abstract_State); 18169 Analyze_If_Present (Pragma_Initial_Condition); 18170 end Initializes; 18171 18172 ------------ 18173 -- Inline -- 18174 ------------ 18175 18176 -- pragma Inline ( NAME {, NAME} ); 18177 18178 when Pragma_Inline => 18179 18180 -- Pragma always active unless in GNATprove mode. It is disabled 18181 -- in GNATprove mode because frontend inlining is applied 18182 -- independently of pragmas Inline and Inline_Always for 18183 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode 18184 -- in inline.ads. 18185 18186 if not GNATprove_Mode then 18187 18188 -- Inline status is Enabled if option -gnatn is specified. 18189 -- However this status determines only the value of the 18190 -- Is_Inlined flag on the subprogram and does not prevent 18191 -- the pragma itself from being recorded for later use, 18192 -- in particular for a later modification of Is_Inlined 18193 -- independently of the -gnatn option. 18194 18195 -- In other words, if -gnatn is specified for a unit, then 18196 -- all Inline pragmas processed for the compilation of this 18197 -- unit, including those in the spec of other units, are 18198 -- activated, so subprograms will be inlined across units. 18199 18200 -- If -gnatn is not specified, no Inline pragma is activated 18201 -- here, which means that subprograms will not be inlined 18202 -- across units. The Is_Inlined flag will nevertheless be 18203 -- set later when bodies are analyzed, so subprograms will 18204 -- be inlined within the unit. 18205 18206 if Inline_Active then 18207 Process_Inline (Enabled); 18208 else 18209 Process_Inline (Disabled); 18210 end if; 18211 end if; 18212 18213 ------------------- 18214 -- Inline_Always -- 18215 ------------------- 18216 18217 -- pragma Inline_Always ( NAME {, NAME} ); 18218 18219 when Pragma_Inline_Always => 18220 GNAT_Pragma; 18221 18222 -- Pragma always active unless in CodePeer mode or GNATprove 18223 -- mode. It is disabled in CodePeer mode because inlining is 18224 -- not helpful, and enabling it caused walk order issues. It 18225 -- is disabled in GNATprove mode because frontend inlining is 18226 -- applied independently of pragmas Inline and Inline_Always for 18227 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in 18228 -- inline.ads. 18229 18230 if not CodePeer_Mode and not GNATprove_Mode then 18231 Process_Inline (Enabled); 18232 end if; 18233 18234 -------------------- 18235 -- Inline_Generic -- 18236 -------------------- 18237 18238 -- pragma Inline_Generic (NAME {, NAME}); 18239 18240 when Pragma_Inline_Generic => 18241 GNAT_Pragma; 18242 Process_Generic_List; 18243 18244 ---------------------- 18245 -- Inspection_Point -- 18246 ---------------------- 18247 18248 -- pragma Inspection_Point [(object_NAME {, object_NAME})]; 18249 18250 when Pragma_Inspection_Point => Inspection_Point : declare 18251 Arg : Node_Id; 18252 Exp : Node_Id; 18253 18254 begin 18255 ip; 18256 18257 if Arg_Count > 0 then 18258 Arg := Arg1; 18259 loop 18260 Exp := Get_Pragma_Arg (Arg); 18261 Analyze (Exp); 18262 18263 if not Is_Entity_Name (Exp) 18264 or else not Is_Object (Entity (Exp)) 18265 then 18266 Error_Pragma_Arg ("object name required", Arg); 18267 end if; 18268 18269 Next (Arg); 18270 exit when No (Arg); 18271 end loop; 18272 end if; 18273 end Inspection_Point; 18274 18275 --------------- 18276 -- Interface -- 18277 --------------- 18278 18279 -- pragma Interface ( 18280 -- [ Convention =>] convention_IDENTIFIER, 18281 -- [ Entity =>] LOCAL_NAME 18282 -- [, [External_Name =>] static_string_EXPRESSION ] 18283 -- [, [Link_Name =>] static_string_EXPRESSION ]); 18284 18285 when Pragma_Interface => 18286 GNAT_Pragma; 18287 Check_Arg_Order 18288 ((Name_Convention, 18289 Name_Entity, 18290 Name_External_Name, 18291 Name_Link_Name)); 18292 Check_At_Least_N_Arguments (2); 18293 Check_At_Most_N_Arguments (4); 18294 Process_Import_Or_Interface; 18295 18296 -- In Ada 2005, the permission to use Interface (a reserved word) 18297 -- as a pragma name is considered an obsolescent feature, and this 18298 -- pragma was already obsolescent in Ada 95. 18299 18300 if Ada_Version >= Ada_95 then 18301 Check_Restriction 18302 (No_Obsolescent_Features, Pragma_Identifier (N)); 18303 18304 if Warn_On_Obsolescent_Feature then 18305 Error_Msg_N 18306 ("pragma Interface is an obsolescent feature?j?", N); 18307 Error_Msg_N 18308 ("|use pragma Import instead?j?", N); 18309 end if; 18310 end if; 18311 18312 -------------------- 18313 -- Interface_Name -- 18314 -------------------- 18315 18316 -- pragma Interface_Name ( 18317 -- [ Entity =>] LOCAL_NAME 18318 -- [,[External_Name =>] static_string_EXPRESSION ] 18319 -- [,[Link_Name =>] static_string_EXPRESSION ]); 18320 18321 when Pragma_Interface_Name => Interface_Name : declare 18322 Id : Node_Id; 18323 Def_Id : Entity_Id; 18324 Hom_Id : Entity_Id; 18325 Found : Boolean; 18326 18327 begin 18328 GNAT_Pragma; 18329 Check_Arg_Order 18330 ((Name_Entity, Name_External_Name, Name_Link_Name)); 18331 Check_At_Least_N_Arguments (2); 18332 Check_At_Most_N_Arguments (3); 18333 Id := Get_Pragma_Arg (Arg1); 18334 Analyze (Id); 18335 18336 -- This is obsolete from Ada 95 on, but it is an implementation 18337 -- defined pragma, so we do not consider that it violates the 18338 -- restriction (No_Obsolescent_Features). 18339 18340 if Ada_Version >= Ada_95 then 18341 if Warn_On_Obsolescent_Feature then 18342 Error_Msg_N 18343 ("pragma Interface_Name is an obsolescent feature?j?", N); 18344 Error_Msg_N 18345 ("|use pragma Import instead?j?", N); 18346 end if; 18347 end if; 18348 18349 if not Is_Entity_Name (Id) then 18350 Error_Pragma_Arg 18351 ("first argument for pragma% must be entity name", Arg1); 18352 elsif Etype (Id) = Any_Type then 18353 return; 18354 else 18355 Def_Id := Entity (Id); 18356 end if; 18357 18358 -- Special DEC-compatible processing for the object case, forces 18359 -- object to be imported. 18360 18361 if Ekind (Def_Id) = E_Variable then 18362 Kill_Size_Check_Code (Def_Id); 18363 Note_Possible_Modification (Id, Sure => False); 18364 18365 -- Initialization is not allowed for imported variable 18366 18367 if Present (Expression (Parent (Def_Id))) 18368 and then Comes_From_Source (Expression (Parent (Def_Id))) 18369 then 18370 Error_Msg_Sloc := Sloc (Def_Id); 18371 Error_Pragma_Arg 18372 ("no initialization allowed for declaration of& #", 18373 Arg2); 18374 18375 else 18376 -- For compatibility, support VADS usage of providing both 18377 -- pragmas Interface and Interface_Name to obtain the effect 18378 -- of a single Import pragma. 18379 18380 if Is_Imported (Def_Id) 18381 and then Present (First_Rep_Item (Def_Id)) 18382 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma 18383 and then Pragma_Name (First_Rep_Item (Def_Id)) = 18384 Name_Interface 18385 then 18386 null; 18387 else 18388 Set_Imported (Def_Id); 18389 end if; 18390 18391 Set_Is_Public (Def_Id); 18392 Process_Interface_Name (Def_Id, Arg2, Arg3, N); 18393 end if; 18394 18395 -- Otherwise must be subprogram 18396 18397 elsif not Is_Subprogram (Def_Id) then 18398 Error_Pragma_Arg 18399 ("argument of pragma% is not subprogram", Arg1); 18400 18401 else 18402 Check_At_Most_N_Arguments (3); 18403 Hom_Id := Def_Id; 18404 Found := False; 18405 18406 -- Loop through homonyms 18407 18408 loop 18409 Def_Id := Get_Base_Subprogram (Hom_Id); 18410 18411 if Is_Imported (Def_Id) then 18412 Process_Interface_Name (Def_Id, Arg2, Arg3, N); 18413 Found := True; 18414 end if; 18415 18416 exit when From_Aspect_Specification (N); 18417 Hom_Id := Homonym (Hom_Id); 18418 18419 exit when No (Hom_Id) 18420 or else Scope (Hom_Id) /= Current_Scope; 18421 end loop; 18422 18423 if not Found then 18424 Error_Pragma_Arg 18425 ("argument of pragma% is not imported subprogram", 18426 Arg1); 18427 end if; 18428 end if; 18429 end Interface_Name; 18430 18431 ----------------------- 18432 -- Interrupt_Handler -- 18433 ----------------------- 18434 18435 -- pragma Interrupt_Handler (handler_NAME); 18436 18437 when Pragma_Interrupt_Handler => 18438 Check_Ada_83_Warning; 18439 Check_Arg_Count (1); 18440 Check_No_Identifiers; 18441 18442 if No_Run_Time_Mode then 18443 Error_Msg_CRT ("Interrupt_Handler pragma", N); 18444 else 18445 Check_Interrupt_Or_Attach_Handler; 18446 Process_Interrupt_Or_Attach_Handler; 18447 end if; 18448 18449 ------------------------ 18450 -- Interrupt_Priority -- 18451 ------------------------ 18452 18453 -- pragma Interrupt_Priority [(EXPRESSION)]; 18454 18455 when Pragma_Interrupt_Priority => Interrupt_Priority : declare 18456 P : constant Node_Id := Parent (N); 18457 Arg : Node_Id; 18458 Ent : Entity_Id; 18459 18460 begin 18461 Check_Ada_83_Warning; 18462 18463 if Arg_Count /= 0 then 18464 Arg := Get_Pragma_Arg (Arg1); 18465 Check_Arg_Count (1); 18466 Check_No_Identifiers; 18467 18468 -- The expression must be analyzed in the special manner 18469 -- described in "Handling of Default and Per-Object 18470 -- Expressions" in sem.ads. 18471 18472 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); 18473 end if; 18474 18475 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then 18476 Pragma_Misplaced; 18477 return; 18478 18479 else 18480 Ent := Defining_Identifier (Parent (P)); 18481 18482 -- Check duplicate pragma before we chain the pragma in the Rep 18483 -- Item chain of Ent. 18484 18485 Check_Duplicate_Pragma (Ent); 18486 Record_Rep_Item (Ent, N); 18487 18488 -- Check the No_Task_At_Interrupt_Priority restriction 18489 18490 if Nkind (P) = N_Task_Definition then 18491 Check_Restriction (No_Task_At_Interrupt_Priority, N); 18492 end if; 18493 end if; 18494 end Interrupt_Priority; 18495 18496 --------------------- 18497 -- Interrupt_State -- 18498 --------------------- 18499 18500 -- pragma Interrupt_State ( 18501 -- [Name =>] INTERRUPT_ID, 18502 -- [State =>] INTERRUPT_STATE); 18503 18504 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION 18505 -- INTERRUPT_STATE => System | Runtime | User 18506 18507 -- Note: if the interrupt id is given as an identifier, then it must 18508 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is 18509 -- given as a static integer expression which must be in the range of 18510 -- Ada.Interrupts.Interrupt_ID. 18511 18512 when Pragma_Interrupt_State => Interrupt_State : declare 18513 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); 18514 -- This is the entity Ada.Interrupts.Interrupt_ID; 18515 18516 State_Type : Character; 18517 -- Set to 's'/'r'/'u' for System/Runtime/User 18518 18519 IST_Num : Pos; 18520 -- Index to entry in Interrupt_States table 18521 18522 Int_Val : Uint; 18523 -- Value of interrupt 18524 18525 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); 18526 -- The first argument to the pragma 18527 18528 Int_Ent : Entity_Id; 18529 -- Interrupt entity in Ada.Interrupts.Names 18530 18531 begin 18532 GNAT_Pragma; 18533 Check_Arg_Order ((Name_Name, Name_State)); 18534 Check_Arg_Count (2); 18535 18536 Check_Optional_Identifier (Arg1, Name_Name); 18537 Check_Optional_Identifier (Arg2, Name_State); 18538 Check_Arg_Is_Identifier (Arg2); 18539 18540 -- First argument is identifier 18541 18542 if Nkind (Arg1X) = N_Identifier then 18543 18544 -- Search list of names in Ada.Interrupts.Names 18545 18546 Int_Ent := First_Entity (RTE (RE_Names)); 18547 loop 18548 if No (Int_Ent) then 18549 Error_Pragma_Arg ("invalid interrupt name", Arg1); 18550 18551 elsif Chars (Int_Ent) = Chars (Arg1X) then 18552 Int_Val := Expr_Value (Constant_Value (Int_Ent)); 18553 exit; 18554 end if; 18555 18556 Next_Entity (Int_Ent); 18557 end loop; 18558 18559 -- First argument is not an identifier, so it must be a static 18560 -- expression of type Ada.Interrupts.Interrupt_ID. 18561 18562 else 18563 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); 18564 Int_Val := Expr_Value (Arg1X); 18565 18566 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) 18567 or else 18568 Int_Val > Expr_Value (Type_High_Bound (Int_Id)) 18569 then 18570 Error_Pragma_Arg 18571 ("value not in range of type " 18572 & """Ada.Interrupts.Interrupt_'I'D""", Arg1); 18573 end if; 18574 end if; 18575 18576 -- Check OK state 18577 18578 case Chars (Get_Pragma_Arg (Arg2)) is 18579 when Name_Runtime => State_Type := 'r'; 18580 when Name_System => State_Type := 's'; 18581 when Name_User => State_Type := 'u'; 18582 18583 when others => 18584 Error_Pragma_Arg ("invalid interrupt state", Arg2); 18585 end case; 18586 18587 -- Check if entry is already stored 18588 18589 IST_Num := Interrupt_States.First; 18590 loop 18591 -- If entry not found, add it 18592 18593 if IST_Num > Interrupt_States.Last then 18594 Interrupt_States.Append 18595 ((Interrupt_Number => UI_To_Int (Int_Val), 18596 Interrupt_State => State_Type, 18597 Pragma_Loc => Loc)); 18598 exit; 18599 18600 -- Case of entry for the same entry 18601 18602 elsif Int_Val = Interrupt_States.Table (IST_Num). 18603 Interrupt_Number 18604 then 18605 -- If state matches, done, no need to make redundant entry 18606 18607 exit when 18608 State_Type = Interrupt_States.Table (IST_Num). 18609 Interrupt_State; 18610 18611 -- Otherwise if state does not match, error 18612 18613 Error_Msg_Sloc := 18614 Interrupt_States.Table (IST_Num).Pragma_Loc; 18615 Error_Pragma_Arg 18616 ("state conflicts with that given #", Arg2); 18617 exit; 18618 end if; 18619 18620 IST_Num := IST_Num + 1; 18621 end loop; 18622 end Interrupt_State; 18623 18624 --------------- 18625 -- Invariant -- 18626 --------------- 18627 18628 -- pragma Invariant 18629 -- ([Entity =>] type_LOCAL_NAME, 18630 -- [Check =>] EXPRESSION 18631 -- [,[Message =>] String_Expression]); 18632 18633 when Pragma_Invariant => Invariant : declare 18634 Discard : Boolean; 18635 Typ : Entity_Id; 18636 Typ_Arg : Node_Id; 18637 18638 begin 18639 GNAT_Pragma; 18640 Check_At_Least_N_Arguments (2); 18641 Check_At_Most_N_Arguments (3); 18642 Check_Optional_Identifier (Arg1, Name_Entity); 18643 Check_Optional_Identifier (Arg2, Name_Check); 18644 18645 if Arg_Count = 3 then 18646 Check_Optional_Identifier (Arg3, Name_Message); 18647 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 18648 end if; 18649 18650 Check_Arg_Is_Local_Name (Arg1); 18651 18652 Typ_Arg := Get_Pragma_Arg (Arg1); 18653 Find_Type (Typ_Arg); 18654 Typ := Entity (Typ_Arg); 18655 18656 -- Nothing to do of the related type is erroneous in some way 18657 18658 if Typ = Any_Type then 18659 return; 18660 18661 -- AI12-0041: Invariants are allowed in interface types 18662 18663 elsif Is_Interface (Typ) then 18664 null; 18665 18666 -- An invariant must apply to a private type, or appear in the 18667 -- private part of a package spec and apply to a completion. 18668 -- a class-wide invariant can only appear on a private declaration 18669 -- or private extension, not a completion. 18670 18671 -- A [class-wide] invariant may be associated a [limited] private 18672 -- type or a private extension. 18673 18674 elsif Ekind_In (Typ, E_Limited_Private_Type, 18675 E_Private_Type, 18676 E_Record_Type_With_Private) 18677 then 18678 null; 18679 18680 -- A non-class-wide invariant may be associated with the full view 18681 -- of a [limited] private type or a private extension. 18682 18683 elsif Has_Private_Declaration (Typ) 18684 and then not Class_Present (N) 18685 then 18686 null; 18687 18688 -- A class-wide invariant may appear on the partial view only 18689 18690 elsif Class_Present (N) then 18691 Error_Pragma_Arg 18692 ("pragma % only allowed for private type", Arg1); 18693 return; 18694 18695 -- A regular invariant may appear on both views 18696 18697 else 18698 Error_Pragma_Arg 18699 ("pragma % only allowed for private type or corresponding " 18700 & "full view", Arg1); 18701 return; 18702 end if; 18703 18704 -- An invariant associated with an abstract type (this includes 18705 -- interfaces) must be class-wide. 18706 18707 if Is_Abstract_Type (Typ) and then not Class_Present (N) then 18708 Error_Pragma_Arg 18709 ("pragma % not allowed for abstract type", Arg1); 18710 return; 18711 end if; 18712 18713 -- A pragma that applies to a Ghost entity becomes Ghost for the 18714 -- purposes of legality checks and removal of ignored Ghost code. 18715 18716 Mark_Ghost_Pragma (N, Typ); 18717 18718 -- The pragma defines a type-specific invariant, the type is said 18719 -- to have invariants of its "own". 18720 18721 Set_Has_Own_Invariants (Typ); 18722 18723 -- If the invariant is class-wide, then it can be inherited by 18724 -- derived or interface implementing types. The type is said to 18725 -- have "inheritable" invariants. 18726 18727 if Class_Present (N) then 18728 Set_Has_Inheritable_Invariants (Typ); 18729 end if; 18730 18731 -- Chain the pragma on to the rep item chain, for processing when 18732 -- the type is frozen. 18733 18734 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 18735 18736 -- Create the declaration of the invariant procedure that will 18737 -- verify the invariant at run time. Interfaces are treated as the 18738 -- partial view of a private type in order to achieve uniformity 18739 -- with the general case. As a result, an interface receives only 18740 -- a "partial" invariant procedure, which is never called. 18741 18742 Build_Invariant_Procedure_Declaration 18743 (Typ => Typ, 18744 Partial_Invariant => Is_Interface (Typ)); 18745 end Invariant; 18746 18747 ---------------- 18748 -- Keep_Names -- 18749 ---------------- 18750 18751 -- pragma Keep_Names ([On => ] LOCAL_NAME); 18752 18753 when Pragma_Keep_Names => Keep_Names : declare 18754 Arg : Node_Id; 18755 18756 begin 18757 GNAT_Pragma; 18758 Check_Arg_Count (1); 18759 Check_Optional_Identifier (Arg1, Name_On); 18760 Check_Arg_Is_Local_Name (Arg1); 18761 18762 Arg := Get_Pragma_Arg (Arg1); 18763 Analyze (Arg); 18764 18765 if Etype (Arg) = Any_Type then 18766 return; 18767 end if; 18768 18769 if not Is_Entity_Name (Arg) 18770 or else Ekind (Entity (Arg)) /= E_Enumeration_Type 18771 then 18772 Error_Pragma_Arg 18773 ("pragma% requires a local enumeration type", Arg1); 18774 end if; 18775 18776 Set_Discard_Names (Entity (Arg), False); 18777 end Keep_Names; 18778 18779 ------------- 18780 -- License -- 18781 ------------- 18782 18783 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL); 18784 18785 when Pragma_License => 18786 GNAT_Pragma; 18787 18788 -- Do not analyze pragma any further in CodePeer mode, to avoid 18789 -- extraneous errors in this implementation-dependent pragma, 18790 -- which has a different profile on other compilers. 18791 18792 if CodePeer_Mode then 18793 return; 18794 end if; 18795 18796 Check_Arg_Count (1); 18797 Check_No_Identifiers; 18798 Check_Valid_Configuration_Pragma; 18799 Check_Arg_Is_Identifier (Arg1); 18800 18801 declare 18802 Sind : constant Source_File_Index := 18803 Source_Index (Current_Sem_Unit); 18804 18805 begin 18806 case Chars (Get_Pragma_Arg (Arg1)) is 18807 when Name_GPL => 18808 Set_License (Sind, GPL); 18809 18810 when Name_Modified_GPL => 18811 Set_License (Sind, Modified_GPL); 18812 18813 when Name_Restricted => 18814 Set_License (Sind, Restricted); 18815 18816 when Name_Unrestricted => 18817 Set_License (Sind, Unrestricted); 18818 18819 when others => 18820 Error_Pragma_Arg ("invalid license name", Arg1); 18821 end case; 18822 end; 18823 18824 --------------- 18825 -- Link_With -- 18826 --------------- 18827 18828 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION}); 18829 18830 when Pragma_Link_With => Link_With : declare 18831 Arg : Node_Id; 18832 18833 begin 18834 GNAT_Pragma; 18835 18836 if Operating_Mode = Generate_Code 18837 and then In_Extended_Main_Source_Unit (N) 18838 then 18839 Check_At_Least_N_Arguments (1); 18840 Check_No_Identifiers; 18841 Check_Is_In_Decl_Part_Or_Package_Spec; 18842 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 18843 Start_String; 18844 18845 Arg := Arg1; 18846 while Present (Arg) loop 18847 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); 18848 18849 -- Store argument, converting sequences of spaces to a 18850 -- single null character (this is one of the differences 18851 -- in processing between Link_With and Linker_Options). 18852 18853 Arg_Store : declare 18854 C : constant Char_Code := Get_Char_Code (' '); 18855 S : constant String_Id := 18856 Strval (Expr_Value_S (Get_Pragma_Arg (Arg))); 18857 L : constant Nat := String_Length (S); 18858 F : Nat := 1; 18859 18860 procedure Skip_Spaces; 18861 -- Advance F past any spaces 18862 18863 ----------------- 18864 -- Skip_Spaces -- 18865 ----------------- 18866 18867 procedure Skip_Spaces is 18868 begin 18869 while F <= L and then Get_String_Char (S, F) = C loop 18870 F := F + 1; 18871 end loop; 18872 end Skip_Spaces; 18873 18874 -- Start of processing for Arg_Store 18875 18876 begin 18877 Skip_Spaces; -- skip leading spaces 18878 18879 -- Loop through characters, changing any embedded 18880 -- sequence of spaces to a single null character (this 18881 -- is how Link_With/Linker_Options differ) 18882 18883 while F <= L loop 18884 if Get_String_Char (S, F) = C then 18885 Skip_Spaces; 18886 exit when F > L; 18887 Store_String_Char (ASCII.NUL); 18888 18889 else 18890 Store_String_Char (Get_String_Char (S, F)); 18891 F := F + 1; 18892 end if; 18893 end loop; 18894 end Arg_Store; 18895 18896 Arg := Next (Arg); 18897 18898 if Present (Arg) then 18899 Store_String_Char (ASCII.NUL); 18900 end if; 18901 end loop; 18902 18903 Store_Linker_Option_String (End_String); 18904 end if; 18905 end Link_With; 18906 18907 ------------------ 18908 -- Linker_Alias -- 18909 ------------------ 18910 18911 -- pragma Linker_Alias ( 18912 -- [Entity =>] LOCAL_NAME 18913 -- [Target =>] static_string_EXPRESSION); 18914 18915 when Pragma_Linker_Alias => 18916 GNAT_Pragma; 18917 Check_Arg_Order ((Name_Entity, Name_Target)); 18918 Check_Arg_Count (2); 18919 Check_Optional_Identifier (Arg1, Name_Entity); 18920 Check_Optional_Identifier (Arg2, Name_Target); 18921 Check_Arg_Is_Library_Level_Local_Name (Arg1); 18922 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 18923 18924 -- The only processing required is to link this item on to the 18925 -- list of rep items for the given entity. This is accomplished 18926 -- by the call to Rep_Item_Too_Late (when no error is detected 18927 -- and False is returned). 18928 18929 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then 18930 return; 18931 else 18932 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 18933 end if; 18934 18935 ------------------------ 18936 -- Linker_Constructor -- 18937 ------------------------ 18938 18939 -- pragma Linker_Constructor (procedure_LOCAL_NAME); 18940 18941 -- Code is shared with Linker_Destructor 18942 18943 ----------------------- 18944 -- Linker_Destructor -- 18945 ----------------------- 18946 18947 -- pragma Linker_Destructor (procedure_LOCAL_NAME); 18948 18949 when Pragma_Linker_Constructor 18950 | Pragma_Linker_Destructor 18951 => 18952 Linker_Constructor : declare 18953 Arg1_X : Node_Id; 18954 Proc : Entity_Id; 18955 18956 begin 18957 GNAT_Pragma; 18958 Check_Arg_Count (1); 18959 Check_No_Identifiers; 18960 Check_Arg_Is_Local_Name (Arg1); 18961 Arg1_X := Get_Pragma_Arg (Arg1); 18962 Analyze (Arg1_X); 18963 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 18964 18965 if not Is_Library_Level_Entity (Proc) then 18966 Error_Pragma_Arg 18967 ("argument for pragma% must be library level entity", Arg1); 18968 end if; 18969 18970 -- The only processing required is to link this item on to the 18971 -- list of rep items for the given entity. This is accomplished 18972 -- by the call to Rep_Item_Too_Late (when no error is detected 18973 -- and False is returned). 18974 18975 if Rep_Item_Too_Late (Proc, N) then 18976 return; 18977 else 18978 Set_Has_Gigi_Rep_Item (Proc); 18979 end if; 18980 end Linker_Constructor; 18981 18982 -------------------- 18983 -- Linker_Options -- 18984 -------------------- 18985 18986 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); 18987 18988 when Pragma_Linker_Options => Linker_Options : declare 18989 Arg : Node_Id; 18990 18991 begin 18992 Check_Ada_83_Warning; 18993 Check_No_Identifiers; 18994 Check_Arg_Count (1); 18995 Check_Is_In_Decl_Part_Or_Package_Spec; 18996 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 18997 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); 18998 18999 Arg := Arg2; 19000 while Present (Arg) loop 19001 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); 19002 Store_String_Char (ASCII.NUL); 19003 Store_String_Chars 19004 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); 19005 Arg := Next (Arg); 19006 end loop; 19007 19008 if Operating_Mode = Generate_Code 19009 and then In_Extended_Main_Source_Unit (N) 19010 then 19011 Store_Linker_Option_String (End_String); 19012 end if; 19013 end Linker_Options; 19014 19015 -------------------- 19016 -- Linker_Section -- 19017 -------------------- 19018 19019 -- pragma Linker_Section ( 19020 -- [Entity =>] LOCAL_NAME 19021 -- [Section =>] static_string_EXPRESSION); 19022 19023 when Pragma_Linker_Section => Linker_Section : declare 19024 Arg : Node_Id; 19025 Ent : Entity_Id; 19026 LPE : Node_Id; 19027 19028 Ghost_Error_Posted : Boolean := False; 19029 -- Flag set when an error concerning the illegal mix of Ghost and 19030 -- non-Ghost subprograms is emitted. 19031 19032 Ghost_Id : Entity_Id := Empty; 19033 -- The entity of the first Ghost subprogram encountered while 19034 -- processing the arguments of the pragma. 19035 19036 begin 19037 GNAT_Pragma; 19038 Check_Arg_Order ((Name_Entity, Name_Section)); 19039 Check_Arg_Count (2); 19040 Check_Optional_Identifier (Arg1, Name_Entity); 19041 Check_Optional_Identifier (Arg2, Name_Section); 19042 Check_Arg_Is_Library_Level_Local_Name (Arg1); 19043 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 19044 19045 -- Check kind of entity 19046 19047 Arg := Get_Pragma_Arg (Arg1); 19048 Ent := Entity (Arg); 19049 19050 case Ekind (Ent) is 19051 19052 -- Objects (constants and variables) and types. For these cases 19053 -- all we need to do is to set the Linker_Section_pragma field, 19054 -- checking that we do not have a duplicate. 19055 19056 when Type_Kind 19057 | E_Constant 19058 | E_Variable 19059 => 19060 LPE := Linker_Section_Pragma (Ent); 19061 19062 if Present (LPE) then 19063 Error_Msg_Sloc := Sloc (LPE); 19064 Error_Msg_NE 19065 ("Linker_Section already specified for &#", Arg1, Ent); 19066 end if; 19067 19068 Set_Linker_Section_Pragma (Ent, N); 19069 19070 -- A pragma that applies to a Ghost entity becomes Ghost for 19071 -- the purposes of legality checks and removal of ignored 19072 -- Ghost code. 19073 19074 Mark_Ghost_Pragma (N, Ent); 19075 19076 -- Subprograms 19077 19078 when Subprogram_Kind => 19079 19080 -- Aspect case, entity already set 19081 19082 if From_Aspect_Specification (N) then 19083 Set_Linker_Section_Pragma 19084 (Entity (Corresponding_Aspect (N)), N); 19085 19086 -- Pragma case, we must climb the homonym chain, but skip 19087 -- any for which the linker section is already set. 19088 19089 else 19090 loop 19091 if No (Linker_Section_Pragma (Ent)) then 19092 Set_Linker_Section_Pragma (Ent, N); 19093 19094 -- A pragma that applies to a Ghost entity becomes 19095 -- Ghost for the purposes of legality checks and 19096 -- removal of ignored Ghost code. 19097 19098 Mark_Ghost_Pragma (N, Ent); 19099 19100 -- Capture the entity of the first Ghost subprogram 19101 -- being processed for error detection purposes. 19102 19103 if Is_Ghost_Entity (Ent) then 19104 if No (Ghost_Id) then 19105 Ghost_Id := Ent; 19106 end if; 19107 19108 -- Otherwise the subprogram is non-Ghost. It is 19109 -- illegal to mix references to Ghost and non-Ghost 19110 -- entities (SPARK RM 6.9). 19111 19112 elsif Present (Ghost_Id) 19113 and then not Ghost_Error_Posted 19114 then 19115 Ghost_Error_Posted := True; 19116 19117 Error_Msg_Name_1 := Pname; 19118 Error_Msg_N 19119 ("pragma % cannot mention ghost and " 19120 & "non-ghost subprograms", N); 19121 19122 Error_Msg_Sloc := Sloc (Ghost_Id); 19123 Error_Msg_NE 19124 ("\& # declared as ghost", N, Ghost_Id); 19125 19126 Error_Msg_Sloc := Sloc (Ent); 19127 Error_Msg_NE 19128 ("\& # declared as non-ghost", N, Ent); 19129 end if; 19130 end if; 19131 19132 Ent := Homonym (Ent); 19133 exit when No (Ent) 19134 or else Scope (Ent) /= Current_Scope; 19135 end loop; 19136 end if; 19137 19138 -- All other cases are illegal 19139 19140 when others => 19141 Error_Pragma_Arg 19142 ("pragma% applies only to objects, subprograms, and types", 19143 Arg1); 19144 end case; 19145 end Linker_Section; 19146 19147 ---------- 19148 -- List -- 19149 ---------- 19150 19151 -- pragma List (On | Off) 19152 19153 -- There is nothing to do here, since we did all the processing for 19154 -- this pragma in Par.Prag (so that it works properly even in syntax 19155 -- only mode). 19156 19157 when Pragma_List => 19158 null; 19159 19160 --------------- 19161 -- Lock_Free -- 19162 --------------- 19163 19164 -- pragma Lock_Free [(Boolean_EXPRESSION)]; 19165 19166 when Pragma_Lock_Free => Lock_Free : declare 19167 P : constant Node_Id := Parent (N); 19168 Arg : Node_Id; 19169 Ent : Entity_Id; 19170 Val : Boolean; 19171 19172 begin 19173 Check_No_Identifiers; 19174 Check_At_Most_N_Arguments (1); 19175 19176 -- Protected definition case 19177 19178 if Nkind (P) = N_Protected_Definition then 19179 Ent := Defining_Identifier (Parent (P)); 19180 19181 -- One argument 19182 19183 if Arg_Count = 1 then 19184 Arg := Get_Pragma_Arg (Arg1); 19185 Val := Is_True (Static_Boolean (Arg)); 19186 19187 -- No arguments (expression is considered to be True) 19188 19189 else 19190 Val := True; 19191 end if; 19192 19193 -- Check duplicate pragma before we chain the pragma in the Rep 19194 -- Item chain of Ent. 19195 19196 Check_Duplicate_Pragma (Ent); 19197 Record_Rep_Item (Ent, N); 19198 Set_Uses_Lock_Free (Ent, Val); 19199 19200 -- Anything else is incorrect placement 19201 19202 else 19203 Pragma_Misplaced; 19204 end if; 19205 end Lock_Free; 19206 19207 -------------------- 19208 -- Locking_Policy -- 19209 -------------------- 19210 19211 -- pragma Locking_Policy (policy_IDENTIFIER); 19212 19213 when Pragma_Locking_Policy => declare 19214 subtype LP_Range is Name_Id 19215 range First_Locking_Policy_Name .. Last_Locking_Policy_Name; 19216 LP_Val : LP_Range; 19217 LP : Character; 19218 19219 begin 19220 Check_Ada_83_Warning; 19221 Check_Arg_Count (1); 19222 Check_No_Identifiers; 19223 Check_Arg_Is_Locking_Policy (Arg1); 19224 Check_Valid_Configuration_Pragma; 19225 LP_Val := Chars (Get_Pragma_Arg (Arg1)); 19226 19227 case LP_Val is 19228 when Name_Ceiling_Locking => LP := 'C'; 19229 when Name_Concurrent_Readers_Locking => LP := 'R'; 19230 when Name_Inheritance_Locking => LP := 'I'; 19231 end case; 19232 19233 if Locking_Policy /= ' ' 19234 and then Locking_Policy /= LP 19235 then 19236 Error_Msg_Sloc := Locking_Policy_Sloc; 19237 Error_Pragma ("locking policy incompatible with policy#"); 19238 19239 -- Set new policy, but always preserve System_Location since we 19240 -- like the error message with the run time name. 19241 19242 else 19243 Locking_Policy := LP; 19244 19245 if Locking_Policy_Sloc /= System_Location then 19246 Locking_Policy_Sloc := Loc; 19247 end if; 19248 end if; 19249 end; 19250 19251 ------------------- 19252 -- Loop_Optimize -- 19253 ------------------- 19254 19255 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } ); 19256 19257 -- OPTIMIZATION_HINT ::= 19258 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector 19259 19260 when Pragma_Loop_Optimize => Loop_Optimize : declare 19261 Hint : Node_Id; 19262 19263 begin 19264 GNAT_Pragma; 19265 Check_At_Least_N_Arguments (1); 19266 Check_No_Identifiers; 19267 19268 Hint := First (Pragma_Argument_Associations (N)); 19269 while Present (Hint) loop 19270 Check_Arg_Is_One_Of (Hint, Name_Ivdep, 19271 Name_No_Unroll, 19272 Name_Unroll, 19273 Name_No_Vector, 19274 Name_Vector); 19275 Next (Hint); 19276 end loop; 19277 19278 Check_Loop_Pragma_Placement; 19279 end Loop_Optimize; 19280 19281 ------------------ 19282 -- Loop_Variant -- 19283 ------------------ 19284 19285 -- pragma Loop_Variant 19286 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } ); 19287 19288 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION 19289 19290 -- CHANGE_DIRECTION ::= Increases | Decreases 19291 19292 when Pragma_Loop_Variant => Loop_Variant : declare 19293 Variant : Node_Id; 19294 19295 begin 19296 GNAT_Pragma; 19297 Check_At_Least_N_Arguments (1); 19298 Check_Loop_Pragma_Placement; 19299 19300 -- Process all increasing / decreasing expressions 19301 19302 Variant := First (Pragma_Argument_Associations (N)); 19303 while Present (Variant) loop 19304 if Chars (Variant) = No_Name then 19305 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant); 19306 19307 elsif not Nam_In (Chars (Variant), Name_Decreases, 19308 Name_Increases) 19309 then 19310 declare 19311 Name : String := Get_Name_String (Chars (Variant)); 19312 19313 begin 19314 -- It is a common mistake to write "Increasing" for 19315 -- "Increases" or "Decreasing" for "Decreases". Recognize 19316 -- specially names starting with "incr" or "decr" to 19317 -- suggest the corresponding name. 19318 19319 System.Case_Util.To_Lower (Name); 19320 19321 if Name'Length >= 4 19322 and then Name (1 .. 4) = "incr" 19323 then 19324 Error_Pragma_Arg_Ident 19325 ("expect name `Increases`", Variant); 19326 19327 elsif Name'Length >= 4 19328 and then Name (1 .. 4) = "decr" 19329 then 19330 Error_Pragma_Arg_Ident 19331 ("expect name `Decreases`", Variant); 19332 19333 else 19334 Error_Pragma_Arg_Ident 19335 ("expect name `Increases` or `Decreases`", Variant); 19336 end if; 19337 end; 19338 end if; 19339 19340 Preanalyze_Assert_Expression 19341 (Expression (Variant), Any_Discrete); 19342 19343 Next (Variant); 19344 end loop; 19345 end Loop_Variant; 19346 19347 ----------------------- 19348 -- Machine_Attribute -- 19349 ----------------------- 19350 19351 -- pragma Machine_Attribute ( 19352 -- [Entity =>] LOCAL_NAME, 19353 -- [Attribute_Name =>] static_string_EXPRESSION 19354 -- [, [Info =>] static_EXPRESSION] ); 19355 19356 when Pragma_Machine_Attribute => Machine_Attribute : declare 19357 Def_Id : Entity_Id; 19358 19359 begin 19360 GNAT_Pragma; 19361 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info)); 19362 19363 if Arg_Count = 3 then 19364 Check_Optional_Identifier (Arg3, Name_Info); 19365 Check_Arg_Is_OK_Static_Expression (Arg3); 19366 else 19367 Check_Arg_Count (2); 19368 end if; 19369 19370 Check_Optional_Identifier (Arg1, Name_Entity); 19371 Check_Optional_Identifier (Arg2, Name_Attribute_Name); 19372 Check_Arg_Is_Local_Name (Arg1); 19373 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 19374 Def_Id := Entity (Get_Pragma_Arg (Arg1)); 19375 19376 if Is_Access_Type (Def_Id) then 19377 Def_Id := Designated_Type (Def_Id); 19378 end if; 19379 19380 if Rep_Item_Too_Early (Def_Id, N) then 19381 return; 19382 end if; 19383 19384 Def_Id := Underlying_Type (Def_Id); 19385 19386 -- The only processing required is to link this item on to the 19387 -- list of rep items for the given entity. This is accomplished 19388 -- by the call to Rep_Item_Too_Late (when no error is detected 19389 -- and False is returned). 19390 19391 if Rep_Item_Too_Late (Def_Id, N) then 19392 return; 19393 else 19394 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 19395 end if; 19396 end Machine_Attribute; 19397 19398 ---------- 19399 -- Main -- 19400 ---------- 19401 19402 -- pragma Main 19403 -- (MAIN_OPTION [, MAIN_OPTION]); 19404 19405 -- MAIN_OPTION ::= 19406 -- [STACK_SIZE =>] static_integer_EXPRESSION 19407 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION 19408 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION 19409 19410 when Pragma_Main => Main : declare 19411 Args : Args_List (1 .. 3); 19412 Names : constant Name_List (1 .. 3) := ( 19413 Name_Stack_Size, 19414 Name_Task_Stack_Size_Default, 19415 Name_Time_Slicing_Enabled); 19416 19417 Nod : Node_Id; 19418 19419 begin 19420 GNAT_Pragma; 19421 Gather_Associations (Names, Args); 19422 19423 for J in 1 .. 2 loop 19424 if Present (Args (J)) then 19425 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); 19426 end if; 19427 end loop; 19428 19429 if Present (Args (3)) then 19430 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean); 19431 end if; 19432 19433 Nod := Next (N); 19434 while Present (Nod) loop 19435 if Nkind (Nod) = N_Pragma 19436 and then Pragma_Name (Nod) = Name_Main 19437 then 19438 Error_Msg_Name_1 := Pname; 19439 Error_Msg_N ("duplicate pragma% not permitted", Nod); 19440 end if; 19441 19442 Next (Nod); 19443 end loop; 19444 end Main; 19445 19446 ------------------ 19447 -- Main_Storage -- 19448 ------------------ 19449 19450 -- pragma Main_Storage 19451 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); 19452 19453 -- MAIN_STORAGE_OPTION ::= 19454 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION 19455 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION 19456 19457 when Pragma_Main_Storage => Main_Storage : declare 19458 Args : Args_List (1 .. 2); 19459 Names : constant Name_List (1 .. 2) := ( 19460 Name_Working_Storage, 19461 Name_Top_Guard); 19462 19463 Nod : Node_Id; 19464 19465 begin 19466 GNAT_Pragma; 19467 Gather_Associations (Names, Args); 19468 19469 for J in 1 .. 2 loop 19470 if Present (Args (J)) then 19471 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); 19472 end if; 19473 end loop; 19474 19475 Check_In_Main_Program; 19476 19477 Nod := Next (N); 19478 while Present (Nod) loop 19479 if Nkind (Nod) = N_Pragma 19480 and then Pragma_Name (Nod) = Name_Main_Storage 19481 then 19482 Error_Msg_Name_1 := Pname; 19483 Error_Msg_N ("duplicate pragma% not permitted", Nod); 19484 end if; 19485 19486 Next (Nod); 19487 end loop; 19488 end Main_Storage; 19489 19490 ---------------------- 19491 -- Max_Queue_Length -- 19492 ---------------------- 19493 19494 -- pragma Max_Queue_Length (static_integer_EXPRESSION); 19495 19496 -- This processing is shared by Pragma_Max_Entry_Queue_Depth 19497 19498 when Pragma_Max_Queue_Length 19499 | Pragma_Max_Entry_Queue_Depth 19500 => 19501 Max_Queue_Length : declare 19502 Arg : Node_Id; 19503 Entry_Decl : Node_Id; 19504 Entry_Id : Entity_Id; 19505 Val : Uint; 19506 19507 begin 19508 if Prag_Id = Pragma_Max_Queue_Length then 19509 GNAT_Pragma; 19510 end if; 19511 19512 Check_Arg_Count (1); 19513 19514 Entry_Decl := 19515 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 19516 19517 -- Entry declaration 19518 19519 if Nkind (Entry_Decl) = N_Entry_Declaration then 19520 19521 -- Entry illegally within a task 19522 19523 if Nkind (Parent (N)) = N_Task_Definition then 19524 Error_Pragma ("pragma % cannot apply to task entries"); 19525 return; 19526 end if; 19527 19528 Entry_Id := Defining_Entity (Entry_Decl); 19529 19530 -- Otherwise the pragma is associated with an illegal construct 19531 19532 else 19533 Error_Pragma ("pragma % must apply to a protected entry"); 19534 return; 19535 end if; 19536 19537 -- Mark the pragma as Ghost if the related subprogram is also 19538 -- Ghost. This also ensures that any expansion performed further 19539 -- below will produce Ghost nodes. 19540 19541 Mark_Ghost_Pragma (N, Entry_Id); 19542 19543 -- Analyze the Integer expression 19544 19545 Arg := Get_Pragma_Arg (Arg1); 19546 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer); 19547 19548 Val := Expr_Value (Arg); 19549 19550 if Val <= 0 then 19551 Error_Pragma_Arg 19552 ("argument for pragma% must be positive", Arg1); 19553 19554 elsif not UI_Is_In_Int_Range (Val) then 19555 Error_Pragma_Arg 19556 ("argument for pragma% out of range of Integer", Arg1); 19557 19558 end if; 19559 19560 -- Manually substitute the expression value of the pragma argument 19561 -- if it's not an integer literal because this is not taken care 19562 -- of automatically elsewhere. 19563 19564 if Nkind (Arg) /= N_Integer_Literal then 19565 Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val)); 19566 Set_Etype (Arg, Etype (Original_Node (Arg))); 19567 end if; 19568 19569 Record_Rep_Item (Entry_Id, N); 19570 end Max_Queue_Length; 19571 19572 ----------------- 19573 -- Memory_Size -- 19574 ----------------- 19575 19576 -- pragma Memory_Size (NUMERIC_LITERAL) 19577 19578 when Pragma_Memory_Size => 19579 GNAT_Pragma; 19580 19581 -- Memory size is simply ignored 19582 19583 Check_No_Identifiers; 19584 Check_Arg_Count (1); 19585 Check_Arg_Is_Integer_Literal (Arg1); 19586 19587 ------------- 19588 -- No_Body -- 19589 ------------- 19590 19591 -- pragma No_Body; 19592 19593 -- The only correct use of this pragma is on its own in a file, in 19594 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body 19595 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to 19596 -- check for a file containing nothing but a No_Body pragma). If we 19597 -- attempt to process it during normal semantics processing, it means 19598 -- it was misplaced. 19599 19600 when Pragma_No_Body => 19601 GNAT_Pragma; 19602 Pragma_Misplaced; 19603 19604 ----------------------------- 19605 -- No_Elaboration_Code_All -- 19606 ----------------------------- 19607 19608 -- pragma No_Elaboration_Code_All; 19609 19610 when Pragma_No_Elaboration_Code_All => 19611 GNAT_Pragma; 19612 Check_Valid_Library_Unit_Pragma; 19613 19614 if Nkind (N) = N_Null_Statement then 19615 return; 19616 end if; 19617 19618 -- Must appear for a spec or generic spec 19619 19620 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)), 19621 N_Generic_Package_Declaration, 19622 N_Generic_Subprogram_Declaration, 19623 N_Package_Declaration, 19624 N_Subprogram_Declaration) 19625 then 19626 Error_Pragma 19627 (Fix_Error 19628 ("pragma% can only occur for package " 19629 & "or subprogram spec")); 19630 end if; 19631 19632 -- Set flag in unit table 19633 19634 Set_No_Elab_Code_All (Current_Sem_Unit); 19635 19636 -- Set restriction No_Elaboration_Code if this is the main unit 19637 19638 if Current_Sem_Unit = Main_Unit then 19639 Set_Restriction (No_Elaboration_Code, N); 19640 end if; 19641 19642 -- If we are in the main unit or in an extended main source unit, 19643 -- then we also add it to the configuration restrictions so that 19644 -- it will apply to all units in the extended main source. 19645 19646 if Current_Sem_Unit = Main_Unit 19647 or else In_Extended_Main_Source_Unit (N) 19648 then 19649 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 19650 end if; 19651 19652 -- If in main extended unit, activate transitive with test 19653 19654 if In_Extended_Main_Source_Unit (N) then 19655 Opt.No_Elab_Code_All_Pragma := N; 19656 end if; 19657 19658 ----------------------------- 19659 -- No_Component_Reordering -- 19660 ----------------------------- 19661 19662 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)]; 19663 19664 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare 19665 E : Entity_Id; 19666 E_Id : Node_Id; 19667 19668 begin 19669 GNAT_Pragma; 19670 Check_At_Most_N_Arguments (1); 19671 19672 if Arg_Count = 0 then 19673 Check_Valid_Configuration_Pragma; 19674 Opt.No_Component_Reordering := True; 19675 19676 else 19677 Check_Optional_Identifier (Arg2, Name_Entity); 19678 Check_Arg_Is_Local_Name (Arg1); 19679 E_Id := Get_Pragma_Arg (Arg1); 19680 19681 if Etype (E_Id) = Any_Type then 19682 return; 19683 end if; 19684 19685 E := Entity (E_Id); 19686 19687 if not Is_Record_Type (E) then 19688 Error_Pragma_Arg ("pragma% requires record type", Arg1); 19689 end if; 19690 19691 Set_No_Reordering (Base_Type (E)); 19692 end if; 19693 end No_Comp_Reordering; 19694 19695 -------------------------- 19696 -- No_Heap_Finalization -- 19697 -------------------------- 19698 19699 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ]; 19700 19701 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare 19702 Context : constant Node_Id := Parent (N); 19703 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1); 19704 Prev : Node_Id; 19705 Typ : Entity_Id; 19706 19707 begin 19708 GNAT_Pragma; 19709 Check_No_Identifiers; 19710 19711 -- The pragma appears in a configuration file 19712 19713 if No (Context) then 19714 Check_Arg_Count (0); 19715 Check_Valid_Configuration_Pragma; 19716 19717 -- Detect a duplicate pragma 19718 19719 if Present (No_Heap_Finalization_Pragma) then 19720 Duplication_Error 19721 (Prag => N, 19722 Prev => No_Heap_Finalization_Pragma); 19723 raise Pragma_Exit; 19724 end if; 19725 19726 No_Heap_Finalization_Pragma := N; 19727 19728 -- Otherwise the pragma should be associated with a library-level 19729 -- named access-to-object type. 19730 19731 else 19732 Check_Arg_Count (1); 19733 Check_Arg_Is_Local_Name (Arg1); 19734 19735 Find_Type (Typ_Arg); 19736 Typ := Entity (Typ_Arg); 19737 19738 -- The type being subjected to the pragma is erroneous 19739 19740 if Typ = Any_Type then 19741 Error_Pragma ("cannot find type referenced by pragma %"); 19742 19743 -- The pragma is applied to an incomplete or generic formal 19744 -- type way too early. 19745 19746 elsif Rep_Item_Too_Early (Typ, N) then 19747 return; 19748 19749 else 19750 Typ := Underlying_Type (Typ); 19751 end if; 19752 19753 -- The pragma must apply to an access-to-object type 19754 19755 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then 19756 null; 19757 19758 -- Give a detailed error message on all other access type kinds 19759 19760 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then 19761 Error_Pragma 19762 ("pragma % cannot apply to access protected subprogram " 19763 & "type"); 19764 19765 elsif Ekind (Typ) = E_Access_Subprogram_Type then 19766 Error_Pragma 19767 ("pragma % cannot apply to access subprogram type"); 19768 19769 elsif Is_Anonymous_Access_Type (Typ) then 19770 Error_Pragma 19771 ("pragma % cannot apply to anonymous access type"); 19772 19773 -- Give a general error message in case the pragma applies to a 19774 -- non-access type. 19775 19776 else 19777 Error_Pragma 19778 ("pragma % must apply to library level access type"); 19779 end if; 19780 19781 -- At this point the argument denotes an access-to-object type. 19782 -- Ensure that the type is declared at the library level. 19783 19784 if Is_Library_Level_Entity (Typ) then 19785 null; 19786 19787 -- Quietly ignore an access-to-object type originally declared 19788 -- at the library level within a generic, but instantiated at 19789 -- a non-library level. As a result the access-to-object type 19790 -- "loses" its No_Heap_Finalization property. 19791 19792 elsif In_Instance then 19793 raise Pragma_Exit; 19794 19795 else 19796 Error_Pragma 19797 ("pragma % must apply to library level access type"); 19798 end if; 19799 19800 -- Detect a duplicate pragma 19801 19802 if Present (No_Heap_Finalization_Pragma) then 19803 Duplication_Error 19804 (Prag => N, 19805 Prev => No_Heap_Finalization_Pragma); 19806 raise Pragma_Exit; 19807 19808 else 19809 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization); 19810 19811 if Present (Prev) then 19812 Duplication_Error 19813 (Prag => N, 19814 Prev => Prev); 19815 raise Pragma_Exit; 19816 end if; 19817 end if; 19818 19819 Record_Rep_Item (Typ, N); 19820 end if; 19821 end No_Heap_Finalization; 19822 19823 --------------- 19824 -- No_Inline -- 19825 --------------- 19826 19827 -- pragma No_Inline ( NAME {, NAME} ); 19828 19829 when Pragma_No_Inline => 19830 GNAT_Pragma; 19831 Process_Inline (Suppressed); 19832 19833 --------------- 19834 -- No_Return -- 19835 --------------- 19836 19837 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name}); 19838 19839 when Pragma_No_Return => No_Return : declare 19840 Arg : Node_Id; 19841 E : Entity_Id; 19842 Found : Boolean; 19843 Id : Node_Id; 19844 19845 Ghost_Error_Posted : Boolean := False; 19846 -- Flag set when an error concerning the illegal mix of Ghost and 19847 -- non-Ghost subprograms is emitted. 19848 19849 Ghost_Id : Entity_Id := Empty; 19850 -- The entity of the first Ghost procedure encountered while 19851 -- processing the arguments of the pragma. 19852 19853 begin 19854 Ada_2005_Pragma; 19855 Check_At_Least_N_Arguments (1); 19856 19857 -- Loop through arguments of pragma 19858 19859 Arg := Arg1; 19860 while Present (Arg) loop 19861 Check_Arg_Is_Local_Name (Arg); 19862 Id := Get_Pragma_Arg (Arg); 19863 Analyze (Id); 19864 19865 if not Is_Entity_Name (Id) then 19866 Error_Pragma_Arg ("entity name required", Arg); 19867 end if; 19868 19869 if Etype (Id) = Any_Type then 19870 raise Pragma_Exit; 19871 end if; 19872 19873 -- Loop to find matching procedures 19874 19875 E := Entity (Id); 19876 19877 Found := False; 19878 while Present (E) 19879 and then Scope (E) = Current_Scope 19880 loop 19881 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then 19882 19883 -- Check that the pragma is not applied to a body. 19884 -- First check the specless body case, to give a 19885 -- different error message. These checks do not apply 19886 -- if Relaxed_RM_Semantics, to accommodate other Ada 19887 -- compilers. Disable these checks under -gnatd.J. 19888 19889 if not Debug_Flag_Dot_JJ then 19890 if Nkind (Parent (Declaration_Node (E))) = 19891 N_Subprogram_Body 19892 and then not Relaxed_RM_Semantics 19893 then 19894 Error_Pragma 19895 ("pragma% requires separate spec and must come " 19896 & "before body"); 19897 end if; 19898 19899 -- Now the "specful" body case 19900 19901 if Rep_Item_Too_Late (E, N) then 19902 raise Pragma_Exit; 19903 end if; 19904 end if; 19905 19906 Set_No_Return (E); 19907 19908 -- A pragma that applies to a Ghost entity becomes Ghost 19909 -- for the purposes of legality checks and removal of 19910 -- ignored Ghost code. 19911 19912 Mark_Ghost_Pragma (N, E); 19913 19914 -- Capture the entity of the first Ghost procedure being 19915 -- processed for error detection purposes. 19916 19917 if Is_Ghost_Entity (E) then 19918 if No (Ghost_Id) then 19919 Ghost_Id := E; 19920 end if; 19921 19922 -- Otherwise the subprogram is non-Ghost. It is illegal 19923 -- to mix references to Ghost and non-Ghost entities 19924 -- (SPARK RM 6.9). 19925 19926 elsif Present (Ghost_Id) 19927 and then not Ghost_Error_Posted 19928 then 19929 Ghost_Error_Posted := True; 19930 19931 Error_Msg_Name_1 := Pname; 19932 Error_Msg_N 19933 ("pragma % cannot mention ghost and non-ghost " 19934 & "procedures", N); 19935 19936 Error_Msg_Sloc := Sloc (Ghost_Id); 19937 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 19938 19939 Error_Msg_Sloc := Sloc (E); 19940 Error_Msg_NE ("\& # declared as non-ghost", N, E); 19941 end if; 19942 19943 -- Set flag on any alias as well 19944 19945 if Is_Overloadable (E) and then Present (Alias (E)) then 19946 Set_No_Return (Alias (E)); 19947 end if; 19948 19949 Found := True; 19950 end if; 19951 19952 exit when From_Aspect_Specification (N); 19953 E := Homonym (E); 19954 end loop; 19955 19956 -- If entity in not in current scope it may be the enclosing 19957 -- suprogram body to which the aspect applies. 19958 19959 if not Found then 19960 if Entity (Id) = Current_Scope 19961 and then From_Aspect_Specification (N) 19962 then 19963 Set_No_Return (Entity (Id)); 19964 else 19965 Error_Pragma_Arg ("no procedure& found for pragma%", Arg); 19966 end if; 19967 end if; 19968 19969 Next (Arg); 19970 end loop; 19971 end No_Return; 19972 19973 ----------------- 19974 -- No_Run_Time -- 19975 ----------------- 19976 19977 -- pragma No_Run_Time; 19978 19979 -- Note: this pragma is retained for backwards compatibility. See 19980 -- body of Rtsfind for full details on its handling. 19981 19982 when Pragma_No_Run_Time => 19983 GNAT_Pragma; 19984 Check_Valid_Configuration_Pragma; 19985 Check_Arg_Count (0); 19986 19987 -- Remove backward compatibility if Build_Type is FSF or GPL and 19988 -- generate a warning. 19989 19990 declare 19991 Ignore : constant Boolean := Build_Type in FSF .. GPL; 19992 begin 19993 if Ignore then 19994 Error_Pragma ("pragma% is ignored, has no effect??"); 19995 else 19996 No_Run_Time_Mode := True; 19997 Configurable_Run_Time_Mode := True; 19998 19999 -- Set Duration to 32 bits if word size is 32 20000 20001 if Ttypes.System_Word_Size = 32 then 20002 Duration_32_Bits_On_Target := True; 20003 end if; 20004 20005 -- Set appropriate restrictions 20006 20007 Set_Restriction (No_Finalization, N); 20008 Set_Restriction (No_Exception_Handlers, N); 20009 Set_Restriction (Max_Tasks, N, 0); 20010 Set_Restriction (No_Tasking, N); 20011 end if; 20012 end; 20013 20014 ----------------------- 20015 -- No_Tagged_Streams -- 20016 ----------------------- 20017 20018 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)]; 20019 20020 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare 20021 E : Entity_Id; 20022 E_Id : Node_Id; 20023 20024 begin 20025 GNAT_Pragma; 20026 Check_At_Most_N_Arguments (1); 20027 20028 -- One argument case 20029 20030 if Arg_Count = 1 then 20031 Check_Optional_Identifier (Arg1, Name_Entity); 20032 Check_Arg_Is_Local_Name (Arg1); 20033 E_Id := Get_Pragma_Arg (Arg1); 20034 20035 if Etype (E_Id) = Any_Type then 20036 return; 20037 end if; 20038 20039 E := Entity (E_Id); 20040 20041 Check_Duplicate_Pragma (E); 20042 20043 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then 20044 Error_Pragma_Arg 20045 ("argument for pragma% must be root tagged type", Arg1); 20046 end if; 20047 20048 if Rep_Item_Too_Early (E, N) 20049 or else 20050 Rep_Item_Too_Late (E, N) 20051 then 20052 return; 20053 else 20054 Set_No_Tagged_Streams_Pragma (E, N); 20055 end if; 20056 20057 -- Zero argument case 20058 20059 else 20060 Check_Is_In_Decl_Part_Or_Package_Spec; 20061 No_Tagged_Streams := N; 20062 end if; 20063 end No_Tagged_Strms; 20064 20065 ------------------------ 20066 -- No_Strict_Aliasing -- 20067 ------------------------ 20068 20069 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; 20070 20071 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare 20072 E : Entity_Id; 20073 E_Id : Node_Id; 20074 20075 begin 20076 GNAT_Pragma; 20077 Check_At_Most_N_Arguments (1); 20078 20079 if Arg_Count = 0 then 20080 Check_Valid_Configuration_Pragma; 20081 Opt.No_Strict_Aliasing := True; 20082 20083 else 20084 Check_Optional_Identifier (Arg2, Name_Entity); 20085 Check_Arg_Is_Local_Name (Arg1); 20086 E_Id := Get_Pragma_Arg (Arg1); 20087 20088 if Etype (E_Id) = Any_Type then 20089 return; 20090 end if; 20091 20092 E := Entity (E_Id); 20093 20094 if not Is_Access_Type (E) then 20095 Error_Pragma_Arg ("pragma% requires access type", Arg1); 20096 end if; 20097 20098 Set_No_Strict_Aliasing (Base_Type (E)); 20099 end if; 20100 end No_Strict_Aliasing; 20101 20102 ----------------------- 20103 -- Normalize_Scalars -- 20104 ----------------------- 20105 20106 -- pragma Normalize_Scalars; 20107 20108 when Pragma_Normalize_Scalars => 20109 Check_Ada_83_Warning; 20110 Check_Arg_Count (0); 20111 Check_Valid_Configuration_Pragma; 20112 20113 -- Normalize_Scalars creates false positives in CodePeer, and 20114 -- incorrect negative results in GNATprove mode, so ignore this 20115 -- pragma in these modes. 20116 20117 if not (CodePeer_Mode or GNATprove_Mode) then 20118 Normalize_Scalars := True; 20119 Init_Or_Norm_Scalars := True; 20120 end if; 20121 20122 ----------------- 20123 -- Obsolescent -- 20124 ----------------- 20125 20126 -- pragma Obsolescent; 20127 20128 -- pragma Obsolescent ( 20129 -- [Message =>] static_string_EXPRESSION 20130 -- [,[Version =>] Ada_05]]); 20131 20132 -- pragma Obsolescent ( 20133 -- [Entity =>] NAME 20134 -- [,[Message =>] static_string_EXPRESSION 20135 -- [,[Version =>] Ada_05]] ); 20136 20137 when Pragma_Obsolescent => Obsolescent : declare 20138 Decl : Node_Id; 20139 Ename : Node_Id; 20140 20141 procedure Set_Obsolescent (E : Entity_Id); 20142 -- Given an entity Ent, mark it as obsolescent if appropriate 20143 20144 --------------------- 20145 -- Set_Obsolescent -- 20146 --------------------- 20147 20148 procedure Set_Obsolescent (E : Entity_Id) is 20149 Active : Boolean; 20150 Ent : Entity_Id; 20151 S : String_Id; 20152 20153 begin 20154 Active := True; 20155 Ent := E; 20156 20157 -- A pragma that applies to a Ghost entity becomes Ghost for 20158 -- the purposes of legality checks and removal of ignored Ghost 20159 -- code. 20160 20161 Mark_Ghost_Pragma (N, E); 20162 20163 -- Entity name was given 20164 20165 if Present (Ename) then 20166 20167 -- If entity name matches, we are fine. Save entity in 20168 -- pragma argument, for ASIS use. 20169 20170 if Chars (Ename) = Chars (Ent) then 20171 Set_Entity (Ename, Ent); 20172 Generate_Reference (Ent, Ename); 20173 20174 -- If entity name does not match, only possibility is an 20175 -- enumeration literal from an enumeration type declaration. 20176 20177 elsif Ekind (Ent) /= E_Enumeration_Type then 20178 Error_Pragma 20179 ("pragma % entity name does not match declaration"); 20180 20181 else 20182 Ent := First_Literal (E); 20183 loop 20184 if No (Ent) then 20185 Error_Pragma 20186 ("pragma % entity name does not match any " 20187 & "enumeration literal"); 20188 20189 elsif Chars (Ent) = Chars (Ename) then 20190 Set_Entity (Ename, Ent); 20191 Generate_Reference (Ent, Ename); 20192 exit; 20193 20194 else 20195 Ent := Next_Literal (Ent); 20196 end if; 20197 end loop; 20198 end if; 20199 end if; 20200 20201 -- Ent points to entity to be marked 20202 20203 if Arg_Count >= 1 then 20204 20205 -- Deal with static string argument 20206 20207 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 20208 S := Strval (Get_Pragma_Arg (Arg1)); 20209 20210 for J in 1 .. String_Length (S) loop 20211 if not In_Character_Range (Get_String_Char (S, J)) then 20212 Error_Pragma_Arg 20213 ("pragma% argument does not allow wide characters", 20214 Arg1); 20215 end if; 20216 end loop; 20217 20218 Obsolescent_Warnings.Append 20219 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1)))); 20220 20221 -- Check for Ada_05 parameter 20222 20223 if Arg_Count /= 1 then 20224 Check_Arg_Count (2); 20225 20226 declare 20227 Argx : constant Node_Id := Get_Pragma_Arg (Arg2); 20228 20229 begin 20230 Check_Arg_Is_Identifier (Argx); 20231 20232 if Chars (Argx) /= Name_Ada_05 then 20233 Error_Msg_Name_2 := Name_Ada_05; 20234 Error_Pragma_Arg 20235 ("only allowed argument for pragma% is %", Argx); 20236 end if; 20237 20238 if Ada_Version_Explicit < Ada_2005 20239 or else not Warn_On_Ada_2005_Compatibility 20240 then 20241 Active := False; 20242 end if; 20243 end; 20244 end if; 20245 end if; 20246 20247 -- Set flag if pragma active 20248 20249 if Active then 20250 Set_Is_Obsolescent (Ent); 20251 end if; 20252 20253 return; 20254 end Set_Obsolescent; 20255 20256 -- Start of processing for pragma Obsolescent 20257 20258 begin 20259 GNAT_Pragma; 20260 20261 Check_At_Most_N_Arguments (3); 20262 20263 -- See if first argument specifies an entity name 20264 20265 if Arg_Count >= 1 20266 and then 20267 (Chars (Arg1) = Name_Entity 20268 or else 20269 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, 20270 N_Identifier, 20271 N_Operator_Symbol)) 20272 then 20273 Ename := Get_Pragma_Arg (Arg1); 20274 20275 -- Eliminate first argument, so we can share processing 20276 20277 Arg1 := Arg2; 20278 Arg2 := Arg3; 20279 Arg_Count := Arg_Count - 1; 20280 20281 -- No Entity name argument given 20282 20283 else 20284 Ename := Empty; 20285 end if; 20286 20287 if Arg_Count >= 1 then 20288 Check_Optional_Identifier (Arg1, Name_Message); 20289 20290 if Arg_Count = 2 then 20291 Check_Optional_Identifier (Arg2, Name_Version); 20292 end if; 20293 end if; 20294 20295 -- Get immediately preceding declaration 20296 20297 Decl := Prev (N); 20298 while Present (Decl) and then Nkind (Decl) = N_Pragma loop 20299 Prev (Decl); 20300 end loop; 20301 20302 -- Cases where we do not follow anything other than another pragma 20303 20304 if No (Decl) then 20305 20306 -- First case: library level compilation unit declaration with 20307 -- the pragma immediately following the declaration. 20308 20309 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 20310 Set_Obsolescent 20311 (Defining_Entity (Unit (Parent (Parent (N))))); 20312 return; 20313 20314 -- Case 2: library unit placement for package 20315 20316 else 20317 declare 20318 Ent : constant Entity_Id := Find_Lib_Unit_Name; 20319 begin 20320 if Is_Package_Or_Generic_Package (Ent) then 20321 Set_Obsolescent (Ent); 20322 return; 20323 end if; 20324 end; 20325 end if; 20326 20327 -- Cases where we must follow a declaration, including an 20328 -- abstract subprogram declaration, which is not in the 20329 -- other node subtypes. 20330 20331 else 20332 if Nkind (Decl) not in N_Declaration 20333 and then Nkind (Decl) not in N_Later_Decl_Item 20334 and then Nkind (Decl) not in N_Generic_Declaration 20335 and then Nkind (Decl) not in N_Renaming_Declaration 20336 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration 20337 then 20338 Error_Pragma 20339 ("pragma% misplaced, " 20340 & "must immediately follow a declaration"); 20341 20342 else 20343 Set_Obsolescent (Defining_Entity (Decl)); 20344 return; 20345 end if; 20346 end if; 20347 end Obsolescent; 20348 20349 -------------- 20350 -- Optimize -- 20351 -------------- 20352 20353 -- pragma Optimize (Time | Space | Off); 20354 20355 -- The actual check for optimize is done in Gigi. Note that this 20356 -- pragma does not actually change the optimization setting, it 20357 -- simply checks that it is consistent with the pragma. 20358 20359 when Pragma_Optimize => 20360 Check_No_Identifiers; 20361 Check_Arg_Count (1); 20362 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); 20363 20364 ------------------------ 20365 -- Optimize_Alignment -- 20366 ------------------------ 20367 20368 -- pragma Optimize_Alignment (Time | Space | Off); 20369 20370 when Pragma_Optimize_Alignment => Optimize_Alignment : begin 20371 GNAT_Pragma; 20372 Check_No_Identifiers; 20373 Check_Arg_Count (1); 20374 Check_Valid_Configuration_Pragma; 20375 20376 declare 20377 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 20378 begin 20379 case Nam is 20380 when Name_Off => Opt.Optimize_Alignment := 'O'; 20381 when Name_Space => Opt.Optimize_Alignment := 'S'; 20382 when Name_Time => Opt.Optimize_Alignment := 'T'; 20383 20384 when others => 20385 Error_Pragma_Arg ("invalid argument for pragma%", Arg1); 20386 end case; 20387 end; 20388 20389 -- Set indication that mode is set locally. If we are in fact in a 20390 -- configuration pragma file, this setting is harmless since the 20391 -- switch will get reset anyway at the start of each unit. 20392 20393 Optimize_Alignment_Local := True; 20394 end Optimize_Alignment; 20395 20396 ------------- 20397 -- Ordered -- 20398 ------------- 20399 20400 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); 20401 20402 when Pragma_Ordered => Ordered : declare 20403 Assoc : constant Node_Id := Arg1; 20404 Type_Id : Node_Id; 20405 Typ : Entity_Id; 20406 20407 begin 20408 GNAT_Pragma; 20409 Check_No_Identifiers; 20410 Check_Arg_Count (1); 20411 Check_Arg_Is_Local_Name (Arg1); 20412 20413 Type_Id := Get_Pragma_Arg (Assoc); 20414 Find_Type (Type_Id); 20415 Typ := Entity (Type_Id); 20416 20417 if Typ = Any_Type then 20418 return; 20419 else 20420 Typ := Underlying_Type (Typ); 20421 end if; 20422 20423 if not Is_Enumeration_Type (Typ) then 20424 Error_Pragma ("pragma% must specify enumeration type"); 20425 end if; 20426 20427 Check_First_Subtype (Arg1); 20428 Set_Has_Pragma_Ordered (Base_Type (Typ)); 20429 end Ordered; 20430 20431 ------------------- 20432 -- Overflow_Mode -- 20433 ------------------- 20434 20435 -- pragma Overflow_Mode 20436 -- ([General => ] MODE [, [Assertions => ] MODE]); 20437 20438 -- MODE := STRICT | MINIMIZED | ELIMINATED 20439 20440 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64 20441 -- since System.Bignums makes this assumption. This is true of nearly 20442 -- all (all?) targets. 20443 20444 when Pragma_Overflow_Mode => Overflow_Mode : declare 20445 function Get_Overflow_Mode 20446 (Name : Name_Id; 20447 Arg : Node_Id) return Overflow_Mode_Type; 20448 -- Function to process one pragma argument, Arg. If an identifier 20449 -- is present, it must be Name. Mode type is returned if a valid 20450 -- argument exists, otherwise an error is signalled. 20451 20452 ----------------------- 20453 -- Get_Overflow_Mode -- 20454 ----------------------- 20455 20456 function Get_Overflow_Mode 20457 (Name : Name_Id; 20458 Arg : Node_Id) return Overflow_Mode_Type 20459 is 20460 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 20461 20462 begin 20463 Check_Optional_Identifier (Arg, Name); 20464 Check_Arg_Is_Identifier (Argx); 20465 20466 if Chars (Argx) = Name_Strict then 20467 return Strict; 20468 20469 elsif Chars (Argx) = Name_Minimized then 20470 return Minimized; 20471 20472 elsif Chars (Argx) = Name_Eliminated then 20473 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then 20474 Error_Pragma_Arg 20475 ("Eliminated not implemented on this target", Argx); 20476 else 20477 return Eliminated; 20478 end if; 20479 20480 else 20481 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 20482 end if; 20483 end Get_Overflow_Mode; 20484 20485 -- Start of processing for Overflow_Mode 20486 20487 begin 20488 GNAT_Pragma; 20489 Check_At_Least_N_Arguments (1); 20490 Check_At_Most_N_Arguments (2); 20491 20492 -- Process first argument 20493 20494 Scope_Suppress.Overflow_Mode_General := 20495 Get_Overflow_Mode (Name_General, Arg1); 20496 20497 -- Case of only one argument 20498 20499 if Arg_Count = 1 then 20500 Scope_Suppress.Overflow_Mode_Assertions := 20501 Scope_Suppress.Overflow_Mode_General; 20502 20503 -- Case of two arguments present 20504 20505 else 20506 Scope_Suppress.Overflow_Mode_Assertions := 20507 Get_Overflow_Mode (Name_Assertions, Arg2); 20508 end if; 20509 end Overflow_Mode; 20510 20511 -------------------------- 20512 -- Overriding Renamings -- 20513 -------------------------- 20514 20515 -- pragma Overriding_Renamings; 20516 20517 when Pragma_Overriding_Renamings => 20518 GNAT_Pragma; 20519 Check_Arg_Count (0); 20520 Check_Valid_Configuration_Pragma; 20521 Overriding_Renamings := True; 20522 20523 ---------- 20524 -- Pack -- 20525 ---------- 20526 20527 -- pragma Pack (first_subtype_LOCAL_NAME); 20528 20529 when Pragma_Pack => Pack : declare 20530 Assoc : constant Node_Id := Arg1; 20531 Ctyp : Entity_Id; 20532 Ignore : Boolean := False; 20533 Typ : Entity_Id; 20534 Type_Id : Node_Id; 20535 20536 begin 20537 Check_No_Identifiers; 20538 Check_Arg_Count (1); 20539 Check_Arg_Is_Local_Name (Arg1); 20540 Type_Id := Get_Pragma_Arg (Assoc); 20541 20542 if not Is_Entity_Name (Type_Id) 20543 or else not Is_Type (Entity (Type_Id)) 20544 then 20545 Error_Pragma_Arg 20546 ("argument for pragma% must be type or subtype", Arg1); 20547 end if; 20548 20549 Find_Type (Type_Id); 20550 Typ := Entity (Type_Id); 20551 20552 if Typ = Any_Type 20553 or else Rep_Item_Too_Early (Typ, N) 20554 then 20555 return; 20556 else 20557 Typ := Underlying_Type (Typ); 20558 end if; 20559 20560 -- A pragma that applies to a Ghost entity becomes Ghost for the 20561 -- purposes of legality checks and removal of ignored Ghost code. 20562 20563 Mark_Ghost_Pragma (N, Typ); 20564 20565 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then 20566 Error_Pragma ("pragma% must specify array or record type"); 20567 end if; 20568 20569 Check_First_Subtype (Arg1); 20570 Check_Duplicate_Pragma (Typ); 20571 20572 -- Array type 20573 20574 if Is_Array_Type (Typ) then 20575 Ctyp := Component_Type (Typ); 20576 20577 -- Ignore pack that does nothing 20578 20579 if Known_Static_Esize (Ctyp) 20580 and then Known_Static_RM_Size (Ctyp) 20581 and then Esize (Ctyp) = RM_Size (Ctyp) 20582 and then Addressable (Esize (Ctyp)) 20583 then 20584 Ignore := True; 20585 end if; 20586 20587 -- Process OK pragma Pack. Note that if there is a separate 20588 -- component clause present, the Pack will be cancelled. This 20589 -- processing is in Freeze. 20590 20591 if not Rep_Item_Too_Late (Typ, N) then 20592 20593 -- In CodePeer mode, we do not need complex front-end 20594 -- expansions related to pragma Pack, so disable handling 20595 -- of pragma Pack. 20596 20597 if CodePeer_Mode then 20598 null; 20599 20600 -- Normal case where we do the pack action 20601 20602 else 20603 if not Ignore then 20604 Set_Is_Packed (Base_Type (Typ)); 20605 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 20606 end if; 20607 20608 Set_Has_Pragma_Pack (Base_Type (Typ)); 20609 end if; 20610 end if; 20611 20612 -- For record types, the pack is always effective 20613 20614 else pragma Assert (Is_Record_Type (Typ)); 20615 if not Rep_Item_Too_Late (Typ, N) then 20616 Set_Is_Packed (Base_Type (Typ)); 20617 Set_Has_Pragma_Pack (Base_Type (Typ)); 20618 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 20619 end if; 20620 end if; 20621 end Pack; 20622 20623 ---------- 20624 -- Page -- 20625 ---------- 20626 20627 -- pragma Page; 20628 20629 -- There is nothing to do here, since we did all the processing for 20630 -- this pragma in Par.Prag (so that it works properly even in syntax 20631 -- only mode). 20632 20633 when Pragma_Page => 20634 null; 20635 20636 ------------- 20637 -- Part_Of -- 20638 ------------- 20639 20640 -- pragma Part_Of (ABSTRACT_STATE); 20641 20642 -- ABSTRACT_STATE ::= NAME 20643 20644 when Pragma_Part_Of => Part_Of : declare 20645 procedure Propagate_Part_Of 20646 (Pack_Id : Entity_Id; 20647 State_Id : Entity_Id; 20648 Instance : Node_Id); 20649 -- Propagate the Part_Of indicator to all abstract states and 20650 -- objects declared in the visible state space of a package 20651 -- denoted by Pack_Id. State_Id is the encapsulating state. 20652 -- Instance is the package instantiation node. 20653 20654 ----------------------- 20655 -- Propagate_Part_Of -- 20656 ----------------------- 20657 20658 procedure Propagate_Part_Of 20659 (Pack_Id : Entity_Id; 20660 State_Id : Entity_Id; 20661 Instance : Node_Id) 20662 is 20663 Has_Item : Boolean := False; 20664 -- Flag set when the visible state space contains at least one 20665 -- abstract state or variable. 20666 20667 procedure Propagate_Part_Of (Pack_Id : Entity_Id); 20668 -- Propagate the Part_Of indicator to all abstract states and 20669 -- objects declared in the visible state space of a package 20670 -- denoted by Pack_Id. 20671 20672 ----------------------- 20673 -- Propagate_Part_Of -- 20674 ----------------------- 20675 20676 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is 20677 Constits : Elist_Id; 20678 Item_Id : Entity_Id; 20679 20680 begin 20681 -- Traverse the entity chain of the package and set relevant 20682 -- attributes of abstract states and objects declared in the 20683 -- visible state space of the package. 20684 20685 Item_Id := First_Entity (Pack_Id); 20686 while Present (Item_Id) 20687 and then not In_Private_Part (Item_Id) 20688 loop 20689 -- Do not consider internally generated items 20690 20691 if not Comes_From_Source (Item_Id) then 20692 null; 20693 20694 -- Do not consider generic formals or their corresponding 20695 -- actuals because they are not part of a visible state. 20696 -- Note that both entities are marked as hidden. 20697 20698 elsif Is_Hidden (Item_Id) then 20699 null; 20700 20701 -- The Part_Of indicator turns an abstract state or an 20702 -- object into a constituent of the encapsulating state. 20703 -- Note that constants are considered here even though 20704 -- they may not depend on variable input. This check is 20705 -- left to the SPARK prover. 20706 20707 elsif Ekind_In (Item_Id, E_Abstract_State, 20708 E_Constant, 20709 E_Variable) 20710 then 20711 Has_Item := True; 20712 Constits := Part_Of_Constituents (State_Id); 20713 20714 if No (Constits) then 20715 Constits := New_Elmt_List; 20716 Set_Part_Of_Constituents (State_Id, Constits); 20717 end if; 20718 20719 Append_Elmt (Item_Id, Constits); 20720 Set_Encapsulating_State (Item_Id, State_Id); 20721 20722 -- Recursively handle nested packages and instantiations 20723 20724 elsif Ekind (Item_Id) = E_Package then 20725 Propagate_Part_Of (Item_Id); 20726 end if; 20727 20728 Next_Entity (Item_Id); 20729 end loop; 20730 end Propagate_Part_Of; 20731 20732 -- Start of processing for Propagate_Part_Of 20733 20734 begin 20735 Propagate_Part_Of (Pack_Id); 20736 20737 -- Detect a package instantiation that is subject to a Part_Of 20738 -- indicator, but has no visible state. 20739 20740 if not Has_Item then 20741 SPARK_Msg_NE 20742 ("package instantiation & has Part_Of indicator but " 20743 & "lacks visible state", Instance, Pack_Id); 20744 end if; 20745 end Propagate_Part_Of; 20746 20747 -- Local variables 20748 20749 Constits : Elist_Id; 20750 Encap : Node_Id; 20751 Encap_Id : Entity_Id; 20752 Item_Id : Entity_Id; 20753 Legal : Boolean; 20754 Stmt : Node_Id; 20755 20756 -- Start of processing for Part_Of 20757 20758 begin 20759 GNAT_Pragma; 20760 Check_No_Identifiers; 20761 Check_Arg_Count (1); 20762 20763 Stmt := Find_Related_Context (N, Do_Checks => True); 20764 20765 -- Object declaration 20766 20767 if Nkind (Stmt) = N_Object_Declaration then 20768 null; 20769 20770 -- Package instantiation 20771 20772 elsif Nkind (Stmt) = N_Package_Instantiation then 20773 null; 20774 20775 -- Single concurrent type declaration 20776 20777 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then 20778 null; 20779 20780 -- Otherwise the pragma is associated with an illegal construct 20781 20782 else 20783 Pragma_Misplaced; 20784 return; 20785 end if; 20786 20787 -- Extract the entity of the related object declaration or package 20788 -- instantiation. In the case of the instantiation, use the entity 20789 -- of the instance spec. 20790 20791 if Nkind (Stmt) = N_Package_Instantiation then 20792 Stmt := Instance_Spec (Stmt); 20793 end if; 20794 20795 Item_Id := Defining_Entity (Stmt); 20796 20797 -- A pragma that applies to a Ghost entity becomes Ghost for the 20798 -- purposes of legality checks and removal of ignored Ghost code. 20799 20800 Mark_Ghost_Pragma (N, Item_Id); 20801 20802 -- Chain the pragma on the contract for further processing by 20803 -- Analyze_Part_Of_In_Decl_Part or for completeness. 20804 20805 Add_Contract_Item (N, Item_Id); 20806 20807 -- A variable may act as constituent of a single concurrent type 20808 -- which in turn could be declared after the variable. Due to this 20809 -- discrepancy, the full analysis of indicator Part_Of is delayed 20810 -- until the end of the enclosing declarative region (see routine 20811 -- Analyze_Part_Of_In_Decl_Part). 20812 20813 if Ekind (Item_Id) = E_Variable then 20814 null; 20815 20816 -- Otherwise indicator Part_Of applies to a constant or a package 20817 -- instantiation. 20818 20819 else 20820 Encap := Get_Pragma_Arg (Arg1); 20821 20822 -- Detect any discrepancies between the placement of the 20823 -- constant or package instantiation with respect to state 20824 -- space and the encapsulating state. 20825 20826 Analyze_Part_Of 20827 (Indic => N, 20828 Item_Id => Item_Id, 20829 Encap => Encap, 20830 Encap_Id => Encap_Id, 20831 Legal => Legal); 20832 20833 if Legal then 20834 pragma Assert (Present (Encap_Id)); 20835 20836 if Ekind (Item_Id) = E_Constant then 20837 Constits := Part_Of_Constituents (Encap_Id); 20838 20839 if No (Constits) then 20840 Constits := New_Elmt_List; 20841 Set_Part_Of_Constituents (Encap_Id, Constits); 20842 end if; 20843 20844 Append_Elmt (Item_Id, Constits); 20845 Set_Encapsulating_State (Item_Id, Encap_Id); 20846 20847 -- Propagate the Part_Of indicator to the visible state 20848 -- space of the package instantiation. 20849 20850 else 20851 Propagate_Part_Of 20852 (Pack_Id => Item_Id, 20853 State_Id => Encap_Id, 20854 Instance => Stmt); 20855 end if; 20856 end if; 20857 end if; 20858 end Part_Of; 20859 20860 ---------------------------------- 20861 -- Partition_Elaboration_Policy -- 20862 ---------------------------------- 20863 20864 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER); 20865 20866 when Pragma_Partition_Elaboration_Policy => PEP : declare 20867 subtype PEP_Range is Name_Id 20868 range First_Partition_Elaboration_Policy_Name 20869 .. Last_Partition_Elaboration_Policy_Name; 20870 PEP_Val : PEP_Range; 20871 PEP : Character; 20872 20873 begin 20874 Ada_2005_Pragma; 20875 Check_Arg_Count (1); 20876 Check_No_Identifiers; 20877 Check_Arg_Is_Partition_Elaboration_Policy (Arg1); 20878 Check_Valid_Configuration_Pragma; 20879 PEP_Val := Chars (Get_Pragma_Arg (Arg1)); 20880 20881 case PEP_Val is 20882 when Name_Concurrent => PEP := 'C'; 20883 when Name_Sequential => PEP := 'S'; 20884 end case; 20885 20886 if Partition_Elaboration_Policy /= ' ' 20887 and then Partition_Elaboration_Policy /= PEP 20888 then 20889 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc; 20890 Error_Pragma 20891 ("partition elaboration policy incompatible with policy#"); 20892 20893 -- Set new policy, but always preserve System_Location since we 20894 -- like the error message with the run time name. 20895 20896 else 20897 Partition_Elaboration_Policy := PEP; 20898 20899 if Partition_Elaboration_Policy_Sloc /= System_Location then 20900 Partition_Elaboration_Policy_Sloc := Loc; 20901 end if; 20902 end if; 20903 end PEP; 20904 20905 ------------- 20906 -- Passive -- 20907 ------------- 20908 20909 -- pragma Passive [(PASSIVE_FORM)]; 20910 20911 -- PASSIVE_FORM ::= Semaphore | No 20912 20913 when Pragma_Passive => 20914 GNAT_Pragma; 20915 20916 if Nkind (Parent (N)) /= N_Task_Definition then 20917 Error_Pragma ("pragma% must be within task definition"); 20918 end if; 20919 20920 if Arg_Count /= 0 then 20921 Check_Arg_Count (1); 20922 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); 20923 end if; 20924 20925 ---------------------------------- 20926 -- Preelaborable_Initialization -- 20927 ---------------------------------- 20928 20929 -- pragma Preelaborable_Initialization (DIRECT_NAME); 20930 20931 when Pragma_Preelaborable_Initialization => Preelab_Init : declare 20932 Ent : Entity_Id; 20933 20934 begin 20935 Ada_2005_Pragma; 20936 Check_Arg_Count (1); 20937 Check_No_Identifiers; 20938 Check_Arg_Is_Identifier (Arg1); 20939 Check_Arg_Is_Local_Name (Arg1); 20940 Check_First_Subtype (Arg1); 20941 Ent := Entity (Get_Pragma_Arg (Arg1)); 20942 20943 -- A pragma that applies to a Ghost entity becomes Ghost for the 20944 -- purposes of legality checks and removal of ignored Ghost code. 20945 20946 Mark_Ghost_Pragma (N, Ent); 20947 20948 -- The pragma may come from an aspect on a private declaration, 20949 -- even if the freeze point at which this is analyzed in the 20950 -- private part after the full view. 20951 20952 if Has_Private_Declaration (Ent) 20953 and then From_Aspect_Specification (N) 20954 then 20955 null; 20956 20957 -- Check appropriate type argument 20958 20959 elsif Is_Private_Type (Ent) 20960 or else Is_Protected_Type (Ent) 20961 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)) 20962 20963 -- AI05-0028: The pragma applies to all composite types. Note 20964 -- that we apply this binding interpretation to earlier versions 20965 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable 20966 -- choice since there are other compilers that do the same. 20967 20968 or else Is_Composite_Type (Ent) 20969 then 20970 null; 20971 20972 else 20973 Error_Pragma_Arg 20974 ("pragma % can only be applied to private, formal derived, " 20975 & "protected, or composite type", Arg1); 20976 end if; 20977 20978 -- Give an error if the pragma is applied to a protected type that 20979 -- does not qualify (due to having entries, or due to components 20980 -- that do not qualify). 20981 20982 if Is_Protected_Type (Ent) 20983 and then not Has_Preelaborable_Initialization (Ent) 20984 then 20985 Error_Msg_N 20986 ("protected type & does not have preelaborable " 20987 & "initialization", Ent); 20988 20989 -- Otherwise mark the type as definitely having preelaborable 20990 -- initialization. 20991 20992 else 20993 Set_Known_To_Have_Preelab_Init (Ent); 20994 end if; 20995 20996 if Has_Pragma_Preelab_Init (Ent) 20997 and then Warn_On_Redundant_Constructs 20998 then 20999 Error_Pragma ("?r?duplicate pragma%!"); 21000 else 21001 Set_Has_Pragma_Preelab_Init (Ent); 21002 end if; 21003 end Preelab_Init; 21004 21005 -------------------- 21006 -- Persistent_BSS -- 21007 -------------------- 21008 21009 -- pragma Persistent_BSS [(object_NAME)]; 21010 21011 when Pragma_Persistent_BSS => Persistent_BSS : declare 21012 Decl : Node_Id; 21013 Ent : Entity_Id; 21014 Prag : Node_Id; 21015 21016 begin 21017 GNAT_Pragma; 21018 Check_At_Most_N_Arguments (1); 21019 21020 -- Case of application to specific object (one argument) 21021 21022 if Arg_Count = 1 then 21023 Check_Arg_Is_Library_Level_Local_Name (Arg1); 21024 21025 if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) 21026 or else not 21027 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, 21028 E_Constant) 21029 then 21030 Error_Pragma_Arg ("pragma% only applies to objects", Arg1); 21031 end if; 21032 21033 Ent := Entity (Get_Pragma_Arg (Arg1)); 21034 21035 -- A pragma that applies to a Ghost entity becomes Ghost for 21036 -- the purposes of legality checks and removal of ignored Ghost 21037 -- code. 21038 21039 Mark_Ghost_Pragma (N, Ent); 21040 21041 -- Check for duplication before inserting in list of 21042 -- representation items. 21043 21044 Check_Duplicate_Pragma (Ent); 21045 21046 if Rep_Item_Too_Late (Ent, N) then 21047 return; 21048 end if; 21049 21050 Decl := Parent (Ent); 21051 21052 if Present (Expression (Decl)) then 21053 Error_Pragma_Arg 21054 ("object for pragma% cannot have initialization", Arg1); 21055 end if; 21056 21057 if not Is_Potentially_Persistent_Type (Etype (Ent)) then 21058 Error_Pragma_Arg 21059 ("object type for pragma% is not potentially persistent", 21060 Arg1); 21061 end if; 21062 21063 Prag := 21064 Make_Linker_Section_Pragma 21065 (Ent, Sloc (N), ".persistent.bss"); 21066 Insert_After (N, Prag); 21067 Analyze (Prag); 21068 21069 -- Case of use as configuration pragma with no arguments 21070 21071 else 21072 Check_Valid_Configuration_Pragma; 21073 Persistent_BSS_Mode := True; 21074 end if; 21075 end Persistent_BSS; 21076 21077 -------------------- 21078 -- Rename_Pragma -- 21079 -------------------- 21080 21081 -- pragma Rename_Pragma ( 21082 -- [New_Name =>] IDENTIFIER, 21083 -- [Renamed =>] pragma_IDENTIFIER); 21084 21085 when Pragma_Rename_Pragma => Rename_Pragma : declare 21086 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1); 21087 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2); 21088 21089 begin 21090 GNAT_Pragma; 21091 Check_Valid_Configuration_Pragma; 21092 Check_Arg_Count (2); 21093 Check_Optional_Identifier (Arg1, Name_New_Name); 21094 Check_Optional_Identifier (Arg2, Name_Renamed); 21095 21096 if Nkind (New_Name) /= N_Identifier then 21097 Error_Pragma_Arg ("identifier expected", Arg1); 21098 end if; 21099 21100 if Nkind (Old_Name) /= N_Identifier then 21101 Error_Pragma_Arg ("identifier expected", Arg2); 21102 end if; 21103 21104 -- The New_Name arg should not be an existing pragma (but we allow 21105 -- it; it's just a warning). The Old_Name arg must be an existing 21106 -- pragma. 21107 21108 if Is_Pragma_Name (Chars (New_Name)) then 21109 Error_Pragma_Arg ("??pragma is already defined", Arg1); 21110 end if; 21111 21112 if not Is_Pragma_Name (Chars (Old_Name)) then 21113 Error_Pragma_Arg ("existing pragma name expected", Arg1); 21114 end if; 21115 21116 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name)); 21117 end Rename_Pragma; 21118 21119 ------------- 21120 -- Polling -- 21121 ------------- 21122 21123 -- pragma Polling (ON | OFF); 21124 21125 when Pragma_Polling => 21126 GNAT_Pragma; 21127 Check_Arg_Count (1); 21128 Check_No_Identifiers; 21129 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 21130 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); 21131 21132 ----------------------------------- 21133 -- Post/Post_Class/Postcondition -- 21134 ----------------------------------- 21135 21136 -- pragma Post (Boolean_EXPRESSION); 21137 -- pragma Post_Class (Boolean_EXPRESSION); 21138 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION 21139 -- [,[Message =>] String_EXPRESSION]); 21140 21141 -- Characteristics: 21142 21143 -- * Analysis - The annotation undergoes initial checks to verify 21144 -- the legal placement and context. Secondary checks preanalyze the 21145 -- expression in: 21146 21147 -- Analyze_Pre_Post_Condition_In_Decl_Part 21148 21149 -- * Expansion - The annotation is expanded during the expansion of 21150 -- the related subprogram [body] contract as performed in: 21151 21152 -- Expand_Subprogram_Contract 21153 21154 -- * Template - The annotation utilizes the generic template of the 21155 -- related subprogram [body] when it is: 21156 21157 -- aspect on subprogram declaration 21158 -- aspect on stand-alone subprogram body 21159 -- pragma on stand-alone subprogram body 21160 21161 -- The annotation must prepare its own template when it is: 21162 21163 -- pragma on subprogram declaration 21164 21165 -- * Globals - Capture of global references must occur after full 21166 -- analysis. 21167 21168 -- * Instance - The annotation is instantiated automatically when 21169 -- the related generic subprogram [body] is instantiated except for 21170 -- the "pragma on subprogram declaration" case. In that scenario 21171 -- the annotation must instantiate itself. 21172 21173 when Pragma_Post 21174 | Pragma_Post_Class 21175 | Pragma_Postcondition 21176 => 21177 Analyze_Pre_Post_Condition; 21178 21179 -------------------------------- 21180 -- Pre/Pre_Class/Precondition -- 21181 -------------------------------- 21182 21183 -- pragma Pre (Boolean_EXPRESSION); 21184 -- pragma Pre_Class (Boolean_EXPRESSION); 21185 -- pragma Precondition ([Check =>] Boolean_EXPRESSION 21186 -- [,[Message =>] String_EXPRESSION]); 21187 21188 -- Characteristics: 21189 21190 -- * Analysis - The annotation undergoes initial checks to verify 21191 -- the legal placement and context. Secondary checks preanalyze the 21192 -- expression in: 21193 21194 -- Analyze_Pre_Post_Condition_In_Decl_Part 21195 21196 -- * Expansion - The annotation is expanded during the expansion of 21197 -- the related subprogram [body] contract as performed in: 21198 21199 -- Expand_Subprogram_Contract 21200 21201 -- * Template - The annotation utilizes the generic template of the 21202 -- related subprogram [body] when it is: 21203 21204 -- aspect on subprogram declaration 21205 -- aspect on stand-alone subprogram body 21206 -- pragma on stand-alone subprogram body 21207 21208 -- The annotation must prepare its own template when it is: 21209 21210 -- pragma on subprogram declaration 21211 21212 -- * Globals - Capture of global references must occur after full 21213 -- analysis. 21214 21215 -- * Instance - The annotation is instantiated automatically when 21216 -- the related generic subprogram [body] is instantiated except for 21217 -- the "pragma on subprogram declaration" case. In that scenario 21218 -- the annotation must instantiate itself. 21219 21220 when Pragma_Pre 21221 | Pragma_Pre_Class 21222 | Pragma_Precondition 21223 => 21224 Analyze_Pre_Post_Condition; 21225 21226 --------------- 21227 -- Predicate -- 21228 --------------- 21229 21230 -- pragma Predicate 21231 -- ([Entity =>] type_LOCAL_NAME, 21232 -- [Check =>] boolean_EXPRESSION); 21233 21234 when Pragma_Predicate => Predicate : declare 21235 Discard : Boolean; 21236 Typ : Entity_Id; 21237 Type_Id : Node_Id; 21238 21239 begin 21240 GNAT_Pragma; 21241 Check_Arg_Count (2); 21242 Check_Optional_Identifier (Arg1, Name_Entity); 21243 Check_Optional_Identifier (Arg2, Name_Check); 21244 21245 Check_Arg_Is_Local_Name (Arg1); 21246 21247 Type_Id := Get_Pragma_Arg (Arg1); 21248 Find_Type (Type_Id); 21249 Typ := Entity (Type_Id); 21250 21251 if Typ = Any_Type then 21252 return; 21253 end if; 21254 21255 -- A pragma that applies to a Ghost entity becomes Ghost for the 21256 -- purposes of legality checks and removal of ignored Ghost code. 21257 21258 Mark_Ghost_Pragma (N, Typ); 21259 21260 -- The remaining processing is simply to link the pragma on to 21261 -- the rep item chain, for processing when the type is frozen. 21262 -- This is accomplished by a call to Rep_Item_Too_Late. We also 21263 -- mark the type as having predicates. 21264 21265 -- If the current policy for predicate checking is Ignore mark the 21266 -- subtype accordingly. In the case of predicates we consider them 21267 -- enabled unless Ignore is specified (either directly or with a 21268 -- general Assertion_Policy pragma) to preserve existing warnings. 21269 21270 Set_Has_Predicates (Typ); 21271 21272 -- Indicate that the pragma must be processed at the point the 21273 -- type is frozen, as is done for the corresponding aspect. 21274 21275 Set_Has_Delayed_Aspects (Typ); 21276 Set_Has_Delayed_Freeze (Typ); 21277 21278 Set_Predicates_Ignored (Typ, 21279 Present (Check_Policy_List) 21280 and then 21281 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore); 21282 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 21283 end Predicate; 21284 21285 ----------------------- 21286 -- Predicate_Failure -- 21287 ----------------------- 21288 21289 -- pragma Predicate_Failure 21290 -- ([Entity =>] type_LOCAL_NAME, 21291 -- [Message =>] string_EXPRESSION); 21292 21293 when Pragma_Predicate_Failure => Predicate_Failure : declare 21294 Discard : Boolean; 21295 Typ : Entity_Id; 21296 Type_Id : Node_Id; 21297 21298 begin 21299 GNAT_Pragma; 21300 Check_Arg_Count (2); 21301 Check_Optional_Identifier (Arg1, Name_Entity); 21302 Check_Optional_Identifier (Arg2, Name_Message); 21303 21304 Check_Arg_Is_Local_Name (Arg1); 21305 21306 Type_Id := Get_Pragma_Arg (Arg1); 21307 Find_Type (Type_Id); 21308 Typ := Entity (Type_Id); 21309 21310 if Typ = Any_Type then 21311 return; 21312 end if; 21313 21314 -- A pragma that applies to a Ghost entity becomes Ghost for the 21315 -- purposes of legality checks and removal of ignored Ghost code. 21316 21317 Mark_Ghost_Pragma (N, Typ); 21318 21319 -- The remaining processing is simply to link the pragma on to 21320 -- the rep item chain, for processing when the type is frozen. 21321 -- This is accomplished by a call to Rep_Item_Too_Late. 21322 21323 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 21324 end Predicate_Failure; 21325 21326 ------------------ 21327 -- Preelaborate -- 21328 ------------------ 21329 21330 -- pragma Preelaborate [(library_unit_NAME)]; 21331 21332 -- Set the flag Is_Preelaborated of program unit name entity 21333 21334 when Pragma_Preelaborate => Preelaborate : declare 21335 Pa : constant Node_Id := Parent (N); 21336 Pk : constant Node_Kind := Nkind (Pa); 21337 Ent : Entity_Id; 21338 21339 begin 21340 Check_Ada_83_Warning; 21341 Check_Valid_Library_Unit_Pragma; 21342 21343 if Nkind (N) = N_Null_Statement then 21344 return; 21345 end if; 21346 21347 Ent := Find_Lib_Unit_Name; 21348 21349 -- A pragma that applies to a Ghost entity becomes Ghost for the 21350 -- purposes of legality checks and removal of ignored Ghost code. 21351 21352 Mark_Ghost_Pragma (N, Ent); 21353 Check_Duplicate_Pragma (Ent); 21354 21355 -- This filters out pragmas inside generic parents that show up 21356 -- inside instantiations. Pragmas that come from aspects in the 21357 -- unit are not ignored. 21358 21359 if Present (Ent) then 21360 if Pk = N_Package_Specification 21361 and then Present (Generic_Parent (Pa)) 21362 and then not From_Aspect_Specification (N) 21363 then 21364 null; 21365 21366 else 21367 if not Debug_Flag_U then 21368 Set_Is_Preelaborated (Ent); 21369 21370 if Legacy_Elaboration_Checks then 21371 Set_Suppress_Elaboration_Warnings (Ent); 21372 end if; 21373 end if; 21374 end if; 21375 end if; 21376 end Preelaborate; 21377 21378 ------------------------------- 21379 -- Prefix_Exception_Messages -- 21380 ------------------------------- 21381 21382 -- pragma Prefix_Exception_Messages; 21383 21384 when Pragma_Prefix_Exception_Messages => 21385 GNAT_Pragma; 21386 Check_Valid_Configuration_Pragma; 21387 Check_Arg_Count (0); 21388 Prefix_Exception_Messages := True; 21389 21390 -------------- 21391 -- Priority -- 21392 -------------- 21393 21394 -- pragma Priority (EXPRESSION); 21395 21396 when Pragma_Priority => Priority : declare 21397 P : constant Node_Id := Parent (N); 21398 Arg : Node_Id; 21399 Ent : Entity_Id; 21400 21401 begin 21402 Check_No_Identifiers; 21403 Check_Arg_Count (1); 21404 21405 -- Subprogram case 21406 21407 if Nkind (P) = N_Subprogram_Body then 21408 Check_In_Main_Program; 21409 21410 Ent := Defining_Unit_Name (Specification (P)); 21411 21412 if Nkind (Ent) = N_Defining_Program_Unit_Name then 21413 Ent := Defining_Identifier (Ent); 21414 end if; 21415 21416 Arg := Get_Pragma_Arg (Arg1); 21417 Analyze_And_Resolve (Arg, Standard_Integer); 21418 21419 -- Must be static 21420 21421 if not Is_OK_Static_Expression (Arg) then 21422 Flag_Non_Static_Expr 21423 ("main subprogram priority is not static!", Arg); 21424 raise Pragma_Exit; 21425 21426 -- If constraint error, then we already signalled an error 21427 21428 elsif Raises_Constraint_Error (Arg) then 21429 null; 21430 21431 -- Otherwise check in range except if Relaxed_RM_Semantics 21432 -- where we ignore the value if out of range. 21433 21434 else 21435 if not Relaxed_RM_Semantics 21436 and then not Is_In_Range (Arg, RTE (RE_Priority)) 21437 then 21438 Error_Pragma_Arg 21439 ("main subprogram priority is out of range", Arg1); 21440 else 21441 Set_Main_Priority 21442 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 21443 end if; 21444 end if; 21445 21446 -- Load an arbitrary entity from System.Tasking.Stages or 21447 -- System.Tasking.Restricted.Stages (depending on the 21448 -- supported profile) to make sure that one of these packages 21449 -- is implicitly with'ed, since we need to have the tasking 21450 -- run time active for the pragma Priority to have any effect. 21451 -- Previously we with'ed the package System.Tasking, but this 21452 -- package does not trigger the required initialization of the 21453 -- run-time library. 21454 21455 declare 21456 Discard : Entity_Id; 21457 pragma Warnings (Off, Discard); 21458 begin 21459 if Restricted_Profile then 21460 Discard := RTE (RE_Activate_Restricted_Tasks); 21461 else 21462 Discard := RTE (RE_Activate_Tasks); 21463 end if; 21464 end; 21465 21466 -- Task or Protected, must be of type Integer 21467 21468 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then 21469 Arg := Get_Pragma_Arg (Arg1); 21470 Ent := Defining_Identifier (Parent (P)); 21471 21472 -- The expression must be analyzed in the special manner 21473 -- described in "Handling of Default and Per-Object 21474 -- Expressions" in sem.ads. 21475 21476 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); 21477 21478 if not Is_OK_Static_Expression (Arg) then 21479 Check_Restriction (Static_Priorities, Arg); 21480 end if; 21481 21482 -- Anything else is incorrect 21483 21484 else 21485 Pragma_Misplaced; 21486 end if; 21487 21488 -- Check duplicate pragma before we chain the pragma in the Rep 21489 -- Item chain of Ent. 21490 21491 Check_Duplicate_Pragma (Ent); 21492 Record_Rep_Item (Ent, N); 21493 end Priority; 21494 21495 ----------------------------------- 21496 -- Priority_Specific_Dispatching -- 21497 ----------------------------------- 21498 21499 -- pragma Priority_Specific_Dispatching ( 21500 -- policy_IDENTIFIER, 21501 -- first_priority_EXPRESSION, 21502 -- last_priority_EXPRESSION); 21503 21504 when Pragma_Priority_Specific_Dispatching => 21505 Priority_Specific_Dispatching : declare 21506 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority); 21507 -- This is the entity System.Any_Priority; 21508 21509 DP : Character; 21510 Lower_Bound : Node_Id; 21511 Upper_Bound : Node_Id; 21512 Lower_Val : Uint; 21513 Upper_Val : Uint; 21514 21515 begin 21516 Ada_2005_Pragma; 21517 Check_Arg_Count (3); 21518 Check_No_Identifiers; 21519 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 21520 Check_Valid_Configuration_Pragma; 21521 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 21522 DP := Fold_Upper (Name_Buffer (1)); 21523 21524 Lower_Bound := Get_Pragma_Arg (Arg2); 21525 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer); 21526 Lower_Val := Expr_Value (Lower_Bound); 21527 21528 Upper_Bound := Get_Pragma_Arg (Arg3); 21529 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer); 21530 Upper_Val := Expr_Value (Upper_Bound); 21531 21532 -- It is not allowed to use Task_Dispatching_Policy and 21533 -- Priority_Specific_Dispatching in the same partition. 21534 21535 if Task_Dispatching_Policy /= ' ' then 21536 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 21537 Error_Pragma 21538 ("pragma% incompatible with Task_Dispatching_Policy#"); 21539 21540 -- Check lower bound in range 21541 21542 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 21543 or else 21544 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id)) 21545 then 21546 Error_Pragma_Arg 21547 ("first_priority is out of range", Arg2); 21548 21549 -- Check upper bound in range 21550 21551 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 21552 or else 21553 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id)) 21554 then 21555 Error_Pragma_Arg 21556 ("last_priority is out of range", Arg3); 21557 21558 -- Check that the priority range is valid 21559 21560 elsif Lower_Val > Upper_Val then 21561 Error_Pragma 21562 ("last_priority_expression must be greater than or equal to " 21563 & "first_priority_expression"); 21564 21565 -- Store the new policy, but always preserve System_Location since 21566 -- we like the error message with the run-time name. 21567 21568 else 21569 -- Check overlapping in the priority ranges specified in other 21570 -- Priority_Specific_Dispatching pragmas within the same 21571 -- partition. We can only check those we know about. 21572 21573 for J in 21574 Specific_Dispatching.First .. Specific_Dispatching.Last 21575 loop 21576 if Specific_Dispatching.Table (J).First_Priority in 21577 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 21578 or else Specific_Dispatching.Table (J).Last_Priority in 21579 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 21580 then 21581 Error_Msg_Sloc := 21582 Specific_Dispatching.Table (J).Pragma_Loc; 21583 Error_Pragma 21584 ("priority range overlaps with " 21585 & "Priority_Specific_Dispatching#"); 21586 end if; 21587 end loop; 21588 21589 -- The use of Priority_Specific_Dispatching is incompatible 21590 -- with Task_Dispatching_Policy. 21591 21592 if Task_Dispatching_Policy /= ' ' then 21593 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 21594 Error_Pragma 21595 ("Priority_Specific_Dispatching incompatible " 21596 & "with Task_Dispatching_Policy#"); 21597 end if; 21598 21599 -- The use of Priority_Specific_Dispatching forces ceiling 21600 -- locking policy. 21601 21602 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then 21603 Error_Msg_Sloc := Locking_Policy_Sloc; 21604 Error_Pragma 21605 ("Priority_Specific_Dispatching incompatible " 21606 & "with Locking_Policy#"); 21607 21608 -- Set the Ceiling_Locking policy, but preserve System_Location 21609 -- since we like the error message with the run time name. 21610 21611 else 21612 Locking_Policy := 'C'; 21613 21614 if Locking_Policy_Sloc /= System_Location then 21615 Locking_Policy_Sloc := Loc; 21616 end if; 21617 end if; 21618 21619 -- Add entry in the table 21620 21621 Specific_Dispatching.Append 21622 ((Dispatching_Policy => DP, 21623 First_Priority => UI_To_Int (Lower_Val), 21624 Last_Priority => UI_To_Int (Upper_Val), 21625 Pragma_Loc => Loc)); 21626 end if; 21627 end Priority_Specific_Dispatching; 21628 21629 ------------- 21630 -- Profile -- 21631 ------------- 21632 21633 -- pragma Profile (profile_IDENTIFIER); 21634 21635 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational 21636 21637 when Pragma_Profile => 21638 Ada_2005_Pragma; 21639 Check_Arg_Count (1); 21640 Check_Valid_Configuration_Pragma; 21641 Check_No_Identifiers; 21642 21643 declare 21644 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 21645 21646 begin 21647 if Chars (Argx) = Name_Ravenscar then 21648 Set_Ravenscar_Profile (Ravenscar, N); 21649 21650 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then 21651 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N); 21652 21653 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then 21654 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N); 21655 21656 elsif Chars (Argx) = Name_Restricted then 21657 Set_Profile_Restrictions 21658 (Restricted, 21659 N, Warn => Treat_Restrictions_As_Warnings); 21660 21661 elsif Chars (Argx) = Name_Rational then 21662 Set_Rational_Profile; 21663 21664 elsif Chars (Argx) = Name_No_Implementation_Extensions then 21665 Set_Profile_Restrictions 21666 (No_Implementation_Extensions, 21667 N, Warn => Treat_Restrictions_As_Warnings); 21668 21669 else 21670 Error_Pragma_Arg ("& is not a valid profile", Argx); 21671 end if; 21672 end; 21673 21674 ---------------------- 21675 -- Profile_Warnings -- 21676 ---------------------- 21677 21678 -- pragma Profile_Warnings (profile_IDENTIFIER); 21679 21680 -- profile_IDENTIFIER => Restricted | Ravenscar 21681 21682 when Pragma_Profile_Warnings => 21683 GNAT_Pragma; 21684 Check_Arg_Count (1); 21685 Check_Valid_Configuration_Pragma; 21686 Check_No_Identifiers; 21687 21688 declare 21689 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 21690 21691 begin 21692 if Chars (Argx) = Name_Ravenscar then 21693 Set_Profile_Restrictions (Ravenscar, N, Warn => True); 21694 21695 elsif Chars (Argx) = Name_Restricted then 21696 Set_Profile_Restrictions (Restricted, N, Warn => True); 21697 21698 elsif Chars (Argx) = Name_No_Implementation_Extensions then 21699 Set_Profile_Restrictions 21700 (No_Implementation_Extensions, N, Warn => True); 21701 21702 else 21703 Error_Pragma_Arg ("& is not a valid profile", Argx); 21704 end if; 21705 end; 21706 21707 -------------------------- 21708 -- Propagate_Exceptions -- 21709 -------------------------- 21710 21711 -- pragma Propagate_Exceptions; 21712 21713 -- Note: this pragma is obsolete and has no effect 21714 21715 when Pragma_Propagate_Exceptions => 21716 GNAT_Pragma; 21717 Check_Arg_Count (0); 21718 21719 if Warn_On_Obsolescent_Feature then 21720 Error_Msg_N 21721 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " & 21722 "and has no effect?j?", N); 21723 end if; 21724 21725 ----------------------------- 21726 -- Provide_Shift_Operators -- 21727 ----------------------------- 21728 21729 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME); 21730 21731 when Pragma_Provide_Shift_Operators => 21732 Provide_Shift_Operators : declare 21733 Ent : Entity_Id; 21734 21735 procedure Declare_Shift_Operator (Nam : Name_Id); 21736 -- Insert declaration and pragma Instrinsic for named shift op 21737 21738 ---------------------------- 21739 -- Declare_Shift_Operator -- 21740 ---------------------------- 21741 21742 procedure Declare_Shift_Operator (Nam : Name_Id) is 21743 Func : Node_Id; 21744 Import : Node_Id; 21745 21746 begin 21747 Func := 21748 Make_Subprogram_Declaration (Loc, 21749 Make_Function_Specification (Loc, 21750 Defining_Unit_Name => 21751 Make_Defining_Identifier (Loc, Chars => Nam), 21752 21753 Result_Definition => 21754 Make_Identifier (Loc, Chars => Chars (Ent)), 21755 21756 Parameter_Specifications => New_List ( 21757 Make_Parameter_Specification (Loc, 21758 Defining_Identifier => 21759 Make_Defining_Identifier (Loc, Name_Value), 21760 Parameter_Type => 21761 Make_Identifier (Loc, Chars => Chars (Ent))), 21762 21763 Make_Parameter_Specification (Loc, 21764 Defining_Identifier => 21765 Make_Defining_Identifier (Loc, Name_Amount), 21766 Parameter_Type => 21767 New_Occurrence_Of (Standard_Natural, Loc))))); 21768 21769 Import := 21770 Make_Pragma (Loc, 21771 Chars => Name_Import, 21772 Pragma_Argument_Associations => New_List ( 21773 Make_Pragma_Argument_Association (Loc, 21774 Expression => Make_Identifier (Loc, Name_Intrinsic)), 21775 Make_Pragma_Argument_Association (Loc, 21776 Expression => Make_Identifier (Loc, Nam)))); 21777 21778 Insert_After (N, Import); 21779 Insert_After (N, Func); 21780 end Declare_Shift_Operator; 21781 21782 -- Start of processing for Provide_Shift_Operators 21783 21784 begin 21785 GNAT_Pragma; 21786 Check_Arg_Count (1); 21787 Check_Arg_Is_Local_Name (Arg1); 21788 21789 Arg1 := Get_Pragma_Arg (Arg1); 21790 21791 -- We must have an entity name 21792 21793 if not Is_Entity_Name (Arg1) then 21794 Error_Pragma_Arg 21795 ("pragma % must apply to integer first subtype", Arg1); 21796 end if; 21797 21798 -- If no Entity, means there was a prior error so ignore 21799 21800 if Present (Entity (Arg1)) then 21801 Ent := Entity (Arg1); 21802 21803 -- Apply error checks 21804 21805 if not Is_First_Subtype (Ent) then 21806 Error_Pragma_Arg 21807 ("cannot apply pragma %", 21808 "\& is not a first subtype", 21809 Arg1); 21810 21811 elsif not Is_Integer_Type (Ent) then 21812 Error_Pragma_Arg 21813 ("cannot apply pragma %", 21814 "\& is not an integer type", 21815 Arg1); 21816 21817 elsif Has_Shift_Operator (Ent) then 21818 Error_Pragma_Arg 21819 ("cannot apply pragma %", 21820 "\& already has declared shift operators", 21821 Arg1); 21822 21823 elsif Is_Frozen (Ent) then 21824 Error_Pragma_Arg 21825 ("pragma % appears too late", 21826 "\& is already frozen", 21827 Arg1); 21828 end if; 21829 21830 -- Now declare the operators. We do this during analysis rather 21831 -- than expansion, since we want the operators available if we 21832 -- are operating in -gnatc or ASIS mode. 21833 21834 Declare_Shift_Operator (Name_Rotate_Left); 21835 Declare_Shift_Operator (Name_Rotate_Right); 21836 Declare_Shift_Operator (Name_Shift_Left); 21837 Declare_Shift_Operator (Name_Shift_Right); 21838 Declare_Shift_Operator (Name_Shift_Right_Arithmetic); 21839 end if; 21840 end Provide_Shift_Operators; 21841 21842 ------------------ 21843 -- Psect_Object -- 21844 ------------------ 21845 21846 -- pragma Psect_Object ( 21847 -- [Internal =>] LOCAL_NAME, 21848 -- [, [External =>] EXTERNAL_SYMBOL] 21849 -- [, [Size =>] EXTERNAL_SYMBOL]); 21850 21851 when Pragma_Common_Object 21852 | Pragma_Psect_Object 21853 => 21854 Psect_Object : declare 21855 Args : Args_List (1 .. 3); 21856 Names : constant Name_List (1 .. 3) := ( 21857 Name_Internal, 21858 Name_External, 21859 Name_Size); 21860 21861 Internal : Node_Id renames Args (1); 21862 External : Node_Id renames Args (2); 21863 Size : Node_Id renames Args (3); 21864 21865 Def_Id : Entity_Id; 21866 21867 procedure Check_Arg (Arg : Node_Id); 21868 -- Checks that argument is either a string literal or an 21869 -- identifier, and posts error message if not. 21870 21871 --------------- 21872 -- Check_Arg -- 21873 --------------- 21874 21875 procedure Check_Arg (Arg : Node_Id) is 21876 begin 21877 if not Nkind_In (Original_Node (Arg), 21878 N_String_Literal, 21879 N_Identifier) 21880 then 21881 Error_Pragma_Arg 21882 ("inappropriate argument for pragma %", Arg); 21883 end if; 21884 end Check_Arg; 21885 21886 -- Start of processing for Common_Object/Psect_Object 21887 21888 begin 21889 GNAT_Pragma; 21890 Gather_Associations (Names, Args); 21891 Process_Extended_Import_Export_Internal_Arg (Internal); 21892 21893 Def_Id := Entity (Internal); 21894 21895 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 21896 Error_Pragma_Arg 21897 ("pragma% must designate an object", Internal); 21898 end if; 21899 21900 Check_Arg (Internal); 21901 21902 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then 21903 Error_Pragma_Arg 21904 ("cannot use pragma% for imported/exported object", 21905 Internal); 21906 end if; 21907 21908 if Is_Concurrent_Type (Etype (Internal)) then 21909 Error_Pragma_Arg 21910 ("cannot specify pragma % for task/protected object", 21911 Internal); 21912 end if; 21913 21914 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 21915 or else 21916 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 21917 then 21918 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N); 21919 end if; 21920 21921 if Ekind (Def_Id) = E_Constant then 21922 Error_Pragma_Arg 21923 ("cannot specify pragma % for a constant", Internal); 21924 end if; 21925 21926 if Is_Record_Type (Etype (Internal)) then 21927 declare 21928 Ent : Entity_Id; 21929 Decl : Entity_Id; 21930 21931 begin 21932 Ent := First_Entity (Etype (Internal)); 21933 while Present (Ent) loop 21934 Decl := Declaration_Node (Ent); 21935 21936 if Ekind (Ent) = E_Component 21937 and then Nkind (Decl) = N_Component_Declaration 21938 and then Present (Expression (Decl)) 21939 and then Warn_On_Export_Import 21940 then 21941 Error_Msg_N 21942 ("?x?object for pragma % has defaults", Internal); 21943 exit; 21944 21945 else 21946 Next_Entity (Ent); 21947 end if; 21948 end loop; 21949 end; 21950 end if; 21951 21952 if Present (Size) then 21953 Check_Arg (Size); 21954 end if; 21955 21956 if Present (External) then 21957 Check_Arg_Is_External_Name (External); 21958 end if; 21959 21960 -- If all error tests pass, link pragma on to the rep item chain 21961 21962 Record_Rep_Item (Def_Id, N); 21963 end Psect_Object; 21964 21965 ---------- 21966 -- Pure -- 21967 ---------- 21968 21969 -- pragma Pure [(library_unit_NAME)]; 21970 21971 when Pragma_Pure => Pure : declare 21972 Ent : Entity_Id; 21973 21974 begin 21975 Check_Ada_83_Warning; 21976 21977 -- If the pragma comes from a subprogram instantiation, nothing to 21978 -- check, this can happen at any level of nesting. 21979 21980 if Is_Wrapper_Package (Current_Scope) then 21981 return; 21982 else 21983 Check_Valid_Library_Unit_Pragma; 21984 end if; 21985 21986 if Nkind (N) = N_Null_Statement then 21987 return; 21988 end if; 21989 21990 Ent := Find_Lib_Unit_Name; 21991 21992 -- A pragma that applies to a Ghost entity becomes Ghost for the 21993 -- purposes of legality checks and removal of ignored Ghost code. 21994 21995 Mark_Ghost_Pragma (N, Ent); 21996 21997 if not Debug_Flag_U then 21998 Set_Is_Pure (Ent); 21999 Set_Has_Pragma_Pure (Ent); 22000 22001 if Legacy_Elaboration_Checks then 22002 Set_Suppress_Elaboration_Warnings (Ent); 22003 end if; 22004 end if; 22005 end Pure; 22006 22007 ------------------- 22008 -- Pure_Function -- 22009 ------------------- 22010 22011 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME); 22012 22013 when Pragma_Pure_Function => Pure_Function : declare 22014 Def_Id : Entity_Id; 22015 E : Entity_Id; 22016 E_Id : Node_Id; 22017 Effective : Boolean := False; 22018 Orig_Def : Entity_Id; 22019 Same_Decl : Boolean := False; 22020 22021 begin 22022 GNAT_Pragma; 22023 Check_Arg_Count (1); 22024 Check_Optional_Identifier (Arg1, Name_Entity); 22025 Check_Arg_Is_Local_Name (Arg1); 22026 E_Id := Get_Pragma_Arg (Arg1); 22027 22028 if Etype (E_Id) = Any_Type then 22029 return; 22030 end if; 22031 22032 -- Loop through homonyms (overloadings) of referenced entity 22033 22034 E := Entity (E_Id); 22035 22036 -- A pragma that applies to a Ghost entity becomes Ghost for the 22037 -- purposes of legality checks and removal of ignored Ghost code. 22038 22039 Mark_Ghost_Pragma (N, E); 22040 22041 if Present (E) then 22042 loop 22043 Def_Id := Get_Base_Subprogram (E); 22044 22045 if not Ekind_In (Def_Id, E_Function, 22046 E_Generic_Function, 22047 E_Operator) 22048 then 22049 Error_Pragma_Arg 22050 ("pragma% requires a function name", Arg1); 22051 end if; 22052 22053 -- When we have a generic function we must jump up a level 22054 -- to the declaration of the wrapper package itself. 22055 22056 Orig_Def := Def_Id; 22057 22058 if Is_Generic_Instance (Def_Id) then 22059 while Nkind (Orig_Def) /= N_Package_Declaration loop 22060 Orig_Def := Parent (Orig_Def); 22061 end loop; 22062 end if; 22063 22064 if In_Same_Declarative_Part (Parent (N), Orig_Def) then 22065 Same_Decl := True; 22066 Set_Is_Pure (Def_Id); 22067 22068 if not Has_Pragma_Pure_Function (Def_Id) then 22069 Set_Has_Pragma_Pure_Function (Def_Id); 22070 Effective := True; 22071 end if; 22072 end if; 22073 22074 exit when From_Aspect_Specification (N); 22075 E := Homonym (E); 22076 exit when No (E) or else Scope (E) /= Current_Scope; 22077 end loop; 22078 22079 if not Effective 22080 and then Warn_On_Redundant_Constructs 22081 then 22082 Error_Msg_NE 22083 ("pragma Pure_Function on& is redundant?r?", 22084 N, Entity (E_Id)); 22085 22086 elsif not Same_Decl then 22087 Error_Pragma_Arg 22088 ("pragma% argument must be in same declarative part", 22089 Arg1); 22090 end if; 22091 end if; 22092 end Pure_Function; 22093 22094 -------------------- 22095 -- Queuing_Policy -- 22096 -------------------- 22097 22098 -- pragma Queuing_Policy (policy_IDENTIFIER); 22099 22100 when Pragma_Queuing_Policy => declare 22101 QP : Character; 22102 22103 begin 22104 Check_Ada_83_Warning; 22105 Check_Arg_Count (1); 22106 Check_No_Identifiers; 22107 Check_Arg_Is_Queuing_Policy (Arg1); 22108 Check_Valid_Configuration_Pragma; 22109 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 22110 QP := Fold_Upper (Name_Buffer (1)); 22111 22112 if Queuing_Policy /= ' ' 22113 and then Queuing_Policy /= QP 22114 then 22115 Error_Msg_Sloc := Queuing_Policy_Sloc; 22116 Error_Pragma ("queuing policy incompatible with policy#"); 22117 22118 -- Set new policy, but always preserve System_Location since we 22119 -- like the error message with the run time name. 22120 22121 else 22122 Queuing_Policy := QP; 22123 22124 if Queuing_Policy_Sloc /= System_Location then 22125 Queuing_Policy_Sloc := Loc; 22126 end if; 22127 end if; 22128 end; 22129 22130 -------------- 22131 -- Rational -- 22132 -------------- 22133 22134 -- pragma Rational, for compatibility with foreign compiler 22135 22136 when Pragma_Rational => 22137 Set_Rational_Profile; 22138 22139 --------------------- 22140 -- Refined_Depends -- 22141 --------------------- 22142 22143 -- pragma Refined_Depends (DEPENDENCY_RELATION); 22144 22145 -- DEPENDENCY_RELATION ::= 22146 -- null 22147 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}) 22148 22149 -- DEPENDENCY_CLAUSE ::= 22150 -- OUTPUT_LIST =>[+] INPUT_LIST 22151 -- | NULL_DEPENDENCY_CLAUSE 22152 22153 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 22154 22155 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 22156 22157 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 22158 22159 -- OUTPUT ::= NAME | FUNCTION_RESULT 22160 -- INPUT ::= NAME 22161 22162 -- where FUNCTION_RESULT is a function Result attribute_reference 22163 22164 -- Characteristics: 22165 22166 -- * Analysis - The annotation undergoes initial checks to verify 22167 -- the legal placement and context. Secondary checks fully analyze 22168 -- the dependency clauses/global list in: 22169 22170 -- Analyze_Refined_Depends_In_Decl_Part 22171 22172 -- * Expansion - None. 22173 22174 -- * Template - The annotation utilizes the generic template of the 22175 -- related subprogram body. 22176 22177 -- * Globals - Capture of global references must occur after full 22178 -- analysis. 22179 22180 -- * Instance - The annotation is instantiated automatically when 22181 -- the related generic subprogram body is instantiated. 22182 22183 when Pragma_Refined_Depends => Refined_Depends : declare 22184 Body_Id : Entity_Id; 22185 Legal : Boolean; 22186 Spec_Id : Entity_Id; 22187 22188 begin 22189 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 22190 22191 if Legal then 22192 22193 -- Chain the pragma on the contract for further processing by 22194 -- Analyze_Refined_Depends_In_Decl_Part. 22195 22196 Add_Contract_Item (N, Body_Id); 22197 22198 -- The legality checks of pragmas Refined_Depends and 22199 -- Refined_Global are affected by the SPARK mode in effect and 22200 -- the volatility of the context. In addition these two pragmas 22201 -- are subject to an inherent order: 22202 22203 -- 1) Refined_Global 22204 -- 2) Refined_Depends 22205 22206 -- Analyze all these pragmas in the order outlined above 22207 22208 Analyze_If_Present (Pragma_SPARK_Mode); 22209 Analyze_If_Present (Pragma_Volatile_Function); 22210 Analyze_If_Present (Pragma_Refined_Global); 22211 Analyze_Refined_Depends_In_Decl_Part (N); 22212 end if; 22213 end Refined_Depends; 22214 22215 -------------------- 22216 -- Refined_Global -- 22217 -------------------- 22218 22219 -- pragma Refined_Global (GLOBAL_SPECIFICATION); 22220 22221 -- GLOBAL_SPECIFICATION ::= 22222 -- null 22223 -- | (GLOBAL_LIST) 22224 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}) 22225 22226 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 22227 22228 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 22229 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 22230 -- GLOBAL_ITEM ::= NAME 22231 22232 -- Characteristics: 22233 22234 -- * Analysis - The annotation undergoes initial checks to verify 22235 -- the legal placement and context. Secondary checks fully analyze 22236 -- the dependency clauses/global list in: 22237 22238 -- Analyze_Refined_Global_In_Decl_Part 22239 22240 -- * Expansion - None. 22241 22242 -- * Template - The annotation utilizes the generic template of the 22243 -- related subprogram body. 22244 22245 -- * Globals - Capture of global references must occur after full 22246 -- analysis. 22247 22248 -- * Instance - The annotation is instantiated automatically when 22249 -- the related generic subprogram body is instantiated. 22250 22251 when Pragma_Refined_Global => Refined_Global : declare 22252 Body_Id : Entity_Id; 22253 Legal : Boolean; 22254 Spec_Id : Entity_Id; 22255 22256 begin 22257 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 22258 22259 if Legal then 22260 22261 -- Chain the pragma on the contract for further processing by 22262 -- Analyze_Refined_Global_In_Decl_Part. 22263 22264 Add_Contract_Item (N, Body_Id); 22265 22266 -- The legality checks of pragmas Refined_Depends and 22267 -- Refined_Global are affected by the SPARK mode in effect and 22268 -- the volatility of the context. In addition these two pragmas 22269 -- are subject to an inherent order: 22270 22271 -- 1) Refined_Global 22272 -- 2) Refined_Depends 22273 22274 -- Analyze all these pragmas in the order outlined above 22275 22276 Analyze_If_Present (Pragma_SPARK_Mode); 22277 Analyze_If_Present (Pragma_Volatile_Function); 22278 Analyze_Refined_Global_In_Decl_Part (N); 22279 Analyze_If_Present (Pragma_Refined_Depends); 22280 end if; 22281 end Refined_Global; 22282 22283 ------------------ 22284 -- Refined_Post -- 22285 ------------------ 22286 22287 -- pragma Refined_Post (boolean_EXPRESSION); 22288 22289 -- Characteristics: 22290 22291 -- * Analysis - The annotation is fully analyzed immediately upon 22292 -- elaboration as it cannot forward reference entities. 22293 22294 -- * Expansion - The annotation is expanded during the expansion of 22295 -- the related subprogram body contract as performed in: 22296 22297 -- Expand_Subprogram_Contract 22298 22299 -- * Template - The annotation utilizes the generic template of the 22300 -- related subprogram body. 22301 22302 -- * Globals - Capture of global references must occur after full 22303 -- analysis. 22304 22305 -- * Instance - The annotation is instantiated automatically when 22306 -- the related generic subprogram body is instantiated. 22307 22308 when Pragma_Refined_Post => Refined_Post : declare 22309 Body_Id : Entity_Id; 22310 Legal : Boolean; 22311 Spec_Id : Entity_Id; 22312 22313 begin 22314 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 22315 22316 -- Fully analyze the pragma when it appears inside a subprogram 22317 -- body because it cannot benefit from forward references. 22318 22319 if Legal then 22320 22321 -- Chain the pragma on the contract for completeness 22322 22323 Add_Contract_Item (N, Body_Id); 22324 22325 -- The legality checks of pragma Refined_Post are affected by 22326 -- the SPARK mode in effect and the volatility of the context. 22327 -- Analyze all pragmas in a specific order. 22328 22329 Analyze_If_Present (Pragma_SPARK_Mode); 22330 Analyze_If_Present (Pragma_Volatile_Function); 22331 Analyze_Pre_Post_Condition_In_Decl_Part (N); 22332 22333 -- Currently it is not possible to inline pre/postconditions on 22334 -- a subprogram subject to pragma Inline_Always. 22335 22336 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 22337 end if; 22338 end Refined_Post; 22339 22340 ------------------- 22341 -- Refined_State -- 22342 ------------------- 22343 22344 -- pragma Refined_State (REFINEMENT_LIST); 22345 22346 -- REFINEMENT_LIST ::= 22347 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE}) 22348 22349 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST 22350 22351 -- CONSTITUENT_LIST ::= 22352 -- null 22353 -- | CONSTITUENT 22354 -- | (CONSTITUENT {, CONSTITUENT}) 22355 22356 -- CONSTITUENT ::= object_NAME | state_NAME 22357 22358 -- Characteristics: 22359 22360 -- * Analysis - The annotation undergoes initial checks to verify 22361 -- the legal placement and context. Secondary checks preanalyze the 22362 -- refinement clauses in: 22363 22364 -- Analyze_Refined_State_In_Decl_Part 22365 22366 -- * Expansion - None. 22367 22368 -- * Template - The annotation utilizes the template of the related 22369 -- package body. 22370 22371 -- * Globals - Capture of global references must occur after full 22372 -- analysis. 22373 22374 -- * Instance - The annotation is instantiated automatically when 22375 -- the related generic package body is instantiated. 22376 22377 when Pragma_Refined_State => Refined_State : declare 22378 Pack_Decl : Node_Id; 22379 Spec_Id : Entity_Id; 22380 22381 begin 22382 GNAT_Pragma; 22383 Check_No_Identifiers; 22384 Check_Arg_Count (1); 22385 22386 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 22387 22388 if Nkind (Pack_Decl) /= N_Package_Body then 22389 Pragma_Misplaced; 22390 return; 22391 end if; 22392 22393 Spec_Id := Corresponding_Spec (Pack_Decl); 22394 22395 -- A pragma that applies to a Ghost entity becomes Ghost for the 22396 -- purposes of legality checks and removal of ignored Ghost code. 22397 22398 Mark_Ghost_Pragma (N, Spec_Id); 22399 22400 -- Chain the pragma on the contract for further processing by 22401 -- Analyze_Refined_State_In_Decl_Part. 22402 22403 Add_Contract_Item (N, Defining_Entity (Pack_Decl)); 22404 22405 -- The legality checks of pragma Refined_State are affected by the 22406 -- SPARK mode in effect. Analyze all pragmas in a specific order. 22407 22408 Analyze_If_Present (Pragma_SPARK_Mode); 22409 22410 -- State refinement is allowed only when the corresponding package 22411 -- declaration has non-null pragma Abstract_State. Refinement not 22412 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)). 22413 22414 if SPARK_Mode /= Off 22415 and then 22416 (No (Abstract_States (Spec_Id)) 22417 or else Has_Null_Abstract_State (Spec_Id)) 22418 then 22419 Error_Msg_NE 22420 ("useless refinement, package & does not define abstract " 22421 & "states", N, Spec_Id); 22422 return; 22423 end if; 22424 end Refined_State; 22425 22426 ----------------------- 22427 -- Relative_Deadline -- 22428 ----------------------- 22429 22430 -- pragma Relative_Deadline (time_span_EXPRESSION); 22431 22432 when Pragma_Relative_Deadline => Relative_Deadline : declare 22433 P : constant Node_Id := Parent (N); 22434 Arg : Node_Id; 22435 22436 begin 22437 Ada_2005_Pragma; 22438 Check_No_Identifiers; 22439 Check_Arg_Count (1); 22440 22441 Arg := Get_Pragma_Arg (Arg1); 22442 22443 -- The expression must be analyzed in the special manner described 22444 -- in "Handling of Default and Per-Object Expressions" in sem.ads. 22445 22446 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); 22447 22448 -- Subprogram case 22449 22450 if Nkind (P) = N_Subprogram_Body then 22451 Check_In_Main_Program; 22452 22453 -- Only Task and subprogram cases allowed 22454 22455 elsif Nkind (P) /= N_Task_Definition then 22456 Pragma_Misplaced; 22457 end if; 22458 22459 -- Check duplicate pragma before we set the corresponding flag 22460 22461 if Has_Relative_Deadline_Pragma (P) then 22462 Error_Pragma ("duplicate pragma% not allowed"); 22463 end if; 22464 22465 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that 22466 -- Relative_Deadline pragma node cannot be inserted in the Rep 22467 -- Item chain of Ent since it is rewritten by the expander as a 22468 -- procedure call statement that will break the chain. 22469 22470 Set_Has_Relative_Deadline_Pragma (P); 22471 end Relative_Deadline; 22472 22473 ------------------------ 22474 -- Remote_Access_Type -- 22475 ------------------------ 22476 22477 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME); 22478 22479 when Pragma_Remote_Access_Type => Remote_Access_Type : declare 22480 E : Entity_Id; 22481 22482 begin 22483 GNAT_Pragma; 22484 Check_Arg_Count (1); 22485 Check_Optional_Identifier (Arg1, Name_Entity); 22486 Check_Arg_Is_Local_Name (Arg1); 22487 22488 E := Entity (Get_Pragma_Arg (Arg1)); 22489 22490 -- A pragma that applies to a Ghost entity becomes Ghost for the 22491 -- purposes of legality checks and removal of ignored Ghost code. 22492 22493 Mark_Ghost_Pragma (N, E); 22494 22495 if Nkind (Parent (E)) = N_Formal_Type_Declaration 22496 and then Ekind (E) = E_General_Access_Type 22497 and then Is_Class_Wide_Type (Directly_Designated_Type (E)) 22498 and then Scope (Root_Type (Directly_Designated_Type (E))) 22499 = Scope (E) 22500 and then Is_Valid_Remote_Object_Type 22501 (Root_Type (Directly_Designated_Type (E))) 22502 then 22503 Set_Is_Remote_Types (E); 22504 22505 else 22506 Error_Pragma_Arg 22507 ("pragma% applies only to formal access-to-class-wide types", 22508 Arg1); 22509 end if; 22510 end Remote_Access_Type; 22511 22512 --------------------------- 22513 -- Remote_Call_Interface -- 22514 --------------------------- 22515 22516 -- pragma Remote_Call_Interface [(library_unit_NAME)]; 22517 22518 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare 22519 Cunit_Node : Node_Id; 22520 Cunit_Ent : Entity_Id; 22521 K : Node_Kind; 22522 22523 begin 22524 Check_Ada_83_Warning; 22525 Check_Valid_Library_Unit_Pragma; 22526 22527 if Nkind (N) = N_Null_Statement then 22528 return; 22529 end if; 22530 22531 Cunit_Node := Cunit (Current_Sem_Unit); 22532 K := Nkind (Unit (Cunit_Node)); 22533 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 22534 22535 -- A pragma that applies to a Ghost entity becomes Ghost for the 22536 -- purposes of legality checks and removal of ignored Ghost code. 22537 22538 Mark_Ghost_Pragma (N, Cunit_Ent); 22539 22540 if K = N_Package_Declaration 22541 or else K = N_Generic_Package_Declaration 22542 or else K = N_Subprogram_Declaration 22543 or else K = N_Generic_Subprogram_Declaration 22544 or else (K = N_Subprogram_Body 22545 and then Acts_As_Spec (Unit (Cunit_Node))) 22546 then 22547 null; 22548 else 22549 Error_Pragma ( 22550 "pragma% must apply to package or subprogram declaration"); 22551 end if; 22552 22553 Set_Is_Remote_Call_Interface (Cunit_Ent); 22554 end Remote_Call_Interface; 22555 22556 ------------------ 22557 -- Remote_Types -- 22558 ------------------ 22559 22560 -- pragma Remote_Types [(library_unit_NAME)]; 22561 22562 when Pragma_Remote_Types => Remote_Types : declare 22563 Cunit_Node : Node_Id; 22564 Cunit_Ent : Entity_Id; 22565 22566 begin 22567 Check_Ada_83_Warning; 22568 Check_Valid_Library_Unit_Pragma; 22569 22570 if Nkind (N) = N_Null_Statement then 22571 return; 22572 end if; 22573 22574 Cunit_Node := Cunit (Current_Sem_Unit); 22575 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 22576 22577 -- A pragma that applies to a Ghost entity becomes Ghost for the 22578 -- purposes of legality checks and removal of ignored Ghost code. 22579 22580 Mark_Ghost_Pragma (N, Cunit_Ent); 22581 22582 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 22583 N_Generic_Package_Declaration) 22584 then 22585 Error_Pragma 22586 ("pragma% can only apply to a package declaration"); 22587 end if; 22588 22589 Set_Is_Remote_Types (Cunit_Ent); 22590 end Remote_Types; 22591 22592 --------------- 22593 -- Ravenscar -- 22594 --------------- 22595 22596 -- pragma Ravenscar; 22597 22598 when Pragma_Ravenscar => 22599 GNAT_Pragma; 22600 Check_Arg_Count (0); 22601 Check_Valid_Configuration_Pragma; 22602 Set_Ravenscar_Profile (Ravenscar, N); 22603 22604 if Warn_On_Obsolescent_Feature then 22605 Error_Msg_N 22606 ("pragma Ravenscar is an obsolescent feature?j?", N); 22607 Error_Msg_N 22608 ("|use pragma Profile (Ravenscar) instead?j?", N); 22609 end if; 22610 22611 ------------------------- 22612 -- Restricted_Run_Time -- 22613 ------------------------- 22614 22615 -- pragma Restricted_Run_Time; 22616 22617 when Pragma_Restricted_Run_Time => 22618 GNAT_Pragma; 22619 Check_Arg_Count (0); 22620 Check_Valid_Configuration_Pragma; 22621 Set_Profile_Restrictions 22622 (Restricted, N, Warn => Treat_Restrictions_As_Warnings); 22623 22624 if Warn_On_Obsolescent_Feature then 22625 Error_Msg_N 22626 ("pragma Restricted_Run_Time is an obsolescent feature?j?", 22627 N); 22628 Error_Msg_N 22629 ("|use pragma Profile (Restricted) instead?j?", N); 22630 end if; 22631 22632 ------------------ 22633 -- Restrictions -- 22634 ------------------ 22635 22636 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 22637 22638 -- RESTRICTION ::= 22639 -- restriction_IDENTIFIER 22640 -- | restriction_parameter_IDENTIFIER => EXPRESSION 22641 22642 when Pragma_Restrictions => 22643 Process_Restrictions_Or_Restriction_Warnings 22644 (Warn => Treat_Restrictions_As_Warnings); 22645 22646 -------------------------- 22647 -- Restriction_Warnings -- 22648 -------------------------- 22649 22650 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 22651 22652 -- RESTRICTION ::= 22653 -- restriction_IDENTIFIER 22654 -- | restriction_parameter_IDENTIFIER => EXPRESSION 22655 22656 when Pragma_Restriction_Warnings => 22657 GNAT_Pragma; 22658 Process_Restrictions_Or_Restriction_Warnings (Warn => True); 22659 22660 ---------------- 22661 -- Reviewable -- 22662 ---------------- 22663 22664 -- pragma Reviewable; 22665 22666 when Pragma_Reviewable => 22667 Check_Ada_83_Warning; 22668 Check_Arg_Count (0); 22669 22670 -- Call dummy debugging function rv. This is done to assist front 22671 -- end debugging. By placing a Reviewable pragma in the source 22672 -- program, a breakpoint on rv catches this place in the source, 22673 -- allowing convenient stepping to the point of interest. 22674 22675 rv; 22676 22677 -------------------------- 22678 -- Secondary_Stack_Size -- 22679 -------------------------- 22680 22681 -- pragma Secondary_Stack_Size (EXPRESSION); 22682 22683 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare 22684 P : constant Node_Id := Parent (N); 22685 Arg : Node_Id; 22686 Ent : Entity_Id; 22687 22688 begin 22689 GNAT_Pragma; 22690 Check_No_Identifiers; 22691 Check_Arg_Count (1); 22692 22693 if Nkind (P) = N_Task_Definition then 22694 Arg := Get_Pragma_Arg (Arg1); 22695 Ent := Defining_Identifier (Parent (P)); 22696 22697 -- The expression must be analyzed in the special manner 22698 -- described in "Handling of Default Expressions" in sem.ads. 22699 22700 Preanalyze_Spec_Expression (Arg, Any_Integer); 22701 22702 -- The pragma cannot appear if the No_Secondary_Stack 22703 -- restriction is in effect. 22704 22705 Check_Restriction (No_Secondary_Stack, Arg); 22706 22707 -- Anything else is incorrect 22708 22709 else 22710 Pragma_Misplaced; 22711 end if; 22712 22713 -- Check duplicate pragma before we chain the pragma in the Rep 22714 -- Item chain of Ent. 22715 22716 Check_Duplicate_Pragma (Ent); 22717 Record_Rep_Item (Ent, N); 22718 end Secondary_Stack_Size; 22719 22720 -------------------------- 22721 -- Short_Circuit_And_Or -- 22722 -------------------------- 22723 22724 -- pragma Short_Circuit_And_Or; 22725 22726 when Pragma_Short_Circuit_And_Or => 22727 GNAT_Pragma; 22728 Check_Arg_Count (0); 22729 Check_Valid_Configuration_Pragma; 22730 Short_Circuit_And_Or := True; 22731 22732 ------------------- 22733 -- Share_Generic -- 22734 ------------------- 22735 22736 -- pragma Share_Generic (GNAME {, GNAME}); 22737 22738 -- GNAME ::= generic_unit_NAME | generic_instance_NAME 22739 22740 when Pragma_Share_Generic => 22741 GNAT_Pragma; 22742 Process_Generic_List; 22743 22744 ------------ 22745 -- Shared -- 22746 ------------ 22747 22748 -- pragma Shared (LOCAL_NAME); 22749 22750 when Pragma_Shared => 22751 GNAT_Pragma; 22752 Process_Atomic_Independent_Shared_Volatile; 22753 22754 -------------------- 22755 -- Shared_Passive -- 22756 -------------------- 22757 22758 -- pragma Shared_Passive [(library_unit_NAME)]; 22759 22760 -- Set the flag Is_Shared_Passive of program unit name entity 22761 22762 when Pragma_Shared_Passive => Shared_Passive : declare 22763 Cunit_Node : Node_Id; 22764 Cunit_Ent : Entity_Id; 22765 22766 begin 22767 Check_Ada_83_Warning; 22768 Check_Valid_Library_Unit_Pragma; 22769 22770 if Nkind (N) = N_Null_Statement then 22771 return; 22772 end if; 22773 22774 Cunit_Node := Cunit (Current_Sem_Unit); 22775 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 22776 22777 -- A pragma that applies to a Ghost entity becomes Ghost for the 22778 -- purposes of legality checks and removal of ignored Ghost code. 22779 22780 Mark_Ghost_Pragma (N, Cunit_Ent); 22781 22782 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 22783 N_Generic_Package_Declaration) 22784 then 22785 Error_Pragma 22786 ("pragma% can only apply to a package declaration"); 22787 end if; 22788 22789 Set_Is_Shared_Passive (Cunit_Ent); 22790 end Shared_Passive; 22791 22792 ----------------------- 22793 -- Short_Descriptors -- 22794 ----------------------- 22795 22796 -- pragma Short_Descriptors; 22797 22798 -- Recognize and validate, but otherwise ignore 22799 22800 when Pragma_Short_Descriptors => 22801 GNAT_Pragma; 22802 Check_Arg_Count (0); 22803 Check_Valid_Configuration_Pragma; 22804 22805 ------------------------------ 22806 -- Simple_Storage_Pool_Type -- 22807 ------------------------------ 22808 22809 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME); 22810 22811 when Pragma_Simple_Storage_Pool_Type => 22812 Simple_Storage_Pool_Type : declare 22813 Typ : Entity_Id; 22814 Type_Id : Node_Id; 22815 22816 begin 22817 GNAT_Pragma; 22818 Check_Arg_Count (1); 22819 Check_Arg_Is_Library_Level_Local_Name (Arg1); 22820 22821 Type_Id := Get_Pragma_Arg (Arg1); 22822 Find_Type (Type_Id); 22823 Typ := Entity (Type_Id); 22824 22825 if Typ = Any_Type then 22826 return; 22827 end if; 22828 22829 -- A pragma that applies to a Ghost entity becomes Ghost for the 22830 -- purposes of legality checks and removal of ignored Ghost code. 22831 22832 Mark_Ghost_Pragma (N, Typ); 22833 22834 -- We require the pragma to apply to a type declared in a package 22835 -- declaration, but not (immediately) within a package body. 22836 22837 if Ekind (Current_Scope) /= E_Package 22838 or else In_Package_Body (Current_Scope) 22839 then 22840 Error_Pragma 22841 ("pragma% can only apply to type declared immediately " 22842 & "within a package declaration"); 22843 end if; 22844 22845 -- A simple storage pool type must be an immutably limited record 22846 -- or private type. If the pragma is given for a private type, 22847 -- the full type is similarly restricted (which is checked later 22848 -- in Freeze_Entity). 22849 22850 if Is_Record_Type (Typ) 22851 and then not Is_Limited_View (Typ) 22852 then 22853 Error_Pragma 22854 ("pragma% can only apply to explicitly limited record type"); 22855 22856 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then 22857 Error_Pragma 22858 ("pragma% can only apply to a private type that is limited"); 22859 22860 elsif not Is_Record_Type (Typ) 22861 and then not Is_Private_Type (Typ) 22862 then 22863 Error_Pragma 22864 ("pragma% can only apply to limited record or private type"); 22865 end if; 22866 22867 Record_Rep_Item (Typ, N); 22868 end Simple_Storage_Pool_Type; 22869 22870 ---------------------- 22871 -- Source_File_Name -- 22872 ---------------------- 22873 22874 -- There are five forms for this pragma: 22875 22876 -- pragma Source_File_Name ( 22877 -- [UNIT_NAME =>] unit_NAME, 22878 -- BODY_FILE_NAME => STRING_LITERAL 22879 -- [, [INDEX =>] INTEGER_LITERAL]); 22880 22881 -- pragma Source_File_Name ( 22882 -- [UNIT_NAME =>] unit_NAME, 22883 -- SPEC_FILE_NAME => STRING_LITERAL 22884 -- [, [INDEX =>] INTEGER_LITERAL]); 22885 22886 -- pragma Source_File_Name ( 22887 -- BODY_FILE_NAME => STRING_LITERAL 22888 -- [, DOT_REPLACEMENT => STRING_LITERAL] 22889 -- [, CASING => CASING_SPEC]); 22890 22891 -- pragma Source_File_Name ( 22892 -- SPEC_FILE_NAME => STRING_LITERAL 22893 -- [, DOT_REPLACEMENT => STRING_LITERAL] 22894 -- [, CASING => CASING_SPEC]); 22895 22896 -- pragma Source_File_Name ( 22897 -- SUBUNIT_FILE_NAME => STRING_LITERAL 22898 -- [, DOT_REPLACEMENT => STRING_LITERAL] 22899 -- [, CASING => CASING_SPEC]); 22900 22901 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 22902 22903 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 22904 -- Source_File_Name (SFN), however their usage is exclusive: SFN can 22905 -- only be used when no project file is used, while SFNP can only be 22906 -- used when a project file is used. 22907 22908 -- No processing here. Processing was completed during parsing, since 22909 -- we need to have file names set as early as possible. Units are 22910 -- loaded well before semantic processing starts. 22911 22912 -- The only processing we defer to this point is the check for 22913 -- correct placement. 22914 22915 when Pragma_Source_File_Name => 22916 GNAT_Pragma; 22917 Check_Valid_Configuration_Pragma; 22918 22919 ------------------------------ 22920 -- Source_File_Name_Project -- 22921 ------------------------------ 22922 22923 -- See Source_File_Name for syntax 22924 22925 -- No processing here. Processing was completed during parsing, since 22926 -- we need to have file names set as early as possible. Units are 22927 -- loaded well before semantic processing starts. 22928 22929 -- The only processing we defer to this point is the check for 22930 -- correct placement. 22931 22932 when Pragma_Source_File_Name_Project => 22933 GNAT_Pragma; 22934 Check_Valid_Configuration_Pragma; 22935 22936 -- Check that a pragma Source_File_Name_Project is used only in a 22937 -- configuration pragmas file. 22938 22939 -- Pragmas Source_File_Name_Project should only be generated by 22940 -- the Project Manager in configuration pragmas files. 22941 22942 -- This is really an ugly test. It seems to depend on some 22943 -- accidental and undocumented property. At the very least it 22944 -- needs to be documented, but it would be better to have a 22945 -- clean way of testing if we are in a configuration file??? 22946 22947 if Present (Parent (N)) then 22948 Error_Pragma 22949 ("pragma% can only appear in a configuration pragmas file"); 22950 end if; 22951 22952 ---------------------- 22953 -- Source_Reference -- 22954 ---------------------- 22955 22956 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); 22957 22958 -- Nothing to do, all processing completed in Par.Prag, since we need 22959 -- the information for possible parser messages that are output. 22960 22961 when Pragma_Source_Reference => 22962 GNAT_Pragma; 22963 22964 ---------------- 22965 -- SPARK_Mode -- 22966 ---------------- 22967 22968 -- pragma SPARK_Mode [(On | Off)]; 22969 22970 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare 22971 Mode_Id : SPARK_Mode_Type; 22972 22973 procedure Check_Pragma_Conformance 22974 (Context_Pragma : Node_Id; 22975 Entity : Entity_Id; 22976 Entity_Pragma : Node_Id); 22977 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode 22978 -- conformance of pragma N depending the following scenarios: 22979 -- 22980 -- If pragma Context_Pragma is not Empty, verify that pragma N is 22981 -- compatible with the pragma Context_Pragma that was inherited 22982 -- from the context: 22983 -- * If the mode of Context_Pragma is ON, then the new mode can 22984 -- be anything. 22985 -- * If the mode of Context_Pragma is OFF, then the only allowed 22986 -- new mode is also OFF. Emit error if this is not the case. 22987 -- 22988 -- If Entity is not Empty, verify that pragma N is compatible with 22989 -- pragma Entity_Pragma that belongs to Entity. 22990 -- * If Entity_Pragma is Empty, always issue an error as this 22991 -- corresponds to the case where a previous section of Entity 22992 -- has no SPARK_Mode set. 22993 -- * If the mode of Entity_Pragma is ON, then the new mode can 22994 -- be anything. 22995 -- * If the mode of Entity_Pragma is OFF, then the only allowed 22996 -- new mode is also OFF. Emit error if this is not the case. 22997 22998 procedure Check_Library_Level_Entity (E : Entity_Id); 22999 -- Subsidiary to routines Process_xxx. Verify that the related 23000 -- entity E subject to pragma SPARK_Mode is library-level. 23001 23002 procedure Process_Body (Decl : Node_Id); 23003 -- Verify the legality of pragma SPARK_Mode when it appears as the 23004 -- top of the body declarations of entry, package, protected unit, 23005 -- subprogram or task unit body denoted by Decl. 23006 23007 procedure Process_Overloadable (Decl : Node_Id); 23008 -- Verify the legality of pragma SPARK_Mode when it applies to an 23009 -- entry or [generic] subprogram declaration denoted by Decl. 23010 23011 procedure Process_Private_Part (Decl : Node_Id); 23012 -- Verify the legality of pragma SPARK_Mode when it appears at the 23013 -- top of the private declarations of a package spec, protected or 23014 -- task unit declaration denoted by Decl. 23015 23016 procedure Process_Statement_Part (Decl : Node_Id); 23017 -- Verify the legality of pragma SPARK_Mode when it appears at the 23018 -- top of the statement sequence of a package body denoted by node 23019 -- Decl. 23020 23021 procedure Process_Visible_Part (Decl : Node_Id); 23022 -- Verify the legality of pragma SPARK_Mode when it appears at the 23023 -- top of the visible declarations of a package spec, protected or 23024 -- task unit declaration denoted by Decl. The routine is also used 23025 -- on protected or task units declared without a definition. 23026 23027 procedure Set_SPARK_Context; 23028 -- Subsidiary to routines Process_xxx. Set the global variables 23029 -- which represent the mode of the context from pragma N. Ensure 23030 -- that Dynamic_Elaboration_Checks are off if the new mode is On. 23031 23032 ------------------------------ 23033 -- Check_Pragma_Conformance -- 23034 ------------------------------ 23035 23036 procedure Check_Pragma_Conformance 23037 (Context_Pragma : Node_Id; 23038 Entity : Entity_Id; 23039 Entity_Pragma : Node_Id) 23040 is 23041 Err_Id : Entity_Id; 23042 Err_N : Node_Id; 23043 23044 begin 23045 -- The current pragma may appear without an argument. If this 23046 -- is the case, associate all error messages with the pragma 23047 -- itself. 23048 23049 if Present (Arg1) then 23050 Err_N := Arg1; 23051 else 23052 Err_N := N; 23053 end if; 23054 23055 -- The mode of the current pragma is compared against that of 23056 -- an enclosing context. 23057 23058 if Present (Context_Pragma) then 23059 pragma Assert (Nkind (Context_Pragma) = N_Pragma); 23060 23061 -- Issue an error if the new mode is less restrictive than 23062 -- that of the context. 23063 23064 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off 23065 and then Get_SPARK_Mode_From_Annotation (N) = On 23066 then 23067 Error_Msg_N 23068 ("cannot change SPARK_Mode from Off to On", Err_N); 23069 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); 23070 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N); 23071 raise Pragma_Exit; 23072 end if; 23073 end if; 23074 23075 -- The mode of the current pragma is compared against that of 23076 -- an initial package, protected type, subprogram or task type 23077 -- declaration. 23078 23079 if Present (Entity) then 23080 23081 -- A simple protected or task type is transformed into an 23082 -- anonymous type whose name cannot be used to issue error 23083 -- messages. Recover the original entity of the type. 23084 23085 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then 23086 Err_Id := 23087 Defining_Entity 23088 (Original_Node (Unit_Declaration_Node (Entity))); 23089 else 23090 Err_Id := Entity; 23091 end if; 23092 23093 -- Both the initial declaration and the completion carry 23094 -- SPARK_Mode pragmas. 23095 23096 if Present (Entity_Pragma) then 23097 pragma Assert (Nkind (Entity_Pragma) = N_Pragma); 23098 23099 -- Issue an error if the new mode is less restrictive 23100 -- than that of the initial declaration. 23101 23102 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off 23103 and then Get_SPARK_Mode_From_Annotation (N) = On 23104 then 23105 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); 23106 Error_Msg_Sloc := Sloc (Entity_Pragma); 23107 Error_Msg_NE 23108 ("\value Off was set for SPARK_Mode on&#", 23109 Err_N, Err_Id); 23110 raise Pragma_Exit; 23111 end if; 23112 23113 -- Otherwise the initial declaration lacks a SPARK_Mode 23114 -- pragma in which case the current pragma is illegal as 23115 -- it cannot "complete". 23116 23117 else 23118 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); 23119 Error_Msg_Sloc := Sloc (Err_Id); 23120 Error_Msg_NE 23121 ("\no value was set for SPARK_Mode on&#", 23122 Err_N, Err_Id); 23123 raise Pragma_Exit; 23124 end if; 23125 end if; 23126 end Check_Pragma_Conformance; 23127 23128 -------------------------------- 23129 -- Check_Library_Level_Entity -- 23130 -------------------------------- 23131 23132 procedure Check_Library_Level_Entity (E : Entity_Id) is 23133 procedure Add_Entity_To_Name_Buffer; 23134 -- Add the E_Kind of entity E to the name buffer 23135 23136 ------------------------------- 23137 -- Add_Entity_To_Name_Buffer -- 23138 ------------------------------- 23139 23140 procedure Add_Entity_To_Name_Buffer is 23141 begin 23142 if Ekind_In (E, E_Entry, E_Entry_Family) then 23143 Add_Str_To_Name_Buffer ("entry"); 23144 23145 elsif Ekind_In (E, E_Generic_Package, 23146 E_Package, 23147 E_Package_Body) 23148 then 23149 Add_Str_To_Name_Buffer ("package"); 23150 23151 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then 23152 Add_Str_To_Name_Buffer ("protected type"); 23153 23154 elsif Ekind_In (E, E_Function, 23155 E_Generic_Function, 23156 E_Generic_Procedure, 23157 E_Procedure, 23158 E_Subprogram_Body) 23159 then 23160 Add_Str_To_Name_Buffer ("subprogram"); 23161 23162 else 23163 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type)); 23164 Add_Str_To_Name_Buffer ("task type"); 23165 end if; 23166 end Add_Entity_To_Name_Buffer; 23167 23168 -- Local variables 23169 23170 Msg_1 : constant String := "incorrect placement of pragma%"; 23171 Msg_2 : Name_Id; 23172 23173 -- Start of processing for Check_Library_Level_Entity 23174 23175 begin 23176 if not Is_Library_Level_Entity (E) then 23177 Error_Msg_Name_1 := Pname; 23178 Error_Msg_N (Fix_Error (Msg_1), N); 23179 23180 Name_Len := 0; 23181 Add_Str_To_Name_Buffer ("\& is not a library-level "); 23182 Add_Entity_To_Name_Buffer; 23183 23184 Msg_2 := Name_Find; 23185 Error_Msg_NE (Get_Name_String (Msg_2), N, E); 23186 23187 raise Pragma_Exit; 23188 end if; 23189 end Check_Library_Level_Entity; 23190 23191 ------------------ 23192 -- Process_Body -- 23193 ------------------ 23194 23195 procedure Process_Body (Decl : Node_Id) is 23196 Body_Id : constant Entity_Id := Defining_Entity (Decl); 23197 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); 23198 23199 begin 23200 -- Ignore pragma when applied to the special body created for 23201 -- inlining, recognized by its internal name _Parent. 23202 23203 if Chars (Body_Id) = Name_uParent then 23204 return; 23205 end if; 23206 23207 Check_Library_Level_Entity (Body_Id); 23208 23209 -- For entry bodies, verify the legality against: 23210 -- * The mode of the context 23211 -- * The mode of the spec (if any) 23212 23213 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then 23214 23215 -- A stand-alone subprogram body 23216 23217 if Body_Id = Spec_Id then 23218 Check_Pragma_Conformance 23219 (Context_Pragma => SPARK_Pragma (Body_Id), 23220 Entity => Empty, 23221 Entity_Pragma => Empty); 23222 23223 -- An entry or subprogram body that completes a previous 23224 -- declaration. 23225 23226 else 23227 Check_Pragma_Conformance 23228 (Context_Pragma => SPARK_Pragma (Body_Id), 23229 Entity => Spec_Id, 23230 Entity_Pragma => SPARK_Pragma (Spec_Id)); 23231 end if; 23232 23233 Set_SPARK_Context; 23234 Set_SPARK_Pragma (Body_Id, N); 23235 Set_SPARK_Pragma_Inherited (Body_Id, False); 23236 23237 -- For package bodies, verify the legality against: 23238 -- * The mode of the context 23239 -- * The mode of the private part 23240 23241 -- This case is separated from protected and task bodies 23242 -- because the statement part of the package body inherits 23243 -- the mode of the body declarations. 23244 23245 elsif Nkind (Decl) = N_Package_Body then 23246 Check_Pragma_Conformance 23247 (Context_Pragma => SPARK_Pragma (Body_Id), 23248 Entity => Spec_Id, 23249 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); 23250 23251 Set_SPARK_Context; 23252 Set_SPARK_Pragma (Body_Id, N); 23253 Set_SPARK_Pragma_Inherited (Body_Id, False); 23254 Set_SPARK_Aux_Pragma (Body_Id, N); 23255 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); 23256 23257 -- For protected and task bodies, verify the legality against: 23258 -- * The mode of the context 23259 -- * The mode of the private part 23260 23261 else 23262 pragma Assert 23263 (Nkind_In (Decl, N_Protected_Body, N_Task_Body)); 23264 23265 Check_Pragma_Conformance 23266 (Context_Pragma => SPARK_Pragma (Body_Id), 23267 Entity => Spec_Id, 23268 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); 23269 23270 Set_SPARK_Context; 23271 Set_SPARK_Pragma (Body_Id, N); 23272 Set_SPARK_Pragma_Inherited (Body_Id, False); 23273 end if; 23274 end Process_Body; 23275 23276 -------------------------- 23277 -- Process_Overloadable -- 23278 -------------------------- 23279 23280 procedure Process_Overloadable (Decl : Node_Id) is 23281 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 23282 Spec_Typ : constant Entity_Id := Etype (Spec_Id); 23283 23284 begin 23285 Check_Library_Level_Entity (Spec_Id); 23286 23287 -- Verify the legality against: 23288 -- * The mode of the context 23289 23290 Check_Pragma_Conformance 23291 (Context_Pragma => SPARK_Pragma (Spec_Id), 23292 Entity => Empty, 23293 Entity_Pragma => Empty); 23294 23295 Set_SPARK_Pragma (Spec_Id, N); 23296 Set_SPARK_Pragma_Inherited (Spec_Id, False); 23297 23298 -- When the pragma applies to the anonymous object created for 23299 -- a single task type, decorate the type as well. This scenario 23300 -- arises when the single task type lacks a task definition, 23301 -- therefore there is no issue with respect to a potential 23302 -- pragma SPARK_Mode in the private part. 23303 23304 -- task type Anon_Task_Typ; 23305 -- Obj : Anon_Task_Typ; 23306 -- pragma SPARK_Mode ...; 23307 23308 if Is_Single_Task_Object (Spec_Id) then 23309 Set_SPARK_Pragma (Spec_Typ, N); 23310 Set_SPARK_Pragma_Inherited (Spec_Typ, False); 23311 Set_SPARK_Aux_Pragma (Spec_Typ, N); 23312 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True); 23313 end if; 23314 end Process_Overloadable; 23315 23316 -------------------------- 23317 -- Process_Private_Part -- 23318 -------------------------- 23319 23320 procedure Process_Private_Part (Decl : Node_Id) is 23321 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 23322 23323 begin 23324 Check_Library_Level_Entity (Spec_Id); 23325 23326 -- Verify the legality against: 23327 -- * The mode of the visible declarations 23328 23329 Check_Pragma_Conformance 23330 (Context_Pragma => Empty, 23331 Entity => Spec_Id, 23332 Entity_Pragma => SPARK_Pragma (Spec_Id)); 23333 23334 Set_SPARK_Context; 23335 Set_SPARK_Aux_Pragma (Spec_Id, N); 23336 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); 23337 end Process_Private_Part; 23338 23339 ---------------------------- 23340 -- Process_Statement_Part -- 23341 ---------------------------- 23342 23343 procedure Process_Statement_Part (Decl : Node_Id) is 23344 Body_Id : constant Entity_Id := Defining_Entity (Decl); 23345 23346 begin 23347 Check_Library_Level_Entity (Body_Id); 23348 23349 -- Verify the legality against: 23350 -- * The mode of the body declarations 23351 23352 Check_Pragma_Conformance 23353 (Context_Pragma => Empty, 23354 Entity => Body_Id, 23355 Entity_Pragma => SPARK_Pragma (Body_Id)); 23356 23357 Set_SPARK_Context; 23358 Set_SPARK_Aux_Pragma (Body_Id, N); 23359 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); 23360 end Process_Statement_Part; 23361 23362 -------------------------- 23363 -- Process_Visible_Part -- 23364 -------------------------- 23365 23366 procedure Process_Visible_Part (Decl : Node_Id) is 23367 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 23368 Obj_Id : Entity_Id; 23369 23370 begin 23371 Check_Library_Level_Entity (Spec_Id); 23372 23373 -- Verify the legality against: 23374 -- * The mode of the context 23375 23376 Check_Pragma_Conformance 23377 (Context_Pragma => SPARK_Pragma (Spec_Id), 23378 Entity => Empty, 23379 Entity_Pragma => Empty); 23380 23381 -- A task unit declared without a definition does not set the 23382 -- SPARK_Mode of the context because the task does not have any 23383 -- entries that could inherit the mode. 23384 23385 if not Nkind_In (Decl, N_Single_Task_Declaration, 23386 N_Task_Type_Declaration) 23387 then 23388 Set_SPARK_Context; 23389 end if; 23390 23391 Set_SPARK_Pragma (Spec_Id, N); 23392 Set_SPARK_Pragma_Inherited (Spec_Id, False); 23393 Set_SPARK_Aux_Pragma (Spec_Id, N); 23394 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); 23395 23396 -- When the pragma applies to a single protected or task type, 23397 -- decorate the corresponding anonymous object as well. 23398 23399 -- protected Anon_Prot_Typ is 23400 -- pragma SPARK_Mode ...; 23401 -- ... 23402 -- end Anon_Prot_Typ; 23403 23404 -- Obj : Anon_Prot_Typ; 23405 23406 if Is_Single_Concurrent_Type (Spec_Id) then 23407 Obj_Id := Anonymous_Object (Spec_Id); 23408 23409 Set_SPARK_Pragma (Obj_Id, N); 23410 Set_SPARK_Pragma_Inherited (Obj_Id, False); 23411 end if; 23412 end Process_Visible_Part; 23413 23414 ----------------------- 23415 -- Set_SPARK_Context -- 23416 ----------------------- 23417 23418 procedure Set_SPARK_Context is 23419 begin 23420 SPARK_Mode := Mode_Id; 23421 SPARK_Mode_Pragma := N; 23422 end Set_SPARK_Context; 23423 23424 -- Local variables 23425 23426 Context : Node_Id; 23427 Mode : Name_Id; 23428 Stmt : Node_Id; 23429 23430 -- Start of processing for Do_SPARK_Mode 23431 23432 begin 23433 -- When a SPARK_Mode pragma appears inside an instantiation whose 23434 -- enclosing context has SPARK_Mode set to "off", the pragma has 23435 -- no semantic effect. 23436 23437 if Ignore_SPARK_Mode_Pragmas_In_Instance then 23438 Rewrite (N, Make_Null_Statement (Loc)); 23439 Analyze (N); 23440 return; 23441 end if; 23442 23443 GNAT_Pragma; 23444 Check_No_Identifiers; 23445 Check_At_Most_N_Arguments (1); 23446 23447 -- Check the legality of the mode (no argument = ON) 23448 23449 if Arg_Count = 1 then 23450 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 23451 Mode := Chars (Get_Pragma_Arg (Arg1)); 23452 else 23453 Mode := Name_On; 23454 end if; 23455 23456 Mode_Id := Get_SPARK_Mode_Type (Mode); 23457 Context := Parent (N); 23458 23459 -- The pragma appears in a configuration file 23460 23461 if No (Context) then 23462 Check_Valid_Configuration_Pragma; 23463 23464 if Present (SPARK_Mode_Pragma) then 23465 Duplication_Error 23466 (Prag => N, 23467 Prev => SPARK_Mode_Pragma); 23468 raise Pragma_Exit; 23469 end if; 23470 23471 Set_SPARK_Context; 23472 23473 -- The pragma acts as a configuration pragma in a compilation unit 23474 23475 -- pragma SPARK_Mode ...; 23476 -- package Pack is ...; 23477 23478 elsif Nkind (Context) = N_Compilation_Unit 23479 and then List_Containing (N) = Context_Items (Context) 23480 then 23481 Check_Valid_Configuration_Pragma; 23482 Set_SPARK_Context; 23483 23484 -- Otherwise the placement of the pragma within the tree dictates 23485 -- its associated construct. Inspect the declarative list where 23486 -- the pragma resides to find a potential construct. 23487 23488 else 23489 Stmt := Prev (N); 23490 while Present (Stmt) loop 23491 23492 -- Skip prior pragmas, but check for duplicates. Note that 23493 -- this also takes care of pragmas generated for aspects. 23494 23495 if Nkind (Stmt) = N_Pragma then 23496 if Pragma_Name (Stmt) = Pname then 23497 Duplication_Error 23498 (Prag => N, 23499 Prev => Stmt); 23500 raise Pragma_Exit; 23501 end if; 23502 23503 -- The pragma applies to an expression function that has 23504 -- already been rewritten into a subprogram declaration. 23505 23506 -- function Expr_Func return ... is (...); 23507 -- pragma SPARK_Mode ...; 23508 23509 elsif Nkind (Stmt) = N_Subprogram_Declaration 23510 and then Nkind (Original_Node (Stmt)) = 23511 N_Expression_Function 23512 then 23513 Process_Overloadable (Stmt); 23514 return; 23515 23516 -- The pragma applies to the anonymous object created for a 23517 -- single concurrent type. 23518 23519 -- protected type Anon_Prot_Typ ...; 23520 -- Obj : Anon_Prot_Typ; 23521 -- pragma SPARK_Mode ...; 23522 23523 elsif Nkind (Stmt) = N_Object_Declaration 23524 and then Is_Single_Concurrent_Object 23525 (Defining_Entity (Stmt)) 23526 then 23527 Process_Overloadable (Stmt); 23528 return; 23529 23530 -- Skip internally generated code 23531 23532 elsif not Comes_From_Source (Stmt) then 23533 null; 23534 23535 -- The pragma applies to an entry or [generic] subprogram 23536 -- declaration. 23537 23538 -- entry Ent ...; 23539 -- pragma SPARK_Mode ...; 23540 23541 -- [generic] 23542 -- procedure Proc ...; 23543 -- pragma SPARK_Mode ...; 23544 23545 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, 23546 N_Subprogram_Declaration) 23547 or else (Nkind (Stmt) = N_Entry_Declaration 23548 and then Is_Protected_Type 23549 (Scope (Defining_Entity (Stmt)))) 23550 then 23551 Process_Overloadable (Stmt); 23552 return; 23553 23554 -- Otherwise the pragma does not apply to a legal construct 23555 -- or it does not appear at the top of a declarative or a 23556 -- statement list. Issue an error and stop the analysis. 23557 23558 else 23559 Pragma_Misplaced; 23560 exit; 23561 end if; 23562 23563 Prev (Stmt); 23564 end loop; 23565 23566 -- The pragma applies to a package or a subprogram that acts as 23567 -- a compilation unit. 23568 23569 -- procedure Proc ...; 23570 -- pragma SPARK_Mode ...; 23571 23572 if Nkind (Context) = N_Compilation_Unit_Aux then 23573 Context := Unit (Parent (Context)); 23574 end if; 23575 23576 -- The pragma appears at the top of entry, package, protected 23577 -- unit, subprogram or task unit body declarations. 23578 23579 -- entry Ent when ... is 23580 -- pragma SPARK_Mode ...; 23581 23582 -- package body Pack is 23583 -- pragma SPARK_Mode ...; 23584 23585 -- procedure Proc ... is 23586 -- pragma SPARK_Mode; 23587 23588 -- protected body Prot is 23589 -- pragma SPARK_Mode ...; 23590 23591 if Nkind_In (Context, N_Entry_Body, 23592 N_Package_Body, 23593 N_Protected_Body, 23594 N_Subprogram_Body, 23595 N_Task_Body) 23596 then 23597 Process_Body (Context); 23598 23599 -- The pragma appears at the top of the visible or private 23600 -- declaration of a package spec, protected or task unit. 23601 23602 -- package Pack is 23603 -- pragma SPARK_Mode ...; 23604 -- private 23605 -- pragma SPARK_Mode ...; 23606 23607 -- protected [type] Prot is 23608 -- pragma SPARK_Mode ...; 23609 -- private 23610 -- pragma SPARK_Mode ...; 23611 23612 elsif Nkind_In (Context, N_Package_Specification, 23613 N_Protected_Definition, 23614 N_Task_Definition) 23615 then 23616 if List_Containing (N) = Visible_Declarations (Context) then 23617 Process_Visible_Part (Parent (Context)); 23618 else 23619 Process_Private_Part (Parent (Context)); 23620 end if; 23621 23622 -- The pragma appears at the top of package body statements 23623 23624 -- package body Pack is 23625 -- begin 23626 -- pragma SPARK_Mode; 23627 23628 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements 23629 and then Nkind (Parent (Context)) = N_Package_Body 23630 then 23631 Process_Statement_Part (Parent (Context)); 23632 23633 -- The pragma appeared as an aspect of a [generic] subprogram 23634 -- declaration that acts as a compilation unit. 23635 23636 -- [generic] 23637 -- procedure Proc ...; 23638 -- pragma SPARK_Mode ...; 23639 23640 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration, 23641 N_Subprogram_Declaration) 23642 then 23643 Process_Overloadable (Context); 23644 23645 -- The pragma does not apply to a legal construct, issue error 23646 23647 else 23648 Pragma_Misplaced; 23649 end if; 23650 end if; 23651 end Do_SPARK_Mode; 23652 23653 -------------------------------- 23654 -- Static_Elaboration_Desired -- 23655 -------------------------------- 23656 23657 -- pragma Static_Elaboration_Desired (DIRECT_NAME); 23658 23659 when Pragma_Static_Elaboration_Desired => 23660 GNAT_Pragma; 23661 Check_At_Most_N_Arguments (1); 23662 23663 if Is_Compilation_Unit (Current_Scope) 23664 and then Ekind (Current_Scope) = E_Package 23665 then 23666 Set_Static_Elaboration_Desired (Current_Scope, True); 23667 else 23668 Error_Pragma ("pragma% must apply to a library-level package"); 23669 end if; 23670 23671 ------------------ 23672 -- Storage_Size -- 23673 ------------------ 23674 23675 -- pragma Storage_Size (EXPRESSION); 23676 23677 when Pragma_Storage_Size => Storage_Size : declare 23678 P : constant Node_Id := Parent (N); 23679 Arg : Node_Id; 23680 23681 begin 23682 Check_No_Identifiers; 23683 Check_Arg_Count (1); 23684 23685 -- The expression must be analyzed in the special manner described 23686 -- in "Handling of Default Expressions" in sem.ads. 23687 23688 Arg := Get_Pragma_Arg (Arg1); 23689 Preanalyze_Spec_Expression (Arg, Any_Integer); 23690 23691 if not Is_OK_Static_Expression (Arg) then 23692 Check_Restriction (Static_Storage_Size, Arg); 23693 end if; 23694 23695 if Nkind (P) /= N_Task_Definition then 23696 Pragma_Misplaced; 23697 return; 23698 23699 else 23700 if Has_Storage_Size_Pragma (P) then 23701 Error_Pragma ("duplicate pragma% not allowed"); 23702 else 23703 Set_Has_Storage_Size_Pragma (P, True); 23704 end if; 23705 23706 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 23707 end if; 23708 end Storage_Size; 23709 23710 ------------------ 23711 -- Storage_Unit -- 23712 ------------------ 23713 23714 -- pragma Storage_Unit (NUMERIC_LITERAL); 23715 23716 -- Only permitted argument is System'Storage_Unit value 23717 23718 when Pragma_Storage_Unit => 23719 Check_No_Identifiers; 23720 Check_Arg_Count (1); 23721 Check_Arg_Is_Integer_Literal (Arg1); 23722 23723 if Intval (Get_Pragma_Arg (Arg1)) /= 23724 UI_From_Int (Ttypes.System_Storage_Unit) 23725 then 23726 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); 23727 Error_Pragma_Arg 23728 ("the only allowed argument for pragma% is ^", Arg1); 23729 end if; 23730 23731 -------------------- 23732 -- Stream_Convert -- 23733 -------------------- 23734 23735 -- pragma Stream_Convert ( 23736 -- [Entity =>] type_LOCAL_NAME, 23737 -- [Read =>] function_NAME, 23738 -- [Write =>] function NAME); 23739 23740 when Pragma_Stream_Convert => Stream_Convert : declare 23741 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); 23742 -- Check that the given argument is the name of a local function 23743 -- of one argument that is not overloaded earlier in the current 23744 -- local scope. A check is also made that the argument is a 23745 -- function with one parameter. 23746 23747 -------------------------------------- 23748 -- Check_OK_Stream_Convert_Function -- 23749 -------------------------------------- 23750 23751 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is 23752 Ent : Entity_Id; 23753 23754 begin 23755 Check_Arg_Is_Local_Name (Arg); 23756 Ent := Entity (Get_Pragma_Arg (Arg)); 23757 23758 if Has_Homonym (Ent) then 23759 Error_Pragma_Arg 23760 ("argument for pragma% may not be overloaded", Arg); 23761 end if; 23762 23763 if Ekind (Ent) /= E_Function 23764 or else No (First_Formal (Ent)) 23765 or else Present (Next_Formal (First_Formal (Ent))) 23766 then 23767 Error_Pragma_Arg 23768 ("argument for pragma% must be function of one argument", 23769 Arg); 23770 end if; 23771 end Check_OK_Stream_Convert_Function; 23772 23773 -- Start of processing for Stream_Convert 23774 23775 begin 23776 GNAT_Pragma; 23777 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write)); 23778 Check_Arg_Count (3); 23779 Check_Optional_Identifier (Arg1, Name_Entity); 23780 Check_Optional_Identifier (Arg2, Name_Read); 23781 Check_Optional_Identifier (Arg3, Name_Write); 23782 Check_Arg_Is_Local_Name (Arg1); 23783 Check_OK_Stream_Convert_Function (Arg2); 23784 Check_OK_Stream_Convert_Function (Arg3); 23785 23786 declare 23787 Typ : constant Entity_Id := 23788 Underlying_Type (Entity (Get_Pragma_Arg (Arg1))); 23789 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2)); 23790 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3)); 23791 23792 begin 23793 Check_First_Subtype (Arg1); 23794 23795 -- Check for too early or too late. Note that we don't enforce 23796 -- the rule about primitive operations in this case, since, as 23797 -- is the case for explicit stream attributes themselves, these 23798 -- restrictions are not appropriate. Note that the chaining of 23799 -- the pragma by Rep_Item_Too_Late is actually the critical 23800 -- processing done for this pragma. 23801 23802 if Rep_Item_Too_Early (Typ, N) 23803 or else 23804 Rep_Item_Too_Late (Typ, N, FOnly => True) 23805 then 23806 return; 23807 end if; 23808 23809 -- Return if previous error 23810 23811 if Etype (Typ) = Any_Type 23812 or else 23813 Etype (Read) = Any_Type 23814 or else 23815 Etype (Write) = Any_Type 23816 then 23817 return; 23818 end if; 23819 23820 -- Error checks 23821 23822 if Underlying_Type (Etype (Read)) /= Typ then 23823 Error_Pragma_Arg 23824 ("incorrect return type for function&", Arg2); 23825 end if; 23826 23827 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then 23828 Error_Pragma_Arg 23829 ("incorrect parameter type for function&", Arg3); 23830 end if; 23831 23832 if Underlying_Type (Etype (First_Formal (Read))) /= 23833 Underlying_Type (Etype (Write)) 23834 then 23835 Error_Pragma_Arg 23836 ("result type of & does not match Read parameter type", 23837 Arg3); 23838 end if; 23839 end; 23840 end Stream_Convert; 23841 23842 ------------------ 23843 -- Style_Checks -- 23844 ------------------ 23845 23846 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 23847 23848 -- This is processed by the parser since some of the style checks 23849 -- take place during source scanning and parsing. This means that 23850 -- we don't need to issue error messages here. 23851 23852 when Pragma_Style_Checks => Style_Checks : declare 23853 A : constant Node_Id := Get_Pragma_Arg (Arg1); 23854 S : String_Id; 23855 C : Char_Code; 23856 23857 begin 23858 GNAT_Pragma; 23859 Check_No_Identifiers; 23860 23861 -- Two argument form 23862 23863 if Arg_Count = 2 then 23864 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 23865 23866 declare 23867 E_Id : Node_Id; 23868 E : Entity_Id; 23869 23870 begin 23871 E_Id := Get_Pragma_Arg (Arg2); 23872 Analyze (E_Id); 23873 23874 if not Is_Entity_Name (E_Id) then 23875 Error_Pragma_Arg 23876 ("second argument of pragma% must be entity name", 23877 Arg2); 23878 end if; 23879 23880 E := Entity (E_Id); 23881 23882 if not Ignore_Style_Checks_Pragmas then 23883 if E = Any_Id then 23884 return; 23885 else 23886 loop 23887 Set_Suppress_Style_Checks 23888 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off); 23889 exit when No (Homonym (E)); 23890 E := Homonym (E); 23891 end loop; 23892 end if; 23893 end if; 23894 end; 23895 23896 -- One argument form 23897 23898 else 23899 Check_Arg_Count (1); 23900 23901 if Nkind (A) = N_String_Literal then 23902 S := Strval (A); 23903 23904 declare 23905 Slen : constant Natural := Natural (String_Length (S)); 23906 Options : String (1 .. Slen); 23907 J : Positive; 23908 23909 begin 23910 J := 1; 23911 loop 23912 C := Get_String_Char (S, Pos (J)); 23913 exit when not In_Character_Range (C); 23914 Options (J) := Get_Character (C); 23915 23916 -- If at end of string, set options. As per discussion 23917 -- above, no need to check for errors, since we issued 23918 -- them in the parser. 23919 23920 if J = Slen then 23921 if not Ignore_Style_Checks_Pragmas then 23922 Set_Style_Check_Options (Options); 23923 end if; 23924 23925 exit; 23926 end if; 23927 23928 J := J + 1; 23929 end loop; 23930 end; 23931 23932 elsif Nkind (A) = N_Identifier then 23933 if Chars (A) = Name_All_Checks then 23934 if not Ignore_Style_Checks_Pragmas then 23935 if GNAT_Mode then 23936 Set_GNAT_Style_Check_Options; 23937 else 23938 Set_Default_Style_Check_Options; 23939 end if; 23940 end if; 23941 23942 elsif Chars (A) = Name_On then 23943 if not Ignore_Style_Checks_Pragmas then 23944 Style_Check := True; 23945 end if; 23946 23947 elsif Chars (A) = Name_Off then 23948 if not Ignore_Style_Checks_Pragmas then 23949 Style_Check := False; 23950 end if; 23951 end if; 23952 end if; 23953 end if; 23954 end Style_Checks; 23955 23956 -------------- 23957 -- Subtitle -- 23958 -------------- 23959 23960 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL); 23961 23962 when Pragma_Subtitle => 23963 GNAT_Pragma; 23964 Check_Arg_Count (1); 23965 Check_Optional_Identifier (Arg1, Name_Subtitle); 23966 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 23967 Store_Note (N); 23968 23969 -------------- 23970 -- Suppress -- 23971 -------------- 23972 23973 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); 23974 23975 when Pragma_Suppress => 23976 Process_Suppress_Unsuppress (Suppress_Case => True); 23977 23978 ------------------ 23979 -- Suppress_All -- 23980 ------------------ 23981 23982 -- pragma Suppress_All; 23983 23984 -- The only check made here is that the pragma has no arguments. 23985 -- There are no placement rules, and the processing required (setting 23986 -- the Has_Pragma_Suppress_All flag in the compilation unit node was 23987 -- taken care of by the parser). Process_Compilation_Unit_Pragmas 23988 -- then creates and inserts a pragma Suppress (All_Checks). 23989 23990 when Pragma_Suppress_All => 23991 GNAT_Pragma; 23992 Check_Arg_Count (0); 23993 23994 ------------------------- 23995 -- Suppress_Debug_Info -- 23996 ------------------------- 23997 23998 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME); 23999 24000 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare 24001 Nam_Id : Entity_Id; 24002 24003 begin 24004 GNAT_Pragma; 24005 Check_Arg_Count (1); 24006 Check_Optional_Identifier (Arg1, Name_Entity); 24007 Check_Arg_Is_Local_Name (Arg1); 24008 24009 Nam_Id := Entity (Get_Pragma_Arg (Arg1)); 24010 24011 -- A pragma that applies to a Ghost entity becomes Ghost for the 24012 -- purposes of legality checks and removal of ignored Ghost code. 24013 24014 Mark_Ghost_Pragma (N, Nam_Id); 24015 Set_Debug_Info_Off (Nam_Id); 24016 end Suppress_Debug_Info; 24017 24018 ---------------------------------- 24019 -- Suppress_Exception_Locations -- 24020 ---------------------------------- 24021 24022 -- pragma Suppress_Exception_Locations; 24023 24024 when Pragma_Suppress_Exception_Locations => 24025 GNAT_Pragma; 24026 Check_Arg_Count (0); 24027 Check_Valid_Configuration_Pragma; 24028 Exception_Locations_Suppressed := True; 24029 24030 ----------------------------- 24031 -- Suppress_Initialization -- 24032 ----------------------------- 24033 24034 -- pragma Suppress_Initialization ([Entity =>] type_Name); 24035 24036 when Pragma_Suppress_Initialization => Suppress_Init : declare 24037 E : Entity_Id; 24038 E_Id : Node_Id; 24039 24040 begin 24041 GNAT_Pragma; 24042 Check_Arg_Count (1); 24043 Check_Optional_Identifier (Arg1, Name_Entity); 24044 Check_Arg_Is_Local_Name (Arg1); 24045 24046 E_Id := Get_Pragma_Arg (Arg1); 24047 24048 if Etype (E_Id) = Any_Type then 24049 return; 24050 end if; 24051 24052 E := Entity (E_Id); 24053 24054 -- A pragma that applies to a Ghost entity becomes Ghost for the 24055 -- purposes of legality checks and removal of ignored Ghost code. 24056 24057 Mark_Ghost_Pragma (N, E); 24058 24059 if not Is_Type (E) and then Ekind (E) /= E_Variable then 24060 Error_Pragma_Arg 24061 ("pragma% requires variable, type or subtype", Arg1); 24062 end if; 24063 24064 if Rep_Item_Too_Early (E, N) 24065 or else 24066 Rep_Item_Too_Late (E, N, FOnly => True) 24067 then 24068 return; 24069 end if; 24070 24071 -- For incomplete/private type, set flag on full view 24072 24073 if Is_Incomplete_Or_Private_Type (E) then 24074 if No (Full_View (Base_Type (E))) then 24075 Error_Pragma_Arg 24076 ("argument of pragma% cannot be an incomplete type", Arg1); 24077 else 24078 Set_Suppress_Initialization (Full_View (Base_Type (E))); 24079 end if; 24080 24081 -- For first subtype, set flag on base type 24082 24083 elsif Is_First_Subtype (E) then 24084 Set_Suppress_Initialization (Base_Type (E)); 24085 24086 -- For other than first subtype, set flag on subtype or variable 24087 24088 else 24089 Set_Suppress_Initialization (E); 24090 end if; 24091 end Suppress_Init; 24092 24093 ----------------- 24094 -- System_Name -- 24095 ----------------- 24096 24097 -- pragma System_Name (DIRECT_NAME); 24098 24099 -- Syntax check: one argument, which must be the identifier GNAT or 24100 -- the identifier GCC, no other identifiers are acceptable. 24101 24102 when Pragma_System_Name => 24103 GNAT_Pragma; 24104 Check_No_Identifiers; 24105 Check_Arg_Count (1); 24106 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); 24107 24108 ----------------------------- 24109 -- Task_Dispatching_Policy -- 24110 ----------------------------- 24111 24112 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER); 24113 24114 when Pragma_Task_Dispatching_Policy => declare 24115 DP : Character; 24116 24117 begin 24118 Check_Ada_83_Warning; 24119 Check_Arg_Count (1); 24120 Check_No_Identifiers; 24121 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 24122 Check_Valid_Configuration_Pragma; 24123 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 24124 DP := Fold_Upper (Name_Buffer (1)); 24125 24126 if Task_Dispatching_Policy /= ' ' 24127 and then Task_Dispatching_Policy /= DP 24128 then 24129 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 24130 Error_Pragma 24131 ("task dispatching policy incompatible with policy#"); 24132 24133 -- Set new policy, but always preserve System_Location since we 24134 -- like the error message with the run time name. 24135 24136 else 24137 Task_Dispatching_Policy := DP; 24138 24139 if Task_Dispatching_Policy_Sloc /= System_Location then 24140 Task_Dispatching_Policy_Sloc := Loc; 24141 end if; 24142 end if; 24143 end; 24144 24145 --------------- 24146 -- Task_Info -- 24147 --------------- 24148 24149 -- pragma Task_Info (EXPRESSION); 24150 24151 when Pragma_Task_Info => Task_Info : declare 24152 P : constant Node_Id := Parent (N); 24153 Ent : Entity_Id; 24154 24155 begin 24156 GNAT_Pragma; 24157 24158 if Warn_On_Obsolescent_Feature then 24159 Error_Msg_N 24160 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U " 24161 & "instead?j?", N); 24162 end if; 24163 24164 if Nkind (P) /= N_Task_Definition then 24165 Error_Pragma ("pragma% must appear in task definition"); 24166 end if; 24167 24168 Check_No_Identifiers; 24169 Check_Arg_Count (1); 24170 24171 Analyze_And_Resolve 24172 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type)); 24173 24174 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then 24175 return; 24176 end if; 24177 24178 Ent := Defining_Identifier (Parent (P)); 24179 24180 -- Check duplicate pragma before we chain the pragma in the Rep 24181 -- Item chain of Ent. 24182 24183 if Has_Rep_Pragma 24184 (Ent, Name_Task_Info, Check_Parents => False) 24185 then 24186 Error_Pragma ("duplicate pragma% not allowed"); 24187 end if; 24188 24189 Record_Rep_Item (Ent, N); 24190 end Task_Info; 24191 24192 --------------- 24193 -- Task_Name -- 24194 --------------- 24195 24196 -- pragma Task_Name (string_EXPRESSION); 24197 24198 when Pragma_Task_Name => Task_Name : declare 24199 P : constant Node_Id := Parent (N); 24200 Arg : Node_Id; 24201 Ent : Entity_Id; 24202 24203 begin 24204 Check_No_Identifiers; 24205 Check_Arg_Count (1); 24206 24207 Arg := Get_Pragma_Arg (Arg1); 24208 24209 -- The expression is used in the call to Create_Task, and must be 24210 -- expanded there, not in the context of the current spec. It must 24211 -- however be analyzed to capture global references, in case it 24212 -- appears in a generic context. 24213 24214 Preanalyze_And_Resolve (Arg, Standard_String); 24215 24216 if Nkind (P) /= N_Task_Definition then 24217 Pragma_Misplaced; 24218 end if; 24219 24220 Ent := Defining_Identifier (Parent (P)); 24221 24222 -- Check duplicate pragma before we chain the pragma in the Rep 24223 -- Item chain of Ent. 24224 24225 if Has_Rep_Pragma 24226 (Ent, Name_Task_Name, Check_Parents => False) 24227 then 24228 Error_Pragma ("duplicate pragma% not allowed"); 24229 end if; 24230 24231 Record_Rep_Item (Ent, N); 24232 end Task_Name; 24233 24234 ------------------ 24235 -- Task_Storage -- 24236 ------------------ 24237 24238 -- pragma Task_Storage ( 24239 -- [Task_Type =>] LOCAL_NAME, 24240 -- [Top_Guard =>] static_integer_EXPRESSION); 24241 24242 when Pragma_Task_Storage => Task_Storage : declare 24243 Args : Args_List (1 .. 2); 24244 Names : constant Name_List (1 .. 2) := ( 24245 Name_Task_Type, 24246 Name_Top_Guard); 24247 24248 Task_Type : Node_Id renames Args (1); 24249 Top_Guard : Node_Id renames Args (2); 24250 24251 Ent : Entity_Id; 24252 24253 begin 24254 GNAT_Pragma; 24255 Gather_Associations (Names, Args); 24256 24257 if No (Task_Type) then 24258 Error_Pragma 24259 ("missing task_type argument for pragma%"); 24260 end if; 24261 24262 Check_Arg_Is_Local_Name (Task_Type); 24263 24264 Ent := Entity (Task_Type); 24265 24266 if not Is_Task_Type (Ent) then 24267 Error_Pragma_Arg 24268 ("argument for pragma% must be task type", Task_Type); 24269 end if; 24270 24271 if No (Top_Guard) then 24272 Error_Pragma_Arg 24273 ("pragma% takes two arguments", Task_Type); 24274 else 24275 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer); 24276 end if; 24277 24278 Check_First_Subtype (Task_Type); 24279 24280 if Rep_Item_Too_Late (Ent, N) then 24281 raise Pragma_Exit; 24282 end if; 24283 end Task_Storage; 24284 24285 --------------- 24286 -- Test_Case -- 24287 --------------- 24288 24289 -- pragma Test_Case 24290 -- ([Name =>] Static_String_EXPRESSION 24291 -- ,[Mode =>] MODE_TYPE 24292 -- [, Requires => Boolean_EXPRESSION] 24293 -- [, Ensures => Boolean_EXPRESSION]); 24294 24295 -- MODE_TYPE ::= Nominal | Robustness 24296 24297 -- Characteristics: 24298 24299 -- * Analysis - The annotation undergoes initial checks to verify 24300 -- the legal placement and context. Secondary checks preanalyze the 24301 -- expressions in: 24302 24303 -- Analyze_Test_Case_In_Decl_Part 24304 24305 -- * Expansion - None. 24306 24307 -- * Template - The annotation utilizes the generic template of the 24308 -- related subprogram when it is: 24309 24310 -- aspect on subprogram declaration 24311 24312 -- The annotation must prepare its own template when it is: 24313 24314 -- pragma on subprogram declaration 24315 24316 -- * Globals - Capture of global references must occur after full 24317 -- analysis. 24318 24319 -- * Instance - The annotation is instantiated automatically when 24320 -- the related generic subprogram is instantiated except for the 24321 -- "pragma on subprogram declaration" case. In that scenario the 24322 -- annotation must instantiate itself. 24323 24324 when Pragma_Test_Case => Test_Case : declare 24325 procedure Check_Distinct_Name (Subp_Id : Entity_Id); 24326 -- Ensure that the contract of subprogram Subp_Id does not contain 24327 -- another Test_Case pragma with the same Name as the current one. 24328 24329 ------------------------- 24330 -- Check_Distinct_Name -- 24331 ------------------------- 24332 24333 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is 24334 Items : constant Node_Id := Contract (Subp_Id); 24335 Name : constant String_Id := Get_Name_From_CTC_Pragma (N); 24336 Prag : Node_Id; 24337 24338 begin 24339 -- Inspect all Test_Case pragma of the related subprogram 24340 -- looking for one with a duplicate "Name" argument. 24341 24342 if Present (Items) then 24343 Prag := Contract_Test_Cases (Items); 24344 while Present (Prag) loop 24345 if Pragma_Name (Prag) = Name_Test_Case 24346 and then Prag /= N 24347 and then String_Equal 24348 (Name, Get_Name_From_CTC_Pragma (Prag)) 24349 then 24350 Error_Msg_Sloc := Sloc (Prag); 24351 Error_Pragma ("name for pragma % is already used #"); 24352 end if; 24353 24354 Prag := Next_Pragma (Prag); 24355 end loop; 24356 end if; 24357 end Check_Distinct_Name; 24358 24359 -- Local variables 24360 24361 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); 24362 Asp_Arg : Node_Id; 24363 Context : Node_Id; 24364 Subp_Decl : Node_Id; 24365 Subp_Id : Entity_Id; 24366 24367 -- Start of processing for Test_Case 24368 24369 begin 24370 GNAT_Pragma; 24371 Check_At_Least_N_Arguments (2); 24372 Check_At_Most_N_Arguments (4); 24373 Check_Arg_Order 24374 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); 24375 24376 -- Argument "Name" 24377 24378 Check_Optional_Identifier (Arg1, Name_Name); 24379 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 24380 24381 -- Argument "Mode" 24382 24383 Check_Optional_Identifier (Arg2, Name_Mode); 24384 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); 24385 24386 -- Arguments "Requires" and "Ensures" 24387 24388 if Present (Arg3) then 24389 if Present (Arg4) then 24390 Check_Identifier (Arg3, Name_Requires); 24391 Check_Identifier (Arg4, Name_Ensures); 24392 else 24393 Check_Identifier_Is_One_Of 24394 (Arg3, Name_Requires, Name_Ensures); 24395 end if; 24396 end if; 24397 24398 -- Pragma Test_Case must be associated with a subprogram declared 24399 -- in a library-level package. First determine whether the current 24400 -- compilation unit is a legal context. 24401 24402 if Nkind_In (Pack_Decl, N_Package_Declaration, 24403 N_Generic_Package_Declaration) 24404 then 24405 null; 24406 24407 -- Otherwise the placement is illegal 24408 24409 else 24410 Error_Pragma 24411 ("pragma % must be specified within a package declaration"); 24412 return; 24413 end if; 24414 24415 Subp_Decl := Find_Related_Declaration_Or_Body (N); 24416 24417 -- Find the enclosing context 24418 24419 Context := Parent (Subp_Decl); 24420 24421 if Present (Context) then 24422 Context := Parent (Context); 24423 end if; 24424 24425 -- Verify the placement of the pragma 24426 24427 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 24428 Error_Pragma 24429 ("pragma % cannot be applied to abstract subprogram"); 24430 return; 24431 24432 elsif Nkind (Subp_Decl) = N_Entry_Declaration then 24433 Error_Pragma ("pragma % cannot be applied to entry"); 24434 return; 24435 24436 -- The context is a [generic] subprogram declared at the top level 24437 -- of the [generic] package unit. 24438 24439 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, 24440 N_Subprogram_Declaration) 24441 and then Present (Context) 24442 and then Nkind_In (Context, N_Generic_Package_Declaration, 24443 N_Package_Declaration) 24444 then 24445 null; 24446 24447 -- Otherwise the placement is illegal 24448 24449 else 24450 Error_Pragma 24451 ("pragma % must be applied to a library-level subprogram " 24452 & "declaration"); 24453 return; 24454 end if; 24455 24456 Subp_Id := Defining_Entity (Subp_Decl); 24457 24458 -- A pragma that applies to a Ghost entity becomes Ghost for the 24459 -- purposes of legality checks and removal of ignored Ghost code. 24460 24461 Mark_Ghost_Pragma (N, Subp_Id); 24462 24463 -- Chain the pragma on the contract for further processing by 24464 -- Analyze_Test_Case_In_Decl_Part. 24465 24466 Add_Contract_Item (N, Subp_Id); 24467 24468 -- Preanalyze the original aspect argument "Name" for ASIS or for 24469 -- a generic subprogram to properly capture global references. 24470 24471 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then 24472 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True); 24473 24474 if Present (Asp_Arg) then 24475 24476 -- The argument appears with an identifier in association 24477 -- form. 24478 24479 if Nkind (Asp_Arg) = N_Component_Association then 24480 Asp_Arg := Expression (Asp_Arg); 24481 end if; 24482 24483 Check_Expr_Is_OK_Static_Expression 24484 (Asp_Arg, Standard_String); 24485 end if; 24486 end if; 24487 24488 -- Ensure that the all Test_Case pragmas of the related subprogram 24489 -- have distinct names. 24490 24491 Check_Distinct_Name (Subp_Id); 24492 24493 -- Fully analyze the pragma when it appears inside an entry 24494 -- or subprogram body because it cannot benefit from forward 24495 -- references. 24496 24497 if Nkind_In (Subp_Decl, N_Entry_Body, 24498 N_Subprogram_Body, 24499 N_Subprogram_Body_Stub) 24500 then 24501 -- The legality checks of pragma Test_Case are affected by the 24502 -- SPARK mode in effect and the volatility of the context. 24503 -- Analyze all pragmas in a specific order. 24504 24505 Analyze_If_Present (Pragma_SPARK_Mode); 24506 Analyze_If_Present (Pragma_Volatile_Function); 24507 Analyze_Test_Case_In_Decl_Part (N); 24508 end if; 24509 end Test_Case; 24510 24511 -------------------------- 24512 -- Thread_Local_Storage -- 24513 -------------------------- 24514 24515 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); 24516 24517 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare 24518 E : Entity_Id; 24519 Id : Node_Id; 24520 24521 begin 24522 GNAT_Pragma; 24523 Check_Arg_Count (1); 24524 Check_Optional_Identifier (Arg1, Name_Entity); 24525 Check_Arg_Is_Library_Level_Local_Name (Arg1); 24526 24527 Id := Get_Pragma_Arg (Arg1); 24528 Analyze (Id); 24529 24530 if not Is_Entity_Name (Id) 24531 or else Ekind (Entity (Id)) /= E_Variable 24532 then 24533 Error_Pragma_Arg ("local variable name required", Arg1); 24534 end if; 24535 24536 E := Entity (Id); 24537 24538 -- A pragma that applies to a Ghost entity becomes Ghost for the 24539 -- purposes of legality checks and removal of ignored Ghost code. 24540 24541 Mark_Ghost_Pragma (N, E); 24542 24543 if Rep_Item_Too_Early (E, N) 24544 or else 24545 Rep_Item_Too_Late (E, N) 24546 then 24547 raise Pragma_Exit; 24548 end if; 24549 24550 Set_Has_Pragma_Thread_Local_Storage (E); 24551 Set_Has_Gigi_Rep_Item (E); 24552 end Thread_Local_Storage; 24553 24554 ---------------- 24555 -- Time_Slice -- 24556 ---------------- 24557 24558 -- pragma Time_Slice (static_duration_EXPRESSION); 24559 24560 when Pragma_Time_Slice => Time_Slice : declare 24561 Val : Ureal; 24562 Nod : Node_Id; 24563 24564 begin 24565 GNAT_Pragma; 24566 Check_Arg_Count (1); 24567 Check_No_Identifiers; 24568 Check_In_Main_Program; 24569 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration); 24570 24571 if not Error_Posted (Arg1) then 24572 Nod := Next (N); 24573 while Present (Nod) loop 24574 if Nkind (Nod) = N_Pragma 24575 and then Pragma_Name (Nod) = Name_Time_Slice 24576 then 24577 Error_Msg_Name_1 := Pname; 24578 Error_Msg_N ("duplicate pragma% not permitted", Nod); 24579 end if; 24580 24581 Next (Nod); 24582 end loop; 24583 end if; 24584 24585 -- Process only if in main unit 24586 24587 if Get_Source_Unit (Loc) = Main_Unit then 24588 Opt.Time_Slice_Set := True; 24589 Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); 24590 24591 if Val <= Ureal_0 then 24592 Opt.Time_Slice_Value := 0; 24593 24594 elsif Val > UR_From_Uint (UI_From_Int (1000)) then 24595 Opt.Time_Slice_Value := 1_000_000_000; 24596 24597 else 24598 Opt.Time_Slice_Value := 24599 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000))); 24600 end if; 24601 end if; 24602 end Time_Slice; 24603 24604 ----------- 24605 -- Title -- 24606 ----------- 24607 24608 -- pragma Title (TITLING_OPTION [, TITLING OPTION]); 24609 24610 -- TITLING_OPTION ::= 24611 -- [Title =>] STRING_LITERAL 24612 -- | [Subtitle =>] STRING_LITERAL 24613 24614 when Pragma_Title => Title : declare 24615 Args : Args_List (1 .. 2); 24616 Names : constant Name_List (1 .. 2) := ( 24617 Name_Title, 24618 Name_Subtitle); 24619 24620 begin 24621 GNAT_Pragma; 24622 Gather_Associations (Names, Args); 24623 Store_Note (N); 24624 24625 for J in 1 .. 2 loop 24626 if Present (Args (J)) then 24627 Check_Arg_Is_OK_Static_Expression 24628 (Args (J), Standard_String); 24629 end if; 24630 end loop; 24631 end Title; 24632 24633 ---------------------------- 24634 -- Type_Invariant[_Class] -- 24635 ---------------------------- 24636 24637 -- pragma Type_Invariant[_Class] 24638 -- ([Entity =>] type_LOCAL_NAME, 24639 -- [Check =>] EXPRESSION); 24640 24641 when Pragma_Type_Invariant 24642 | Pragma_Type_Invariant_Class 24643 => 24644 Type_Invariant : declare 24645 I_Pragma : Node_Id; 24646 24647 begin 24648 Check_Arg_Count (2); 24649 24650 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma, 24651 -- setting Class_Present for the Type_Invariant_Class case. 24652 24653 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class); 24654 I_Pragma := New_Copy (N); 24655 Set_Pragma_Identifier 24656 (I_Pragma, Make_Identifier (Loc, Name_Invariant)); 24657 Rewrite (N, I_Pragma); 24658 Set_Analyzed (N, False); 24659 Analyze (N); 24660 end Type_Invariant; 24661 24662 --------------------- 24663 -- Unchecked_Union -- 24664 --------------------- 24665 24666 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) 24667 24668 when Pragma_Unchecked_Union => Unchecked_Union : declare 24669 Assoc : constant Node_Id := Arg1; 24670 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 24671 Clist : Node_Id; 24672 Comp : Node_Id; 24673 Tdef : Node_Id; 24674 Typ : Entity_Id; 24675 Variant : Node_Id; 24676 Vpart : Node_Id; 24677 24678 begin 24679 Ada_2005_Pragma; 24680 Check_No_Identifiers; 24681 Check_Arg_Count (1); 24682 Check_Arg_Is_Local_Name (Arg1); 24683 24684 Find_Type (Type_Id); 24685 24686 Typ := Entity (Type_Id); 24687 24688 -- A pragma that applies to a Ghost entity becomes Ghost for the 24689 -- purposes of legality checks and removal of ignored Ghost code. 24690 24691 Mark_Ghost_Pragma (N, Typ); 24692 24693 if Typ = Any_Type 24694 or else Rep_Item_Too_Early (Typ, N) 24695 then 24696 return; 24697 else 24698 Typ := Underlying_Type (Typ); 24699 end if; 24700 24701 if Rep_Item_Too_Late (Typ, N) then 24702 return; 24703 end if; 24704 24705 Check_First_Subtype (Arg1); 24706 24707 -- Note remaining cases are references to a type in the current 24708 -- declarative part. If we find an error, we post the error on 24709 -- the relevant type declaration at an appropriate point. 24710 24711 if not Is_Record_Type (Typ) then 24712 Error_Msg_N ("unchecked union must be record type", Typ); 24713 return; 24714 24715 elsif Is_Tagged_Type (Typ) then 24716 Error_Msg_N ("unchecked union must not be tagged", Typ); 24717 return; 24718 24719 elsif not Has_Discriminants (Typ) then 24720 Error_Msg_N 24721 ("unchecked union must have one discriminant", Typ); 24722 return; 24723 24724 -- Note: in previous versions of GNAT we used to check for limited 24725 -- types and give an error, but in fact the standard does allow 24726 -- Unchecked_Union on limited types, so this check was removed. 24727 24728 -- Similarly, GNAT used to require that all discriminants have 24729 -- default values, but this is not mandated by the RM. 24730 24731 -- Proceed with basic error checks completed 24732 24733 else 24734 Tdef := Type_Definition (Declaration_Node (Typ)); 24735 Clist := Component_List (Tdef); 24736 24737 -- Check presence of component list and variant part 24738 24739 if No (Clist) or else No (Variant_Part (Clist)) then 24740 Error_Msg_N 24741 ("unchecked union must have variant part", Tdef); 24742 return; 24743 end if; 24744 24745 -- Check components 24746 24747 Comp := First_Non_Pragma (Component_Items (Clist)); 24748 while Present (Comp) loop 24749 Check_Component (Comp, Typ); 24750 Next_Non_Pragma (Comp); 24751 end loop; 24752 24753 -- Check variant part 24754 24755 Vpart := Variant_Part (Clist); 24756 24757 Variant := First_Non_Pragma (Variants (Vpart)); 24758 while Present (Variant) loop 24759 Check_Variant (Variant, Typ); 24760 Next_Non_Pragma (Variant); 24761 end loop; 24762 end if; 24763 24764 Set_Is_Unchecked_Union (Typ); 24765 Set_Convention (Typ, Convention_C); 24766 Set_Has_Unchecked_Union (Base_Type (Typ)); 24767 Set_Is_Unchecked_Union (Base_Type (Typ)); 24768 end Unchecked_Union; 24769 24770 ---------------------------- 24771 -- Unevaluated_Use_Of_Old -- 24772 ---------------------------- 24773 24774 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow); 24775 24776 when Pragma_Unevaluated_Use_Of_Old => 24777 GNAT_Pragma; 24778 Check_Arg_Count (1); 24779 Check_No_Identifiers; 24780 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow); 24781 24782 -- Suppress/Unsuppress can appear as a configuration pragma, or in 24783 -- a declarative part or a package spec. 24784 24785 if not Is_Configuration_Pragma then 24786 Check_Is_In_Decl_Part_Or_Package_Spec; 24787 end if; 24788 24789 -- Store proper setting of Uneval_Old 24790 24791 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 24792 Uneval_Old := Fold_Upper (Name_Buffer (1)); 24793 24794 ------------------------ 24795 -- Unimplemented_Unit -- 24796 ------------------------ 24797 24798 -- pragma Unimplemented_Unit; 24799 24800 -- Note: this only gives an error if we are generating code, or if 24801 -- we are in a generic library unit (where the pragma appears in the 24802 -- body, not in the spec). 24803 24804 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare 24805 Cunitent : constant Entity_Id := 24806 Cunit_Entity (Get_Source_Unit (Loc)); 24807 Ent_Kind : constant Entity_Kind := Ekind (Cunitent); 24808 24809 begin 24810 GNAT_Pragma; 24811 Check_Arg_Count (0); 24812 24813 if Operating_Mode = Generate_Code 24814 or else Ent_Kind = E_Generic_Function 24815 or else Ent_Kind = E_Generic_Procedure 24816 or else Ent_Kind = E_Generic_Package 24817 then 24818 Get_Name_String (Chars (Cunitent)); 24819 Set_Casing (Mixed_Case); 24820 Write_Str (Name_Buffer (1 .. Name_Len)); 24821 Write_Str (" is not supported in this configuration"); 24822 Write_Eol; 24823 raise Unrecoverable_Error; 24824 end if; 24825 end Unimplemented_Unit; 24826 24827 ------------------------ 24828 -- Universal_Aliasing -- 24829 ------------------------ 24830 24831 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)]; 24832 24833 when Pragma_Universal_Aliasing => Universal_Alias : declare 24834 E : Entity_Id; 24835 E_Id : Node_Id; 24836 24837 begin 24838 GNAT_Pragma; 24839 Check_Arg_Count (1); 24840 Check_Optional_Identifier (Arg2, Name_Entity); 24841 Check_Arg_Is_Local_Name (Arg1); 24842 E_Id := Get_Pragma_Arg (Arg1); 24843 24844 if Etype (E_Id) = Any_Type then 24845 return; 24846 end if; 24847 24848 E := Entity (E_Id); 24849 24850 if not Is_Type (E) then 24851 Error_Pragma_Arg ("pragma% requires type", Arg1); 24852 end if; 24853 24854 -- A pragma that applies to a Ghost entity becomes Ghost for the 24855 -- purposes of legality checks and removal of ignored Ghost code. 24856 24857 Mark_Ghost_Pragma (N, E); 24858 Set_Universal_Aliasing (Base_Type (E)); 24859 Record_Rep_Item (E, N); 24860 end Universal_Alias; 24861 24862 -------------------- 24863 -- Universal_Data -- 24864 -------------------- 24865 24866 -- pragma Universal_Data [(library_unit_NAME)]; 24867 24868 when Pragma_Universal_Data => 24869 GNAT_Pragma; 24870 Error_Pragma ("??pragma% ignored (applies only to AAMP)"); 24871 24872 ---------------- 24873 -- Unmodified -- 24874 ---------------- 24875 24876 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME}); 24877 24878 when Pragma_Unmodified => 24879 Analyze_Unmodified_Or_Unused; 24880 24881 ------------------ 24882 -- Unreferenced -- 24883 ------------------ 24884 24885 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME}); 24886 24887 -- or when used in a context clause: 24888 24889 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME} 24890 24891 when Pragma_Unreferenced => 24892 Analyze_Unreferenced_Or_Unused; 24893 24894 -------------------------- 24895 -- Unreferenced_Objects -- 24896 -------------------------- 24897 24898 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME}); 24899 24900 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare 24901 Arg : Node_Id; 24902 Arg_Expr : Node_Id; 24903 Arg_Id : Entity_Id; 24904 24905 Ghost_Error_Posted : Boolean := False; 24906 -- Flag set when an error concerning the illegal mix of Ghost and 24907 -- non-Ghost types is emitted. 24908 24909 Ghost_Id : Entity_Id := Empty; 24910 -- The entity of the first Ghost type encountered while processing 24911 -- the arguments of the pragma. 24912 24913 begin 24914 GNAT_Pragma; 24915 Check_At_Least_N_Arguments (1); 24916 24917 Arg := Arg1; 24918 while Present (Arg) loop 24919 Check_No_Identifier (Arg); 24920 Check_Arg_Is_Local_Name (Arg); 24921 Arg_Expr := Get_Pragma_Arg (Arg); 24922 24923 if Is_Entity_Name (Arg_Expr) then 24924 Arg_Id := Entity (Arg_Expr); 24925 24926 if Is_Type (Arg_Id) then 24927 Set_Has_Pragma_Unreferenced_Objects (Arg_Id); 24928 24929 -- A pragma that applies to a Ghost entity becomes Ghost 24930 -- for the purposes of legality checks and removal of 24931 -- ignored Ghost code. 24932 24933 Mark_Ghost_Pragma (N, Arg_Id); 24934 24935 -- Capture the entity of the first Ghost type being 24936 -- processed for error detection purposes. 24937 24938 if Is_Ghost_Entity (Arg_Id) then 24939 if No (Ghost_Id) then 24940 Ghost_Id := Arg_Id; 24941 end if; 24942 24943 -- Otherwise the type is non-Ghost. It is illegal to mix 24944 -- references to Ghost and non-Ghost entities 24945 -- (SPARK RM 6.9). 24946 24947 elsif Present (Ghost_Id) 24948 and then not Ghost_Error_Posted 24949 then 24950 Ghost_Error_Posted := True; 24951 24952 Error_Msg_Name_1 := Pname; 24953 Error_Msg_N 24954 ("pragma % cannot mention ghost and non-ghost types", 24955 N); 24956 24957 Error_Msg_Sloc := Sloc (Ghost_Id); 24958 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 24959 24960 Error_Msg_Sloc := Sloc (Arg_Id); 24961 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id); 24962 end if; 24963 else 24964 Error_Pragma_Arg 24965 ("argument for pragma% must be type or subtype", Arg); 24966 end if; 24967 else 24968 Error_Pragma_Arg 24969 ("argument for pragma% must be type or subtype", Arg); 24970 end if; 24971 24972 Next (Arg); 24973 end loop; 24974 end Unreferenced_Objects; 24975 24976 ------------------------------ 24977 -- Unreserve_All_Interrupts -- 24978 ------------------------------ 24979 24980 -- pragma Unreserve_All_Interrupts; 24981 24982 when Pragma_Unreserve_All_Interrupts => 24983 GNAT_Pragma; 24984 Check_Arg_Count (0); 24985 24986 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then 24987 Unreserve_All_Interrupts := True; 24988 end if; 24989 24990 ---------------- 24991 -- Unsuppress -- 24992 ---------------- 24993 24994 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); 24995 24996 when Pragma_Unsuppress => 24997 Ada_2005_Pragma; 24998 Process_Suppress_Unsuppress (Suppress_Case => False); 24999 25000 ------------ 25001 -- Unused -- 25002 ------------ 25003 25004 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME}); 25005 25006 when Pragma_Unused => 25007 Analyze_Unmodified_Or_Unused (Is_Unused => True); 25008 Analyze_Unreferenced_Or_Unused (Is_Unused => True); 25009 25010 ------------------- 25011 -- Use_VADS_Size -- 25012 ------------------- 25013 25014 -- pragma Use_VADS_Size; 25015 25016 when Pragma_Use_VADS_Size => 25017 GNAT_Pragma; 25018 Check_Arg_Count (0); 25019 Check_Valid_Configuration_Pragma; 25020 Use_VADS_Size := True; 25021 25022 --------------------- 25023 -- Validity_Checks -- 25024 --------------------- 25025 25026 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 25027 25028 when Pragma_Validity_Checks => Validity_Checks : declare 25029 A : constant Node_Id := Get_Pragma_Arg (Arg1); 25030 S : String_Id; 25031 C : Char_Code; 25032 25033 begin 25034 GNAT_Pragma; 25035 Check_Arg_Count (1); 25036 Check_No_Identifiers; 25037 25038 -- Pragma always active unless in CodePeer or GNATprove modes, 25039 -- which use a fixed configuration of validity checks. 25040 25041 if not (CodePeer_Mode or GNATprove_Mode) then 25042 if Nkind (A) = N_String_Literal then 25043 S := Strval (A); 25044 25045 declare 25046 Slen : constant Natural := Natural (String_Length (S)); 25047 Options : String (1 .. Slen); 25048 J : Positive; 25049 25050 begin 25051 -- Couldn't we use a for loop here over Options'Range??? 25052 25053 J := 1; 25054 loop 25055 C := Get_String_Char (S, Pos (J)); 25056 25057 -- This is a weird test, it skips setting validity 25058 -- checks entirely if any element of S is out of 25059 -- range of Character, what is that about ??? 25060 25061 exit when not In_Character_Range (C); 25062 Options (J) := Get_Character (C); 25063 25064 if J = Slen then 25065 Set_Validity_Check_Options (Options); 25066 exit; 25067 else 25068 J := J + 1; 25069 end if; 25070 end loop; 25071 end; 25072 25073 elsif Nkind (A) = N_Identifier then 25074 if Chars (A) = Name_All_Checks then 25075 Set_Validity_Check_Options ("a"); 25076 elsif Chars (A) = Name_On then 25077 Validity_Checks_On := True; 25078 elsif Chars (A) = Name_Off then 25079 Validity_Checks_On := False; 25080 end if; 25081 end if; 25082 end if; 25083 end Validity_Checks; 25084 25085 -------------- 25086 -- Volatile -- 25087 -------------- 25088 25089 -- pragma Volatile (LOCAL_NAME); 25090 25091 when Pragma_Volatile => 25092 Process_Atomic_Independent_Shared_Volatile; 25093 25094 ------------------------- 25095 -- Volatile_Components -- 25096 ------------------------- 25097 25098 -- pragma Volatile_Components (array_LOCAL_NAME); 25099 25100 -- Volatile is handled by the same circuit as Atomic_Components 25101 25102 -------------------------- 25103 -- Volatile_Full_Access -- 25104 -------------------------- 25105 25106 -- pragma Volatile_Full_Access (LOCAL_NAME); 25107 25108 when Pragma_Volatile_Full_Access => 25109 GNAT_Pragma; 25110 Process_Atomic_Independent_Shared_Volatile; 25111 25112 ----------------------- 25113 -- Volatile_Function -- 25114 ----------------------- 25115 25116 -- pragma Volatile_Function [ (boolean_EXPRESSION) ]; 25117 25118 when Pragma_Volatile_Function => Volatile_Function : declare 25119 Over_Id : Entity_Id; 25120 Spec_Id : Entity_Id; 25121 Subp_Decl : Node_Id; 25122 25123 begin 25124 GNAT_Pragma; 25125 Check_No_Identifiers; 25126 Check_At_Most_N_Arguments (1); 25127 25128 Subp_Decl := 25129 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 25130 25131 -- Generic subprogram 25132 25133 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 25134 null; 25135 25136 -- Body acts as spec 25137 25138 elsif Nkind (Subp_Decl) = N_Subprogram_Body 25139 and then No (Corresponding_Spec (Subp_Decl)) 25140 then 25141 null; 25142 25143 -- Body stub acts as spec 25144 25145 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 25146 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 25147 then 25148 null; 25149 25150 -- Subprogram 25151 25152 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 25153 null; 25154 25155 else 25156 Pragma_Misplaced; 25157 return; 25158 end if; 25159 25160 Spec_Id := Unique_Defining_Entity (Subp_Decl); 25161 25162 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 25163 Pragma_Misplaced; 25164 return; 25165 end if; 25166 25167 -- A pragma that applies to a Ghost entity becomes Ghost for the 25168 -- purposes of legality checks and removal of ignored Ghost code. 25169 25170 Mark_Ghost_Pragma (N, Spec_Id); 25171 25172 -- Chain the pragma on the contract for completeness 25173 25174 Add_Contract_Item (N, Spec_Id); 25175 25176 -- The legality checks of pragma Volatile_Function are affected by 25177 -- the SPARK mode in effect. Analyze all pragmas in a specific 25178 -- order. 25179 25180 Analyze_If_Present (Pragma_SPARK_Mode); 25181 25182 -- A volatile function cannot override a non-volatile function 25183 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed 25184 -- in New_Overloaded_Entity, however at that point the pragma has 25185 -- not been processed yet. 25186 25187 Over_Id := Overridden_Operation (Spec_Id); 25188 25189 if Present (Over_Id) 25190 and then not Is_Volatile_Function (Over_Id) 25191 then 25192 Error_Msg_N 25193 ("incompatible volatile function values in effect", Spec_Id); 25194 25195 Error_Msg_Sloc := Sloc (Over_Id); 25196 Error_Msg_N 25197 ("\& declared # with Volatile_Function value False", 25198 Spec_Id); 25199 25200 Error_Msg_Sloc := Sloc (Spec_Id); 25201 Error_Msg_N 25202 ("\overridden # with Volatile_Function value True", 25203 Spec_Id); 25204 end if; 25205 25206 -- Analyze the Boolean expression (if any) 25207 25208 if Present (Arg1) then 25209 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 25210 end if; 25211 end Volatile_Function; 25212 25213 ---------------------- 25214 -- Warning_As_Error -- 25215 ---------------------- 25216 25217 -- pragma Warning_As_Error (static_string_EXPRESSION); 25218 25219 when Pragma_Warning_As_Error => 25220 GNAT_Pragma; 25221 Check_Arg_Count (1); 25222 Check_No_Identifiers; 25223 Check_Valid_Configuration_Pragma; 25224 25225 if not Is_Static_String_Expression (Arg1) then 25226 Error_Pragma_Arg 25227 ("argument of pragma% must be static string expression", 25228 Arg1); 25229 25230 -- OK static string expression 25231 25232 else 25233 Acquire_Warning_Match_String (Arg1); 25234 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1; 25235 Warnings_As_Errors (Warnings_As_Errors_Count) := 25236 new String'(Name_Buffer (1 .. Name_Len)); 25237 end if; 25238 25239 -------------- 25240 -- Warnings -- 25241 -------------- 25242 25243 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); 25244 25245 -- DETAILS ::= On | Off 25246 -- DETAILS ::= On | Off, local_NAME 25247 -- DETAILS ::= static_string_EXPRESSION 25248 -- DETAILS ::= On | Off, static_string_EXPRESSION 25249 25250 -- TOOL_NAME ::= GNAT | GNATProve 25251 25252 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} 25253 25254 -- Note: If the first argument matches an allowed tool name, it is 25255 -- always considered to be a tool name, even if there is a string 25256 -- variable of that name. 25257 25258 -- Note if the second argument of DETAILS is a local_NAME then the 25259 -- second form is always understood. If the intention is to use 25260 -- the fourth form, then you can write NAME & "" to force the 25261 -- intepretation as a static_string_EXPRESSION. 25262 25263 when Pragma_Warnings => Warnings : declare 25264 Reason : String_Id; 25265 25266 begin 25267 GNAT_Pragma; 25268 Check_At_Least_N_Arguments (1); 25269 25270 -- See if last argument is labeled Reason. If so, make sure we 25271 -- have a string literal or a concatenation of string literals, 25272 -- and acquire the REASON string. Then remove the REASON argument 25273 -- by decreasing Num_Args by one; Remaining processing looks only 25274 -- at first Num_Args arguments). 25275 25276 declare 25277 Last_Arg : constant Node_Id := 25278 Last (Pragma_Argument_Associations (N)); 25279 25280 begin 25281 if Nkind (Last_Arg) = N_Pragma_Argument_Association 25282 and then Chars (Last_Arg) = Name_Reason 25283 then 25284 Start_String; 25285 Get_Reason_String (Get_Pragma_Arg (Last_Arg)); 25286 Reason := End_String; 25287 Arg_Count := Arg_Count - 1; 25288 25289 -- Not allowed in compiler units (bootstrap issues) 25290 25291 Check_Compiler_Unit ("Reason for pragma Warnings", N); 25292 25293 -- No REASON string, set null string as reason 25294 25295 else 25296 Reason := Null_String_Id; 25297 end if; 25298 end; 25299 25300 -- Now proceed with REASON taken care of and eliminated 25301 25302 Check_No_Identifiers; 25303 25304 -- If debug flag -gnatd.i is set, pragma is ignored 25305 25306 if Debug_Flag_Dot_I then 25307 return; 25308 end if; 25309 25310 -- Process various forms of the pragma 25311 25312 declare 25313 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 25314 Shifted_Args : List_Id; 25315 25316 begin 25317 -- See if first argument is a tool name, currently either 25318 -- GNAT or GNATprove. If so, either ignore the pragma if the 25319 -- tool used does not match, or continue as if no tool name 25320 -- was given otherwise, by shifting the arguments. 25321 25322 if Nkind (Argx) = N_Identifier 25323 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove) 25324 then 25325 if Chars (Argx) = Name_Gnat then 25326 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then 25327 Rewrite (N, Make_Null_Statement (Loc)); 25328 Analyze (N); 25329 raise Pragma_Exit; 25330 end if; 25331 25332 elsif Chars (Argx) = Name_Gnatprove then 25333 if not GNATprove_Mode then 25334 Rewrite (N, Make_Null_Statement (Loc)); 25335 Analyze (N); 25336 raise Pragma_Exit; 25337 end if; 25338 25339 else 25340 raise Program_Error; 25341 end if; 25342 25343 -- At this point, the pragma Warnings applies to the tool, 25344 -- so continue with shifted arguments. 25345 25346 Arg_Count := Arg_Count - 1; 25347 25348 if Arg_Count = 1 then 25349 Shifted_Args := New_List (New_Copy (Arg2)); 25350 elsif Arg_Count = 2 then 25351 Shifted_Args := New_List (New_Copy (Arg2), 25352 New_Copy (Arg3)); 25353 elsif Arg_Count = 3 then 25354 Shifted_Args := New_List (New_Copy (Arg2), 25355 New_Copy (Arg3), 25356 New_Copy (Arg4)); 25357 else 25358 raise Program_Error; 25359 end if; 25360 25361 Rewrite (N, 25362 Make_Pragma (Loc, 25363 Chars => Name_Warnings, 25364 Pragma_Argument_Associations => Shifted_Args)); 25365 Analyze (N); 25366 raise Pragma_Exit; 25367 end if; 25368 25369 -- One argument case 25370 25371 if Arg_Count = 1 then 25372 25373 -- On/Off one argument case was processed by parser 25374 25375 if Nkind (Argx) = N_Identifier 25376 and then Nam_In (Chars (Argx), Name_On, Name_Off) 25377 then 25378 null; 25379 25380 -- One argument case must be ON/OFF or static string expr 25381 25382 elsif not Is_Static_String_Expression (Arg1) then 25383 Error_Pragma_Arg 25384 ("argument of pragma% must be On/Off or static string " 25385 & "expression", Arg1); 25386 25387 -- One argument string expression case 25388 25389 else 25390 declare 25391 Lit : constant Node_Id := Expr_Value_S (Argx); 25392 Str : constant String_Id := Strval (Lit); 25393 Len : constant Nat := String_Length (Str); 25394 C : Char_Code; 25395 J : Nat; 25396 OK : Boolean; 25397 Chr : Character; 25398 25399 begin 25400 J := 1; 25401 while J <= Len loop 25402 C := Get_String_Char (Str, J); 25403 OK := In_Character_Range (C); 25404 25405 if OK then 25406 Chr := Get_Character (C); 25407 25408 -- Dash case: only -Wxxx is accepted 25409 25410 if J = 1 25411 and then J < Len 25412 and then Chr = '-' 25413 then 25414 J := J + 1; 25415 C := Get_String_Char (Str, J); 25416 Chr := Get_Character (C); 25417 exit when Chr = 'W'; 25418 OK := False; 25419 25420 -- Dot case 25421 25422 elsif J < Len and then Chr = '.' then 25423 J := J + 1; 25424 C := Get_String_Char (Str, J); 25425 Chr := Get_Character (C); 25426 25427 if not Set_Dot_Warning_Switch (Chr) then 25428 Error_Pragma_Arg 25429 ("invalid warning switch character " 25430 & '.' & Chr, Arg1); 25431 end if; 25432 25433 -- Non-Dot case 25434 25435 else 25436 OK := Set_Warning_Switch (Chr); 25437 end if; 25438 25439 if not OK then 25440 Error_Pragma_Arg 25441 ("invalid warning switch character " & Chr, 25442 Arg1); 25443 end if; 25444 25445 else 25446 Error_Pragma_Arg 25447 ("invalid wide character in warning switch ", 25448 Arg1); 25449 end if; 25450 25451 J := J + 1; 25452 end loop; 25453 end; 25454 end if; 25455 25456 -- Two or more arguments (must be two) 25457 25458 else 25459 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 25460 Check_Arg_Count (2); 25461 25462 declare 25463 E_Id : Node_Id; 25464 E : Entity_Id; 25465 Err : Boolean; 25466 25467 begin 25468 E_Id := Get_Pragma_Arg (Arg2); 25469 Analyze (E_Id); 25470 25471 -- In the expansion of an inlined body, a reference to 25472 -- the formal may be wrapped in a conversion if the 25473 -- actual is a conversion. Retrieve the real entity name. 25474 25475 if (In_Instance_Body or In_Inlined_Body) 25476 and then Nkind (E_Id) = N_Unchecked_Type_Conversion 25477 then 25478 E_Id := Expression (E_Id); 25479 end if; 25480 25481 -- Entity name case 25482 25483 if Is_Entity_Name (E_Id) then 25484 E := Entity (E_Id); 25485 25486 if E = Any_Id then 25487 return; 25488 else 25489 loop 25490 Set_Warnings_Off 25491 (E, (Chars (Get_Pragma_Arg (Arg1)) = 25492 Name_Off)); 25493 25494 -- Suppress elaboration warnings if the entity 25495 -- denotes an elaboration target. 25496 25497 if Is_Elaboration_Target (E) then 25498 Set_Is_Elaboration_Warnings_OK_Id (E, False); 25499 end if; 25500 25501 -- For OFF case, make entry in warnings off 25502 -- pragma table for later processing. But we do 25503 -- not do that within an instance, since these 25504 -- warnings are about what is needed in the 25505 -- template, not an instance of it. 25506 25507 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off 25508 and then Warn_On_Warnings_Off 25509 and then not In_Instance 25510 then 25511 Warnings_Off_Pragmas.Append ((N, E, Reason)); 25512 end if; 25513 25514 if Is_Enumeration_Type (E) then 25515 declare 25516 Lit : Entity_Id; 25517 begin 25518 Lit := First_Literal (E); 25519 while Present (Lit) loop 25520 Set_Warnings_Off (Lit); 25521 Next_Literal (Lit); 25522 end loop; 25523 end; 25524 end if; 25525 25526 exit when No (Homonym (E)); 25527 E := Homonym (E); 25528 end loop; 25529 end if; 25530 25531 -- Error if not entity or static string expression case 25532 25533 elsif not Is_Static_String_Expression (Arg2) then 25534 Error_Pragma_Arg 25535 ("second argument of pragma% must be entity name " 25536 & "or static string expression", Arg2); 25537 25538 -- Static string expression case 25539 25540 else 25541 Acquire_Warning_Match_String (Arg2); 25542 25543 -- Note on configuration pragma case: If this is a 25544 -- configuration pragma, then for an OFF pragma, we 25545 -- just set Config True in the call, which is all 25546 -- that needs to be done. For the case of ON, this 25547 -- is normally an error, unless it is canceling the 25548 -- effect of a previous OFF pragma in the same file. 25549 -- In any other case, an error will be signalled (ON 25550 -- with no matching OFF). 25551 25552 -- Note: We set Used if we are inside a generic to 25553 -- disable the test that the non-config case actually 25554 -- cancels a warning. That's because we can't be sure 25555 -- there isn't an instantiation in some other unit 25556 -- where a warning is suppressed. 25557 25558 -- We could do a little better here by checking if the 25559 -- generic unit we are inside is public, but for now 25560 -- we don't bother with that refinement. 25561 25562 if Chars (Argx) = Name_Off then 25563 Set_Specific_Warning_Off 25564 (Loc, Name_Buffer (1 .. Name_Len), Reason, 25565 Config => Is_Configuration_Pragma, 25566 Used => Inside_A_Generic or else In_Instance); 25567 25568 elsif Chars (Argx) = Name_On then 25569 Set_Specific_Warning_On 25570 (Loc, Name_Buffer (1 .. Name_Len), Err); 25571 25572 if Err then 25573 Error_Msg 25574 ("??pragma Warnings On with no matching " 25575 & "Warnings Off", Loc); 25576 end if; 25577 end if; 25578 end if; 25579 end; 25580 end if; 25581 end; 25582 end Warnings; 25583 25584 ------------------- 25585 -- Weak_External -- 25586 ------------------- 25587 25588 -- pragma Weak_External ([Entity =>] LOCAL_NAME); 25589 25590 when Pragma_Weak_External => Weak_External : declare 25591 Ent : Entity_Id; 25592 25593 begin 25594 GNAT_Pragma; 25595 Check_Arg_Count (1); 25596 Check_Optional_Identifier (Arg1, Name_Entity); 25597 Check_Arg_Is_Library_Level_Local_Name (Arg1); 25598 Ent := Entity (Get_Pragma_Arg (Arg1)); 25599 25600 if Rep_Item_Too_Early (Ent, N) then 25601 return; 25602 else 25603 Ent := Underlying_Type (Ent); 25604 end if; 25605 25606 -- The only processing required is to link this item on to the 25607 -- list of rep items for the given entity. This is accomplished 25608 -- by the call to Rep_Item_Too_Late (when no error is detected 25609 -- and False is returned). 25610 25611 if Rep_Item_Too_Late (Ent, N) then 25612 return; 25613 else 25614 Set_Has_Gigi_Rep_Item (Ent); 25615 end if; 25616 end Weak_External; 25617 25618 ----------------------------- 25619 -- Wide_Character_Encoding -- 25620 ----------------------------- 25621 25622 -- pragma Wide_Character_Encoding (IDENTIFIER); 25623 25624 when Pragma_Wide_Character_Encoding => 25625 GNAT_Pragma; 25626 25627 -- Nothing to do, handled in parser. Note that we do not enforce 25628 -- configuration pragma placement, this pragma can appear at any 25629 -- place in the source, allowing mixed encodings within a single 25630 -- source program. 25631 25632 null; 25633 25634 -------------------- 25635 -- Unknown_Pragma -- 25636 -------------------- 25637 25638 -- Should be impossible, since the case of an unknown pragma is 25639 -- separately processed before the case statement is entered. 25640 25641 when Unknown_Pragma => 25642 raise Program_Error; 25643 end case; 25644 25645 -- AI05-0144: detect dangerous order dependence. Disabled for now, 25646 -- until AI is formally approved. 25647 25648 -- Check_Order_Dependence; 25649 25650 exception 25651 when Pragma_Exit => null; 25652 end Analyze_Pragma; 25653 25654 --------------------------------------------- 25655 -- Analyze_Pre_Post_Condition_In_Decl_Part -- 25656 --------------------------------------------- 25657 25658 -- WARNING: This routine manages Ghost regions. Return statements must be 25659 -- replaced by gotos which jump to the end of the routine and restore the 25660 -- Ghost mode. 25661 25662 procedure Analyze_Pre_Post_Condition_In_Decl_Part 25663 (N : Node_Id; 25664 Freeze_Id : Entity_Id := Empty) 25665 is 25666 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 25667 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 25668 25669 Disp_Typ : Entity_Id; 25670 -- The dispatching type of the subprogram subject to the pre- or 25671 -- postcondition. 25672 25673 function Check_References (Nod : Node_Id) return Traverse_Result; 25674 -- Check that expression Nod does not mention non-primitives of the 25675 -- type, global objects of the type, or other illegalities described 25676 -- and implied by AI12-0113. 25677 25678 ---------------------- 25679 -- Check_References -- 25680 ---------------------- 25681 25682 function Check_References (Nod : Node_Id) return Traverse_Result is 25683 begin 25684 if Nkind (Nod) = N_Function_Call 25685 and then Is_Entity_Name (Name (Nod)) 25686 then 25687 declare 25688 Func : constant Entity_Id := Entity (Name (Nod)); 25689 Form : Entity_Id; 25690 25691 begin 25692 -- An operation of the type must be a primitive 25693 25694 if No (Find_Dispatching_Type (Func)) then 25695 Form := First_Formal (Func); 25696 while Present (Form) loop 25697 if Etype (Form) = Disp_Typ then 25698 Error_Msg_NE 25699 ("operation in class-wide condition must be " 25700 & "primitive of &", Nod, Disp_Typ); 25701 end if; 25702 25703 Next_Formal (Form); 25704 end loop; 25705 25706 -- A return object of the type is illegal as well 25707 25708 if Etype (Func) = Disp_Typ 25709 or else Etype (Func) = Class_Wide_Type (Disp_Typ) 25710 then 25711 Error_Msg_NE 25712 ("operation in class-wide condition must be primitive " 25713 & "of &", Nod, Disp_Typ); 25714 end if; 25715 25716 -- Otherwise we have a call to an overridden primitive, and we 25717 -- will create a common class-wide clone for the body of 25718 -- original operation and its eventual inherited versions. If 25719 -- the original operation dispatches on result it is never 25720 -- inherited and there is no need for a clone. There is not 25721 -- need for a clone either in GNATprove mode, as cases that 25722 -- would require it are rejected (when an inherited primitive 25723 -- calls an overridden operation in a class-wide contract), and 25724 -- the clone would make proof impossible in some cases. 25725 25726 elsif not Is_Abstract_Subprogram (Spec_Id) 25727 and then No (Class_Wide_Clone (Spec_Id)) 25728 and then not Has_Controlling_Result (Spec_Id) 25729 and then not GNATprove_Mode 25730 then 25731 Build_Class_Wide_Clone_Decl (Spec_Id); 25732 end if; 25733 end; 25734 25735 elsif Is_Entity_Name (Nod) 25736 and then 25737 (Etype (Nod) = Disp_Typ 25738 or else Etype (Nod) = Class_Wide_Type (Disp_Typ)) 25739 and then Ekind_In (Entity (Nod), E_Constant, E_Variable) 25740 then 25741 Error_Msg_NE 25742 ("object in class-wide condition must be formal of type &", 25743 Nod, Disp_Typ); 25744 25745 elsif Nkind (Nod) = N_Explicit_Dereference 25746 and then (Etype (Nod) = Disp_Typ 25747 or else Etype (Nod) = Class_Wide_Type (Disp_Typ)) 25748 and then (not Is_Entity_Name (Prefix (Nod)) 25749 or else not Is_Formal (Entity (Prefix (Nod)))) 25750 then 25751 Error_Msg_NE 25752 ("operation in class-wide condition must be primitive of &", 25753 Nod, Disp_Typ); 25754 end if; 25755 25756 return OK; 25757 end Check_References; 25758 25759 procedure Check_Class_Wide_Condition is 25760 new Traverse_Proc (Check_References); 25761 25762 -- Local variables 25763 25764 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 25765 25766 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 25767 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 25768 -- Save the Ghost-related attributes to restore on exit 25769 25770 Errors : Nat; 25771 Restore_Scope : Boolean := False; 25772 25773 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part 25774 25775 begin 25776 -- Do not analyze the pragma multiple times 25777 25778 if Is_Analyzed_Pragma (N) then 25779 return; 25780 end if; 25781 25782 -- Set the Ghost mode in effect from the pragma. Due to the delayed 25783 -- analysis of the pragma, the Ghost mode at point of declaration and 25784 -- point of analysis may not necessarily be the same. Use the mode in 25785 -- effect at the point of declaration. 25786 25787 Set_Ghost_Mode (N); 25788 25789 -- Ensure that the subprogram and its formals are visible when analyzing 25790 -- the expression of the pragma. 25791 25792 if not In_Open_Scopes (Spec_Id) then 25793 Restore_Scope := True; 25794 Push_Scope (Spec_Id); 25795 25796 if Is_Generic_Subprogram (Spec_Id) then 25797 Install_Generic_Formals (Spec_Id); 25798 else 25799 Install_Formals (Spec_Id); 25800 end if; 25801 end if; 25802 25803 Errors := Serious_Errors_Detected; 25804 Preanalyze_Assert_Expression (Expr, Standard_Boolean); 25805 25806 -- Emit a clarification message when the expression contains at least 25807 -- one undefined reference, possibly due to contract freezing. 25808 25809 if Errors /= Serious_Errors_Detected 25810 and then Present (Freeze_Id) 25811 and then Has_Undefined_Reference (Expr) 25812 then 25813 Contract_Freeze_Error (Spec_Id, Freeze_Id); 25814 end if; 25815 25816 if Class_Present (N) then 25817 25818 -- Verify that a class-wide condition is legal, i.e. the operation is 25819 -- a primitive of a tagged type. Note that a generic subprogram is 25820 -- not a primitive operation. 25821 25822 Disp_Typ := Find_Dispatching_Type (Spec_Id); 25823 25824 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then 25825 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N); 25826 25827 if From_Aspect_Specification (N) then 25828 Error_Msg_N 25829 ("aspect % can only be specified for a primitive operation " 25830 & "of a tagged type", Corresponding_Aspect (N)); 25831 25832 -- The pragma is a source construct 25833 25834 else 25835 Error_Msg_N 25836 ("pragma % can only be specified for a primitive operation " 25837 & "of a tagged type", N); 25838 end if; 25839 25840 -- Remaining semantic checks require a full tree traversal 25841 25842 else 25843 Check_Class_Wide_Condition (Expr); 25844 end if; 25845 25846 end if; 25847 25848 if Restore_Scope then 25849 End_Scope; 25850 end if; 25851 25852 -- If analysis of the condition indicates that a class-wide clone 25853 -- has been created, build and analyze its declaration. 25854 25855 if Is_Subprogram (Spec_Id) 25856 and then Present (Class_Wide_Clone (Spec_Id)) 25857 then 25858 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id))); 25859 end if; 25860 25861 -- Currently it is not possible to inline pre/postconditions on a 25862 -- subprogram subject to pragma Inline_Always. 25863 25864 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 25865 Set_Is_Analyzed_Pragma (N); 25866 25867 Restore_Ghost_Region (Saved_GM, Saved_IGR); 25868 end Analyze_Pre_Post_Condition_In_Decl_Part; 25869 25870 ------------------------------------------ 25871 -- Analyze_Refined_Depends_In_Decl_Part -- 25872 ------------------------------------------ 25873 25874 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is 25875 procedure Check_Dependency_Clause 25876 (Spec_Id : Entity_Id; 25877 Dep_Clause : Node_Id; 25878 Dep_States : Elist_Id; 25879 Refinements : List_Id; 25880 Matched_Items : in out Elist_Id); 25881 -- Try to match a single dependency clause Dep_Clause against one or 25882 -- more refinement clauses found in list Refinements. Each successful 25883 -- match eliminates at least one refinement clause from Refinements. 25884 -- Spec_Id denotes the entity of the related subprogram. Dep_States 25885 -- denotes the entities of all abstract states which appear in pragma 25886 -- Depends. Matched_Items contains the entities of all successfully 25887 -- matched items found in pragma Depends. 25888 25889 procedure Check_Output_States 25890 (Spec_Id : Entity_Id; 25891 Spec_Inputs : Elist_Id; 25892 Spec_Outputs : Elist_Id; 25893 Body_Inputs : Elist_Id; 25894 Body_Outputs : Elist_Id); 25895 -- Determine whether pragma Depends contains an output state with a 25896 -- visible refinement and if so, ensure that pragma Refined_Depends 25897 -- mentions all its constituents as outputs. Spec_Id is the entity of 25898 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the 25899 -- inputs and outputs of the subprogram spec synthesized from pragma 25900 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs 25901 -- of the subprogram body synthesized from pragma Refined_Depends. 25902 25903 function Collect_States (Clauses : List_Id) return Elist_Id; 25904 -- Given a normalized list of dependencies obtained from calling 25905 -- Normalize_Clauses, return a list containing the entities of all 25906 -- states appearing in dependencies. It helps in checking refinements 25907 -- involving a state and a corresponding constituent which is not a 25908 -- direct constituent of the state. 25909 25910 procedure Normalize_Clauses (Clauses : List_Id); 25911 -- Given a list of dependence or refinement clauses Clauses, normalize 25912 -- each clause by creating multiple dependencies with exactly one input 25913 -- and one output. 25914 25915 procedure Remove_Extra_Clauses 25916 (Clauses : List_Id; 25917 Matched_Items : Elist_Id); 25918 -- Given a list of refinement clauses Clauses, remove all clauses whose 25919 -- inputs and/or outputs have been previously matched. See the body for 25920 -- all special cases. Matched_Items contains the entities of all matched 25921 -- items found in pragma Depends. 25922 25923 procedure Report_Extra_Clauses 25924 (Spec_Id : Entity_Id; 25925 Clauses : List_Id); 25926 -- Emit an error for each extra clause found in list Clauses. Spec_Id 25927 -- denotes the entity of the related subprogram. 25928 25929 ----------------------------- 25930 -- Check_Dependency_Clause -- 25931 ----------------------------- 25932 25933 procedure Check_Dependency_Clause 25934 (Spec_Id : Entity_Id; 25935 Dep_Clause : Node_Id; 25936 Dep_States : Elist_Id; 25937 Refinements : List_Id; 25938 Matched_Items : in out Elist_Id) 25939 is 25940 Dep_Input : constant Node_Id := Expression (Dep_Clause); 25941 Dep_Output : constant Node_Id := First (Choices (Dep_Clause)); 25942 25943 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean; 25944 -- Determine whether dependency item Dep_Item has been matched in a 25945 -- previous clause. 25946 25947 function Is_In_Out_State_Clause return Boolean; 25948 -- Determine whether dependence clause Dep_Clause denotes an abstract 25949 -- state that depends on itself (State => State). 25950 25951 function Is_Null_Refined_State (Item : Node_Id) return Boolean; 25952 -- Determine whether item Item denotes an abstract state with visible 25953 -- null refinement. 25954 25955 procedure Match_Items 25956 (Dep_Item : Node_Id; 25957 Ref_Item : Node_Id; 25958 Matched : out Boolean); 25959 -- Try to match dependence item Dep_Item against refinement item 25960 -- Ref_Item. To match against a possible null refinement (see 2, 9), 25961 -- set Ref_Item to Empty. Flag Matched is set to True when one of 25962 -- the following conformance scenarios is in effect: 25963 -- 1) Both items denote null 25964 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case) 25965 -- 3) Both items denote attribute 'Result 25966 -- 4) Both items denote the same object 25967 -- 5) Both items denote the same formal parameter 25968 -- 6) Both items denote the same current instance of a type 25969 -- 7) Both items denote the same discriminant 25970 -- 8) Dep_Item is an abstract state with visible null refinement 25971 -- and Ref_Item denotes null. 25972 -- 9) Dep_Item is an abstract state with visible null refinement 25973 -- and Ref_Item is Empty (special case). 25974 -- 10) Dep_Item is an abstract state with full or partial visible 25975 -- non-null refinement and Ref_Item denotes one of its 25976 -- constituents. 25977 -- 11) Dep_Item is an abstract state without a full visible 25978 -- refinement and Ref_Item denotes the same state. 25979 -- When scenario 10 is in effect, the entity of the abstract state 25980 -- denoted by Dep_Item is added to list Refined_States. 25981 25982 procedure Record_Item (Item_Id : Entity_Id); 25983 -- Store the entity of an item denoted by Item_Id in Matched_Items 25984 25985 ------------------------ 25986 -- Is_Already_Matched -- 25987 ------------------------ 25988 25989 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is 25990 Item_Id : Entity_Id := Empty; 25991 25992 begin 25993 -- When the dependency item denotes attribute 'Result, check for 25994 -- the entity of the related subprogram. 25995 25996 if Is_Attribute_Result (Dep_Item) then 25997 Item_Id := Spec_Id; 25998 25999 elsif Is_Entity_Name (Dep_Item) then 26000 Item_Id := Available_View (Entity_Of (Dep_Item)); 26001 end if; 26002 26003 return 26004 Present (Item_Id) and then Contains (Matched_Items, Item_Id); 26005 end Is_Already_Matched; 26006 26007 ---------------------------- 26008 -- Is_In_Out_State_Clause -- 26009 ---------------------------- 26010 26011 function Is_In_Out_State_Clause return Boolean is 26012 Dep_Input_Id : Entity_Id; 26013 Dep_Output_Id : Entity_Id; 26014 26015 begin 26016 -- Detect the following clause: 26017 -- State => State 26018 26019 if Is_Entity_Name (Dep_Input) 26020 and then Is_Entity_Name (Dep_Output) 26021 then 26022 -- Handle abstract views generated for limited with clauses 26023 26024 Dep_Input_Id := Available_View (Entity_Of (Dep_Input)); 26025 Dep_Output_Id := Available_View (Entity_Of (Dep_Output)); 26026 26027 return 26028 Ekind (Dep_Input_Id) = E_Abstract_State 26029 and then Dep_Input_Id = Dep_Output_Id; 26030 else 26031 return False; 26032 end if; 26033 end Is_In_Out_State_Clause; 26034 26035 --------------------------- 26036 -- Is_Null_Refined_State -- 26037 --------------------------- 26038 26039 function Is_Null_Refined_State (Item : Node_Id) return Boolean is 26040 Item_Id : Entity_Id; 26041 26042 begin 26043 if Is_Entity_Name (Item) then 26044 26045 -- Handle abstract views generated for limited with clauses 26046 26047 Item_Id := Available_View (Entity_Of (Item)); 26048 26049 return 26050 Ekind (Item_Id) = E_Abstract_State 26051 and then Has_Null_Visible_Refinement (Item_Id); 26052 else 26053 return False; 26054 end if; 26055 end Is_Null_Refined_State; 26056 26057 ----------------- 26058 -- Match_Items -- 26059 ----------------- 26060 26061 procedure Match_Items 26062 (Dep_Item : Node_Id; 26063 Ref_Item : Node_Id; 26064 Matched : out Boolean) 26065 is 26066 Dep_Item_Id : Entity_Id; 26067 Ref_Item_Id : Entity_Id; 26068 26069 begin 26070 -- Assume that the two items do not match 26071 26072 Matched := False; 26073 26074 -- A null matches null or Empty (special case) 26075 26076 if Nkind (Dep_Item) = N_Null 26077 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null) 26078 then 26079 Matched := True; 26080 26081 -- Attribute 'Result matches attribute 'Result 26082 26083 elsif Is_Attribute_Result (Dep_Item) 26084 and then Is_Attribute_Result (Ref_Item) 26085 then 26086 -- Put the entity of the related function on the list of 26087 -- matched items because attribute 'Result does not carry 26088 -- an entity similar to states and constituents. 26089 26090 Record_Item (Spec_Id); 26091 Matched := True; 26092 26093 -- Abstract states, current instances of concurrent types, 26094 -- discriminants, formal parameters and objects. 26095 26096 elsif Is_Entity_Name (Dep_Item) then 26097 26098 -- Handle abstract views generated for limited with clauses 26099 26100 Dep_Item_Id := Available_View (Entity_Of (Dep_Item)); 26101 26102 if Ekind (Dep_Item_Id) = E_Abstract_State then 26103 26104 -- An abstract state with visible null refinement matches 26105 -- null or Empty (special case). 26106 26107 if Has_Null_Visible_Refinement (Dep_Item_Id) 26108 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null) 26109 then 26110 Record_Item (Dep_Item_Id); 26111 Matched := True; 26112 26113 -- An abstract state with visible non-null refinement 26114 -- matches one of its constituents, or itself for an 26115 -- abstract state with partial visible refinement. 26116 26117 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then 26118 if Is_Entity_Name (Ref_Item) then 26119 Ref_Item_Id := Entity_Of (Ref_Item); 26120 26121 if Ekind_In (Ref_Item_Id, E_Abstract_State, 26122 E_Constant, 26123 E_Variable) 26124 and then Present (Encapsulating_State (Ref_Item_Id)) 26125 and then Find_Encapsulating_State 26126 (Dep_States, Ref_Item_Id) = Dep_Item_Id 26127 then 26128 Record_Item (Dep_Item_Id); 26129 Matched := True; 26130 26131 elsif not Has_Visible_Refinement (Dep_Item_Id) 26132 and then Ref_Item_Id = Dep_Item_Id 26133 then 26134 Record_Item (Dep_Item_Id); 26135 Matched := True; 26136 end if; 26137 end if; 26138 26139 -- An abstract state without a visible refinement matches 26140 -- itself. 26141 26142 elsif Is_Entity_Name (Ref_Item) 26143 and then Entity_Of (Ref_Item) = Dep_Item_Id 26144 then 26145 Record_Item (Dep_Item_Id); 26146 Matched := True; 26147 end if; 26148 26149 -- A current instance of a concurrent type, discriminant, 26150 -- formal parameter or an object matches itself. 26151 26152 elsif Is_Entity_Name (Ref_Item) 26153 and then Entity_Of (Ref_Item) = Dep_Item_Id 26154 then 26155 Record_Item (Dep_Item_Id); 26156 Matched := True; 26157 end if; 26158 end if; 26159 end Match_Items; 26160 26161 ----------------- 26162 -- Record_Item -- 26163 ----------------- 26164 26165 procedure Record_Item (Item_Id : Entity_Id) is 26166 begin 26167 if No (Matched_Items) then 26168 Matched_Items := New_Elmt_List; 26169 end if; 26170 26171 Append_Unique_Elmt (Item_Id, Matched_Items); 26172 end Record_Item; 26173 26174 -- Local variables 26175 26176 Clause_Matched : Boolean := False; 26177 Dummy : Boolean := False; 26178 Inputs_Match : Boolean; 26179 Next_Ref_Clause : Node_Id; 26180 Outputs_Match : Boolean; 26181 Ref_Clause : Node_Id; 26182 Ref_Input : Node_Id; 26183 Ref_Output : Node_Id; 26184 26185 -- Start of processing for Check_Dependency_Clause 26186 26187 begin 26188 -- Do not perform this check in an instance because it was already 26189 -- performed successfully in the generic template. 26190 26191 if Is_Generic_Instance (Spec_Id) then 26192 return; 26193 end if; 26194 26195 -- Examine all refinement clauses and compare them against the 26196 -- dependence clause. 26197 26198 Ref_Clause := First (Refinements); 26199 while Present (Ref_Clause) loop 26200 Next_Ref_Clause := Next (Ref_Clause); 26201 26202 -- Obtain the attributes of the current refinement clause 26203 26204 Ref_Input := Expression (Ref_Clause); 26205 Ref_Output := First (Choices (Ref_Clause)); 26206 26207 -- The current refinement clause matches the dependence clause 26208 -- when both outputs match and both inputs match. See routine 26209 -- Match_Items for all possible conformance scenarios. 26210 26211 -- Depends Dep_Output => Dep_Input 26212 -- ^ ^ 26213 -- match ? match ? 26214 -- v v 26215 -- Refined_Depends Ref_Output => Ref_Input 26216 26217 Match_Items 26218 (Dep_Item => Dep_Input, 26219 Ref_Item => Ref_Input, 26220 Matched => Inputs_Match); 26221 26222 Match_Items 26223 (Dep_Item => Dep_Output, 26224 Ref_Item => Ref_Output, 26225 Matched => Outputs_Match); 26226 26227 -- An In_Out state clause may be matched against a refinement with 26228 -- a null input or null output as long as the non-null side of the 26229 -- relation contains a valid constituent of the In_Out_State. 26230 26231 if Is_In_Out_State_Clause then 26232 26233 -- Depends => (State => State) 26234 -- Refined_Depends => (null => Constit) -- OK 26235 26236 if Inputs_Match 26237 and then not Outputs_Match 26238 and then Nkind (Ref_Output) = N_Null 26239 then 26240 Outputs_Match := True; 26241 end if; 26242 26243 -- Depends => (State => State) 26244 -- Refined_Depends => (Constit => null) -- OK 26245 26246 if not Inputs_Match 26247 and then Outputs_Match 26248 and then Nkind (Ref_Input) = N_Null 26249 then 26250 Inputs_Match := True; 26251 end if; 26252 end if; 26253 26254 -- The current refinement clause is legally constructed following 26255 -- the rules in SPARK RM 7.2.5, therefore it can be removed from 26256 -- the pool of candidates. The seach continues because a single 26257 -- dependence clause may have multiple matching refinements. 26258 26259 if Inputs_Match and Outputs_Match then 26260 Clause_Matched := True; 26261 Remove (Ref_Clause); 26262 end if; 26263 26264 Ref_Clause := Next_Ref_Clause; 26265 end loop; 26266 26267 -- Depending on the order or composition of refinement clauses, an 26268 -- In_Out state clause may not be directly refinable. 26269 26270 -- Refined_State => (State => (Constit_1, Constit_2)) 26271 -- Depends => ((Output, State) => (Input, State)) 26272 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2) 26273 26274 -- Matching normalized clause (State => State) fails because there is 26275 -- no direct refinement capable of satisfying this relation. Another 26276 -- similar case arises when clauses (Constit_1 => Input) and (Output 26277 -- => Constit_2) are matched first, leaving no candidates for clause 26278 -- (State => State). Both scenarios are legal as long as one of the 26279 -- previous clauses mentioned a valid constituent of State. 26280 26281 if not Clause_Matched 26282 and then Is_In_Out_State_Clause 26283 and then Is_Already_Matched (Dep_Input) 26284 then 26285 Clause_Matched := True; 26286 end if; 26287 26288 -- A clause where the input is an abstract state with visible null 26289 -- refinement or a 'Result attribute is implicitly matched when the 26290 -- output has already been matched in a previous clause. 26291 26292 -- Refined_State => (State => null) 26293 -- Depends => (Output => State) -- implicitly OK 26294 -- Refined_Depends => (Output => ...) 26295 -- Depends => (...'Result => State) -- implicitly OK 26296 -- Refined_Depends => (...'Result => ...) 26297 26298 if not Clause_Matched 26299 and then Is_Null_Refined_State (Dep_Input) 26300 and then Is_Already_Matched (Dep_Output) 26301 then 26302 Clause_Matched := True; 26303 end if; 26304 26305 -- A clause where the output is an abstract state with visible null 26306 -- refinement is implicitly matched when the input has already been 26307 -- matched in a previous clause. 26308 26309 -- Refined_State => (State => null) 26310 -- Depends => (State => Input) -- implicitly OK 26311 -- Refined_Depends => (... => Input) 26312 26313 if not Clause_Matched 26314 and then Is_Null_Refined_State (Dep_Output) 26315 and then Is_Already_Matched (Dep_Input) 26316 then 26317 Clause_Matched := True; 26318 end if; 26319 26320 -- At this point either all refinement clauses have been examined or 26321 -- pragma Refined_Depends contains a solitary null. Only an abstract 26322 -- state with null refinement can possibly match these cases. 26323 26324 -- Refined_State => (State => null) 26325 -- Depends => (State => null) 26326 -- Refined_Depends => null -- OK 26327 26328 if not Clause_Matched then 26329 Match_Items 26330 (Dep_Item => Dep_Input, 26331 Ref_Item => Empty, 26332 Matched => Inputs_Match); 26333 26334 Match_Items 26335 (Dep_Item => Dep_Output, 26336 Ref_Item => Empty, 26337 Matched => Outputs_Match); 26338 26339 Clause_Matched := Inputs_Match and Outputs_Match; 26340 end if; 26341 26342 -- If the contents of Refined_Depends are legal, then the current 26343 -- dependence clause should be satisfied either by an explicit match 26344 -- or by one of the special cases. 26345 26346 if not Clause_Matched then 26347 SPARK_Msg_NE 26348 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no " 26349 & "matching refinement in body"), Dep_Clause, Spec_Id); 26350 end if; 26351 end Check_Dependency_Clause; 26352 26353 ------------------------- 26354 -- Check_Output_States -- 26355 ------------------------- 26356 26357 procedure Check_Output_States 26358 (Spec_Id : Entity_Id; 26359 Spec_Inputs : Elist_Id; 26360 Spec_Outputs : Elist_Id; 26361 Body_Inputs : Elist_Id; 26362 Body_Outputs : Elist_Id) 26363 is 26364 procedure Check_Constituent_Usage (State_Id : Entity_Id); 26365 -- Determine whether all constituents of state State_Id with full 26366 -- visible refinement are used as outputs in pragma Refined_Depends. 26367 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)). 26368 26369 ----------------------------- 26370 -- Check_Constituent_Usage -- 26371 ----------------------------- 26372 26373 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 26374 Constits : constant Elist_Id := 26375 Partial_Refinement_Constituents (State_Id); 26376 Constit_Elmt : Elmt_Id; 26377 Constit_Id : Entity_Id; 26378 Only_Partial : constant Boolean := 26379 not Has_Visible_Refinement (State_Id); 26380 Posted : Boolean := False; 26381 26382 begin 26383 if Present (Constits) then 26384 Constit_Elmt := First_Elmt (Constits); 26385 while Present (Constit_Elmt) loop 26386 Constit_Id := Node (Constit_Elmt); 26387 26388 -- Issue an error when a constituent of State_Id is used, 26389 -- and State_Id has only partial visible refinement 26390 -- (SPARK RM 7.2.4(3d)). 26391 26392 if Only_Partial then 26393 if (Present (Body_Inputs) 26394 and then Appears_In (Body_Inputs, Constit_Id)) 26395 or else 26396 (Present (Body_Outputs) 26397 and then Appears_In (Body_Outputs, Constit_Id)) 26398 then 26399 Error_Msg_Name_1 := Chars (State_Id); 26400 SPARK_Msg_NE 26401 ("constituent & of state % cannot be used in " 26402 & "dependence refinement", N, Constit_Id); 26403 Error_Msg_Name_1 := Chars (State_Id); 26404 SPARK_Msg_N ("\use state % instead", N); 26405 end if; 26406 26407 -- The constituent acts as an input (SPARK RM 7.2.5(3)) 26408 26409 elsif Present (Body_Inputs) 26410 and then Appears_In (Body_Inputs, Constit_Id) 26411 then 26412 Error_Msg_Name_1 := Chars (State_Id); 26413 SPARK_Msg_NE 26414 ("constituent & of state % must act as output in " 26415 & "dependence refinement", N, Constit_Id); 26416 26417 -- The constituent is altogether missing (SPARK RM 7.2.5(3)) 26418 26419 elsif No (Body_Outputs) 26420 or else not Appears_In (Body_Outputs, Constit_Id) 26421 then 26422 if not Posted then 26423 Posted := True; 26424 SPARK_Msg_NE 26425 ("output state & must be replaced by all its " 26426 & "constituents in dependence refinement", 26427 N, State_Id); 26428 end if; 26429 26430 SPARK_Msg_NE 26431 ("\constituent & is missing in output list", 26432 N, Constit_Id); 26433 end if; 26434 26435 Next_Elmt (Constit_Elmt); 26436 end loop; 26437 end if; 26438 end Check_Constituent_Usage; 26439 26440 -- Local variables 26441 26442 Item : Node_Id; 26443 Item_Elmt : Elmt_Id; 26444 Item_Id : Entity_Id; 26445 26446 -- Start of processing for Check_Output_States 26447 26448 begin 26449 -- Do not perform this check in an instance because it was already 26450 -- performed successfully in the generic template. 26451 26452 if Is_Generic_Instance (Spec_Id) then 26453 null; 26454 26455 -- Inspect the outputs of pragma Depends looking for a state with a 26456 -- visible refinement. 26457 26458 elsif Present (Spec_Outputs) then 26459 Item_Elmt := First_Elmt (Spec_Outputs); 26460 while Present (Item_Elmt) loop 26461 Item := Node (Item_Elmt); 26462 26463 -- Deal with the mixed nature of the input and output lists 26464 26465 if Nkind (Item) = N_Defining_Identifier then 26466 Item_Id := Item; 26467 else 26468 Item_Id := Available_View (Entity_Of (Item)); 26469 end if; 26470 26471 if Ekind (Item_Id) = E_Abstract_State then 26472 26473 -- The state acts as an input-output, skip it 26474 26475 if Present (Spec_Inputs) 26476 and then Appears_In (Spec_Inputs, Item_Id) 26477 then 26478 null; 26479 26480 -- Ensure that all of the constituents are utilized as 26481 -- outputs in pragma Refined_Depends. 26482 26483 elsif Has_Non_Null_Visible_Refinement (Item_Id) then 26484 Check_Constituent_Usage (Item_Id); 26485 end if; 26486 end if; 26487 26488 Next_Elmt (Item_Elmt); 26489 end loop; 26490 end if; 26491 end Check_Output_States; 26492 26493 -------------------- 26494 -- Collect_States -- 26495 -------------------- 26496 26497 function Collect_States (Clauses : List_Id) return Elist_Id is 26498 procedure Collect_State 26499 (Item : Node_Id; 26500 States : in out Elist_Id); 26501 -- Add the entity of Item to list States when it denotes to a state 26502 26503 ------------------- 26504 -- Collect_State -- 26505 ------------------- 26506 26507 procedure Collect_State 26508 (Item : Node_Id; 26509 States : in out Elist_Id) 26510 is 26511 Id : Entity_Id; 26512 26513 begin 26514 if Is_Entity_Name (Item) then 26515 Id := Entity_Of (Item); 26516 26517 if Ekind (Id) = E_Abstract_State then 26518 if No (States) then 26519 States := New_Elmt_List; 26520 end if; 26521 26522 Append_Unique_Elmt (Id, States); 26523 end if; 26524 end if; 26525 end Collect_State; 26526 26527 -- Local variables 26528 26529 Clause : Node_Id; 26530 Input : Node_Id; 26531 Output : Node_Id; 26532 States : Elist_Id := No_Elist; 26533 26534 -- Start of processing for Collect_States 26535 26536 begin 26537 Clause := First (Clauses); 26538 while Present (Clause) loop 26539 Input := Expression (Clause); 26540 Output := First (Choices (Clause)); 26541 26542 Collect_State (Input, States); 26543 Collect_State (Output, States); 26544 26545 Next (Clause); 26546 end loop; 26547 26548 return States; 26549 end Collect_States; 26550 26551 ----------------------- 26552 -- Normalize_Clauses -- 26553 ----------------------- 26554 26555 procedure Normalize_Clauses (Clauses : List_Id) is 26556 procedure Normalize_Inputs (Clause : Node_Id); 26557 -- Normalize clause Clause by creating multiple clauses for each 26558 -- input item of Clause. It is assumed that Clause has exactly one 26559 -- output. The transformation is as follows: 26560 -- 26561 -- Output => (Input_1, Input_2) -- original 26562 -- 26563 -- Output => Input_1 -- normalizations 26564 -- Output => Input_2 26565 26566 procedure Normalize_Outputs (Clause : Node_Id); 26567 -- Normalize clause Clause by creating multiple clause for each 26568 -- output item of Clause. The transformation is as follows: 26569 -- 26570 -- (Output_1, Output_2) => Input -- original 26571 -- 26572 -- Output_1 => Input -- normalization 26573 -- Output_2 => Input 26574 26575 ---------------------- 26576 -- Normalize_Inputs -- 26577 ---------------------- 26578 26579 procedure Normalize_Inputs (Clause : Node_Id) is 26580 Inputs : constant Node_Id := Expression (Clause); 26581 Loc : constant Source_Ptr := Sloc (Clause); 26582 Output : constant List_Id := Choices (Clause); 26583 Last_Input : Node_Id; 26584 Input : Node_Id; 26585 New_Clause : Node_Id; 26586 Next_Input : Node_Id; 26587 26588 begin 26589 -- Normalization is performed only when the original clause has 26590 -- more than one input. Multiple inputs appear as an aggregate. 26591 26592 if Nkind (Inputs) = N_Aggregate then 26593 Last_Input := Last (Expressions (Inputs)); 26594 26595 -- Create a new clause for each input 26596 26597 Input := First (Expressions (Inputs)); 26598 while Present (Input) loop 26599 Next_Input := Next (Input); 26600 26601 -- Unhook the current input from the original input list 26602 -- because it will be relocated to a new clause. 26603 26604 Remove (Input); 26605 26606 -- Special processing for the last input. At this point the 26607 -- original aggregate has been stripped down to one element. 26608 -- Replace the aggregate by the element itself. 26609 26610 if Input = Last_Input then 26611 Rewrite (Inputs, Input); 26612 26613 -- Generate a clause of the form: 26614 -- Output => Input 26615 26616 else 26617 New_Clause := 26618 Make_Component_Association (Loc, 26619 Choices => New_Copy_List_Tree (Output), 26620 Expression => Input); 26621 26622 -- The new clause contains replicated content that has 26623 -- already been analyzed, mark the clause as analyzed. 26624 26625 Set_Analyzed (New_Clause); 26626 Insert_After (Clause, New_Clause); 26627 end if; 26628 26629 Input := Next_Input; 26630 end loop; 26631 end if; 26632 end Normalize_Inputs; 26633 26634 ----------------------- 26635 -- Normalize_Outputs -- 26636 ----------------------- 26637 26638 procedure Normalize_Outputs (Clause : Node_Id) is 26639 Inputs : constant Node_Id := Expression (Clause); 26640 Loc : constant Source_Ptr := Sloc (Clause); 26641 Outputs : constant Node_Id := First (Choices (Clause)); 26642 Last_Output : Node_Id; 26643 New_Clause : Node_Id; 26644 Next_Output : Node_Id; 26645 Output : Node_Id; 26646 26647 begin 26648 -- Multiple outputs appear as an aggregate. Nothing to do when 26649 -- the clause has exactly one output. 26650 26651 if Nkind (Outputs) = N_Aggregate then 26652 Last_Output := Last (Expressions (Outputs)); 26653 26654 -- Create a clause for each output. Note that each time a new 26655 -- clause is created, the original output list slowly shrinks 26656 -- until there is one item left. 26657 26658 Output := First (Expressions (Outputs)); 26659 while Present (Output) loop 26660 Next_Output := Next (Output); 26661 26662 -- Unhook the output from the original output list as it 26663 -- will be relocated to a new clause. 26664 26665 Remove (Output); 26666 26667 -- Special processing for the last output. At this point 26668 -- the original aggregate has been stripped down to one 26669 -- element. Replace the aggregate by the element itself. 26670 26671 if Output = Last_Output then 26672 Rewrite (Outputs, Output); 26673 26674 else 26675 -- Generate a clause of the form: 26676 -- (Output => Inputs) 26677 26678 New_Clause := 26679 Make_Component_Association (Loc, 26680 Choices => New_List (Output), 26681 Expression => New_Copy_Tree (Inputs)); 26682 26683 -- The new clause contains replicated content that has 26684 -- already been analyzed. There is not need to reanalyze 26685 -- them. 26686 26687 Set_Analyzed (New_Clause); 26688 Insert_After (Clause, New_Clause); 26689 end if; 26690 26691 Output := Next_Output; 26692 end loop; 26693 end if; 26694 end Normalize_Outputs; 26695 26696 -- Local variables 26697 26698 Clause : Node_Id; 26699 26700 -- Start of processing for Normalize_Clauses 26701 26702 begin 26703 Clause := First (Clauses); 26704 while Present (Clause) loop 26705 Normalize_Outputs (Clause); 26706 Next (Clause); 26707 end loop; 26708 26709 Clause := First (Clauses); 26710 while Present (Clause) loop 26711 Normalize_Inputs (Clause); 26712 Next (Clause); 26713 end loop; 26714 end Normalize_Clauses; 26715 26716 -------------------------- 26717 -- Remove_Extra_Clauses -- 26718 -------------------------- 26719 26720 procedure Remove_Extra_Clauses 26721 (Clauses : List_Id; 26722 Matched_Items : Elist_Id) 26723 is 26724 Clause : Node_Id; 26725 Input : Node_Id; 26726 Input_Id : Entity_Id; 26727 Next_Clause : Node_Id; 26728 Output : Node_Id; 26729 State_Id : Entity_Id; 26730 26731 begin 26732 Clause := First (Clauses); 26733 while Present (Clause) loop 26734 Next_Clause := Next (Clause); 26735 26736 Input := Expression (Clause); 26737 Output := First (Choices (Clause)); 26738 26739 -- Recognize a clause of the form 26740 26741 -- null => Input 26742 26743 -- where Input is a constituent of a state which was already 26744 -- successfully matched. This clause must be removed because it 26745 -- simply indicates that some of the constituents of the state 26746 -- are not used. 26747 26748 -- Refined_State => (State => (Constit_1, Constit_2)) 26749 -- Depends => (Output => State) 26750 -- Refined_Depends => ((Output => Constit_1), -- State matched 26751 -- (null => Constit_2)) -- OK 26752 26753 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then 26754 26755 -- Handle abstract views generated for limited with clauses 26756 26757 Input_Id := Available_View (Entity_Of (Input)); 26758 26759 -- The input must be a constituent of a state 26760 26761 if Ekind_In (Input_Id, E_Abstract_State, 26762 E_Constant, 26763 E_Variable) 26764 and then Present (Encapsulating_State (Input_Id)) 26765 then 26766 State_Id := Encapsulating_State (Input_Id); 26767 26768 -- The state must have a non-null visible refinement and be 26769 -- matched in a previous clause. 26770 26771 if Has_Non_Null_Visible_Refinement (State_Id) 26772 and then Contains (Matched_Items, State_Id) 26773 then 26774 Remove (Clause); 26775 end if; 26776 end if; 26777 26778 -- Recognize a clause of the form 26779 26780 -- Output => null 26781 26782 -- where Output is an arbitrary item. This clause must be removed 26783 -- because a null input legitimately matches anything. 26784 26785 elsif Nkind (Input) = N_Null then 26786 Remove (Clause); 26787 end if; 26788 26789 Clause := Next_Clause; 26790 end loop; 26791 end Remove_Extra_Clauses; 26792 26793 -------------------------- 26794 -- Report_Extra_Clauses -- 26795 -------------------------- 26796 26797 procedure Report_Extra_Clauses 26798 (Spec_Id : Entity_Id; 26799 Clauses : List_Id) 26800 is 26801 Clause : Node_Id; 26802 26803 begin 26804 -- Do not perform this check in an instance because it was already 26805 -- performed successfully in the generic template. 26806 26807 if Is_Generic_Instance (Spec_Id) then 26808 null; 26809 26810 elsif Present (Clauses) then 26811 Clause := First (Clauses); 26812 while Present (Clause) loop 26813 SPARK_Msg_N 26814 ("unmatched or extra clause in dependence refinement", 26815 Clause); 26816 26817 Next (Clause); 26818 end loop; 26819 end if; 26820 end Report_Extra_Clauses; 26821 26822 -- Local variables 26823 26824 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 26825 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 26826 Errors : constant Nat := Serious_Errors_Detected; 26827 26828 Clause : Node_Id; 26829 Deps : Node_Id; 26830 Dummy : Boolean; 26831 Refs : Node_Id; 26832 26833 Body_Inputs : Elist_Id := No_Elist; 26834 Body_Outputs : Elist_Id := No_Elist; 26835 -- The inputs and outputs of the subprogram body synthesized from pragma 26836 -- Refined_Depends. 26837 26838 Dependencies : List_Id := No_List; 26839 Depends : Node_Id; 26840 -- The corresponding Depends pragma along with its clauses 26841 26842 Matched_Items : Elist_Id := No_Elist; 26843 -- A list containing the entities of all successfully matched items 26844 -- found in pragma Depends. 26845 26846 Refinements : List_Id := No_List; 26847 -- The clauses of pragma Refined_Depends 26848 26849 Spec_Id : Entity_Id; 26850 -- The entity of the subprogram subject to pragma Refined_Depends 26851 26852 Spec_Inputs : Elist_Id := No_Elist; 26853 Spec_Outputs : Elist_Id := No_Elist; 26854 -- The inputs and outputs of the subprogram spec synthesized from pragma 26855 -- Depends. 26856 26857 States : Elist_Id := No_Elist; 26858 -- A list containing the entities of all states whose constituents 26859 -- appear in pragma Depends. 26860 26861 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part 26862 26863 begin 26864 -- Do not analyze the pragma multiple times 26865 26866 if Is_Analyzed_Pragma (N) then 26867 return; 26868 end if; 26869 26870 Spec_Id := Unique_Defining_Entity (Body_Decl); 26871 26872 -- Use the anonymous object as the proper spec when Refined_Depends 26873 -- applies to the body of a single task type. The object carries the 26874 -- proper Chars as well as all non-refined versions of pragmas. 26875 26876 if Is_Single_Concurrent_Type (Spec_Id) then 26877 Spec_Id := Anonymous_Object (Spec_Id); 26878 end if; 26879 26880 Depends := Get_Pragma (Spec_Id, Pragma_Depends); 26881 26882 -- Subprogram declarations lacks pragma Depends. Refined_Depends is 26883 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)). 26884 26885 if No (Depends) then 26886 SPARK_Msg_NE 26887 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " 26888 & "& lacks aspect or pragma Depends"), N, Spec_Id); 26889 goto Leave; 26890 end if; 26891 26892 Deps := Expression (Get_Argument (Depends, Spec_Id)); 26893 26894 -- A null dependency relation renders the refinement useless because it 26895 -- cannot possibly mention abstract states with visible refinement. Note 26896 -- that the inverse is not true as states may be refined to null 26897 -- (SPARK RM 7.2.5(2)). 26898 26899 if Nkind (Deps) = N_Null then 26900 SPARK_Msg_NE 26901 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " 26902 & "depend on abstract state with visible refinement"), N, Spec_Id); 26903 goto Leave; 26904 end if; 26905 26906 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends. 26907 -- This ensures that the categorization of all refined dependency items 26908 -- is consistent with their role. 26909 26910 Analyze_Depends_In_Decl_Part (N); 26911 26912 -- Do not match dependencies against refinements if Refined_Depends is 26913 -- illegal to avoid emitting misleading error. 26914 26915 if Serious_Errors_Detected = Errors then 26916 26917 -- The related subprogram lacks pragma [Refined_]Global. Synthesize 26918 -- the inputs and outputs of the subprogram spec and body to verify 26919 -- the use of states with visible refinement and their constituents. 26920 26921 if No (Get_Pragma (Spec_Id, Pragma_Global)) 26922 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global)) 26923 then 26924 Collect_Subprogram_Inputs_Outputs 26925 (Subp_Id => Spec_Id, 26926 Synthesize => True, 26927 Subp_Inputs => Spec_Inputs, 26928 Subp_Outputs => Spec_Outputs, 26929 Global_Seen => Dummy); 26930 26931 Collect_Subprogram_Inputs_Outputs 26932 (Subp_Id => Body_Id, 26933 Synthesize => True, 26934 Subp_Inputs => Body_Inputs, 26935 Subp_Outputs => Body_Outputs, 26936 Global_Seen => Dummy); 26937 26938 -- For an output state with a visible refinement, ensure that all 26939 -- constituents appear as outputs in the dependency refinement. 26940 26941 Check_Output_States 26942 (Spec_Id => Spec_Id, 26943 Spec_Inputs => Spec_Inputs, 26944 Spec_Outputs => Spec_Outputs, 26945 Body_Inputs => Body_Inputs, 26946 Body_Outputs => Body_Outputs); 26947 end if; 26948 26949 -- Matching is disabled in ASIS because clauses are not normalized as 26950 -- this is a tree altering activity similar to expansion. 26951 26952 if ASIS_Mode then 26953 goto Leave; 26954 end if; 26955 26956 -- Multiple dependency clauses appear as component associations of an 26957 -- aggregate. Note that the clauses are copied because the algorithm 26958 -- modifies them and this should not be visible in Depends. 26959 26960 pragma Assert (Nkind (Deps) = N_Aggregate); 26961 Dependencies := New_Copy_List_Tree (Component_Associations (Deps)); 26962 Normalize_Clauses (Dependencies); 26963 26964 -- Gather all states which appear in Depends 26965 26966 States := Collect_States (Dependencies); 26967 26968 Refs := Expression (Get_Argument (N, Spec_Id)); 26969 26970 if Nkind (Refs) = N_Null then 26971 Refinements := No_List; 26972 26973 -- Multiple dependency clauses appear as component associations of an 26974 -- aggregate. Note that the clauses are copied because the algorithm 26975 -- modifies them and this should not be visible in Refined_Depends. 26976 26977 else pragma Assert (Nkind (Refs) = N_Aggregate); 26978 Refinements := New_Copy_List_Tree (Component_Associations (Refs)); 26979 Normalize_Clauses (Refinements); 26980 end if; 26981 26982 -- At this point the clauses of pragmas Depends and Refined_Depends 26983 -- have been normalized into simple dependencies between one output 26984 -- and one input. Examine all clauses of pragma Depends looking for 26985 -- matching clauses in pragma Refined_Depends. 26986 26987 Clause := First (Dependencies); 26988 while Present (Clause) loop 26989 Check_Dependency_Clause 26990 (Spec_Id => Spec_Id, 26991 Dep_Clause => Clause, 26992 Dep_States => States, 26993 Refinements => Refinements, 26994 Matched_Items => Matched_Items); 26995 26996 Next (Clause); 26997 end loop; 26998 26999 -- Pragma Refined_Depends may contain multiple clarification clauses 27000 -- which indicate that certain constituents do not influence the data 27001 -- flow in any way. Such clauses must be removed as long as the state 27002 -- has been matched, otherwise they will be incorrectly flagged as 27003 -- unmatched. 27004 27005 -- Refined_State => (State => (Constit_1, Constit_2)) 27006 -- Depends => (Output => State) 27007 -- Refined_Depends => ((Output => Constit_1), -- State matched 27008 -- (null => Constit_2)) -- must be removed 27009 27010 Remove_Extra_Clauses (Refinements, Matched_Items); 27011 27012 if Serious_Errors_Detected = Errors then 27013 Report_Extra_Clauses (Spec_Id, Refinements); 27014 end if; 27015 end if; 27016 27017 <<Leave>> 27018 Set_Is_Analyzed_Pragma (N); 27019 end Analyze_Refined_Depends_In_Decl_Part; 27020 27021 ----------------------------------------- 27022 -- Analyze_Refined_Global_In_Decl_Part -- 27023 ----------------------------------------- 27024 27025 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is 27026 Global : Node_Id; 27027 -- The corresponding Global pragma 27028 27029 Has_In_State : Boolean := False; 27030 Has_In_Out_State : Boolean := False; 27031 Has_Out_State : Boolean := False; 27032 Has_Proof_In_State : Boolean := False; 27033 -- These flags are set when the corresponding Global pragma has a state 27034 -- of mode Input, In_Out, Output or Proof_In respectively with a visible 27035 -- refinement. 27036 27037 Has_Null_State : Boolean := False; 27038 -- This flag is set when the corresponding Global pragma has at least 27039 -- one state with a null refinement. 27040 27041 In_Constits : Elist_Id := No_Elist; 27042 In_Out_Constits : Elist_Id := No_Elist; 27043 Out_Constits : Elist_Id := No_Elist; 27044 Proof_In_Constits : Elist_Id := No_Elist; 27045 -- These lists contain the entities of all Input, In_Out, Output and 27046 -- Proof_In constituents that appear in Refined_Global and participate 27047 -- in state refinement. 27048 27049 In_Items : Elist_Id := No_Elist; 27050 In_Out_Items : Elist_Id := No_Elist; 27051 Out_Items : Elist_Id := No_Elist; 27052 Proof_In_Items : Elist_Id := No_Elist; 27053 -- These lists contain the entities of all Input, In_Out, Output and 27054 -- Proof_In items defined in the corresponding Global pragma. 27055 27056 Repeat_Items : Elist_Id := No_Elist; 27057 -- A list of all global items without full visible refinement found 27058 -- in pragma Global. These states should be repeated in the global 27059 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible 27060 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)). 27061 27062 Spec_Id : Entity_Id; 27063 -- The entity of the subprogram subject to pragma Refined_Global 27064 27065 States : Elist_Id := No_Elist; 27066 -- A list of all states with full or partial visible refinement found in 27067 -- pragma Global. 27068 27069 procedure Check_In_Out_States; 27070 -- Determine whether the corresponding Global pragma mentions In_Out 27071 -- states with visible refinement and if so, ensure that one of the 27072 -- following completions apply to the constituents of the state: 27073 -- 1) there is at least one constituent of mode In_Out 27074 -- 2) there is at least one Input and one Output constituent 27075 -- 3) not all constituents are present and one of them is of mode 27076 -- Output. 27077 -- This routine may remove elements from In_Constits, In_Out_Constits, 27078 -- Out_Constits and Proof_In_Constits. 27079 27080 procedure Check_Input_States; 27081 -- Determine whether the corresponding Global pragma mentions Input 27082 -- states with visible refinement and if so, ensure that at least one of 27083 -- its constituents appears as an Input item in Refined_Global. 27084 -- This routine may remove elements from In_Constits, In_Out_Constits, 27085 -- Out_Constits and Proof_In_Constits. 27086 27087 procedure Check_Output_States; 27088 -- Determine whether the corresponding Global pragma mentions Output 27089 -- states with visible refinement and if so, ensure that all of its 27090 -- constituents appear as Output items in Refined_Global. 27091 -- This routine may remove elements from In_Constits, In_Out_Constits, 27092 -- Out_Constits and Proof_In_Constits. 27093 27094 procedure Check_Proof_In_States; 27095 -- Determine whether the corresponding Global pragma mentions Proof_In 27096 -- states with visible refinement and if so, ensure that at least one of 27097 -- its constituents appears as a Proof_In item in Refined_Global. 27098 -- This routine may remove elements from In_Constits, In_Out_Constits, 27099 -- Out_Constits and Proof_In_Constits. 27100 27101 procedure Check_Refined_Global_List 27102 (List : Node_Id; 27103 Global_Mode : Name_Id := Name_Input); 27104 -- Verify the legality of a single global list declaration. Global_Mode 27105 -- denotes the current mode in effect. 27106 27107 procedure Collect_Global_Items 27108 (List : Node_Id; 27109 Mode : Name_Id := Name_Input); 27110 -- Gather all Input, In_Out, Output and Proof_In items from node List 27111 -- and separate them in lists In_Items, In_Out_Items, Out_Items and 27112 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State 27113 -- and Has_Proof_In_State are set when there is at least one abstract 27114 -- state with full or partial visible refinement available in the 27115 -- corresponding mode. Flag Has_Null_State is set when at least state 27116 -- has a null refinement. Mode denotes the current global mode in 27117 -- effect. 27118 27119 function Present_Then_Remove 27120 (List : Elist_Id; 27121 Item : Entity_Id) return Boolean; 27122 -- Search List for a particular entity Item. If Item has been found, 27123 -- remove it from List. This routine is used to strip lists In_Constits, 27124 -- In_Out_Constits and Out_Constits of valid constituents. 27125 27126 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id); 27127 -- Same as function Present_Then_Remove, but do not report the presence 27128 -- of Item in List. 27129 27130 procedure Report_Extra_Constituents; 27131 -- Emit an error for each constituent found in lists In_Constits, 27132 -- In_Out_Constits and Out_Constits. 27133 27134 procedure Report_Missing_Items; 27135 -- Emit an error for each global item not repeated found in list 27136 -- Repeat_Items. 27137 27138 ------------------------- 27139 -- Check_In_Out_States -- 27140 ------------------------- 27141 27142 procedure Check_In_Out_States is 27143 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27144 -- Determine whether one of the following coverage scenarios is in 27145 -- effect: 27146 -- 1) there is at least one constituent of mode In_Out or Output 27147 -- 2) there is at least one pair of constituents with modes Input 27148 -- and Output, or Proof_In and Output. 27149 -- 3) there is at least one constituent of mode Output and not all 27150 -- constituents are present. 27151 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)). 27152 27153 ----------------------------- 27154 -- Check_Constituent_Usage -- 27155 ----------------------------- 27156 27157 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27158 Constits : constant Elist_Id := 27159 Partial_Refinement_Constituents (State_Id); 27160 Constit_Elmt : Elmt_Id; 27161 Constit_Id : Entity_Id; 27162 Has_Missing : Boolean := False; 27163 In_Out_Seen : Boolean := False; 27164 Input_Seen : Boolean := False; 27165 Output_Seen : Boolean := False; 27166 Proof_In_Seen : Boolean := False; 27167 27168 begin 27169 -- Process all the constituents of the state and note their modes 27170 -- within the global refinement. 27171 27172 if Present (Constits) then 27173 Constit_Elmt := First_Elmt (Constits); 27174 while Present (Constit_Elmt) loop 27175 Constit_Id := Node (Constit_Elmt); 27176 27177 if Present_Then_Remove (In_Constits, Constit_Id) then 27178 Input_Seen := True; 27179 27180 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then 27181 In_Out_Seen := True; 27182 27183 elsif Present_Then_Remove (Out_Constits, Constit_Id) then 27184 Output_Seen := True; 27185 27186 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) 27187 then 27188 Proof_In_Seen := True; 27189 27190 else 27191 Has_Missing := True; 27192 end if; 27193 27194 Next_Elmt (Constit_Elmt); 27195 end loop; 27196 end if; 27197 27198 -- An In_Out constituent is a valid completion 27199 27200 if In_Out_Seen then 27201 null; 27202 27203 -- A pair of one Input/Proof_In and one Output constituent is a 27204 -- valid completion. 27205 27206 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then 27207 null; 27208 27209 elsif Output_Seen then 27210 27211 -- A single Output constituent is a valid completion only when 27212 -- some of the other constituents are missing. 27213 27214 if Has_Missing then 27215 null; 27216 27217 -- Otherwise all constituents are of mode Output 27218 27219 else 27220 SPARK_Msg_NE 27221 ("global refinement of state & must include at least one " 27222 & "constituent of mode `In_Out`, `Input`, or `Proof_In`", 27223 N, State_Id); 27224 end if; 27225 27226 -- The state lacks a completion. When full refinement is visible, 27227 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial 27228 -- refinement is visible, emit an error if the abstract state 27229 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where 27230 -- both are utilized, Check_State_And_Constituent_Use. will issue 27231 -- the error. 27232 27233 elsif not Input_Seen 27234 and then not In_Out_Seen 27235 and then not Output_Seen 27236 and then not Proof_In_Seen 27237 then 27238 if Has_Visible_Refinement (State_Id) 27239 or else Contains (Repeat_Items, State_Id) 27240 then 27241 SPARK_Msg_NE 27242 ("missing global refinement of state &", N, State_Id); 27243 end if; 27244 27245 -- Otherwise the state has a malformed completion where at least 27246 -- one of the constituents has a different mode. 27247 27248 else 27249 SPARK_Msg_NE 27250 ("global refinement of state & redefines the mode of its " 27251 & "constituents", N, State_Id); 27252 end if; 27253 end Check_Constituent_Usage; 27254 27255 -- Local variables 27256 27257 Item_Elmt : Elmt_Id; 27258 Item_Id : Entity_Id; 27259 27260 -- Start of processing for Check_In_Out_States 27261 27262 begin 27263 -- Do not perform this check in an instance because it was already 27264 -- performed successfully in the generic template. 27265 27266 if Is_Generic_Instance (Spec_Id) then 27267 null; 27268 27269 -- Inspect the In_Out items of the corresponding Global pragma 27270 -- looking for a state with a visible refinement. 27271 27272 elsif Has_In_Out_State and then Present (In_Out_Items) then 27273 Item_Elmt := First_Elmt (In_Out_Items); 27274 while Present (Item_Elmt) loop 27275 Item_Id := Node (Item_Elmt); 27276 27277 -- Ensure that one of the three coverage variants is satisfied 27278 27279 if Ekind (Item_Id) = E_Abstract_State 27280 and then Has_Non_Null_Visible_Refinement (Item_Id) 27281 then 27282 Check_Constituent_Usage (Item_Id); 27283 end if; 27284 27285 Next_Elmt (Item_Elmt); 27286 end loop; 27287 end if; 27288 end Check_In_Out_States; 27289 27290 ------------------------ 27291 -- Check_Input_States -- 27292 ------------------------ 27293 27294 procedure Check_Input_States is 27295 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27296 -- Determine whether at least one constituent of state State_Id with 27297 -- full or partial visible refinement is used and has mode Input. 27298 -- Ensure that the remaining constituents do not have In_Out or 27299 -- Output modes. Emit an error if this is not the case 27300 -- (SPARK RM 7.2.4(5)). 27301 27302 ----------------------------- 27303 -- Check_Constituent_Usage -- 27304 ----------------------------- 27305 27306 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27307 Constits : constant Elist_Id := 27308 Partial_Refinement_Constituents (State_Id); 27309 Constit_Elmt : Elmt_Id; 27310 Constit_Id : Entity_Id; 27311 In_Seen : Boolean := False; 27312 27313 begin 27314 if Present (Constits) then 27315 Constit_Elmt := First_Elmt (Constits); 27316 while Present (Constit_Elmt) loop 27317 Constit_Id := Node (Constit_Elmt); 27318 27319 -- At least one of the constituents appears as an Input 27320 27321 if Present_Then_Remove (In_Constits, Constit_Id) then 27322 In_Seen := True; 27323 27324 -- A Proof_In constituent can refine an Input state as long 27325 -- as there is at least one Input constituent present. 27326 27327 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) 27328 then 27329 null; 27330 27331 -- The constituent appears in the global refinement, but has 27332 -- mode In_Out or Output (SPARK RM 7.2.4(5)). 27333 27334 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) 27335 or else Present_Then_Remove (Out_Constits, Constit_Id) 27336 then 27337 Error_Msg_Name_1 := Chars (State_Id); 27338 SPARK_Msg_NE 27339 ("constituent & of state % must have mode `Input` in " 27340 & "global refinement", N, Constit_Id); 27341 end if; 27342 27343 Next_Elmt (Constit_Elmt); 27344 end loop; 27345 end if; 27346 27347 -- Not one of the constituents appeared as Input. Always emit an 27348 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)). 27349 -- When only partial refinement is visible, emit an error if the 27350 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In 27351 -- the case where both are utilized, an error will be issued in 27352 -- Check_State_And_Constituent_Use. 27353 27354 if not In_Seen 27355 and then (Has_Visible_Refinement (State_Id) 27356 or else Contains (Repeat_Items, State_Id)) 27357 then 27358 SPARK_Msg_NE 27359 ("global refinement of state & must include at least one " 27360 & "constituent of mode `Input`", N, State_Id); 27361 end if; 27362 end Check_Constituent_Usage; 27363 27364 -- Local variables 27365 27366 Item_Elmt : Elmt_Id; 27367 Item_Id : Entity_Id; 27368 27369 -- Start of processing for Check_Input_States 27370 27371 begin 27372 -- Do not perform this check in an instance because it was already 27373 -- performed successfully in the generic template. 27374 27375 if Is_Generic_Instance (Spec_Id) then 27376 null; 27377 27378 -- Inspect the Input items of the corresponding Global pragma looking 27379 -- for a state with a visible refinement. 27380 27381 elsif Has_In_State and then Present (In_Items) then 27382 Item_Elmt := First_Elmt (In_Items); 27383 while Present (Item_Elmt) loop 27384 Item_Id := Node (Item_Elmt); 27385 27386 -- When full refinement is visible, ensure that at least one of 27387 -- the constituents is utilized and is of mode Input. When only 27388 -- partial refinement is visible, ensure that either one of 27389 -- the constituents is utilized and is of mode Input, or the 27390 -- abstract state is repeated and no constituent is utilized. 27391 27392 if Ekind (Item_Id) = E_Abstract_State 27393 and then Has_Non_Null_Visible_Refinement (Item_Id) 27394 then 27395 Check_Constituent_Usage (Item_Id); 27396 end if; 27397 27398 Next_Elmt (Item_Elmt); 27399 end loop; 27400 end if; 27401 end Check_Input_States; 27402 27403 ------------------------- 27404 -- Check_Output_States -- 27405 ------------------------- 27406 27407 procedure Check_Output_States is 27408 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27409 -- Determine whether all constituents of state State_Id with full 27410 -- visible refinement are used and have mode Output. Emit an error 27411 -- if this is not the case (SPARK RM 7.2.4(5)). 27412 27413 ----------------------------- 27414 -- Check_Constituent_Usage -- 27415 ----------------------------- 27416 27417 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27418 Constits : constant Elist_Id := 27419 Partial_Refinement_Constituents (State_Id); 27420 Only_Partial : constant Boolean := 27421 not Has_Visible_Refinement (State_Id); 27422 Constit_Elmt : Elmt_Id; 27423 Constit_Id : Entity_Id; 27424 Posted : Boolean := False; 27425 27426 begin 27427 if Present (Constits) then 27428 Constit_Elmt := First_Elmt (Constits); 27429 while Present (Constit_Elmt) loop 27430 Constit_Id := Node (Constit_Elmt); 27431 27432 -- Issue an error when a constituent of State_Id is utilized 27433 -- and State_Id has only partial visible refinement 27434 -- (SPARK RM 7.2.4(3d)). 27435 27436 if Only_Partial then 27437 if Present_Then_Remove (Out_Constits, Constit_Id) 27438 or else Present_Then_Remove (In_Constits, Constit_Id) 27439 or else 27440 Present_Then_Remove (In_Out_Constits, Constit_Id) 27441 or else 27442 Present_Then_Remove (Proof_In_Constits, Constit_Id) 27443 then 27444 Error_Msg_Name_1 := Chars (State_Id); 27445 SPARK_Msg_NE 27446 ("constituent & of state % cannot be used in global " 27447 & "refinement", N, Constit_Id); 27448 Error_Msg_Name_1 := Chars (State_Id); 27449 SPARK_Msg_N ("\use state % instead", N); 27450 end if; 27451 27452 elsif Present_Then_Remove (Out_Constits, Constit_Id) then 27453 null; 27454 27455 -- The constituent appears in the global refinement, but has 27456 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)). 27457 27458 elsif Present_Then_Remove (In_Constits, Constit_Id) 27459 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 27460 or else Present_Then_Remove (Proof_In_Constits, Constit_Id) 27461 then 27462 Error_Msg_Name_1 := Chars (State_Id); 27463 SPARK_Msg_NE 27464 ("constituent & of state % must have mode `Output` in " 27465 & "global refinement", N, Constit_Id); 27466 27467 -- The constituent is altogether missing (SPARK RM 7.2.5(3)) 27468 27469 else 27470 if not Posted then 27471 Posted := True; 27472 SPARK_Msg_NE 27473 ("`Output` state & must be replaced by all its " 27474 & "constituents in global refinement", N, State_Id); 27475 end if; 27476 27477 SPARK_Msg_NE 27478 ("\constituent & is missing in output list", 27479 N, Constit_Id); 27480 end if; 27481 27482 Next_Elmt (Constit_Elmt); 27483 end loop; 27484 end if; 27485 end Check_Constituent_Usage; 27486 27487 -- Local variables 27488 27489 Item_Elmt : Elmt_Id; 27490 Item_Id : Entity_Id; 27491 27492 -- Start of processing for Check_Output_States 27493 27494 begin 27495 -- Do not perform this check in an instance because it was already 27496 -- performed successfully in the generic template. 27497 27498 if Is_Generic_Instance (Spec_Id) then 27499 null; 27500 27501 -- Inspect the Output items of the corresponding Global pragma 27502 -- looking for a state with a visible refinement. 27503 27504 elsif Has_Out_State and then Present (Out_Items) then 27505 Item_Elmt := First_Elmt (Out_Items); 27506 while Present (Item_Elmt) loop 27507 Item_Id := Node (Item_Elmt); 27508 27509 -- When full refinement is visible, ensure that all of the 27510 -- constituents are utilized and they have mode Output. When 27511 -- only partial refinement is visible, ensure that no 27512 -- constituent is utilized. 27513 27514 if Ekind (Item_Id) = E_Abstract_State 27515 and then Has_Non_Null_Visible_Refinement (Item_Id) 27516 then 27517 Check_Constituent_Usage (Item_Id); 27518 end if; 27519 27520 Next_Elmt (Item_Elmt); 27521 end loop; 27522 end if; 27523 end Check_Output_States; 27524 27525 --------------------------- 27526 -- Check_Proof_In_States -- 27527 --------------------------- 27528 27529 procedure Check_Proof_In_States is 27530 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27531 -- Determine whether at least one constituent of state State_Id with 27532 -- full or partial visible refinement is used and has mode Proof_In. 27533 -- Ensure that the remaining constituents do not have Input, In_Out, 27534 -- or Output modes. Emit an error if this is not the case 27535 -- (SPARK RM 7.2.4(5)). 27536 27537 ----------------------------- 27538 -- Check_Constituent_Usage -- 27539 ----------------------------- 27540 27541 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27542 Constits : constant Elist_Id := 27543 Partial_Refinement_Constituents (State_Id); 27544 Constit_Elmt : Elmt_Id; 27545 Constit_Id : Entity_Id; 27546 Proof_In_Seen : Boolean := False; 27547 27548 begin 27549 if Present (Constits) then 27550 Constit_Elmt := First_Elmt (Constits); 27551 while Present (Constit_Elmt) loop 27552 Constit_Id := Node (Constit_Elmt); 27553 27554 -- At least one of the constituents appears as Proof_In 27555 27556 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then 27557 Proof_In_Seen := True; 27558 27559 -- The constituent appears in the global refinement, but has 27560 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)). 27561 27562 elsif Present_Then_Remove (In_Constits, Constit_Id) 27563 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 27564 or else Present_Then_Remove (Out_Constits, Constit_Id) 27565 then 27566 Error_Msg_Name_1 := Chars (State_Id); 27567 SPARK_Msg_NE 27568 ("constituent & of state % must have mode `Proof_In` " 27569 & "in global refinement", N, Constit_Id); 27570 end if; 27571 27572 Next_Elmt (Constit_Elmt); 27573 end loop; 27574 end if; 27575 27576 -- Not one of the constituents appeared as Proof_In. Always emit 27577 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)). 27578 -- When only partial refinement is visible, emit an error if the 27579 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In 27580 -- the case where both are utilized, an error will be issued by 27581 -- Check_State_And_Constituent_Use. 27582 27583 if not Proof_In_Seen 27584 and then (Has_Visible_Refinement (State_Id) 27585 or else Contains (Repeat_Items, State_Id)) 27586 then 27587 SPARK_Msg_NE 27588 ("global refinement of state & must include at least one " 27589 & "constituent of mode `Proof_In`", N, State_Id); 27590 end if; 27591 end Check_Constituent_Usage; 27592 27593 -- Local variables 27594 27595 Item_Elmt : Elmt_Id; 27596 Item_Id : Entity_Id; 27597 27598 -- Start of processing for Check_Proof_In_States 27599 27600 begin 27601 -- Do not perform this check in an instance because it was already 27602 -- performed successfully in the generic template. 27603 27604 if Is_Generic_Instance (Spec_Id) then 27605 null; 27606 27607 -- Inspect the Proof_In items of the corresponding Global pragma 27608 -- looking for a state with a visible refinement. 27609 27610 elsif Has_Proof_In_State and then Present (Proof_In_Items) then 27611 Item_Elmt := First_Elmt (Proof_In_Items); 27612 while Present (Item_Elmt) loop 27613 Item_Id := Node (Item_Elmt); 27614 27615 -- Ensure that at least one of the constituents is utilized 27616 -- and is of mode Proof_In. When only partial refinement is 27617 -- visible, ensure that either one of the constituents is 27618 -- utilized and is of mode Proof_In, or the abstract state 27619 -- is repeated and no constituent is utilized. 27620 27621 if Ekind (Item_Id) = E_Abstract_State 27622 and then Has_Non_Null_Visible_Refinement (Item_Id) 27623 then 27624 Check_Constituent_Usage (Item_Id); 27625 end if; 27626 27627 Next_Elmt (Item_Elmt); 27628 end loop; 27629 end if; 27630 end Check_Proof_In_States; 27631 27632 ------------------------------- 27633 -- Check_Refined_Global_List -- 27634 ------------------------------- 27635 27636 procedure Check_Refined_Global_List 27637 (List : Node_Id; 27638 Global_Mode : Name_Id := Name_Input) 27639 is 27640 procedure Check_Refined_Global_Item 27641 (Item : Node_Id; 27642 Global_Mode : Name_Id); 27643 -- Verify the legality of a single global item declaration. Parameter 27644 -- Global_Mode denotes the current mode in effect. 27645 27646 ------------------------------- 27647 -- Check_Refined_Global_Item -- 27648 ------------------------------- 27649 27650 procedure Check_Refined_Global_Item 27651 (Item : Node_Id; 27652 Global_Mode : Name_Id) 27653 is 27654 Item_Id : constant Entity_Id := Entity_Of (Item); 27655 27656 procedure Inconsistent_Mode_Error (Expect : Name_Id); 27657 -- Issue a common error message for all mode mismatches. Expect 27658 -- denotes the expected mode. 27659 27660 ----------------------------- 27661 -- Inconsistent_Mode_Error -- 27662 ----------------------------- 27663 27664 procedure Inconsistent_Mode_Error (Expect : Name_Id) is 27665 begin 27666 SPARK_Msg_NE 27667 ("global item & has inconsistent modes", Item, Item_Id); 27668 27669 Error_Msg_Name_1 := Global_Mode; 27670 Error_Msg_Name_2 := Expect; 27671 SPARK_Msg_N ("\expected mode %, found mode %", Item); 27672 end Inconsistent_Mode_Error; 27673 27674 -- Local variables 27675 27676 Enc_State : Entity_Id := Empty; 27677 -- Encapsulating state for constituent, Empty otherwise 27678 27679 -- Start of processing for Check_Refined_Global_Item 27680 27681 begin 27682 if Ekind_In (Item_Id, E_Abstract_State, 27683 E_Constant, 27684 E_Variable) 27685 then 27686 Enc_State := Find_Encapsulating_State (States, Item_Id); 27687 end if; 27688 27689 -- When the state or object acts as a constituent of another 27690 -- state with a visible refinement, collect it for the state 27691 -- completeness checks performed later on. Note that the item 27692 -- acts as a constituent only when the encapsulating state is 27693 -- present in pragma Global. 27694 27695 if Present (Enc_State) 27696 and then (Has_Visible_Refinement (Enc_State) 27697 or else Has_Partial_Visible_Refinement (Enc_State)) 27698 and then Contains (States, Enc_State) 27699 then 27700 -- If the state has only partial visible refinement, remove it 27701 -- from the list of items that should be repeated from pragma 27702 -- Global. 27703 27704 if not Has_Visible_Refinement (Enc_State) then 27705 Present_Then_Remove (Repeat_Items, Enc_State); 27706 end if; 27707 27708 if Global_Mode = Name_Input then 27709 Append_New_Elmt (Item_Id, In_Constits); 27710 27711 elsif Global_Mode = Name_In_Out then 27712 Append_New_Elmt (Item_Id, In_Out_Constits); 27713 27714 elsif Global_Mode = Name_Output then 27715 Append_New_Elmt (Item_Id, Out_Constits); 27716 27717 elsif Global_Mode = Name_Proof_In then 27718 Append_New_Elmt (Item_Id, Proof_In_Constits); 27719 end if; 27720 27721 -- When not a constituent, ensure that both occurrences of the 27722 -- item in pragmas Global and Refined_Global match. Also remove 27723 -- it when present from the list of items that should be repeated 27724 -- from pragma Global. 27725 27726 else 27727 Present_Then_Remove (Repeat_Items, Item_Id); 27728 27729 if Contains (In_Items, Item_Id) then 27730 if Global_Mode /= Name_Input then 27731 Inconsistent_Mode_Error (Name_Input); 27732 end if; 27733 27734 elsif Contains (In_Out_Items, Item_Id) then 27735 if Global_Mode /= Name_In_Out then 27736 Inconsistent_Mode_Error (Name_In_Out); 27737 end if; 27738 27739 elsif Contains (Out_Items, Item_Id) then 27740 if Global_Mode /= Name_Output then 27741 Inconsistent_Mode_Error (Name_Output); 27742 end if; 27743 27744 elsif Contains (Proof_In_Items, Item_Id) then 27745 null; 27746 27747 -- The item does not appear in the corresponding Global pragma, 27748 -- it must be an extra (SPARK RM 7.2.4(3)). 27749 27750 else 27751 pragma Assert (Present (Global)); 27752 Error_Msg_Sloc := Sloc (Global); 27753 SPARK_Msg_NE 27754 ("extra global item & does not refine or repeat any " 27755 & "global item #", Item, Item_Id); 27756 end if; 27757 end if; 27758 end Check_Refined_Global_Item; 27759 27760 -- Local variables 27761 27762 Item : Node_Id; 27763 27764 -- Start of processing for Check_Refined_Global_List 27765 27766 begin 27767 -- Do not perform this check in an instance because it was already 27768 -- performed successfully in the generic template. 27769 27770 if Is_Generic_Instance (Spec_Id) then 27771 null; 27772 27773 elsif Nkind (List) = N_Null then 27774 null; 27775 27776 -- Single global item declaration 27777 27778 elsif Nkind_In (List, N_Expanded_Name, 27779 N_Identifier, 27780 N_Selected_Component) 27781 then 27782 Check_Refined_Global_Item (List, Global_Mode); 27783 27784 -- Simple global list or moded global list declaration 27785 27786 elsif Nkind (List) = N_Aggregate then 27787 27788 -- The declaration of a simple global list appear as a collection 27789 -- of expressions. 27790 27791 if Present (Expressions (List)) then 27792 Item := First (Expressions (List)); 27793 while Present (Item) loop 27794 Check_Refined_Global_Item (Item, Global_Mode); 27795 Next (Item); 27796 end loop; 27797 27798 -- The declaration of a moded global list appears as a collection 27799 -- of component associations where individual choices denote 27800 -- modes. 27801 27802 elsif Present (Component_Associations (List)) then 27803 Item := First (Component_Associations (List)); 27804 while Present (Item) loop 27805 Check_Refined_Global_List 27806 (List => Expression (Item), 27807 Global_Mode => Chars (First (Choices (Item)))); 27808 27809 Next (Item); 27810 end loop; 27811 27812 -- Invalid tree 27813 27814 else 27815 raise Program_Error; 27816 end if; 27817 27818 -- Invalid list 27819 27820 else 27821 raise Program_Error; 27822 end if; 27823 end Check_Refined_Global_List; 27824 27825 -------------------------- 27826 -- Collect_Global_Items -- 27827 -------------------------- 27828 27829 procedure Collect_Global_Items 27830 (List : Node_Id; 27831 Mode : Name_Id := Name_Input) 27832 is 27833 procedure Collect_Global_Item 27834 (Item : Node_Id; 27835 Item_Mode : Name_Id); 27836 -- Add a single item to the appropriate list. Item_Mode denotes the 27837 -- current mode in effect. 27838 27839 ------------------------- 27840 -- Collect_Global_Item -- 27841 ------------------------- 27842 27843 procedure Collect_Global_Item 27844 (Item : Node_Id; 27845 Item_Mode : Name_Id) 27846 is 27847 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item)); 27848 -- The above handles abstract views of variables and states built 27849 -- for limited with clauses. 27850 27851 begin 27852 -- Signal that the global list contains at least one abstract 27853 -- state with a visible refinement. Note that the refinement may 27854 -- be null in which case there are no constituents. 27855 27856 if Ekind (Item_Id) = E_Abstract_State then 27857 if Has_Null_Visible_Refinement (Item_Id) then 27858 Has_Null_State := True; 27859 27860 elsif Has_Non_Null_Visible_Refinement (Item_Id) then 27861 Append_New_Elmt (Item_Id, States); 27862 27863 if Item_Mode = Name_Input then 27864 Has_In_State := True; 27865 elsif Item_Mode = Name_In_Out then 27866 Has_In_Out_State := True; 27867 elsif Item_Mode = Name_Output then 27868 Has_Out_State := True; 27869 elsif Item_Mode = Name_Proof_In then 27870 Has_Proof_In_State := True; 27871 end if; 27872 end if; 27873 end if; 27874 27875 -- Record global items without full visible refinement found in 27876 -- pragma Global which should be repeated in the global refinement 27877 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)). 27878 27879 if Ekind (Item_Id) /= E_Abstract_State 27880 or else not Has_Visible_Refinement (Item_Id) 27881 then 27882 Append_New_Elmt (Item_Id, Repeat_Items); 27883 end if; 27884 27885 -- Add the item to the proper list 27886 27887 if Item_Mode = Name_Input then 27888 Append_New_Elmt (Item_Id, In_Items); 27889 elsif Item_Mode = Name_In_Out then 27890 Append_New_Elmt (Item_Id, In_Out_Items); 27891 elsif Item_Mode = Name_Output then 27892 Append_New_Elmt (Item_Id, Out_Items); 27893 elsif Item_Mode = Name_Proof_In then 27894 Append_New_Elmt (Item_Id, Proof_In_Items); 27895 end if; 27896 end Collect_Global_Item; 27897 27898 -- Local variables 27899 27900 Item : Node_Id; 27901 27902 -- Start of processing for Collect_Global_Items 27903 27904 begin 27905 if Nkind (List) = N_Null then 27906 null; 27907 27908 -- Single global item declaration 27909 27910 elsif Nkind_In (List, N_Expanded_Name, 27911 N_Identifier, 27912 N_Selected_Component) 27913 then 27914 Collect_Global_Item (List, Mode); 27915 27916 -- Single global list or moded global list declaration 27917 27918 elsif Nkind (List) = N_Aggregate then 27919 27920 -- The declaration of a simple global list appear as a collection 27921 -- of expressions. 27922 27923 if Present (Expressions (List)) then 27924 Item := First (Expressions (List)); 27925 while Present (Item) loop 27926 Collect_Global_Item (Item, Mode); 27927 Next (Item); 27928 end loop; 27929 27930 -- The declaration of a moded global list appears as a collection 27931 -- of component associations where individual choices denote mode. 27932 27933 elsif Present (Component_Associations (List)) then 27934 Item := First (Component_Associations (List)); 27935 while Present (Item) loop 27936 Collect_Global_Items 27937 (List => Expression (Item), 27938 Mode => Chars (First (Choices (Item)))); 27939 27940 Next (Item); 27941 end loop; 27942 27943 -- Invalid tree 27944 27945 else 27946 raise Program_Error; 27947 end if; 27948 27949 -- To accommodate partial decoration of disabled SPARK features, this 27950 -- routine may be called with illegal input. If this is the case, do 27951 -- not raise Program_Error. 27952 27953 else 27954 null; 27955 end if; 27956 end Collect_Global_Items; 27957 27958 ------------------------- 27959 -- Present_Then_Remove -- 27960 ------------------------- 27961 27962 function Present_Then_Remove 27963 (List : Elist_Id; 27964 Item : Entity_Id) return Boolean 27965 is 27966 Elmt : Elmt_Id; 27967 27968 begin 27969 if Present (List) then 27970 Elmt := First_Elmt (List); 27971 while Present (Elmt) loop 27972 if Node (Elmt) = Item then 27973 Remove_Elmt (List, Elmt); 27974 return True; 27975 end if; 27976 27977 Next_Elmt (Elmt); 27978 end loop; 27979 end if; 27980 27981 return False; 27982 end Present_Then_Remove; 27983 27984 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is 27985 Ignore : Boolean; 27986 begin 27987 Ignore := Present_Then_Remove (List, Item); 27988 end Present_Then_Remove; 27989 27990 ------------------------------- 27991 -- Report_Extra_Constituents -- 27992 ------------------------------- 27993 27994 procedure Report_Extra_Constituents is 27995 procedure Report_Extra_Constituents_In_List (List : Elist_Id); 27996 -- Emit an error for every element of List 27997 27998 --------------------------------------- 27999 -- Report_Extra_Constituents_In_List -- 28000 --------------------------------------- 28001 28002 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is 28003 Constit_Elmt : Elmt_Id; 28004 28005 begin 28006 if Present (List) then 28007 Constit_Elmt := First_Elmt (List); 28008 while Present (Constit_Elmt) loop 28009 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt)); 28010 Next_Elmt (Constit_Elmt); 28011 end loop; 28012 end if; 28013 end Report_Extra_Constituents_In_List; 28014 28015 -- Start of processing for Report_Extra_Constituents 28016 28017 begin 28018 -- Do not perform this check in an instance because it was already 28019 -- performed successfully in the generic template. 28020 28021 if Is_Generic_Instance (Spec_Id) then 28022 null; 28023 28024 else 28025 Report_Extra_Constituents_In_List (In_Constits); 28026 Report_Extra_Constituents_In_List (In_Out_Constits); 28027 Report_Extra_Constituents_In_List (Out_Constits); 28028 Report_Extra_Constituents_In_List (Proof_In_Constits); 28029 end if; 28030 end Report_Extra_Constituents; 28031 28032 -------------------------- 28033 -- Report_Missing_Items -- 28034 -------------------------- 28035 28036 procedure Report_Missing_Items is 28037 Item_Elmt : Elmt_Id; 28038 Item_Id : Entity_Id; 28039 28040 begin 28041 -- Do not perform this check in an instance because it was already 28042 -- performed successfully in the generic template. 28043 28044 if Is_Generic_Instance (Spec_Id) then 28045 null; 28046 28047 else 28048 if Present (Repeat_Items) then 28049 Item_Elmt := First_Elmt (Repeat_Items); 28050 while Present (Item_Elmt) loop 28051 Item_Id := Node (Item_Elmt); 28052 SPARK_Msg_NE ("missing global item &", N, Item_Id); 28053 Next_Elmt (Item_Elmt); 28054 end loop; 28055 end if; 28056 end if; 28057 end Report_Missing_Items; 28058 28059 -- Local variables 28060 28061 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 28062 Errors : constant Nat := Serious_Errors_Detected; 28063 Items : Node_Id; 28064 No_Constit : Boolean; 28065 28066 -- Start of processing for Analyze_Refined_Global_In_Decl_Part 28067 28068 begin 28069 -- Do not analyze the pragma multiple times 28070 28071 if Is_Analyzed_Pragma (N) then 28072 return; 28073 end if; 28074 28075 Spec_Id := Unique_Defining_Entity (Body_Decl); 28076 28077 -- Use the anonymous object as the proper spec when Refined_Global 28078 -- applies to the body of a single task type. The object carries the 28079 -- proper Chars as well as all non-refined versions of pragmas. 28080 28081 if Is_Single_Concurrent_Type (Spec_Id) then 28082 Spec_Id := Anonymous_Object (Spec_Id); 28083 end if; 28084 28085 Global := Get_Pragma (Spec_Id, Pragma_Global); 28086 Items := Expression (Get_Argument (N, Spec_Id)); 28087 28088 -- The subprogram declaration lacks pragma Global. This renders 28089 -- Refined_Global useless as there is nothing to refine. 28090 28091 if No (Global) then 28092 SPARK_Msg_NE 28093 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " 28094 & "& lacks aspect or pragma Global"), N, Spec_Id); 28095 goto Leave; 28096 end if; 28097 28098 -- Extract all relevant items from the corresponding Global pragma 28099 28100 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id))); 28101 28102 -- Package and subprogram bodies are instantiated individually in 28103 -- a separate compiler pass. Due to this mode of instantiation, the 28104 -- refinement of a state may no longer be visible when a subprogram 28105 -- body contract is instantiated. Since the generic template is legal, 28106 -- do not perform this check in the instance to circumvent this oddity. 28107 28108 if Is_Generic_Instance (Spec_Id) then 28109 null; 28110 28111 -- Non-instance case 28112 28113 else 28114 -- The corresponding Global pragma must mention at least one 28115 -- state with a visible refinement at the point Refined_Global 28116 -- is processed. States with null refinements need Refined_Global 28117 -- pragma (SPARK RM 7.2.4(2)). 28118 28119 if not Has_In_State 28120 and then not Has_In_Out_State 28121 and then not Has_Out_State 28122 and then not Has_Proof_In_State 28123 and then not Has_Null_State 28124 then 28125 SPARK_Msg_NE 28126 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " 28127 & "depend on abstract state with visible refinement"), 28128 N, Spec_Id); 28129 goto Leave; 28130 28131 -- The global refinement of inputs and outputs cannot be null when 28132 -- the corresponding Global pragma contains at least one item except 28133 -- in the case where we have states with null refinements. 28134 28135 elsif Nkind (Items) = N_Null 28136 and then 28137 (Present (In_Items) 28138 or else Present (In_Out_Items) 28139 or else Present (Out_Items) 28140 or else Present (Proof_In_Items)) 28141 and then not Has_Null_State 28142 then 28143 SPARK_Msg_NE 28144 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has " 28145 & "global items"), N, Spec_Id); 28146 goto Leave; 28147 end if; 28148 end if; 28149 28150 -- Analyze Refined_Global as if it behaved as a regular pragma Global. 28151 -- This ensures that the categorization of all refined global items is 28152 -- consistent with their role. 28153 28154 Analyze_Global_In_Decl_Part (N); 28155 28156 -- Perform all refinement checks with respect to completeness and mode 28157 -- matching. 28158 28159 if Serious_Errors_Detected = Errors then 28160 Check_Refined_Global_List (Items); 28161 end if; 28162 28163 -- Store the information that no constituent is used in the global 28164 -- refinement, prior to calling checking procedures which remove items 28165 -- from the list of constituents. 28166 28167 No_Constit := 28168 No (In_Constits) 28169 and then No (In_Out_Constits) 28170 and then No (Out_Constits) 28171 and then No (Proof_In_Constits); 28172 28173 -- For Input states with visible refinement, at least one constituent 28174 -- must be used as an Input in the global refinement. 28175 28176 if Serious_Errors_Detected = Errors then 28177 Check_Input_States; 28178 end if; 28179 28180 -- Verify all possible completion variants for In_Out states with 28181 -- visible refinement. 28182 28183 if Serious_Errors_Detected = Errors then 28184 Check_In_Out_States; 28185 end if; 28186 28187 -- For Output states with visible refinement, all constituents must be 28188 -- used as Outputs in the global refinement. 28189 28190 if Serious_Errors_Detected = Errors then 28191 Check_Output_States; 28192 end if; 28193 28194 -- For Proof_In states with visible refinement, at least one constituent 28195 -- must be used as Proof_In in the global refinement. 28196 28197 if Serious_Errors_Detected = Errors then 28198 Check_Proof_In_States; 28199 end if; 28200 28201 -- Emit errors for all constituents that belong to other states with 28202 -- visible refinement that do not appear in Global. 28203 28204 if Serious_Errors_Detected = Errors then 28205 Report_Extra_Constituents; 28206 end if; 28207 28208 -- Emit errors for all items in Global that are not repeated in the 28209 -- global refinement and for which there is no full visible refinement 28210 -- and, in the case of states with partial visible refinement, no 28211 -- constituent is mentioned in the global refinement. 28212 28213 if Serious_Errors_Detected = Errors then 28214 Report_Missing_Items; 28215 end if; 28216 28217 -- Emit an error if no constituent is used in the global refinement 28218 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise 28219 -- one may be issued by the checking procedures. Do not perform this 28220 -- check in an instance because it was already performed successfully 28221 -- in the generic template. 28222 28223 if Serious_Errors_Detected = Errors 28224 and then not Is_Generic_Instance (Spec_Id) 28225 and then not Has_Null_State 28226 and then No_Constit 28227 then 28228 SPARK_Msg_N ("missing refinement", N); 28229 end if; 28230 28231 <<Leave>> 28232 Set_Is_Analyzed_Pragma (N); 28233 end Analyze_Refined_Global_In_Decl_Part; 28234 28235 ---------------------------------------- 28236 -- Analyze_Refined_State_In_Decl_Part -- 28237 ---------------------------------------- 28238 28239 procedure Analyze_Refined_State_In_Decl_Part 28240 (N : Node_Id; 28241 Freeze_Id : Entity_Id := Empty) 28242 is 28243 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 28244 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 28245 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); 28246 28247 Available_States : Elist_Id := No_Elist; 28248 -- A list of all abstract states defined in the package declaration that 28249 -- are available for refinement. The list is used to report unrefined 28250 -- states. 28251 28252 Body_States : Elist_Id := No_Elist; 28253 -- A list of all hidden states that appear in the body of the related 28254 -- package. The list is used to report unused hidden states. 28255 28256 Constituents_Seen : Elist_Id := No_Elist; 28257 -- A list that contains all constituents processed so far. The list is 28258 -- used to detect multiple uses of the same constituent. 28259 28260 Freeze_Posted : Boolean := False; 28261 -- A flag that controls the output of a freezing-related error (see use 28262 -- below). 28263 28264 Refined_States_Seen : Elist_Id := No_Elist; 28265 -- A list that contains all refined states processed so far. The list is 28266 -- used to detect duplicate refinements. 28267 28268 procedure Analyze_Refinement_Clause (Clause : Node_Id); 28269 -- Perform full analysis of a single refinement clause 28270 28271 procedure Report_Unrefined_States (States : Elist_Id); 28272 -- Emit errors for all unrefined abstract states found in list States 28273 28274 ------------------------------- 28275 -- Analyze_Refinement_Clause -- 28276 ------------------------------- 28277 28278 procedure Analyze_Refinement_Clause (Clause : Node_Id) is 28279 AR_Constit : Entity_Id := Empty; 28280 AW_Constit : Entity_Id := Empty; 28281 ER_Constit : Entity_Id := Empty; 28282 EW_Constit : Entity_Id := Empty; 28283 -- The entities of external constituents that contain one of the 28284 -- following enabled properties: Async_Readers, Async_Writers, 28285 -- Effective_Reads and Effective_Writes. 28286 28287 External_Constit_Seen : Boolean := False; 28288 -- Flag used to mark when at least one external constituent is part 28289 -- of the state refinement. 28290 28291 Non_Null_Seen : Boolean := False; 28292 Null_Seen : Boolean := False; 28293 -- Flags used to detect multiple uses of null in a single clause or a 28294 -- mixture of null and non-null constituents. 28295 28296 Part_Of_Constits : Elist_Id := No_Elist; 28297 -- A list of all candidate constituents subject to indicator Part_Of 28298 -- where the encapsulating state is the current state. 28299 28300 State : Node_Id; 28301 State_Id : Entity_Id; 28302 -- The current state being refined 28303 28304 procedure Analyze_Constituent (Constit : Node_Id); 28305 -- Perform full analysis of a single constituent 28306 28307 procedure Check_External_Property 28308 (Prop_Nam : Name_Id; 28309 Enabled : Boolean; 28310 Constit : Entity_Id); 28311 -- Determine whether a property denoted by name Prop_Nam is present 28312 -- in the refined state. Emit an error if this is not the case. Flag 28313 -- Enabled should be set when the property applies to the refined 28314 -- state. Constit denotes the constituent (if any) which introduces 28315 -- the property in the refinement. 28316 28317 procedure Match_State; 28318 -- Determine whether the state being refined appears in list 28319 -- Available_States. Emit an error when attempting to re-refine the 28320 -- state or when the state is not defined in the package declaration, 28321 -- otherwise remove the state from Available_States. 28322 28323 procedure Report_Unused_Constituents (Constits : Elist_Id); 28324 -- Emit errors for all unused Part_Of constituents in list Constits 28325 28326 ------------------------- 28327 -- Analyze_Constituent -- 28328 ------------------------- 28329 28330 procedure Analyze_Constituent (Constit : Node_Id) is 28331 procedure Match_Constituent (Constit_Id : Entity_Id); 28332 -- Determine whether constituent Constit denoted by its entity 28333 -- Constit_Id appears in Body_States. Emit an error when the 28334 -- constituent is not a valid hidden state of the related package 28335 -- or when it is used more than once. Otherwise remove the 28336 -- constituent from Body_States. 28337 28338 ----------------------- 28339 -- Match_Constituent -- 28340 ----------------------- 28341 28342 procedure Match_Constituent (Constit_Id : Entity_Id) is 28343 procedure Collect_Constituent; 28344 -- Verify the legality of constituent Constit_Id and add it to 28345 -- the refinements of State_Id. 28346 28347 ------------------------- 28348 -- Collect_Constituent -- 28349 ------------------------- 28350 28351 procedure Collect_Constituent is 28352 Constits : Elist_Id; 28353 28354 begin 28355 -- The Ghost policy in effect at the point of abstract state 28356 -- declaration and constituent must match (SPARK RM 6.9(15)) 28357 28358 Check_Ghost_Refinement 28359 (State, State_Id, Constit, Constit_Id); 28360 28361 -- A synchronized state must be refined by a synchronized 28362 -- object or another synchronized state (SPARK RM 9.6). 28363 28364 if Is_Synchronized_State (State_Id) 28365 and then not Is_Synchronized_Object (Constit_Id) 28366 and then not Is_Synchronized_State (Constit_Id) 28367 then 28368 SPARK_Msg_NE 28369 ("constituent of synchronized state & must be " 28370 & "synchronized", Constit, State_Id); 28371 end if; 28372 28373 -- Add the constituent to the list of processed items to aid 28374 -- with the detection of duplicates. 28375 28376 Append_New_Elmt (Constit_Id, Constituents_Seen); 28377 28378 -- Collect the constituent in the list of refinement items 28379 -- and establish a relation between the refined state and 28380 -- the item. 28381 28382 Constits := Refinement_Constituents (State_Id); 28383 28384 if No (Constits) then 28385 Constits := New_Elmt_List; 28386 Set_Refinement_Constituents (State_Id, Constits); 28387 end if; 28388 28389 Append_Elmt (Constit_Id, Constits); 28390 Set_Encapsulating_State (Constit_Id, State_Id); 28391 28392 -- The state has at least one legal constituent, mark the 28393 -- start of the refinement region. The region ends when the 28394 -- body declarations end (see routine Analyze_Declarations). 28395 28396 Set_Has_Visible_Refinement (State_Id); 28397 28398 -- When the constituent is external, save its relevant 28399 -- property for further checks. 28400 28401 if Async_Readers_Enabled (Constit_Id) then 28402 AR_Constit := Constit_Id; 28403 External_Constit_Seen := True; 28404 end if; 28405 28406 if Async_Writers_Enabled (Constit_Id) then 28407 AW_Constit := Constit_Id; 28408 External_Constit_Seen := True; 28409 end if; 28410 28411 if Effective_Reads_Enabled (Constit_Id) then 28412 ER_Constit := Constit_Id; 28413 External_Constit_Seen := True; 28414 end if; 28415 28416 if Effective_Writes_Enabled (Constit_Id) then 28417 EW_Constit := Constit_Id; 28418 External_Constit_Seen := True; 28419 end if; 28420 end Collect_Constituent; 28421 28422 -- Local variables 28423 28424 State_Elmt : Elmt_Id; 28425 28426 -- Start of processing for Match_Constituent 28427 28428 begin 28429 -- Detect a duplicate use of a constituent 28430 28431 if Contains (Constituents_Seen, Constit_Id) then 28432 SPARK_Msg_NE 28433 ("duplicate use of constituent &", Constit, Constit_Id); 28434 return; 28435 end if; 28436 28437 -- The constituent is subject to a Part_Of indicator 28438 28439 if Present (Encapsulating_State (Constit_Id)) then 28440 if Encapsulating_State (Constit_Id) = State_Id then 28441 Remove (Part_Of_Constits, Constit_Id); 28442 Collect_Constituent; 28443 28444 -- The constituent is part of another state and is used 28445 -- incorrectly in the refinement of the current state. 28446 28447 else 28448 Error_Msg_Name_1 := Chars (State_Id); 28449 SPARK_Msg_NE 28450 ("& cannot act as constituent of state %", 28451 Constit, Constit_Id); 28452 SPARK_Msg_NE 28453 ("\Part_Of indicator specifies encapsulator &", 28454 Constit, Encapsulating_State (Constit_Id)); 28455 end if; 28456 28457 -- The only other source of legal constituents is the body 28458 -- state space of the related package. 28459 28460 else 28461 if Present (Body_States) then 28462 State_Elmt := First_Elmt (Body_States); 28463 while Present (State_Elmt) loop 28464 28465 -- Consume a valid constituent to signal that it has 28466 -- been encountered. 28467 28468 if Node (State_Elmt) = Constit_Id then 28469 Remove_Elmt (Body_States, State_Elmt); 28470 Collect_Constituent; 28471 return; 28472 end if; 28473 28474 Next_Elmt (State_Elmt); 28475 end loop; 28476 end if; 28477 28478 -- At this point it is known that the constituent is not 28479 -- part of the package hidden state and cannot be used in 28480 -- a refinement (SPARK RM 7.2.2(9)). 28481 28482 Error_Msg_Name_1 := Chars (Spec_Id); 28483 SPARK_Msg_NE 28484 ("cannot use & in refinement, constituent is not a hidden " 28485 & "state of package %", Constit, Constit_Id); 28486 end if; 28487 end Match_Constituent; 28488 28489 -- Local variables 28490 28491 Constit_Id : Entity_Id; 28492 Constits : Elist_Id; 28493 28494 -- Start of processing for Analyze_Constituent 28495 28496 begin 28497 -- Detect multiple uses of null in a single refinement clause or a 28498 -- mixture of null and non-null constituents. 28499 28500 if Nkind (Constit) = N_Null then 28501 if Null_Seen then 28502 SPARK_Msg_N 28503 ("multiple null constituents not allowed", Constit); 28504 28505 elsif Non_Null_Seen then 28506 SPARK_Msg_N 28507 ("cannot mix null and non-null constituents", Constit); 28508 28509 else 28510 Null_Seen := True; 28511 28512 -- Collect the constituent in the list of refinement items 28513 28514 Constits := Refinement_Constituents (State_Id); 28515 28516 if No (Constits) then 28517 Constits := New_Elmt_List; 28518 Set_Refinement_Constituents (State_Id, Constits); 28519 end if; 28520 28521 Append_Elmt (Constit, Constits); 28522 28523 -- The state has at least one legal constituent, mark the 28524 -- start of the refinement region. The region ends when the 28525 -- body declarations end (see Analyze_Declarations). 28526 28527 Set_Has_Visible_Refinement (State_Id); 28528 end if; 28529 28530 -- Non-null constituents 28531 28532 else 28533 Non_Null_Seen := True; 28534 28535 if Null_Seen then 28536 SPARK_Msg_N 28537 ("cannot mix null and non-null constituents", Constit); 28538 end if; 28539 28540 Analyze (Constit); 28541 Resolve_State (Constit); 28542 28543 -- Ensure that the constituent denotes a valid state or a 28544 -- whole object (SPARK RM 7.2.2(5)). 28545 28546 if Is_Entity_Name (Constit) then 28547 Constit_Id := Entity_Of (Constit); 28548 28549 -- When a constituent is declared after a subprogram body 28550 -- that caused freezing of the related contract where 28551 -- pragma Refined_State resides, the constituent appears 28552 -- undefined and carries Any_Id as its entity. 28553 28554 -- package body Pack 28555 -- with Refined_State => (State => Constit) 28556 -- is 28557 -- procedure Proc 28558 -- with Refined_Global => (Input => Constit) 28559 -- is 28560 -- ... 28561 -- end Proc; 28562 28563 -- Constit : ...; 28564 -- end Pack; 28565 28566 if Constit_Id = Any_Id then 28567 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id); 28568 28569 -- Emit a specialized info message when the contract of 28570 -- the related package body was "frozen" by another body. 28571 -- Note that it is not possible to precisely identify why 28572 -- the constituent is undefined because it is not visible 28573 -- when pragma Refined_State is analyzed. This message is 28574 -- a reasonable approximation. 28575 28576 if Present (Freeze_Id) and then not Freeze_Posted then 28577 Freeze_Posted := True; 28578 28579 Error_Msg_Name_1 := Chars (Body_Id); 28580 Error_Msg_Sloc := Sloc (Freeze_Id); 28581 SPARK_Msg_NE 28582 ("body & declared # freezes the contract of %", 28583 N, Freeze_Id); 28584 SPARK_Msg_N 28585 ("\all constituents must be declared before body #", 28586 N); 28587 28588 -- A misplaced constituent is a critical error because 28589 -- pragma Refined_Depends or Refined_Global depends on 28590 -- the proper link between a state and a constituent. 28591 -- Stop the compilation, as this leads to a multitude 28592 -- of misleading cascaded errors. 28593 28594 raise Unrecoverable_Error; 28595 end if; 28596 28597 -- The constituent is a valid state or object 28598 28599 elsif Ekind_In (Constit_Id, E_Abstract_State, 28600 E_Constant, 28601 E_Variable) 28602 then 28603 Match_Constituent (Constit_Id); 28604 28605 -- The variable may eventually become a constituent of a 28606 -- single protected/task type. Record the reference now 28607 -- and verify its legality when analyzing the contract of 28608 -- the variable (SPARK RM 9.3). 28609 28610 if Ekind (Constit_Id) = E_Variable then 28611 Record_Possible_Part_Of_Reference 28612 (Var_Id => Constit_Id, 28613 Ref => Constit); 28614 end if; 28615 28616 -- Otherwise the constituent is illegal 28617 28618 else 28619 SPARK_Msg_NE 28620 ("constituent & must denote object or state", 28621 Constit, Constit_Id); 28622 end if; 28623 28624 -- The constituent is illegal 28625 28626 else 28627 SPARK_Msg_N ("malformed constituent", Constit); 28628 end if; 28629 end if; 28630 end Analyze_Constituent; 28631 28632 ----------------------------- 28633 -- Check_External_Property -- 28634 ----------------------------- 28635 28636 procedure Check_External_Property 28637 (Prop_Nam : Name_Id; 28638 Enabled : Boolean; 28639 Constit : Entity_Id) 28640 is 28641 begin 28642 -- The property is missing in the declaration of the state, but 28643 -- a constituent is introducing it in the state refinement 28644 -- (SPARK RM 7.2.8(2)). 28645 28646 if not Enabled and then Present (Constit) then 28647 Error_Msg_Name_1 := Prop_Nam; 28648 Error_Msg_Name_2 := Chars (State_Id); 28649 SPARK_Msg_NE 28650 ("constituent & introduces external property % in refinement " 28651 & "of state %", State, Constit); 28652 28653 Error_Msg_Sloc := Sloc (State_Id); 28654 SPARK_Msg_N 28655 ("\property is missing in abstract state declaration #", 28656 State); 28657 end if; 28658 end Check_External_Property; 28659 28660 ----------------- 28661 -- Match_State -- 28662 ----------------- 28663 28664 procedure Match_State is 28665 State_Elmt : Elmt_Id; 28666 28667 begin 28668 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8)) 28669 28670 if Contains (Refined_States_Seen, State_Id) then 28671 SPARK_Msg_NE 28672 ("duplicate refinement of state &", State, State_Id); 28673 return; 28674 end if; 28675 28676 -- Inspect the abstract states defined in the package declaration 28677 -- looking for a match. 28678 28679 State_Elmt := First_Elmt (Available_States); 28680 while Present (State_Elmt) loop 28681 28682 -- A valid abstract state is being refined in the body. Add 28683 -- the state to the list of processed refined states to aid 28684 -- with the detection of duplicate refinements. Remove the 28685 -- state from Available_States to signal that it has already 28686 -- been refined. 28687 28688 if Node (State_Elmt) = State_Id then 28689 Append_New_Elmt (State_Id, Refined_States_Seen); 28690 Remove_Elmt (Available_States, State_Elmt); 28691 return; 28692 end if; 28693 28694 Next_Elmt (State_Elmt); 28695 end loop; 28696 28697 -- If we get here, we are refining a state that is not defined in 28698 -- the package declaration. 28699 28700 Error_Msg_Name_1 := Chars (Spec_Id); 28701 SPARK_Msg_NE 28702 ("cannot refine state, & is not defined in package %", 28703 State, State_Id); 28704 end Match_State; 28705 28706 -------------------------------- 28707 -- Report_Unused_Constituents -- 28708 -------------------------------- 28709 28710 procedure Report_Unused_Constituents (Constits : Elist_Id) is 28711 Constit_Elmt : Elmt_Id; 28712 Constit_Id : Entity_Id; 28713 Posted : Boolean := False; 28714 28715 begin 28716 if Present (Constits) then 28717 Constit_Elmt := First_Elmt (Constits); 28718 while Present (Constit_Elmt) loop 28719 Constit_Id := Node (Constit_Elmt); 28720 28721 -- Generate an error message of the form: 28722 28723 -- state ... has unused Part_Of constituents 28724 -- abstract state ... defined at ... 28725 -- constant ... defined at ... 28726 -- variable ... defined at ... 28727 28728 if not Posted then 28729 Posted := True; 28730 SPARK_Msg_NE 28731 ("state & has unused Part_Of constituents", 28732 State, State_Id); 28733 end if; 28734 28735 Error_Msg_Sloc := Sloc (Constit_Id); 28736 28737 if Ekind (Constit_Id) = E_Abstract_State then 28738 SPARK_Msg_NE 28739 ("\abstract state & defined #", State, Constit_Id); 28740 28741 elsif Ekind (Constit_Id) = E_Constant then 28742 SPARK_Msg_NE 28743 ("\constant & defined #", State, Constit_Id); 28744 28745 else 28746 pragma Assert (Ekind (Constit_Id) = E_Variable); 28747 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id); 28748 end if; 28749 28750 Next_Elmt (Constit_Elmt); 28751 end loop; 28752 end if; 28753 end Report_Unused_Constituents; 28754 28755 -- Local declarations 28756 28757 Body_Ref : Node_Id; 28758 Body_Ref_Elmt : Elmt_Id; 28759 Constit : Node_Id; 28760 Extra_State : Node_Id; 28761 28762 -- Start of processing for Analyze_Refinement_Clause 28763 28764 begin 28765 -- A refinement clause appears as a component association where the 28766 -- sole choice is the state and the expressions are the constituents. 28767 -- This is a syntax error, always report. 28768 28769 if Nkind (Clause) /= N_Component_Association then 28770 Error_Msg_N ("malformed state refinement clause", Clause); 28771 return; 28772 end if; 28773 28774 -- Analyze the state name of a refinement clause 28775 28776 State := First (Choices (Clause)); 28777 28778 Analyze (State); 28779 Resolve_State (State); 28780 28781 -- Ensure that the state name denotes a valid abstract state that is 28782 -- defined in the spec of the related package. 28783 28784 if Is_Entity_Name (State) then 28785 State_Id := Entity_Of (State); 28786 28787 -- When the abstract state is undefined, it appears as Any_Id. Do 28788 -- not continue with the analysis of the clause. 28789 28790 if State_Id = Any_Id then 28791 return; 28792 28793 -- Catch any attempts to re-refine a state or refine a state that 28794 -- is not defined in the package declaration. 28795 28796 elsif Ekind (State_Id) = E_Abstract_State then 28797 Match_State; 28798 28799 else 28800 SPARK_Msg_NE ("& must denote abstract state", State, State_Id); 28801 return; 28802 end if; 28803 28804 -- References to a state with visible refinement are illegal. 28805 -- When nested packages are involved, detecting such references is 28806 -- tricky because pragma Refined_State is analyzed later than the 28807 -- offending pragma Depends or Global. References that occur in 28808 -- such nested context are stored in a list. Emit errors for all 28809 -- references found in Body_References (SPARK RM 6.1.4(8)). 28810 28811 if Present (Body_References (State_Id)) then 28812 Body_Ref_Elmt := First_Elmt (Body_References (State_Id)); 28813 while Present (Body_Ref_Elmt) loop 28814 Body_Ref := Node (Body_Ref_Elmt); 28815 28816 SPARK_Msg_N ("reference to & not allowed", Body_Ref); 28817 Error_Msg_Sloc := Sloc (State); 28818 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref); 28819 28820 Next_Elmt (Body_Ref_Elmt); 28821 end loop; 28822 end if; 28823 28824 -- The state name is illegal. This is a syntax error, always report. 28825 28826 else 28827 Error_Msg_N ("malformed state name in refinement clause", State); 28828 return; 28829 end if; 28830 28831 -- A refinement clause may only refine one state at a time 28832 28833 Extra_State := Next (State); 28834 28835 if Present (Extra_State) then 28836 SPARK_Msg_N 28837 ("refinement clause cannot cover multiple states", Extra_State); 28838 end if; 28839 28840 -- Replicate the Part_Of constituents of the refined state because 28841 -- the algorithm will consume items. 28842 28843 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id)); 28844 28845 -- Analyze all constituents of the refinement. Multiple constituents 28846 -- appear as an aggregate. 28847 28848 Constit := Expression (Clause); 28849 28850 if Nkind (Constit) = N_Aggregate then 28851 if Present (Component_Associations (Constit)) then 28852 SPARK_Msg_N 28853 ("constituents of refinement clause must appear in " 28854 & "positional form", Constit); 28855 28856 else pragma Assert (Present (Expressions (Constit))); 28857 Constit := First (Expressions (Constit)); 28858 while Present (Constit) loop 28859 Analyze_Constituent (Constit); 28860 Next (Constit); 28861 end loop; 28862 end if; 28863 28864 -- Various forms of a single constituent. Note that these may include 28865 -- malformed constituents. 28866 28867 else 28868 Analyze_Constituent (Constit); 28869 end if; 28870 28871 -- Verify that external constituents do not introduce new external 28872 -- property in the state refinement (SPARK RM 7.2.8(2)). 28873 28874 if Is_External_State (State_Id) then 28875 Check_External_Property 28876 (Prop_Nam => Name_Async_Readers, 28877 Enabled => Async_Readers_Enabled (State_Id), 28878 Constit => AR_Constit); 28879 28880 Check_External_Property 28881 (Prop_Nam => Name_Async_Writers, 28882 Enabled => Async_Writers_Enabled (State_Id), 28883 Constit => AW_Constit); 28884 28885 Check_External_Property 28886 (Prop_Nam => Name_Effective_Reads, 28887 Enabled => Effective_Reads_Enabled (State_Id), 28888 Constit => ER_Constit); 28889 28890 Check_External_Property 28891 (Prop_Nam => Name_Effective_Writes, 28892 Enabled => Effective_Writes_Enabled (State_Id), 28893 Constit => EW_Constit); 28894 28895 -- When a refined state is not external, it should not have external 28896 -- constituents (SPARK RM 7.2.8(1)). 28897 28898 elsif External_Constit_Seen then 28899 SPARK_Msg_NE 28900 ("non-external state & cannot contain external constituents in " 28901 & "refinement", State, State_Id); 28902 end if; 28903 28904 -- Ensure that all Part_Of candidate constituents have been mentioned 28905 -- in the refinement clause. 28906 28907 Report_Unused_Constituents (Part_Of_Constits); 28908 end Analyze_Refinement_Clause; 28909 28910 ----------------------------- 28911 -- Report_Unrefined_States -- 28912 ----------------------------- 28913 28914 procedure Report_Unrefined_States (States : Elist_Id) is 28915 State_Elmt : Elmt_Id; 28916 28917 begin 28918 if Present (States) then 28919 State_Elmt := First_Elmt (States); 28920 while Present (State_Elmt) loop 28921 SPARK_Msg_N 28922 ("abstract state & must be refined", Node (State_Elmt)); 28923 28924 Next_Elmt (State_Elmt); 28925 end loop; 28926 end if; 28927 end Report_Unrefined_States; 28928 28929 -- Local declarations 28930 28931 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 28932 Clause : Node_Id; 28933 28934 -- Start of processing for Analyze_Refined_State_In_Decl_Part 28935 28936 begin 28937 -- Do not analyze the pragma multiple times 28938 28939 if Is_Analyzed_Pragma (N) then 28940 return; 28941 end if; 28942 28943 -- Save the scenario for examination by the ABE Processing phase 28944 28945 Record_Elaboration_Scenario (N); 28946 28947 -- Replicate the abstract states declared by the package because the 28948 -- matching algorithm will consume states. 28949 28950 Available_States := New_Copy_Elist (Abstract_States (Spec_Id)); 28951 28952 -- Gather all abstract states and objects declared in the visible 28953 -- state space of the package body. These items must be utilized as 28954 -- constituents in a state refinement. 28955 28956 Body_States := Collect_Body_States (Body_Id); 28957 28958 -- Multiple non-null state refinements appear as an aggregate 28959 28960 if Nkind (Clauses) = N_Aggregate then 28961 if Present (Expressions (Clauses)) then 28962 SPARK_Msg_N 28963 ("state refinements must appear as component associations", 28964 Clauses); 28965 28966 else pragma Assert (Present (Component_Associations (Clauses))); 28967 Clause := First (Component_Associations (Clauses)); 28968 while Present (Clause) loop 28969 Analyze_Refinement_Clause (Clause); 28970 Next (Clause); 28971 end loop; 28972 end if; 28973 28974 -- Various forms of a single state refinement. Note that these may 28975 -- include malformed refinements. 28976 28977 else 28978 Analyze_Refinement_Clause (Clauses); 28979 end if; 28980 28981 -- List all abstract states that were left unrefined 28982 28983 Report_Unrefined_States (Available_States); 28984 28985 Set_Is_Analyzed_Pragma (N); 28986 end Analyze_Refined_State_In_Decl_Part; 28987 28988 ------------------------------------ 28989 -- Analyze_Test_Case_In_Decl_Part -- 28990 ------------------------------------ 28991 28992 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is 28993 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 28994 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 28995 28996 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id); 28997 -- Preanalyze one of the optional arguments "Requires" or "Ensures" 28998 -- denoted by Arg_Nam. 28999 29000 ------------------------------ 29001 -- Preanalyze_Test_Case_Arg -- 29002 ------------------------------ 29003 29004 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is 29005 Arg : Node_Id; 29006 29007 begin 29008 -- Preanalyze the original aspect argument for ASIS or for a generic 29009 -- subprogram to properly capture global references. 29010 29011 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then 29012 Arg := 29013 Test_Case_Arg 29014 (Prag => N, 29015 Arg_Nam => Arg_Nam, 29016 From_Aspect => True); 29017 29018 if Present (Arg) then 29019 Preanalyze_Assert_Expression 29020 (Expression (Arg), Standard_Boolean); 29021 end if; 29022 end if; 29023 29024 Arg := Test_Case_Arg (N, Arg_Nam); 29025 29026 if Present (Arg) then 29027 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean); 29028 end if; 29029 end Preanalyze_Test_Case_Arg; 29030 29031 -- Local variables 29032 29033 Restore_Scope : Boolean := False; 29034 29035 -- Start of processing for Analyze_Test_Case_In_Decl_Part 29036 29037 begin 29038 -- Do not analyze the pragma multiple times 29039 29040 if Is_Analyzed_Pragma (N) then 29041 return; 29042 end if; 29043 29044 -- Ensure that the formal parameters are visible when analyzing all 29045 -- clauses. This falls out of the general rule of aspects pertaining 29046 -- to subprogram declarations. 29047 29048 if not In_Open_Scopes (Spec_Id) then 29049 Restore_Scope := True; 29050 Push_Scope (Spec_Id); 29051 29052 if Is_Generic_Subprogram (Spec_Id) then 29053 Install_Generic_Formals (Spec_Id); 29054 else 29055 Install_Formals (Spec_Id); 29056 end if; 29057 end if; 29058 29059 Preanalyze_Test_Case_Arg (Name_Requires); 29060 Preanalyze_Test_Case_Arg (Name_Ensures); 29061 29062 if Restore_Scope then 29063 End_Scope; 29064 end if; 29065 29066 -- Currently it is not possible to inline pre/postconditions on a 29067 -- subprogram subject to pragma Inline_Always. 29068 29069 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 29070 29071 Set_Is_Analyzed_Pragma (N); 29072 end Analyze_Test_Case_In_Decl_Part; 29073 29074 ---------------- 29075 -- Appears_In -- 29076 ---------------- 29077 29078 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is 29079 Elmt : Elmt_Id; 29080 Id : Entity_Id; 29081 29082 begin 29083 if Present (List) then 29084 Elmt := First_Elmt (List); 29085 while Present (Elmt) loop 29086 if Nkind (Node (Elmt)) = N_Defining_Identifier then 29087 Id := Node (Elmt); 29088 else 29089 Id := Entity_Of (Node (Elmt)); 29090 end if; 29091 29092 if Id = Item_Id then 29093 return True; 29094 end if; 29095 29096 Next_Elmt (Elmt); 29097 end loop; 29098 end if; 29099 29100 return False; 29101 end Appears_In; 29102 29103 ----------------------------------- 29104 -- Build_Pragma_Check_Equivalent -- 29105 ----------------------------------- 29106 29107 function Build_Pragma_Check_Equivalent 29108 (Prag : Node_Id; 29109 Subp_Id : Entity_Id := Empty; 29110 Inher_Id : Entity_Id := Empty; 29111 Keep_Pragma_Id : Boolean := False) return Node_Id 29112 is 29113 function Suppress_Reference (N : Node_Id) return Traverse_Result; 29114 -- Detect whether node N references a formal parameter subject to 29115 -- pragma Unreferenced. If this is the case, set Comes_From_Source 29116 -- to False to suppress the generation of a reference when analyzing 29117 -- N later on. 29118 29119 ------------------------ 29120 -- Suppress_Reference -- 29121 ------------------------ 29122 29123 function Suppress_Reference (N : Node_Id) return Traverse_Result is 29124 Formal : Entity_Id; 29125 29126 begin 29127 if Is_Entity_Name (N) and then Present (Entity (N)) then 29128 Formal := Entity (N); 29129 29130 -- The formal parameter is subject to pragma Unreferenced. Prevent 29131 -- the generation of references by resetting the Comes_From_Source 29132 -- flag. 29133 29134 if Is_Formal (Formal) 29135 and then Has_Pragma_Unreferenced (Formal) 29136 then 29137 Set_Comes_From_Source (N, False); 29138 end if; 29139 end if; 29140 29141 return OK; 29142 end Suppress_Reference; 29143 29144 procedure Suppress_References is 29145 new Traverse_Proc (Suppress_Reference); 29146 29147 -- Local variables 29148 29149 Loc : constant Source_Ptr := Sloc (Prag); 29150 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 29151 Check_Prag : Node_Id; 29152 Msg_Arg : Node_Id; 29153 Nam : Name_Id; 29154 29155 Needs_Wrapper : Boolean; 29156 pragma Unreferenced (Needs_Wrapper); 29157 29158 -- Start of processing for Build_Pragma_Check_Equivalent 29159 29160 begin 29161 -- When the pre- or postcondition is inherited, map the formals of the 29162 -- inherited subprogram to those of the current subprogram. In addition, 29163 -- map primitive operations of the parent type into the corresponding 29164 -- primitive operations of the descendant. 29165 29166 if Present (Inher_Id) then 29167 pragma Assert (Present (Subp_Id)); 29168 29169 Update_Primitives_Mapping (Inher_Id, Subp_Id); 29170 29171 -- Use generic machinery to copy inherited pragma, as if it were an 29172 -- instantiation, resetting source locations appropriately, so that 29173 -- expressions inside the inherited pragma use chained locations. 29174 -- This is used in particular in GNATprove to locate precisely 29175 -- messages on a given inherited pragma. 29176 29177 Set_Copied_Sloc_For_Inherited_Pragma 29178 (Unit_Declaration_Node (Subp_Id), Inher_Id); 29179 Check_Prag := New_Copy_Tree (Source => Prag); 29180 29181 -- Build the inherited class-wide condition 29182 29183 Build_Class_Wide_Expression 29184 (Prag => Check_Prag, 29185 Subp => Subp_Id, 29186 Par_Subp => Inher_Id, 29187 Adjust_Sloc => True, 29188 Needs_Wrapper => Needs_Wrapper); 29189 29190 -- If not an inherited condition simply copy the original pragma 29191 29192 else 29193 Check_Prag := New_Copy_Tree (Source => Prag); 29194 end if; 29195 29196 -- Mark the pragma as being internally generated and reset the Analyzed 29197 -- flag. 29198 29199 Set_Analyzed (Check_Prag, False); 29200 Set_Comes_From_Source (Check_Prag, False); 29201 29202 -- The tree of the original pragma may contain references to the 29203 -- formal parameters of the related subprogram. At the same time 29204 -- the corresponding body may mark the formals as unreferenced: 29205 29206 -- procedure Proc (Formal : ...) 29207 -- with Pre => Formal ...; 29208 29209 -- procedure Proc (Formal : ...) is 29210 -- pragma Unreferenced (Formal); 29211 -- ... 29212 29213 -- This creates problems because all pragma Check equivalents are 29214 -- analyzed at the end of the body declarations. Since all source 29215 -- references have already been accounted for, reset any references 29216 -- to such formals in the generated pragma Check equivalent. 29217 29218 Suppress_References (Check_Prag); 29219 29220 if Present (Corresponding_Aspect (Prag)) then 29221 Nam := Chars (Identifier (Corresponding_Aspect (Prag))); 29222 else 29223 Nam := Prag_Nam; 29224 end if; 29225 29226 -- Unless Keep_Pragma_Id is True in order to keep the identifier of 29227 -- the copied pragma in the newly created pragma, convert the copy into 29228 -- pragma Check by correcting the name and adding a check_kind argument. 29229 29230 if not Keep_Pragma_Id then 29231 Set_Class_Present (Check_Prag, False); 29232 29233 Set_Pragma_Identifier 29234 (Check_Prag, Make_Identifier (Loc, Name_Check)); 29235 29236 Prepend_To (Pragma_Argument_Associations (Check_Prag), 29237 Make_Pragma_Argument_Association (Loc, 29238 Expression => Make_Identifier (Loc, Nam))); 29239 end if; 29240 29241 -- Update the error message when the pragma is inherited 29242 29243 if Present (Inher_Id) then 29244 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag)); 29245 29246 if Chars (Msg_Arg) = Name_Message then 29247 String_To_Name_Buffer (Strval (Expression (Msg_Arg))); 29248 29249 -- Insert "inherited" to improve the error message 29250 29251 if Name_Buffer (1 .. 8) = "failed p" then 29252 Insert_Str_In_Name_Buffer ("inherited ", 8); 29253 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer); 29254 end if; 29255 end if; 29256 end if; 29257 29258 return Check_Prag; 29259 end Build_Pragma_Check_Equivalent; 29260 29261 ----------------------------- 29262 -- Check_Applicable_Policy -- 29263 ----------------------------- 29264 29265 procedure Check_Applicable_Policy (N : Node_Id) is 29266 PP : Node_Id; 29267 Policy : Name_Id; 29268 29269 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N); 29270 29271 begin 29272 -- No effect if not valid assertion kind name 29273 29274 if not Is_Valid_Assertion_Kind (Ename) then 29275 return; 29276 end if; 29277 29278 -- Loop through entries in check policy list 29279 29280 PP := Opt.Check_Policy_List; 29281 while Present (PP) loop 29282 declare 29283 PPA : constant List_Id := Pragma_Argument_Associations (PP); 29284 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 29285 29286 begin 29287 if Ename = Pnm 29288 or else Pnm = Name_Assertion 29289 or else (Pnm = Name_Statement_Assertions 29290 and then Nam_In (Ename, Name_Assert, 29291 Name_Assert_And_Cut, 29292 Name_Assume, 29293 Name_Loop_Invariant, 29294 Name_Loop_Variant)) 29295 then 29296 Policy := Chars (Get_Pragma_Arg (Last (PPA))); 29297 29298 case Policy is 29299 when Name_Ignore 29300 | Name_Off 29301 => 29302 -- In CodePeer mode and GNATprove mode, we need to 29303 -- consider all assertions, unless they are disabled. 29304 -- Force Is_Checked on ignored assertions, in particular 29305 -- because transformations of the AST may depend on 29306 -- assertions being checked (e.g. the translation of 29307 -- attribute 'Loop_Entry). 29308 29309 if CodePeer_Mode or GNATprove_Mode then 29310 Set_Is_Checked (N, True); 29311 Set_Is_Ignored (N, False); 29312 else 29313 Set_Is_Checked (N, False); 29314 Set_Is_Ignored (N, True); 29315 end if; 29316 29317 when Name_Check 29318 | Name_On 29319 => 29320 Set_Is_Checked (N, True); 29321 Set_Is_Ignored (N, False); 29322 29323 when Name_Disable => 29324 Set_Is_Ignored (N, True); 29325 Set_Is_Checked (N, False); 29326 Set_Is_Disabled (N, True); 29327 29328 -- That should be exhaustive, the null here is a defence 29329 -- against a malformed tree from previous errors. 29330 29331 when others => 29332 null; 29333 end case; 29334 29335 return; 29336 end if; 29337 29338 PP := Next_Pragma (PP); 29339 end; 29340 end loop; 29341 29342 -- If there are no specific entries that matched, then we let the 29343 -- setting of assertions govern. Note that this provides the needed 29344 -- compatibility with the RM for the cases of assertion, invariant, 29345 -- precondition, predicate, and postcondition. Note also that 29346 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode. 29347 29348 if Assertions_Enabled then 29349 Set_Is_Checked (N, True); 29350 Set_Is_Ignored (N, False); 29351 else 29352 Set_Is_Checked (N, False); 29353 Set_Is_Ignored (N, True); 29354 end if; 29355 end Check_Applicable_Policy; 29356 29357 ------------------------------- 29358 -- Check_External_Properties -- 29359 ------------------------------- 29360 29361 procedure Check_External_Properties 29362 (Item : Node_Id; 29363 AR : Boolean; 29364 AW : Boolean; 29365 ER : Boolean; 29366 EW : Boolean) 29367 is 29368 begin 29369 -- All properties enabled 29370 29371 if AR and AW and ER and EW then 29372 null; 29373 29374 -- Async_Readers + Effective_Writes 29375 -- Async_Readers + Async_Writers + Effective_Writes 29376 29377 elsif AR and EW and not ER then 29378 null; 29379 29380 -- Async_Writers + Effective_Reads 29381 -- Async_Readers + Async_Writers + Effective_Reads 29382 29383 elsif AW and ER and not EW then 29384 null; 29385 29386 -- Async_Readers + Async_Writers 29387 29388 elsif AR and AW and not ER and not EW then 29389 null; 29390 29391 -- Async_Readers 29392 29393 elsif AR and not AW and not ER and not EW then 29394 null; 29395 29396 -- Async_Writers 29397 29398 elsif AW and not AR and not ER and not EW then 29399 null; 29400 29401 else 29402 SPARK_Msg_N 29403 ("illegal combination of external properties (SPARK RM 7.1.2(6))", 29404 Item); 29405 end if; 29406 end Check_External_Properties; 29407 29408 ---------------- 29409 -- Check_Kind -- 29410 ---------------- 29411 29412 function Check_Kind (Nam : Name_Id) return Name_Id is 29413 PP : Node_Id; 29414 29415 begin 29416 -- Loop through entries in check policy list 29417 29418 PP := Opt.Check_Policy_List; 29419 while Present (PP) loop 29420 declare 29421 PPA : constant List_Id := Pragma_Argument_Associations (PP); 29422 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 29423 29424 begin 29425 if Nam = Pnm 29426 or else (Pnm = Name_Assertion 29427 and then Is_Valid_Assertion_Kind (Nam)) 29428 or else (Pnm = Name_Statement_Assertions 29429 and then Nam_In (Nam, Name_Assert, 29430 Name_Assert_And_Cut, 29431 Name_Assume, 29432 Name_Loop_Invariant, 29433 Name_Loop_Variant)) 29434 then 29435 case (Chars (Get_Pragma_Arg (Last (PPA)))) is 29436 when Name_Check 29437 | Name_On 29438 => 29439 return Name_Check; 29440 29441 when Name_Ignore 29442 | Name_Off 29443 => 29444 return Name_Ignore; 29445 29446 when Name_Disable => 29447 return Name_Disable; 29448 29449 when others => 29450 raise Program_Error; 29451 end case; 29452 29453 else 29454 PP := Next_Pragma (PP); 29455 end if; 29456 end; 29457 end loop; 29458 29459 -- If there are no specific entries that matched, then we let the 29460 -- setting of assertions govern. Note that this provides the needed 29461 -- compatibility with the RM for the cases of assertion, invariant, 29462 -- precondition, predicate, and postcondition. 29463 29464 if Assertions_Enabled then 29465 return Name_Check; 29466 else 29467 return Name_Ignore; 29468 end if; 29469 end Check_Kind; 29470 29471 --------------------------- 29472 -- Check_Missing_Part_Of -- 29473 --------------------------- 29474 29475 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is 29476 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean; 29477 -- Determine whether a package denoted by Pack_Id declares at least one 29478 -- visible state. 29479 29480 ----------------------- 29481 -- Has_Visible_State -- 29482 ----------------------- 29483 29484 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is 29485 Item_Id : Entity_Id; 29486 29487 begin 29488 -- Traverse the entity chain of the package trying to find at least 29489 -- one visible abstract state, variable or a package [instantiation] 29490 -- that declares a visible state. 29491 29492 Item_Id := First_Entity (Pack_Id); 29493 while Present (Item_Id) 29494 and then not In_Private_Part (Item_Id) 29495 loop 29496 -- Do not consider internally generated items 29497 29498 if not Comes_From_Source (Item_Id) then 29499 null; 29500 29501 -- Do not consider generic formals or their corresponding actuals 29502 -- because they are not part of a visible state. Note that both 29503 -- entities are marked as hidden. 29504 29505 elsif Is_Hidden (Item_Id) then 29506 null; 29507 29508 -- A visible state has been found. Note that constants are not 29509 -- considered here because it is not possible to determine whether 29510 -- they depend on variable input. This check is left to the SPARK 29511 -- prover. 29512 29513 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 29514 return True; 29515 29516 -- Recursively peek into nested packages and instantiations 29517 29518 elsif Ekind (Item_Id) = E_Package 29519 and then Has_Visible_State (Item_Id) 29520 then 29521 return True; 29522 end if; 29523 29524 Next_Entity (Item_Id); 29525 end loop; 29526 29527 return False; 29528 end Has_Visible_State; 29529 29530 -- Local variables 29531 29532 Pack_Id : Entity_Id; 29533 Placement : State_Space_Kind; 29534 29535 -- Start of processing for Check_Missing_Part_Of 29536 29537 begin 29538 -- Do not consider abstract states, variables or package instantiations 29539 -- coming from an instance as those always inherit the Part_Of indicator 29540 -- of the instance itself. 29541 29542 if In_Instance then 29543 return; 29544 29545 -- Do not consider internally generated entities as these can never 29546 -- have a Part_Of indicator. 29547 29548 elsif not Comes_From_Source (Item_Id) then 29549 return; 29550 29551 -- Perform these checks only when SPARK_Mode is enabled as they will 29552 -- interfere with standard Ada rules and produce false positives. 29553 29554 elsif SPARK_Mode /= On then 29555 return; 29556 29557 -- Do not consider constants, because the compiler cannot accurately 29558 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and 29559 -- act as a hidden state of a package. 29560 29561 elsif Ekind (Item_Id) = E_Constant then 29562 return; 29563 end if; 29564 29565 -- Find where the abstract state, variable or package instantiation 29566 -- lives with respect to the state space. 29567 29568 Find_Placement_In_State_Space 29569 (Item_Id => Item_Id, 29570 Placement => Placement, 29571 Pack_Id => Pack_Id); 29572 29573 -- Items that appear in a non-package construct (subprogram, block, etc) 29574 -- do not require a Part_Of indicator because they can never act as a 29575 -- hidden state. 29576 29577 if Placement = Not_In_Package then 29578 null; 29579 29580 -- An item declared in the body state space of a package always act as a 29581 -- constituent and does not need explicit Part_Of indicator. 29582 29583 elsif Placement = Body_State_Space then 29584 null; 29585 29586 -- In general an item declared in the visible state space of a package 29587 -- does not require a Part_Of indicator. The only exception is when the 29588 -- related package is a nongeneric private child unit, in which case 29589 -- Part_Of must denote a state in the parent unit or in one of its 29590 -- descendants. 29591 29592 elsif Placement = Visible_State_Space then 29593 if Is_Child_Unit (Pack_Id) 29594 and then not Is_Generic_Unit (Pack_Id) 29595 and then Is_Private_Descendant (Pack_Id) 29596 then 29597 -- A package instantiation does not need a Part_Of indicator when 29598 -- the related generic template has no visible state. 29599 29600 if Ekind (Item_Id) = E_Package 29601 and then Is_Generic_Instance (Item_Id) 29602 and then not Has_Visible_State (Item_Id) 29603 then 29604 null; 29605 29606 -- All other cases require Part_Of 29607 29608 else 29609 Error_Msg_N 29610 ("indicator Part_Of is required in this context " 29611 & "(SPARK RM 7.2.6(3))", Item_Id); 29612 Error_Msg_Name_1 := Chars (Pack_Id); 29613 Error_Msg_N 29614 ("\& is declared in the visible part of private child " 29615 & "unit %", Item_Id); 29616 end if; 29617 end if; 29618 29619 -- When the item appears in the private state space of a package, it 29620 -- must be a part of some state declared by the said package. 29621 29622 else pragma Assert (Placement = Private_State_Space); 29623 29624 -- The related package does not declare a state, the item cannot act 29625 -- as a Part_Of constituent. 29626 29627 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then 29628 null; 29629 29630 -- A package instantiation does not need a Part_Of indicator when the 29631 -- related generic template has no visible state. 29632 29633 elsif Ekind (Item_Id) = E_Package 29634 and then Is_Generic_Instance (Item_Id) 29635 and then not Has_Visible_State (Item_Id) 29636 then 29637 null; 29638 29639 -- All other cases require Part_Of 29640 29641 else 29642 Error_Msg_N 29643 ("indicator Part_Of is required in this context " 29644 & "(SPARK RM 7.2.6(2))", Item_Id); 29645 Error_Msg_Name_1 := Chars (Pack_Id); 29646 Error_Msg_N 29647 ("\& is declared in the private part of package %", Item_Id); 29648 end if; 29649 end if; 29650 end Check_Missing_Part_Of; 29651 29652 --------------------------------------------------- 29653 -- Check_Postcondition_Use_In_Inlined_Subprogram -- 29654 --------------------------------------------------- 29655 29656 procedure Check_Postcondition_Use_In_Inlined_Subprogram 29657 (Prag : Node_Id; 29658 Spec_Id : Entity_Id) 29659 is 29660 begin 29661 if Warn_On_Redundant_Constructs 29662 and then Has_Pragma_Inline_Always (Spec_Id) 29663 and then Assertions_Enabled 29664 then 29665 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag); 29666 29667 if From_Aspect_Specification (Prag) then 29668 Error_Msg_NE 29669 ("aspect % not enforced on inlined subprogram &?r?", 29670 Corresponding_Aspect (Prag), Spec_Id); 29671 else 29672 Error_Msg_NE 29673 ("pragma % not enforced on inlined subprogram &?r?", 29674 Prag, Spec_Id); 29675 end if; 29676 end if; 29677 end Check_Postcondition_Use_In_Inlined_Subprogram; 29678 29679 ------------------------------------- 29680 -- Check_State_And_Constituent_Use -- 29681 ------------------------------------- 29682 29683 procedure Check_State_And_Constituent_Use 29684 (States : Elist_Id; 29685 Constits : Elist_Id; 29686 Context : Node_Id) 29687 is 29688 Constit_Elmt : Elmt_Id; 29689 Constit_Id : Entity_Id; 29690 State_Id : Entity_Id; 29691 29692 begin 29693 -- Nothing to do if there are no states or constituents 29694 29695 if No (States) or else No (Constits) then 29696 return; 29697 end if; 29698 29699 -- Inspect the list of constituents and try to determine whether its 29700 -- encapsulating state is in list States. 29701 29702 Constit_Elmt := First_Elmt (Constits); 29703 while Present (Constit_Elmt) loop 29704 Constit_Id := Node (Constit_Elmt); 29705 29706 -- Determine whether the constituent is part of an encapsulating 29707 -- state that appears in the same context and if this is the case, 29708 -- emit an error (SPARK RM 7.2.6(7)). 29709 29710 State_Id := Find_Encapsulating_State (States, Constit_Id); 29711 29712 if Present (State_Id) then 29713 Error_Msg_Name_1 := Chars (Constit_Id); 29714 SPARK_Msg_NE 29715 ("cannot mention state & and its constituent % in the same " 29716 & "context", Context, State_Id); 29717 exit; 29718 end if; 29719 29720 Next_Elmt (Constit_Elmt); 29721 end loop; 29722 end Check_State_And_Constituent_Use; 29723 29724 --------------------------------------------- 29725 -- Collect_Inherited_Class_Wide_Conditions -- 29726 --------------------------------------------- 29727 29728 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is 29729 Parent_Subp : constant Entity_Id := 29730 Ultimate_Alias (Overridden_Operation (Subp)); 29731 -- The Overridden_Operation may itself be inherited and as such have no 29732 -- explicit contract. 29733 29734 Prags : constant Node_Id := Contract (Parent_Subp); 29735 In_Spec_Expr : Boolean; 29736 Installed : Boolean; 29737 Prag : Node_Id; 29738 New_Prag : Node_Id; 29739 29740 begin 29741 Installed := False; 29742 29743 -- Iterate over the contract of the overridden subprogram to find all 29744 -- inherited class-wide pre- and postconditions. 29745 29746 if Present (Prags) then 29747 Prag := Pre_Post_Conditions (Prags); 29748 29749 while Present (Prag) loop 29750 if Nam_In (Pragma_Name_Unmapped (Prag), 29751 Name_Precondition, Name_Postcondition) 29752 and then Class_Present (Prag) 29753 then 29754 -- The generated pragma must be analyzed in the context of 29755 -- the subprogram, to make its formals visible. In addition, 29756 -- we must inhibit freezing and full analysis because the 29757 -- controlling type of the subprogram is not frozen yet, and 29758 -- may have further primitives. 29759 29760 if not Installed then 29761 Installed := True; 29762 Push_Scope (Subp); 29763 Install_Formals (Subp); 29764 In_Spec_Expr := In_Spec_Expression; 29765 In_Spec_Expression := True; 29766 end if; 29767 29768 New_Prag := 29769 Build_Pragma_Check_Equivalent 29770 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True); 29771 29772 Insert_After (Unit_Declaration_Node (Subp), New_Prag); 29773 Preanalyze (New_Prag); 29774 29775 -- Prevent further analysis in subsequent processing of the 29776 -- current list of declarations 29777 29778 Set_Analyzed (New_Prag); 29779 end if; 29780 29781 Prag := Next_Pragma (Prag); 29782 end loop; 29783 29784 if Installed then 29785 In_Spec_Expression := In_Spec_Expr; 29786 End_Scope; 29787 end if; 29788 end if; 29789 end Collect_Inherited_Class_Wide_Conditions; 29790 29791 --------------------------------------- 29792 -- Collect_Subprogram_Inputs_Outputs -- 29793 --------------------------------------- 29794 29795 procedure Collect_Subprogram_Inputs_Outputs 29796 (Subp_Id : Entity_Id; 29797 Synthesize : Boolean := False; 29798 Subp_Inputs : in out Elist_Id; 29799 Subp_Outputs : in out Elist_Id; 29800 Global_Seen : out Boolean) 29801 is 29802 procedure Collect_Dependency_Clause (Clause : Node_Id); 29803 -- Collect all relevant items from a dependency clause 29804 29805 procedure Collect_Global_List 29806 (List : Node_Id; 29807 Mode : Name_Id := Name_Input); 29808 -- Collect all relevant items from a global list 29809 29810 ------------------------------- 29811 -- Collect_Dependency_Clause -- 29812 ------------------------------- 29813 29814 procedure Collect_Dependency_Clause (Clause : Node_Id) is 29815 procedure Collect_Dependency_Item 29816 (Item : Node_Id; 29817 Is_Input : Boolean); 29818 -- Add an item to the proper subprogram input or output collection 29819 29820 ----------------------------- 29821 -- Collect_Dependency_Item -- 29822 ----------------------------- 29823 29824 procedure Collect_Dependency_Item 29825 (Item : Node_Id; 29826 Is_Input : Boolean) 29827 is 29828 Extra : Node_Id; 29829 29830 begin 29831 -- Nothing to collect when the item is null 29832 29833 if Nkind (Item) = N_Null then 29834 null; 29835 29836 -- Ditto for attribute 'Result 29837 29838 elsif Is_Attribute_Result (Item) then 29839 null; 29840 29841 -- Multiple items appear as an aggregate 29842 29843 elsif Nkind (Item) = N_Aggregate then 29844 Extra := First (Expressions (Item)); 29845 while Present (Extra) loop 29846 Collect_Dependency_Item (Extra, Is_Input); 29847 Next (Extra); 29848 end loop; 29849 29850 -- Otherwise this is a solitary item 29851 29852 else 29853 if Is_Input then 29854 Append_New_Elmt (Item, Subp_Inputs); 29855 else 29856 Append_New_Elmt (Item, Subp_Outputs); 29857 end if; 29858 end if; 29859 end Collect_Dependency_Item; 29860 29861 -- Start of processing for Collect_Dependency_Clause 29862 29863 begin 29864 if Nkind (Clause) = N_Null then 29865 null; 29866 29867 -- A dependency clause appears as component association 29868 29869 elsif Nkind (Clause) = N_Component_Association then 29870 Collect_Dependency_Item 29871 (Item => Expression (Clause), 29872 Is_Input => True); 29873 29874 Collect_Dependency_Item 29875 (Item => First (Choices (Clause)), 29876 Is_Input => False); 29877 29878 -- To accommodate partial decoration of disabled SPARK features, this 29879 -- routine may be called with illegal input. If this is the case, do 29880 -- not raise Program_Error. 29881 29882 else 29883 null; 29884 end if; 29885 end Collect_Dependency_Clause; 29886 29887 ------------------------- 29888 -- Collect_Global_List -- 29889 ------------------------- 29890 29891 procedure Collect_Global_List 29892 (List : Node_Id; 29893 Mode : Name_Id := Name_Input) 29894 is 29895 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id); 29896 -- Add an item to the proper subprogram input or output collection 29897 29898 ------------------------- 29899 -- Collect_Global_Item -- 29900 ------------------------- 29901 29902 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is 29903 begin 29904 if Nam_In (Mode, Name_In_Out, Name_Input) then 29905 Append_New_Elmt (Item, Subp_Inputs); 29906 end if; 29907 29908 if Nam_In (Mode, Name_In_Out, Name_Output) then 29909 Append_New_Elmt (Item, Subp_Outputs); 29910 end if; 29911 end Collect_Global_Item; 29912 29913 -- Local variables 29914 29915 Assoc : Node_Id; 29916 Item : Node_Id; 29917 29918 -- Start of processing for Collect_Global_List 29919 29920 begin 29921 if Nkind (List) = N_Null then 29922 null; 29923 29924 -- Single global item declaration 29925 29926 elsif Nkind_In (List, N_Expanded_Name, 29927 N_Identifier, 29928 N_Selected_Component) 29929 then 29930 Collect_Global_Item (List, Mode); 29931 29932 -- Simple global list or moded global list declaration 29933 29934 elsif Nkind (List) = N_Aggregate then 29935 if Present (Expressions (List)) then 29936 Item := First (Expressions (List)); 29937 while Present (Item) loop 29938 Collect_Global_Item (Item, Mode); 29939 Next (Item); 29940 end loop; 29941 29942 else 29943 Assoc := First (Component_Associations (List)); 29944 while Present (Assoc) loop 29945 Collect_Global_List 29946 (List => Expression (Assoc), 29947 Mode => Chars (First (Choices (Assoc)))); 29948 Next (Assoc); 29949 end loop; 29950 end if; 29951 29952 -- To accommodate partial decoration of disabled SPARK features, this 29953 -- routine may be called with illegal input. If this is the case, do 29954 -- not raise Program_Error. 29955 29956 else 29957 null; 29958 end if; 29959 end Collect_Global_List; 29960 29961 -- Local variables 29962 29963 Clause : Node_Id; 29964 Clauses : Node_Id; 29965 Depends : Node_Id; 29966 Formal : Entity_Id; 29967 Global : Node_Id; 29968 Spec_Id : Entity_Id := Empty; 29969 Subp_Decl : Node_Id; 29970 Typ : Entity_Id; 29971 29972 -- Start of processing for Collect_Subprogram_Inputs_Outputs 29973 29974 begin 29975 Global_Seen := False; 29976 29977 -- Process all formal parameters of entries, [generic] subprograms, and 29978 -- their bodies. 29979 29980 if Ekind_In (Subp_Id, E_Entry, 29981 E_Entry_Family, 29982 E_Function, 29983 E_Generic_Function, 29984 E_Generic_Procedure, 29985 E_Procedure, 29986 E_Subprogram_Body) 29987 then 29988 Subp_Decl := Unit_Declaration_Node (Subp_Id); 29989 Spec_Id := Unique_Defining_Entity (Subp_Decl); 29990 29991 -- Process all formal parameters 29992 29993 Formal := First_Entity (Spec_Id); 29994 while Present (Formal) loop 29995 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then 29996 Append_New_Elmt (Formal, Subp_Inputs); 29997 end if; 29998 29999 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then 30000 Append_New_Elmt (Formal, Subp_Outputs); 30001 30002 -- Out parameters can act as inputs when the related type is 30003 -- tagged, unconstrained array, unconstrained record, or record 30004 -- with unconstrained components. 30005 30006 if Ekind (Formal) = E_Out_Parameter 30007 and then Is_Unconstrained_Or_Tagged_Item (Formal) 30008 then 30009 Append_New_Elmt (Formal, Subp_Inputs); 30010 end if; 30011 end if; 30012 30013 Next_Entity (Formal); 30014 end loop; 30015 30016 -- Otherwise the input denotes a task type, a task body, or the 30017 -- anonymous object created for a single task type. 30018 30019 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body) 30020 or else Is_Single_Task_Object (Subp_Id) 30021 then 30022 Subp_Decl := Declaration_Node (Subp_Id); 30023 Spec_Id := Unique_Defining_Entity (Subp_Decl); 30024 end if; 30025 30026 -- When processing an entry, subprogram or task body, look for pragmas 30027 -- Refined_Depends and Refined_Global as they specify the inputs and 30028 -- outputs. 30029 30030 if Is_Entry_Body (Subp_Id) 30031 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body) 30032 then 30033 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends); 30034 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); 30035 30036 -- Subprogram declaration or stand-alone body case, look for pragmas 30037 -- Depends and Global 30038 30039 else 30040 Depends := Get_Pragma (Spec_Id, Pragma_Depends); 30041 Global := Get_Pragma (Spec_Id, Pragma_Global); 30042 end if; 30043 30044 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends 30045 -- because it provides finer granularity of inputs and outputs. 30046 30047 if Present (Global) then 30048 Global_Seen := True; 30049 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id))); 30050 30051 -- When the related subprogram lacks pragma [Refined_]Global, fall back 30052 -- to [Refined_]Depends if the caller requests this behavior. Synthesize 30053 -- the inputs and outputs from [Refined_]Depends. 30054 30055 elsif Synthesize and then Present (Depends) then 30056 Clauses := Expression (Get_Argument (Depends, Spec_Id)); 30057 30058 -- Multiple dependency clauses appear as an aggregate 30059 30060 if Nkind (Clauses) = N_Aggregate then 30061 Clause := First (Component_Associations (Clauses)); 30062 while Present (Clause) loop 30063 Collect_Dependency_Clause (Clause); 30064 Next (Clause); 30065 end loop; 30066 30067 -- Otherwise this is a single dependency clause 30068 30069 else 30070 Collect_Dependency_Clause (Clauses); 30071 end if; 30072 end if; 30073 30074 -- The current instance of a protected type acts as a formal parameter 30075 -- of mode IN for functions and IN OUT for entries and procedures 30076 -- (SPARK RM 6.1.4). 30077 30078 if Ekind (Scope (Spec_Id)) = E_Protected_Type then 30079 Typ := Scope (Spec_Id); 30080 30081 -- Use the anonymous object when the type is single protected 30082 30083 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then 30084 Typ := Anonymous_Object (Typ); 30085 end if; 30086 30087 Append_New_Elmt (Typ, Subp_Inputs); 30088 30089 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then 30090 Append_New_Elmt (Typ, Subp_Outputs); 30091 end if; 30092 30093 -- The current instance of a task type acts as a formal parameter of 30094 -- mode IN OUT (SPARK RM 6.1.4). 30095 30096 elsif Ekind (Spec_Id) = E_Task_Type then 30097 Typ := Spec_Id; 30098 30099 -- Use the anonymous object when the type is single task 30100 30101 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then 30102 Typ := Anonymous_Object (Typ); 30103 end if; 30104 30105 Append_New_Elmt (Typ, Subp_Inputs); 30106 Append_New_Elmt (Typ, Subp_Outputs); 30107 30108 elsif Is_Single_Task_Object (Spec_Id) then 30109 Append_New_Elmt (Spec_Id, Subp_Inputs); 30110 Append_New_Elmt (Spec_Id, Subp_Outputs); 30111 end if; 30112 end Collect_Subprogram_Inputs_Outputs; 30113 30114 --------------------------- 30115 -- Contract_Freeze_Error -- 30116 --------------------------- 30117 30118 procedure Contract_Freeze_Error 30119 (Contract_Id : Entity_Id; 30120 Freeze_Id : Entity_Id) 30121 is 30122 begin 30123 Error_Msg_Name_1 := Chars (Contract_Id); 30124 Error_Msg_Sloc := Sloc (Freeze_Id); 30125 30126 SPARK_Msg_NE 30127 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id); 30128 SPARK_Msg_N 30129 ("\all contractual items must be declared before body #", Contract_Id); 30130 end Contract_Freeze_Error; 30131 30132 --------------------------------- 30133 -- Delay_Config_Pragma_Analyze -- 30134 --------------------------------- 30135 30136 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is 30137 begin 30138 return Nam_In (Pragma_Name_Unmapped (N), 30139 Name_Interrupt_State, Name_Priority_Specific_Dispatching); 30140 end Delay_Config_Pragma_Analyze; 30141 30142 ----------------------- 30143 -- Duplication_Error -- 30144 ----------------------- 30145 30146 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is 30147 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag); 30148 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev); 30149 30150 begin 30151 Error_Msg_Sloc := Sloc (Prev); 30152 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag); 30153 30154 -- Emit a precise message to distinguish between source pragmas and 30155 -- pragmas generated from aspects. The ordering of the two pragmas is 30156 -- the following: 30157 30158 -- Prev -- ok 30159 -- Prag -- duplicate 30160 30161 -- No error is emitted when both pragmas come from aspects because this 30162 -- is already detected by the general aspect analysis mechanism. 30163 30164 if Prag_From_Asp and Prev_From_Asp then 30165 null; 30166 elsif Prag_From_Asp then 30167 Error_Msg_N ("aspect % duplicates pragma declared #", Prag); 30168 elsif Prev_From_Asp then 30169 Error_Msg_N ("pragma % duplicates aspect declared #", Prag); 30170 else 30171 Error_Msg_N ("pragma % duplicates pragma declared #", Prag); 30172 end if; 30173 end Duplication_Error; 30174 30175 ------------------------------ 30176 -- Find_Encapsulating_State -- 30177 ------------------------------ 30178 30179 function Find_Encapsulating_State 30180 (States : Elist_Id; 30181 Constit_Id : Entity_Id) return Entity_Id 30182 is 30183 State_Id : Entity_Id; 30184 30185 begin 30186 -- Since a constituent may be part of a larger constituent set, climb 30187 -- the encapsulating state chain looking for a state that appears in 30188 -- States. 30189 30190 State_Id := Encapsulating_State (Constit_Id); 30191 while Present (State_Id) loop 30192 if Contains (States, State_Id) then 30193 return State_Id; 30194 end if; 30195 30196 State_Id := Encapsulating_State (State_Id); 30197 end loop; 30198 30199 return Empty; 30200 end Find_Encapsulating_State; 30201 30202 -------------------------- 30203 -- Find_Related_Context -- 30204 -------------------------- 30205 30206 function Find_Related_Context 30207 (Prag : Node_Id; 30208 Do_Checks : Boolean := False) return Node_Id 30209 is 30210 Stmt : Node_Id; 30211 30212 begin 30213 Stmt := Prev (Prag); 30214 while Present (Stmt) loop 30215 30216 -- Skip prior pragmas, but check for duplicates 30217 30218 if Nkind (Stmt) = N_Pragma then 30219 if Do_Checks 30220 and then Pragma_Name (Stmt) = Pragma_Name (Prag) 30221 then 30222 Duplication_Error 30223 (Prag => Prag, 30224 Prev => Stmt); 30225 end if; 30226 30227 -- Skip internally generated code 30228 30229 elsif not Comes_From_Source (Stmt) then 30230 30231 -- The anonymous object created for a single concurrent type is a 30232 -- suitable context. 30233 30234 if Nkind (Stmt) = N_Object_Declaration 30235 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) 30236 then 30237 return Stmt; 30238 end if; 30239 30240 -- Return the current source construct 30241 30242 else 30243 return Stmt; 30244 end if; 30245 30246 Prev (Stmt); 30247 end loop; 30248 30249 return Empty; 30250 end Find_Related_Context; 30251 30252 -------------------------------------- 30253 -- Find_Related_Declaration_Or_Body -- 30254 -------------------------------------- 30255 30256 function Find_Related_Declaration_Or_Body 30257 (Prag : Node_Id; 30258 Do_Checks : Boolean := False) return Node_Id 30259 is 30260 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag); 30261 30262 procedure Expression_Function_Error; 30263 -- Emit an error concerning pragma Prag that illegaly applies to an 30264 -- expression function. 30265 30266 ------------------------------- 30267 -- Expression_Function_Error -- 30268 ------------------------------- 30269 30270 procedure Expression_Function_Error is 30271 begin 30272 Error_Msg_Name_1 := Prag_Nam; 30273 30274 -- Emit a precise message to distinguish between source pragmas and 30275 -- pragmas generated from aspects. 30276 30277 if From_Aspect_Specification (Prag) then 30278 Error_Msg_N 30279 ("aspect % cannot apply to a stand alone expression function", 30280 Prag); 30281 else 30282 Error_Msg_N 30283 ("pragma % cannot apply to a stand alone expression function", 30284 Prag); 30285 end if; 30286 end Expression_Function_Error; 30287 30288 -- Local variables 30289 30290 Context : constant Node_Id := Parent (Prag); 30291 Stmt : Node_Id; 30292 30293 Look_For_Body : constant Boolean := 30294 Nam_In (Prag_Nam, Name_Refined_Depends, 30295 Name_Refined_Global, 30296 Name_Refined_Post, 30297 Name_Refined_State); 30298 -- Refinement pragmas must be associated with a subprogram body [stub] 30299 30300 -- Start of processing for Find_Related_Declaration_Or_Body 30301 30302 begin 30303 Stmt := Prev (Prag); 30304 while Present (Stmt) loop 30305 30306 -- Skip prior pragmas, but check for duplicates. Pragmas produced 30307 -- by splitting a complex pre/postcondition are not considered to 30308 -- be duplicates. 30309 30310 if Nkind (Stmt) = N_Pragma then 30311 if Do_Checks 30312 and then not Split_PPC (Stmt) 30313 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam 30314 then 30315 Duplication_Error 30316 (Prag => Prag, 30317 Prev => Stmt); 30318 end if; 30319 30320 -- Emit an error when a refinement pragma appears on an expression 30321 -- function without a completion. 30322 30323 elsif Do_Checks 30324 and then Look_For_Body 30325 and then Nkind (Stmt) = N_Subprogram_Declaration 30326 and then Nkind (Original_Node (Stmt)) = N_Expression_Function 30327 and then not Has_Completion (Defining_Entity (Stmt)) 30328 then 30329 Expression_Function_Error; 30330 return Empty; 30331 30332 -- The refinement pragma applies to a subprogram body stub 30333 30334 elsif Look_For_Body 30335 and then Nkind (Stmt) = N_Subprogram_Body_Stub 30336 then 30337 return Stmt; 30338 30339 -- Skip internally generated code 30340 30341 elsif not Comes_From_Source (Stmt) then 30342 30343 -- The anonymous object created for a single concurrent type is a 30344 -- suitable context. 30345 30346 if Nkind (Stmt) = N_Object_Declaration 30347 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) 30348 then 30349 return Stmt; 30350 30351 elsif Nkind (Stmt) = N_Subprogram_Declaration then 30352 30353 -- The subprogram declaration is an internally generated spec 30354 -- for an expression function. 30355 30356 if Nkind (Original_Node (Stmt)) = N_Expression_Function then 30357 return Stmt; 30358 30359 -- The subprogram declaration is an internally generated spec 30360 -- for a stand-alone subrogram body declared inside a protected 30361 -- body. 30362 30363 elsif Present (Corresponding_Body (Stmt)) 30364 and then Comes_From_Source (Corresponding_Body (Stmt)) 30365 and then Is_Protected_Type (Current_Scope) 30366 then 30367 return Stmt; 30368 30369 -- The subprogram is actually an instance housed within an 30370 -- anonymous wrapper package. 30371 30372 elsif Present (Generic_Parent (Specification (Stmt))) then 30373 return Stmt; 30374 end if; 30375 end if; 30376 30377 -- Return the current construct which is either a subprogram body, 30378 -- a subprogram declaration or is illegal. 30379 30380 else 30381 return Stmt; 30382 end if; 30383 30384 Prev (Stmt); 30385 end loop; 30386 30387 -- If we fall through, then the pragma was either the first declaration 30388 -- or it was preceded by other pragmas and no source constructs. 30389 30390 -- The pragma is associated with a library-level subprogram 30391 30392 if Nkind (Context) = N_Compilation_Unit_Aux then 30393 return Unit (Parent (Context)); 30394 30395 -- The pragma appears inside the declarations of an entry body 30396 30397 elsif Nkind (Context) = N_Entry_Body then 30398 return Context; 30399 30400 -- The pragma appears inside the statements of a subprogram body. This 30401 -- placement is the result of subprogram contract expansion. 30402 30403 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 30404 return Parent (Context); 30405 30406 -- The pragma appears inside the declarative part of a package body 30407 30408 elsif Nkind (Context) = N_Package_Body then 30409 return Context; 30410 30411 -- The pragma appears inside the declarative part of a subprogram body 30412 30413 elsif Nkind (Context) = N_Subprogram_Body then 30414 return Context; 30415 30416 -- The pragma appears inside the declarative part of a task body 30417 30418 elsif Nkind (Context) = N_Task_Body then 30419 return Context; 30420 30421 -- The pragma appears inside the visible part of a package specification 30422 30423 elsif Nkind (Context) = N_Package_Specification then 30424 return Parent (Context); 30425 30426 -- The pragma is a byproduct of aspect expansion, return the related 30427 -- context of the original aspect. This case has a lower priority as 30428 -- the above circuitry pinpoints precisely the related context. 30429 30430 elsif Present (Corresponding_Aspect (Prag)) then 30431 return Parent (Corresponding_Aspect (Prag)); 30432 30433 -- No candidate subprogram [body] found 30434 30435 else 30436 return Empty; 30437 end if; 30438 end Find_Related_Declaration_Or_Body; 30439 30440 ---------------------------------- 30441 -- Find_Related_Package_Or_Body -- 30442 ---------------------------------- 30443 30444 function Find_Related_Package_Or_Body 30445 (Prag : Node_Id; 30446 Do_Checks : Boolean := False) return Node_Id 30447 is 30448 Context : constant Node_Id := Parent (Prag); 30449 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 30450 Stmt : Node_Id; 30451 30452 begin 30453 Stmt := Prev (Prag); 30454 while Present (Stmt) loop 30455 30456 -- Skip prior pragmas, but check for duplicates 30457 30458 if Nkind (Stmt) = N_Pragma then 30459 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then 30460 Duplication_Error 30461 (Prag => Prag, 30462 Prev => Stmt); 30463 end if; 30464 30465 -- Skip internally generated code 30466 30467 elsif not Comes_From_Source (Stmt) then 30468 if Nkind (Stmt) = N_Subprogram_Declaration then 30469 30470 -- The subprogram declaration is an internally generated spec 30471 -- for an expression function. 30472 30473 if Nkind (Original_Node (Stmt)) = N_Expression_Function then 30474 return Stmt; 30475 30476 -- The subprogram is actually an instance housed within an 30477 -- anonymous wrapper package. 30478 30479 elsif Present (Generic_Parent (Specification (Stmt))) then 30480 return Stmt; 30481 end if; 30482 end if; 30483 30484 -- Return the current source construct which is illegal 30485 30486 else 30487 return Stmt; 30488 end if; 30489 30490 Prev (Stmt); 30491 end loop; 30492 30493 -- If we fall through, then the pragma was either the first declaration 30494 -- or it was preceded by other pragmas and no source constructs. 30495 30496 -- The pragma is associated with a package. The immediate context in 30497 -- this case is the specification of the package. 30498 30499 if Nkind (Context) = N_Package_Specification then 30500 return Parent (Context); 30501 30502 -- The pragma appears in the declarations of a package body 30503 30504 elsif Nkind (Context) = N_Package_Body then 30505 return Context; 30506 30507 -- The pragma appears in the statements of a package body 30508 30509 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements 30510 and then Nkind (Parent (Context)) = N_Package_Body 30511 then 30512 return Parent (Context); 30513 30514 -- The pragma is a byproduct of aspect expansion, return the related 30515 -- context of the original aspect. This case has a lower priority as 30516 -- the above circuitry pinpoints precisely the related context. 30517 30518 elsif Present (Corresponding_Aspect (Prag)) then 30519 return Parent (Corresponding_Aspect (Prag)); 30520 30521 -- No candidate package [body] found 30522 30523 else 30524 return Empty; 30525 end if; 30526 end Find_Related_Package_Or_Body; 30527 30528 ------------------ 30529 -- Get_Argument -- 30530 ------------------ 30531 30532 function Get_Argument 30533 (Prag : Node_Id; 30534 Context_Id : Entity_Id := Empty) return Node_Id 30535 is 30536 Args : constant List_Id := Pragma_Argument_Associations (Prag); 30537 30538 begin 30539 -- Use the expression of the original aspect when compiling for ASIS or 30540 -- when analyzing the template of a generic unit. In both cases the 30541 -- aspect's tree must be decorated to allow for ASIS queries or to save 30542 -- the global references in the generic context. 30543 30544 if From_Aspect_Specification (Prag) 30545 and then (ASIS_Mode or else (Present (Context_Id) 30546 and then Is_Generic_Unit (Context_Id))) 30547 then 30548 return Corresponding_Aspect (Prag); 30549 30550 -- Otherwise use the expression of the pragma 30551 30552 elsif Present (Args) then 30553 return First (Args); 30554 30555 else 30556 return Empty; 30557 end if; 30558 end Get_Argument; 30559 30560 ------------------------- 30561 -- Get_Base_Subprogram -- 30562 ------------------------- 30563 30564 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is 30565 begin 30566 -- Follow subprogram renaming chain 30567 30568 if Is_Subprogram (Def_Id) 30569 and then Nkind (Parent (Declaration_Node (Def_Id))) = 30570 N_Subprogram_Renaming_Declaration 30571 and then Present (Alias (Def_Id)) 30572 then 30573 return Alias (Def_Id); 30574 else 30575 return Def_Id; 30576 end if; 30577 end Get_Base_Subprogram; 30578 30579 ----------------------- 30580 -- Get_SPARK_Mode_Type -- 30581 ----------------------- 30582 30583 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is 30584 begin 30585 if N = Name_On then 30586 return On; 30587 elsif N = Name_Off then 30588 return Off; 30589 30590 -- Any other argument is illegal. Assume that no SPARK mode applies to 30591 -- avoid potential cascaded errors. 30592 30593 else 30594 return None; 30595 end if; 30596 end Get_SPARK_Mode_Type; 30597 30598 ------------------------------------ 30599 -- Get_SPARK_Mode_From_Annotation -- 30600 ------------------------------------ 30601 30602 function Get_SPARK_Mode_From_Annotation 30603 (N : Node_Id) return SPARK_Mode_Type 30604 is 30605 Mode : Node_Id; 30606 30607 begin 30608 if Nkind (N) = N_Aspect_Specification then 30609 Mode := Expression (N); 30610 30611 else pragma Assert (Nkind (N) = N_Pragma); 30612 Mode := First (Pragma_Argument_Associations (N)); 30613 30614 if Present (Mode) then 30615 Mode := Get_Pragma_Arg (Mode); 30616 end if; 30617 end if; 30618 30619 -- Aspect or pragma SPARK_Mode specifies an explicit mode 30620 30621 if Present (Mode) then 30622 if Nkind (Mode) = N_Identifier then 30623 return Get_SPARK_Mode_Type (Chars (Mode)); 30624 30625 -- In case of a malformed aspect or pragma, return the default None 30626 30627 else 30628 return None; 30629 end if; 30630 30631 -- Otherwise the lack of an expression defaults SPARK_Mode to On 30632 30633 else 30634 return On; 30635 end if; 30636 end Get_SPARK_Mode_From_Annotation; 30637 30638 --------------------------- 30639 -- Has_Extra_Parentheses -- 30640 --------------------------- 30641 30642 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is 30643 Expr : Node_Id; 30644 30645 begin 30646 -- The aggregate should not have an expression list because a clause 30647 -- is always interpreted as a component association. The only way an 30648 -- expression list can sneak in is by adding extra parentheses around 30649 -- the individual clauses: 30650 30651 -- Depends (Output => Input) -- proper form 30652 -- Depends ((Output => Input)) -- extra parentheses 30653 30654 -- Since the extra parentheses are not allowed by the syntax of the 30655 -- pragma, flag them now to avoid emitting misleading errors down the 30656 -- line. 30657 30658 if Nkind (Clause) = N_Aggregate 30659 and then Present (Expressions (Clause)) 30660 then 30661 Expr := First (Expressions (Clause)); 30662 while Present (Expr) loop 30663 30664 -- A dependency clause surrounded by extra parentheses appears 30665 -- as an aggregate of component associations with an optional 30666 -- Paren_Count set. 30667 30668 if Nkind (Expr) = N_Aggregate 30669 and then Present (Component_Associations (Expr)) 30670 then 30671 SPARK_Msg_N 30672 ("dependency clause contains extra parentheses", Expr); 30673 30674 -- Otherwise the expression is a malformed construct 30675 30676 else 30677 SPARK_Msg_N ("malformed dependency clause", Expr); 30678 end if; 30679 30680 Next (Expr); 30681 end loop; 30682 30683 return True; 30684 end if; 30685 30686 return False; 30687 end Has_Extra_Parentheses; 30688 30689 ---------------- 30690 -- Initialize -- 30691 ---------------- 30692 30693 procedure Initialize is 30694 begin 30695 Externals.Init; 30696 end Initialize; 30697 30698 -------- 30699 -- ip -- 30700 -------- 30701 30702 procedure ip is 30703 begin 30704 Dummy := Dummy + 1; 30705 end ip; 30706 30707 ----------------------------- 30708 -- Is_Config_Static_String -- 30709 ----------------------------- 30710 30711 function Is_Config_Static_String (Arg : Node_Id) return Boolean is 30712 30713 function Add_Config_Static_String (Arg : Node_Id) return Boolean; 30714 -- This is an internal recursive function that is just like the outer 30715 -- function except that it adds the string to the name buffer rather 30716 -- than placing the string in the name buffer. 30717 30718 ------------------------------ 30719 -- Add_Config_Static_String -- 30720 ------------------------------ 30721 30722 function Add_Config_Static_String (Arg : Node_Id) return Boolean is 30723 N : Node_Id; 30724 C : Char_Code; 30725 30726 begin 30727 N := Arg; 30728 30729 if Nkind (N) = N_Op_Concat then 30730 if Add_Config_Static_String (Left_Opnd (N)) then 30731 N := Right_Opnd (N); 30732 else 30733 return False; 30734 end if; 30735 end if; 30736 30737 if Nkind (N) /= N_String_Literal then 30738 Error_Msg_N ("string literal expected for pragma argument", N); 30739 return False; 30740 30741 else 30742 for J in 1 .. String_Length (Strval (N)) loop 30743 C := Get_String_Char (Strval (N), J); 30744 30745 if not In_Character_Range (C) then 30746 Error_Msg 30747 ("string literal contains invalid wide character", 30748 Sloc (N) + 1 + Source_Ptr (J)); 30749 return False; 30750 end if; 30751 30752 Add_Char_To_Name_Buffer (Get_Character (C)); 30753 end loop; 30754 end if; 30755 30756 return True; 30757 end Add_Config_Static_String; 30758 30759 -- Start of processing for Is_Config_Static_String 30760 30761 begin 30762 Name_Len := 0; 30763 30764 return Add_Config_Static_String (Arg); 30765 end Is_Config_Static_String; 30766 30767 ------------------------------- 30768 -- Is_Elaboration_SPARK_Mode -- 30769 ------------------------------- 30770 30771 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is 30772 begin 30773 pragma Assert 30774 (Nkind (N) = N_Pragma 30775 and then Pragma_Name (N) = Name_SPARK_Mode 30776 and then Is_List_Member (N)); 30777 30778 -- Pragma SPARK_Mode affects the elaboration of a package body when it 30779 -- appears in the statement part of the body. 30780 30781 return 30782 Present (Parent (N)) 30783 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements 30784 and then List_Containing (N) = Statements (Parent (N)) 30785 and then Present (Parent (Parent (N))) 30786 and then Nkind (Parent (Parent (N))) = N_Package_Body; 30787 end Is_Elaboration_SPARK_Mode; 30788 30789 ----------------------- 30790 -- Is_Enabled_Pragma -- 30791 ----------------------- 30792 30793 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is 30794 Arg : Node_Id; 30795 30796 begin 30797 if Present (Prag) then 30798 Arg := First (Pragma_Argument_Associations (Prag)); 30799 30800 if Present (Arg) then 30801 return Is_True (Expr_Value (Get_Pragma_Arg (Arg))); 30802 30803 -- The lack of a Boolean argument automatically enables the pragma 30804 30805 else 30806 return True; 30807 end if; 30808 30809 -- The pragma is missing, therefore it is not enabled 30810 30811 else 30812 return False; 30813 end if; 30814 end Is_Enabled_Pragma; 30815 30816 ----------------------------------------- 30817 -- Is_Non_Significant_Pragma_Reference -- 30818 ----------------------------------------- 30819 30820 -- This function makes use of the following static table which indicates 30821 -- whether appearance of some name in a given pragma is to be considered 30822 -- as a reference for the purposes of warnings about unreferenced objects. 30823 30824 -- -1 indicates that appearence in any argument is significant 30825 -- 0 indicates that appearance in any argument is not significant 30826 -- +n indicates that appearance as argument n is significant, but all 30827 -- other arguments are not significant 30828 -- 9n arguments from n on are significant, before n insignificant 30829 30830 Sig_Flags : constant array (Pragma_Id) of Int := 30831 (Pragma_Abort_Defer => -1, 30832 Pragma_Abstract_State => -1, 30833 Pragma_Acc_Data => 0, 30834 Pragma_Acc_Kernels => 0, 30835 Pragma_Acc_Loop => 0, 30836 Pragma_Acc_Parallel => 0, 30837 Pragma_Ada_83 => -1, 30838 Pragma_Ada_95 => -1, 30839 Pragma_Ada_05 => -1, 30840 Pragma_Ada_2005 => -1, 30841 Pragma_Ada_12 => -1, 30842 Pragma_Ada_2012 => -1, 30843 Pragma_Ada_2020 => -1, 30844 Pragma_All_Calls_Remote => -1, 30845 Pragma_Allow_Integer_Address => -1, 30846 Pragma_Annotate => 93, 30847 Pragma_Assert => -1, 30848 Pragma_Assert_And_Cut => -1, 30849 Pragma_Assertion_Policy => 0, 30850 Pragma_Assume => -1, 30851 Pragma_Assume_No_Invalid_Values => 0, 30852 Pragma_Async_Readers => 0, 30853 Pragma_Async_Writers => 0, 30854 Pragma_Asynchronous => 0, 30855 Pragma_Atomic => 0, 30856 Pragma_Atomic_Components => 0, 30857 Pragma_Attach_Handler => -1, 30858 Pragma_Attribute_Definition => 92, 30859 Pragma_Check => -1, 30860 Pragma_Check_Float_Overflow => 0, 30861 Pragma_Check_Name => 0, 30862 Pragma_Check_Policy => 0, 30863 Pragma_CPP_Class => 0, 30864 Pragma_CPP_Constructor => 0, 30865 Pragma_CPP_Virtual => 0, 30866 Pragma_CPP_Vtable => 0, 30867 Pragma_CPU => -1, 30868 Pragma_C_Pass_By_Copy => 0, 30869 Pragma_Comment => -1, 30870 Pragma_Common_Object => 0, 30871 Pragma_Compile_Time_Error => -1, 30872 Pragma_Compile_Time_Warning => -1, 30873 Pragma_Compiler_Unit => -1, 30874 Pragma_Compiler_Unit_Warning => -1, 30875 Pragma_Complete_Representation => 0, 30876 Pragma_Complex_Representation => 0, 30877 Pragma_Component_Alignment => 0, 30878 Pragma_Constant_After_Elaboration => 0, 30879 Pragma_Contract_Cases => -1, 30880 Pragma_Controlled => 0, 30881 Pragma_Convention => 0, 30882 Pragma_Convention_Identifier => 0, 30883 Pragma_Deadline_Floor => -1, 30884 Pragma_Debug => -1, 30885 Pragma_Debug_Policy => 0, 30886 Pragma_Detect_Blocking => 0, 30887 Pragma_Default_Initial_Condition => -1, 30888 Pragma_Default_Scalar_Storage_Order => 0, 30889 Pragma_Default_Storage_Pool => 0, 30890 Pragma_Depends => -1, 30891 Pragma_Disable_Atomic_Synchronization => 0, 30892 Pragma_Discard_Names => 0, 30893 Pragma_Dispatching_Domain => -1, 30894 Pragma_Effective_Reads => 0, 30895 Pragma_Effective_Writes => 0, 30896 Pragma_Elaborate => 0, 30897 Pragma_Elaborate_All => 0, 30898 Pragma_Elaborate_Body => 0, 30899 Pragma_Elaboration_Checks => 0, 30900 Pragma_Eliminate => 0, 30901 Pragma_Enable_Atomic_Synchronization => 0, 30902 Pragma_Export => -1, 30903 Pragma_Export_Function => -1, 30904 Pragma_Export_Object => -1, 30905 Pragma_Export_Procedure => -1, 30906 Pragma_Export_Value => -1, 30907 Pragma_Export_Valued_Procedure => -1, 30908 Pragma_Extend_System => -1, 30909 Pragma_Extensions_Allowed => 0, 30910 Pragma_Extensions_Visible => 0, 30911 Pragma_External => -1, 30912 Pragma_Favor_Top_Level => 0, 30913 Pragma_External_Name_Casing => 0, 30914 Pragma_Fast_Math => 0, 30915 Pragma_Finalize_Storage_Only => 0, 30916 Pragma_Ghost => 0, 30917 Pragma_Global => -1, 30918 Pragma_Ident => -1, 30919 Pragma_Ignore_Pragma => 0, 30920 Pragma_Implementation_Defined => -1, 30921 Pragma_Implemented => -1, 30922 Pragma_Implicit_Packing => 0, 30923 Pragma_Import => 93, 30924 Pragma_Import_Function => 0, 30925 Pragma_Import_Object => 0, 30926 Pragma_Import_Procedure => 0, 30927 Pragma_Import_Valued_Procedure => 0, 30928 Pragma_Independent => 0, 30929 Pragma_Independent_Components => 0, 30930 Pragma_Initial_Condition => -1, 30931 Pragma_Initialize_Scalars => 0, 30932 Pragma_Initializes => -1, 30933 Pragma_Inline => 0, 30934 Pragma_Inline_Always => 0, 30935 Pragma_Inline_Generic => 0, 30936 Pragma_Inspection_Point => -1, 30937 Pragma_Interface => 92, 30938 Pragma_Interface_Name => 0, 30939 Pragma_Interrupt_Handler => -1, 30940 Pragma_Interrupt_Priority => -1, 30941 Pragma_Interrupt_State => -1, 30942 Pragma_Invariant => -1, 30943 Pragma_Keep_Names => 0, 30944 Pragma_License => 0, 30945 Pragma_Link_With => -1, 30946 Pragma_Linker_Alias => -1, 30947 Pragma_Linker_Constructor => -1, 30948 Pragma_Linker_Destructor => -1, 30949 Pragma_Linker_Options => -1, 30950 Pragma_Linker_Section => -1, 30951 Pragma_List => 0, 30952 Pragma_Lock_Free => 0, 30953 Pragma_Locking_Policy => 0, 30954 Pragma_Loop_Invariant => -1, 30955 Pragma_Loop_Optimize => 0, 30956 Pragma_Loop_Variant => -1, 30957 Pragma_Machine_Attribute => -1, 30958 Pragma_Main => -1, 30959 Pragma_Main_Storage => -1, 30960 Pragma_Max_Entry_Queue_Depth => 0, 30961 Pragma_Max_Queue_Length => 0, 30962 Pragma_Memory_Size => 0, 30963 Pragma_No_Return => 0, 30964 Pragma_No_Body => 0, 30965 Pragma_No_Component_Reordering => -1, 30966 Pragma_No_Elaboration_Code_All => 0, 30967 Pragma_No_Heap_Finalization => 0, 30968 Pragma_No_Inline => 0, 30969 Pragma_No_Run_Time => -1, 30970 Pragma_No_Strict_Aliasing => -1, 30971 Pragma_No_Tagged_Streams => 0, 30972 Pragma_Normalize_Scalars => 0, 30973 Pragma_Obsolescent => 0, 30974 Pragma_Optimize => 0, 30975 Pragma_Optimize_Alignment => 0, 30976 Pragma_Overflow_Mode => 0, 30977 Pragma_Overriding_Renamings => 0, 30978 Pragma_Ordered => 0, 30979 Pragma_Pack => 0, 30980 Pragma_Page => 0, 30981 Pragma_Part_Of => 0, 30982 Pragma_Partition_Elaboration_Policy => 0, 30983 Pragma_Passive => 0, 30984 Pragma_Persistent_BSS => 0, 30985 Pragma_Polling => 0, 30986 Pragma_Prefix_Exception_Messages => 0, 30987 Pragma_Post => -1, 30988 Pragma_Postcondition => -1, 30989 Pragma_Post_Class => -1, 30990 Pragma_Pre => -1, 30991 Pragma_Precondition => -1, 30992 Pragma_Predicate => -1, 30993 Pragma_Predicate_Failure => -1, 30994 Pragma_Preelaborable_Initialization => -1, 30995 Pragma_Preelaborate => 0, 30996 Pragma_Pre_Class => -1, 30997 Pragma_Priority => -1, 30998 Pragma_Priority_Specific_Dispatching => 0, 30999 Pragma_Profile => 0, 31000 Pragma_Profile_Warnings => 0, 31001 Pragma_Propagate_Exceptions => 0, 31002 Pragma_Provide_Shift_Operators => 0, 31003 Pragma_Psect_Object => 0, 31004 Pragma_Pure => 0, 31005 Pragma_Pure_Function => 0, 31006 Pragma_Queuing_Policy => 0, 31007 Pragma_Rational => 0, 31008 Pragma_Ravenscar => 0, 31009 Pragma_Refined_Depends => -1, 31010 Pragma_Refined_Global => -1, 31011 Pragma_Refined_Post => -1, 31012 Pragma_Refined_State => -1, 31013 Pragma_Relative_Deadline => 0, 31014 Pragma_Rename_Pragma => 0, 31015 Pragma_Remote_Access_Type => -1, 31016 Pragma_Remote_Call_Interface => -1, 31017 Pragma_Remote_Types => -1, 31018 Pragma_Restricted_Run_Time => 0, 31019 Pragma_Restriction_Warnings => 0, 31020 Pragma_Restrictions => 0, 31021 Pragma_Reviewable => -1, 31022 Pragma_Secondary_Stack_Size => -1, 31023 Pragma_Short_Circuit_And_Or => 0, 31024 Pragma_Share_Generic => 0, 31025 Pragma_Shared => 0, 31026 Pragma_Shared_Passive => 0, 31027 Pragma_Short_Descriptors => 0, 31028 Pragma_Simple_Storage_Pool_Type => 0, 31029 Pragma_Source_File_Name => 0, 31030 Pragma_Source_File_Name_Project => 0, 31031 Pragma_Source_Reference => 0, 31032 Pragma_SPARK_Mode => 0, 31033 Pragma_Storage_Size => -1, 31034 Pragma_Storage_Unit => 0, 31035 Pragma_Static_Elaboration_Desired => 0, 31036 Pragma_Stream_Convert => 0, 31037 Pragma_Style_Checks => 0, 31038 Pragma_Subtitle => 0, 31039 Pragma_Suppress => 0, 31040 Pragma_Suppress_Exception_Locations => 0, 31041 Pragma_Suppress_All => 0, 31042 Pragma_Suppress_Debug_Info => 0, 31043 Pragma_Suppress_Initialization => 0, 31044 Pragma_System_Name => 0, 31045 Pragma_Task_Dispatching_Policy => 0, 31046 Pragma_Task_Info => -1, 31047 Pragma_Task_Name => -1, 31048 Pragma_Task_Storage => -1, 31049 Pragma_Test_Case => -1, 31050 Pragma_Thread_Local_Storage => -1, 31051 Pragma_Time_Slice => -1, 31052 Pragma_Title => 0, 31053 Pragma_Type_Invariant => -1, 31054 Pragma_Type_Invariant_Class => -1, 31055 Pragma_Unchecked_Union => 0, 31056 Pragma_Unevaluated_Use_Of_Old => 0, 31057 Pragma_Unimplemented_Unit => 0, 31058 Pragma_Universal_Aliasing => 0, 31059 Pragma_Universal_Data => 0, 31060 Pragma_Unmodified => 0, 31061 Pragma_Unreferenced => 0, 31062 Pragma_Unreferenced_Objects => 0, 31063 Pragma_Unreserve_All_Interrupts => 0, 31064 Pragma_Unsuppress => 0, 31065 Pragma_Unused => 0, 31066 Pragma_Use_VADS_Size => 0, 31067 Pragma_Validity_Checks => 0, 31068 Pragma_Volatile => 0, 31069 Pragma_Volatile_Components => 0, 31070 Pragma_Volatile_Full_Access => 0, 31071 Pragma_Volatile_Function => 0, 31072 Pragma_Warning_As_Error => 0, 31073 Pragma_Warnings => 0, 31074 Pragma_Weak_External => 0, 31075 Pragma_Wide_Character_Encoding => 0, 31076 Unknown_Pragma => 0); 31077 31078 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is 31079 Id : Pragma_Id; 31080 P : Node_Id; 31081 C : Int; 31082 AN : Nat; 31083 31084 function Arg_No return Nat; 31085 -- Returns an integer showing what argument we are in. A value of 31086 -- zero means we are not in any of the arguments. 31087 31088 ------------ 31089 -- Arg_No -- 31090 ------------ 31091 31092 function Arg_No return Nat is 31093 A : Node_Id; 31094 N : Nat; 31095 31096 begin 31097 A := First (Pragma_Argument_Associations (Parent (P))); 31098 N := 1; 31099 loop 31100 if No (A) then 31101 return 0; 31102 elsif A = P then 31103 return N; 31104 end if; 31105 31106 Next (A); 31107 N := N + 1; 31108 end loop; 31109 end Arg_No; 31110 31111 -- Start of processing for Non_Significant_Pragma_Reference 31112 31113 begin 31114 P := Parent (N); 31115 31116 if Nkind (P) /= N_Pragma_Argument_Association then 31117 return False; 31118 31119 else 31120 Id := Get_Pragma_Id (Parent (P)); 31121 C := Sig_Flags (Id); 31122 AN := Arg_No; 31123 31124 if AN = 0 then 31125 return False; 31126 end if; 31127 31128 case C is 31129 when -1 => 31130 return False; 31131 31132 when 0 => 31133 return True; 31134 31135 when 92 .. 99 => 31136 return AN < (C - 90); 31137 31138 when others => 31139 return AN /= C; 31140 end case; 31141 end if; 31142 end Is_Non_Significant_Pragma_Reference; 31143 31144 ------------------------------ 31145 -- Is_Pragma_String_Literal -- 31146 ------------------------------ 31147 31148 -- This function returns true if the corresponding pragma argument is a 31149 -- static string expression. These are the only cases in which string 31150 -- literals can appear as pragma arguments. We also allow a string literal 31151 -- as the first argument to pragma Assert (although it will of course 31152 -- always generate a type error). 31153 31154 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is 31155 Pragn : constant Node_Id := Parent (Par); 31156 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); 31157 Pname : constant Name_Id := Pragma_Name (Pragn); 31158 Argn : Natural; 31159 N : Node_Id; 31160 31161 begin 31162 Argn := 1; 31163 N := First (Assoc); 31164 loop 31165 exit when N = Par; 31166 Argn := Argn + 1; 31167 Next (N); 31168 end loop; 31169 31170 if Pname = Name_Assert then 31171 return True; 31172 31173 elsif Pname = Name_Export then 31174 return Argn > 2; 31175 31176 elsif Pname = Name_Ident then 31177 return Argn = 1; 31178 31179 elsif Pname = Name_Import then 31180 return Argn > 2; 31181 31182 elsif Pname = Name_Interface_Name then 31183 return Argn > 1; 31184 31185 elsif Pname = Name_Linker_Alias then 31186 return Argn = 2; 31187 31188 elsif Pname = Name_Linker_Section then 31189 return Argn = 2; 31190 31191 elsif Pname = Name_Machine_Attribute then 31192 return Argn = 2; 31193 31194 elsif Pname = Name_Source_File_Name then 31195 return True; 31196 31197 elsif Pname = Name_Source_Reference then 31198 return Argn = 2; 31199 31200 elsif Pname = Name_Title then 31201 return True; 31202 31203 elsif Pname = Name_Subtitle then 31204 return True; 31205 31206 else 31207 return False; 31208 end if; 31209 end Is_Pragma_String_Literal; 31210 31211 --------------------------- 31212 -- Is_Private_SPARK_Mode -- 31213 --------------------------- 31214 31215 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is 31216 begin 31217 pragma Assert 31218 (Nkind (N) = N_Pragma 31219 and then Pragma_Name (N) = Name_SPARK_Mode 31220 and then Is_List_Member (N)); 31221 31222 -- For pragma SPARK_Mode to be private, it has to appear in the private 31223 -- declarations of a package. 31224 31225 return 31226 Present (Parent (N)) 31227 and then Nkind (Parent (N)) = N_Package_Specification 31228 and then List_Containing (N) = Private_Declarations (Parent (N)); 31229 end Is_Private_SPARK_Mode; 31230 31231 ------------------------------------- 31232 -- Is_Unconstrained_Or_Tagged_Item -- 31233 ------------------------------------- 31234 31235 function Is_Unconstrained_Or_Tagged_Item 31236 (Item : Entity_Id) return Boolean 31237 is 31238 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean; 31239 -- Determine whether record type Typ has at least one unconstrained 31240 -- component. 31241 31242 --------------------------------- 31243 -- Has_Unconstrained_Component -- 31244 --------------------------------- 31245 31246 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is 31247 Comp : Entity_Id; 31248 31249 begin 31250 Comp := First_Component (Typ); 31251 while Present (Comp) loop 31252 if Is_Unconstrained_Or_Tagged_Item (Comp) then 31253 return True; 31254 end if; 31255 31256 Next_Component (Comp); 31257 end loop; 31258 31259 return False; 31260 end Has_Unconstrained_Component; 31261 31262 -- Local variables 31263 31264 Typ : constant Entity_Id := Etype (Item); 31265 31266 -- Start of processing for Is_Unconstrained_Or_Tagged_Item 31267 31268 begin 31269 if Is_Tagged_Type (Typ) then 31270 return True; 31271 31272 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then 31273 return True; 31274 31275 elsif Is_Record_Type (Typ) then 31276 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then 31277 return True; 31278 else 31279 return Has_Unconstrained_Component (Typ); 31280 end if; 31281 31282 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then 31283 return True; 31284 31285 else 31286 return False; 31287 end if; 31288 end Is_Unconstrained_Or_Tagged_Item; 31289 31290 ----------------------------- 31291 -- Is_Valid_Assertion_Kind -- 31292 ----------------------------- 31293 31294 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is 31295 begin 31296 case Nam is 31297 when 31298 -- RM defined 31299 31300 Name_Assert 31301 | Name_Assertion_Policy 31302 | Name_Static_Predicate 31303 | Name_Dynamic_Predicate 31304 | Name_Pre 31305 | Name_uPre 31306 | Name_Post 31307 | Name_uPost 31308 | Name_Type_Invariant 31309 | Name_uType_Invariant 31310 31311 -- Impl defined 31312 31313 | Name_Assert_And_Cut 31314 | Name_Assume 31315 | Name_Contract_Cases 31316 | Name_Debug 31317 | Name_Default_Initial_Condition 31318 | Name_Ghost 31319 | Name_Initial_Condition 31320 | Name_Invariant 31321 | Name_uInvariant 31322 | Name_Loop_Invariant 31323 | Name_Loop_Variant 31324 | Name_Postcondition 31325 | Name_Precondition 31326 | Name_Predicate 31327 | Name_Refined_Post 31328 | Name_Statement_Assertions 31329 => 31330 return True; 31331 31332 when others => 31333 return False; 31334 end case; 31335 end Is_Valid_Assertion_Kind; 31336 31337 -------------------------------------- 31338 -- Process_Compilation_Unit_Pragmas -- 31339 -------------------------------------- 31340 31341 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is 31342 begin 31343 -- A special check for pragma Suppress_All, a very strange DEC pragma, 31344 -- strange because it comes at the end of the unit. Rational has the 31345 -- same name for a pragma, but treats it as a program unit pragma, In 31346 -- GNAT we just decide to allow it anywhere at all. If it appeared then 31347 -- the flag Has_Pragma_Suppress_All was set on the compilation unit 31348 -- node, and we insert a pragma Suppress (All_Checks) at the start of 31349 -- the context clause to ensure the correct processing. 31350 31351 if Has_Pragma_Suppress_All (N) then 31352 Prepend_To (Context_Items (N), 31353 Make_Pragma (Sloc (N), 31354 Chars => Name_Suppress, 31355 Pragma_Argument_Associations => New_List ( 31356 Make_Pragma_Argument_Association (Sloc (N), 31357 Expression => Make_Identifier (Sloc (N), Name_All_Checks))))); 31358 end if; 31359 31360 -- Nothing else to do at the current time 31361 31362 end Process_Compilation_Unit_Pragmas; 31363 31364 ------------------------------------------- 31365 -- Process_Compile_Time_Warning_Or_Error -- 31366 ------------------------------------------- 31367 31368 procedure Process_Compile_Time_Warning_Or_Error 31369 (N : Node_Id; 31370 Eloc : Source_Ptr) 31371 is 31372 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 31373 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 31374 Arg2 : constant Node_Id := Next (Arg1); 31375 31376 begin 31377 Analyze_And_Resolve (Arg1x, Standard_Boolean); 31378 31379 if Compile_Time_Known_Value (Arg1x) then 31380 if Is_True (Expr_Value (Arg1x)) then 31381 31382 -- We have already verified that the second argument is a static 31383 -- string expression. Its string value must be retrieved 31384 -- explicitly if it is a declared constant, otherwise it has 31385 -- been constant-folded previously. 31386 31387 declare 31388 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 31389 Pname : constant Name_Id := Pragma_Name_Unmapped (N); 31390 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); 31391 Str : constant String_Id := 31392 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))); 31393 Str_Len : constant Nat := String_Length (Str); 31394 31395 Force : constant Boolean := 31396 Prag_Id = Pragma_Compile_Time_Warning 31397 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit)) 31398 and then (Ekind (Cent) /= E_Package 31399 or else not In_Private_Part (Cent)); 31400 -- Set True if this is the warning case, and we are in the 31401 -- visible part of a package spec, or in a subprogram spec, 31402 -- in which case we want to force the client to see the 31403 -- warning, even though it is not in the main unit. 31404 31405 C : Character; 31406 CC : Char_Code; 31407 Cont : Boolean; 31408 Ptr : Nat; 31409 31410 begin 31411 -- Loop through segments of message separated by line feeds. 31412 -- We output these segments as separate messages with 31413 -- continuation marks for all but the first. 31414 31415 Cont := False; 31416 Ptr := 1; 31417 loop 31418 Error_Msg_Strlen := 0; 31419 31420 -- Loop to copy characters from argument to error message 31421 -- string buffer. 31422 31423 loop 31424 exit when Ptr > Str_Len; 31425 CC := Get_String_Char (Str, Ptr); 31426 Ptr := Ptr + 1; 31427 31428 -- Ignore wide chars ??? else store character 31429 31430 if In_Character_Range (CC) then 31431 C := Get_Character (CC); 31432 exit when C = ASCII.LF; 31433 Error_Msg_Strlen := Error_Msg_Strlen + 1; 31434 Error_Msg_String (Error_Msg_Strlen) := C; 31435 end if; 31436 end loop; 31437 31438 -- Here with one line ready to go 31439 31440 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; 31441 31442 -- If this is a warning in a spec, then we want clients 31443 -- to see the warning, so mark the message with the 31444 -- special sequence !! to force the warning. In the case 31445 -- of a package spec, we do not force this if we are in 31446 -- the private part of the spec. 31447 31448 if Force then 31449 if Cont = False then 31450 Error_Msg ("<<~!!", Eloc); 31451 Cont := True; 31452 else 31453 Error_Msg ("\<<~!!", Eloc); 31454 end if; 31455 31456 -- Error, rather than warning, or in a body, so we do not 31457 -- need to force visibility for client (error will be 31458 -- output in any case, and this is the situation in which 31459 -- we do not want a client to get a warning, since the 31460 -- warning is in the body or the spec private part). 31461 31462 else 31463 if Cont = False then 31464 Error_Msg ("<<~", Eloc); 31465 Cont := True; 31466 else 31467 Error_Msg ("\<<~", Eloc); 31468 end if; 31469 end if; 31470 31471 exit when Ptr > Str_Len; 31472 end loop; 31473 end; 31474 end if; 31475 end if; 31476 end Process_Compile_Time_Warning_Or_Error; 31477 31478 ------------------------------------ 31479 -- Record_Possible_Body_Reference -- 31480 ------------------------------------ 31481 31482 procedure Record_Possible_Body_Reference 31483 (State_Id : Entity_Id; 31484 Ref : Node_Id) 31485 is 31486 Context : Node_Id; 31487 Spec_Id : Entity_Id; 31488 31489 begin 31490 -- Ensure that we are dealing with a reference to a state 31491 31492 pragma Assert (Ekind (State_Id) = E_Abstract_State); 31493 31494 -- Climb the tree starting from the reference looking for a package body 31495 -- whose spec declares the referenced state. This criteria automatically 31496 -- excludes references in package specs which are legal. Note that it is 31497 -- not wise to emit an error now as the package body may lack pragma 31498 -- Refined_State or the referenced state may not be mentioned in the 31499 -- refinement. This approach avoids the generation of misleading errors. 31500 31501 Context := Ref; 31502 while Present (Context) loop 31503 if Nkind (Context) = N_Package_Body then 31504 Spec_Id := Corresponding_Spec (Context); 31505 31506 if Present (Abstract_States (Spec_Id)) 31507 and then Contains (Abstract_States (Spec_Id), State_Id) 31508 then 31509 if No (Body_References (State_Id)) then 31510 Set_Body_References (State_Id, New_Elmt_List); 31511 end if; 31512 31513 Append_Elmt (Ref, To => Body_References (State_Id)); 31514 exit; 31515 end if; 31516 end if; 31517 31518 Context := Parent (Context); 31519 end loop; 31520 end Record_Possible_Body_Reference; 31521 31522 ------------------------------------------ 31523 -- Relocate_Pragmas_To_Anonymous_Object -- 31524 ------------------------------------------ 31525 31526 procedure Relocate_Pragmas_To_Anonymous_Object 31527 (Typ_Decl : Node_Id; 31528 Obj_Decl : Node_Id) 31529 is 31530 Decl : Node_Id; 31531 Def : Node_Id; 31532 Next_Decl : Node_Id; 31533 31534 begin 31535 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then 31536 Def := Protected_Definition (Typ_Decl); 31537 else 31538 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration); 31539 Def := Task_Definition (Typ_Decl); 31540 end if; 31541 31542 -- The concurrent definition has a visible declaration list. Inspect it 31543 -- and relocate all canidate pragmas. 31544 31545 if Present (Def) and then Present (Visible_Declarations (Def)) then 31546 Decl := First (Visible_Declarations (Def)); 31547 while Present (Decl) loop 31548 31549 -- Preserve the following declaration for iteration purposes due 31550 -- to possible relocation of a pragma. 31551 31552 Next_Decl := Next (Decl); 31553 31554 if Nkind (Decl) = N_Pragma 31555 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl)) 31556 then 31557 Remove (Decl); 31558 Insert_After (Obj_Decl, Decl); 31559 31560 -- Skip internally generated code 31561 31562 elsif not Comes_From_Source (Decl) then 31563 null; 31564 31565 -- No candidate pragmas are available for relocation 31566 31567 else 31568 exit; 31569 end if; 31570 31571 Decl := Next_Decl; 31572 end loop; 31573 end if; 31574 end Relocate_Pragmas_To_Anonymous_Object; 31575 31576 ------------------------------ 31577 -- Relocate_Pragmas_To_Body -- 31578 ------------------------------ 31579 31580 procedure Relocate_Pragmas_To_Body 31581 (Subp_Body : Node_Id; 31582 Target_Body : Node_Id := Empty) 31583 is 31584 procedure Relocate_Pragma (Prag : Node_Id); 31585 -- Remove a single pragma from its current list and add it to the 31586 -- declarations of the proper body (either Subp_Body or Target_Body). 31587 31588 --------------------- 31589 -- Relocate_Pragma -- 31590 --------------------- 31591 31592 procedure Relocate_Pragma (Prag : Node_Id) is 31593 Decls : List_Id; 31594 Target : Node_Id; 31595 31596 begin 31597 -- When subprogram stubs or expression functions are involves, the 31598 -- destination declaration list belongs to the proper body. 31599 31600 if Present (Target_Body) then 31601 Target := Target_Body; 31602 else 31603 Target := Subp_Body; 31604 end if; 31605 31606 Decls := Declarations (Target); 31607 31608 if No (Decls) then 31609 Decls := New_List; 31610 Set_Declarations (Target, Decls); 31611 end if; 31612 31613 -- Unhook the pragma from its current list 31614 31615 Remove (Prag); 31616 Prepend (Prag, Decls); 31617 end Relocate_Pragma; 31618 31619 -- Local variables 31620 31621 Body_Id : constant Entity_Id := 31622 Defining_Unit_Name (Specification (Subp_Body)); 31623 Next_Stmt : Node_Id; 31624 Stmt : Node_Id; 31625 31626 -- Start of processing for Relocate_Pragmas_To_Body 31627 31628 begin 31629 -- Do not process a body that comes from a separate unit as no construct 31630 -- can possibly follow it. 31631 31632 if not Is_List_Member (Subp_Body) then 31633 return; 31634 31635 -- Do not relocate pragmas that follow a stub if the stub does not have 31636 -- a proper body. 31637 31638 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub 31639 and then No (Target_Body) 31640 then 31641 return; 31642 31643 -- Do not process internally generated routine _Postconditions 31644 31645 elsif Ekind (Body_Id) = E_Procedure 31646 and then Chars (Body_Id) = Name_uPostconditions 31647 then 31648 return; 31649 end if; 31650 31651 -- Look at what is following the body. We are interested in certain kind 31652 -- of pragmas (either from source or byproducts of expansion) that can 31653 -- apply to a body [stub]. 31654 31655 Stmt := Next (Subp_Body); 31656 while Present (Stmt) loop 31657 31658 -- Preserve the following statement for iteration purposes due to a 31659 -- possible relocation of a pragma. 31660 31661 Next_Stmt := Next (Stmt); 31662 31663 -- Move a candidate pragma following the body to the declarations of 31664 -- the body. 31665 31666 if Nkind (Stmt) = N_Pragma 31667 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt)) 31668 then 31669 31670 -- If a source pragma Warnings follows the body, it applies to 31671 -- following statements and does not belong in the body. 31672 31673 if Get_Pragma_Id (Stmt) = Pragma_Warnings 31674 and then Comes_From_Source (Stmt) 31675 then 31676 null; 31677 else 31678 Relocate_Pragma (Stmt); 31679 end if; 31680 31681 -- Skip internally generated code 31682 31683 elsif not Comes_From_Source (Stmt) then 31684 null; 31685 31686 -- No candidate pragmas are available for relocation 31687 31688 else 31689 exit; 31690 end if; 31691 31692 Stmt := Next_Stmt; 31693 end loop; 31694 end Relocate_Pragmas_To_Body; 31695 31696 ------------------- 31697 -- Resolve_State -- 31698 ------------------- 31699 31700 procedure Resolve_State (N : Node_Id) is 31701 Func : Entity_Id; 31702 State : Entity_Id; 31703 31704 begin 31705 if Is_Entity_Name (N) and then Present (Entity (N)) then 31706 Func := Entity (N); 31707 31708 -- Handle overloading of state names by functions. Traverse the 31709 -- homonym chain looking for an abstract state. 31710 31711 if Ekind (Func) = E_Function and then Has_Homonym (Func) then 31712 pragma Assert (Is_Overloaded (N)); 31713 31714 State := Homonym (Func); 31715 while Present (State) loop 31716 if Ekind (State) = E_Abstract_State then 31717 31718 -- Resolve the overloading by setting the proper entity of 31719 -- the reference to that of the state. 31720 31721 Set_Etype (N, Standard_Void_Type); 31722 Set_Entity (N, State); 31723 Set_Is_Overloaded (N, False); 31724 31725 Generate_Reference (State, N); 31726 return; 31727 end if; 31728 31729 State := Homonym (State); 31730 end loop; 31731 31732 -- A function can never act as a state. If the homonym chain does 31733 -- not contain a corresponding state, then something went wrong in 31734 -- the overloading mechanism. 31735 31736 raise Program_Error; 31737 end if; 31738 end if; 31739 end Resolve_State; 31740 31741 ---------------------------- 31742 -- Rewrite_Assertion_Kind -- 31743 ---------------------------- 31744 31745 procedure Rewrite_Assertion_Kind 31746 (N : Node_Id; 31747 From_Policy : Boolean := False) 31748 is 31749 Nam : Name_Id; 31750 31751 begin 31752 Nam := No_Name; 31753 if Nkind (N) = N_Attribute_Reference 31754 and then Attribute_Name (N) = Name_Class 31755 and then Nkind (Prefix (N)) = N_Identifier 31756 then 31757 case Chars (Prefix (N)) is 31758 when Name_Pre => 31759 Nam := Name_uPre; 31760 31761 when Name_Post => 31762 Nam := Name_uPost; 31763 31764 when Name_Type_Invariant => 31765 Nam := Name_uType_Invariant; 31766 31767 when Name_Invariant => 31768 Nam := Name_uInvariant; 31769 31770 when others => 31771 return; 31772 end case; 31773 31774 -- Recommend standard use of aspect names Pre/Post 31775 31776 elsif Nkind (N) = N_Identifier 31777 and then From_Policy 31778 and then Serious_Errors_Detected = 0 31779 and then not ASIS_Mode 31780 then 31781 if Chars (N) = Name_Precondition 31782 or else Chars (N) = Name_Postcondition 31783 then 31784 Error_Msg_N ("Check_Policy is a non-standard pragma??", N); 31785 Error_Msg_N 31786 ("\use Assertion_Policy and aspect names Pre/Post for " 31787 & "Ada2012 conformance?", N); 31788 end if; 31789 31790 return; 31791 end if; 31792 31793 if Nam /= No_Name then 31794 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam)); 31795 end if; 31796 end Rewrite_Assertion_Kind; 31797 31798 -------- 31799 -- rv -- 31800 -------- 31801 31802 procedure rv is 31803 begin 31804 Dummy := Dummy + 1; 31805 end rv; 31806 31807 -------------------------------- 31808 -- Set_Encoded_Interface_Name -- 31809 -------------------------------- 31810 31811 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is 31812 Str : constant String_Id := Strval (S); 31813 Len : constant Nat := String_Length (Str); 31814 CC : Char_Code; 31815 C : Character; 31816 J : Pos; 31817 31818 Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; 31819 31820 procedure Encode; 31821 -- Stores encoded value of character code CC. The encoding we use an 31822 -- underscore followed by four lower case hex digits. 31823 31824 ------------ 31825 -- Encode -- 31826 ------------ 31827 31828 procedure Encode is 31829 begin 31830 Store_String_Char (Get_Char_Code ('_')); 31831 Store_String_Char 31832 (Get_Char_Code (Hex (Integer (CC / 2 ** 12)))); 31833 Store_String_Char 31834 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#)))); 31835 Store_String_Char 31836 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#)))); 31837 Store_String_Char 31838 (Get_Char_Code (Hex (Integer (CC and 16#0F#)))); 31839 end Encode; 31840 31841 -- Start of processing for Set_Encoded_Interface_Name 31842 31843 begin 31844 -- If first character is asterisk, this is a link name, and we leave it 31845 -- completely unmodified. We also ignore null strings (the latter case 31846 -- happens only in error cases). 31847 31848 if Len = 0 31849 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') 31850 then 31851 Set_Interface_Name (E, S); 31852 31853 else 31854 J := 1; 31855 loop 31856 CC := Get_String_Char (Str, J); 31857 31858 exit when not In_Character_Range (CC); 31859 31860 C := Get_Character (CC); 31861 31862 exit when C /= '_' and then C /= '$' 31863 and then C not in '0' .. '9' 31864 and then C not in 'a' .. 'z' 31865 and then C not in 'A' .. 'Z'; 31866 31867 if J = Len then 31868 Set_Interface_Name (E, S); 31869 return; 31870 31871 else 31872 J := J + 1; 31873 end if; 31874 end loop; 31875 31876 -- Here we need to encode. The encoding we use as follows: 31877 -- three underscores + four hex digits (lower case) 31878 31879 Start_String; 31880 31881 for J in 1 .. String_Length (Str) loop 31882 CC := Get_String_Char (Str, J); 31883 31884 if not In_Character_Range (CC) then 31885 Encode; 31886 else 31887 C := Get_Character (CC); 31888 31889 if C = '_' or else C = '$' 31890 or else C in '0' .. '9' 31891 or else C in 'a' .. 'z' 31892 or else C in 'A' .. 'Z' 31893 then 31894 Store_String_Char (CC); 31895 else 31896 Encode; 31897 end if; 31898 end if; 31899 end loop; 31900 31901 Set_Interface_Name (E, 31902 Make_String_Literal (Sloc (S), 31903 Strval => End_String)); 31904 end if; 31905 end Set_Encoded_Interface_Name; 31906 31907 ------------------------ 31908 -- Set_Elab_Unit_Name -- 31909 ------------------------ 31910 31911 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is 31912 Pref : Node_Id; 31913 Scop : Entity_Id; 31914 31915 begin 31916 if Nkind (N) = N_Identifier 31917 and then Nkind (With_Item) = N_Identifier 31918 then 31919 Set_Entity (N, Entity (With_Item)); 31920 31921 elsif Nkind (N) = N_Selected_Component then 31922 Change_Selected_Component_To_Expanded_Name (N); 31923 Set_Entity (N, Entity (With_Item)); 31924 Set_Entity (Selector_Name (N), Entity (N)); 31925 31926 Pref := Prefix (N); 31927 Scop := Scope (Entity (N)); 31928 while Nkind (Pref) = N_Selected_Component loop 31929 Change_Selected_Component_To_Expanded_Name (Pref); 31930 Set_Entity (Selector_Name (Pref), Scop); 31931 Set_Entity (Pref, Scop); 31932 Pref := Prefix (Pref); 31933 Scop := Scope (Scop); 31934 end loop; 31935 31936 Set_Entity (Pref, Scop); 31937 end if; 31938 31939 Generate_Reference (Entity (With_Item), N, Set_Ref => False); 31940 end Set_Elab_Unit_Name; 31941 31942 ------------------- 31943 -- Test_Case_Arg -- 31944 ------------------- 31945 31946 function Test_Case_Arg 31947 (Prag : Node_Id; 31948 Arg_Nam : Name_Id; 31949 From_Aspect : Boolean := False) return Node_Id 31950 is 31951 Aspect : constant Node_Id := Corresponding_Aspect (Prag); 31952 Arg : Node_Id; 31953 Args : Node_Id; 31954 31955 begin 31956 pragma Assert (Nam_In (Arg_Nam, Name_Ensures, 31957 Name_Mode, 31958 Name_Name, 31959 Name_Requires)); 31960 31961 -- The caller requests the aspect argument 31962 31963 if From_Aspect then 31964 if Present (Aspect) 31965 and then Nkind (Expression (Aspect)) = N_Aggregate 31966 then 31967 Args := Expression (Aspect); 31968 31969 -- "Name" and "Mode" may appear without an identifier as a 31970 -- positional association. 31971 31972 if Present (Expressions (Args)) then 31973 Arg := First (Expressions (Args)); 31974 31975 if Present (Arg) and then Arg_Nam = Name_Name then 31976 return Arg; 31977 end if; 31978 31979 -- Skip "Name" 31980 31981 Arg := Next (Arg); 31982 31983 if Present (Arg) and then Arg_Nam = Name_Mode then 31984 return Arg; 31985 end if; 31986 end if; 31987 31988 -- Some or all arguments may appear as component associatons 31989 31990 if Present (Component_Associations (Args)) then 31991 Arg := First (Component_Associations (Args)); 31992 while Present (Arg) loop 31993 if Chars (First (Choices (Arg))) = Arg_Nam then 31994 return Arg; 31995 end if; 31996 31997 Next (Arg); 31998 end loop; 31999 end if; 32000 end if; 32001 32002 -- Otherwise retrieve the argument directly from the pragma 32003 32004 else 32005 Arg := First (Pragma_Argument_Associations (Prag)); 32006 32007 if Present (Arg) and then Arg_Nam = Name_Name then 32008 return Arg; 32009 end if; 32010 32011 -- Skip argument "Name" 32012 32013 Arg := Next (Arg); 32014 32015 if Present (Arg) and then Arg_Nam = Name_Mode then 32016 return Arg; 32017 end if; 32018 32019 -- Skip argument "Mode" 32020 32021 Arg := Next (Arg); 32022 32023 -- Arguments "Requires" and "Ensures" are optional and may not be 32024 -- present at all. 32025 32026 while Present (Arg) loop 32027 if Chars (Arg) = Arg_Nam then 32028 return Arg; 32029 end if; 32030 32031 Next (Arg); 32032 end loop; 32033 end if; 32034 32035 return Empty; 32036 end Test_Case_Arg; 32037 32038end Sem_Prag; 32039