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 Expander; use Expander; 45with Freeze; use Freeze; 46with Ghost; use Ghost; 47with Gnatvsn; use Gnatvsn; 48with Lib; use Lib; 49with Lib.Writ; use Lib.Writ; 50with Lib.Xref; use Lib.Xref; 51with Namet.Sp; use Namet.Sp; 52with Nlists; use Nlists; 53with Nmake; use Nmake; 54with Output; use Output; 55with Par_SCO; use Par_SCO; 56with Restrict; use Restrict; 57with Rident; use Rident; 58with Rtsfind; use Rtsfind; 59with Sem; use Sem; 60with Sem_Aux; use Sem_Aux; 61with Sem_Ch3; use Sem_Ch3; 62with Sem_Ch6; use Sem_Ch6; 63with Sem_Ch8; use Sem_Ch8; 64with Sem_Ch12; use Sem_Ch12; 65with Sem_Ch13; use Sem_Ch13; 66with Sem_Disp; use Sem_Disp; 67with Sem_Dist; use Sem_Dist; 68with Sem_Elab; use Sem_Elab; 69with Sem_Elim; use Sem_Elim; 70with Sem_Eval; use Sem_Eval; 71with Sem_Intr; use Sem_Intr; 72with Sem_Mech; use Sem_Mech; 73with Sem_Res; use Sem_Res; 74with Sem_Type; use Sem_Type; 75with Sem_Util; use Sem_Util; 76with Sem_Warn; use Sem_Warn; 77with Stand; use Stand; 78with Sinfo; use Sinfo; 79with Sinfo.CN; use Sinfo.CN; 80with Sinput; use Sinput; 81with Stringt; use Stringt; 82with Stylesw; use Stylesw; 83with Table; 84with Targparm; use Targparm; 85with Tbuild; use Tbuild; 86with Ttypes; 87with Uintp; use Uintp; 88with Uname; use Uname; 89with Urealp; use Urealp; 90with Validsw; use Validsw; 91with Warnsw; use Warnsw; 92 93with System.Case_Util; 94 95package body Sem_Prag is 96 97 ---------------------------------------------- 98 -- Common Handling of Import-Export Pragmas -- 99 ---------------------------------------------- 100 101 -- In the following section, a number of Import_xxx and Export_xxx pragmas 102 -- are defined by GNAT. These are compatible with the DEC pragmas of the 103 -- same name, and all have the following common form and processing: 104 105 -- pragma Export_xxx 106 -- [Internal =>] LOCAL_NAME 107 -- [, [External =>] EXTERNAL_SYMBOL] 108 -- [, other optional parameters ]); 109 110 -- pragma Import_xxx 111 -- [Internal =>] LOCAL_NAME 112 -- [, [External =>] EXTERNAL_SYMBOL] 113 -- [, other optional parameters ]); 114 115 -- EXTERNAL_SYMBOL ::= 116 -- IDENTIFIER 117 -- | static_string_EXPRESSION 118 119 -- The internal LOCAL_NAME designates the entity that is imported or 120 -- exported, and must refer to an entity in the current declarative 121 -- part (as required by the rules for LOCAL_NAME). 122 123 -- The external linker name is designated by the External parameter if 124 -- given, or the Internal parameter if not (if there is no External 125 -- parameter, the External parameter is a copy of the Internal name). 126 127 -- If the External parameter is given as a string, then this string is 128 -- treated as an external name (exactly as though it had been given as an 129 -- External_Name parameter for a normal Import pragma). 130 131 -- If the External parameter is given as an identifier (or there is no 132 -- External parameter, so that the Internal identifier is used), then 133 -- the external name is the characters of the identifier, translated 134 -- to all lower case letters. 135 136 -- Note: the external name specified or implied by any of these special 137 -- Import_xxx or Export_xxx pragmas override an external or link name 138 -- specified in a previous Import or Export pragma. 139 140 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of 141 -- named notation, following the standard rules for subprogram calls, i.e. 142 -- parameters can be given in any order if named notation is used, and 143 -- positional and named notation can be mixed, subject to the rule that all 144 -- positional parameters must appear first. 145 146 -- Note: All these pragmas are implemented exactly following the DEC design 147 -- and implementation and are intended to be fully compatible with the use 148 -- of these pragmas in the DEC Ada compiler. 149 150 -------------------------------------------- 151 -- Checking for Duplicated External Names -- 152 -------------------------------------------- 153 154 -- It is suspicious if two separate Export pragmas use the same external 155 -- name. The following table is used to diagnose this situation so that 156 -- an appropriate warning can be issued. 157 158 -- The Node_Id stored is for the N_String_Literal node created to hold 159 -- the value of the external name. The Sloc of this node is used to 160 -- cross-reference the location of the duplication. 161 162 package Externals is new Table.Table ( 163 Table_Component_Type => Node_Id, 164 Table_Index_Type => Int, 165 Table_Low_Bound => 0, 166 Table_Initial => 100, 167 Table_Increment => 100, 168 Table_Name => "Name_Externals"); 169 170 ------------------------------------- 171 -- Local Subprograms and Variables -- 172 ------------------------------------- 173 174 function Adjust_External_Name_Case (N : Node_Id) return Node_Id; 175 -- This routine is used for possible casing adjustment of an explicit 176 -- external name supplied as a string literal (the node N), according to 177 -- the casing requirement of Opt.External_Name_Casing. If this is set to 178 -- As_Is, then the string literal is returned unchanged, but if it is set 179 -- to Uppercase or Lowercase, then a new string literal with appropriate 180 -- casing is constructed. 181 182 procedure Analyze_Part_Of 183 (Indic : Node_Id; 184 Item_Id : Entity_Id; 185 Encap : Node_Id; 186 Encap_Id : out Entity_Id; 187 Legal : out Boolean); 188 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and 189 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the 190 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or 191 -- package instantiation. Encap denotes the encapsulating state or single 192 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when 193 -- the indicator is legal. 194 195 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean; 196 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends. 197 -- Query whether a particular item appears in a mixed list of nodes and 198 -- entities. It is assumed that all nodes in the list have entities. 199 200 procedure Check_Postcondition_Use_In_Inlined_Subprogram 201 (Prag : Node_Id; 202 Spec_Id : Entity_Id); 203 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition, 204 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma 205 -- Prag is associated with subprogram Spec_Id subject to Inline_Always, 206 -- and assertions are enabled. 207 208 procedure Check_State_And_Constituent_Use 209 (States : Elist_Id; 210 Constits : Elist_Id; 211 Context : Node_Id); 212 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_] 213 -- Global and Initializes. Determine whether a state from list States and a 214 -- corresponding constituent from list Constits (if any) appear in the same 215 -- context denoted by Context. If this is the case, emit an error. 216 217 procedure Contract_Freeze_Error 218 (Contract_Id : Entity_Id; 219 Freeze_Id : Entity_Id); 220 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and 221 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity 222 -- of a body which caused contract freezing and Contract_Id denotes the 223 -- entity of the affected contstruct. 224 225 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id); 226 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma 227 -- Prag that duplicates previous pragma Prev. 228 229 function Find_Encapsulating_State 230 (States : Elist_Id; 231 Constit_Id : Entity_Id) return Entity_Id; 232 -- Given the entity of a constituent Constit_Id, find the corresponding 233 -- encapsulating state which appears in States. The routine returns Empty 234 -- if no such state is found. 235 236 function Find_Related_Context 237 (Prag : Node_Id; 238 Do_Checks : Boolean := False) return Node_Id; 239 -- Subsidiary to the analysis of pragmas 240 -- Async_Readers 241 -- Async_Writers 242 -- Constant_After_Elaboration 243 -- Effective_Reads 244 -- Effective_Writers 245 -- Part_Of 246 -- Find the first source declaration or statement found while traversing 247 -- the previous node chain starting from pragma Prag. If flag Do_Checks is 248 -- set, the routine reports duplicate pragmas. The routine returns Empty 249 -- when reaching the start of the node chain. 250 251 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; 252 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the 253 -- original one, following the renaming chain) is returned. Otherwise the 254 -- entity is returned unchanged. Should be in Einfo??? 255 256 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type; 257 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram 258 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding 259 -- value of type SPARK_Mode_Type. 260 261 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean; 262 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends. 263 -- Determine whether dependency clause Clause is surrounded by extra 264 -- parentheses. If this is the case, issue an error message. 265 266 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; 267 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of 268 -- pragma Depends. Determine whether the type of dependency item Item is 269 -- tagged, unconstrained array, unconstrained record or a record with at 270 -- least one unconstrained component. 271 272 procedure Record_Possible_Body_Reference 273 (State_Id : Entity_Id; 274 Ref : Node_Id); 275 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] 276 -- Global. Given an abstract state denoted by State_Id and a reference Ref 277 -- to it, determine whether the reference appears in a package body that 278 -- will eventually refine the state. If this is the case, record the 279 -- reference for future checks (see Analyze_Refined_State_In_Decls). 280 281 procedure Resolve_State (N : Node_Id); 282 -- Handle the overloading of state names by functions. When N denotes a 283 -- function, this routine finds the corresponding state and sets the entity 284 -- of N to that of the state. 285 286 procedure Rewrite_Assertion_Kind 287 (N : Node_Id; 288 From_Policy : Boolean := False); 289 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class, 290 -- then it is rewritten as an identifier with the corresponding special 291 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check 292 -- and Check_Policy. If the names are Precondition or Postcondition, this 293 -- combination is deprecated in favor of Assertion_Policy and Ada2012 294 -- Aspect names. The parameter From_Policy indicates that the pragma 295 -- is the old non-standard Check_Policy and not a rewritten pragma. 296 297 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id); 298 -- Place semantic information on the argument of an Elaborate/Elaborate_All 299 -- pragma. Entity name for unit and its parents is taken from item in 300 -- previous with_clause that mentions the unit. 301 302 procedure Validate_Compile_Time_Warning_Or_Error 303 (N : Node_Id; 304 Eloc : Source_Ptr); 305 -- Common processing for Compile_Time_Error and Compile_Time_Warning of 306 -- pragma N. Called when the pragma is processed as part of its regular 307 -- analysis but also called after calling the back end to validate these 308 -- pragmas for size and alignment appropriateness. 309 310 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id); 311 -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean 312 -- expression is not known at compile time during the front end. This 313 -- procedure makes an entry in a table. The actual checking is performed by 314 -- Validate_Compile_Time_Warning_Errors, which is invoked after calling the 315 -- back end. 316 317 Dummy : Integer := 0; 318 pragma Volatile (Dummy); 319 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization 320 321 procedure ip; 322 pragma No_Inline (ip); 323 -- A dummy procedure called when pragma Inspection_Point is analyzed. This 324 -- is just to help debugging the front end. If a pragma Inspection_Point 325 -- is added to a source program, then breaking on ip will get you to that 326 -- point in the program. 327 328 procedure rv; 329 pragma No_Inline (rv); 330 -- This is a dummy function called by the processing for pragma Reviewable. 331 -- It is there for assisting front end debugging. By placing a Reviewable 332 -- pragma in the source program, a breakpoint on rv catches this place in 333 -- the source, allowing convenient stepping to the point of interest. 334 335 ------------------------------------------------------ 336 -- Table for Defer_Compile_Time_Warning_Error_To_BE -- 337 ------------------------------------------------------ 338 339 -- The following table collects pragmas Compile_Time_Error and Compile_ 340 -- Time_Warning for validation. Entries are made by calls to subprogram 341 -- Defer_Compile_Time_Warning_Error_To_BE, and the call to the procedure 342 -- Validate_Compile_Time_Warning_Errors does the actual error checking 343 -- and posting of warning and error messages. The reason for this delayed 344 -- processing is to take advantage of back-annotations of attributes size 345 -- and alignment values performed by the back end. 346 347 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is 348 -- that by the time Validate_Compile_Time_Warning_Errors is called, Sprint 349 -- will already have modified all Sloc values if the -gnatD option is set. 350 351 type CTWE_Entry is record 352 Eloc : Source_Ptr; 353 -- Source location used in warnings and error messages 354 355 Prag : Node_Id; 356 -- Pragma Compile_Time_Error or Compile_Time_Warning 357 358 Scope : Node_Id; 359 -- The scope which encloses the pragma 360 end record; 361 362 package Compile_Time_Warnings_Errors is new Table.Table ( 363 Table_Component_Type => CTWE_Entry, 364 Table_Index_Type => Int, 365 Table_Low_Bound => 1, 366 Table_Initial => 50, 367 Table_Increment => 200, 368 Table_Name => "Compile_Time_Warnings_Errors"); 369 370 ------------------------------- 371 -- Adjust_External_Name_Case -- 372 ------------------------------- 373 374 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is 375 CC : Char_Code; 376 377 begin 378 -- Adjust case of literal if required 379 380 if Opt.External_Name_Exp_Casing = As_Is then 381 return N; 382 383 else 384 -- Copy existing string 385 386 Start_String; 387 388 -- Set proper casing 389 390 for J in 1 .. String_Length (Strval (N)) loop 391 CC := Get_String_Char (Strval (N), J); 392 393 if Opt.External_Name_Exp_Casing = Uppercase 394 and then CC >= Get_Char_Code ('a') 395 and then CC <= Get_Char_Code ('z') 396 then 397 Store_String_Char (CC - 32); 398 399 elsif Opt.External_Name_Exp_Casing = Lowercase 400 and then CC >= Get_Char_Code ('A') 401 and then CC <= Get_Char_Code ('Z') 402 then 403 Store_String_Char (CC + 32); 404 405 else 406 Store_String_Char (CC); 407 end if; 408 end loop; 409 410 return 411 Make_String_Literal (Sloc (N), 412 Strval => End_String); 413 end if; 414 end Adjust_External_Name_Case; 415 416 ----------------------------------------- 417 -- Analyze_Contract_Cases_In_Decl_Part -- 418 ----------------------------------------- 419 420 -- WARNING: This routine manages Ghost regions. Return statements must be 421 -- replaced by gotos which jump to the end of the routine and restore the 422 -- Ghost mode. 423 424 procedure Analyze_Contract_Cases_In_Decl_Part 425 (N : Node_Id; 426 Freeze_Id : Entity_Id := Empty) 427 is 428 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 429 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 430 431 Others_Seen : Boolean := False; 432 -- This flag is set when an "others" choice is encountered. It is used 433 -- to detect multiple illegal occurrences of "others". 434 435 procedure Analyze_Contract_Case (CCase : Node_Id); 436 -- Verify the legality of a single contract case 437 438 --------------------------- 439 -- Analyze_Contract_Case -- 440 --------------------------- 441 442 procedure Analyze_Contract_Case (CCase : Node_Id) is 443 Case_Guard : Node_Id; 444 Conseq : Node_Id; 445 Errors : Nat; 446 Extra_Guard : Node_Id; 447 448 begin 449 if Nkind (CCase) = N_Component_Association then 450 Case_Guard := First (Choices (CCase)); 451 Conseq := Expression (CCase); 452 453 -- Each contract case must have exactly one case guard 454 455 Extra_Guard := Next (Case_Guard); 456 457 if Present (Extra_Guard) then 458 Error_Msg_N 459 ("contract case must have exactly one case guard", 460 Extra_Guard); 461 end if; 462 463 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1)) 464 465 if Nkind (Case_Guard) = N_Others_Choice then 466 if Others_Seen then 467 Error_Msg_N 468 ("only one others choice allowed in contract cases", 469 Case_Guard); 470 else 471 Others_Seen := True; 472 end if; 473 474 elsif Others_Seen then 475 Error_Msg_N 476 ("others must be the last choice in contract cases", N); 477 end if; 478 479 -- Preanalyze the case guard and consequence 480 481 if Nkind (Case_Guard) /= N_Others_Choice then 482 Errors := Serious_Errors_Detected; 483 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); 484 485 -- Emit a clarification message when the case guard contains 486 -- at least one undefined reference, possibly due to contract 487 -- freezing. 488 489 if Errors /= Serious_Errors_Detected 490 and then Present (Freeze_Id) 491 and then Has_Undefined_Reference (Case_Guard) 492 then 493 Contract_Freeze_Error (Spec_Id, Freeze_Id); 494 end if; 495 end if; 496 497 Errors := Serious_Errors_Detected; 498 Preanalyze_Assert_Expression (Conseq, Standard_Boolean); 499 500 -- Emit a clarification message when the consequence contains 501 -- at least one undefined reference, possibly due to contract 502 -- freezing. 503 504 if Errors /= Serious_Errors_Detected 505 and then Present (Freeze_Id) 506 and then Has_Undefined_Reference (Conseq) 507 then 508 Contract_Freeze_Error (Spec_Id, Freeze_Id); 509 end if; 510 511 -- The contract case is malformed 512 513 else 514 Error_Msg_N ("wrong syntax in contract case", CCase); 515 end if; 516 end Analyze_Contract_Case; 517 518 -- Local variables 519 520 CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 521 522 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 523 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 524 -- Save the Ghost-related attributes to restore on exit 525 526 CCase : Node_Id; 527 Restore_Scope : Boolean := False; 528 529 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part 530 531 begin 532 -- Do not analyze the pragma multiple times 533 534 if Is_Analyzed_Pragma (N) then 535 return; 536 end if; 537 538 -- Set the Ghost mode in effect from the pragma. Due to the delayed 539 -- analysis of the pragma, the Ghost mode at point of declaration and 540 -- point of analysis may not necessarily be the same. Use the mode in 541 -- effect at the point of declaration. 542 543 Set_Ghost_Mode (N); 544 545 -- Single and multiple contract cases must appear in aggregate form. If 546 -- this is not the case, then either the parser of the analysis of the 547 -- pragma failed to produce an aggregate. 548 549 pragma Assert (Nkind (CCases) = N_Aggregate); 550 551 if Present (Component_Associations (CCases)) then 552 553 -- Ensure that the formal parameters are visible when analyzing all 554 -- clauses. This falls out of the general rule of aspects pertaining 555 -- to subprogram declarations. 556 557 if not In_Open_Scopes (Spec_Id) then 558 Restore_Scope := True; 559 Push_Scope (Spec_Id); 560 561 if Is_Generic_Subprogram (Spec_Id) then 562 Install_Generic_Formals (Spec_Id); 563 else 564 Install_Formals (Spec_Id); 565 end if; 566 end if; 567 568 CCase := First (Component_Associations (CCases)); 569 while Present (CCase) loop 570 Analyze_Contract_Case (CCase); 571 Next (CCase); 572 end loop; 573 574 if Restore_Scope then 575 End_Scope; 576 end if; 577 578 -- Currently it is not possible to inline pre/postconditions on a 579 -- subprogram subject to pragma Inline_Always. 580 581 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 582 583 -- Otherwise the pragma is illegal 584 585 else 586 Error_Msg_N ("wrong syntax for constract cases", N); 587 end if; 588 589 Set_Is_Analyzed_Pragma (N); 590 591 Restore_Ghost_Region (Saved_GM, Saved_IGR); 592 end Analyze_Contract_Cases_In_Decl_Part; 593 594 ---------------------------------- 595 -- Analyze_Depends_In_Decl_Part -- 596 ---------------------------------- 597 598 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is 599 Loc : constant Source_Ptr := Sloc (N); 600 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 601 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 602 603 All_Inputs_Seen : Elist_Id := No_Elist; 604 -- A list containing the entities of all the inputs processed so far. 605 -- The list is populated with unique entities because the same input 606 -- may appear in multiple input lists. 607 608 All_Outputs_Seen : Elist_Id := No_Elist; 609 -- A list containing the entities of all the outputs processed so far. 610 -- The list is populated with unique entities because output items are 611 -- unique in a dependence relation. 612 613 Constits_Seen : Elist_Id := No_Elist; 614 -- A list containing the entities of all constituents processed so far. 615 -- It aids in detecting illegal usage of a state and a corresponding 616 -- constituent in pragma [Refinde_]Depends. 617 618 Global_Seen : Boolean := False; 619 -- A flag set when pragma Global has been processed 620 621 Null_Output_Seen : Boolean := False; 622 -- A flag used to track the legality of a null output 623 624 Result_Seen : Boolean := False; 625 -- A flag set when Spec_Id'Result is processed 626 627 States_Seen : Elist_Id := No_Elist; 628 -- A list containing the entities of all states processed so far. It 629 -- helps in detecting illegal usage of a state and a corresponding 630 -- constituent in pragma [Refined_]Depends. 631 632 Subp_Inputs : Elist_Id := No_Elist; 633 Subp_Outputs : Elist_Id := No_Elist; 634 -- Two lists containing the full set of inputs and output of the related 635 -- subprograms. Note that these lists contain both nodes and entities. 636 637 Task_Input_Seen : Boolean := False; 638 Task_Output_Seen : Boolean := False; 639 -- Flags used to track the implicit dependence of a task unit on itself 640 641 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id); 642 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind 643 -- to the name buffer. The individual kinds are as follows: 644 -- E_Abstract_State - "state" 645 -- E_Constant - "constant" 646 -- E_Generic_In_Out_Parameter - "generic parameter" 647 -- E_Generic_In_Parameter - "generic parameter" 648 -- E_In_Parameter - "parameter" 649 -- E_In_Out_Parameter - "parameter" 650 -- E_Loop_Parameter - "loop parameter" 651 -- E_Out_Parameter - "parameter" 652 -- E_Protected_Type - "current instance of protected type" 653 -- E_Task_Type - "current instance of task type" 654 -- E_Variable - "global" 655 656 procedure Analyze_Dependency_Clause 657 (Clause : Node_Id; 658 Is_Last : Boolean); 659 -- Verify the legality of a single dependency clause. Flag Is_Last 660 -- denotes whether Clause is the last clause in the relation. 661 662 procedure Check_Function_Return; 663 -- Verify that Funtion'Result appears as one of the outputs 664 -- (SPARK RM 6.1.5(10)). 665 666 procedure Check_Role 667 (Item : Node_Id; 668 Item_Id : Entity_Id; 669 Is_Input : Boolean; 670 Self_Ref : Boolean); 671 -- Ensure that an item fulfills its designated input and/or output role 672 -- as specified by pragma Global (if any) or the enclosing context. If 673 -- this is not the case, emit an error. Item and Item_Id denote the 674 -- attributes of an item. Flag Is_Input should be set when item comes 675 -- from an input list. Flag Self_Ref should be set when the item is an 676 -- output and the dependency clause has operator "+". 677 678 procedure Check_Usage 679 (Subp_Items : Elist_Id; 680 Used_Items : Elist_Id; 681 Is_Input : Boolean); 682 -- Verify that all items from Subp_Items appear in Used_Items. Emit an 683 -- error if this is not the case. 684 685 procedure Normalize_Clause (Clause : Node_Id); 686 -- Remove a self-dependency "+" from the input list of a clause 687 688 ----------------------------- 689 -- Add_Item_To_Name_Buffer -- 690 ----------------------------- 691 692 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is 693 begin 694 if Ekind (Item_Id) = E_Abstract_State then 695 Add_Str_To_Name_Buffer ("state"); 696 697 elsif Ekind (Item_Id) = E_Constant then 698 Add_Str_To_Name_Buffer ("constant"); 699 700 elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, 701 E_Generic_In_Parameter) 702 then 703 Add_Str_To_Name_Buffer ("generic parameter"); 704 705 elsif Is_Formal (Item_Id) then 706 Add_Str_To_Name_Buffer ("parameter"); 707 708 elsif Ekind (Item_Id) = E_Loop_Parameter then 709 Add_Str_To_Name_Buffer ("loop parameter"); 710 711 elsif Ekind (Item_Id) = E_Protected_Type 712 or else Is_Single_Protected_Object (Item_Id) 713 then 714 Add_Str_To_Name_Buffer ("current instance of protected type"); 715 716 elsif Ekind (Item_Id) = E_Task_Type 717 or else Is_Single_Task_Object (Item_Id) 718 then 719 Add_Str_To_Name_Buffer ("current instance of task type"); 720 721 elsif Ekind (Item_Id) = E_Variable then 722 Add_Str_To_Name_Buffer ("global"); 723 724 -- The routine should not be called with non-SPARK items 725 726 else 727 raise Program_Error; 728 end if; 729 end Add_Item_To_Name_Buffer; 730 731 ------------------------------- 732 -- Analyze_Dependency_Clause -- 733 ------------------------------- 734 735 procedure Analyze_Dependency_Clause 736 (Clause : Node_Id; 737 Is_Last : Boolean) 738 is 739 procedure Analyze_Input_List (Inputs : Node_Id); 740 -- Verify the legality of a single input list 741 742 procedure Analyze_Input_Output 743 (Item : Node_Id; 744 Is_Input : Boolean; 745 Self_Ref : Boolean; 746 Top_Level : Boolean; 747 Seen : in out Elist_Id; 748 Null_Seen : in out Boolean; 749 Non_Null_Seen : in out Boolean); 750 -- Verify the legality of a single input or output item. Flag 751 -- Is_Input should be set whenever Item is an input, False when it 752 -- denotes an output. Flag Self_Ref should be set when the item is an 753 -- output and the dependency clause has a "+". Flag Top_Level should 754 -- be set whenever Item appears immediately within an input or output 755 -- list. Seen is a collection of all abstract states, objects and 756 -- formals processed so far. Flag Null_Seen denotes whether a null 757 -- input or output has been encountered. Flag Non_Null_Seen denotes 758 -- whether a non-null input or output has been encountered. 759 760 ------------------------ 761 -- Analyze_Input_List -- 762 ------------------------ 763 764 procedure Analyze_Input_List (Inputs : Node_Id) is 765 Inputs_Seen : Elist_Id := No_Elist; 766 -- A list containing the entities of all inputs that appear in the 767 -- current input list. 768 769 Non_Null_Input_Seen : Boolean := False; 770 Null_Input_Seen : Boolean := False; 771 -- Flags used to check the legality of an input list 772 773 Input : Node_Id; 774 775 begin 776 -- Multiple inputs appear as an aggregate 777 778 if Nkind (Inputs) = N_Aggregate then 779 if Present (Component_Associations (Inputs)) then 780 SPARK_Msg_N 781 ("nested dependency relations not allowed", Inputs); 782 783 elsif Present (Expressions (Inputs)) then 784 Input := First (Expressions (Inputs)); 785 while Present (Input) loop 786 Analyze_Input_Output 787 (Item => Input, 788 Is_Input => True, 789 Self_Ref => False, 790 Top_Level => False, 791 Seen => Inputs_Seen, 792 Null_Seen => Null_Input_Seen, 793 Non_Null_Seen => Non_Null_Input_Seen); 794 795 Next (Input); 796 end loop; 797 798 -- Syntax error, always report 799 800 else 801 Error_Msg_N ("malformed input dependency list", Inputs); 802 end if; 803 804 -- Process a solitary input 805 806 else 807 Analyze_Input_Output 808 (Item => Inputs, 809 Is_Input => True, 810 Self_Ref => False, 811 Top_Level => False, 812 Seen => Inputs_Seen, 813 Null_Seen => Null_Input_Seen, 814 Non_Null_Seen => Non_Null_Input_Seen); 815 end if; 816 817 -- Detect an illegal dependency clause of the form 818 819 -- (null =>[+] null) 820 821 if Null_Output_Seen and then Null_Input_Seen then 822 SPARK_Msg_N 823 ("null dependency clause cannot have a null input list", 824 Inputs); 825 end if; 826 end Analyze_Input_List; 827 828 -------------------------- 829 -- Analyze_Input_Output -- 830 -------------------------- 831 832 procedure Analyze_Input_Output 833 (Item : Node_Id; 834 Is_Input : Boolean; 835 Self_Ref : Boolean; 836 Top_Level : Boolean; 837 Seen : in out Elist_Id; 838 Null_Seen : in out Boolean; 839 Non_Null_Seen : in out Boolean) 840 is 841 procedure Current_Task_Instance_Seen; 842 -- Set the appropriate global flag when the current instance of a 843 -- task unit is encountered. 844 845 -------------------------------- 846 -- Current_Task_Instance_Seen -- 847 -------------------------------- 848 849 procedure Current_Task_Instance_Seen is 850 begin 851 if Is_Input then 852 Task_Input_Seen := True; 853 else 854 Task_Output_Seen := True; 855 end if; 856 end Current_Task_Instance_Seen; 857 858 -- Local variables 859 860 Is_Output : constant Boolean := not Is_Input; 861 Grouped : Node_Id; 862 Item_Id : Entity_Id; 863 864 -- Start of processing for Analyze_Input_Output 865 866 begin 867 -- Multiple input or output items appear as an aggregate 868 869 if Nkind (Item) = N_Aggregate then 870 if not Top_Level then 871 SPARK_Msg_N ("nested grouping of items not allowed", Item); 872 873 elsif Present (Component_Associations (Item)) then 874 SPARK_Msg_N 875 ("nested dependency relations not allowed", Item); 876 877 -- Recursively analyze the grouped items 878 879 elsif Present (Expressions (Item)) then 880 Grouped := First (Expressions (Item)); 881 while Present (Grouped) loop 882 Analyze_Input_Output 883 (Item => Grouped, 884 Is_Input => Is_Input, 885 Self_Ref => Self_Ref, 886 Top_Level => False, 887 Seen => Seen, 888 Null_Seen => Null_Seen, 889 Non_Null_Seen => Non_Null_Seen); 890 891 Next (Grouped); 892 end loop; 893 894 -- Syntax error, always report 895 896 else 897 Error_Msg_N ("malformed dependency list", Item); 898 end if; 899 900 -- Process attribute 'Result in the context of a dependency clause 901 902 elsif Is_Attribute_Result (Item) then 903 Non_Null_Seen := True; 904 905 Analyze (Item); 906 907 -- Attribute 'Result is allowed to appear on the output side of 908 -- a dependency clause (SPARK RM 6.1.5(6)). 909 910 if Is_Input then 911 SPARK_Msg_N ("function result cannot act as input", Item); 912 913 elsif Null_Seen then 914 SPARK_Msg_N 915 ("cannot mix null and non-null dependency items", Item); 916 917 else 918 Result_Seen := True; 919 end if; 920 921 -- Detect multiple uses of null in a single dependency list or 922 -- throughout the whole relation. Verify the placement of a null 923 -- output list relative to the other clauses (SPARK RM 6.1.5(12)). 924 925 elsif Nkind (Item) = N_Null then 926 if Null_Seen then 927 SPARK_Msg_N 928 ("multiple null dependency relations not allowed", Item); 929 930 elsif Non_Null_Seen then 931 SPARK_Msg_N 932 ("cannot mix null and non-null dependency items", Item); 933 934 else 935 Null_Seen := True; 936 937 if Is_Output then 938 if not Is_Last then 939 SPARK_Msg_N 940 ("null output list must be the last clause in a " 941 & "dependency relation", Item); 942 943 -- Catch a useless dependence of the form: 944 -- null =>+ ... 945 946 elsif Self_Ref then 947 SPARK_Msg_N 948 ("useless dependence, null depends on itself", Item); 949 end if; 950 end if; 951 end if; 952 953 -- Default case 954 955 else 956 Non_Null_Seen := True; 957 958 if Null_Seen then 959 SPARK_Msg_N ("cannot mix null and non-null items", Item); 960 end if; 961 962 Analyze (Item); 963 Resolve_State (Item); 964 965 -- Find the entity of the item. If this is a renaming, climb 966 -- the renaming chain to reach the root object. Renamings of 967 -- non-entire objects do not yield an entity (Empty). 968 969 Item_Id := Entity_Of (Item); 970 971 if Present (Item_Id) then 972 973 -- Constants 974 975 if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter) 976 or else 977 978 -- Current instances of concurrent types 979 980 Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) 981 or else 982 983 -- Formal parameters 984 985 Ekind_In (Item_Id, E_Generic_In_Out_Parameter, 986 E_Generic_In_Parameter, 987 E_In_Parameter, 988 E_In_Out_Parameter, 989 E_Out_Parameter) 990 or else 991 992 -- States, variables 993 994 Ekind_In (Item_Id, E_Abstract_State, E_Variable) 995 then 996 -- A [generic] function is not allowed to have Output 997 -- items in its dependency relations. Note that "null" 998 -- and attribute 'Result are still valid items. 999 1000 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 1001 and then not Is_Input 1002 then 1003 SPARK_Msg_N 1004 ("output item is not applicable to function", Item); 1005 end if; 1006 1007 -- The item denotes a concurrent type. Note that single 1008 -- protected/task types are not considered here because 1009 -- they behave as objects in the context of pragma 1010 -- [Refined_]Depends. 1011 1012 if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then 1013 1014 -- This use is legal as long as the concurrent type is 1015 -- the current instance of an enclosing type. 1016 1017 if Is_CCT_Instance (Item_Id, Spec_Id) then 1018 1019 -- The dependence of a task unit on itself is 1020 -- implicit and may or may not be explicitly 1021 -- specified (SPARK RM 6.1.4). 1022 1023 if Ekind (Item_Id) = E_Task_Type then 1024 Current_Task_Instance_Seen; 1025 end if; 1026 1027 -- Otherwise this is not the current instance 1028 1029 else 1030 SPARK_Msg_N 1031 ("invalid use of subtype mark in dependency " 1032 & "relation", Item); 1033 end if; 1034 1035 -- The dependency of a task unit on itself is implicit 1036 -- and may or may not be explicitly specified 1037 -- (SPARK RM 6.1.4). 1038 1039 elsif Is_Single_Task_Object (Item_Id) 1040 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id) 1041 then 1042 Current_Task_Instance_Seen; 1043 end if; 1044 1045 -- Ensure that the item fulfills its role as input and/or 1046 -- output as specified by pragma Global or the enclosing 1047 -- context. 1048 1049 Check_Role (Item, Item_Id, Is_Input, Self_Ref); 1050 1051 -- Detect multiple uses of the same state, variable or 1052 -- formal parameter. If this is not the case, add the 1053 -- item to the list of processed relations. 1054 1055 if Contains (Seen, Item_Id) then 1056 SPARK_Msg_NE 1057 ("duplicate use of item &", Item, Item_Id); 1058 else 1059 Append_New_Elmt (Item_Id, Seen); 1060 end if; 1061 1062 -- Detect illegal use of an input related to a null 1063 -- output. Such input items cannot appear in other 1064 -- input lists (SPARK RM 6.1.5(13)). 1065 1066 if Is_Input 1067 and then Null_Output_Seen 1068 and then Contains (All_Inputs_Seen, Item_Id) 1069 then 1070 SPARK_Msg_N 1071 ("input of a null output list cannot appear in " 1072 & "multiple input lists", Item); 1073 end if; 1074 1075 -- Add an input or a self-referential output to the list 1076 -- of all processed inputs. 1077 1078 if Is_Input or else Self_Ref then 1079 Append_New_Elmt (Item_Id, All_Inputs_Seen); 1080 end if; 1081 1082 -- State related checks (SPARK RM 6.1.5(3)) 1083 1084 if Ekind (Item_Id) = E_Abstract_State then 1085 1086 -- Package and subprogram bodies are instantiated 1087 -- individually in a separate compiler pass. Due to 1088 -- this mode of instantiation, the refinement of a 1089 -- state may no longer be visible when a subprogram 1090 -- body contract is instantiated. Since the generic 1091 -- template is legal, do not perform this check in 1092 -- the instance to circumvent this oddity. 1093 1094 if In_Instance then 1095 null; 1096 1097 -- An abstract state with visible refinement cannot 1098 -- appear in pragma [Refined_]Depends as its place 1099 -- must be taken by some of its constituents 1100 -- (SPARK RM 6.1.4(7)). 1101 1102 elsif Has_Visible_Refinement (Item_Id) then 1103 SPARK_Msg_NE 1104 ("cannot mention state & in dependence relation", 1105 Item, Item_Id); 1106 SPARK_Msg_N ("\use its constituents instead", Item); 1107 return; 1108 1109 -- If the reference to the abstract state appears in 1110 -- an enclosing package body that will eventually 1111 -- refine the state, record the reference for future 1112 -- checks. 1113 1114 else 1115 Record_Possible_Body_Reference 1116 (State_Id => Item_Id, 1117 Ref => Item); 1118 end if; 1119 end if; 1120 1121 -- When the item renames an entire object, replace the 1122 -- item with a reference to the object. 1123 1124 if Entity (Item) /= Item_Id then 1125 Rewrite (Item, 1126 New_Occurrence_Of (Item_Id, Sloc (Item))); 1127 Analyze (Item); 1128 end if; 1129 1130 -- Add the entity of the current item to the list of 1131 -- processed items. 1132 1133 if Ekind (Item_Id) = E_Abstract_State then 1134 Append_New_Elmt (Item_Id, States_Seen); 1135 1136 -- The variable may eventually become a constituent of a 1137 -- single protected/task type. Record the reference now 1138 -- and verify its legality when analyzing the contract of 1139 -- the variable (SPARK RM 9.3). 1140 1141 elsif Ekind (Item_Id) = E_Variable then 1142 Record_Possible_Part_Of_Reference 1143 (Var_Id => Item_Id, 1144 Ref => Item); 1145 end if; 1146 1147 if Ekind_In (Item_Id, E_Abstract_State, 1148 E_Constant, 1149 E_Variable) 1150 and then Present (Encapsulating_State (Item_Id)) 1151 then 1152 Append_New_Elmt (Item_Id, Constits_Seen); 1153 end if; 1154 1155 -- All other input/output items are illegal 1156 -- (SPARK RM 6.1.5(1)). 1157 1158 else 1159 SPARK_Msg_N 1160 ("item must denote parameter, variable, state or " 1161 & "current instance of concurrent type", Item); 1162 end if; 1163 1164 -- All other input/output items are illegal 1165 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report. 1166 1167 else 1168 Error_Msg_N 1169 ("item must denote parameter, variable, state or current " 1170 & "instance of concurrent type", Item); 1171 end if; 1172 end if; 1173 end Analyze_Input_Output; 1174 1175 -- Local variables 1176 1177 Inputs : Node_Id; 1178 Output : Node_Id; 1179 Self_Ref : Boolean; 1180 1181 Non_Null_Output_Seen : Boolean := False; 1182 -- Flag used to check the legality of an output list 1183 1184 -- Start of processing for Analyze_Dependency_Clause 1185 1186 begin 1187 Inputs := Expression (Clause); 1188 Self_Ref := False; 1189 1190 -- An input list with a self-dependency appears as operator "+" where 1191 -- the actuals inputs are the right operand. 1192 1193 if Nkind (Inputs) = N_Op_Plus then 1194 Inputs := Right_Opnd (Inputs); 1195 Self_Ref := True; 1196 end if; 1197 1198 -- Process the output_list of a dependency_clause 1199 1200 Output := First (Choices (Clause)); 1201 while Present (Output) loop 1202 Analyze_Input_Output 1203 (Item => Output, 1204 Is_Input => False, 1205 Self_Ref => Self_Ref, 1206 Top_Level => True, 1207 Seen => All_Outputs_Seen, 1208 Null_Seen => Null_Output_Seen, 1209 Non_Null_Seen => Non_Null_Output_Seen); 1210 1211 Next (Output); 1212 end loop; 1213 1214 -- Process the input_list of a dependency_clause 1215 1216 Analyze_Input_List (Inputs); 1217 end Analyze_Dependency_Clause; 1218 1219 --------------------------- 1220 -- Check_Function_Return -- 1221 --------------------------- 1222 1223 procedure Check_Function_Return is 1224 begin 1225 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 1226 and then not Result_Seen 1227 then 1228 SPARK_Msg_NE 1229 ("result of & must appear in exactly one output list", 1230 N, Spec_Id); 1231 end if; 1232 end Check_Function_Return; 1233 1234 ---------------- 1235 -- Check_Role -- 1236 ---------------- 1237 1238 procedure Check_Role 1239 (Item : Node_Id; 1240 Item_Id : Entity_Id; 1241 Is_Input : Boolean; 1242 Self_Ref : Boolean) 1243 is 1244 procedure Find_Role 1245 (Item_Is_Input : out Boolean; 1246 Item_Is_Output : out Boolean); 1247 -- Find the input/output role of Item_Id. Flags Item_Is_Input and 1248 -- Item_Is_Output are set depending on the role. 1249 1250 procedure Role_Error 1251 (Item_Is_Input : Boolean; 1252 Item_Is_Output : Boolean); 1253 -- Emit an error message concerning the incorrect use of Item in 1254 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output 1255 -- denote whether the item is an input and/or an output. 1256 1257 --------------- 1258 -- Find_Role -- 1259 --------------- 1260 1261 procedure Find_Role 1262 (Item_Is_Input : out Boolean; 1263 Item_Is_Output : out Boolean) 1264 is 1265 -- A constant or IN parameter of access type should be handled 1266 -- like a variable, as the underlying memory pointed-to can be 1267 -- modified. Use Adjusted_Kind to do this adjustment. 1268 1269 Adjusted_Kind : Entity_Kind := Ekind (Item_Id); 1270 1271 begin 1272 if Ekind_In (Item_Id, E_Constant, 1273 E_Generic_In_Parameter, 1274 E_In_Parameter) 1275 and then Is_Access_Type (Etype (Item_Id)) 1276 then 1277 Adjusted_Kind := E_Variable; 1278 end if; 1279 1280 case Adjusted_Kind is 1281 1282 -- Abstract states 1283 1284 when E_Abstract_State => 1285 1286 -- When pragma Global is present it determines the mode of 1287 -- the abstract state. 1288 1289 if Global_Seen then 1290 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id); 1291 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1292 1293 -- Otherwise the state has a default IN OUT mode, because it 1294 -- behaves as a variable. 1295 1296 else 1297 Item_Is_Input := True; 1298 Item_Is_Output := True; 1299 end if; 1300 1301 -- Constants and IN parameters 1302 1303 when E_Constant 1304 | E_Generic_In_Parameter 1305 | E_In_Parameter 1306 | E_Loop_Parameter 1307 => 1308 -- When pragma Global is present it determines the mode 1309 -- of constant objects as inputs (and such objects cannot 1310 -- appear as outputs in the Global contract). 1311 1312 if Global_Seen then 1313 Item_Is_Input := Appears_In (Subp_Inputs, Item_Id); 1314 else 1315 Item_Is_Input := True; 1316 end if; 1317 1318 Item_Is_Output := False; 1319 1320 -- Variables and IN OUT parameters, as well as constants and 1321 -- IN parameters of access type which are handled like 1322 -- variables. 1323 1324 when E_Generic_In_Out_Parameter 1325 | E_In_Out_Parameter 1326 | E_Variable 1327 => 1328 -- When pragma Global is present it determines the mode of 1329 -- the object. 1330 1331 if Global_Seen then 1332 1333 -- A variable has mode IN when its type is unconstrained 1334 -- or tagged because array bounds, discriminants or tags 1335 -- can be read. 1336 1337 Item_Is_Input := 1338 Appears_In (Subp_Inputs, Item_Id) 1339 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1340 1341 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1342 1343 -- Otherwise the variable has a default IN OUT mode 1344 1345 else 1346 Item_Is_Input := True; 1347 Item_Is_Output := True; 1348 end if; 1349 1350 when E_Out_Parameter => 1351 1352 -- An OUT parameter of the related subprogram; it cannot 1353 -- appear in Global. 1354 1355 if Scope (Item_Id) = Spec_Id then 1356 1357 -- The parameter has mode IN if its type is unconstrained 1358 -- or tagged because array bounds, discriminants or tags 1359 -- can be read. 1360 1361 Item_Is_Input := 1362 Is_Unconstrained_Or_Tagged_Item (Item_Id); 1363 1364 Item_Is_Output := True; 1365 1366 -- An OUT parameter of an enclosing subprogram; it can 1367 -- appear in Global and behaves as a read-write variable. 1368 1369 else 1370 -- When pragma Global is present it determines the mode 1371 -- of the object. 1372 1373 if Global_Seen then 1374 1375 -- A variable has mode IN when its type is 1376 -- unconstrained or tagged because array 1377 -- bounds, discriminants or tags can be read. 1378 1379 Item_Is_Input := 1380 Appears_In (Subp_Inputs, Item_Id) 1381 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1382 1383 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1384 1385 -- Otherwise the variable has a default IN OUT mode 1386 1387 else 1388 Item_Is_Input := True; 1389 Item_Is_Output := True; 1390 end if; 1391 end if; 1392 1393 -- Protected types 1394 1395 when E_Protected_Type => 1396 if Global_Seen then 1397 1398 -- A variable has mode IN when its type is unconstrained 1399 -- or tagged because array bounds, discriminants or tags 1400 -- can be read. 1401 1402 Item_Is_Input := 1403 Appears_In (Subp_Inputs, Item_Id) 1404 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1405 1406 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1407 1408 else 1409 -- A protected type acts as a formal parameter of mode IN 1410 -- when it applies to a protected function. 1411 1412 if Ekind (Spec_Id) = E_Function then 1413 Item_Is_Input := True; 1414 Item_Is_Output := False; 1415 1416 -- Otherwise the protected type acts as a formal of mode 1417 -- IN OUT. 1418 1419 else 1420 Item_Is_Input := True; 1421 Item_Is_Output := True; 1422 end if; 1423 end if; 1424 1425 -- Task types 1426 1427 when E_Task_Type => 1428 1429 -- When pragma Global is present it determines the mode of 1430 -- the object. 1431 1432 if Global_Seen then 1433 Item_Is_Input := 1434 Appears_In (Subp_Inputs, Item_Id) 1435 or else Is_Unconstrained_Or_Tagged_Item (Item_Id); 1436 1437 Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); 1438 1439 -- Otherwise task types act as IN OUT parameters 1440 1441 else 1442 Item_Is_Input := True; 1443 Item_Is_Output := True; 1444 end if; 1445 1446 when others => 1447 raise Program_Error; 1448 end case; 1449 end Find_Role; 1450 1451 ---------------- 1452 -- Role_Error -- 1453 ---------------- 1454 1455 procedure Role_Error 1456 (Item_Is_Input : Boolean; 1457 Item_Is_Output : Boolean) 1458 is 1459 Error_Msg : Name_Id; 1460 1461 begin 1462 Name_Len := 0; 1463 1464 -- When the item is not part of the input and the output set of 1465 -- the related subprogram, then it appears as extra in pragma 1466 -- [Refined_]Depends. 1467 1468 if not Item_Is_Input and then not Item_Is_Output then 1469 Add_Item_To_Name_Buffer (Item_Id); 1470 Add_Str_To_Name_Buffer 1471 (" & cannot appear in dependence relation"); 1472 1473 Error_Msg := Name_Find; 1474 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1475 1476 Error_Msg_Name_1 := Chars (Spec_Id); 1477 SPARK_Msg_NE 1478 (Fix_Msg (Spec_Id, "\& is not part of the input or output " 1479 & "set of subprogram %"), Item, Item_Id); 1480 1481 -- The mode of the item and its role in pragma [Refined_]Depends 1482 -- are in conflict. Construct a detailed message explaining the 1483 -- illegality (SPARK RM 6.1.5(5-6)). 1484 1485 else 1486 if Item_Is_Input then 1487 Add_Str_To_Name_Buffer ("read-only"); 1488 else 1489 Add_Str_To_Name_Buffer ("write-only"); 1490 end if; 1491 1492 Add_Char_To_Name_Buffer (' '); 1493 Add_Item_To_Name_Buffer (Item_Id); 1494 Add_Str_To_Name_Buffer (" & cannot appear as "); 1495 1496 if Item_Is_Input then 1497 Add_Str_To_Name_Buffer ("output"); 1498 else 1499 Add_Str_To_Name_Buffer ("input"); 1500 end if; 1501 1502 Add_Str_To_Name_Buffer (" in dependence relation"); 1503 Error_Msg := Name_Find; 1504 SPARK_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1505 end if; 1506 end Role_Error; 1507 1508 -- Local variables 1509 1510 Item_Is_Input : Boolean; 1511 Item_Is_Output : Boolean; 1512 1513 -- Start of processing for Check_Role 1514 1515 begin 1516 Find_Role (Item_Is_Input, Item_Is_Output); 1517 1518 -- Input item 1519 1520 if Is_Input then 1521 if not Item_Is_Input then 1522 Role_Error (Item_Is_Input, Item_Is_Output); 1523 end if; 1524 1525 -- Self-referential item 1526 1527 elsif Self_Ref then 1528 if not Item_Is_Input or else not Item_Is_Output then 1529 Role_Error (Item_Is_Input, Item_Is_Output); 1530 end if; 1531 1532 -- Output item 1533 1534 elsif not Item_Is_Output then 1535 Role_Error (Item_Is_Input, Item_Is_Output); 1536 end if; 1537 end Check_Role; 1538 1539 ----------------- 1540 -- Check_Usage -- 1541 ----------------- 1542 1543 procedure Check_Usage 1544 (Subp_Items : Elist_Id; 1545 Used_Items : Elist_Id; 1546 Is_Input : Boolean) 1547 is 1548 procedure Usage_Error (Item_Id : Entity_Id); 1549 -- Emit an error concerning the illegal usage of an item 1550 1551 ----------------- 1552 -- Usage_Error -- 1553 ----------------- 1554 1555 procedure Usage_Error (Item_Id : Entity_Id) is 1556 Error_Msg : Name_Id; 1557 1558 begin 1559 -- Input case 1560 1561 if Is_Input then 1562 1563 -- Unconstrained and tagged items are not part of the explicit 1564 -- input set of the related subprogram, they do not have to be 1565 -- present in a dependence relation and should not be flagged 1566 -- (SPARK RM 6.1.5(5)). 1567 1568 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then 1569 Name_Len := 0; 1570 1571 Add_Item_To_Name_Buffer (Item_Id); 1572 Add_Str_To_Name_Buffer 1573 (" & is missing from input dependence list"); 1574 1575 Error_Msg := Name_Find; 1576 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); 1577 SPARK_Msg_NE 1578 ("\add `null ='> &` dependency to ignore this input", 1579 N, Item_Id); 1580 end if; 1581 1582 -- Output case (SPARK RM 6.1.5(10)) 1583 1584 else 1585 Name_Len := 0; 1586 1587 Add_Item_To_Name_Buffer (Item_Id); 1588 Add_Str_To_Name_Buffer 1589 (" & is missing from output dependence list"); 1590 1591 Error_Msg := Name_Find; 1592 SPARK_Msg_NE (Get_Name_String (Error_Msg), N, Item_Id); 1593 end if; 1594 end Usage_Error; 1595 1596 -- Local variables 1597 1598 Elmt : Elmt_Id; 1599 Item : Node_Id; 1600 Item_Id : Entity_Id; 1601 1602 -- Start of processing for Check_Usage 1603 1604 begin 1605 if No (Subp_Items) then 1606 return; 1607 end if; 1608 1609 -- Each input or output of the subprogram must appear in a dependency 1610 -- relation. 1611 1612 Elmt := First_Elmt (Subp_Items); 1613 while Present (Elmt) loop 1614 Item := Node (Elmt); 1615 1616 if Nkind (Item) = N_Defining_Identifier then 1617 Item_Id := Item; 1618 else 1619 Item_Id := Entity_Of (Item); 1620 end if; 1621 1622 -- The item does not appear in a dependency 1623 1624 if Present (Item_Id) 1625 and then not Contains (Used_Items, Item_Id) 1626 then 1627 if Is_Formal (Item_Id) then 1628 Usage_Error (Item_Id); 1629 1630 -- The current instance of a protected type behaves as a formal 1631 -- parameter (SPARK RM 6.1.4). 1632 1633 elsif Ekind (Item_Id) = E_Protected_Type 1634 or else Is_Single_Protected_Object (Item_Id) 1635 then 1636 Usage_Error (Item_Id); 1637 1638 -- The current instance of a task type behaves as a formal 1639 -- parameter (SPARK RM 6.1.4). 1640 1641 elsif Ekind (Item_Id) = E_Task_Type 1642 or else Is_Single_Task_Object (Item_Id) 1643 then 1644 -- The dependence of a task unit on itself is implicit and 1645 -- may or may not be explicitly specified (SPARK RM 6.1.4). 1646 -- Emit an error if only one input/output is present. 1647 1648 if Task_Input_Seen /= Task_Output_Seen then 1649 Usage_Error (Item_Id); 1650 end if; 1651 1652 -- States and global objects are not used properly only when 1653 -- the subprogram is subject to pragma Global. 1654 1655 elsif Global_Seen then 1656 Usage_Error (Item_Id); 1657 end if; 1658 end if; 1659 1660 Next_Elmt (Elmt); 1661 end loop; 1662 end Check_Usage; 1663 1664 ---------------------- 1665 -- Normalize_Clause -- 1666 ---------------------- 1667 1668 procedure Normalize_Clause (Clause : Node_Id) is 1669 procedure Create_Or_Modify_Clause 1670 (Output : Node_Id; 1671 Outputs : Node_Id; 1672 Inputs : Node_Id; 1673 After : Node_Id; 1674 In_Place : Boolean; 1675 Multiple : Boolean); 1676 -- Create a brand new clause to represent the self-reference or 1677 -- modify the input and/or output lists of an existing clause. Output 1678 -- denotes a self-referencial output. Outputs is the output list of a 1679 -- clause. Inputs is the input list of a clause. After denotes the 1680 -- clause after which the new clause is to be inserted. Flag In_Place 1681 -- should be set when normalizing the last output of an output list. 1682 -- Flag Multiple should be set when Output comes from a list with 1683 -- multiple items. 1684 1685 ----------------------------- 1686 -- Create_Or_Modify_Clause -- 1687 ----------------------------- 1688 1689 procedure Create_Or_Modify_Clause 1690 (Output : Node_Id; 1691 Outputs : Node_Id; 1692 Inputs : Node_Id; 1693 After : Node_Id; 1694 In_Place : Boolean; 1695 Multiple : Boolean) 1696 is 1697 procedure Propagate_Output 1698 (Output : Node_Id; 1699 Inputs : Node_Id); 1700 -- Handle the various cases of output propagation to the input 1701 -- list. Output denotes a self-referencial output item. Inputs 1702 -- is the input list of a clause. 1703 1704 ---------------------- 1705 -- Propagate_Output -- 1706 ---------------------- 1707 1708 procedure Propagate_Output 1709 (Output : Node_Id; 1710 Inputs : Node_Id) 1711 is 1712 function In_Input_List 1713 (Item : Entity_Id; 1714 Inputs : List_Id) return Boolean; 1715 -- Determine whether a particulat item appears in the input 1716 -- list of a clause. 1717 1718 ------------------- 1719 -- In_Input_List -- 1720 ------------------- 1721 1722 function In_Input_List 1723 (Item : Entity_Id; 1724 Inputs : List_Id) return Boolean 1725 is 1726 Elmt : Node_Id; 1727 1728 begin 1729 Elmt := First (Inputs); 1730 while Present (Elmt) loop 1731 if Entity_Of (Elmt) = Item then 1732 return True; 1733 end if; 1734 1735 Next (Elmt); 1736 end loop; 1737 1738 return False; 1739 end In_Input_List; 1740 1741 -- Local variables 1742 1743 Output_Id : constant Entity_Id := Entity_Of (Output); 1744 Grouped : List_Id; 1745 1746 -- Start of processing for Propagate_Output 1747 1748 begin 1749 -- The clause is of the form: 1750 1751 -- (Output =>+ null) 1752 1753 -- Remove null input and replace it with a copy of the output: 1754 1755 -- (Output => Output) 1756 1757 if Nkind (Inputs) = N_Null then 1758 Rewrite (Inputs, New_Copy_Tree (Output)); 1759 1760 -- The clause is of the form: 1761 1762 -- (Output =>+ (Input1, ..., InputN)) 1763 1764 -- Determine whether the output is not already mentioned in the 1765 -- input list and if not, add it to the list of inputs: 1766 1767 -- (Output => (Output, Input1, ..., InputN)) 1768 1769 elsif Nkind (Inputs) = N_Aggregate then 1770 Grouped := Expressions (Inputs); 1771 1772 if not In_Input_List 1773 (Item => Output_Id, 1774 Inputs => Grouped) 1775 then 1776 Prepend_To (Grouped, New_Copy_Tree (Output)); 1777 end if; 1778 1779 -- The clause is of the form: 1780 1781 -- (Output =>+ Input) 1782 1783 -- If the input does not mention the output, group the two 1784 -- together: 1785 1786 -- (Output => (Output, Input)) 1787 1788 elsif Entity_Of (Inputs) /= Output_Id then 1789 Rewrite (Inputs, 1790 Make_Aggregate (Loc, 1791 Expressions => New_List ( 1792 New_Copy_Tree (Output), 1793 New_Copy_Tree (Inputs)))); 1794 end if; 1795 end Propagate_Output; 1796 1797 -- Local variables 1798 1799 Loc : constant Source_Ptr := Sloc (Clause); 1800 New_Clause : Node_Id; 1801 1802 -- Start of processing for Create_Or_Modify_Clause 1803 1804 begin 1805 -- A null output depending on itself does not require any 1806 -- normalization. 1807 1808 if Nkind (Output) = N_Null then 1809 return; 1810 1811 -- A function result cannot depend on itself because it cannot 1812 -- appear in the input list of a relation (SPARK RM 6.1.5(10)). 1813 1814 elsif Is_Attribute_Result (Output) then 1815 SPARK_Msg_N ("function result cannot depend on itself", Output); 1816 return; 1817 end if; 1818 1819 -- When performing the transformation in place, simply add the 1820 -- output to the list of inputs (if not already there). This 1821 -- case arises when dealing with the last output of an output 1822 -- list. Perform the normalization in place to avoid generating 1823 -- a malformed tree. 1824 1825 if In_Place then 1826 Propagate_Output (Output, Inputs); 1827 1828 -- A list with multiple outputs is slowly trimmed until only 1829 -- one element remains. When this happens, replace aggregate 1830 -- with the element itself. 1831 1832 if Multiple then 1833 Remove (Output); 1834 Rewrite (Outputs, Output); 1835 end if; 1836 1837 -- Default case 1838 1839 else 1840 -- Unchain the output from its output list as it will appear in 1841 -- a new clause. Note that we cannot simply rewrite the output 1842 -- as null because this will violate the semantics of pragma 1843 -- Depends. 1844 1845 Remove (Output); 1846 1847 -- Generate a new clause of the form: 1848 -- (Output => Inputs) 1849 1850 New_Clause := 1851 Make_Component_Association (Loc, 1852 Choices => New_List (Output), 1853 Expression => New_Copy_Tree (Inputs)); 1854 1855 -- The new clause contains replicated content that has already 1856 -- been analyzed. There is not need to reanalyze or renormalize 1857 -- it again. 1858 1859 Set_Analyzed (New_Clause); 1860 1861 Propagate_Output 1862 (Output => First (Choices (New_Clause)), 1863 Inputs => Expression (New_Clause)); 1864 1865 Insert_After (After, New_Clause); 1866 end if; 1867 end Create_Or_Modify_Clause; 1868 1869 -- Local variables 1870 1871 Outputs : constant Node_Id := First (Choices (Clause)); 1872 Inputs : Node_Id; 1873 Last_Output : Node_Id; 1874 Next_Output : Node_Id; 1875 Output : Node_Id; 1876 1877 -- Start of processing for Normalize_Clause 1878 1879 begin 1880 -- A self-dependency appears as operator "+". Remove the "+" from the 1881 -- tree by moving the real inputs to their proper place. 1882 1883 if Nkind (Expression (Clause)) = N_Op_Plus then 1884 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause))); 1885 Inputs := Expression (Clause); 1886 1887 -- Multiple outputs appear as an aggregate 1888 1889 if Nkind (Outputs) = N_Aggregate then 1890 Last_Output := Last (Expressions (Outputs)); 1891 1892 Output := First (Expressions (Outputs)); 1893 while Present (Output) loop 1894 1895 -- Normalization may remove an output from its list, 1896 -- preserve the subsequent output now. 1897 1898 Next_Output := Next (Output); 1899 1900 Create_Or_Modify_Clause 1901 (Output => Output, 1902 Outputs => Outputs, 1903 Inputs => Inputs, 1904 After => Clause, 1905 In_Place => Output = Last_Output, 1906 Multiple => True); 1907 1908 Output := Next_Output; 1909 end loop; 1910 1911 -- Solitary output 1912 1913 else 1914 Create_Or_Modify_Clause 1915 (Output => Outputs, 1916 Outputs => Empty, 1917 Inputs => Inputs, 1918 After => Empty, 1919 In_Place => True, 1920 Multiple => False); 1921 end if; 1922 end if; 1923 end Normalize_Clause; 1924 1925 -- Local variables 1926 1927 Deps : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 1928 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 1929 1930 Clause : Node_Id; 1931 Errors : Nat; 1932 Last_Clause : Node_Id; 1933 Restore_Scope : Boolean := False; 1934 1935 -- Start of processing for Analyze_Depends_In_Decl_Part 1936 1937 begin 1938 -- Do not analyze the pragma multiple times 1939 1940 if Is_Analyzed_Pragma (N) then 1941 return; 1942 end if; 1943 1944 -- Empty dependency list 1945 1946 if Nkind (Deps) = N_Null then 1947 1948 -- Gather all states, objects and formal parameters that the 1949 -- subprogram may depend on. These items are obtained from the 1950 -- parameter profile or pragma [Refined_]Global (if available). 1951 1952 Collect_Subprogram_Inputs_Outputs 1953 (Subp_Id => Subp_Id, 1954 Subp_Inputs => Subp_Inputs, 1955 Subp_Outputs => Subp_Outputs, 1956 Global_Seen => Global_Seen); 1957 1958 -- Verify that every input or output of the subprogram appear in a 1959 -- dependency. 1960 1961 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 1962 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 1963 Check_Function_Return; 1964 1965 -- Dependency clauses appear as component associations of an aggregate 1966 1967 elsif Nkind (Deps) = N_Aggregate then 1968 1969 -- Do not attempt to perform analysis of a syntactically illegal 1970 -- clause as this will lead to misleading errors. 1971 1972 if Has_Extra_Parentheses (Deps) then 1973 return; 1974 end if; 1975 1976 if Present (Component_Associations (Deps)) then 1977 Last_Clause := Last (Component_Associations (Deps)); 1978 1979 -- Gather all states, objects and formal parameters that the 1980 -- subprogram may depend on. These items are obtained from the 1981 -- parameter profile or pragma [Refined_]Global (if available). 1982 1983 Collect_Subprogram_Inputs_Outputs 1984 (Subp_Id => Subp_Id, 1985 Subp_Inputs => Subp_Inputs, 1986 Subp_Outputs => Subp_Outputs, 1987 Global_Seen => Global_Seen); 1988 1989 -- When pragma [Refined_]Depends appears on a single concurrent 1990 -- type, it is relocated to the anonymous object. 1991 1992 if Is_Single_Concurrent_Object (Spec_Id) then 1993 null; 1994 1995 -- Ensure that the formal parameters are visible when analyzing 1996 -- all clauses. This falls out of the general rule of aspects 1997 -- pertaining to subprogram declarations. 1998 1999 elsif not In_Open_Scopes (Spec_Id) then 2000 Restore_Scope := True; 2001 Push_Scope (Spec_Id); 2002 2003 if Ekind (Spec_Id) = E_Task_Type then 2004 if Has_Discriminants (Spec_Id) then 2005 Install_Discriminants (Spec_Id); 2006 end if; 2007 2008 elsif Is_Generic_Subprogram (Spec_Id) then 2009 Install_Generic_Formals (Spec_Id); 2010 2011 else 2012 Install_Formals (Spec_Id); 2013 end if; 2014 end if; 2015 2016 Clause := First (Component_Associations (Deps)); 2017 while Present (Clause) loop 2018 Errors := Serious_Errors_Detected; 2019 2020 -- The normalization mechanism may create extra clauses that 2021 -- contain replicated input and output names. There is no need 2022 -- to reanalyze them. 2023 2024 if not Analyzed (Clause) then 2025 Set_Analyzed (Clause); 2026 2027 Analyze_Dependency_Clause 2028 (Clause => Clause, 2029 Is_Last => Clause = Last_Clause); 2030 end if; 2031 2032 -- Do not normalize a clause if errors were detected (count 2033 -- of Serious_Errors has increased) because the inputs and/or 2034 -- outputs may denote illegal items. Normalization is disabled 2035 -- in ASIS mode as it alters the tree by introducing new nodes 2036 -- similar to expansion. 2037 2038 if Serious_Errors_Detected = Errors and then not ASIS_Mode then 2039 Normalize_Clause (Clause); 2040 end if; 2041 2042 Next (Clause); 2043 end loop; 2044 2045 if Restore_Scope then 2046 End_Scope; 2047 end if; 2048 2049 -- Verify that every input or output of the subprogram appear in a 2050 -- dependency. 2051 2052 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 2053 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 2054 Check_Function_Return; 2055 2056 -- The dependency list is malformed. This is a syntax error, always 2057 -- report. 2058 2059 else 2060 Error_Msg_N ("malformed dependency relation", Deps); 2061 return; 2062 end if; 2063 2064 -- The top level dependency relation is malformed. This is a syntax 2065 -- error, always report. 2066 2067 else 2068 Error_Msg_N ("malformed dependency relation", Deps); 2069 goto Leave; 2070 end if; 2071 2072 -- Ensure that a state and a corresponding constituent do not appear 2073 -- together in pragma [Refined_]Depends. 2074 2075 Check_State_And_Constituent_Use 2076 (States => States_Seen, 2077 Constits => Constits_Seen, 2078 Context => N); 2079 2080 <<Leave>> 2081 Set_Is_Analyzed_Pragma (N); 2082 end Analyze_Depends_In_Decl_Part; 2083 2084 -------------------------------------------- 2085 -- Analyze_External_Property_In_Decl_Part -- 2086 -------------------------------------------- 2087 2088 procedure Analyze_External_Property_In_Decl_Part 2089 (N : Node_Id; 2090 Expr_Val : out Boolean) 2091 is 2092 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name (N)); 2093 Arg1 : constant Node_Id := 2094 First (Pragma_Argument_Associations (N)); 2095 Obj_Decl : constant Node_Id := Find_Related_Context (N); 2096 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 2097 Expr : Node_Id; 2098 2099 begin 2100 Expr_Val := False; 2101 2102 -- Do not analyze the pragma multiple times 2103 2104 if Is_Analyzed_Pragma (N) then 2105 return; 2106 end if; 2107 2108 Error_Msg_Name_1 := Pragma_Name (N); 2109 2110 -- An external property pragma must apply to an effectively volatile 2111 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)). 2112 -- The check is performed at the end of the declarative region due to a 2113 -- possible out-of-order arrangement of pragmas: 2114 2115 -- Obj : ...; 2116 -- pragma Async_Readers (Obj); 2117 -- pragma Volatile (Obj); 2118 2119 if Prag_Id /= Pragma_No_Caching 2120 and then not Is_Effectively_Volatile (Obj_Id) 2121 then 2122 if No_Caching_Enabled (Obj_Id) then 2123 SPARK_Msg_N 2124 ("illegal combination of external property % and property " 2125 & """No_Caching"" (SPARK RM 7.1.2(6))", N); 2126 else 2127 SPARK_Msg_N 2128 ("external property % must apply to a volatile object", N); 2129 end if; 2130 2131 -- Pragma No_Caching should only apply to volatile variables of 2132 -- a non-effectively volatile type (SPARK RM 7.1.2). 2133 2134 elsif Prag_Id = Pragma_No_Caching then 2135 if Is_Effectively_Volatile (Etype (Obj_Id)) then 2136 SPARK_Msg_N ("property % must not apply to an object of " 2137 & "an effectively volatile type", N); 2138 elsif not Is_Volatile (Obj_Id) then 2139 SPARK_Msg_N ("property % must apply to a volatile object", N); 2140 end if; 2141 end if; 2142 2143 -- Ensure that the Boolean expression (if present) is static. A missing 2144 -- argument defaults the value to True (SPARK RM 7.1.2(5)). 2145 2146 Expr_Val := True; 2147 2148 if Present (Arg1) then 2149 Expr := Get_Pragma_Arg (Arg1); 2150 2151 if Is_OK_Static_Expression (Expr) then 2152 Expr_Val := Is_True (Expr_Value (Expr)); 2153 end if; 2154 end if; 2155 2156 Set_Is_Analyzed_Pragma (N); 2157 end Analyze_External_Property_In_Decl_Part; 2158 2159 --------------------------------- 2160 -- Analyze_Global_In_Decl_Part -- 2161 --------------------------------- 2162 2163 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is 2164 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 2165 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 2166 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl); 2167 2168 Constits_Seen : Elist_Id := No_Elist; 2169 -- A list containing the entities of all constituents processed so far. 2170 -- It aids in detecting illegal usage of a state and a corresponding 2171 -- constituent in pragma [Refinde_]Global. 2172 2173 Seen : Elist_Id := No_Elist; 2174 -- A list containing the entities of all the items processed so far. It 2175 -- plays a role in detecting distinct entities. 2176 2177 States_Seen : Elist_Id := No_Elist; 2178 -- A list containing the entities of all states processed so far. It 2179 -- helps in detecting illegal usage of a state and a corresponding 2180 -- constituent in pragma [Refined_]Global. 2181 2182 In_Out_Seen : Boolean := False; 2183 Input_Seen : Boolean := False; 2184 Output_Seen : Boolean := False; 2185 Proof_Seen : Boolean := False; 2186 -- Flags used to verify the consistency of modes 2187 2188 procedure Analyze_Global_List 2189 (List : Node_Id; 2190 Global_Mode : Name_Id := Name_Input); 2191 -- Verify the legality of a single global list declaration. Global_Mode 2192 -- denotes the current mode in effect. 2193 2194 ------------------------- 2195 -- Analyze_Global_List -- 2196 ------------------------- 2197 2198 procedure Analyze_Global_List 2199 (List : Node_Id; 2200 Global_Mode : Name_Id := Name_Input) 2201 is 2202 procedure Analyze_Global_Item 2203 (Item : Node_Id; 2204 Global_Mode : Name_Id); 2205 -- Verify the legality of a single global item declaration denoted by 2206 -- Item. Global_Mode denotes the current mode in effect. 2207 2208 procedure Check_Duplicate_Mode 2209 (Mode : Node_Id; 2210 Status : in out Boolean); 2211 -- Flag Status denotes whether a particular mode has been seen while 2212 -- processing a global list. This routine verifies that Mode is not a 2213 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)). 2214 2215 procedure Check_Mode_Restriction_In_Enclosing_Context 2216 (Item : Node_Id; 2217 Item_Id : Entity_Id); 2218 -- Verify that an item of mode In_Out or Output does not appear as 2219 -- an input in the Global aspect of an enclosing subprogram or task 2220 -- unit. If this is the case, emit an error. Item and Item_Id are 2221 -- respectively the item and its entity. 2222 2223 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); 2224 -- Mode denotes either In_Out or Output. Depending on the kind of the 2225 -- related subprogram, emit an error if those two modes apply to a 2226 -- function (SPARK RM 6.1.4(10)). 2227 2228 ------------------------- 2229 -- Analyze_Global_Item -- 2230 ------------------------- 2231 2232 procedure Analyze_Global_Item 2233 (Item : Node_Id; 2234 Global_Mode : Name_Id) 2235 is 2236 Item_Id : Entity_Id; 2237 2238 begin 2239 -- Detect one of the following cases 2240 2241 -- with Global => (null, Name) 2242 -- with Global => (Name_1, null, Name_2) 2243 -- with Global => (Name, null) 2244 2245 if Nkind (Item) = N_Null then 2246 SPARK_Msg_N ("cannot mix null and non-null global items", Item); 2247 return; 2248 end if; 2249 2250 Analyze (Item); 2251 Resolve_State (Item); 2252 2253 -- Find the entity of the item. If this is a renaming, climb the 2254 -- renaming chain to reach the root object. Renamings of non- 2255 -- entire objects do not yield an entity (Empty). 2256 2257 Item_Id := Entity_Of (Item); 2258 2259 if Present (Item_Id) then 2260 2261 -- A global item may denote a formal parameter of an enclosing 2262 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to 2263 -- provide a better error diagnostic. 2264 2265 if Is_Formal (Item_Id) then 2266 if Scope (Item_Id) = Spec_Id then 2267 SPARK_Msg_NE 2268 (Fix_Msg (Spec_Id, "global item cannot reference " 2269 & "parameter of subprogram &"), Item, Spec_Id); 2270 return; 2271 end if; 2272 2273 -- A global item may denote a concurrent type as long as it is 2274 -- the current instance of an enclosing protected or task type 2275 -- (SPARK RM 6.1.4). 2276 2277 elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then 2278 if Is_CCT_Instance (Item_Id, Spec_Id) then 2279 2280 -- Pragma [Refined_]Global associated with a protected 2281 -- subprogram cannot mention the current instance of a 2282 -- protected type because the instance behaves as a 2283 -- formal parameter. 2284 2285 if Ekind (Item_Id) = E_Protected_Type then 2286 if Scope (Spec_Id) = Item_Id then 2287 Error_Msg_Name_1 := Chars (Item_Id); 2288 SPARK_Msg_NE 2289 (Fix_Msg (Spec_Id, "global item of subprogram & " 2290 & "cannot reference current instance of " 2291 & "protected type %"), Item, Spec_Id); 2292 return; 2293 end if; 2294 2295 -- Pragma [Refined_]Global associated with a task type 2296 -- cannot mention the current instance of a task type 2297 -- because the instance behaves as a formal parameter. 2298 2299 else pragma Assert (Ekind (Item_Id) = E_Task_Type); 2300 if Spec_Id = Item_Id then 2301 Error_Msg_Name_1 := Chars (Item_Id); 2302 SPARK_Msg_NE 2303 (Fix_Msg (Spec_Id, "global item of subprogram & " 2304 & "cannot reference current instance of task " 2305 & "type %"), Item, Spec_Id); 2306 return; 2307 end if; 2308 end if; 2309 2310 -- Otherwise the global item denotes a subtype mark that is 2311 -- not a current instance. 2312 2313 else 2314 SPARK_Msg_N 2315 ("invalid use of subtype mark in global list", Item); 2316 return; 2317 end if; 2318 2319 -- A global item may denote the anonymous object created for a 2320 -- single protected/task type as long as the current instance 2321 -- is the same single type (SPARK RM 6.1.4). 2322 2323 elsif Is_Single_Concurrent_Object (Item_Id) 2324 and then Is_CCT_Instance (Etype (Item_Id), Spec_Id) 2325 then 2326 -- Pragma [Refined_]Global associated with a protected 2327 -- subprogram cannot mention the current instance of a 2328 -- protected type because the instance behaves as a formal 2329 -- parameter. 2330 2331 if Is_Single_Protected_Object (Item_Id) then 2332 if Scope (Spec_Id) = Etype (Item_Id) then 2333 Error_Msg_Name_1 := Chars (Item_Id); 2334 SPARK_Msg_NE 2335 (Fix_Msg (Spec_Id, "global item of subprogram & " 2336 & "cannot reference current instance of protected " 2337 & "type %"), Item, Spec_Id); 2338 return; 2339 end if; 2340 2341 -- Pragma [Refined_]Global associated with a task type 2342 -- cannot mention the current instance of a task type 2343 -- because the instance behaves as a formal parameter. 2344 2345 else pragma Assert (Is_Single_Task_Object (Item_Id)); 2346 if Spec_Id = Item_Id then 2347 Error_Msg_Name_1 := Chars (Item_Id); 2348 SPARK_Msg_NE 2349 (Fix_Msg (Spec_Id, "global item of subprogram & " 2350 & "cannot reference current instance of task " 2351 & "type %"), Item, Spec_Id); 2352 return; 2353 end if; 2354 end if; 2355 2356 -- A formal object may act as a global item inside a generic 2357 2358 elsif Is_Formal_Object (Item_Id) then 2359 null; 2360 2361 -- The only legal references are those to abstract states, 2362 -- objects and various kinds of constants (SPARK RM 6.1.4(4)). 2363 2364 elsif not Ekind_In (Item_Id, E_Abstract_State, 2365 E_Constant, 2366 E_Loop_Parameter, 2367 E_Variable) 2368 then 2369 SPARK_Msg_N 2370 ("global item must denote object, state or current " 2371 & "instance of concurrent type", Item); 2372 2373 if Ekind (Item_Id) in Named_Kind then 2374 SPARK_Msg_NE 2375 ("\named number & is not an object", Item, Item); 2376 end if; 2377 2378 return; 2379 end if; 2380 2381 -- State related checks 2382 2383 if Ekind (Item_Id) = E_Abstract_State then 2384 2385 -- Package and subprogram bodies are instantiated 2386 -- individually in a separate compiler pass. Due to this 2387 -- mode of instantiation, the refinement of a state may 2388 -- no longer be visible when a subprogram body contract 2389 -- is instantiated. Since the generic template is legal, 2390 -- do not perform this check in the instance to circumvent 2391 -- this oddity. 2392 2393 if In_Instance then 2394 null; 2395 2396 -- An abstract state with visible refinement cannot appear 2397 -- in pragma [Refined_]Global as its place must be taken by 2398 -- some of its constituents (SPARK RM 6.1.4(7)). 2399 2400 elsif Has_Visible_Refinement (Item_Id) then 2401 SPARK_Msg_NE 2402 ("cannot mention state & in global refinement", 2403 Item, Item_Id); 2404 SPARK_Msg_N ("\use its constituents instead", Item); 2405 return; 2406 2407 -- An external state cannot appear as a global item of a 2408 -- nonvolatile function (SPARK RM 7.1.3(8)). 2409 2410 elsif Is_External_State (Item_Id) 2411 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function) 2412 and then not Is_Volatile_Function (Spec_Id) 2413 then 2414 SPARK_Msg_NE 2415 ("external state & cannot act as global item of " 2416 & "nonvolatile function", Item, Item_Id); 2417 return; 2418 2419 -- If the reference to the abstract state appears in an 2420 -- enclosing package body that will eventually refine the 2421 -- state, record the reference for future checks. 2422 2423 else 2424 Record_Possible_Body_Reference 2425 (State_Id => Item_Id, 2426 Ref => Item); 2427 end if; 2428 2429 -- Constant related checks 2430 2431 elsif Ekind (Item_Id) = E_Constant 2432 and then not Is_Access_Type (Etype (Item_Id)) 2433 then 2434 2435 -- Unless it is of an access type, a constant is a read-only 2436 -- item, therefore it cannot act as an output. 2437 2438 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2439 SPARK_Msg_NE 2440 ("constant & cannot act as output", Item, Item_Id); 2441 return; 2442 end if; 2443 2444 -- Loop parameter related checks 2445 2446 elsif Ekind (Item_Id) = E_Loop_Parameter then 2447 2448 -- A loop parameter is a read-only item, therefore it cannot 2449 -- act as an output. 2450 2451 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2452 SPARK_Msg_NE 2453 ("loop parameter & cannot act as output", 2454 Item, Item_Id); 2455 return; 2456 end if; 2457 2458 -- Variable related checks. These are only relevant when 2459 -- SPARK_Mode is on as they are not standard Ada legality 2460 -- rules. 2461 2462 elsif SPARK_Mode = On 2463 and then Ekind (Item_Id) = E_Variable 2464 and then Is_Effectively_Volatile (Item_Id) 2465 then 2466 -- An effectively volatile object cannot appear as a global 2467 -- item of a nonvolatile function (SPARK RM 7.1.3(8)). 2468 2469 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) 2470 and then not Is_Volatile_Function (Spec_Id) 2471 then 2472 Error_Msg_NE 2473 ("volatile object & cannot act as global item of a " 2474 & "function", Item, Item_Id); 2475 return; 2476 2477 -- An effectively volatile object with external property 2478 -- Effective_Reads set to True must have mode Output or 2479 -- In_Out (SPARK RM 7.1.3(10)). 2480 2481 elsif Effective_Reads_Enabled (Item_Id) 2482 and then Global_Mode = Name_Input 2483 then 2484 Error_Msg_NE 2485 ("volatile object & with property Effective_Reads must " 2486 & "have mode In_Out or Output", Item, Item_Id); 2487 return; 2488 end if; 2489 end if; 2490 2491 -- When the item renames an entire object, replace the item 2492 -- with a reference to the object. 2493 2494 if Entity (Item) /= Item_Id then 2495 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item))); 2496 Analyze (Item); 2497 end if; 2498 2499 -- Some form of illegal construct masquerading as a name 2500 -- (SPARK RM 6.1.4(4)). 2501 2502 else 2503 Error_Msg_N 2504 ("global item must denote object, state or current instance " 2505 & "of concurrent type", Item); 2506 return; 2507 end if; 2508 2509 -- Verify that an output does not appear as an input in an 2510 -- enclosing subprogram. 2511 2512 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2513 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id); 2514 end if; 2515 2516 -- The same entity might be referenced through various way. 2517 -- Check the entity of the item rather than the item itself 2518 -- (SPARK RM 6.1.4(10)). 2519 2520 if Contains (Seen, Item_Id) then 2521 SPARK_Msg_N ("duplicate global item", Item); 2522 2523 -- Add the entity of the current item to the list of processed 2524 -- items. 2525 2526 else 2527 Append_New_Elmt (Item_Id, Seen); 2528 2529 if Ekind (Item_Id) = E_Abstract_State then 2530 Append_New_Elmt (Item_Id, States_Seen); 2531 2532 -- The variable may eventually become a constituent of a single 2533 -- protected/task type. Record the reference now and verify its 2534 -- legality when analyzing the contract of the variable 2535 -- (SPARK RM 9.3). 2536 2537 elsif Ekind (Item_Id) = E_Variable then 2538 Record_Possible_Part_Of_Reference 2539 (Var_Id => Item_Id, 2540 Ref => Item); 2541 end if; 2542 2543 if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable) 2544 and then Present (Encapsulating_State (Item_Id)) 2545 then 2546 Append_New_Elmt (Item_Id, Constits_Seen); 2547 end if; 2548 end if; 2549 end Analyze_Global_Item; 2550 2551 -------------------------- 2552 -- Check_Duplicate_Mode -- 2553 -------------------------- 2554 2555 procedure Check_Duplicate_Mode 2556 (Mode : Node_Id; 2557 Status : in out Boolean) 2558 is 2559 begin 2560 if Status then 2561 SPARK_Msg_N ("duplicate global mode", Mode); 2562 end if; 2563 2564 Status := True; 2565 end Check_Duplicate_Mode; 2566 2567 ------------------------------------------------- 2568 -- Check_Mode_Restriction_In_Enclosing_Context -- 2569 ------------------------------------------------- 2570 2571 procedure Check_Mode_Restriction_In_Enclosing_Context 2572 (Item : Node_Id; 2573 Item_Id : Entity_Id) 2574 is 2575 Context : Entity_Id; 2576 Dummy : Boolean; 2577 Inputs : Elist_Id := No_Elist; 2578 Outputs : Elist_Id := No_Elist; 2579 2580 begin 2581 -- Traverse the scope stack looking for enclosing subprograms or 2582 -- tasks subject to pragma [Refined_]Global. 2583 2584 Context := Scope (Subp_Id); 2585 while Present (Context) and then Context /= Standard_Standard loop 2586 2587 -- For a single task type, retrieve the corresponding object to 2588 -- which pragma [Refined_]Global is attached. 2589 2590 if Ekind (Context) = E_Task_Type 2591 and then Is_Single_Concurrent_Type (Context) 2592 then 2593 Context := Anonymous_Object (Context); 2594 end if; 2595 2596 if (Is_Subprogram (Context) 2597 or else Ekind (Context) = E_Task_Type 2598 or else Is_Single_Task_Object (Context)) 2599 and then 2600 (Present (Get_Pragma (Context, Pragma_Global)) 2601 or else 2602 Present (Get_Pragma (Context, Pragma_Refined_Global))) 2603 then 2604 Collect_Subprogram_Inputs_Outputs 2605 (Subp_Id => Context, 2606 Subp_Inputs => Inputs, 2607 Subp_Outputs => Outputs, 2608 Global_Seen => Dummy); 2609 2610 -- The item is classified as In_Out or Output but appears as 2611 -- an Input in an enclosing subprogram or task unit (SPARK 2612 -- RM 6.1.4(12)). 2613 2614 if Appears_In (Inputs, Item_Id) 2615 and then not Appears_In (Outputs, Item_Id) 2616 then 2617 SPARK_Msg_NE 2618 ("global item & cannot have mode In_Out or Output", 2619 Item, Item_Id); 2620 2621 if Is_Subprogram (Context) then 2622 SPARK_Msg_NE 2623 (Fix_Msg (Subp_Id, "\item already appears as input " 2624 & "of subprogram &"), Item, Context); 2625 else 2626 SPARK_Msg_NE 2627 (Fix_Msg (Subp_Id, "\item already appears as input " 2628 & "of task &"), Item, Context); 2629 end if; 2630 2631 -- Stop the traversal once an error has been detected 2632 2633 exit; 2634 end if; 2635 end if; 2636 2637 Context := Scope (Context); 2638 end loop; 2639 end Check_Mode_Restriction_In_Enclosing_Context; 2640 2641 ---------------------------------------- 2642 -- Check_Mode_Restriction_In_Function -- 2643 ---------------------------------------- 2644 2645 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is 2646 begin 2647 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 2648 SPARK_Msg_N 2649 ("global mode & is not applicable to functions", Mode); 2650 end if; 2651 end Check_Mode_Restriction_In_Function; 2652 2653 -- Local variables 2654 2655 Assoc : Node_Id; 2656 Item : Node_Id; 2657 Mode : Node_Id; 2658 2659 -- Start of processing for Analyze_Global_List 2660 2661 begin 2662 if Nkind (List) = N_Null then 2663 Set_Analyzed (List); 2664 2665 -- Single global item declaration 2666 2667 elsif Nkind_In (List, N_Expanded_Name, 2668 N_Identifier, 2669 N_Selected_Component) 2670 then 2671 Analyze_Global_Item (List, Global_Mode); 2672 2673 -- Simple global list or moded global list declaration 2674 2675 elsif Nkind (List) = N_Aggregate then 2676 Set_Analyzed (List); 2677 2678 -- The declaration of a simple global list appear as a collection 2679 -- of expressions. 2680 2681 if Present (Expressions (List)) then 2682 if Present (Component_Associations (List)) then 2683 SPARK_Msg_N 2684 ("cannot mix moded and non-moded global lists", List); 2685 end if; 2686 2687 Item := First (Expressions (List)); 2688 while Present (Item) loop 2689 Analyze_Global_Item (Item, Global_Mode); 2690 Next (Item); 2691 end loop; 2692 2693 -- The declaration of a moded global list appears as a collection 2694 -- of component associations where individual choices denote 2695 -- modes. 2696 2697 elsif Present (Component_Associations (List)) then 2698 if Present (Expressions (List)) then 2699 SPARK_Msg_N 2700 ("cannot mix moded and non-moded global lists", List); 2701 end if; 2702 2703 Assoc := First (Component_Associations (List)); 2704 while Present (Assoc) loop 2705 Mode := First (Choices (Assoc)); 2706 2707 if Nkind (Mode) = N_Identifier then 2708 if Chars (Mode) = Name_In_Out then 2709 Check_Duplicate_Mode (Mode, In_Out_Seen); 2710 Check_Mode_Restriction_In_Function (Mode); 2711 2712 elsif Chars (Mode) = Name_Input then 2713 Check_Duplicate_Mode (Mode, Input_Seen); 2714 2715 elsif Chars (Mode) = Name_Output then 2716 Check_Duplicate_Mode (Mode, Output_Seen); 2717 Check_Mode_Restriction_In_Function (Mode); 2718 2719 elsif Chars (Mode) = Name_Proof_In then 2720 Check_Duplicate_Mode (Mode, Proof_Seen); 2721 2722 else 2723 SPARK_Msg_N ("invalid mode selector", Mode); 2724 end if; 2725 2726 else 2727 SPARK_Msg_N ("invalid mode selector", Mode); 2728 end if; 2729 2730 -- Items in a moded list appear as a collection of 2731 -- expressions. Reuse the existing machinery to analyze 2732 -- them. 2733 2734 Analyze_Global_List 2735 (List => Expression (Assoc), 2736 Global_Mode => Chars (Mode)); 2737 2738 Next (Assoc); 2739 end loop; 2740 2741 -- Invalid tree 2742 2743 else 2744 raise Program_Error; 2745 end if; 2746 2747 -- Any other attempt to declare a global item is illegal. This is a 2748 -- syntax error, always report. 2749 2750 else 2751 Error_Msg_N ("malformed global list", List); 2752 end if; 2753 end Analyze_Global_List; 2754 2755 -- Local variables 2756 2757 Items : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 2758 2759 Restore_Scope : Boolean := False; 2760 2761 -- Start of processing for Analyze_Global_In_Decl_Part 2762 2763 begin 2764 -- Do not analyze the pragma multiple times 2765 2766 if Is_Analyzed_Pragma (N) then 2767 return; 2768 end if; 2769 2770 -- There is nothing to be done for a null global list 2771 2772 if Nkind (Items) = N_Null then 2773 Set_Analyzed (Items); 2774 2775 -- Analyze the various forms of global lists and items. Note that some 2776 -- of these may be malformed in which case the analysis emits error 2777 -- messages. 2778 2779 else 2780 -- When pragma [Refined_]Global appears on a single concurrent type, 2781 -- it is relocated to the anonymous object. 2782 2783 if Is_Single_Concurrent_Object (Spec_Id) then 2784 null; 2785 2786 -- Ensure that the formal parameters are visible when processing an 2787 -- item. This falls out of the general rule of aspects pertaining to 2788 -- subprogram declarations. 2789 2790 elsif not In_Open_Scopes (Spec_Id) then 2791 Restore_Scope := True; 2792 Push_Scope (Spec_Id); 2793 2794 if Ekind (Spec_Id) = E_Task_Type then 2795 if Has_Discriminants (Spec_Id) then 2796 Install_Discriminants (Spec_Id); 2797 end if; 2798 2799 elsif Is_Generic_Subprogram (Spec_Id) then 2800 Install_Generic_Formals (Spec_Id); 2801 2802 else 2803 Install_Formals (Spec_Id); 2804 end if; 2805 end if; 2806 2807 Analyze_Global_List (Items); 2808 2809 if Restore_Scope then 2810 End_Scope; 2811 end if; 2812 end if; 2813 2814 -- Ensure that a state and a corresponding constituent do not appear 2815 -- together in pragma [Refined_]Global. 2816 2817 Check_State_And_Constituent_Use 2818 (States => States_Seen, 2819 Constits => Constits_Seen, 2820 Context => N); 2821 2822 Set_Is_Analyzed_Pragma (N); 2823 end Analyze_Global_In_Decl_Part; 2824 2825 -------------------------------------------- 2826 -- Analyze_Initial_Condition_In_Decl_Part -- 2827 -------------------------------------------- 2828 2829 -- WARNING: This routine manages Ghost regions. Return statements must be 2830 -- replaced by gotos which jump to the end of the routine and restore the 2831 -- Ghost mode. 2832 2833 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is 2834 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 2835 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 2836 Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id)); 2837 2838 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 2839 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 2840 -- Save the Ghost-related attributes to restore on exit 2841 2842 begin 2843 -- Do not analyze the pragma multiple times 2844 2845 if Is_Analyzed_Pragma (N) then 2846 return; 2847 end if; 2848 2849 -- Set the Ghost mode in effect from the pragma. Due to the delayed 2850 -- analysis of the pragma, the Ghost mode at point of declaration and 2851 -- point of analysis may not necessarily be the same. Use the mode in 2852 -- effect at the point of declaration. 2853 2854 Set_Ghost_Mode (N); 2855 2856 -- The expression is preanalyzed because it has not been moved to its 2857 -- final place yet. A direct analysis may generate side effects and this 2858 -- is not desired at this point. 2859 2860 Preanalyze_Assert_Expression (Expr, Standard_Boolean); 2861 Set_Is_Analyzed_Pragma (N); 2862 2863 Restore_Ghost_Region (Saved_GM, Saved_IGR); 2864 end Analyze_Initial_Condition_In_Decl_Part; 2865 2866 -------------------------------------- 2867 -- Analyze_Initializes_In_Decl_Part -- 2868 -------------------------------------- 2869 2870 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is 2871 Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 2872 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl); 2873 2874 Constits_Seen : Elist_Id := No_Elist; 2875 -- A list containing the entities of all constituents processed so far. 2876 -- It aids in detecting illegal usage of a state and a corresponding 2877 -- constituent in pragma Initializes. 2878 2879 Items_Seen : Elist_Id := No_Elist; 2880 -- A list of all initialization items processed so far. This list is 2881 -- used to detect duplicate items. 2882 2883 States_And_Objs : Elist_Id := No_Elist; 2884 -- A list of all abstract states and objects declared in the visible 2885 -- declarations of the related package. This list is used to detect the 2886 -- legality of initialization items. 2887 2888 States_Seen : Elist_Id := No_Elist; 2889 -- A list containing the entities of all states processed so far. It 2890 -- helps in detecting illegal usage of a state and a corresponding 2891 -- constituent in pragma Initializes. 2892 2893 procedure Analyze_Initialization_Item (Item : Node_Id); 2894 -- Verify the legality of a single initialization item 2895 2896 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id); 2897 -- Verify the legality of a single initialization item followed by a 2898 -- list of input items. 2899 2900 procedure Collect_States_And_Objects; 2901 -- Inspect the visible declarations of the related package and gather 2902 -- the entities of all abstract states and objects in States_And_Objs. 2903 2904 --------------------------------- 2905 -- Analyze_Initialization_Item -- 2906 --------------------------------- 2907 2908 procedure Analyze_Initialization_Item (Item : Node_Id) is 2909 Item_Id : Entity_Id; 2910 2911 begin 2912 Analyze (Item); 2913 Resolve_State (Item); 2914 2915 if Is_Entity_Name (Item) then 2916 Item_Id := Entity_Of (Item); 2917 2918 if Present (Item_Id) 2919 and then Ekind_In (Item_Id, E_Abstract_State, 2920 E_Constant, 2921 E_Variable) 2922 then 2923 -- When the initialization item is undefined, it appears as 2924 -- Any_Id. Do not continue with the analysis of the item. 2925 2926 if Item_Id = Any_Id then 2927 null; 2928 2929 -- The state or variable must be declared in the visible 2930 -- declarations of the package (SPARK RM 7.1.5(7)). 2931 2932 elsif not Contains (States_And_Objs, Item_Id) then 2933 Error_Msg_Name_1 := Chars (Pack_Id); 2934 SPARK_Msg_NE 2935 ("initialization item & must appear in the visible " 2936 & "declarations of package %", Item, Item_Id); 2937 2938 -- Detect a duplicate use of the same initialization item 2939 -- (SPARK RM 7.1.5(5)). 2940 2941 elsif Contains (Items_Seen, Item_Id) then 2942 SPARK_Msg_N ("duplicate initialization item", Item); 2943 2944 -- The item is legal, add it to the list of processed states 2945 -- and variables. 2946 2947 else 2948 Append_New_Elmt (Item_Id, Items_Seen); 2949 2950 if Ekind (Item_Id) = E_Abstract_State then 2951 Append_New_Elmt (Item_Id, States_Seen); 2952 end if; 2953 2954 if Present (Encapsulating_State (Item_Id)) then 2955 Append_New_Elmt (Item_Id, Constits_Seen); 2956 end if; 2957 end if; 2958 2959 -- The item references something that is not a state or object 2960 -- (SPARK RM 7.1.5(3)). 2961 2962 else 2963 SPARK_Msg_N 2964 ("initialization item must denote object or state", Item); 2965 end if; 2966 2967 -- Some form of illegal construct masquerading as a name 2968 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. 2969 2970 else 2971 Error_Msg_N 2972 ("initialization item must denote object or state", Item); 2973 end if; 2974 end Analyze_Initialization_Item; 2975 2976 --------------------------------------------- 2977 -- Analyze_Initialization_Item_With_Inputs -- 2978 --------------------------------------------- 2979 2980 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is 2981 Inputs_Seen : Elist_Id := No_Elist; 2982 -- A list of all inputs processed so far. This list is used to detect 2983 -- duplicate uses of an input. 2984 2985 Non_Null_Seen : Boolean := False; 2986 Null_Seen : Boolean := False; 2987 -- Flags used to check the legality of an input list 2988 2989 procedure Analyze_Input_Item (Input : Node_Id); 2990 -- Verify the legality of a single input item 2991 2992 ------------------------ 2993 -- Analyze_Input_Item -- 2994 ------------------------ 2995 2996 procedure Analyze_Input_Item (Input : Node_Id) is 2997 Input_Id : Entity_Id; 2998 2999 begin 3000 -- Null input list 3001 3002 if Nkind (Input) = N_Null then 3003 if Null_Seen then 3004 SPARK_Msg_N 3005 ("multiple null initializations not allowed", Item); 3006 3007 elsif Non_Null_Seen then 3008 SPARK_Msg_N 3009 ("cannot mix null and non-null initialization item", Item); 3010 else 3011 Null_Seen := True; 3012 end if; 3013 3014 -- Input item 3015 3016 else 3017 Non_Null_Seen := True; 3018 3019 if Null_Seen then 3020 SPARK_Msg_N 3021 ("cannot mix null and non-null initialization item", Item); 3022 end if; 3023 3024 Analyze (Input); 3025 Resolve_State (Input); 3026 3027 if Is_Entity_Name (Input) then 3028 Input_Id := Entity_Of (Input); 3029 3030 if Present (Input_Id) 3031 and then Ekind_In (Input_Id, E_Abstract_State, 3032 E_Constant, 3033 E_Generic_In_Out_Parameter, 3034 E_Generic_In_Parameter, 3035 E_In_Parameter, 3036 E_In_Out_Parameter, 3037 E_Out_Parameter, 3038 E_Protected_Type, 3039 E_Task_Type, 3040 E_Variable) 3041 then 3042 -- The input cannot denote states or objects declared 3043 -- within the related package (SPARK RM 7.1.5(4)). 3044 3045 if Within_Scope (Input_Id, Current_Scope) then 3046 3047 -- Do not consider generic formal parameters or their 3048 -- respective mappings to generic formals. Even though 3049 -- the formals appear within the scope of the package, 3050 -- it is allowed for an initialization item to depend 3051 -- on an input item. 3052 3053 if Ekind_In (Input_Id, E_Generic_In_Out_Parameter, 3054 E_Generic_In_Parameter) 3055 then 3056 null; 3057 3058 elsif Ekind_In (Input_Id, E_Constant, E_Variable) 3059 and then Present (Corresponding_Generic_Association 3060 (Declaration_Node (Input_Id))) 3061 then 3062 null; 3063 3064 else 3065 Error_Msg_Name_1 := Chars (Pack_Id); 3066 SPARK_Msg_NE 3067 ("input item & cannot denote a visible object or " 3068 & "state of package %", Input, Input_Id); 3069 return; 3070 end if; 3071 end if; 3072 3073 -- Detect a duplicate use of the same input item 3074 -- (SPARK RM 7.1.5(5)). 3075 3076 if Contains (Inputs_Seen, Input_Id) then 3077 SPARK_Msg_N ("duplicate input item", Input); 3078 return; 3079 end if; 3080 3081 -- At this point it is known that the input is legal. Add 3082 -- it to the list of processed inputs. 3083 3084 Append_New_Elmt (Input_Id, Inputs_Seen); 3085 3086 if Ekind (Input_Id) = E_Abstract_State then 3087 Append_New_Elmt (Input_Id, States_Seen); 3088 end if; 3089 3090 if Ekind_In (Input_Id, E_Abstract_State, 3091 E_Constant, 3092 E_Variable) 3093 and then Present (Encapsulating_State (Input_Id)) 3094 then 3095 Append_New_Elmt (Input_Id, Constits_Seen); 3096 end if; 3097 3098 -- The input references something that is not a state or an 3099 -- object (SPARK RM 7.1.5(3)). 3100 3101 else 3102 SPARK_Msg_N 3103 ("input item must denote object or state", Input); 3104 end if; 3105 3106 -- Some form of illegal construct masquerading as a name 3107 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report. 3108 3109 else 3110 Error_Msg_N 3111 ("input item must denote object or state", Input); 3112 end if; 3113 end if; 3114 end Analyze_Input_Item; 3115 3116 -- Local variables 3117 3118 Inputs : constant Node_Id := Expression (Item); 3119 Elmt : Node_Id; 3120 Input : Node_Id; 3121 3122 Name_Seen : Boolean := False; 3123 -- A flag used to detect multiple item names 3124 3125 -- Start of processing for Analyze_Initialization_Item_With_Inputs 3126 3127 begin 3128 -- Inspect the name of an item with inputs 3129 3130 Elmt := First (Choices (Item)); 3131 while Present (Elmt) loop 3132 if Name_Seen then 3133 SPARK_Msg_N ("only one item allowed in initialization", Elmt); 3134 else 3135 Name_Seen := True; 3136 Analyze_Initialization_Item (Elmt); 3137 end if; 3138 3139 Next (Elmt); 3140 end loop; 3141 3142 -- Multiple input items appear as an aggregate 3143 3144 if Nkind (Inputs) = N_Aggregate then 3145 if Present (Expressions (Inputs)) then 3146 Input := First (Expressions (Inputs)); 3147 while Present (Input) loop 3148 Analyze_Input_Item (Input); 3149 Next (Input); 3150 end loop; 3151 end if; 3152 3153 if Present (Component_Associations (Inputs)) then 3154 SPARK_Msg_N 3155 ("inputs must appear in named association form", Inputs); 3156 end if; 3157 3158 -- Single input item 3159 3160 else 3161 Analyze_Input_Item (Inputs); 3162 end if; 3163 end Analyze_Initialization_Item_With_Inputs; 3164 3165 -------------------------------- 3166 -- Collect_States_And_Objects -- 3167 -------------------------------- 3168 3169 procedure Collect_States_And_Objects is 3170 Pack_Spec : constant Node_Id := Specification (Pack_Decl); 3171 Decl : Node_Id; 3172 3173 begin 3174 -- Collect the abstract states defined in the package (if any) 3175 3176 if Present (Abstract_States (Pack_Id)) then 3177 States_And_Objs := New_Copy_Elist (Abstract_States (Pack_Id)); 3178 end if; 3179 3180 -- Collect all objects that appear in the visible declarations of the 3181 -- related package. 3182 3183 if Present (Visible_Declarations (Pack_Spec)) then 3184 Decl := First (Visible_Declarations (Pack_Spec)); 3185 while Present (Decl) loop 3186 if Comes_From_Source (Decl) 3187 and then Nkind_In (Decl, N_Object_Declaration, 3188 N_Object_Renaming_Declaration) 3189 then 3190 Append_New_Elmt (Defining_Entity (Decl), States_And_Objs); 3191 3192 elsif Is_Single_Concurrent_Type_Declaration (Decl) then 3193 Append_New_Elmt 3194 (Anonymous_Object (Defining_Entity (Decl)), 3195 States_And_Objs); 3196 end if; 3197 3198 Next (Decl); 3199 end loop; 3200 end if; 3201 end Collect_States_And_Objects; 3202 3203 -- Local variables 3204 3205 Inits : constant Node_Id := Expression (Get_Argument (N, Pack_Id)); 3206 Init : Node_Id; 3207 3208 -- Start of processing for Analyze_Initializes_In_Decl_Part 3209 3210 begin 3211 -- Do not analyze the pragma multiple times 3212 3213 if Is_Analyzed_Pragma (N) then 3214 return; 3215 end if; 3216 3217 -- Nothing to do when the initialization list is empty 3218 3219 if Nkind (Inits) = N_Null then 3220 return; 3221 end if; 3222 3223 -- Single and multiple initialization clauses appear as an aggregate. If 3224 -- this is not the case, then either the parser or the analysis of the 3225 -- pragma failed to produce an aggregate. 3226 3227 pragma Assert (Nkind (Inits) = N_Aggregate); 3228 3229 -- Initialize the various lists used during analysis 3230 3231 Collect_States_And_Objects; 3232 3233 if Present (Expressions (Inits)) then 3234 Init := First (Expressions (Inits)); 3235 while Present (Init) loop 3236 Analyze_Initialization_Item (Init); 3237 Next (Init); 3238 end loop; 3239 end if; 3240 3241 if Present (Component_Associations (Inits)) then 3242 Init := First (Component_Associations (Inits)); 3243 while Present (Init) loop 3244 Analyze_Initialization_Item_With_Inputs (Init); 3245 Next (Init); 3246 end loop; 3247 end if; 3248 3249 -- Ensure that a state and a corresponding constituent do not appear 3250 -- together in pragma Initializes. 3251 3252 Check_State_And_Constituent_Use 3253 (States => States_Seen, 3254 Constits => Constits_Seen, 3255 Context => N); 3256 3257 Set_Is_Analyzed_Pragma (N); 3258 end Analyze_Initializes_In_Decl_Part; 3259 3260 --------------------- 3261 -- Analyze_Part_Of -- 3262 --------------------- 3263 3264 procedure Analyze_Part_Of 3265 (Indic : Node_Id; 3266 Item_Id : Entity_Id; 3267 Encap : Node_Id; 3268 Encap_Id : out Entity_Id; 3269 Legal : out Boolean) 3270 is 3271 procedure Check_Part_Of_Abstract_State; 3272 pragma Inline (Check_Part_Of_Abstract_State); 3273 -- Verify the legality of indicator Part_Of when the encapsulator is an 3274 -- abstract state. 3275 3276 procedure Check_Part_Of_Concurrent_Type; 3277 pragma Inline (Check_Part_Of_Concurrent_Type); 3278 -- Verify the legality of indicator Part_Of when the encapsulator is a 3279 -- single concurrent type. 3280 3281 ---------------------------------- 3282 -- Check_Part_Of_Abstract_State -- 3283 ---------------------------------- 3284 3285 procedure Check_Part_Of_Abstract_State is 3286 Pack_Id : Entity_Id; 3287 Placement : State_Space_Kind; 3288 Parent_Unit : Entity_Id; 3289 3290 begin 3291 -- Determine where the object, package instantiation or state lives 3292 -- with respect to the enclosing packages or package bodies. 3293 3294 Find_Placement_In_State_Space 3295 (Item_Id => Item_Id, 3296 Placement => Placement, 3297 Pack_Id => Pack_Id); 3298 3299 -- The item appears in a non-package construct with a declarative 3300 -- part (subprogram, block, etc). As such, the item is not allowed 3301 -- to be a part of an encapsulating state because the item is not 3302 -- visible. 3303 3304 if Placement = Not_In_Package then 3305 SPARK_Msg_N 3306 ("indicator Part_Of cannot appear in this context " 3307 & "(SPARK RM 7.2.6(5))", Indic); 3308 3309 Error_Msg_Name_1 := Chars (Scope (Encap_Id)); 3310 SPARK_Msg_NE 3311 ("\& is not part of the hidden state of package %", 3312 Indic, Item_Id); 3313 return; 3314 3315 -- The item appears in the visible state space of some package. In 3316 -- general this scenario does not warrant Part_Of except when the 3317 -- package is a nongeneric private child unit and the encapsulating 3318 -- state is declared in a parent unit or a public descendant of that 3319 -- parent unit. 3320 3321 elsif Placement = Visible_State_Space then 3322 if Is_Child_Unit (Pack_Id) 3323 and then not Is_Generic_Unit (Pack_Id) 3324 and then Is_Private_Descendant (Pack_Id) 3325 then 3326 -- A variable or state abstraction which is part of the visible 3327 -- state of a nongeneric private child unit or its public 3328 -- descendants must have its Part_Of indicator specified. The 3329 -- Part_Of indicator must denote a state declared by either the 3330 -- parent unit of the private unit or by a public descendant of 3331 -- that parent unit. 3332 3333 -- Find the nearest private ancestor (which can be the current 3334 -- unit itself). 3335 3336 Parent_Unit := Pack_Id; 3337 while Present (Parent_Unit) loop 3338 exit when 3339 Private_Present 3340 (Parent (Unit_Declaration_Node (Parent_Unit))); 3341 Parent_Unit := Scope (Parent_Unit); 3342 end loop; 3343 3344 Parent_Unit := Scope (Parent_Unit); 3345 3346 if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then 3347 SPARK_Msg_NE 3348 ("indicator Part_Of must denote abstract state of & or of " 3349 & "its public descendant (SPARK RM 7.2.6(3))", 3350 Indic, Parent_Unit); 3351 return; 3352 3353 elsif Scope (Encap_Id) = Parent_Unit 3354 or else 3355 (Is_Ancestor_Package (Parent_Unit, Scope (Encap_Id)) 3356 and then not Is_Private_Descendant (Scope (Encap_Id))) 3357 then 3358 null; 3359 3360 else 3361 SPARK_Msg_NE 3362 ("indicator Part_Of must denote abstract state of & or of " 3363 & "its public descendant (SPARK RM 7.2.6(3))", 3364 Indic, Parent_Unit); 3365 return; 3366 end if; 3367 3368 -- Indicator Part_Of is not needed when the related package is 3369 -- not a nongeneric private child unit or a public descendant 3370 -- thereof. 3371 3372 else 3373 SPARK_Msg_N 3374 ("indicator Part_Of cannot appear in this context " 3375 & "(SPARK RM 7.2.6(5))", Indic); 3376 3377 Error_Msg_Name_1 := Chars (Pack_Id); 3378 SPARK_Msg_NE 3379 ("\& is declared in the visible part of package %", 3380 Indic, Item_Id); 3381 return; 3382 end if; 3383 3384 -- When the item appears in the private state space of a package, the 3385 -- encapsulating state must be declared in the same package. 3386 3387 elsif Placement = Private_State_Space then 3388 if Scope (Encap_Id) /= Pack_Id then 3389 SPARK_Msg_NE 3390 ("indicator Part_Of must denote an abstract state of " 3391 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id); 3392 3393 Error_Msg_Name_1 := Chars (Pack_Id); 3394 SPARK_Msg_NE 3395 ("\& is declared in the private part of package %", 3396 Indic, Item_Id); 3397 return; 3398 end if; 3399 3400 -- Items declared in the body state space of a package do not need 3401 -- Part_Of indicators as the refinement has already been seen. 3402 3403 else 3404 SPARK_Msg_N 3405 ("indicator Part_Of cannot appear in this context " 3406 & "(SPARK RM 7.2.6(5))", Indic); 3407 3408 if Scope (Encap_Id) = Pack_Id then 3409 Error_Msg_Name_1 := Chars (Pack_Id); 3410 SPARK_Msg_NE 3411 ("\& is declared in the body of package %", Indic, Item_Id); 3412 end if; 3413 3414 return; 3415 end if; 3416 3417 -- At this point it is known that the Part_Of indicator is legal 3418 3419 Legal := True; 3420 end Check_Part_Of_Abstract_State; 3421 3422 ----------------------------------- 3423 -- Check_Part_Of_Concurrent_Type -- 3424 ----------------------------------- 3425 3426 procedure Check_Part_Of_Concurrent_Type is 3427 function In_Proper_Order 3428 (First : Node_Id; 3429 Second : Node_Id) return Boolean; 3430 pragma Inline (In_Proper_Order); 3431 -- Determine whether node First precedes node Second 3432 3433 procedure Placement_Error; 3434 pragma Inline (Placement_Error); 3435 -- Emit an error concerning the illegal placement of the item with 3436 -- respect to the single concurrent type. 3437 3438 --------------------- 3439 -- In_Proper_Order -- 3440 --------------------- 3441 3442 function In_Proper_Order 3443 (First : Node_Id; 3444 Second : Node_Id) return Boolean 3445 is 3446 N : Node_Id; 3447 3448 begin 3449 if List_Containing (First) = List_Containing (Second) then 3450 N := First; 3451 while Present (N) loop 3452 if N = Second then 3453 return True; 3454 end if; 3455 3456 Next (N); 3457 end loop; 3458 end if; 3459 3460 return False; 3461 end In_Proper_Order; 3462 3463 --------------------- 3464 -- Placement_Error -- 3465 --------------------- 3466 3467 procedure Placement_Error is 3468 begin 3469 SPARK_Msg_N 3470 ("indicator Part_Of must denote a previously declared single " 3471 & "protected type or single task type", Encap); 3472 end Placement_Error; 3473 3474 -- Local variables 3475 3476 Conc_Typ : constant Entity_Id := Etype (Encap_Id); 3477 Encap_Decl : constant Node_Id := Declaration_Node (Encap_Id); 3478 Encap_Context : constant Node_Id := Parent (Encap_Decl); 3479 3480 Item_Context : Node_Id; 3481 Item_Decl : Node_Id; 3482 Prv_Decls : List_Id; 3483 Vis_Decls : List_Id; 3484 3485 -- Start of processing for Check_Part_Of_Concurrent_Type 3486 3487 begin 3488 -- Only abstract states and variables can act as constituents of an 3489 -- encapsulating single concurrent type. 3490 3491 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 3492 null; 3493 3494 -- The constituent is a constant 3495 3496 elsif Ekind (Item_Id) = E_Constant then 3497 Error_Msg_Name_1 := Chars (Encap_Id); 3498 SPARK_Msg_NE 3499 (Fix_Msg (Conc_Typ, "constant & cannot act as constituent of " 3500 & "single protected type %"), Indic, Item_Id); 3501 return; 3502 3503 -- The constituent is a package instantiation 3504 3505 else 3506 Error_Msg_Name_1 := Chars (Encap_Id); 3507 SPARK_Msg_NE 3508 (Fix_Msg (Conc_Typ, "package instantiation & cannot act as " 3509 & "constituent of single protected type %"), Indic, Item_Id); 3510 return; 3511 end if; 3512 3513 -- When the item denotes an abstract state of a nested package, use 3514 -- the declaration of the package to detect proper placement. 3515 3516 -- package Pack is 3517 -- task T; 3518 -- package Nested 3519 -- with Abstract_State => (State with Part_Of => T) 3520 3521 if Ekind (Item_Id) = E_Abstract_State then 3522 Item_Decl := Unit_Declaration_Node (Scope (Item_Id)); 3523 else 3524 Item_Decl := Declaration_Node (Item_Id); 3525 end if; 3526 3527 Item_Context := Parent (Item_Decl); 3528 3529 -- The item and the single concurrent type must appear in the same 3530 -- declarative region, with the item following the declaration of 3531 -- the single concurrent type (SPARK RM 9(3)). 3532 3533 if Item_Context = Encap_Context then 3534 if Nkind_In (Item_Context, N_Package_Specification, 3535 N_Protected_Definition, 3536 N_Task_Definition) 3537 then 3538 Prv_Decls := Private_Declarations (Item_Context); 3539 Vis_Decls := Visible_Declarations (Item_Context); 3540 3541 -- The placement is OK when the single concurrent type appears 3542 -- within the visible declarations and the item in the private 3543 -- declarations. 3544 -- 3545 -- package Pack is 3546 -- protected PO ... 3547 -- private 3548 -- Constit : ... with Part_Of => PO; 3549 -- end Pack; 3550 3551 if List_Containing (Encap_Decl) = Vis_Decls 3552 and then List_Containing (Item_Decl) = Prv_Decls 3553 then 3554 null; 3555 3556 -- The placement is illegal when the item appears within the 3557 -- visible declarations and the single concurrent type is in 3558 -- the private declarations. 3559 -- 3560 -- package Pack is 3561 -- Constit : ... with Part_Of => PO; 3562 -- private 3563 -- protected PO ... 3564 -- end Pack; 3565 3566 elsif List_Containing (Item_Decl) = Vis_Decls 3567 and then List_Containing (Encap_Decl) = Prv_Decls 3568 then 3569 Placement_Error; 3570 return; 3571 3572 -- Otherwise both the item and the single concurrent type are 3573 -- in the same list. Ensure that the declaration of the single 3574 -- concurrent type precedes that of the item. 3575 3576 elsif not In_Proper_Order 3577 (First => Encap_Decl, 3578 Second => Item_Decl) 3579 then 3580 Placement_Error; 3581 return; 3582 end if; 3583 3584 -- Otherwise both the item and the single concurrent type are 3585 -- in the same list. Ensure that the declaration of the single 3586 -- concurrent type precedes that of the item. 3587 3588 elsif not In_Proper_Order 3589 (First => Encap_Decl, 3590 Second => Item_Decl) 3591 then 3592 Placement_Error; 3593 return; 3594 end if; 3595 3596 -- Otherwise the item and the single concurrent type reside within 3597 -- unrelated regions. 3598 3599 else 3600 Error_Msg_Name_1 := Chars (Encap_Id); 3601 SPARK_Msg_NE 3602 (Fix_Msg (Conc_Typ, "constituent & must be declared " 3603 & "immediately within the same region as single protected " 3604 & "type %"), Indic, Item_Id); 3605 return; 3606 end if; 3607 3608 -- At this point it is known that the Part_Of indicator is legal 3609 3610 Legal := True; 3611 end Check_Part_Of_Concurrent_Type; 3612 3613 -- Start of processing for Analyze_Part_Of 3614 3615 begin 3616 -- Assume that the indicator is illegal 3617 3618 Encap_Id := Empty; 3619 Legal := False; 3620 3621 if Nkind_In (Encap, N_Expanded_Name, 3622 N_Identifier, 3623 N_Selected_Component) 3624 then 3625 Analyze (Encap); 3626 Resolve_State (Encap); 3627 3628 Encap_Id := Entity (Encap); 3629 3630 -- The encapsulator is an abstract state 3631 3632 if Ekind (Encap_Id) = E_Abstract_State then 3633 null; 3634 3635 -- The encapsulator is a single concurrent type (SPARK RM 9.3) 3636 3637 elsif Is_Single_Concurrent_Object (Encap_Id) then 3638 null; 3639 3640 -- Otherwise the encapsulator is not a legal choice 3641 3642 else 3643 SPARK_Msg_N 3644 ("indicator Part_Of must denote abstract state, single " 3645 & "protected type or single task type", Encap); 3646 return; 3647 end if; 3648 3649 -- This is a syntax error, always report 3650 3651 else 3652 Error_Msg_N 3653 ("indicator Part_Of must denote abstract state, single protected " 3654 & "type or single task type", Encap); 3655 return; 3656 end if; 3657 3658 -- Catch a case where indicator Part_Of denotes the abstract view of a 3659 -- variable which appears as an abstract state (SPARK RM 10.1.2 2). 3660 3661 if From_Limited_With (Encap_Id) 3662 and then Present (Non_Limited_View (Encap_Id)) 3663 and then Ekind (Non_Limited_View (Encap_Id)) = E_Variable 3664 then 3665 SPARK_Msg_N ("indicator Part_Of must denote abstract state", Encap); 3666 SPARK_Msg_N ("\& denotes abstract view of object", Encap); 3667 return; 3668 end if; 3669 3670 -- The encapsulator is an abstract state 3671 3672 if Ekind (Encap_Id) = E_Abstract_State then 3673 Check_Part_Of_Abstract_State; 3674 3675 -- The encapsulator is a single concurrent type 3676 3677 else 3678 Check_Part_Of_Concurrent_Type; 3679 end if; 3680 end Analyze_Part_Of; 3681 3682 ---------------------------------- 3683 -- Analyze_Part_Of_In_Decl_Part -- 3684 ---------------------------------- 3685 3686 procedure Analyze_Part_Of_In_Decl_Part 3687 (N : Node_Id; 3688 Freeze_Id : Entity_Id := Empty) 3689 is 3690 Encap : constant Node_Id := 3691 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 3692 Errors : constant Nat := Serious_Errors_Detected; 3693 Var_Decl : constant Node_Id := Find_Related_Context (N); 3694 Var_Id : constant Entity_Id := Defining_Entity (Var_Decl); 3695 Constits : Elist_Id; 3696 Encap_Id : Entity_Id; 3697 Legal : Boolean; 3698 3699 begin 3700 -- Detect any discrepancies between the placement of the variable with 3701 -- respect to general state space and the encapsulating state or single 3702 -- concurrent type. 3703 3704 Analyze_Part_Of 3705 (Indic => N, 3706 Item_Id => Var_Id, 3707 Encap => Encap, 3708 Encap_Id => Encap_Id, 3709 Legal => Legal); 3710 3711 -- The Part_Of indicator turns the variable into a constituent of the 3712 -- encapsulating state or single concurrent type. 3713 3714 if Legal then 3715 pragma Assert (Present (Encap_Id)); 3716 Constits := Part_Of_Constituents (Encap_Id); 3717 3718 if No (Constits) then 3719 Constits := New_Elmt_List; 3720 Set_Part_Of_Constituents (Encap_Id, Constits); 3721 end if; 3722 3723 Append_Elmt (Var_Id, Constits); 3724 Set_Encapsulating_State (Var_Id, Encap_Id); 3725 3726 -- A Part_Of constituent partially refines an abstract state. This 3727 -- property does not apply to protected or task units. 3728 3729 if Ekind (Encap_Id) = E_Abstract_State then 3730 Set_Has_Partial_Visible_Refinement (Encap_Id); 3731 end if; 3732 end if; 3733 3734 -- Emit a clarification message when the encapsulator is undefined, 3735 -- possibly due to contract freezing. 3736 3737 if Errors /= Serious_Errors_Detected 3738 and then Present (Freeze_Id) 3739 and then Has_Undefined_Reference (Encap) 3740 then 3741 Contract_Freeze_Error (Var_Id, Freeze_Id); 3742 end if; 3743 end Analyze_Part_Of_In_Decl_Part; 3744 3745 -------------------- 3746 -- Analyze_Pragma -- 3747 -------------------- 3748 3749 procedure Analyze_Pragma (N : Node_Id) is 3750 Loc : constant Source_Ptr := Sloc (N); 3751 3752 Pname : Name_Id := Pragma_Name (N); 3753 -- Name of the source pragma, or name of the corresponding aspect for 3754 -- pragmas which originate in a source aspect. In the latter case, the 3755 -- name may be different from the pragma name. 3756 3757 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); 3758 3759 Pragma_Exit : exception; 3760 -- This exception is used to exit pragma processing completely. It 3761 -- is used when an error is detected, and no further processing is 3762 -- required. It is also used if an earlier error has left the tree in 3763 -- a state where the pragma should not be processed. 3764 3765 Arg_Count : Nat; 3766 -- Number of pragma argument associations 3767 3768 Arg1 : Node_Id; 3769 Arg2 : Node_Id; 3770 Arg3 : Node_Id; 3771 Arg4 : Node_Id; 3772 -- First four pragma arguments (pragma argument association nodes, or 3773 -- Empty if the corresponding argument does not exist). 3774 3775 type Name_List is array (Natural range <>) of Name_Id; 3776 type Args_List is array (Natural range <>) of Node_Id; 3777 -- Types used for arguments to Check_Arg_Order and Gather_Associations 3778 3779 ----------------------- 3780 -- Local Subprograms -- 3781 ----------------------- 3782 3783 function Acc_First (N : Node_Id) return Node_Id; 3784 -- Helper function to iterate over arguments given to OpenAcc pragmas 3785 3786 function Acc_Next (N : Node_Id) return Node_Id; 3787 -- Helper function to iterate over arguments given to OpenAcc pragmas 3788 3789 procedure Ada_2005_Pragma; 3790 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In 3791 -- Ada 95 mode, these are implementation defined pragmas, so should be 3792 -- caught by the No_Implementation_Pragmas restriction. 3793 3794 procedure Ada_2012_Pragma; 3795 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. 3796 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so 3797 -- should be caught by the No_Implementation_Pragmas restriction. 3798 3799 procedure Analyze_Depends_Global 3800 (Spec_Id : out Entity_Id; 3801 Subp_Decl : out Node_Id; 3802 Legal : out Boolean); 3803 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the 3804 -- legality of the placement and related context of the pragma. Spec_Id 3805 -- is the entity of the related subprogram. Subp_Decl is the declaration 3806 -- of the related subprogram. Sets flag Legal when the pragma is legal. 3807 3808 procedure Analyze_If_Present (Id : Pragma_Id); 3809 -- Inspect the remainder of the list containing pragma N and look for 3810 -- a pragma that matches Id. If found, analyze the pragma. 3811 3812 procedure Analyze_Pre_Post_Condition; 3813 -- Subsidiary to the analysis of pragmas Precondition and Postcondition 3814 3815 procedure Analyze_Refined_Depends_Global_Post 3816 (Spec_Id : out Entity_Id; 3817 Body_Id : out Entity_Id; 3818 Legal : out Boolean); 3819 -- Subsidiary routine to the analysis of body pragmas Refined_Depends, 3820 -- Refined_Global and Refined_Post. Verify the legality of the placement 3821 -- and related context of the pragma. Spec_Id is the entity of the 3822 -- related subprogram. Body_Id is the entity of the subprogram body. 3823 -- Flag Legal is set when the pragma is legal. 3824 3825 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False); 3826 -- Perform full analysis of pragma Unmodified and the write aspect of 3827 -- pragma Unused. Flag Is_Unused should be set when verifying the 3828 -- semantics of pragma Unused. 3829 3830 procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False); 3831 -- Perform full analysis of pragma Unreferenced and the read aspect of 3832 -- pragma Unused. Flag Is_Unused should be set when verifying the 3833 -- semantics of pragma Unused. 3834 3835 procedure Check_Ada_83_Warning; 3836 -- Issues a warning message for the current pragma if operating in Ada 3837 -- 83 mode (used for language pragmas that are not a standard part of 3838 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use 3839 -- of 95 pragma. 3840 3841 procedure Check_Arg_Count (Required : Nat); 3842 -- Check argument count for pragma is equal to given parameter. If not, 3843 -- then issue an error message and raise Pragma_Exit. 3844 3845 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument 3846 -- Arg which can either be a pragma argument association, in which case 3847 -- the check is applied to the expression of the association or an 3848 -- expression directly. 3849 3850 procedure Check_Arg_Is_External_Name (Arg : Node_Id); 3851 -- Check that an argument has the right form for an EXTERNAL_NAME 3852 -- parameter of an extended import/export pragma. The rule is that the 3853 -- name must be an identifier or string literal (in Ada 83 mode) or a 3854 -- static string expression (in Ada 95 mode). 3855 3856 procedure Check_Arg_Is_Identifier (Arg : Node_Id); 3857 -- Check the specified argument Arg to make sure that it is an 3858 -- identifier. If not give error and raise Pragma_Exit. 3859 3860 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); 3861 -- Check the specified argument Arg to make sure that it is an integer 3862 -- literal. If not give error and raise Pragma_Exit. 3863 3864 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); 3865 -- Check the specified argument Arg to make sure that it has the proper 3866 -- syntactic form for a local name and meets the semantic requirements 3867 -- for a local name. The local name is analyzed as part of the 3868 -- processing for this call. In addition, the local name is required 3869 -- to represent an entity at the library level. 3870 3871 procedure Check_Arg_Is_Local_Name (Arg : Node_Id); 3872 -- Check the specified argument Arg to make sure that it has the proper 3873 -- syntactic form for a local name and meets the semantic requirements 3874 -- for a local name. The local name is analyzed as part of the 3875 -- processing for this call. 3876 3877 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); 3878 -- Check the specified argument Arg to make sure that it is a valid 3879 -- locking policy name. If not give error and raise Pragma_Exit. 3880 3881 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); 3882 -- Check the specified argument Arg to make sure that it is a valid 3883 -- elaboration policy name. If not give error and raise Pragma_Exit. 3884 3885 procedure Check_Arg_Is_One_Of 3886 (Arg : Node_Id; 3887 N1, N2 : Name_Id); 3888 procedure Check_Arg_Is_One_Of 3889 (Arg : Node_Id; 3890 N1, N2, N3 : Name_Id); 3891 procedure Check_Arg_Is_One_Of 3892 (Arg : Node_Id; 3893 N1, N2, N3, N4 : Name_Id); 3894 procedure Check_Arg_Is_One_Of 3895 (Arg : Node_Id; 3896 N1, N2, N3, N4, N5 : Name_Id); 3897 -- Check the specified argument Arg to make sure that it is an 3898 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if 3899 -- present). If not then give error and raise Pragma_Exit. 3900 3901 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); 3902 -- Check the specified argument Arg to make sure that it is a valid 3903 -- queuing policy name. If not give error and raise Pragma_Exit. 3904 3905 procedure Check_Arg_Is_OK_Static_Expression 3906 (Arg : Node_Id; 3907 Typ : Entity_Id := Empty); 3908 -- Check the specified argument Arg to make sure that it is a static 3909 -- expression of the given type (i.e. it will be analyzed and resolved 3910 -- using this type, which can be any valid argument to Resolve, e.g. 3911 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 3912 -- Typ is left Empty, then any static expression is allowed. Includes 3913 -- checking that the argument does not raise Constraint_Error. 3914 3915 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); 3916 -- Check the specified argument Arg to make sure that it is a valid task 3917 -- dispatching policy name. If not give error and raise Pragma_Exit. 3918 3919 procedure Check_Arg_Order (Names : Name_List); 3920 -- Checks for an instance of two arguments with identifiers for the 3921 -- current pragma which are not in the sequence indicated by Names, 3922 -- and if so, generates a fatal message about bad order of arguments. 3923 3924 procedure Check_At_Least_N_Arguments (N : Nat); 3925 -- Check there are at least N arguments present 3926 3927 procedure Check_At_Most_N_Arguments (N : Nat); 3928 -- Check there are no more than N arguments present 3929 3930 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean); 3931 -- Apply legality checks to type or object E subject to an Atomic aspect 3932 -- in Ada 2020 (RM C.6(13)) or to a Volatile_Full_Access aspect. 3933 3934 procedure Check_Component 3935 (Comp : Node_Id; 3936 UU_Typ : Entity_Id; 3937 In_Variant_Part : Boolean := False); 3938 -- Examine an Unchecked_Union component for correct use of per-object 3939 -- constrained subtypes, and for restrictions on finalizable components. 3940 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part 3941 -- should be set when Comp comes from a record variant. 3942 3943 procedure Check_Duplicate_Pragma (E : Entity_Id); 3944 -- Check if a rep item of the same name as the current pragma is already 3945 -- chained as a rep pragma to the given entity. If so give a message 3946 -- about the duplicate, and then raise Pragma_Exit so does not return. 3947 -- Note that if E is a type, then this routine avoids flagging a pragma 3948 -- which applies to a parent type from which E is derived. 3949 3950 procedure Check_Duplicated_Export_Name (Nam : Node_Id); 3951 -- Nam is an N_String_Literal node containing the external name set by 3952 -- an Import or Export pragma (or extended Import or Export pragma). 3953 -- This procedure checks for possible duplications if this is the export 3954 -- case, and if found, issues an appropriate error message. 3955 3956 procedure Check_Expr_Is_OK_Static_Expression 3957 (Expr : Node_Id; 3958 Typ : Entity_Id := Empty); 3959 -- Check the specified expression Expr to make sure that it is a static 3960 -- expression of the given type (i.e. it will be analyzed and resolved 3961 -- using this type, which can be any valid argument to Resolve, e.g. 3962 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 3963 -- Typ is left Empty, then any static expression is allowed. Includes 3964 -- checking that the expression does not raise Constraint_Error. 3965 3966 procedure Check_First_Subtype (Arg : Node_Id); 3967 -- Checks that Arg, whose expression is an entity name, references a 3968 -- first subtype. 3969 3970 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id); 3971 -- Checks that the given argument has an identifier, and if so, requires 3972 -- it to match the given identifier name. If there is no identifier, or 3973 -- a non-matching identifier, then an error message is given and 3974 -- Pragma_Exit is raised. 3975 3976 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); 3977 -- Checks that the given argument has an identifier, and if so, requires 3978 -- it to match one of the given identifier names. If there is no 3979 -- identifier, or a non-matching identifier, then an error message is 3980 -- given and Pragma_Exit is raised. 3981 3982 procedure Check_In_Main_Program; 3983 -- Common checks for pragmas that appear within a main program 3984 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). 3985 3986 procedure Check_Interrupt_Or_Attach_Handler; 3987 -- Common processing for first argument of pragma Interrupt_Handler or 3988 -- pragma Attach_Handler. 3989 3990 procedure Check_Loop_Pragma_Placement; 3991 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant 3992 -- appear immediately within a construct restricted to loops, and that 3993 -- pragmas Loop_Invariant and Loop_Variant are grouped together. 3994 3995 procedure Check_Is_In_Decl_Part_Or_Package_Spec; 3996 -- Check that pragma appears in a declarative part, or in a package 3997 -- specification, i.e. that it does not occur in a statement sequence 3998 -- in a body. 3999 4000 procedure Check_No_Identifier (Arg : Node_Id); 4001 -- Checks that the given argument does not have an identifier. If 4002 -- an identifier is present, then an error message is issued, and 4003 -- Pragma_Exit is raised. 4004 4005 procedure Check_No_Identifiers; 4006 -- Checks that none of the arguments to the pragma has an identifier. 4007 -- If any argument has an identifier, then an error message is issued, 4008 -- and Pragma_Exit is raised. 4009 4010 procedure Check_No_Link_Name; 4011 -- Checks that no link name is specified 4012 4013 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 4014 -- Checks if the given argument has an identifier, and if so, requires 4015 -- it to match the given identifier name. If there is a non-matching 4016 -- identifier, then an error message is given and Pragma_Exit is raised. 4017 4018 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); 4019 -- Checks if the given argument has an identifier, and if so, requires 4020 -- it to match the given identifier name. If there is a non-matching 4021 -- identifier, then an error message is given and Pragma_Exit is raised. 4022 -- In this version of the procedure, the identifier name is given as 4023 -- a string with lower case letters. 4024 4025 procedure Check_Static_Boolean_Expression (Expr : Node_Id); 4026 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers, 4027 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes, 4028 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr 4029 -- is an OK static boolean expression. Emit an error if this is not the 4030 -- case. 4031 4032 procedure Check_Static_Constraint (Constr : Node_Id); 4033 -- Constr is a constraint from an N_Subtype_Indication node from a 4034 -- component constraint in an Unchecked_Union type. This routine checks 4035 -- that the constraint is static as required by the restrictions for 4036 -- Unchecked_Union. 4037 4038 procedure Check_Valid_Configuration_Pragma; 4039 -- Legality checks for placement of a configuration pragma 4040 4041 procedure Check_Valid_Library_Unit_Pragma; 4042 -- Legality checks for library unit pragmas. A special case arises for 4043 -- pragmas in generic instances that come from copies of the original 4044 -- library unit pragmas in the generic templates. In the case of other 4045 -- than library level instantiations these can appear in contexts which 4046 -- would normally be invalid (they only apply to the original template 4047 -- and to library level instantiations), and they are simply ignored, 4048 -- which is implemented by rewriting them as null statements. 4049 4050 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); 4051 -- Check an Unchecked_Union variant for lack of nested variants and 4052 -- presence of at least one component. UU_Typ is the related Unchecked_ 4053 -- Union type. 4054 4055 procedure Ensure_Aggregate_Form (Arg : Node_Id); 4056 -- Subsidiary routine to the processing of pragmas Abstract_State, 4057 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends, 4058 -- Refined_Global and Refined_State. Transform argument Arg into 4059 -- an aggregate if not one already. N_Null is never transformed. 4060 -- Arg may denote an aspect specification or a pragma argument 4061 -- association. 4062 4063 procedure Error_Pragma (Msg : String); 4064 pragma No_Return (Error_Pragma); 4065 -- Outputs error message for current pragma. The message contains a % 4066 -- that will be replaced with the pragma name, and the flag is placed 4067 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine 4068 -- calls Fix_Error (see spec of that procedure for details). 4069 4070 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); 4071 pragma No_Return (Error_Pragma_Arg); 4072 -- Outputs error message for current pragma. The message may contain 4073 -- a % that will be replaced with the pragma name. The parameter Arg 4074 -- may either be a pragma argument association, in which case the flag 4075 -- is placed on the expression of this association, or an expression, 4076 -- in which case the flag is placed directly on the expression. The 4077 -- message is placed using Error_Msg_N, so the message may also contain 4078 -- an & insertion character which will reference the given Arg value. 4079 -- After placing the message, Pragma_Exit is raised. Note: this routine 4080 -- calls Fix_Error (see spec of that procedure for details). 4081 4082 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); 4083 pragma No_Return (Error_Pragma_Arg); 4084 -- Similar to above form of Error_Pragma_Arg except that two messages 4085 -- are provided, the second is a continuation comment starting with \. 4086 4087 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); 4088 pragma No_Return (Error_Pragma_Arg_Ident); 4089 -- Outputs error message for current pragma. The message may contain a % 4090 -- that will be replaced with the pragma name. The parameter Arg must be 4091 -- a pragma argument association with a non-empty identifier (i.e. its 4092 -- Chars field must be set), and the error message is placed on the 4093 -- identifier. The message is placed using Error_Msg_N so the message 4094 -- may also contain an & insertion character which will reference 4095 -- the identifier. After placing the message, Pragma_Exit is raised. 4096 -- Note: this routine calls Fix_Error (see spec of that procedure for 4097 -- details). 4098 4099 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); 4100 pragma No_Return (Error_Pragma_Ref); 4101 -- Outputs error message for current pragma. The message may contain 4102 -- a % that will be replaced with the pragma name. The parameter Ref 4103 -- must be an entity whose name can be referenced by & and sloc by #. 4104 -- After placing the message, Pragma_Exit is raised. Note: this routine 4105 -- calls Fix_Error (see spec of that procedure for details). 4106 4107 function Find_Lib_Unit_Name return Entity_Id; 4108 -- Used for a library unit pragma to find the entity to which the 4109 -- library unit pragma applies, returns the entity found. 4110 4111 procedure Find_Program_Unit_Name (Id : Node_Id); 4112 -- If the pragma is a compilation unit pragma, the id must denote the 4113 -- compilation unit in the same compilation, and the pragma must appear 4114 -- in the list of preceding or trailing pragmas. If it is a program 4115 -- unit pragma that is not a compilation unit pragma, then the 4116 -- identifier must be visible. 4117 4118 function Find_Unique_Parameterless_Procedure 4119 (Name : Entity_Id; 4120 Arg : Node_Id) return Entity_Id; 4121 -- Used for a procedure pragma to find the unique parameterless 4122 -- procedure identified by Name, returns it if it exists, otherwise 4123 -- errors out and uses Arg as the pragma argument for the message. 4124 4125 function Fix_Error (Msg : String) return String; 4126 -- This is called prior to issuing an error message. Msg is the normal 4127 -- error message issued in the pragma case. This routine checks for the 4128 -- case of a pragma coming from an aspect in the source, and returns a 4129 -- message suitable for the aspect case as follows: 4130 -- 4131 -- Each substring "pragma" is replaced by "aspect" 4132 -- 4133 -- If "argument of" is at the start of the error message text, it is 4134 -- replaced by "entity for". 4135 -- 4136 -- If "argument" is at the start of the error message text, it is 4137 -- replaced by "entity". 4138 -- 4139 -- So for example, "argument of pragma X must be discrete type" 4140 -- returns "entity for aspect X must be a discrete type". 4141 4142 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may 4143 -- be different from the pragma name). If the current pragma results 4144 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the 4145 -- original pragma name. 4146 4147 procedure Gather_Associations 4148 (Names : Name_List; 4149 Args : out Args_List); 4150 -- This procedure is used to gather the arguments for a pragma that 4151 -- permits arbitrary ordering of parameters using the normal rules 4152 -- for named and positional parameters. The Names argument is a list 4153 -- of Name_Id values that corresponds to the allowed pragma argument 4154 -- association identifiers in order. The result returned in Args is 4155 -- a list of corresponding expressions that are the pragma arguments. 4156 -- Note that this is a list of expressions, not of pragma argument 4157 -- associations (Gather_Associations has completely checked all the 4158 -- optional identifiers when it returns). An entry in Args is Empty 4159 -- on return if the corresponding argument is not present. 4160 4161 procedure GNAT_Pragma; 4162 -- Called for all GNAT defined pragmas to check the relevant restriction 4163 -- (No_Implementation_Pragmas). 4164 4165 function Is_Before_First_Decl 4166 (Pragma_Node : Node_Id; 4167 Decls : List_Id) return Boolean; 4168 -- Return True if Pragma_Node is before the first declarative item in 4169 -- Decls where Decls is the list of declarative items. 4170 4171 function Is_Configuration_Pragma return Boolean; 4172 -- Determines if the placement of the current pragma is appropriate 4173 -- for a configuration pragma. 4174 4175 function Is_In_Context_Clause return Boolean; 4176 -- Returns True if pragma appears within the context clause of a unit, 4177 -- and False for any other placement (does not generate any messages). 4178 4179 function Is_Static_String_Expression (Arg : Node_Id) return Boolean; 4180 -- Analyzes the argument, and determines if it is a static string 4181 -- expression, returns True if so, False if non-static or not String. 4182 -- A special case is that a string literal returns True in Ada 83 mode 4183 -- (which has no such thing as static string expressions). Note that 4184 -- the call analyzes its argument, so this cannot be used for the case 4185 -- where an identifier might not be declared. 4186 4187 procedure Pragma_Misplaced; 4188 pragma No_Return (Pragma_Misplaced); 4189 -- Issue fatal error message for misplaced pragma 4190 4191 procedure Process_Atomic_Independent_Shared_Volatile; 4192 -- Common processing for pragmas Atomic, Independent, Shared, Volatile, 4193 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma 4194 -- and treated as being identical in effect to pragma Atomic. 4195 4196 procedure Process_Compile_Time_Warning_Or_Error; 4197 -- Common processing for Compile_Time_Error and Compile_Time_Warning 4198 4199 procedure Process_Convention 4200 (C : out Convention_Id; 4201 Ent : out Entity_Id); 4202 -- Common processing for Convention, Interface, Import and Export. 4203 -- Checks first two arguments of pragma, and sets the appropriate 4204 -- convention value in the specified entity or entities. On return 4205 -- C is the convention, Ent is the referenced entity. 4206 4207 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); 4208 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is 4209 -- Name_Suppress for Disable and Name_Unsuppress for Enable. 4210 4211 procedure Process_Extended_Import_Export_Object_Pragma 4212 (Arg_Internal : Node_Id; 4213 Arg_External : Node_Id; 4214 Arg_Size : Node_Id); 4215 -- Common processing for the pragmas Import/Export_Object. The three 4216 -- arguments correspond to the three named parameters of the pragmas. An 4217 -- argument is empty if the corresponding parameter is not present in 4218 -- the pragma. 4219 4220 procedure Process_Extended_Import_Export_Internal_Arg 4221 (Arg_Internal : Node_Id := Empty); 4222 -- Common processing for all extended Import and Export pragmas. The 4223 -- argument is the pragma parameter for the Internal argument. If 4224 -- Arg_Internal is empty or inappropriate, an error message is posted. 4225 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is 4226 -- set to identify the referenced entity. 4227 4228 procedure Process_Extended_Import_Export_Subprogram_Pragma 4229 (Arg_Internal : Node_Id; 4230 Arg_External : Node_Id; 4231 Arg_Parameter_Types : Node_Id; 4232 Arg_Result_Type : Node_Id := Empty; 4233 Arg_Mechanism : Node_Id; 4234 Arg_Result_Mechanism : Node_Id := Empty); 4235 -- Common processing for all extended Import and Export pragmas applying 4236 -- to subprograms. The caller omits any arguments that do not apply to 4237 -- the pragma in question (for example, Arg_Result_Type can be non-Empty 4238 -- only in the Import_Function and Export_Function cases). The argument 4239 -- names correspond to the allowed pragma association identifiers. 4240 4241 procedure Process_Generic_List; 4242 -- Common processing for Share_Generic and Inline_Generic 4243 4244 procedure Process_Import_Or_Interface; 4245 -- Common processing for Import or Interface 4246 4247 procedure Process_Import_Predefined_Type; 4248 -- Processing for completing a type with pragma Import. This is used 4249 -- to declare types that match predefined C types, especially for cases 4250 -- without corresponding Ada predefined type. 4251 4252 type Inline_Status is (Suppressed, Disabled, Enabled); 4253 -- Inline status of a subprogram, indicated as follows: 4254 -- Suppressed: inlining is suppressed for the subprogram 4255 -- Disabled: no inlining is requested for the subprogram 4256 -- Enabled: inlining is requested/required for the subprogram 4257 4258 procedure Process_Inline (Status : Inline_Status); 4259 -- Common processing for No_Inline, Inline and Inline_Always. Parameter 4260 -- indicates the inline status specified by the pragma. 4261 4262 procedure Process_Interface_Name 4263 (Subprogram_Def : Entity_Id; 4264 Ext_Arg : Node_Id; 4265 Link_Arg : Node_Id; 4266 Prag : Node_Id); 4267 -- Given the last two arguments of pragma Import, pragma Export, or 4268 -- pragma Interface_Name, performs validity checks and sets the 4269 -- Interface_Name field of the given subprogram entity to the 4270 -- appropriate external or link name, depending on the arguments given. 4271 -- Ext_Arg is always present, but Link_Arg may be missing. Note that 4272 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and 4273 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg 4274 -- nor Link_Arg is present, the interface name is set to the default 4275 -- from the subprogram name. In addition, the pragma itself is passed 4276 -- to analyze any expressions in the case the pragma came from an aspect 4277 -- specification. 4278 4279 procedure Process_Interrupt_Or_Attach_Handler; 4280 -- Common processing for Interrupt and Attach_Handler pragmas 4281 4282 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); 4283 -- Common processing for Restrictions and Restriction_Warnings pragmas. 4284 -- Warn is True for Restriction_Warnings, or for Restrictions if the 4285 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag 4286 -- is not set in the Restrictions case. 4287 4288 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); 4289 -- Common processing for Suppress and Unsuppress. The boolean parameter 4290 -- Suppress_Case is True for the Suppress case, and False for the 4291 -- Unsuppress case. 4292 4293 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id); 4294 -- Subsidiary to the analysis of pragmas Independent[_Components]. 4295 -- Record such a pragma N applied to entity E for future checks. 4296 4297 procedure Set_Exported (E : Entity_Id; Arg : Node_Id); 4298 -- This procedure sets the Is_Exported flag for the given entity, 4299 -- checking that the entity was not previously imported. Arg is 4300 -- the argument that specified the entity. A check is also made 4301 -- for exporting inappropriate entities. 4302 4303 procedure Set_Extended_Import_Export_External_Name 4304 (Internal_Ent : Entity_Id; 4305 Arg_External : Node_Id); 4306 -- Common processing for all extended import export pragmas. The first 4307 -- argument, Internal_Ent, is the internal entity, which has already 4308 -- been checked for validity by the caller. Arg_External is from the 4309 -- Import or Export pragma, and may be null if no External parameter 4310 -- was present. If Arg_External is present and is a non-null string 4311 -- (a null string is treated as the default), then the Interface_Name 4312 -- field of Internal_Ent is set appropriately. 4313 4314 procedure Set_Imported (E : Entity_Id); 4315 -- This procedure sets the Is_Imported flag for the given entity, 4316 -- checking that it is not previously exported or imported. 4317 4318 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); 4319 -- Mech is a parameter passing mechanism (see Import_Function syntax 4320 -- for MECHANISM_NAME). This routine checks that the mechanism argument 4321 -- has the right form, and if not issues an error message. If the 4322 -- argument has the right form then the Mechanism field of Ent is 4323 -- set appropriately. 4324 4325 procedure Set_Rational_Profile; 4326 -- Activate the set of configuration pragmas and permissions that make 4327 -- up the Rational profile. 4328 4329 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id); 4330 -- Activate the set of configuration pragmas and restrictions that make 4331 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar, 4332 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node, 4333 -- which is used for error messages on any constructs violating the 4334 -- profile. 4335 4336 procedure Validate_Acc_Condition_Clause (Clause : Node_Id); 4337 -- Make sure the argument of a given Acc_If clause is a Boolean 4338 4339 procedure Validate_Acc_Data_Clause (Clause : Node_Id); 4340 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin, 4341 -- Copyout...) is an identifier or an aggregate of identifiers. 4342 4343 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id); 4344 -- Make sure the argument of an OpenAcc clause is an Integer expression 4345 4346 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id); 4347 -- Make sure the argument of an OpenAcc clause is an Integer expression 4348 -- or a list of Integer expressions. 4349 4350 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id); 4351 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma 4352 -- contains at least N-1 nested loops. 4353 4354 procedure Validate_Acc_Loop_Gang (Clause : Node_Id); 4355 -- Make sure the argument of the Gang clause of a Loop directive is 4356 -- either an integer expression or a (Static => integer expressions) 4357 -- aggregate. 4358 4359 procedure Validate_Acc_Loop_Vector (Clause : Node_Id); 4360 -- When this procedure is called in a construct offloaded by an 4361 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does 4362 -- not exist on said pragma. In all cases, make sure the argument 4363 -- is an Integer expression. 4364 4365 procedure Validate_Acc_Loop_Worker (Clause : Node_Id); 4366 -- When this procedure is called in a construct offloaded by an 4367 -- Acc_Parallel pragma, makes sure that no argument has been given. 4368 -- When this procedure is called in a construct offloaded by an 4369 -- Acc_Kernels pragma and if Loop_Worker was given an argument, 4370 -- makes sure that the Num_Workers clause does not appear on the 4371 -- Acc_Kernels pragma and that the argument is an integer. 4372 4373 procedure Validate_Acc_Name_Reduction (Clause : Node_Id); 4374 -- Make sure the reduction clause is an aggregate made of a string 4375 -- representing a supported reduction operation (i.e. "+", "*", "and", 4376 -- "or", "min" or "max") and either an identifier or aggregate of 4377 -- identifiers. 4378 4379 procedure Validate_Acc_Size_Expressions (Clause : Node_Id); 4380 -- Makes sure that Clause is either an integer expression or an 4381 -- association with a Static as name and a list of integer expressions 4382 -- or "*" strings on the right hand side. 4383 4384 --------------- 4385 -- Acc_First -- 4386 --------------- 4387 4388 function Acc_First (N : Node_Id) return Node_Id is 4389 begin 4390 if Nkind (N) = N_Aggregate then 4391 if Present (Expressions (N)) then 4392 return First (Expressions (N)); 4393 4394 elsif Present (Component_Associations (N)) then 4395 return Expression (First (Component_Associations (N))); 4396 end if; 4397 end if; 4398 4399 return N; 4400 end Acc_First; 4401 4402 -------------- 4403 -- Acc_Next -- 4404 -------------- 4405 4406 function Acc_Next (N : Node_Id) return Node_Id is 4407 begin 4408 if Nkind (Parent (N)) = N_Component_Association then 4409 return Expression (Next (Parent (N))); 4410 4411 elsif Nkind (Parent (N)) = N_Aggregate then 4412 return Next (N); 4413 4414 else 4415 return Empty; 4416 end if; 4417 end Acc_Next; 4418 4419 --------------------- 4420 -- Ada_2005_Pragma -- 4421 --------------------- 4422 4423 procedure Ada_2005_Pragma is 4424 begin 4425 if Ada_Version <= Ada_95 then 4426 Check_Restriction (No_Implementation_Pragmas, N); 4427 end if; 4428 end Ada_2005_Pragma; 4429 4430 --------------------- 4431 -- Ada_2012_Pragma -- 4432 --------------------- 4433 4434 procedure Ada_2012_Pragma is 4435 begin 4436 if Ada_Version <= Ada_2005 then 4437 Check_Restriction (No_Implementation_Pragmas, N); 4438 end if; 4439 end Ada_2012_Pragma; 4440 4441 ---------------------------- 4442 -- Analyze_Depends_Global -- 4443 ---------------------------- 4444 4445 procedure Analyze_Depends_Global 4446 (Spec_Id : out Entity_Id; 4447 Subp_Decl : out Node_Id; 4448 Legal : out Boolean) 4449 is 4450 begin 4451 -- Assume that the pragma is illegal 4452 4453 Spec_Id := Empty; 4454 Subp_Decl := Empty; 4455 Legal := False; 4456 4457 GNAT_Pragma; 4458 Check_Arg_Count (1); 4459 4460 -- Ensure the proper placement of the pragma. Depends/Global must be 4461 -- associated with a subprogram declaration or a body that acts as a 4462 -- spec. 4463 4464 Subp_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); 4465 4466 -- Entry 4467 4468 if Nkind (Subp_Decl) = N_Entry_Declaration then 4469 null; 4470 4471 -- Generic subprogram 4472 4473 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 4474 null; 4475 4476 -- Object declaration of a single concurrent type 4477 4478 elsif Nkind (Subp_Decl) = N_Object_Declaration 4479 and then Is_Single_Concurrent_Object 4480 (Unique_Defining_Entity (Subp_Decl)) 4481 then 4482 null; 4483 4484 -- Single task type 4485 4486 elsif Nkind (Subp_Decl) = N_Single_Task_Declaration then 4487 null; 4488 4489 -- Subprogram body acts as spec 4490 4491 elsif Nkind (Subp_Decl) = N_Subprogram_Body 4492 and then No (Corresponding_Spec (Subp_Decl)) 4493 then 4494 null; 4495 4496 -- Subprogram body stub acts as spec 4497 4498 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4499 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 4500 then 4501 null; 4502 4503 -- Subprogram declaration 4504 4505 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 4506 null; 4507 4508 -- Task type 4509 4510 elsif Nkind (Subp_Decl) = N_Task_Type_Declaration then 4511 null; 4512 4513 else 4514 Pragma_Misplaced; 4515 return; 4516 end if; 4517 4518 -- If we get here, then the pragma is legal 4519 4520 Legal := True; 4521 Spec_Id := Unique_Defining_Entity (Subp_Decl); 4522 4523 -- When the related context is an entry, the entry must belong to a 4524 -- protected unit (SPARK RM 6.1.4(6)). 4525 4526 if Is_Entry_Declaration (Spec_Id) 4527 and then Ekind (Scope (Spec_Id)) /= E_Protected_Type 4528 then 4529 Pragma_Misplaced; 4530 return; 4531 4532 -- When the related context is an anonymous object created for a 4533 -- simple concurrent type, the type must be a task 4534 -- (SPARK RM 6.1.4(6)). 4535 4536 elsif Is_Single_Concurrent_Object (Spec_Id) 4537 and then Ekind (Etype (Spec_Id)) /= E_Task_Type 4538 then 4539 Pragma_Misplaced; 4540 return; 4541 end if; 4542 4543 -- A pragma that applies to a Ghost entity becomes Ghost for the 4544 -- purposes of legality checks and removal of ignored Ghost code. 4545 4546 Mark_Ghost_Pragma (N, Spec_Id); 4547 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 4548 end Analyze_Depends_Global; 4549 4550 ------------------------ 4551 -- Analyze_If_Present -- 4552 ------------------------ 4553 4554 procedure Analyze_If_Present (Id : Pragma_Id) is 4555 Stmt : Node_Id; 4556 4557 begin 4558 pragma Assert (Is_List_Member (N)); 4559 4560 -- Inspect the declarations or statements following pragma N looking 4561 -- for another pragma whose Id matches the caller's request. If it is 4562 -- available, analyze it. 4563 4564 Stmt := Next (N); 4565 while Present (Stmt) loop 4566 if Nkind (Stmt) = N_Pragma and then Get_Pragma_Id (Stmt) = Id then 4567 Analyze_Pragma (Stmt); 4568 exit; 4569 4570 -- The first source declaration or statement immediately following 4571 -- N ends the region where a pragma may appear. 4572 4573 elsif Comes_From_Source (Stmt) then 4574 exit; 4575 end if; 4576 4577 Next (Stmt); 4578 end loop; 4579 end Analyze_If_Present; 4580 4581 -------------------------------- 4582 -- Analyze_Pre_Post_Condition -- 4583 -------------------------------- 4584 4585 procedure Analyze_Pre_Post_Condition is 4586 Prag_Iden : constant Node_Id := Pragma_Identifier (N); 4587 Subp_Decl : Node_Id; 4588 Subp_Id : Entity_Id; 4589 4590 Duplicates_OK : Boolean := False; 4591 -- Flag set when a pre/postcondition allows multiple pragmas of the 4592 -- same kind. 4593 4594 In_Body_OK : Boolean := False; 4595 -- Flag set when a pre/postcondition is allowed to appear on a body 4596 -- even though the subprogram may have a spec. 4597 4598 Is_Pre_Post : Boolean := False; 4599 -- Flag set when the pragma is one of Pre, Pre_Class, Post or 4600 -- Post_Class. 4601 4602 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean; 4603 -- Implement rules in AI12-0131: an overriding operation can have 4604 -- a class-wide precondition only if one of its ancestors has an 4605 -- explicit class-wide precondition. 4606 4607 ----------------------------- 4608 -- Inherits_Class_Wide_Pre -- 4609 ----------------------------- 4610 4611 function Inherits_Class_Wide_Pre (E : Entity_Id) return Boolean is 4612 Typ : constant Entity_Id := Find_Dispatching_Type (E); 4613 Cont : Node_Id; 4614 Prag : Node_Id; 4615 Prev : Entity_Id := Overridden_Operation (E); 4616 4617 begin 4618 -- Check ancestors on the overriding operation to examine the 4619 -- preconditions that may apply to them. 4620 4621 while Present (Prev) loop 4622 Cont := Contract (Prev); 4623 if Present (Cont) then 4624 Prag := Pre_Post_Conditions (Cont); 4625 while Present (Prag) loop 4626 if Pragma_Name (Prag) = Name_Precondition 4627 and then Class_Present (Prag) 4628 then 4629 return True; 4630 end if; 4631 4632 Prag := Next_Pragma (Prag); 4633 end loop; 4634 end if; 4635 4636 -- For a type derived from a generic formal type, the operation 4637 -- inheriting the condition is a renaming, not an overriding of 4638 -- the operation of the formal. Ditto for an inherited 4639 -- operation which has no explicit contracts. 4640 4641 if Is_Generic_Type (Find_Dispatching_Type (Prev)) 4642 or else not Comes_From_Source (Prev) 4643 then 4644 Prev := Alias (Prev); 4645 else 4646 Prev := Overridden_Operation (Prev); 4647 end if; 4648 end loop; 4649 4650 -- If the controlling type of the subprogram has progenitors, an 4651 -- interface operation implemented by the current operation may 4652 -- have a class-wide precondition. 4653 4654 if Has_Interfaces (Typ) then 4655 declare 4656 Elmt : Elmt_Id; 4657 Ints : Elist_Id; 4658 Prim : Entity_Id; 4659 Prim_Elmt : Elmt_Id; 4660 Prim_List : Elist_Id; 4661 4662 begin 4663 Collect_Interfaces (Typ, Ints); 4664 Elmt := First_Elmt (Ints); 4665 4666 -- Iterate over the primitive operations of each interface 4667 4668 while Present (Elmt) loop 4669 Prim_List := Direct_Primitive_Operations (Node (Elmt)); 4670 Prim_Elmt := First_Elmt (Prim_List); 4671 while Present (Prim_Elmt) loop 4672 Prim := Node (Prim_Elmt); 4673 if Chars (Prim) = Chars (E) 4674 and then Present (Contract (Prim)) 4675 and then Class_Present 4676 (Pre_Post_Conditions (Contract (Prim))) 4677 then 4678 return True; 4679 end if; 4680 4681 Next_Elmt (Prim_Elmt); 4682 end loop; 4683 4684 Next_Elmt (Elmt); 4685 end loop; 4686 end; 4687 end if; 4688 4689 return False; 4690 end Inherits_Class_Wide_Pre; 4691 4692 -- Start of processing for Analyze_Pre_Post_Condition 4693 4694 begin 4695 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to 4696 -- offer uniformity among the various kinds of pre/postconditions by 4697 -- rewriting the pragma identifier. This allows the retrieval of the 4698 -- original pragma name by routine Original_Aspect_Pragma_Name. 4699 4700 if Comes_From_Source (N) then 4701 if Nam_In (Pname, Name_Pre, Name_Pre_Class) then 4702 Is_Pre_Post := True; 4703 Set_Class_Present (N, Pname = Name_Pre_Class); 4704 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Precondition)); 4705 4706 elsif Nam_In (Pname, Name_Post, Name_Post_Class) then 4707 Is_Pre_Post := True; 4708 Set_Class_Present (N, Pname = Name_Post_Class); 4709 Rewrite (Prag_Iden, Make_Identifier (Loc, Name_Postcondition)); 4710 end if; 4711 end if; 4712 4713 -- Determine the semantics with respect to duplicates and placement 4714 -- in a body. Pragmas Precondition and Postcondition were introduced 4715 -- before aspects and are not subject to the same aspect-like rules. 4716 4717 if Nam_In (Pname, Name_Precondition, Name_Postcondition) then 4718 Duplicates_OK := True; 4719 In_Body_OK := True; 4720 end if; 4721 4722 GNAT_Pragma; 4723 4724 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single 4725 -- argument without an identifier. 4726 4727 if Is_Pre_Post then 4728 Check_Arg_Count (1); 4729 Check_No_Identifiers; 4730 4731 -- Pragmas Precondition and Postcondition have complex argument 4732 -- profile. 4733 4734 else 4735 Check_At_Least_N_Arguments (1); 4736 Check_At_Most_N_Arguments (2); 4737 Check_Optional_Identifier (Arg1, Name_Check); 4738 4739 if Present (Arg2) then 4740 Check_Optional_Identifier (Arg2, Name_Message); 4741 Preanalyze_Spec_Expression 4742 (Get_Pragma_Arg (Arg2), Standard_String); 4743 end if; 4744 end if; 4745 4746 -- For a pragma PPC in the extended main source unit, record enabled 4747 -- status in SCO. 4748 -- ??? nothing checks that the pragma is in the main source unit 4749 4750 if Is_Checked (N) and then not Split_PPC (N) then 4751 Set_SCO_Pragma_Enabled (Loc); 4752 end if; 4753 4754 -- Ensure the proper placement of the pragma 4755 4756 Subp_Decl := 4757 Find_Related_Declaration_Or_Body 4758 (N, Do_Checks => not Duplicates_OK); 4759 4760 -- When a pre/postcondition pragma applies to an abstract subprogram, 4761 -- its original form must be an aspect with 'Class. 4762 4763 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 4764 if not From_Aspect_Specification (N) then 4765 Error_Pragma 4766 ("pragma % cannot be applied to abstract subprogram"); 4767 4768 elsif not Class_Present (N) then 4769 Error_Pragma 4770 ("aspect % requires ''Class for abstract subprogram"); 4771 end if; 4772 4773 -- Entry declaration 4774 4775 elsif Nkind (Subp_Decl) = N_Entry_Declaration then 4776 null; 4777 4778 -- Generic subprogram declaration 4779 4780 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 4781 null; 4782 4783 -- Subprogram body 4784 4785 elsif Nkind (Subp_Decl) = N_Subprogram_Body 4786 and then (No (Corresponding_Spec (Subp_Decl)) or In_Body_OK) 4787 then 4788 null; 4789 4790 -- Subprogram body stub 4791 4792 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 4793 and then (No (Corresponding_Spec_Of_Stub (Subp_Decl)) or In_Body_OK) 4794 then 4795 null; 4796 4797 -- Subprogram declaration 4798 4799 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 4800 4801 -- AI05-0230: When a pre/postcondition pragma applies to a null 4802 -- procedure, its original form must be an aspect with 'Class. 4803 4804 if Nkind (Specification (Subp_Decl)) = N_Procedure_Specification 4805 and then Null_Present (Specification (Subp_Decl)) 4806 and then From_Aspect_Specification (N) 4807 and then not Class_Present (N) 4808 then 4809 Error_Pragma ("aspect % requires ''Class for null procedure"); 4810 end if; 4811 4812 -- Implement the legality checks mandated by AI12-0131: 4813 -- Pre'Class shall not be specified for an overriding primitive 4814 -- subprogram of a tagged type T unless the Pre'Class aspect is 4815 -- specified for the corresponding primitive subprogram of some 4816 -- ancestor of T. 4817 4818 declare 4819 E : constant Entity_Id := Defining_Entity (Subp_Decl); 4820 4821 begin 4822 if Class_Present (N) 4823 and then Pragma_Name (N) = Name_Precondition 4824 and then Present (Overridden_Operation (E)) 4825 and then not Inherits_Class_Wide_Pre (E) 4826 then 4827 Error_Msg_N 4828 ("illegal class-wide precondition on overriding operation", 4829 Corresponding_Aspect (N)); 4830 end if; 4831 end; 4832 4833 -- A renaming declaration may inherit a generated pragma, its 4834 -- placement comes from expansion, not from source. 4835 4836 elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 4837 and then not Comes_From_Source (N) 4838 then 4839 null; 4840 4841 -- Otherwise the placement is illegal 4842 4843 else 4844 Pragma_Misplaced; 4845 return; 4846 end if; 4847 4848 Subp_Id := Defining_Entity (Subp_Decl); 4849 4850 -- A pragma that applies to a Ghost entity becomes Ghost for the 4851 -- purposes of legality checks and removal of ignored Ghost code. 4852 4853 Mark_Ghost_Pragma (N, Subp_Id); 4854 4855 -- Chain the pragma on the contract for further processing by 4856 -- Analyze_Pre_Post_Condition_In_Decl_Part. 4857 4858 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 4859 4860 -- Fully analyze the pragma when it appears inside an entry or 4861 -- subprogram body because it cannot benefit from forward references. 4862 4863 if Nkind_In (Subp_Decl, N_Entry_Body, 4864 N_Subprogram_Body, 4865 N_Subprogram_Body_Stub) 4866 then 4867 -- The legality checks of pragmas Precondition and Postcondition 4868 -- are affected by the SPARK mode in effect and the volatility of 4869 -- the context. Analyze all pragmas in a specific order. 4870 4871 Analyze_If_Present (Pragma_SPARK_Mode); 4872 Analyze_If_Present (Pragma_Volatile_Function); 4873 Analyze_Pre_Post_Condition_In_Decl_Part (N); 4874 end if; 4875 end Analyze_Pre_Post_Condition; 4876 4877 ----------------------------------------- 4878 -- Analyze_Refined_Depends_Global_Post -- 4879 ----------------------------------------- 4880 4881 procedure Analyze_Refined_Depends_Global_Post 4882 (Spec_Id : out Entity_Id; 4883 Body_Id : out Entity_Id; 4884 Legal : out Boolean) 4885 is 4886 Body_Decl : Node_Id; 4887 Spec_Decl : Node_Id; 4888 4889 begin 4890 -- Assume that the pragma is illegal 4891 4892 Spec_Id := Empty; 4893 Body_Id := Empty; 4894 Legal := False; 4895 4896 GNAT_Pragma; 4897 Check_Arg_Count (1); 4898 Check_No_Identifiers; 4899 4900 -- Verify the placement of the pragma and check for duplicates. The 4901 -- pragma must apply to a subprogram body [stub]. 4902 4903 Body_Decl := Find_Related_Declaration_Or_Body (N, Do_Checks => True); 4904 4905 if not Nkind_In (Body_Decl, N_Entry_Body, 4906 N_Subprogram_Body, 4907 N_Subprogram_Body_Stub, 4908 N_Task_Body, 4909 N_Task_Body_Stub) 4910 then 4911 Pragma_Misplaced; 4912 return; 4913 end if; 4914 4915 Body_Id := Defining_Entity (Body_Decl); 4916 Spec_Id := Unique_Defining_Entity (Body_Decl); 4917 4918 -- The pragma must apply to the second declaration of a subprogram. 4919 -- In other words, the body [stub] cannot acts as a spec. 4920 4921 if No (Spec_Id) then 4922 Error_Pragma ("pragma % cannot apply to a stand alone body"); 4923 return; 4924 4925 -- Catch the case where the subprogram body is a subunit and acts as 4926 -- the third declaration of the subprogram. 4927 4928 elsif Nkind (Parent (Body_Decl)) = N_Subunit then 4929 Error_Pragma ("pragma % cannot apply to a subunit"); 4930 return; 4931 end if; 4932 4933 -- A refined pragma can only apply to the body [stub] of a subprogram 4934 -- declared in the visible part of a package. Retrieve the context of 4935 -- the subprogram declaration. 4936 4937 Spec_Decl := Unit_Declaration_Node (Spec_Id); 4938 4939 -- When dealing with protected entries or protected subprograms, use 4940 -- the enclosing protected type as the proper context. 4941 4942 if Ekind_In (Spec_Id, E_Entry, 4943 E_Entry_Family, 4944 E_Function, 4945 E_Procedure) 4946 and then Ekind (Scope (Spec_Id)) = E_Protected_Type 4947 then 4948 Spec_Decl := Declaration_Node (Scope (Spec_Id)); 4949 end if; 4950 4951 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then 4952 Error_Pragma 4953 (Fix_Msg (Spec_Id, "pragma % must apply to the body of " 4954 & "subprogram declared in a package specification")); 4955 return; 4956 end if; 4957 4958 -- If we get here, then the pragma is legal 4959 4960 Legal := True; 4961 4962 -- A pragma that applies to a Ghost entity becomes Ghost for the 4963 -- purposes of legality checks and removal of ignored Ghost code. 4964 4965 Mark_Ghost_Pragma (N, Spec_Id); 4966 4967 if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then 4968 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 4969 end if; 4970 end Analyze_Refined_Depends_Global_Post; 4971 4972 ---------------------------------- 4973 -- Analyze_Unmodified_Or_Unused -- 4974 ---------------------------------- 4975 4976 procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is 4977 Arg : Node_Id; 4978 Arg_Expr : Node_Id; 4979 Arg_Id : Entity_Id; 4980 4981 Ghost_Error_Posted : Boolean := False; 4982 -- Flag set when an error concerning the illegal mix of Ghost and 4983 -- non-Ghost variables is emitted. 4984 4985 Ghost_Id : Entity_Id := Empty; 4986 -- The entity of the first Ghost variable encountered while 4987 -- processing the arguments of the pragma. 4988 4989 begin 4990 GNAT_Pragma; 4991 Check_At_Least_N_Arguments (1); 4992 4993 -- Loop through arguments 4994 4995 Arg := Arg1; 4996 while Present (Arg) loop 4997 Check_No_Identifier (Arg); 4998 4999 -- Note: the analyze call done by Check_Arg_Is_Local_Name will 5000 -- in fact generate reference, so that the entity will have a 5001 -- reference, which will inhibit any warnings about it not 5002 -- being referenced, and also properly show up in the ali file 5003 -- as a reference. But this reference is recorded before the 5004 -- Has_Pragma_Unreferenced flag is set, so that no warning is 5005 -- generated for this reference. 5006 5007 Check_Arg_Is_Local_Name (Arg); 5008 Arg_Expr := Get_Pragma_Arg (Arg); 5009 5010 if Is_Entity_Name (Arg_Expr) then 5011 Arg_Id := Entity (Arg_Expr); 5012 5013 -- Skip processing the argument if already flagged 5014 5015 if Is_Assignable (Arg_Id) 5016 and then not Has_Pragma_Unmodified (Arg_Id) 5017 and then not Has_Pragma_Unused (Arg_Id) 5018 then 5019 Set_Has_Pragma_Unmodified (Arg_Id); 5020 5021 if Is_Unused then 5022 Set_Has_Pragma_Unused (Arg_Id); 5023 end if; 5024 5025 -- A pragma that applies to a Ghost entity becomes Ghost for 5026 -- the purposes of legality checks and removal of ignored 5027 -- Ghost code. 5028 5029 Mark_Ghost_Pragma (N, Arg_Id); 5030 5031 -- Capture the entity of the first Ghost variable being 5032 -- processed for error detection purposes. 5033 5034 if Is_Ghost_Entity (Arg_Id) then 5035 if No (Ghost_Id) then 5036 Ghost_Id := Arg_Id; 5037 end if; 5038 5039 -- Otherwise the variable is non-Ghost. It is illegal to mix 5040 -- references to Ghost and non-Ghost entities 5041 -- (SPARK RM 6.9). 5042 5043 elsif Present (Ghost_Id) 5044 and then not Ghost_Error_Posted 5045 then 5046 Ghost_Error_Posted := True; 5047 5048 Error_Msg_Name_1 := Pname; 5049 Error_Msg_N 5050 ("pragma % cannot mention ghost and non-ghost " 5051 & "variables", N); 5052 5053 Error_Msg_Sloc := Sloc (Ghost_Id); 5054 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 5055 5056 Error_Msg_Sloc := Sloc (Arg_Id); 5057 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id); 5058 end if; 5059 5060 -- Warn if already flagged as Unused or Unmodified 5061 5062 elsif Has_Pragma_Unmodified (Arg_Id) then 5063 if Has_Pragma_Unused (Arg_Id) then 5064 Error_Msg_NE 5065 ("??pragma Unused already given for &!", Arg_Expr, 5066 Arg_Id); 5067 else 5068 Error_Msg_NE 5069 ("??pragma Unmodified already given for &!", Arg_Expr, 5070 Arg_Id); 5071 end if; 5072 5073 -- Otherwise the pragma referenced an illegal entity 5074 5075 else 5076 Error_Pragma_Arg 5077 ("pragma% can only be applied to a variable", Arg_Expr); 5078 end if; 5079 end if; 5080 5081 Next (Arg); 5082 end loop; 5083 end Analyze_Unmodified_Or_Unused; 5084 5085 ------------------------------------ 5086 -- Analyze_Unreferenced_Or_Unused -- 5087 ------------------------------------ 5088 5089 procedure Analyze_Unreferenced_Or_Unused 5090 (Is_Unused : Boolean := False) 5091 is 5092 Arg : Node_Id; 5093 Arg_Expr : Node_Id; 5094 Arg_Id : Entity_Id; 5095 Citem : Node_Id; 5096 5097 Ghost_Error_Posted : Boolean := False; 5098 -- Flag set when an error concerning the illegal mix of Ghost and 5099 -- non-Ghost names is emitted. 5100 5101 Ghost_Id : Entity_Id := Empty; 5102 -- The entity of the first Ghost name encountered while processing 5103 -- the arguments of the pragma. 5104 5105 begin 5106 GNAT_Pragma; 5107 Check_At_Least_N_Arguments (1); 5108 5109 -- Check case of appearing within context clause 5110 5111 if not Is_Unused and then Is_In_Context_Clause then 5112 5113 -- The arguments must all be units mentioned in a with clause in 5114 -- the same context clause. Note that Par.Prag already checked 5115 -- that the arguments are either identifiers or selected 5116 -- components. 5117 5118 Arg := Arg1; 5119 while Present (Arg) loop 5120 Citem := First (List_Containing (N)); 5121 while Citem /= N loop 5122 Arg_Expr := Get_Pragma_Arg (Arg); 5123 5124 if Nkind (Citem) = N_With_Clause 5125 and then Same_Name (Name (Citem), Arg_Expr) 5126 then 5127 Set_Has_Pragma_Unreferenced 5128 (Cunit_Entity 5129 (Get_Source_Unit 5130 (Library_Unit (Citem)))); 5131 Set_Elab_Unit_Name (Arg_Expr, Name (Citem)); 5132 exit; 5133 end if; 5134 5135 Next (Citem); 5136 end loop; 5137 5138 if Citem = N then 5139 Error_Pragma_Arg 5140 ("argument of pragma% is not withed unit", Arg); 5141 end if; 5142 5143 Next (Arg); 5144 end loop; 5145 5146 -- Case of not in list of context items 5147 5148 else 5149 Arg := Arg1; 5150 while Present (Arg) loop 5151 Check_No_Identifier (Arg); 5152 5153 -- Note: the analyze call done by Check_Arg_Is_Local_Name will 5154 -- in fact generate reference, so that the entity will have a 5155 -- reference, which will inhibit any warnings about it not 5156 -- being referenced, and also properly show up in the ali file 5157 -- as a reference. But this reference is recorded before the 5158 -- Has_Pragma_Unreferenced flag is set, so that no warning is 5159 -- generated for this reference. 5160 5161 Check_Arg_Is_Local_Name (Arg); 5162 Arg_Expr := Get_Pragma_Arg (Arg); 5163 5164 if Is_Entity_Name (Arg_Expr) then 5165 Arg_Id := Entity (Arg_Expr); 5166 5167 -- Warn if already flagged as Unused or Unreferenced and 5168 -- skip processing the argument. 5169 5170 if Has_Pragma_Unreferenced (Arg_Id) then 5171 if Has_Pragma_Unused (Arg_Id) then 5172 Error_Msg_NE 5173 ("??pragma Unused already given for &!", Arg_Expr, 5174 Arg_Id); 5175 else 5176 Error_Msg_NE 5177 ("??pragma Unreferenced already given for &!", 5178 Arg_Expr, Arg_Id); 5179 end if; 5180 5181 -- Apply Unreferenced to the entity 5182 5183 else 5184 -- If the entity is overloaded, the pragma applies to the 5185 -- most recent overloading, as documented. In this case, 5186 -- name resolution does not generate a reference, so it 5187 -- must be done here explicitly. 5188 5189 if Is_Overloaded (Arg_Expr) then 5190 Generate_Reference (Arg_Id, N); 5191 end if; 5192 5193 Set_Has_Pragma_Unreferenced (Arg_Id); 5194 5195 if Is_Unused then 5196 Set_Has_Pragma_Unused (Arg_Id); 5197 end if; 5198 5199 -- A pragma that applies to a Ghost entity becomes Ghost 5200 -- for the purposes of legality checks and removal of 5201 -- ignored Ghost code. 5202 5203 Mark_Ghost_Pragma (N, Arg_Id); 5204 5205 -- Capture the entity of the first Ghost name being 5206 -- processed for error detection purposes. 5207 5208 if Is_Ghost_Entity (Arg_Id) then 5209 if No (Ghost_Id) then 5210 Ghost_Id := Arg_Id; 5211 end if; 5212 5213 -- Otherwise the name is non-Ghost. It is illegal to mix 5214 -- references to Ghost and non-Ghost entities 5215 -- (SPARK RM 6.9). 5216 5217 elsif Present (Ghost_Id) 5218 and then not Ghost_Error_Posted 5219 then 5220 Ghost_Error_Posted := True; 5221 5222 Error_Msg_Name_1 := Pname; 5223 Error_Msg_N 5224 ("pragma % cannot mention ghost and non-ghost " 5225 & "names", N); 5226 5227 Error_Msg_Sloc := Sloc (Ghost_Id); 5228 Error_Msg_NE 5229 ("\& # declared as ghost", N, Ghost_Id); 5230 5231 Error_Msg_Sloc := Sloc (Arg_Id); 5232 Error_Msg_NE 5233 ("\& # declared as non-ghost", N, Arg_Id); 5234 end if; 5235 end if; 5236 end if; 5237 5238 Next (Arg); 5239 end loop; 5240 end if; 5241 end Analyze_Unreferenced_Or_Unused; 5242 5243 -------------------------- 5244 -- Check_Ada_83_Warning -- 5245 -------------------------- 5246 5247 procedure Check_Ada_83_Warning is 5248 begin 5249 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 5250 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N); 5251 end if; 5252 end Check_Ada_83_Warning; 5253 5254 --------------------- 5255 -- Check_Arg_Count -- 5256 --------------------- 5257 5258 procedure Check_Arg_Count (Required : Nat) is 5259 begin 5260 if Arg_Count /= Required then 5261 Error_Pragma ("wrong number of arguments for pragma%"); 5262 end if; 5263 end Check_Arg_Count; 5264 5265 -------------------------------- 5266 -- Check_Arg_Is_External_Name -- 5267 -------------------------------- 5268 5269 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is 5270 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5271 5272 begin 5273 if Nkind (Argx) = N_Identifier then 5274 return; 5275 5276 else 5277 Analyze_And_Resolve (Argx, Standard_String); 5278 5279 if Is_OK_Static_Expression (Argx) then 5280 return; 5281 5282 elsif Etype (Argx) = Any_Type then 5283 raise Pragma_Exit; 5284 5285 -- An interesting special case, if we have a string literal and 5286 -- we are in Ada 83 mode, then we allow it even though it will 5287 -- not be flagged as static. This allows expected Ada 83 mode 5288 -- use of external names which are string literals, even though 5289 -- technically these are not static in Ada 83. 5290 5291 elsif Ada_Version = Ada_83 5292 and then Nkind (Argx) = N_String_Literal 5293 then 5294 return; 5295 5296 -- Here we have a real error (non-static expression) 5297 5298 else 5299 Error_Msg_Name_1 := Pname; 5300 Flag_Non_Static_Expr 5301 (Fix_Error ("argument for pragma% must be a identifier or " 5302 & "static string expression!"), Argx); 5303 5304 raise Pragma_Exit; 5305 end if; 5306 end if; 5307 end Check_Arg_Is_External_Name; 5308 5309 ----------------------------- 5310 -- Check_Arg_Is_Identifier -- 5311 ----------------------------- 5312 5313 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is 5314 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5315 begin 5316 if Nkind (Argx) /= N_Identifier then 5317 Error_Pragma_Arg ("argument for pragma% must be identifier", Argx); 5318 end if; 5319 end Check_Arg_Is_Identifier; 5320 5321 ---------------------------------- 5322 -- Check_Arg_Is_Integer_Literal -- 5323 ---------------------------------- 5324 5325 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is 5326 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5327 begin 5328 if Nkind (Argx) /= N_Integer_Literal then 5329 Error_Pragma_Arg 5330 ("argument for pragma% must be integer literal", Argx); 5331 end if; 5332 end Check_Arg_Is_Integer_Literal; 5333 5334 ------------------------------------------- 5335 -- Check_Arg_Is_Library_Level_Local_Name -- 5336 ------------------------------------------- 5337 5338 -- LOCAL_NAME ::= 5339 -- DIRECT_NAME 5340 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 5341 -- | library_unit_NAME 5342 5343 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is 5344 begin 5345 Check_Arg_Is_Local_Name (Arg); 5346 5347 -- If it came from an aspect, we want to give the error just as if it 5348 -- came from source. 5349 5350 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) 5351 and then (Comes_From_Source (N) 5352 or else Present (Corresponding_Aspect (Parent (Arg)))) 5353 then 5354 Error_Pragma_Arg 5355 ("argument for pragma% must be library level entity", Arg); 5356 end if; 5357 end Check_Arg_Is_Library_Level_Local_Name; 5358 5359 ----------------------------- 5360 -- Check_Arg_Is_Local_Name -- 5361 ----------------------------- 5362 5363 -- LOCAL_NAME ::= 5364 -- DIRECT_NAME 5365 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 5366 -- | library_unit_NAME 5367 5368 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is 5369 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5370 5371 begin 5372 -- If this pragma came from an aspect specification, we don't want to 5373 -- check for this error, because that would cause spurious errors, in 5374 -- case a type is frozen in a scope more nested than the type. The 5375 -- aspect itself of course can't be anywhere but on the declaration 5376 -- itself. 5377 5378 if Nkind (Arg) = N_Pragma_Argument_Association then 5379 if From_Aspect_Specification (Parent (Arg)) then 5380 return; 5381 end if; 5382 5383 -- Arg is the Expression of an N_Pragma_Argument_Association 5384 5385 else 5386 if From_Aspect_Specification (Parent (Parent (Arg))) then 5387 return; 5388 end if; 5389 end if; 5390 5391 Analyze (Argx); 5392 5393 if Nkind (Argx) not in N_Direct_Name 5394 and then (Nkind (Argx) /= N_Attribute_Reference 5395 or else Present (Expressions (Argx)) 5396 or else Nkind (Prefix (Argx)) /= N_Identifier) 5397 and then (not Is_Entity_Name (Argx) 5398 or else not Is_Compilation_Unit (Entity (Argx))) 5399 then 5400 Error_Pragma_Arg ("argument for pragma% must be local name", Argx); 5401 end if; 5402 5403 -- No further check required if not an entity name 5404 5405 if not Is_Entity_Name (Argx) then 5406 null; 5407 5408 else 5409 declare 5410 OK : Boolean; 5411 Ent : constant Entity_Id := Entity (Argx); 5412 Scop : constant Entity_Id := Scope (Ent); 5413 5414 begin 5415 -- Case of a pragma applied to a compilation unit: pragma must 5416 -- occur immediately after the program unit in the compilation. 5417 5418 if Is_Compilation_Unit (Ent) then 5419 declare 5420 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 5421 5422 begin 5423 -- Case of pragma placed immediately after spec 5424 5425 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then 5426 OK := True; 5427 5428 -- Case of pragma placed immediately after body 5429 5430 elsif Nkind (Decl) = N_Subprogram_Declaration 5431 and then Present (Corresponding_Body (Decl)) 5432 then 5433 OK := Parent (N) = 5434 Aux_Decls_Node 5435 (Parent (Unit_Declaration_Node 5436 (Corresponding_Body (Decl)))); 5437 5438 -- All other cases are illegal 5439 5440 else 5441 OK := False; 5442 end if; 5443 end; 5444 5445 -- Special restricted placement rule from 10.2.1(11.8/2) 5446 5447 elsif Is_Generic_Formal (Ent) 5448 and then Prag_Id = Pragma_Preelaborable_Initialization 5449 then 5450 OK := List_Containing (N) = 5451 Generic_Formal_Declarations 5452 (Unit_Declaration_Node (Scop)); 5453 5454 -- If this is an aspect applied to a subprogram body, the 5455 -- pragma is inserted in its declarative part. 5456 5457 elsif From_Aspect_Specification (N) 5458 and then Ent = Current_Scope 5459 and then 5460 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body 5461 then 5462 OK := True; 5463 5464 -- If the aspect is a predicate (possibly others ???) and the 5465 -- context is a record type, this is a discriminant expression 5466 -- within a type declaration, that freezes the predicated 5467 -- subtype. 5468 5469 elsif From_Aspect_Specification (N) 5470 and then Prag_Id = Pragma_Predicate 5471 and then Ekind (Current_Scope) = E_Record_Type 5472 and then Scop = Scope (Current_Scope) 5473 then 5474 OK := True; 5475 5476 -- Default case, just check that the pragma occurs in the scope 5477 -- of the entity denoted by the name. 5478 5479 else 5480 OK := Current_Scope = Scop; 5481 end if; 5482 5483 if not OK then 5484 Error_Pragma_Arg 5485 ("pragma% argument must be in same declarative part", Arg); 5486 end if; 5487 end; 5488 end if; 5489 end Check_Arg_Is_Local_Name; 5490 5491 --------------------------------- 5492 -- Check_Arg_Is_Locking_Policy -- 5493 --------------------------------- 5494 5495 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is 5496 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5497 5498 begin 5499 Check_Arg_Is_Identifier (Argx); 5500 5501 if not Is_Locking_Policy_Name (Chars (Argx)) then 5502 Error_Pragma_Arg ("& is not a valid locking policy name", Argx); 5503 end if; 5504 end Check_Arg_Is_Locking_Policy; 5505 5506 ----------------------------------------------- 5507 -- Check_Arg_Is_Partition_Elaboration_Policy -- 5508 ----------------------------------------------- 5509 5510 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is 5511 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5512 5513 begin 5514 Check_Arg_Is_Identifier (Argx); 5515 5516 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then 5517 Error_Pragma_Arg 5518 ("& is not a valid partition elaboration policy name", Argx); 5519 end if; 5520 end Check_Arg_Is_Partition_Elaboration_Policy; 5521 5522 ------------------------- 5523 -- Check_Arg_Is_One_Of -- 5524 ------------------------- 5525 5526 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 5527 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5528 5529 begin 5530 Check_Arg_Is_Identifier (Argx); 5531 5532 if not Nam_In (Chars (Argx), N1, N2) then 5533 Error_Msg_Name_2 := N1; 5534 Error_Msg_Name_3 := N2; 5535 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); 5536 end if; 5537 end Check_Arg_Is_One_Of; 5538 5539 procedure Check_Arg_Is_One_Of 5540 (Arg : Node_Id; 5541 N1, N2, N3 : Name_Id) 5542 is 5543 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5544 5545 begin 5546 Check_Arg_Is_Identifier (Argx); 5547 5548 if not Nam_In (Chars (Argx), N1, N2, N3) then 5549 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 5550 end if; 5551 end Check_Arg_Is_One_Of; 5552 5553 procedure Check_Arg_Is_One_Of 5554 (Arg : Node_Id; 5555 N1, N2, N3, N4 : Name_Id) 5556 is 5557 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5558 5559 begin 5560 Check_Arg_Is_Identifier (Argx); 5561 5562 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then 5563 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 5564 end if; 5565 end Check_Arg_Is_One_Of; 5566 5567 procedure Check_Arg_Is_One_Of 5568 (Arg : Node_Id; 5569 N1, N2, N3, N4, N5 : Name_Id) 5570 is 5571 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5572 5573 begin 5574 Check_Arg_Is_Identifier (Argx); 5575 5576 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then 5577 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 5578 end if; 5579 end Check_Arg_Is_One_Of; 5580 5581 --------------------------------- 5582 -- Check_Arg_Is_Queuing_Policy -- 5583 --------------------------------- 5584 5585 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is 5586 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5587 5588 begin 5589 Check_Arg_Is_Identifier (Argx); 5590 5591 if not Is_Queuing_Policy_Name (Chars (Argx)) then 5592 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); 5593 end if; 5594 end Check_Arg_Is_Queuing_Policy; 5595 5596 --------------------------------------- 5597 -- Check_Arg_Is_OK_Static_Expression -- 5598 --------------------------------------- 5599 5600 procedure Check_Arg_Is_OK_Static_Expression 5601 (Arg : Node_Id; 5602 Typ : Entity_Id := Empty) 5603 is 5604 begin 5605 Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ); 5606 end Check_Arg_Is_OK_Static_Expression; 5607 5608 ------------------------------------------ 5609 -- Check_Arg_Is_Task_Dispatching_Policy -- 5610 ------------------------------------------ 5611 5612 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is 5613 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 5614 5615 begin 5616 Check_Arg_Is_Identifier (Argx); 5617 5618 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then 5619 Error_Pragma_Arg 5620 ("& is not an allowed task dispatching policy name", Argx); 5621 end if; 5622 end Check_Arg_Is_Task_Dispatching_Policy; 5623 5624 --------------------- 5625 -- Check_Arg_Order -- 5626 --------------------- 5627 5628 procedure Check_Arg_Order (Names : Name_List) is 5629 Arg : Node_Id; 5630 5631 Highest_So_Far : Natural := 0; 5632 -- Highest index in Names seen do far 5633 5634 begin 5635 Arg := Arg1; 5636 for J in 1 .. Arg_Count loop 5637 if Chars (Arg) /= No_Name then 5638 for K in Names'Range loop 5639 if Chars (Arg) = Names (K) then 5640 if K < Highest_So_Far then 5641 Error_Msg_Name_1 := Pname; 5642 Error_Msg_N 5643 ("parameters out of order for pragma%", Arg); 5644 Error_Msg_Name_1 := Names (K); 5645 Error_Msg_Name_2 := Names (Highest_So_Far); 5646 Error_Msg_N ("\% must appear before %", Arg); 5647 raise Pragma_Exit; 5648 5649 else 5650 Highest_So_Far := K; 5651 end if; 5652 end if; 5653 end loop; 5654 end if; 5655 5656 Arg := Next (Arg); 5657 end loop; 5658 end Check_Arg_Order; 5659 5660 -------------------------------- 5661 -- Check_At_Least_N_Arguments -- 5662 -------------------------------- 5663 5664 procedure Check_At_Least_N_Arguments (N : Nat) is 5665 begin 5666 if Arg_Count < N then 5667 Error_Pragma ("too few arguments for pragma%"); 5668 end if; 5669 end Check_At_Least_N_Arguments; 5670 5671 ------------------------------- 5672 -- Check_At_Most_N_Arguments -- 5673 ------------------------------- 5674 5675 procedure Check_At_Most_N_Arguments (N : Nat) is 5676 Arg : Node_Id; 5677 begin 5678 if Arg_Count > N then 5679 Arg := Arg1; 5680 for J in 1 .. N loop 5681 Next (Arg); 5682 Error_Pragma_Arg ("too many arguments for pragma%", Arg); 5683 end loop; 5684 end if; 5685 end Check_At_Most_N_Arguments; 5686 5687 ------------------------ 5688 -- Check_Atomic_VFA -- 5689 ------------------------ 5690 5691 procedure Check_Atomic_VFA (E : Entity_Id; VFA : Boolean) is 5692 5693 Aliased_Subcomponent : exception; 5694 -- Exception raised if an aliased subcomponent is found in E 5695 5696 Independent_Subcomponent : exception; 5697 -- Exception raised if an independent subcomponent is found in E 5698 5699 procedure Check_Subcomponents (Typ : Entity_Id); 5700 -- Apply checks to subcomponents for Atomic and Volatile_Full_Access 5701 5702 ------------------------- 5703 -- Check_Subcomponents -- 5704 ------------------------- 5705 5706 procedure Check_Subcomponents (Typ : Entity_Id) is 5707 Comp : Entity_Id; 5708 5709 begin 5710 if Is_Array_Type (Typ) then 5711 Comp := Component_Type (Typ); 5712 5713 -- For Atomic we accept any atomic subcomponents 5714 5715 if not VFA 5716 and then (Has_Atomic_Components (Typ) 5717 or else Is_Atomic (Comp)) 5718 then 5719 null; 5720 5721 -- Give an error if the components are aliased 5722 5723 elsif Has_Aliased_Components (Typ) 5724 or else Is_Aliased (Comp) 5725 then 5726 raise Aliased_Subcomponent; 5727 5728 -- For VFA we accept non-aliased VFA subcomponents 5729 5730 elsif VFA 5731 and then Is_Volatile_Full_Access (Comp) 5732 then 5733 null; 5734 5735 -- Give an error if the components are independent 5736 5737 elsif Has_Independent_Components (Typ) 5738 or else Is_Independent (Comp) 5739 then 5740 raise Independent_Subcomponent; 5741 end if; 5742 5743 -- Recurse on the component type 5744 5745 Check_Subcomponents (Comp); 5746 5747 -- Note: Has_Aliased_Components, like Has_Atomic_Components, 5748 -- and Has_Independent_Components, applies only to arrays. 5749 -- However, this flag does not have a corresponding pragma, so 5750 -- perhaps it should be possible to apply it to record types as 5751 -- well. Should this be done ??? 5752 5753 elsif Is_Record_Type (Typ) then 5754 -- It is possible to have an aliased discriminant, so they 5755 -- must be checked along with normal components. 5756 5757 Comp := First_Component_Or_Discriminant (Typ); 5758 while Present (Comp) loop 5759 5760 -- For Atomic we accept any atomic subcomponents 5761 5762 if not VFA 5763 and then (Is_Atomic (Comp) 5764 or else Is_Atomic (Etype (Comp))) 5765 then 5766 null; 5767 5768 -- Give an error if the component is aliased 5769 5770 elsif Is_Aliased (Comp) 5771 or else Is_Aliased (Etype (Comp)) 5772 then 5773 raise Aliased_Subcomponent; 5774 5775 -- For VFA we accept non-aliased VFA subcomponents 5776 5777 elsif VFA 5778 and then (Is_Volatile_Full_Access (Comp) 5779 or else Is_Volatile_Full_Access (Etype (Comp))) 5780 then 5781 null; 5782 5783 -- Give an error if the component is independent 5784 5785 elsif Is_Independent (Comp) 5786 or else Is_Independent (Etype (Comp)) 5787 then 5788 raise Independent_Subcomponent; 5789 end if; 5790 5791 -- Recurse on the component type 5792 5793 Check_Subcomponents (Etype (Comp)); 5794 5795 Next_Component_Or_Discriminant (Comp); 5796 end loop; 5797 end if; 5798 end Check_Subcomponents; 5799 5800 Typ : Entity_Id; 5801 5802 begin 5803 -- Fetch the type in case we are dealing with an object or component 5804 5805 if Is_Type (E) then 5806 Typ := E; 5807 else 5808 pragma Assert (Is_Object (E) 5809 or else 5810 Nkind (Declaration_Node (E)) = N_Component_Declaration); 5811 5812 Typ := Etype (E); 5813 end if; 5814 5815 -- Check all the subcomponents of the type recursively, if any 5816 5817 Check_Subcomponents (Typ); 5818 5819 exception 5820 when Aliased_Subcomponent => 5821 if VFA then 5822 Error_Pragma 5823 ("cannot apply Volatile_Full_Access with aliased " 5824 & "subcomponent "); 5825 else 5826 Error_Pragma 5827 ("cannot apply Atomic with aliased subcomponent " 5828 & "(RM C.6(13))"); 5829 end if; 5830 5831 when Independent_Subcomponent => 5832 if VFA then 5833 Error_Pragma 5834 ("cannot apply Volatile_Full_Access with independent " 5835 & "subcomponent "); 5836 else 5837 Error_Pragma 5838 ("cannot apply Atomic with independent subcomponent " 5839 & "(RM C.6(13))"); 5840 end if; 5841 5842 when others => 5843 raise Program_Error; 5844 end Check_Atomic_VFA; 5845 5846 --------------------- 5847 -- Check_Component -- 5848 --------------------- 5849 5850 procedure Check_Component 5851 (Comp : Node_Id; 5852 UU_Typ : Entity_Id; 5853 In_Variant_Part : Boolean := False) 5854 is 5855 Comp_Id : constant Entity_Id := Defining_Identifier (Comp); 5856 Sindic : constant Node_Id := 5857 Subtype_Indication (Component_Definition (Comp)); 5858 Typ : constant Entity_Id := Etype (Comp_Id); 5859 5860 begin 5861 -- Ada 2005 (AI-216): If a component subtype is subject to a per- 5862 -- object constraint, then the component type shall be an Unchecked_ 5863 -- Union. 5864 5865 if Nkind (Sindic) = N_Subtype_Indication 5866 and then Has_Per_Object_Constraint (Comp_Id) 5867 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) 5868 then 5869 Error_Msg_N 5870 ("component subtype subject to per-object constraint " 5871 & "must be an Unchecked_Union", Comp); 5872 5873 -- Ada 2012 (AI05-0026): For an unchecked union type declared within 5874 -- the body of a generic unit, or within the body of any of its 5875 -- descendant library units, no part of the type of a component 5876 -- declared in a variant_part of the unchecked union type shall be of 5877 -- a formal private type or formal private extension declared within 5878 -- the formal part of the generic unit. 5879 5880 elsif Ada_Version >= Ada_2012 5881 and then In_Generic_Body (UU_Typ) 5882 and then In_Variant_Part 5883 and then Is_Private_Type (Typ) 5884 and then Is_Generic_Type (Typ) 5885 then 5886 Error_Msg_N 5887 ("component of unchecked union cannot be of generic type", Comp); 5888 5889 elsif Needs_Finalization (Typ) then 5890 Error_Msg_N 5891 ("component of unchecked union cannot be controlled", Comp); 5892 5893 elsif Has_Task (Typ) then 5894 Error_Msg_N 5895 ("component of unchecked union cannot have tasks", Comp); 5896 end if; 5897 end Check_Component; 5898 5899 ---------------------------- 5900 -- Check_Duplicate_Pragma -- 5901 ---------------------------- 5902 5903 procedure Check_Duplicate_Pragma (E : Entity_Id) is 5904 Id : Entity_Id := E; 5905 P : Node_Id; 5906 5907 begin 5908 -- Nothing to do if this pragma comes from an aspect specification, 5909 -- since we could not be duplicating a pragma, and we dealt with the 5910 -- case of duplicated aspects in Analyze_Aspect_Specifications. 5911 5912 if From_Aspect_Specification (N) then 5913 return; 5914 end if; 5915 5916 -- Otherwise current pragma may duplicate previous pragma or a 5917 -- previously given aspect specification or attribute definition 5918 -- clause for the same pragma. 5919 5920 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False); 5921 5922 if Present (P) then 5923 5924 -- If the entity is a type, then we have to make sure that the 5925 -- ostensible duplicate is not for a parent type from which this 5926 -- type is derived. 5927 5928 if Is_Type (E) then 5929 if Nkind (P) = N_Pragma then 5930 declare 5931 Args : constant List_Id := 5932 Pragma_Argument_Associations (P); 5933 begin 5934 if Present (Args) 5935 and then Is_Entity_Name (Expression (First (Args))) 5936 and then Is_Type (Entity (Expression (First (Args)))) 5937 and then Entity (Expression (First (Args))) /= E 5938 then 5939 return; 5940 end if; 5941 end; 5942 5943 elsif Nkind (P) = N_Aspect_Specification 5944 and then Is_Type (Entity (P)) 5945 and then Entity (P) /= E 5946 then 5947 return; 5948 end if; 5949 end if; 5950 5951 -- Here we have a definite duplicate 5952 5953 Error_Msg_Name_1 := Pragma_Name (N); 5954 Error_Msg_Sloc := Sloc (P); 5955 5956 -- For a single protected or a single task object, the error is 5957 -- issued on the original entity. 5958 5959 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then 5960 Id := Defining_Identifier (Original_Node (Parent (Id))); 5961 end if; 5962 5963 if Nkind (P) = N_Aspect_Specification 5964 or else From_Aspect_Specification (P) 5965 then 5966 Error_Msg_NE ("aspect% for & previously given#", N, Id); 5967 else 5968 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); 5969 end if; 5970 5971 raise Pragma_Exit; 5972 end if; 5973 end Check_Duplicate_Pragma; 5974 5975 ---------------------------------- 5976 -- Check_Duplicated_Export_Name -- 5977 ---------------------------------- 5978 5979 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is 5980 String_Val : constant String_Id := Strval (Nam); 5981 5982 begin 5983 -- We are only interested in the export case, and in the case of 5984 -- generics, it is the instance, not the template, that is the 5985 -- problem (the template will generate a warning in any case). 5986 5987 if not Inside_A_Generic 5988 and then (Prag_Id = Pragma_Export 5989 or else 5990 Prag_Id = Pragma_Export_Procedure 5991 or else 5992 Prag_Id = Pragma_Export_Valued_Procedure 5993 or else 5994 Prag_Id = Pragma_Export_Function) 5995 then 5996 for J in Externals.First .. Externals.Last loop 5997 if String_Equal (String_Val, Strval (Externals.Table (J))) then 5998 Error_Msg_Sloc := Sloc (Externals.Table (J)); 5999 Error_Msg_N ("external name duplicates name given#", Nam); 6000 exit; 6001 end if; 6002 end loop; 6003 6004 Externals.Append (Nam); 6005 end if; 6006 end Check_Duplicated_Export_Name; 6007 6008 ---------------------------------------- 6009 -- Check_Expr_Is_OK_Static_Expression -- 6010 ---------------------------------------- 6011 6012 procedure Check_Expr_Is_OK_Static_Expression 6013 (Expr : Node_Id; 6014 Typ : Entity_Id := Empty) 6015 is 6016 begin 6017 if Present (Typ) then 6018 Analyze_And_Resolve (Expr, Typ); 6019 else 6020 Analyze_And_Resolve (Expr); 6021 end if; 6022 6023 -- An expression cannot be considered static if its resolution failed 6024 -- or if it's erroneous. Stop the analysis of the related pragma. 6025 6026 if Etype (Expr) = Any_Type or else Error_Posted (Expr) then 6027 raise Pragma_Exit; 6028 6029 elsif Is_OK_Static_Expression (Expr) then 6030 return; 6031 6032 -- An interesting special case, if we have a string literal and we 6033 -- are in Ada 83 mode, then we allow it even though it will not be 6034 -- flagged as static. This allows the use of Ada 95 pragmas like 6035 -- Import in Ada 83 mode. They will of course be flagged with 6036 -- warnings as usual, but will not cause errors. 6037 6038 elsif Ada_Version = Ada_83 6039 and then Nkind (Expr) = N_String_Literal 6040 then 6041 return; 6042 6043 -- Finally, we have a real error 6044 6045 else 6046 Error_Msg_Name_1 := Pname; 6047 Flag_Non_Static_Expr 6048 (Fix_Error ("argument for pragma% must be a static expression!"), 6049 Expr); 6050 raise Pragma_Exit; 6051 end if; 6052 end Check_Expr_Is_OK_Static_Expression; 6053 6054 ------------------------- 6055 -- Check_First_Subtype -- 6056 ------------------------- 6057 6058 procedure Check_First_Subtype (Arg : Node_Id) is 6059 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 6060 Ent : constant Entity_Id := Entity (Argx); 6061 6062 begin 6063 if Is_First_Subtype (Ent) then 6064 null; 6065 6066 elsif Is_Type (Ent) then 6067 Error_Pragma_Arg 6068 ("pragma% cannot apply to subtype", Argx); 6069 6070 elsif Is_Object (Ent) then 6071 Error_Pragma_Arg 6072 ("pragma% cannot apply to object, requires a type", Argx); 6073 6074 else 6075 Error_Pragma_Arg 6076 ("pragma% cannot apply to&, requires a type", Argx); 6077 end if; 6078 end Check_First_Subtype; 6079 6080 ---------------------- 6081 -- Check_Identifier -- 6082 ---------------------- 6083 6084 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is 6085 begin 6086 if Present (Arg) 6087 and then Nkind (Arg) = N_Pragma_Argument_Association 6088 then 6089 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then 6090 Error_Msg_Name_1 := Pname; 6091 Error_Msg_Name_2 := Id; 6092 Error_Msg_N ("pragma% argument expects identifier%", Arg); 6093 raise Pragma_Exit; 6094 end if; 6095 end if; 6096 end Check_Identifier; 6097 6098 -------------------------------- 6099 -- Check_Identifier_Is_One_Of -- 6100 -------------------------------- 6101 6102 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 6103 begin 6104 if Present (Arg) 6105 and then Nkind (Arg) = N_Pragma_Argument_Association 6106 then 6107 if Chars (Arg) = No_Name then 6108 Error_Msg_Name_1 := Pname; 6109 Error_Msg_N ("pragma% argument expects an identifier", Arg); 6110 raise Pragma_Exit; 6111 6112 elsif Chars (Arg) /= N1 6113 and then Chars (Arg) /= N2 6114 then 6115 Error_Msg_Name_1 := Pname; 6116 Error_Msg_N ("invalid identifier for pragma% argument", Arg); 6117 raise Pragma_Exit; 6118 end if; 6119 end if; 6120 end Check_Identifier_Is_One_Of; 6121 6122 --------------------------- 6123 -- Check_In_Main_Program -- 6124 --------------------------- 6125 6126 procedure Check_In_Main_Program is 6127 P : constant Node_Id := Parent (N); 6128 6129 begin 6130 -- Must be in subprogram body 6131 6132 if Nkind (P) /= N_Subprogram_Body then 6133 Error_Pragma ("% pragma allowed only in subprogram"); 6134 6135 -- Otherwise warn if obviously not main program 6136 6137 elsif Present (Parameter_Specifications (Specification (P))) 6138 or else not Is_Compilation_Unit (Defining_Entity (P)) 6139 then 6140 Error_Msg_Name_1 := Pname; 6141 Error_Msg_N 6142 ("??pragma% is only effective in main program", N); 6143 end if; 6144 end Check_In_Main_Program; 6145 6146 --------------------------------------- 6147 -- Check_Interrupt_Or_Attach_Handler -- 6148 --------------------------------------- 6149 6150 procedure Check_Interrupt_Or_Attach_Handler is 6151 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); 6152 Handler_Proc, Proc_Scope : Entity_Id; 6153 6154 begin 6155 Analyze (Arg1_X); 6156 6157 if Prag_Id = Pragma_Interrupt_Handler then 6158 Check_Restriction (No_Dynamic_Attachment, N); 6159 end if; 6160 6161 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 6162 Proc_Scope := Scope (Handler_Proc); 6163 6164 if Ekind (Proc_Scope) /= E_Protected_Type then 6165 Error_Pragma_Arg 6166 ("argument of pragma% must be protected procedure", Arg1); 6167 end if; 6168 6169 -- For pragma case (as opposed to access case), check placement. 6170 -- We don't need to do that for aspects, because we have the 6171 -- check that they aspect applies an appropriate procedure. 6172 6173 if not From_Aspect_Specification (N) 6174 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope)) 6175 then 6176 Error_Pragma ("pragma% must be in protected definition"); 6177 end if; 6178 6179 if not Is_Library_Level_Entity (Proc_Scope) then 6180 Error_Pragma_Arg 6181 ("argument for pragma% must be library level entity", Arg1); 6182 end if; 6183 6184 -- AI05-0033: A pragma cannot appear within a generic body, because 6185 -- instance can be in a nested scope. The check that protected type 6186 -- is itself a library-level declaration is done elsewhere. 6187 6188 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly 6189 -- handle code prior to AI-0033. Analysis tools typically are not 6190 -- interested in this pragma in any case, so no need to worry too 6191 -- much about its placement. 6192 6193 if Inside_A_Generic then 6194 if Ekind (Scope (Current_Scope)) = E_Generic_Package 6195 and then In_Package_Body (Scope (Current_Scope)) 6196 and then not Relaxed_RM_Semantics 6197 then 6198 Error_Pragma ("pragma% cannot be used inside a generic"); 6199 end if; 6200 end if; 6201 end Check_Interrupt_Or_Attach_Handler; 6202 6203 --------------------------------- 6204 -- Check_Loop_Pragma_Placement -- 6205 --------------------------------- 6206 6207 procedure Check_Loop_Pragma_Placement is 6208 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id); 6209 -- Verify whether the current pragma is properly grouped with other 6210 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the 6211 -- related loop where the pragma appears. 6212 6213 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean; 6214 -- Determine whether an arbitrary statement Stmt denotes pragma 6215 -- Loop_Invariant or Loop_Variant. 6216 6217 procedure Placement_Error (Constr : Node_Id); 6218 pragma No_Return (Placement_Error); 6219 -- Node Constr denotes the last loop restricted construct before we 6220 -- encountered an illegal relation between enclosing constructs. Emit 6221 -- an error depending on what Constr was. 6222 6223 -------------------------------- 6224 -- Check_Loop_Pragma_Grouping -- 6225 -------------------------------- 6226 6227 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is 6228 Stop_Search : exception; 6229 -- This exception is used to terminate the recursive descent of 6230 -- routine Check_Grouping. 6231 6232 procedure Check_Grouping (L : List_Id); 6233 -- Find the first group of pragmas in list L and if successful, 6234 -- ensure that the current pragma is part of that group. The 6235 -- routine raises Stop_Search once such a check is performed to 6236 -- halt the recursive descent. 6237 6238 procedure Grouping_Error (Prag : Node_Id); 6239 pragma No_Return (Grouping_Error); 6240 -- Emit an error concerning the current pragma indicating that it 6241 -- should be placed after pragma Prag. 6242 6243 -------------------- 6244 -- Check_Grouping -- 6245 -------------------- 6246 6247 procedure Check_Grouping (L : List_Id) is 6248 HSS : Node_Id; 6249 Stmt : Node_Id; 6250 Prag : Node_Id := Empty; -- init to avoid warning 6251 6252 begin 6253 -- Inspect the list of declarations or statements looking for 6254 -- the first grouping of pragmas: 6255 6256 -- loop 6257 -- pragma Loop_Invariant ...; 6258 -- pragma Loop_Variant ...; 6259 -- . . . -- (1) 6260 -- pragma Loop_Variant ...; -- current pragma 6261 6262 -- If the current pragma is not in the grouping, then it must 6263 -- either appear in a different declarative or statement list 6264 -- or the construct at (1) is separating the pragma from the 6265 -- grouping. 6266 6267 Stmt := First (L); 6268 while Present (Stmt) loop 6269 6270 -- First pragma of the first topmost grouping has been found 6271 6272 if Is_Loop_Pragma (Stmt) then 6273 6274 -- The group and the current pragma are not in the same 6275 -- declarative or statement list. 6276 6277 if List_Containing (Stmt) /= List_Containing (N) then 6278 Grouping_Error (Stmt); 6279 6280 -- Try to reach the current pragma from the first pragma 6281 -- of the grouping while skipping other members: 6282 6283 -- pragma Loop_Invariant ...; -- first pragma 6284 -- pragma Loop_Variant ...; -- member 6285 -- . . . 6286 -- pragma Loop_Variant ...; -- current pragma 6287 6288 else 6289 while Present (Stmt) loop 6290 -- The current pragma is either the first pragma 6291 -- of the group or is a member of the group. 6292 -- Stop the search as the placement is legal. 6293 6294 if Stmt = N then 6295 raise Stop_Search; 6296 6297 -- Skip group members, but keep track of the 6298 -- last pragma in the group. 6299 6300 elsif Is_Loop_Pragma (Stmt) then 6301 Prag := Stmt; 6302 6303 -- Skip declarations and statements generated by 6304 -- the compiler during expansion. Note that some 6305 -- source statements (e.g. pragma Assert) may have 6306 -- been transformed so that they do not appear as 6307 -- coming from source anymore, so we instead look 6308 -- at their Original_Node. 6309 6310 elsif not Comes_From_Source (Original_Node (Stmt)) 6311 then 6312 null; 6313 6314 -- A non-pragma is separating the group from the 6315 -- current pragma, the placement is illegal. 6316 6317 else 6318 Grouping_Error (Prag); 6319 end if; 6320 6321 Next (Stmt); 6322 end loop; 6323 6324 -- If the traversal did not reach the current pragma, 6325 -- then the list must be malformed. 6326 6327 raise Program_Error; 6328 end if; 6329 6330 -- Pragmas Loop_Invariant and Loop_Variant may only appear 6331 -- inside a loop or a block housed inside a loop. Inspect 6332 -- the declarations and statements of the block as they may 6333 -- contain the first grouping. This case follows the one for 6334 -- loop pragmas, as block statements which originate in a 6335 -- loop pragma (and so Is_Loop_Pragma will return True on 6336 -- that block statement) should be treated in the previous 6337 -- case. 6338 6339 elsif Nkind (Stmt) = N_Block_Statement then 6340 HSS := Handled_Statement_Sequence (Stmt); 6341 6342 Check_Grouping (Declarations (Stmt)); 6343 6344 if Present (HSS) then 6345 Check_Grouping (Statements (HSS)); 6346 end if; 6347 end if; 6348 6349 Next (Stmt); 6350 end loop; 6351 end Check_Grouping; 6352 6353 -------------------- 6354 -- Grouping_Error -- 6355 -------------------- 6356 6357 procedure Grouping_Error (Prag : Node_Id) is 6358 begin 6359 Error_Msg_Sloc := Sloc (Prag); 6360 Error_Pragma ("pragma% must appear next to pragma#"); 6361 end Grouping_Error; 6362 6363 -- Start of processing for Check_Loop_Pragma_Grouping 6364 6365 begin 6366 -- Inspect the statements of the loop or nested blocks housed 6367 -- within to determine whether the current pragma is part of the 6368 -- first topmost grouping of Loop_Invariant and Loop_Variant. 6369 6370 Check_Grouping (Statements (Loop_Stmt)); 6371 6372 exception 6373 when Stop_Search => null; 6374 end Check_Loop_Pragma_Grouping; 6375 6376 -------------------- 6377 -- Is_Loop_Pragma -- 6378 -------------------- 6379 6380 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is 6381 begin 6382 -- Inspect the original node as Loop_Invariant and Loop_Variant 6383 -- pragmas are rewritten to null when assertions are disabled. 6384 6385 if Nkind (Original_Node (Stmt)) = N_Pragma then 6386 return 6387 Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)), 6388 Name_Loop_Invariant, 6389 Name_Loop_Variant); 6390 else 6391 return False; 6392 end if; 6393 end Is_Loop_Pragma; 6394 6395 --------------------- 6396 -- Placement_Error -- 6397 --------------------- 6398 6399 procedure Placement_Error (Constr : Node_Id) is 6400 LA : constant String := " with Loop_Entry"; 6401 6402 begin 6403 if Prag_Id = Pragma_Assert then 6404 Error_Msg_String (1 .. LA'Length) := LA; 6405 Error_Msg_Strlen := LA'Length; 6406 else 6407 Error_Msg_Strlen := 0; 6408 end if; 6409 6410 if Nkind (Constr) = N_Pragma then 6411 Error_Pragma 6412 ("pragma %~ must appear immediately within the statements " 6413 & "of a loop"); 6414 else 6415 Error_Pragma_Arg 6416 ("block containing pragma %~ must appear immediately within " 6417 & "the statements of a loop", Constr); 6418 end if; 6419 end Placement_Error; 6420 6421 -- Local declarations 6422 6423 Prev : Node_Id; 6424 Stmt : Node_Id; 6425 6426 -- Start of processing for Check_Loop_Pragma_Placement 6427 6428 begin 6429 -- Check that pragma appears immediately within a loop statement, 6430 -- ignoring intervening block statements. 6431 6432 Prev := N; 6433 Stmt := Parent (N); 6434 while Present (Stmt) loop 6435 6436 -- The pragma or previous block must appear immediately within the 6437 -- current block's declarative or statement part. 6438 6439 if Nkind (Stmt) = N_Block_Statement then 6440 if (No (Declarations (Stmt)) 6441 or else List_Containing (Prev) /= Declarations (Stmt)) 6442 and then 6443 List_Containing (Prev) /= 6444 Statements (Handled_Statement_Sequence (Stmt)) 6445 then 6446 Placement_Error (Prev); 6447 return; 6448 6449 -- Keep inspecting the parents because we are now within a 6450 -- chain of nested blocks. 6451 6452 else 6453 Prev := Stmt; 6454 Stmt := Parent (Stmt); 6455 end if; 6456 6457 -- The pragma or previous block must appear immediately within the 6458 -- statements of the loop. 6459 6460 elsif Nkind (Stmt) = N_Loop_Statement then 6461 if List_Containing (Prev) /= Statements (Stmt) then 6462 Placement_Error (Prev); 6463 end if; 6464 6465 -- Stop the traversal because we reached the innermost loop 6466 -- regardless of whether we encountered an error or not. 6467 6468 exit; 6469 6470 -- Ignore a handled statement sequence. Note that this node may 6471 -- be related to a subprogram body in which case we will emit an 6472 -- error on the next iteration of the search. 6473 6474 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then 6475 Stmt := Parent (Stmt); 6476 6477 -- Any other statement breaks the chain from the pragma to the 6478 -- loop. 6479 6480 else 6481 Placement_Error (Prev); 6482 return; 6483 end if; 6484 end loop; 6485 6486 -- Check that the current pragma Loop_Invariant or Loop_Variant is 6487 -- grouped together with other such pragmas. 6488 6489 if Is_Loop_Pragma (N) then 6490 6491 -- The previous check should have located the related loop 6492 6493 pragma Assert (Nkind (Stmt) = N_Loop_Statement); 6494 Check_Loop_Pragma_Grouping (Stmt); 6495 end if; 6496 end Check_Loop_Pragma_Placement; 6497 6498 ------------------------------------------- 6499 -- Check_Is_In_Decl_Part_Or_Package_Spec -- 6500 ------------------------------------------- 6501 6502 procedure Check_Is_In_Decl_Part_Or_Package_Spec is 6503 P : Node_Id; 6504 6505 begin 6506 P := Parent (N); 6507 loop 6508 if No (P) then 6509 exit; 6510 6511 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then 6512 exit; 6513 6514 elsif Nkind_In (P, N_Package_Specification, 6515 N_Block_Statement) 6516 then 6517 return; 6518 6519 -- Note: the following tests seem a little peculiar, because 6520 -- they test for bodies, but if we were in the statement part 6521 -- of the body, we would already have hit the handled statement 6522 -- sequence, so the only way we get here is by being in the 6523 -- declarative part of the body. 6524 6525 elsif Nkind_In (P, N_Subprogram_Body, 6526 N_Package_Body, 6527 N_Task_Body, 6528 N_Entry_Body) 6529 then 6530 return; 6531 end if; 6532 6533 P := Parent (P); 6534 end loop; 6535 6536 Error_Pragma ("pragma% is not in declarative part or package spec"); 6537 end Check_Is_In_Decl_Part_Or_Package_Spec; 6538 6539 ------------------------- 6540 -- Check_No_Identifier -- 6541 ------------------------- 6542 6543 procedure Check_No_Identifier (Arg : Node_Id) is 6544 begin 6545 if Nkind (Arg) = N_Pragma_Argument_Association 6546 and then Chars (Arg) /= No_Name 6547 then 6548 Error_Pragma_Arg_Ident 6549 ("pragma% does not permit identifier& here", Arg); 6550 end if; 6551 end Check_No_Identifier; 6552 6553 -------------------------- 6554 -- Check_No_Identifiers -- 6555 -------------------------- 6556 6557 procedure Check_No_Identifiers is 6558 Arg_Node : Node_Id; 6559 begin 6560 Arg_Node := Arg1; 6561 for J in 1 .. Arg_Count loop 6562 Check_No_Identifier (Arg_Node); 6563 Next (Arg_Node); 6564 end loop; 6565 end Check_No_Identifiers; 6566 6567 ------------------------ 6568 -- Check_No_Link_Name -- 6569 ------------------------ 6570 6571 procedure Check_No_Link_Name is 6572 begin 6573 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then 6574 Arg4 := Arg3; 6575 end if; 6576 6577 if Present (Arg4) then 6578 Error_Pragma_Arg 6579 ("Link_Name argument not allowed for Import Intrinsic", Arg4); 6580 end if; 6581 end Check_No_Link_Name; 6582 6583 ------------------------------- 6584 -- Check_Optional_Identifier -- 6585 ------------------------------- 6586 6587 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 6588 begin 6589 if Present (Arg) 6590 and then Nkind (Arg) = N_Pragma_Argument_Association 6591 and then Chars (Arg) /= No_Name 6592 then 6593 if Chars (Arg) /= Id then 6594 Error_Msg_Name_1 := Pname; 6595 Error_Msg_Name_2 := Id; 6596 Error_Msg_N ("pragma% argument expects identifier%", Arg); 6597 raise Pragma_Exit; 6598 end if; 6599 end if; 6600 end Check_Optional_Identifier; 6601 6602 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is 6603 begin 6604 Check_Optional_Identifier (Arg, Name_Find (Id)); 6605 end Check_Optional_Identifier; 6606 6607 ------------------------------------- 6608 -- Check_Static_Boolean_Expression -- 6609 ------------------------------------- 6610 6611 procedure Check_Static_Boolean_Expression (Expr : Node_Id) is 6612 begin 6613 if Present (Expr) then 6614 Analyze_And_Resolve (Expr, Standard_Boolean); 6615 6616 if not Is_OK_Static_Expression (Expr) then 6617 Error_Pragma_Arg 6618 ("expression of pragma % must be static", Expr); 6619 end if; 6620 end if; 6621 end Check_Static_Boolean_Expression; 6622 6623 ----------------------------- 6624 -- Check_Static_Constraint -- 6625 ----------------------------- 6626 6627 -- Note: for convenience in writing this procedure, in addition to 6628 -- the officially (i.e. by spec) allowed argument which is always a 6629 -- constraint, it also allows ranges and discriminant associations. 6630 -- Above is not clear ??? 6631 6632 procedure Check_Static_Constraint (Constr : Node_Id) is 6633 6634 procedure Require_Static (E : Node_Id); 6635 -- Require given expression to be static expression 6636 6637 -------------------- 6638 -- Require_Static -- 6639 -------------------- 6640 6641 procedure Require_Static (E : Node_Id) is 6642 begin 6643 if not Is_OK_Static_Expression (E) then 6644 Flag_Non_Static_Expr 6645 ("non-static constraint not allowed in Unchecked_Union!", E); 6646 raise Pragma_Exit; 6647 end if; 6648 end Require_Static; 6649 6650 -- Start of processing for Check_Static_Constraint 6651 6652 begin 6653 case Nkind (Constr) is 6654 when N_Discriminant_Association => 6655 Require_Static (Expression (Constr)); 6656 6657 when N_Range => 6658 Require_Static (Low_Bound (Constr)); 6659 Require_Static (High_Bound (Constr)); 6660 6661 when N_Attribute_Reference => 6662 Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); 6663 Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); 6664 6665 when N_Range_Constraint => 6666 Check_Static_Constraint (Range_Expression (Constr)); 6667 6668 when N_Index_Or_Discriminant_Constraint => 6669 declare 6670 IDC : Entity_Id; 6671 begin 6672 IDC := First (Constraints (Constr)); 6673 while Present (IDC) loop 6674 Check_Static_Constraint (IDC); 6675 Next (IDC); 6676 end loop; 6677 end; 6678 6679 when others => 6680 null; 6681 end case; 6682 end Check_Static_Constraint; 6683 6684 -------------------------------------- 6685 -- Check_Valid_Configuration_Pragma -- 6686 -------------------------------------- 6687 6688 -- A configuration pragma must appear in the context clause of a 6689 -- compilation unit, and only other pragmas may precede it. Note that 6690 -- the test also allows use in a configuration pragma file. 6691 6692 procedure Check_Valid_Configuration_Pragma is 6693 begin 6694 if not Is_Configuration_Pragma then 6695 Error_Pragma ("incorrect placement for configuration pragma%"); 6696 end if; 6697 end Check_Valid_Configuration_Pragma; 6698 6699 ------------------------------------- 6700 -- Check_Valid_Library_Unit_Pragma -- 6701 ------------------------------------- 6702 6703 procedure Check_Valid_Library_Unit_Pragma is 6704 Plist : List_Id; 6705 Parent_Node : Node_Id; 6706 Unit_Name : Entity_Id; 6707 Unit_Kind : Node_Kind; 6708 Unit_Node : Node_Id; 6709 Sindex : Source_File_Index; 6710 6711 begin 6712 if not Is_List_Member (N) then 6713 Pragma_Misplaced; 6714 6715 else 6716 Plist := List_Containing (N); 6717 Parent_Node := Parent (Plist); 6718 6719 if Parent_Node = Empty then 6720 Pragma_Misplaced; 6721 6722 -- Case of pragma appearing after a compilation unit. In this case 6723 -- it must have an argument with the corresponding name and must 6724 -- be part of the following pragmas of its parent. 6725 6726 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then 6727 if Plist /= Pragmas_After (Parent_Node) then 6728 Pragma_Misplaced; 6729 6730 elsif Arg_Count = 0 then 6731 Error_Pragma 6732 ("argument required if outside compilation unit"); 6733 6734 else 6735 Check_No_Identifiers; 6736 Check_Arg_Count (1); 6737 Unit_Node := Unit (Parent (Parent_Node)); 6738 Unit_Kind := Nkind (Unit_Node); 6739 6740 Analyze (Get_Pragma_Arg (Arg1)); 6741 6742 if Unit_Kind = N_Generic_Subprogram_Declaration 6743 or else Unit_Kind = N_Subprogram_Declaration 6744 then 6745 Unit_Name := Defining_Entity (Unit_Node); 6746 6747 elsif Unit_Kind in N_Generic_Instantiation then 6748 Unit_Name := Defining_Entity (Unit_Node); 6749 6750 else 6751 Unit_Name := Cunit_Entity (Current_Sem_Unit); 6752 end if; 6753 6754 if Chars (Unit_Name) /= 6755 Chars (Entity (Get_Pragma_Arg (Arg1))) 6756 then 6757 Error_Pragma_Arg 6758 ("pragma% argument is not current unit name", Arg1); 6759 end if; 6760 6761 if Ekind (Unit_Name) = E_Package 6762 and then Present (Renamed_Entity (Unit_Name)) 6763 then 6764 Error_Pragma ("pragma% not allowed for renamed package"); 6765 end if; 6766 end if; 6767 6768 -- Pragma appears other than after a compilation unit 6769 6770 else 6771 -- Here we check for the generic instantiation case and also 6772 -- for the case of processing a generic formal package. We 6773 -- detect these cases by noting that the Sloc on the node 6774 -- does not belong to the current compilation unit. 6775 6776 Sindex := Source_Index (Current_Sem_Unit); 6777 6778 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then 6779 Rewrite (N, Make_Null_Statement (Loc)); 6780 return; 6781 6782 -- If before first declaration, the pragma applies to the 6783 -- enclosing unit, and the name if present must be this name. 6784 6785 elsif Is_Before_First_Decl (N, Plist) then 6786 Unit_Node := Unit_Declaration_Node (Current_Scope); 6787 Unit_Kind := Nkind (Unit_Node); 6788 6789 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then 6790 Pragma_Misplaced; 6791 6792 elsif Unit_Kind = N_Subprogram_Body 6793 and then not Acts_As_Spec (Unit_Node) 6794 then 6795 Pragma_Misplaced; 6796 6797 elsif Nkind (Parent_Node) = N_Package_Body then 6798 Pragma_Misplaced; 6799 6800 elsif Nkind (Parent_Node) = N_Package_Specification 6801 and then Plist = Private_Declarations (Parent_Node) 6802 then 6803 Pragma_Misplaced; 6804 6805 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration 6806 or else Nkind (Parent_Node) = 6807 N_Generic_Subprogram_Declaration) 6808 and then Plist = Generic_Formal_Declarations (Parent_Node) 6809 then 6810 Pragma_Misplaced; 6811 6812 elsif Arg_Count > 0 then 6813 Analyze (Get_Pragma_Arg (Arg1)); 6814 6815 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then 6816 Error_Pragma_Arg 6817 ("name in pragma% must be enclosing unit", Arg1); 6818 end if; 6819 6820 -- It is legal to have no argument in this context 6821 6822 else 6823 return; 6824 end if; 6825 6826 -- Error if not before first declaration. This is because a 6827 -- library unit pragma argument must be the name of a library 6828 -- unit (RM 10.1.5(7)), but the only names permitted in this 6829 -- context are (RM 10.1.5(6)) names of subprogram declarations, 6830 -- generic subprogram declarations or generic instantiations. 6831 6832 else 6833 Error_Pragma 6834 ("pragma% misplaced, must be before first declaration"); 6835 end if; 6836 end if; 6837 end if; 6838 end Check_Valid_Library_Unit_Pragma; 6839 6840 ------------------- 6841 -- Check_Variant -- 6842 ------------------- 6843 6844 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is 6845 Clist : constant Node_Id := Component_List (Variant); 6846 Comp : Node_Id; 6847 6848 begin 6849 Comp := First_Non_Pragma (Component_Items (Clist)); 6850 while Present (Comp) loop 6851 Check_Component (Comp, UU_Typ, In_Variant_Part => True); 6852 Next_Non_Pragma (Comp); 6853 end loop; 6854 end Check_Variant; 6855 6856 --------------------------- 6857 -- Ensure_Aggregate_Form -- 6858 --------------------------- 6859 6860 procedure Ensure_Aggregate_Form (Arg : Node_Id) is 6861 CFSD : constant Boolean := Get_Comes_From_Source_Default; 6862 Expr : constant Node_Id := Expression (Arg); 6863 Loc : constant Source_Ptr := Sloc (Expr); 6864 Comps : List_Id := No_List; 6865 Exprs : List_Id := No_List; 6866 Nam : Name_Id := No_Name; 6867 Nam_Loc : Source_Ptr; 6868 6869 begin 6870 -- The pragma argument is in positional form: 6871 6872 -- pragma Depends (Nam => ...) 6873 -- ^ 6874 -- Chars field 6875 6876 -- Note that the Sloc of the Chars field is the Sloc of the pragma 6877 -- argument association. 6878 6879 if Nkind (Arg) = N_Pragma_Argument_Association then 6880 Nam := Chars (Arg); 6881 Nam_Loc := Sloc (Arg); 6882 6883 -- Remove the pragma argument name as this will be captured in the 6884 -- aggregate. 6885 6886 Set_Chars (Arg, No_Name); 6887 end if; 6888 6889 -- The argument is already in aggregate form, but the presence of a 6890 -- name causes this to be interpreted as named association which in 6891 -- turn must be converted into an aggregate. 6892 6893 -- pragma Global (In_Out => (A, B, C)) 6894 -- ^ ^ 6895 -- name aggregate 6896 6897 -- pragma Global ((In_Out => (A, B, C))) 6898 -- ^ ^ 6899 -- aggregate aggregate 6900 6901 if Nkind (Expr) = N_Aggregate then 6902 if Nam = No_Name then 6903 return; 6904 end if; 6905 6906 -- Do not transform a null argument into an aggregate as N_Null has 6907 -- special meaning in formal verification pragmas. 6908 6909 elsif Nkind (Expr) = N_Null then 6910 return; 6911 end if; 6912 6913 -- Everything comes from source if the original comes from source 6914 6915 Set_Comes_From_Source_Default (Comes_From_Source (Arg)); 6916 6917 -- Positional argument is transformed into an aggregate with an 6918 -- Expressions list. 6919 6920 if Nam = No_Name then 6921 Exprs := New_List (Relocate_Node (Expr)); 6922 6923 -- An associative argument is transformed into an aggregate with 6924 -- Component_Associations. 6925 6926 else 6927 Comps := New_List ( 6928 Make_Component_Association (Loc, 6929 Choices => New_List (Make_Identifier (Nam_Loc, Nam)), 6930 Expression => Relocate_Node (Expr))); 6931 end if; 6932 6933 Set_Expression (Arg, 6934 Make_Aggregate (Loc, 6935 Component_Associations => Comps, 6936 Expressions => Exprs)); 6937 6938 -- Restore Comes_From_Source default 6939 6940 Set_Comes_From_Source_Default (CFSD); 6941 end Ensure_Aggregate_Form; 6942 6943 ------------------ 6944 -- Error_Pragma -- 6945 ------------------ 6946 6947 procedure Error_Pragma (Msg : String) is 6948 begin 6949 Error_Msg_Name_1 := Pname; 6950 Error_Msg_N (Fix_Error (Msg), N); 6951 raise Pragma_Exit; 6952 end Error_Pragma; 6953 6954 ---------------------- 6955 -- Error_Pragma_Arg -- 6956 ---------------------- 6957 6958 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is 6959 begin 6960 Error_Msg_Name_1 := Pname; 6961 Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg)); 6962 raise Pragma_Exit; 6963 end Error_Pragma_Arg; 6964 6965 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is 6966 begin 6967 Error_Msg_Name_1 := Pname; 6968 Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg)); 6969 Error_Pragma_Arg (Msg2, Arg); 6970 end Error_Pragma_Arg; 6971 6972 ---------------------------- 6973 -- Error_Pragma_Arg_Ident -- 6974 ---------------------------- 6975 6976 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is 6977 begin 6978 Error_Msg_Name_1 := Pname; 6979 Error_Msg_N (Fix_Error (Msg), Arg); 6980 raise Pragma_Exit; 6981 end Error_Pragma_Arg_Ident; 6982 6983 ---------------------- 6984 -- Error_Pragma_Ref -- 6985 ---------------------- 6986 6987 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is 6988 begin 6989 Error_Msg_Name_1 := Pname; 6990 Error_Msg_Sloc := Sloc (Ref); 6991 Error_Msg_NE (Fix_Error (Msg), N, Ref); 6992 raise Pragma_Exit; 6993 end Error_Pragma_Ref; 6994 6995 ------------------------ 6996 -- Find_Lib_Unit_Name -- 6997 ------------------------ 6998 6999 function Find_Lib_Unit_Name return Entity_Id is 7000 begin 7001 -- Return inner compilation unit entity, for case of nested 7002 -- categorization pragmas. This happens in generic unit. 7003 7004 if Nkind (Parent (N)) = N_Package_Specification 7005 and then Defining_Entity (Parent (N)) /= Current_Scope 7006 then 7007 return Defining_Entity (Parent (N)); 7008 else 7009 return Current_Scope; 7010 end if; 7011 end Find_Lib_Unit_Name; 7012 7013 ---------------------------- 7014 -- Find_Program_Unit_Name -- 7015 ---------------------------- 7016 7017 procedure Find_Program_Unit_Name (Id : Node_Id) is 7018 Unit_Name : Entity_Id; 7019 Unit_Kind : Node_Kind; 7020 P : constant Node_Id := Parent (N); 7021 7022 begin 7023 if Nkind (P) = N_Compilation_Unit then 7024 Unit_Kind := Nkind (Unit (P)); 7025 7026 if Nkind_In (Unit_Kind, N_Subprogram_Declaration, 7027 N_Package_Declaration) 7028 or else Unit_Kind in N_Generic_Declaration 7029 then 7030 Unit_Name := Defining_Entity (Unit (P)); 7031 7032 if Chars (Id) = Chars (Unit_Name) then 7033 Set_Entity (Id, Unit_Name); 7034 Set_Etype (Id, Etype (Unit_Name)); 7035 else 7036 Set_Etype (Id, Any_Type); 7037 Error_Pragma 7038 ("cannot find program unit referenced by pragma%"); 7039 end if; 7040 7041 else 7042 Set_Etype (Id, Any_Type); 7043 Error_Pragma ("pragma% inapplicable to this unit"); 7044 end if; 7045 7046 else 7047 Analyze (Id); 7048 end if; 7049 end Find_Program_Unit_Name; 7050 7051 ----------------------------------------- 7052 -- Find_Unique_Parameterless_Procedure -- 7053 ----------------------------------------- 7054 7055 function Find_Unique_Parameterless_Procedure 7056 (Name : Entity_Id; 7057 Arg : Node_Id) return Entity_Id 7058 is 7059 Proc : Entity_Id := Empty; 7060 7061 begin 7062 -- The body of this procedure needs some comments ??? 7063 7064 if not Is_Entity_Name (Name) then 7065 Error_Pragma_Arg 7066 ("argument of pragma% must be entity name", Arg); 7067 7068 elsif not Is_Overloaded (Name) then 7069 Proc := Entity (Name); 7070 7071 if Ekind (Proc) /= E_Procedure 7072 or else Present (First_Formal (Proc)) 7073 then 7074 Error_Pragma_Arg 7075 ("argument of pragma% must be parameterless procedure", Arg); 7076 end if; 7077 7078 else 7079 declare 7080 Found : Boolean := False; 7081 It : Interp; 7082 Index : Interp_Index; 7083 7084 begin 7085 Get_First_Interp (Name, Index, It); 7086 while Present (It.Nam) loop 7087 Proc := It.Nam; 7088 7089 if Ekind (Proc) = E_Procedure 7090 and then No (First_Formal (Proc)) 7091 then 7092 if not Found then 7093 Found := True; 7094 Set_Entity (Name, Proc); 7095 Set_Is_Overloaded (Name, False); 7096 else 7097 Error_Pragma_Arg 7098 ("ambiguous handler name for pragma% ", Arg); 7099 end if; 7100 end if; 7101 7102 Get_Next_Interp (Index, It); 7103 end loop; 7104 7105 if not Found then 7106 Error_Pragma_Arg 7107 ("argument of pragma% must be parameterless procedure", 7108 Arg); 7109 else 7110 Proc := Entity (Name); 7111 end if; 7112 end; 7113 end if; 7114 7115 return Proc; 7116 end Find_Unique_Parameterless_Procedure; 7117 7118 --------------- 7119 -- Fix_Error -- 7120 --------------- 7121 7122 function Fix_Error (Msg : String) return String is 7123 Res : String (Msg'Range) := Msg; 7124 Res_Last : Natural := Msg'Last; 7125 J : Natural; 7126 7127 begin 7128 -- If we have a rewriting of another pragma, go to that pragma 7129 7130 if Is_Rewrite_Substitution (N) 7131 and then Nkind (Original_Node (N)) = N_Pragma 7132 then 7133 Error_Msg_Name_1 := Pragma_Name (Original_Node (N)); 7134 end if; 7135 7136 -- Case where pragma comes from an aspect specification 7137 7138 if From_Aspect_Specification (N) then 7139 7140 -- Change appearence of "pragma" in message to "aspect" 7141 7142 J := Res'First; 7143 while J <= Res_Last - 5 loop 7144 if Res (J .. J + 5) = "pragma" then 7145 Res (J .. J + 5) := "aspect"; 7146 J := J + 6; 7147 7148 else 7149 J := J + 1; 7150 end if; 7151 end loop; 7152 7153 -- Change "argument of" at start of message to "entity for" 7154 7155 if Res'Length > 11 7156 and then Res (Res'First .. Res'First + 10) = "argument of" 7157 then 7158 Res (Res'First .. Res'First + 9) := "entity for"; 7159 Res (Res'First + 10 .. Res_Last - 1) := 7160 Res (Res'First + 11 .. Res_Last); 7161 Res_Last := Res_Last - 1; 7162 end if; 7163 7164 -- Change "argument" at start of message to "entity" 7165 7166 if Res'Length > 8 7167 and then Res (Res'First .. Res'First + 7) = "argument" 7168 then 7169 Res (Res'First .. Res'First + 5) := "entity"; 7170 Res (Res'First + 6 .. Res_Last - 2) := 7171 Res (Res'First + 8 .. Res_Last); 7172 Res_Last := Res_Last - 2; 7173 end if; 7174 7175 -- Get name from corresponding aspect 7176 7177 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N); 7178 end if; 7179 7180 -- Return possibly modified message 7181 7182 return Res (Res'First .. Res_Last); 7183 end Fix_Error; 7184 7185 ------------------------- 7186 -- Gather_Associations -- 7187 ------------------------- 7188 7189 procedure Gather_Associations 7190 (Names : Name_List; 7191 Args : out Args_List) 7192 is 7193 Arg : Node_Id; 7194 7195 begin 7196 -- Initialize all parameters to Empty 7197 7198 for J in Args'Range loop 7199 Args (J) := Empty; 7200 end loop; 7201 7202 -- That's all we have to do if there are no argument associations 7203 7204 if No (Pragma_Argument_Associations (N)) then 7205 return; 7206 end if; 7207 7208 -- Otherwise first deal with any positional parameters present 7209 7210 Arg := First (Pragma_Argument_Associations (N)); 7211 for Index in Args'Range loop 7212 exit when No (Arg) or else Chars (Arg) /= No_Name; 7213 Args (Index) := Get_Pragma_Arg (Arg); 7214 Next (Arg); 7215 end loop; 7216 7217 -- Positional parameters all processed, if any left, then we 7218 -- have too many positional parameters. 7219 7220 if Present (Arg) and then Chars (Arg) = No_Name then 7221 Error_Pragma_Arg 7222 ("too many positional associations for pragma%", Arg); 7223 end if; 7224 7225 -- Process named parameters if any are present 7226 7227 while Present (Arg) loop 7228 if Chars (Arg) = No_Name then 7229 Error_Pragma_Arg 7230 ("positional association cannot follow named association", 7231 Arg); 7232 7233 else 7234 for Index in Names'Range loop 7235 if Names (Index) = Chars (Arg) then 7236 if Present (Args (Index)) then 7237 Error_Pragma_Arg 7238 ("duplicate argument association for pragma%", Arg); 7239 else 7240 Args (Index) := Get_Pragma_Arg (Arg); 7241 exit; 7242 end if; 7243 end if; 7244 7245 if Index = Names'Last then 7246 Error_Msg_Name_1 := Pname; 7247 Error_Msg_N ("pragma% does not allow & argument", Arg); 7248 7249 -- Check for possible misspelling 7250 7251 for Index1 in Names'Range loop 7252 if Is_Bad_Spelling_Of 7253 (Chars (Arg), Names (Index1)) 7254 then 7255 Error_Msg_Name_1 := Names (Index1); 7256 Error_Msg_N -- CODEFIX 7257 ("\possible misspelling of%", Arg); 7258 exit; 7259 end if; 7260 end loop; 7261 7262 raise Pragma_Exit; 7263 end if; 7264 end loop; 7265 end if; 7266 7267 Next (Arg); 7268 end loop; 7269 end Gather_Associations; 7270 7271 ----------------- 7272 -- GNAT_Pragma -- 7273 ----------------- 7274 7275 procedure GNAT_Pragma is 7276 begin 7277 -- We need to check the No_Implementation_Pragmas restriction for 7278 -- the case of a pragma from source. Note that the case of aspects 7279 -- generating corresponding pragmas marks these pragmas as not being 7280 -- from source, so this test also catches that case. 7281 7282 if Comes_From_Source (N) then 7283 Check_Restriction (No_Implementation_Pragmas, N); 7284 end if; 7285 end GNAT_Pragma; 7286 7287 -------------------------- 7288 -- Is_Before_First_Decl -- 7289 -------------------------- 7290 7291 function Is_Before_First_Decl 7292 (Pragma_Node : Node_Id; 7293 Decls : List_Id) return Boolean 7294 is 7295 Item : Node_Id := First (Decls); 7296 7297 begin 7298 -- Only other pragmas can come before this pragma, but they might 7299 -- have been rewritten so check the original node. 7300 7301 loop 7302 if No (Item) or else Nkind (Original_Node (Item)) /= N_Pragma then 7303 return False; 7304 7305 elsif Item = Pragma_Node then 7306 return True; 7307 end if; 7308 7309 Next (Item); 7310 end loop; 7311 end Is_Before_First_Decl; 7312 7313 ----------------------------- 7314 -- Is_Configuration_Pragma -- 7315 ----------------------------- 7316 7317 -- A configuration pragma must appear in the context clause of a 7318 -- compilation unit, and only other pragmas may precede it. Note that 7319 -- the test below also permits use in a configuration pragma file. 7320 7321 function Is_Configuration_Pragma return Boolean is 7322 Lis : constant List_Id := List_Containing (N); 7323 Par : constant Node_Id := Parent (N); 7324 Prg : Node_Id; 7325 7326 begin 7327 -- If no parent, then we are in the configuration pragma file, 7328 -- so the placement is definitely appropriate. 7329 7330 if No (Par) then 7331 return True; 7332 7333 -- Otherwise we must be in the context clause of a compilation unit 7334 -- and the only thing allowed before us in the context list is more 7335 -- configuration pragmas. 7336 7337 elsif Nkind (Par) = N_Compilation_Unit 7338 and then Context_Items (Par) = Lis 7339 then 7340 Prg := First (Lis); 7341 7342 loop 7343 if Prg = N then 7344 return True; 7345 elsif Nkind (Prg) /= N_Pragma then 7346 return False; 7347 end if; 7348 7349 Next (Prg); 7350 end loop; 7351 7352 else 7353 return False; 7354 end if; 7355 end Is_Configuration_Pragma; 7356 7357 -------------------------- 7358 -- Is_In_Context_Clause -- 7359 -------------------------- 7360 7361 function Is_In_Context_Clause return Boolean is 7362 Plist : List_Id; 7363 Parent_Node : Node_Id; 7364 7365 begin 7366 if not Is_List_Member (N) then 7367 return False; 7368 7369 else 7370 Plist := List_Containing (N); 7371 Parent_Node := Parent (Plist); 7372 7373 if Parent_Node = Empty 7374 or else Nkind (Parent_Node) /= N_Compilation_Unit 7375 or else Context_Items (Parent_Node) /= Plist 7376 then 7377 return False; 7378 end if; 7379 end if; 7380 7381 return True; 7382 end Is_In_Context_Clause; 7383 7384 --------------------------------- 7385 -- Is_Static_String_Expression -- 7386 --------------------------------- 7387 7388 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is 7389 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 7390 Lit : constant Boolean := Nkind (Argx) = N_String_Literal; 7391 7392 begin 7393 Analyze_And_Resolve (Argx); 7394 7395 -- Special case Ada 83, where the expression will never be static, 7396 -- but we will return true if we had a string literal to start with. 7397 7398 if Ada_Version = Ada_83 then 7399 return Lit; 7400 7401 -- Normal case, true only if we end up with a string literal that 7402 -- is marked as being the result of evaluating a static expression. 7403 7404 else 7405 return Is_OK_Static_Expression (Argx) 7406 and then Nkind (Argx) = N_String_Literal; 7407 end if; 7408 7409 end Is_Static_String_Expression; 7410 7411 ---------------------- 7412 -- Pragma_Misplaced -- 7413 ---------------------- 7414 7415 procedure Pragma_Misplaced is 7416 begin 7417 Error_Pragma ("incorrect placement of pragma%"); 7418 end Pragma_Misplaced; 7419 7420 ------------------------------------------------ 7421 -- Process_Atomic_Independent_Shared_Volatile -- 7422 ------------------------------------------------ 7423 7424 procedure Process_Atomic_Independent_Shared_Volatile is 7425 procedure Check_VFA_Conflicts (Ent : Entity_Id); 7426 -- Check that Volatile_Full_Access and VFA do not conflict 7427 7428 procedure Mark_Component_Or_Object (Ent : Entity_Id); 7429 -- Appropriately set flags on the given entity, either an array or 7430 -- record component, or an object declaration) according to the 7431 -- current pragma. 7432 7433 procedure Mark_Type (Ent : Entity_Id); 7434 -- Appropriately set flags on the given entity, a type 7435 7436 procedure Set_Atomic_VFA (Ent : Entity_Id); 7437 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if 7438 -- no explicit alignment was given, set alignment to unknown, since 7439 -- back end knows what the alignment requirements are for atomic and 7440 -- full access arrays. Note: this is necessary for derived types. 7441 7442 ------------------------- 7443 -- Check_VFA_Conflicts -- 7444 ------------------------- 7445 7446 procedure Check_VFA_Conflicts (Ent : Entity_Id) is 7447 Comp : Entity_Id; 7448 Typ : Entity_Id; 7449 7450 VFA_And_Atomic : Boolean := False; 7451 -- Set True if both VFA and Atomic present 7452 7453 begin 7454 -- Fetch the type in case we are dealing with an object or 7455 -- component. 7456 7457 if Is_Type (Ent) then 7458 Typ := Ent; 7459 else 7460 pragma Assert (Is_Object (Ent) 7461 or else 7462 Nkind (Declaration_Node (Ent)) = N_Component_Declaration); 7463 7464 Typ := Etype (Ent); 7465 end if; 7466 7467 -- Check Atomic and VFA used together 7468 7469 if Prag_Id = Pragma_Volatile_Full_Access 7470 or else Is_Volatile_Full_Access (Ent) 7471 then 7472 if Prag_Id = Pragma_Atomic 7473 or else Prag_Id = Pragma_Shared 7474 or else Is_Atomic (Ent) 7475 then 7476 VFA_And_Atomic := True; 7477 7478 elsif Is_Array_Type (Typ) then 7479 VFA_And_Atomic := Has_Atomic_Components (Typ); 7480 7481 -- Note: Has_Atomic_Components is not used below, as this flag 7482 -- represents the pragma of the same name, Atomic_Components, 7483 -- which only applies to arrays. 7484 7485 elsif Is_Record_Type (Typ) then 7486 -- Attributes cannot be applied to discriminants, only 7487 -- regular record components. 7488 7489 Comp := First_Component (Typ); 7490 while Present (Comp) loop 7491 if Is_Atomic (Comp) 7492 or else Is_Atomic (Typ) 7493 then 7494 VFA_And_Atomic := True; 7495 7496 exit; 7497 end if; 7498 7499 Next_Component (Comp); 7500 end loop; 7501 end if; 7502 7503 if VFA_And_Atomic then 7504 Error_Pragma 7505 ("cannot have Volatile_Full_Access and Atomic for same " 7506 & "entity"); 7507 end if; 7508 end if; 7509 end Check_VFA_Conflicts; 7510 7511 ------------------------------ 7512 -- Mark_Component_Or_Object -- 7513 ------------------------------ 7514 7515 procedure Mark_Component_Or_Object (Ent : Entity_Id) is 7516 begin 7517 if Prag_Id = Pragma_Atomic 7518 or else Prag_Id = Pragma_Shared 7519 or else Prag_Id = Pragma_Volatile_Full_Access 7520 then 7521 if Prag_Id = Pragma_Volatile_Full_Access then 7522 Set_Is_Volatile_Full_Access (Ent); 7523 else 7524 Set_Is_Atomic (Ent); 7525 end if; 7526 7527 -- If the object declaration has an explicit initialization, a 7528 -- temporary may have to be created to hold the expression, to 7529 -- ensure that access to the object remains atomic. 7530 7531 if Nkind (Parent (Ent)) = N_Object_Declaration 7532 and then Present (Expression (Parent (Ent))) 7533 then 7534 Set_Has_Delayed_Freeze (Ent); 7535 end if; 7536 end if; 7537 7538 -- Atomic/Shared/Volatile_Full_Access imply Independent 7539 7540 if Prag_Id /= Pragma_Volatile then 7541 Set_Is_Independent (Ent); 7542 7543 if Prag_Id = Pragma_Independent then 7544 Record_Independence_Check (N, Ent); 7545 end if; 7546 end if; 7547 7548 -- Atomic/Shared/Volatile_Full_Access imply Volatile 7549 7550 if Prag_Id /= Pragma_Independent then 7551 Set_Is_Volatile (Ent); 7552 Set_Treat_As_Volatile (Ent); 7553 end if; 7554 end Mark_Component_Or_Object; 7555 7556 --------------- 7557 -- Mark_Type -- 7558 --------------- 7559 7560 procedure Mark_Type (Ent : Entity_Id) is 7561 begin 7562 -- Attribute belongs on the base type. If the view of the type is 7563 -- currently private, it also belongs on the underlying type. 7564 7565 -- In Ada_2020, the pragma can apply to a formal type, for which 7566 -- there may be no underlying type. 7567 7568 if Prag_Id = Pragma_Atomic 7569 or else Prag_Id = Pragma_Shared 7570 or else Prag_Id = Pragma_Volatile_Full_Access 7571 then 7572 Set_Atomic_VFA (Ent); 7573 Set_Atomic_VFA (Base_Type (Ent)); 7574 7575 if not Is_Generic_Type (Ent) then 7576 Set_Atomic_VFA (Underlying_Type (Ent)); 7577 end if; 7578 end if; 7579 7580 -- Atomic/Shared/Volatile_Full_Access imply Independent 7581 7582 if Prag_Id /= Pragma_Volatile then 7583 Set_Is_Independent (Ent); 7584 Set_Is_Independent (Base_Type (Ent)); 7585 7586 if not Is_Generic_Type (Ent) then 7587 Set_Is_Independent (Underlying_Type (Ent)); 7588 7589 if Prag_Id = Pragma_Independent then 7590 Record_Independence_Check (N, Base_Type (Ent)); 7591 end if; 7592 end if; 7593 end if; 7594 7595 -- Atomic/Shared/Volatile_Full_Access imply Volatile 7596 7597 if Prag_Id /= Pragma_Independent then 7598 Set_Is_Volatile (Ent); 7599 Set_Is_Volatile (Base_Type (Ent)); 7600 7601 if not Is_Generic_Type (Ent) then 7602 Set_Is_Volatile (Underlying_Type (Ent)); 7603 Set_Treat_As_Volatile (Underlying_Type (Ent)); 7604 end if; 7605 7606 Set_Treat_As_Volatile (Ent); 7607 end if; 7608 7609 -- Apply Volatile to the composite type's individual components, 7610 -- (RM C.6(8/3)). 7611 7612 if Prag_Id = Pragma_Volatile 7613 and then Is_Record_Type (Etype (Ent)) 7614 then 7615 declare 7616 Comp : Entity_Id; 7617 begin 7618 Comp := First_Component (Ent); 7619 while Present (Comp) loop 7620 Mark_Component_Or_Object (Comp); 7621 7622 Next_Component (Comp); 7623 end loop; 7624 end; 7625 end if; 7626 end Mark_Type; 7627 7628 -------------------- 7629 -- Set_Atomic_VFA -- 7630 -------------------- 7631 7632 procedure Set_Atomic_VFA (Ent : Entity_Id) is 7633 begin 7634 if Prag_Id = Pragma_Volatile_Full_Access then 7635 Set_Is_Volatile_Full_Access (Ent); 7636 else 7637 Set_Is_Atomic (Ent); 7638 end if; 7639 7640 if not Has_Alignment_Clause (Ent) then 7641 Set_Alignment (Ent, Uint_0); 7642 end if; 7643 end Set_Atomic_VFA; 7644 7645 -- Local variables 7646 7647 Decl : Node_Id; 7648 E : Entity_Id; 7649 E_Arg : Node_Id; 7650 7651 -- Start of processing for Process_Atomic_Independent_Shared_Volatile 7652 7653 begin 7654 Check_Ada_83_Warning; 7655 Check_No_Identifiers; 7656 Check_Arg_Count (1); 7657 Check_Arg_Is_Local_Name (Arg1); 7658 E_Arg := Get_Pragma_Arg (Arg1); 7659 7660 if Etype (E_Arg) = Any_Type then 7661 return; 7662 end if; 7663 7664 E := Entity (E_Arg); 7665 7666 -- A pragma that applies to a Ghost entity becomes Ghost for the 7667 -- purposes of legality checks and removal of ignored Ghost code. 7668 7669 Mark_Ghost_Pragma (N, E); 7670 7671 -- Check duplicate before we chain ourselves 7672 7673 Check_Duplicate_Pragma (E); 7674 7675 -- Check appropriateness of the entity 7676 7677 Decl := Declaration_Node (E); 7678 7679 -- Deal with the case where the pragma/attribute is applied to a type 7680 7681 if Is_Type (E) then 7682 if Rep_Item_Too_Early (E, N) 7683 or else Rep_Item_Too_Late (E, N) 7684 then 7685 return; 7686 else 7687 Check_First_Subtype (Arg1); 7688 end if; 7689 7690 Mark_Type (E); 7691 7692 -- Deal with the case where the pragma/attribute applies to a 7693 -- component or object declaration. 7694 7695 elsif Nkind (Decl) = N_Object_Declaration 7696 or else (Nkind (Decl) = N_Component_Declaration 7697 and then Original_Record_Component (E) = E) 7698 then 7699 if Rep_Item_Too_Late (E, N) then 7700 return; 7701 end if; 7702 7703 Mark_Component_Or_Object (E); 7704 7705 -- In other cases give an error 7706 7707 else 7708 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 7709 end if; 7710 7711 -- Check that Volatile_Full_Access and Atomic do not conflict 7712 7713 Check_VFA_Conflicts (E); 7714 7715 -- Check for the application of Atomic or Volatile_Full_Access to 7716 -- an entity that has [nonatomic] aliased, or else specified to be 7717 -- independently addressable, subcomponents. 7718 7719 if (Prag_Id = Pragma_Atomic and then Ada_Version >= Ada_2020) 7720 or else Prag_Id = Pragma_Volatile_Full_Access 7721 then 7722 Check_Atomic_VFA (E, VFA => Prag_Id = Pragma_Volatile_Full_Access); 7723 end if; 7724 7725 -- The following check is only relevant when SPARK_Mode is on as 7726 -- this is not a standard Ada legality rule. Pragma Volatile can 7727 -- only apply to a full type declaration or an object declaration 7728 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for 7729 -- untagged derived types that are rewritten as subtypes of their 7730 -- respective root types. 7731 7732 if SPARK_Mode = On 7733 and then Prag_Id = Pragma_Volatile 7734 and then not Nkind_In (Original_Node (Decl), 7735 N_Full_Type_Declaration, 7736 N_Object_Declaration, 7737 N_Single_Protected_Declaration, 7738 N_Single_Task_Declaration) 7739 then 7740 Error_Pragma_Arg 7741 ("argument of pragma % must denote a full type or object " 7742 & "declaration", Arg1); 7743 end if; 7744 end Process_Atomic_Independent_Shared_Volatile; 7745 7746 ------------------------------------------- 7747 -- Process_Compile_Time_Warning_Or_Error -- 7748 ------------------------------------------- 7749 7750 procedure Process_Compile_Time_Warning_Or_Error is 7751 P : Node_Id := Parent (N); 7752 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 7753 begin 7754 -- In GNATprove mode, pragmas Compile_Time_Error and 7755 -- Compile_Time_Warning are ignored, as the analyzer may not have the 7756 -- same information as the compiler (in particular regarding size of 7757 -- objects decided in gigi) so it makes no sense to issue an error or 7758 -- warning in GNATprove. 7759 7760 if GNATprove_Mode then 7761 Rewrite (N, Make_Null_Statement (Loc)); 7762 return; 7763 end if; 7764 7765 Check_Arg_Count (2); 7766 Check_No_Identifiers; 7767 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 7768 Analyze_And_Resolve (Arg1x, Standard_Boolean); 7769 7770 -- If the condition is known at compile time (now), validate it now. 7771 -- Otherwise, register the expression for validation after the back 7772 -- end has been called, because it might be known at compile time 7773 -- then. For example, if the expression is "Record_Type'Size /= 32" 7774 -- it might be known after the back end has determined the size of 7775 -- Record_Type. We do not defer validation if we're inside a generic 7776 -- unit, because we will have more information in the instances. 7777 7778 if Compile_Time_Known_Value (Arg1x) then 7779 Validate_Compile_Time_Warning_Or_Error (N, Sloc (Arg1)); 7780 else 7781 while Present (P) and then Nkind (P) not in N_Generic_Declaration 7782 loop 7783 if Nkind_In (P, N_Package_Body, N_Subprogram_Body) then 7784 P := Corresponding_Spec (P); 7785 else 7786 P := Parent (P); 7787 end if; 7788 end loop; 7789 7790 if No (P) then 7791 Defer_Compile_Time_Warning_Error_To_BE (N); 7792 end if; 7793 end if; 7794 end Process_Compile_Time_Warning_Or_Error; 7795 7796 ------------------------ 7797 -- Process_Convention -- 7798 ------------------------ 7799 7800 procedure Process_Convention 7801 (C : out Convention_Id; 7802 Ent : out Entity_Id) 7803 is 7804 Cname : Name_Id; 7805 7806 procedure Diagnose_Multiple_Pragmas (S : Entity_Id); 7807 -- Called if we have more than one Export/Import/Convention pragma. 7808 -- This is generally illegal, but we have a special case of allowing 7809 -- Import and Interface to coexist if they specify the convention in 7810 -- a consistent manner. We are allowed to do this, since Interface is 7811 -- an implementation defined pragma, and we choose to do it since we 7812 -- know Rational allows this combination. S is the entity id of the 7813 -- subprogram in question. This procedure also sets the special flag 7814 -- Import_Interface_Present in both pragmas in the case where we do 7815 -- have matching Import and Interface pragmas. 7816 7817 procedure Set_Convention_From_Pragma (E : Entity_Id); 7818 -- Set convention in entity E, and also flag that the entity has a 7819 -- convention pragma. If entity is for a private or incomplete type, 7820 -- also set convention and flag on underlying type. This procedure 7821 -- also deals with the special case of C_Pass_By_Copy convention, 7822 -- and error checks for inappropriate convention specification. 7823 7824 ------------------------------- 7825 -- Diagnose_Multiple_Pragmas -- 7826 ------------------------------- 7827 7828 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is 7829 Pdec : constant Node_Id := Declaration_Node (S); 7830 Decl : Node_Id; 7831 Err : Boolean; 7832 7833 function Same_Convention (Decl : Node_Id) return Boolean; 7834 -- Decl is a pragma node. This function returns True if this 7835 -- pragma has a first argument that is an identifier with a 7836 -- Chars field corresponding to the Convention_Id C. 7837 7838 function Same_Name (Decl : Node_Id) return Boolean; 7839 -- Decl is a pragma node. This function returns True if this 7840 -- pragma has a second argument that is an identifier with a 7841 -- Chars field that matches the Chars of the current subprogram. 7842 7843 --------------------- 7844 -- Same_Convention -- 7845 --------------------- 7846 7847 function Same_Convention (Decl : Node_Id) return Boolean is 7848 Arg1 : constant Node_Id := 7849 First (Pragma_Argument_Associations (Decl)); 7850 7851 begin 7852 if Present (Arg1) then 7853 declare 7854 Arg : constant Node_Id := Get_Pragma_Arg (Arg1); 7855 begin 7856 if Nkind (Arg) = N_Identifier 7857 and then Is_Convention_Name (Chars (Arg)) 7858 and then Get_Convention_Id (Chars (Arg)) = C 7859 then 7860 return True; 7861 end if; 7862 end; 7863 end if; 7864 7865 return False; 7866 end Same_Convention; 7867 7868 --------------- 7869 -- Same_Name -- 7870 --------------- 7871 7872 function Same_Name (Decl : Node_Id) return Boolean is 7873 Arg1 : constant Node_Id := 7874 First (Pragma_Argument_Associations (Decl)); 7875 Arg2 : Node_Id; 7876 7877 begin 7878 if No (Arg1) then 7879 return False; 7880 end if; 7881 7882 Arg2 := Next (Arg1); 7883 7884 if No (Arg2) then 7885 return False; 7886 end if; 7887 7888 declare 7889 Arg : constant Node_Id := Get_Pragma_Arg (Arg2); 7890 begin 7891 if Nkind (Arg) = N_Identifier 7892 and then Chars (Arg) = Chars (S) 7893 then 7894 return True; 7895 end if; 7896 end; 7897 7898 return False; 7899 end Same_Name; 7900 7901 -- Start of processing for Diagnose_Multiple_Pragmas 7902 7903 begin 7904 Err := True; 7905 7906 -- Definitely give message if we have Convention/Export here 7907 7908 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then 7909 null; 7910 7911 -- If we have an Import or Export, scan back from pragma to 7912 -- find any previous pragma applying to the same procedure. 7913 -- The scan will be terminated by the start of the list, or 7914 -- hitting the subprogram declaration. This won't allow one 7915 -- pragma to appear in the public part and one in the private 7916 -- part, but that seems very unlikely in practice. 7917 7918 else 7919 Decl := Prev (N); 7920 while Present (Decl) and then Decl /= Pdec loop 7921 7922 -- Look for pragma with same name as us 7923 7924 if Nkind (Decl) = N_Pragma 7925 and then Same_Name (Decl) 7926 then 7927 -- Give error if same as our pragma or Export/Convention 7928 7929 if Nam_In (Pragma_Name_Unmapped (Decl), 7930 Name_Export, 7931 Name_Convention, 7932 Pragma_Name_Unmapped (N)) 7933 then 7934 exit; 7935 7936 -- Case of Import/Interface or the other way round 7937 7938 elsif Nam_In (Pragma_Name_Unmapped (Decl), 7939 Name_Interface, Name_Import) 7940 then 7941 -- Here we know that we have Import and Interface. It 7942 -- doesn't matter which way round they are. See if 7943 -- they specify the same convention. If so, all OK, 7944 -- and set special flags to stop other messages 7945 7946 if Same_Convention (Decl) then 7947 Set_Import_Interface_Present (N); 7948 Set_Import_Interface_Present (Decl); 7949 Err := False; 7950 7951 -- If different conventions, special message 7952 7953 else 7954 Error_Msg_Sloc := Sloc (Decl); 7955 Error_Pragma_Arg 7956 ("convention differs from that given#", Arg1); 7957 return; 7958 end if; 7959 end if; 7960 end if; 7961 7962 Next (Decl); 7963 end loop; 7964 end if; 7965 7966 -- Give message if needed if we fall through those tests 7967 -- except on Relaxed_RM_Semantics where we let go: either this 7968 -- is a case accepted/ignored by other Ada compilers (e.g. 7969 -- a mix of Convention and Import), or another error will be 7970 -- generated later (e.g. using both Import and Export). 7971 7972 if Err and not Relaxed_RM_Semantics then 7973 Error_Pragma_Arg 7974 ("at most one Convention/Export/Import pragma is allowed", 7975 Arg2); 7976 end if; 7977 end Diagnose_Multiple_Pragmas; 7978 7979 -------------------------------- 7980 -- Set_Convention_From_Pragma -- 7981 -------------------------------- 7982 7983 procedure Set_Convention_From_Pragma (E : Entity_Id) is 7984 begin 7985 -- Ada 2005 (AI-430): Check invalid attempt to change convention 7986 -- for an overridden dispatching operation. Technically this is 7987 -- an amendment and should only be done in Ada 2005 mode. However, 7988 -- this is clearly a mistake, since the problem that is addressed 7989 -- by this AI is that there is a clear gap in the RM. 7990 7991 if Is_Dispatching_Operation (E) 7992 and then Present (Overridden_Operation (E)) 7993 and then C /= Convention (Overridden_Operation (E)) 7994 then 7995 Error_Pragma_Arg 7996 ("cannot change convention for overridden dispatching " 7997 & "operation", Arg1); 7998 end if; 7999 8000 -- Special checks for Convention_Stdcall 8001 8002 if C = Convention_Stdcall then 8003 8004 -- A dispatching call is not allowed. A dispatching subprogram 8005 -- cannot be used to interface to the Win32 API, so in fact 8006 -- this check does not impose any effective restriction. 8007 8008 if Is_Dispatching_Operation (E) then 8009 Error_Msg_Sloc := Sloc (E); 8010 8011 -- Note: make this unconditional so that if there is more 8012 -- than one call to which the pragma applies, we get a 8013 -- message for each call. Also don't use Error_Pragma, 8014 -- so that we get multiple messages. 8015 8016 Error_Msg_N 8017 ("dispatching subprogram# cannot use Stdcall convention!", 8018 Arg1); 8019 8020 -- Several allowed cases 8021 8022 elsif Is_Subprogram_Or_Generic_Subprogram (E) 8023 8024 -- A variable is OK 8025 8026 or else Ekind (E) = E_Variable 8027 8028 -- A component as well. The entity does not have its Ekind 8029 -- set until the enclosing record declaration is fully 8030 -- analyzed. 8031 8032 or else Nkind (Parent (E)) = N_Component_Declaration 8033 8034 -- An access to subprogram is also allowed 8035 8036 or else 8037 (Is_Access_Type (E) 8038 and then Ekind (Designated_Type (E)) = E_Subprogram_Type) 8039 8040 -- Allow internal call to set convention of subprogram type 8041 8042 or else Ekind (E) = E_Subprogram_Type 8043 then 8044 null; 8045 8046 else 8047 Error_Pragma_Arg 8048 ("second argument of pragma% must be subprogram (type)", 8049 Arg2); 8050 end if; 8051 end if; 8052 8053 -- Set the convention 8054 8055 Set_Convention (E, C); 8056 Set_Has_Convention_Pragma (E); 8057 8058 -- For the case of a record base type, also set the convention of 8059 -- any anonymous access types declared in the record which do not 8060 -- currently have a specified convention. 8061 8062 if Is_Record_Type (E) and then Is_Base_Type (E) then 8063 declare 8064 Comp : Node_Id; 8065 8066 begin 8067 Comp := First_Component (E); 8068 while Present (Comp) loop 8069 if Present (Etype (Comp)) 8070 and then Ekind_In (Etype (Comp), 8071 E_Anonymous_Access_Type, 8072 E_Anonymous_Access_Subprogram_Type) 8073 and then not Has_Convention_Pragma (Comp) 8074 then 8075 Set_Convention (Comp, C); 8076 end if; 8077 8078 Next_Component (Comp); 8079 end loop; 8080 end; 8081 end if; 8082 8083 -- Deal with incomplete/private type case, where underlying type 8084 -- is available, so set convention of that underlying type. 8085 8086 if Is_Incomplete_Or_Private_Type (E) 8087 and then Present (Underlying_Type (E)) 8088 then 8089 Set_Convention (Underlying_Type (E), C); 8090 Set_Has_Convention_Pragma (Underlying_Type (E), True); 8091 end if; 8092 8093 -- A class-wide type should inherit the convention of the specific 8094 -- root type (although this isn't specified clearly by the RM). 8095 8096 if Is_Type (E) and then Present (Class_Wide_Type (E)) then 8097 Set_Convention (Class_Wide_Type (E), C); 8098 end if; 8099 8100 -- If the entity is a record type, then check for special case of 8101 -- C_Pass_By_Copy, which is treated the same as C except that the 8102 -- special record flag is set. This convention is only permitted 8103 -- on record types (see AI95-00131). 8104 8105 if Cname = Name_C_Pass_By_Copy then 8106 if Is_Record_Type (E) then 8107 Set_C_Pass_By_Copy (Base_Type (E)); 8108 elsif Is_Incomplete_Or_Private_Type (E) 8109 and then Is_Record_Type (Underlying_Type (E)) 8110 then 8111 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); 8112 else 8113 Error_Pragma_Arg 8114 ("C_Pass_By_Copy convention allowed only for record type", 8115 Arg2); 8116 end if; 8117 end if; 8118 8119 -- If the entity is a derived boolean type, check for the special 8120 -- case of convention C, C++, or Fortran, where we consider any 8121 -- nonzero value to represent true. 8122 8123 if Is_Discrete_Type (E) 8124 and then Root_Type (Etype (E)) = Standard_Boolean 8125 and then 8126 (C = Convention_C 8127 or else 8128 C = Convention_CPP 8129 or else 8130 C = Convention_Fortran) 8131 then 8132 Set_Nonzero_Is_True (Base_Type (E)); 8133 end if; 8134 end Set_Convention_From_Pragma; 8135 8136 -- Local variables 8137 8138 Comp_Unit : Unit_Number_Type; 8139 E : Entity_Id; 8140 E1 : Entity_Id; 8141 Id : Node_Id; 8142 8143 -- Start of processing for Process_Convention 8144 8145 begin 8146 Check_At_Least_N_Arguments (2); 8147 Check_Optional_Identifier (Arg1, Name_Convention); 8148 Check_Arg_Is_Identifier (Arg1); 8149 Cname := Chars (Get_Pragma_Arg (Arg1)); 8150 8151 -- C_Pass_By_Copy is treated as a synonym for convention C (this is 8152 -- tested again below to set the critical flag). 8153 8154 if Cname = Name_C_Pass_By_Copy then 8155 C := Convention_C; 8156 8157 -- Otherwise we must have something in the standard convention list 8158 8159 elsif Is_Convention_Name (Cname) then 8160 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); 8161 8162 -- Otherwise warn on unrecognized convention 8163 8164 else 8165 if Warn_On_Export_Import then 8166 Error_Msg_N 8167 ("??unrecognized convention name, C assumed", 8168 Get_Pragma_Arg (Arg1)); 8169 end if; 8170 8171 C := Convention_C; 8172 end if; 8173 8174 Check_Optional_Identifier (Arg2, Name_Entity); 8175 Check_Arg_Is_Local_Name (Arg2); 8176 8177 Id := Get_Pragma_Arg (Arg2); 8178 Analyze (Id); 8179 8180 if not Is_Entity_Name (Id) then 8181 Error_Pragma_Arg ("entity name required", Arg2); 8182 end if; 8183 8184 E := Entity (Id); 8185 8186 -- Set entity to return 8187 8188 Ent := E; 8189 8190 -- Ada_Pass_By_Copy special checking 8191 8192 if C = Convention_Ada_Pass_By_Copy then 8193 if not Is_First_Subtype (E) then 8194 Error_Pragma_Arg 8195 ("convention `Ada_Pass_By_Copy` only allowed for types", 8196 Arg2); 8197 end if; 8198 8199 if Is_By_Reference_Type (E) then 8200 Error_Pragma_Arg 8201 ("convention `Ada_Pass_By_Copy` not allowed for by-reference " 8202 & "type", Arg1); 8203 end if; 8204 8205 -- Ada_Pass_By_Reference special checking 8206 8207 elsif C = Convention_Ada_Pass_By_Reference then 8208 if not Is_First_Subtype (E) then 8209 Error_Pragma_Arg 8210 ("convention `Ada_Pass_By_Reference` only allowed for types", 8211 Arg2); 8212 end if; 8213 8214 if Is_By_Copy_Type (E) then 8215 Error_Pragma_Arg 8216 ("convention `Ada_Pass_By_Reference` not allowed for by-copy " 8217 & "type", Arg1); 8218 end if; 8219 end if; 8220 8221 -- Go to renamed subprogram if present, since convention applies to 8222 -- the actual renamed entity, not to the renaming entity. If the 8223 -- subprogram is inherited, go to parent subprogram. 8224 8225 if Is_Subprogram (E) 8226 and then Present (Alias (E)) 8227 then 8228 if Nkind (Parent (Declaration_Node (E))) = 8229 N_Subprogram_Renaming_Declaration 8230 then 8231 if Scope (E) /= Scope (Alias (E)) then 8232 Error_Pragma_Ref 8233 ("cannot apply pragma% to non-local entity&#", E); 8234 end if; 8235 8236 E := Alias (E); 8237 8238 elsif Nkind_In (Parent (E), N_Full_Type_Declaration, 8239 N_Private_Extension_Declaration) 8240 and then Scope (E) = Scope (Alias (E)) 8241 then 8242 E := Alias (E); 8243 8244 -- Return the parent subprogram the entity was inherited from 8245 8246 Ent := E; 8247 end if; 8248 end if; 8249 8250 -- Check that we are not applying this to a specless body. Relax this 8251 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers. 8252 8253 if Is_Subprogram (E) 8254 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body 8255 and then not Relaxed_RM_Semantics 8256 then 8257 Error_Pragma 8258 ("pragma% requires separate spec and must come before body"); 8259 end if; 8260 8261 -- Check that we are not applying this to a named constant 8262 8263 if Ekind_In (E, E_Named_Integer, E_Named_Real) then 8264 Error_Msg_Name_1 := Pname; 8265 Error_Msg_N 8266 ("cannot apply pragma% to named constant!", 8267 Get_Pragma_Arg (Arg2)); 8268 Error_Pragma_Arg 8269 ("\supply appropriate type for&!", Arg2); 8270 end if; 8271 8272 if Ekind (E) = E_Enumeration_Literal then 8273 Error_Pragma ("enumeration literal not allowed for pragma%"); 8274 end if; 8275 8276 -- Check for rep item appearing too early or too late 8277 8278 if Etype (E) = Any_Type 8279 or else Rep_Item_Too_Early (E, N) 8280 then 8281 raise Pragma_Exit; 8282 8283 elsif Present (Underlying_Type (E)) then 8284 E := Underlying_Type (E); 8285 end if; 8286 8287 if Rep_Item_Too_Late (E, N) then 8288 raise Pragma_Exit; 8289 end if; 8290 8291 if Has_Convention_Pragma (E) then 8292 Diagnose_Multiple_Pragmas (E); 8293 8294 elsif Convention (E) = Convention_Protected 8295 or else Ekind (Scope (E)) = E_Protected_Type 8296 then 8297 Error_Pragma_Arg 8298 ("a protected operation cannot be given a different convention", 8299 Arg2); 8300 end if; 8301 8302 -- For Intrinsic, a subprogram is required 8303 8304 if C = Convention_Intrinsic 8305 and then not Is_Subprogram_Or_Generic_Subprogram (E) 8306 then 8307 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics 8308 8309 if not (Is_Type (E) and then Relaxed_RM_Semantics) then 8310 Error_Pragma_Arg 8311 ("second argument of pragma% must be a subprogram", Arg2); 8312 end if; 8313 end if; 8314 8315 -- Deal with non-subprogram cases 8316 8317 if not Is_Subprogram_Or_Generic_Subprogram (E) then 8318 Set_Convention_From_Pragma (E); 8319 8320 if Is_Type (E) then 8321 8322 -- The pragma must apply to a first subtype, but it can also 8323 -- apply to a generic type in a generic formal part, in which 8324 -- case it will also appear in the corresponding instance. 8325 8326 if Is_Generic_Type (E) or else In_Instance then 8327 null; 8328 else 8329 Check_First_Subtype (Arg2); 8330 end if; 8331 8332 Set_Convention_From_Pragma (Base_Type (E)); 8333 8334 -- For access subprograms, we must set the convention on the 8335 -- internally generated directly designated type as well. 8336 8337 if Ekind (E) = E_Access_Subprogram_Type then 8338 Set_Convention_From_Pragma (Directly_Designated_Type (E)); 8339 end if; 8340 end if; 8341 8342 -- For the subprogram case, set proper convention for all homonyms 8343 -- in same scope and the same declarative part, i.e. the same 8344 -- compilation unit. 8345 8346 else 8347 Comp_Unit := Get_Source_Unit (E); 8348 Set_Convention_From_Pragma (E); 8349 8350 -- Treat a pragma Import as an implicit body, and pragma import 8351 -- as implicit reference (for navigation in GNAT Studio). 8352 8353 if Prag_Id = Pragma_Import then 8354 Generate_Reference (E, Id, 'b'); 8355 8356 -- For exported entities we restrict the generation of references 8357 -- to entities exported to foreign languages since entities 8358 -- exported to Ada do not provide further information to 8359 -- GNAT Studio and add undesired references to the output of the 8360 -- gnatxref tool. 8361 8362 elsif Prag_Id = Pragma_Export 8363 and then Convention (E) /= Convention_Ada 8364 then 8365 Generate_Reference (E, Id, 'i'); 8366 end if; 8367 8368 -- If the pragma comes from an aspect, it only applies to the 8369 -- given entity, not its homonyms. 8370 8371 if From_Aspect_Specification (N) then 8372 if C = Convention_Intrinsic 8373 and then Nkind (Ent) = N_Defining_Operator_Symbol 8374 then 8375 if Is_Fixed_Point_Type (Etype (Ent)) 8376 or else Is_Fixed_Point_Type (Etype (First_Entity (Ent))) 8377 or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent))) 8378 then 8379 Error_Msg_N 8380 ("no intrinsic operator available for this fixed-point " 8381 & "operation", N); 8382 Error_Msg_N 8383 ("\use expression functions with the desired " 8384 & "conversions made explicit", N); 8385 end if; 8386 end if; 8387 8388 return; 8389 end if; 8390 8391 -- Otherwise Loop through the homonyms of the pragma argument's 8392 -- entity, an apply convention to those in the current scope. 8393 8394 E1 := Ent; 8395 8396 loop 8397 E1 := Homonym (E1); 8398 exit when No (E1) or else Scope (E1) /= Current_Scope; 8399 8400 -- Ignore entry for which convention is already set 8401 8402 if Has_Convention_Pragma (E1) then 8403 goto Continue; 8404 end if; 8405 8406 if Is_Subprogram (E1) 8407 and then Nkind (Parent (Declaration_Node (E1))) = 8408 N_Subprogram_Body 8409 and then not Relaxed_RM_Semantics 8410 then 8411 Set_Has_Completion (E); -- to prevent cascaded error 8412 Error_Pragma_Ref 8413 ("pragma% requires separate spec and must come before " 8414 & "body#", E1); 8415 end if; 8416 8417 -- Do not set the pragma on inherited operations or on formal 8418 -- subprograms. 8419 8420 if Comes_From_Source (E1) 8421 and then Comp_Unit = Get_Source_Unit (E1) 8422 and then not Is_Formal_Subprogram (E1) 8423 and then Nkind (Original_Node (Parent (E1))) /= 8424 N_Full_Type_Declaration 8425 then 8426 if Present (Alias (E1)) 8427 and then Scope (E1) /= Scope (Alias (E1)) 8428 then 8429 Error_Pragma_Ref 8430 ("cannot apply pragma% to non-local entity& declared#", 8431 E1); 8432 end if; 8433 8434 Set_Convention_From_Pragma (E1); 8435 8436 if Prag_Id = Pragma_Import then 8437 Generate_Reference (E1, Id, 'b'); 8438 end if; 8439 end if; 8440 8441 <<Continue>> 8442 null; 8443 end loop; 8444 end if; 8445 end Process_Convention; 8446 8447 ---------------------------------------- 8448 -- Process_Disable_Enable_Atomic_Sync -- 8449 ---------------------------------------- 8450 8451 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is 8452 begin 8453 Check_No_Identifiers; 8454 Check_At_Most_N_Arguments (1); 8455 8456 -- Modeled internally as 8457 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity]) 8458 8459 Rewrite (N, 8460 Make_Pragma (Loc, 8461 Chars => Nam, 8462 Pragma_Argument_Associations => New_List ( 8463 Make_Pragma_Argument_Association (Loc, 8464 Expression => 8465 Make_Identifier (Loc, Name_Atomic_Synchronization))))); 8466 8467 if Present (Arg1) then 8468 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); 8469 end if; 8470 8471 Analyze (N); 8472 end Process_Disable_Enable_Atomic_Sync; 8473 8474 ------------------------------------------------- 8475 -- Process_Extended_Import_Export_Internal_Arg -- 8476 ------------------------------------------------- 8477 8478 procedure Process_Extended_Import_Export_Internal_Arg 8479 (Arg_Internal : Node_Id := Empty) 8480 is 8481 begin 8482 if No (Arg_Internal) then 8483 Error_Pragma ("Internal parameter required for pragma%"); 8484 end if; 8485 8486 if Nkind (Arg_Internal) = N_Identifier then 8487 null; 8488 8489 elsif Nkind (Arg_Internal) = N_Operator_Symbol 8490 and then (Prag_Id = Pragma_Import_Function 8491 or else 8492 Prag_Id = Pragma_Export_Function) 8493 then 8494 null; 8495 8496 else 8497 Error_Pragma_Arg 8498 ("wrong form for Internal parameter for pragma%", Arg_Internal); 8499 end if; 8500 8501 Check_Arg_Is_Local_Name (Arg_Internal); 8502 end Process_Extended_Import_Export_Internal_Arg; 8503 8504 -------------------------------------------------- 8505 -- Process_Extended_Import_Export_Object_Pragma -- 8506 -------------------------------------------------- 8507 8508 procedure Process_Extended_Import_Export_Object_Pragma 8509 (Arg_Internal : Node_Id; 8510 Arg_External : Node_Id; 8511 Arg_Size : Node_Id) 8512 is 8513 Def_Id : Entity_Id; 8514 8515 begin 8516 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 8517 Def_Id := Entity (Arg_Internal); 8518 8519 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 8520 Error_Pragma_Arg 8521 ("pragma% must designate an object", Arg_Internal); 8522 end if; 8523 8524 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 8525 or else 8526 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 8527 then 8528 Error_Pragma_Arg 8529 ("previous Common/Psect_Object applies, pragma % not permitted", 8530 Arg_Internal); 8531 end if; 8532 8533 if Rep_Item_Too_Late (Def_Id, N) then 8534 raise Pragma_Exit; 8535 end if; 8536 8537 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 8538 8539 if Present (Arg_Size) then 8540 Check_Arg_Is_External_Name (Arg_Size); 8541 end if; 8542 8543 -- Export_Object case 8544 8545 if Prag_Id = Pragma_Export_Object then 8546 if not Is_Library_Level_Entity (Def_Id) then 8547 Error_Pragma_Arg 8548 ("argument for pragma% must be library level entity", 8549 Arg_Internal); 8550 end if; 8551 8552 if Ekind (Current_Scope) = E_Generic_Package then 8553 Error_Pragma ("pragma& cannot appear in a generic unit"); 8554 end if; 8555 8556 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then 8557 Error_Pragma_Arg 8558 ("exported object must have compile time known size", 8559 Arg_Internal); 8560 end if; 8561 8562 if Warn_On_Export_Import and then Is_Exported (Def_Id) then 8563 Error_Msg_N ("??duplicate Export_Object pragma", N); 8564 else 8565 Set_Exported (Def_Id, Arg_Internal); 8566 end if; 8567 8568 -- Import_Object case 8569 8570 else 8571 if Is_Concurrent_Type (Etype (Def_Id)) then 8572 Error_Pragma_Arg 8573 ("cannot use pragma% for task/protected object", 8574 Arg_Internal); 8575 end if; 8576 8577 if Ekind (Def_Id) = E_Constant then 8578 Error_Pragma_Arg 8579 ("cannot import a constant", Arg_Internal); 8580 end if; 8581 8582 if Warn_On_Export_Import 8583 and then Has_Discriminants (Etype (Def_Id)) 8584 then 8585 Error_Msg_N 8586 ("imported value must be initialized??", Arg_Internal); 8587 end if; 8588 8589 if Warn_On_Export_Import 8590 and then Is_Access_Type (Etype (Def_Id)) 8591 then 8592 Error_Pragma_Arg 8593 ("cannot import object of an access type??", Arg_Internal); 8594 end if; 8595 8596 if Warn_On_Export_Import 8597 and then Is_Imported (Def_Id) 8598 then 8599 Error_Msg_N ("??duplicate Import_Object pragma", N); 8600 8601 -- Check for explicit initialization present. Note that an 8602 -- initialization generated by the code generator, e.g. for an 8603 -- access type, does not count here. 8604 8605 elsif Present (Expression (Parent (Def_Id))) 8606 and then 8607 Comes_From_Source 8608 (Original_Node (Expression (Parent (Def_Id)))) 8609 then 8610 Error_Msg_Sloc := Sloc (Def_Id); 8611 Error_Pragma_Arg 8612 ("imported entities cannot be initialized (RM B.1(24))", 8613 "\no initialization allowed for & declared#", Arg1); 8614 else 8615 Set_Imported (Def_Id); 8616 Note_Possible_Modification (Arg_Internal, Sure => False); 8617 end if; 8618 end if; 8619 end Process_Extended_Import_Export_Object_Pragma; 8620 8621 ------------------------------------------------------ 8622 -- Process_Extended_Import_Export_Subprogram_Pragma -- 8623 ------------------------------------------------------ 8624 8625 procedure Process_Extended_Import_Export_Subprogram_Pragma 8626 (Arg_Internal : Node_Id; 8627 Arg_External : Node_Id; 8628 Arg_Parameter_Types : Node_Id; 8629 Arg_Result_Type : Node_Id := Empty; 8630 Arg_Mechanism : Node_Id; 8631 Arg_Result_Mechanism : Node_Id := Empty) 8632 is 8633 Ent : Entity_Id; 8634 Def_Id : Entity_Id; 8635 Hom_Id : Entity_Id; 8636 Formal : Entity_Id; 8637 Ambiguous : Boolean; 8638 Match : Boolean; 8639 8640 function Same_Base_Type 8641 (Ptype : Node_Id; 8642 Formal : Entity_Id) return Boolean; 8643 -- Determines if Ptype references the type of Formal. Note that only 8644 -- the base types need to match according to the spec. Ptype here is 8645 -- the argument from the pragma, which is either a type name, or an 8646 -- access attribute. 8647 8648 -------------------- 8649 -- Same_Base_Type -- 8650 -------------------- 8651 8652 function Same_Base_Type 8653 (Ptype : Node_Id; 8654 Formal : Entity_Id) return Boolean 8655 is 8656 Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); 8657 Pref : Node_Id; 8658 8659 begin 8660 -- Case where pragma argument is typ'Access 8661 8662 if Nkind (Ptype) = N_Attribute_Reference 8663 and then Attribute_Name (Ptype) = Name_Access 8664 then 8665 Pref := Prefix (Ptype); 8666 Find_Type (Pref); 8667 8668 if not Is_Entity_Name (Pref) 8669 or else Entity (Pref) = Any_Type 8670 then 8671 raise Pragma_Exit; 8672 end if; 8673 8674 -- We have a match if the corresponding argument is of an 8675 -- anonymous access type, and its designated type matches the 8676 -- type of the prefix of the access attribute 8677 8678 return Ekind (Ftyp) = E_Anonymous_Access_Type 8679 and then Base_Type (Entity (Pref)) = 8680 Base_Type (Etype (Designated_Type (Ftyp))); 8681 8682 -- Case where pragma argument is a type name 8683 8684 else 8685 Find_Type (Ptype); 8686 8687 if not Is_Entity_Name (Ptype) 8688 or else Entity (Ptype) = Any_Type 8689 then 8690 raise Pragma_Exit; 8691 end if; 8692 8693 -- We have a match if the corresponding argument is of the type 8694 -- given in the pragma (comparing base types) 8695 8696 return Base_Type (Entity (Ptype)) = Ftyp; 8697 end if; 8698 end Same_Base_Type; 8699 8700 -- Start of processing for 8701 -- Process_Extended_Import_Export_Subprogram_Pragma 8702 8703 begin 8704 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 8705 Ent := Empty; 8706 Ambiguous := False; 8707 8708 -- Loop through homonyms (overloadings) of the entity 8709 8710 Hom_Id := Entity (Arg_Internal); 8711 while Present (Hom_Id) loop 8712 Def_Id := Get_Base_Subprogram (Hom_Id); 8713 8714 -- We need a subprogram in the current scope 8715 8716 if not Is_Subprogram (Def_Id) 8717 or else Scope (Def_Id) /= Current_Scope 8718 then 8719 null; 8720 8721 else 8722 Match := True; 8723 8724 -- Pragma cannot apply to subprogram body 8725 8726 if Is_Subprogram (Def_Id) 8727 and then Nkind (Parent (Declaration_Node (Def_Id))) = 8728 N_Subprogram_Body 8729 then 8730 Error_Pragma 8731 ("pragma% requires separate spec and must come before " 8732 & "body"); 8733 end if; 8734 8735 -- Test result type if given, note that the result type 8736 -- parameter can only be present for the function cases. 8737 8738 if Present (Arg_Result_Type) 8739 and then not Same_Base_Type (Arg_Result_Type, Def_Id) 8740 then 8741 Match := False; 8742 8743 elsif Etype (Def_Id) /= Standard_Void_Type 8744 and then Nam_In (Pname, Name_Export_Procedure, 8745 Name_Import_Procedure) 8746 then 8747 Match := False; 8748 8749 -- Test parameter types if given. Note that this parameter has 8750 -- not been analyzed (and must not be, since it is semantic 8751 -- nonsense), so we get it as the parser left it. 8752 8753 elsif Present (Arg_Parameter_Types) then 8754 Check_Matching_Types : declare 8755 Formal : Entity_Id; 8756 Ptype : Node_Id; 8757 8758 begin 8759 Formal := First_Formal (Def_Id); 8760 8761 if Nkind (Arg_Parameter_Types) = N_Null then 8762 if Present (Formal) then 8763 Match := False; 8764 end if; 8765 8766 -- A list of one type, e.g. (List) is parsed as a 8767 -- parenthesized expression. 8768 8769 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate 8770 and then Paren_Count (Arg_Parameter_Types) = 1 8771 then 8772 if No (Formal) 8773 or else Present (Next_Formal (Formal)) 8774 then 8775 Match := False; 8776 else 8777 Match := 8778 Same_Base_Type (Arg_Parameter_Types, Formal); 8779 end if; 8780 8781 -- A list of more than one type is parsed as a aggregate 8782 8783 elsif Nkind (Arg_Parameter_Types) = N_Aggregate 8784 and then Paren_Count (Arg_Parameter_Types) = 0 8785 then 8786 Ptype := First (Expressions (Arg_Parameter_Types)); 8787 while Present (Ptype) or else Present (Formal) loop 8788 if No (Ptype) 8789 or else No (Formal) 8790 or else not Same_Base_Type (Ptype, Formal) 8791 then 8792 Match := False; 8793 exit; 8794 else 8795 Next_Formal (Formal); 8796 Next (Ptype); 8797 end if; 8798 end loop; 8799 8800 -- Anything else is of the wrong form 8801 8802 else 8803 Error_Pragma_Arg 8804 ("wrong form for Parameter_Types parameter", 8805 Arg_Parameter_Types); 8806 end if; 8807 end Check_Matching_Types; 8808 end if; 8809 8810 -- Match is now False if the entry we found did not match 8811 -- either a supplied Parameter_Types or Result_Types argument 8812 8813 if Match then 8814 if No (Ent) then 8815 Ent := Def_Id; 8816 8817 -- Ambiguous case, the flag Ambiguous shows if we already 8818 -- detected this and output the initial messages. 8819 8820 else 8821 if not Ambiguous then 8822 Ambiguous := True; 8823 Error_Msg_Name_1 := Pname; 8824 Error_Msg_N 8825 ("pragma% does not uniquely identify subprogram!", 8826 N); 8827 Error_Msg_Sloc := Sloc (Ent); 8828 Error_Msg_N ("matching subprogram #!", N); 8829 Ent := Empty; 8830 end if; 8831 8832 Error_Msg_Sloc := Sloc (Def_Id); 8833 Error_Msg_N ("matching subprogram #!", N); 8834 end if; 8835 end if; 8836 end if; 8837 8838 Hom_Id := Homonym (Hom_Id); 8839 end loop; 8840 8841 -- See if we found an entry 8842 8843 if No (Ent) then 8844 if not Ambiguous then 8845 if Is_Generic_Subprogram (Entity (Arg_Internal)) then 8846 Error_Pragma 8847 ("pragma% cannot be given for generic subprogram"); 8848 else 8849 Error_Pragma 8850 ("pragma% does not identify local subprogram"); 8851 end if; 8852 end if; 8853 8854 return; 8855 end if; 8856 8857 -- Import pragmas must be for imported entities 8858 8859 if Prag_Id = Pragma_Import_Function 8860 or else 8861 Prag_Id = Pragma_Import_Procedure 8862 or else 8863 Prag_Id = Pragma_Import_Valued_Procedure 8864 then 8865 if not Is_Imported (Ent) then 8866 Error_Pragma 8867 ("pragma Import or Interface must precede pragma%"); 8868 end if; 8869 8870 -- Here we have the Export case which can set the entity as exported 8871 8872 -- But does not do so if the specified external name is null, since 8873 -- that is taken as a signal in DEC Ada 83 (with which we want to be 8874 -- compatible) to request no external name. 8875 8876 elsif Nkind (Arg_External) = N_String_Literal 8877 and then String_Length (Strval (Arg_External)) = 0 8878 then 8879 null; 8880 8881 -- In all other cases, set entity as exported 8882 8883 else 8884 Set_Exported (Ent, Arg_Internal); 8885 end if; 8886 8887 -- Special processing for Valued_Procedure cases 8888 8889 if Prag_Id = Pragma_Import_Valued_Procedure 8890 or else 8891 Prag_Id = Pragma_Export_Valued_Procedure 8892 then 8893 Formal := First_Formal (Ent); 8894 8895 if No (Formal) then 8896 Error_Pragma ("at least one parameter required for pragma%"); 8897 8898 elsif Ekind (Formal) /= E_Out_Parameter then 8899 Error_Pragma ("first parameter must have mode out for pragma%"); 8900 8901 else 8902 Set_Is_Valued_Procedure (Ent); 8903 end if; 8904 end if; 8905 8906 Set_Extended_Import_Export_External_Name (Ent, Arg_External); 8907 8908 -- Process Result_Mechanism argument if present. We have already 8909 -- checked that this is only allowed for the function case. 8910 8911 if Present (Arg_Result_Mechanism) then 8912 Set_Mechanism_Value (Ent, Arg_Result_Mechanism); 8913 end if; 8914 8915 -- Process Mechanism parameter if present. Note that this parameter 8916 -- is not analyzed, and must not be analyzed since it is semantic 8917 -- nonsense, so we get it in exactly as the parser left it. 8918 8919 if Present (Arg_Mechanism) then 8920 declare 8921 Formal : Entity_Id; 8922 Massoc : Node_Id; 8923 Mname : Node_Id; 8924 Choice : Node_Id; 8925 8926 begin 8927 -- A single mechanism association without a formal parameter 8928 -- name is parsed as a parenthesized expression. All other 8929 -- cases are parsed as aggregates, so we rewrite the single 8930 -- parameter case as an aggregate for consistency. 8931 8932 if Nkind (Arg_Mechanism) /= N_Aggregate 8933 and then Paren_Count (Arg_Mechanism) = 1 8934 then 8935 Rewrite (Arg_Mechanism, 8936 Make_Aggregate (Sloc (Arg_Mechanism), 8937 Expressions => New_List ( 8938 Relocate_Node (Arg_Mechanism)))); 8939 end if; 8940 8941 -- Case of only mechanism name given, applies to all formals 8942 8943 if Nkind (Arg_Mechanism) /= N_Aggregate then 8944 Formal := First_Formal (Ent); 8945 while Present (Formal) loop 8946 Set_Mechanism_Value (Formal, Arg_Mechanism); 8947 Next_Formal (Formal); 8948 end loop; 8949 8950 -- Case of list of mechanism associations given 8951 8952 else 8953 if Null_Record_Present (Arg_Mechanism) then 8954 Error_Pragma_Arg 8955 ("inappropriate form for Mechanism parameter", 8956 Arg_Mechanism); 8957 end if; 8958 8959 -- Deal with positional ones first 8960 8961 Formal := First_Formal (Ent); 8962 8963 if Present (Expressions (Arg_Mechanism)) then 8964 Mname := First (Expressions (Arg_Mechanism)); 8965 while Present (Mname) loop 8966 if No (Formal) then 8967 Error_Pragma_Arg 8968 ("too many mechanism associations", Mname); 8969 end if; 8970 8971 Set_Mechanism_Value (Formal, Mname); 8972 Next_Formal (Formal); 8973 Next (Mname); 8974 end loop; 8975 end if; 8976 8977 -- Deal with named entries 8978 8979 if Present (Component_Associations (Arg_Mechanism)) then 8980 Massoc := First (Component_Associations (Arg_Mechanism)); 8981 while Present (Massoc) loop 8982 Choice := First (Choices (Massoc)); 8983 8984 if Nkind (Choice) /= N_Identifier 8985 or else Present (Next (Choice)) 8986 then 8987 Error_Pragma_Arg 8988 ("incorrect form for mechanism association", 8989 Massoc); 8990 end if; 8991 8992 Formal := First_Formal (Ent); 8993 loop 8994 if No (Formal) then 8995 Error_Pragma_Arg 8996 ("parameter name & not present", Choice); 8997 end if; 8998 8999 if Chars (Choice) = Chars (Formal) then 9000 Set_Mechanism_Value 9001 (Formal, Expression (Massoc)); 9002 9003 -- Set entity on identifier (needed by ASIS) 9004 9005 Set_Entity (Choice, Formal); 9006 9007 exit; 9008 end if; 9009 9010 Next_Formal (Formal); 9011 end loop; 9012 9013 Next (Massoc); 9014 end loop; 9015 end if; 9016 end if; 9017 end; 9018 end if; 9019 end Process_Extended_Import_Export_Subprogram_Pragma; 9020 9021 -------------------------- 9022 -- Process_Generic_List -- 9023 -------------------------- 9024 9025 procedure Process_Generic_List is 9026 Arg : Node_Id; 9027 Exp : Node_Id; 9028 9029 begin 9030 Check_No_Identifiers; 9031 Check_At_Least_N_Arguments (1); 9032 9033 -- Check all arguments are names of generic units or instances 9034 9035 Arg := Arg1; 9036 while Present (Arg) loop 9037 Exp := Get_Pragma_Arg (Arg); 9038 Analyze (Exp); 9039 9040 if not Is_Entity_Name (Exp) 9041 or else 9042 (not Is_Generic_Instance (Entity (Exp)) 9043 and then 9044 not Is_Generic_Unit (Entity (Exp))) 9045 then 9046 Error_Pragma_Arg 9047 ("pragma% argument must be name of generic unit/instance", 9048 Arg); 9049 end if; 9050 9051 Next (Arg); 9052 end loop; 9053 end Process_Generic_List; 9054 9055 ------------------------------------ 9056 -- Process_Import_Predefined_Type -- 9057 ------------------------------------ 9058 9059 procedure Process_Import_Predefined_Type is 9060 Loc : constant Source_Ptr := Sloc (N); 9061 Elmt : Elmt_Id; 9062 Ftyp : Node_Id := Empty; 9063 Decl : Node_Id; 9064 Def : Node_Id; 9065 Nam : Name_Id; 9066 9067 begin 9068 Nam := String_To_Name (Strval (Expression (Arg3))); 9069 9070 Elmt := First_Elmt (Predefined_Float_Types); 9071 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop 9072 Next_Elmt (Elmt); 9073 end loop; 9074 9075 Ftyp := Node (Elmt); 9076 9077 if Present (Ftyp) then 9078 9079 -- Don't build a derived type declaration, because predefined C 9080 -- types have no declaration anywhere, so cannot really be named. 9081 -- Instead build a full type declaration, starting with an 9082 -- appropriate type definition is built 9083 9084 if Is_Floating_Point_Type (Ftyp) then 9085 Def := Make_Floating_Point_Definition (Loc, 9086 Make_Integer_Literal (Loc, Digits_Value (Ftyp)), 9087 Make_Real_Range_Specification (Loc, 9088 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))), 9089 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp))))); 9090 9091 -- Should never have a predefined type we cannot handle 9092 9093 else 9094 raise Program_Error; 9095 end if; 9096 9097 -- Build and insert a Full_Type_Declaration, which will be 9098 -- analyzed as soon as this list entry has been analyzed. 9099 9100 Decl := Make_Full_Type_Declaration (Loc, 9101 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))), 9102 Type_Definition => Def); 9103 9104 Insert_After (N, Decl); 9105 Mark_Rewrite_Insertion (Decl); 9106 9107 else 9108 Error_Pragma_Arg ("no matching type found for pragma%", Arg2); 9109 end if; 9110 end Process_Import_Predefined_Type; 9111 9112 --------------------------------- 9113 -- Process_Import_Or_Interface -- 9114 --------------------------------- 9115 9116 procedure Process_Import_Or_Interface is 9117 C : Convention_Id; 9118 Def_Id : Entity_Id; 9119 Hom_Id : Entity_Id; 9120 9121 begin 9122 -- In Relaxed_RM_Semantics, support old Ada 83 style: 9123 -- pragma Import (Entity, "external name"); 9124 9125 if Relaxed_RM_Semantics 9126 and then Arg_Count = 2 9127 and then Prag_Id = Pragma_Import 9128 and then Nkind (Expression (Arg2)) = N_String_Literal 9129 then 9130 C := Convention_C; 9131 Def_Id := Get_Pragma_Arg (Arg1); 9132 Analyze (Def_Id); 9133 9134 if not Is_Entity_Name (Def_Id) then 9135 Error_Pragma_Arg ("entity name required", Arg1); 9136 end if; 9137 9138 Def_Id := Entity (Def_Id); 9139 Kill_Size_Check_Code (Def_Id); 9140 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False); 9141 9142 else 9143 Process_Convention (C, Def_Id); 9144 9145 -- A pragma that applies to a Ghost entity becomes Ghost for the 9146 -- purposes of legality checks and removal of ignored Ghost code. 9147 9148 Mark_Ghost_Pragma (N, Def_Id); 9149 Kill_Size_Check_Code (Def_Id); 9150 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); 9151 end if; 9152 9153 -- Various error checks 9154 9155 if Ekind_In (Def_Id, E_Variable, E_Constant) then 9156 9157 -- We do not permit Import to apply to a renaming declaration 9158 9159 if Present (Renamed_Object (Def_Id)) then 9160 Error_Pragma_Arg 9161 ("pragma% not allowed for object renaming", Arg2); 9162 9163 -- User initialization is not allowed for imported object, but 9164 -- the object declaration may contain a default initialization, 9165 -- that will be discarded. Note that an explicit initialization 9166 -- only counts if it comes from source, otherwise it is simply 9167 -- the code generator making an implicit initialization explicit. 9168 9169 elsif Present (Expression (Parent (Def_Id))) 9170 and then Comes_From_Source 9171 (Original_Node (Expression (Parent (Def_Id)))) 9172 then 9173 -- Set imported flag to prevent cascaded errors 9174 9175 Set_Is_Imported (Def_Id); 9176 9177 Error_Msg_Sloc := Sloc (Def_Id); 9178 Error_Pragma_Arg 9179 ("no initialization allowed for declaration of& #", 9180 "\imported entities cannot be initialized (RM B.1(24))", 9181 Arg2); 9182 9183 else 9184 -- If the pragma comes from an aspect specification the 9185 -- Is_Imported flag has already been set. 9186 9187 if not From_Aspect_Specification (N) then 9188 Set_Imported (Def_Id); 9189 end if; 9190 9191 Process_Interface_Name (Def_Id, Arg3, Arg4, N); 9192 9193 -- Note that we do not set Is_Public here. That's because we 9194 -- only want to set it if there is no address clause, and we 9195 -- don't know that yet, so we delay that processing till 9196 -- freeze time. 9197 9198 -- pragma Import completes deferred constants 9199 9200 if Ekind (Def_Id) = E_Constant then 9201 Set_Has_Completion (Def_Id); 9202 end if; 9203 9204 -- It is not possible to import a constant of an unconstrained 9205 -- array type (e.g. string) because there is no simple way to 9206 -- write a meaningful subtype for it. 9207 9208 if Is_Array_Type (Etype (Def_Id)) 9209 and then not Is_Constrained (Etype (Def_Id)) 9210 then 9211 Error_Msg_NE 9212 ("imported constant& must have a constrained subtype", 9213 N, Def_Id); 9214 end if; 9215 end if; 9216 9217 elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then 9218 9219 -- If the name is overloaded, pragma applies to all of the denoted 9220 -- entities in the same declarative part, unless the pragma comes 9221 -- from an aspect specification or was generated by the compiler 9222 -- (such as for pragma Provide_Shift_Operators). 9223 9224 Hom_Id := Def_Id; 9225 while Present (Hom_Id) loop 9226 9227 Def_Id := Get_Base_Subprogram (Hom_Id); 9228 9229 -- Ignore inherited subprograms because the pragma will apply 9230 -- to the parent operation, which is the one called. 9231 9232 if Is_Overloadable (Def_Id) 9233 and then Present (Alias (Def_Id)) 9234 then 9235 null; 9236 9237 -- If it is not a subprogram, it must be in an outer scope and 9238 -- pragma does not apply. 9239 9240 elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then 9241 null; 9242 9243 -- The pragma does not apply to primitives of interfaces 9244 9245 elsif Is_Dispatching_Operation (Def_Id) 9246 and then Present (Find_Dispatching_Type (Def_Id)) 9247 and then Is_Interface (Find_Dispatching_Type (Def_Id)) 9248 then 9249 null; 9250 9251 -- Verify that the homonym is in the same declarative part (not 9252 -- just the same scope). If the pragma comes from an aspect 9253 -- specification we know that it is part of the declaration. 9254 9255 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) 9256 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux 9257 and then not From_Aspect_Specification (N) 9258 then 9259 exit; 9260 9261 else 9262 -- If the pragma comes from an aspect specification the 9263 -- Is_Imported flag has already been set. 9264 9265 if not From_Aspect_Specification (N) then 9266 Set_Imported (Def_Id); 9267 end if; 9268 9269 -- Reject an Import applied to an abstract subprogram 9270 9271 if Is_Subprogram (Def_Id) 9272 and then Is_Abstract_Subprogram (Def_Id) 9273 then 9274 Error_Msg_Sloc := Sloc (Def_Id); 9275 Error_Msg_NE 9276 ("cannot import abstract subprogram& declared#", 9277 Arg2, Def_Id); 9278 end if; 9279 9280 -- Special processing for Convention_Intrinsic 9281 9282 if C = Convention_Intrinsic then 9283 9284 -- Link_Name argument not allowed for intrinsic 9285 9286 Check_No_Link_Name; 9287 9288 Set_Is_Intrinsic_Subprogram (Def_Id); 9289 9290 -- If no external name is present, then check that this 9291 -- is a valid intrinsic subprogram. If an external name 9292 -- is present, then this is handled by the back end. 9293 9294 if No (Arg3) then 9295 Check_Intrinsic_Subprogram 9296 (Def_Id, Get_Pragma_Arg (Arg2)); 9297 end if; 9298 end if; 9299 9300 -- Verify that the subprogram does not have a completion 9301 -- through a renaming declaration. For other completions the 9302 -- pragma appears as a too late representation. 9303 9304 declare 9305 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); 9306 9307 begin 9308 if Present (Decl) 9309 and then Nkind (Decl) = N_Subprogram_Declaration 9310 and then Present (Corresponding_Body (Decl)) 9311 and then Nkind (Unit_Declaration_Node 9312 (Corresponding_Body (Decl))) = 9313 N_Subprogram_Renaming_Declaration 9314 then 9315 Error_Msg_Sloc := Sloc (Def_Id); 9316 Error_Msg_NE 9317 ("cannot import&, renaming already provided for " 9318 & "declaration #", N, Def_Id); 9319 end if; 9320 end; 9321 9322 -- If the pragma comes from an aspect specification, there 9323 -- must be an Import aspect specified as well. In the rare 9324 -- case where Import is set to False, the suprogram needs to 9325 -- have a local completion. 9326 9327 declare 9328 Imp_Aspect : constant Node_Id := 9329 Find_Aspect (Def_Id, Aspect_Import); 9330 Expr : Node_Id; 9331 9332 begin 9333 if Present (Imp_Aspect) 9334 and then Present (Expression (Imp_Aspect)) 9335 then 9336 Expr := Expression (Imp_Aspect); 9337 Analyze_And_Resolve (Expr, Standard_Boolean); 9338 9339 if Is_Entity_Name (Expr) 9340 and then Entity (Expr) = Standard_True 9341 then 9342 Set_Has_Completion (Def_Id); 9343 end if; 9344 9345 -- If there is no expression, the default is True, as for 9346 -- all boolean aspects. Same for the older pragma. 9347 9348 else 9349 Set_Has_Completion (Def_Id); 9350 end if; 9351 end; 9352 9353 Process_Interface_Name (Def_Id, Arg3, Arg4, N); 9354 end if; 9355 9356 if Is_Compilation_Unit (Hom_Id) then 9357 9358 -- Its possible homonyms are not affected by the pragma. 9359 -- Such homonyms might be present in the context of other 9360 -- units being compiled. 9361 9362 exit; 9363 9364 elsif From_Aspect_Specification (N) then 9365 exit; 9366 9367 -- If the pragma was created by the compiler, then we don't 9368 -- want it to apply to other homonyms. This kind of case can 9369 -- occur when using pragma Provide_Shift_Operators, which 9370 -- generates implicit shift and rotate operators with Import 9371 -- pragmas that might apply to earlier explicit or implicit 9372 -- declarations marked with Import (for example, coming from 9373 -- an earlier pragma Provide_Shift_Operators for another type), 9374 -- and we don't generally want other homonyms being treated 9375 -- as imported or the pragma flagged as an illegal duplicate. 9376 9377 elsif not Comes_From_Source (N) then 9378 exit; 9379 9380 else 9381 Hom_Id := Homonym (Hom_Id); 9382 end if; 9383 end loop; 9384 9385 -- Import a CPP class 9386 9387 elsif C = Convention_CPP 9388 and then (Is_Record_Type (Def_Id) 9389 or else Ekind (Def_Id) = E_Incomplete_Type) 9390 then 9391 if Ekind (Def_Id) = E_Incomplete_Type then 9392 if Present (Full_View (Def_Id)) then 9393 Def_Id := Full_View (Def_Id); 9394 9395 else 9396 Error_Msg_N 9397 ("cannot import 'C'P'P type before full declaration seen", 9398 Get_Pragma_Arg (Arg2)); 9399 9400 -- Although we have reported the error we decorate it as 9401 -- CPP_Class to avoid reporting spurious errors 9402 9403 Set_Is_CPP_Class (Def_Id); 9404 return; 9405 end if; 9406 end if; 9407 9408 -- Types treated as CPP classes must be declared limited (note: 9409 -- this used to be a warning but there is no real benefit to it 9410 -- since we did effectively intend to treat the type as limited 9411 -- anyway). 9412 9413 if not Is_Limited_Type (Def_Id) then 9414 Error_Msg_N 9415 ("imported 'C'P'P type must be limited", 9416 Get_Pragma_Arg (Arg2)); 9417 end if; 9418 9419 if Etype (Def_Id) /= Def_Id 9420 and then not Is_CPP_Class (Root_Type (Def_Id)) 9421 then 9422 Error_Msg_N ("root type must be a 'C'P'P type", Arg1); 9423 end if; 9424 9425 Set_Is_CPP_Class (Def_Id); 9426 9427 -- Imported CPP types must not have discriminants (because C++ 9428 -- classes do not have discriminants). 9429 9430 if Has_Discriminants (Def_Id) then 9431 Error_Msg_N 9432 ("imported 'C'P'P type cannot have discriminants", 9433 First (Discriminant_Specifications 9434 (Declaration_Node (Def_Id)))); 9435 end if; 9436 9437 -- Check that components of imported CPP types do not have default 9438 -- expressions. For private types this check is performed when the 9439 -- full view is analyzed (see Process_Full_View). 9440 9441 if not Is_Private_Type (Def_Id) then 9442 Check_CPP_Type_Has_No_Defaults (Def_Id); 9443 end if; 9444 9445 -- Import a CPP exception 9446 9447 elsif C = Convention_CPP 9448 and then Ekind (Def_Id) = E_Exception 9449 then 9450 if No (Arg3) then 9451 Error_Pragma_Arg 9452 ("'External_'Name arguments is required for 'Cpp exception", 9453 Arg3); 9454 else 9455 -- As only a string is allowed, Check_Arg_Is_External_Name 9456 -- isn't called. 9457 9458 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 9459 end if; 9460 9461 if Present (Arg4) then 9462 Error_Pragma_Arg 9463 ("Link_Name argument not allowed for imported Cpp exception", 9464 Arg4); 9465 end if; 9466 9467 -- Do not call Set_Interface_Name as the name of the exception 9468 -- shouldn't be modified (and in particular it shouldn't be 9469 -- the External_Name). For exceptions, the External_Name is the 9470 -- name of the RTTI structure. 9471 9472 -- ??? Emit an error if pragma Import/Export_Exception is present 9473 9474 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then 9475 Check_No_Link_Name; 9476 Check_Arg_Count (3); 9477 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 9478 9479 Process_Import_Predefined_Type; 9480 9481 else 9482 Error_Pragma_Arg 9483 ("second argument of pragma% must be object, subprogram " 9484 & "or incomplete type", 9485 Arg2); 9486 end if; 9487 9488 -- If this pragma applies to a compilation unit, then the unit, which 9489 -- is a subprogram, does not require (or allow) a body. We also do 9490 -- not need to elaborate imported procedures. 9491 9492 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 9493 declare 9494 Cunit : constant Node_Id := Parent (Parent (N)); 9495 begin 9496 Set_Body_Required (Cunit, False); 9497 end; 9498 end if; 9499 end Process_Import_Or_Interface; 9500 9501 -------------------- 9502 -- Process_Inline -- 9503 -------------------- 9504 9505 procedure Process_Inline (Status : Inline_Status) is 9506 Applies : Boolean; 9507 Assoc : Node_Id; 9508 Decl : Node_Id; 9509 Subp : Entity_Id; 9510 Subp_Id : Node_Id; 9511 9512 Ghost_Error_Posted : Boolean := False; 9513 -- Flag set when an error concerning the illegal mix of Ghost and 9514 -- non-Ghost subprograms is emitted. 9515 9516 Ghost_Id : Entity_Id := Empty; 9517 -- The entity of the first Ghost subprogram encountered while 9518 -- processing the arguments of the pragma. 9519 9520 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id); 9521 -- Verify the placement of pragma Inline_Always with respect to the 9522 -- initial declaration of subprogram Spec_Id. 9523 9524 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; 9525 -- Returns True if it can be determined at this stage that inlining 9526 -- is not possible, for example if the body is available and contains 9527 -- exception handlers, we prevent inlining, since otherwise we can 9528 -- get undefined symbols at link time. This function also emits a 9529 -- warning if the pragma appears too late. 9530 -- 9531 -- ??? is business with link symbols still valid, or does it relate 9532 -- to front end ZCX which is being phased out ??? 9533 9534 procedure Make_Inline (Subp : Entity_Id); 9535 -- Subp is the defining unit name of the subprogram declaration. If 9536 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on 9537 -- the corresponding body, if there is one present. 9538 9539 procedure Set_Inline_Flags (Subp : Entity_Id); 9540 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp. 9541 -- Also set or clear Is_Inlined flag on Subp depending on Status. 9542 9543 ----------------------------------- 9544 -- Check_Inline_Always_Placement -- 9545 ----------------------------------- 9546 9547 procedure Check_Inline_Always_Placement (Spec_Id : Entity_Id) is 9548 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 9549 9550 function Compilation_Unit_OK return Boolean; 9551 pragma Inline (Compilation_Unit_OK); 9552 -- Determine whether pragma Inline_Always applies to a compatible 9553 -- compilation unit denoted by Spec_Id. 9554 9555 function Declarative_List_OK return Boolean; 9556 pragma Inline (Declarative_List_OK); 9557 -- Determine whether the initial declaration of subprogram Spec_Id 9558 -- and the pragma appear in compatible declarative lists. 9559 9560 function Subprogram_Body_OK return Boolean; 9561 pragma Inline (Subprogram_Body_OK); 9562 -- Determine whether pragma Inline_Always applies to a compatible 9563 -- subprogram body denoted by Spec_Id. 9564 9565 ------------------------- 9566 -- Compilation_Unit_OK -- 9567 ------------------------- 9568 9569 function Compilation_Unit_OK return Boolean is 9570 Comp_Unit : constant Node_Id := Parent (Spec_Decl); 9571 9572 begin 9573 -- The pragma appears after the initial declaration of a 9574 -- compilation unit. 9575 9576 -- procedure Comp_Unit; 9577 -- pragma Inline_Always (Comp_Unit); 9578 9579 -- Note that for compatibility reasons, the following case is 9580 -- also accepted. 9581 9582 -- procedure Stand_Alone_Body_Comp_Unit is 9583 -- ... 9584 -- end Stand_Alone_Body_Comp_Unit; 9585 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit); 9586 9587 return 9588 Nkind (Comp_Unit) = N_Compilation_Unit 9589 and then Present (Aux_Decls_Node (Comp_Unit)) 9590 and then Is_List_Member (N) 9591 and then List_Containing (N) = 9592 Pragmas_After (Aux_Decls_Node (Comp_Unit)); 9593 end Compilation_Unit_OK; 9594 9595 ------------------------- 9596 -- Declarative_List_OK -- 9597 ------------------------- 9598 9599 function Declarative_List_OK return Boolean is 9600 Context : constant Node_Id := Parent (Spec_Decl); 9601 9602 Init_Decl : Node_Id; 9603 Init_List : List_Id; 9604 Prag_List : List_Id; 9605 9606 begin 9607 -- Determine the proper initial declaration. In general this is 9608 -- the declaration node of the subprogram except when the input 9609 -- denotes a generic instantiation. 9610 9611 -- procedure Inst is new Gen; 9612 -- pragma Inline_Always (Inst); 9613 9614 -- In this case the original subprogram is moved inside an 9615 -- anonymous package while pragma Inline_Always remains at the 9616 -- level of the anonymous package. Use the declaration of the 9617 -- package because it reflects the placement of the original 9618 -- instantiation. 9619 9620 -- package Anon_Pack is 9621 -- procedure Inst is ... end Inst; -- original 9622 -- end Anon_Pack; 9623 9624 -- procedure Inst renames Anon_Pack.Inst; 9625 -- pragma Inline_Always (Inst); 9626 9627 if Is_Generic_Instance (Spec_Id) then 9628 Init_Decl := Parent (Parent (Spec_Decl)); 9629 pragma Assert (Nkind (Init_Decl) = N_Package_Declaration); 9630 else 9631 Init_Decl := Spec_Decl; 9632 end if; 9633 9634 if Is_List_Member (Init_Decl) and then Is_List_Member (N) then 9635 Init_List := List_Containing (Init_Decl); 9636 Prag_List := List_Containing (N); 9637 9638 -- The pragma and then initial declaration appear within the 9639 -- same declarative list. 9640 9641 if Init_List = Prag_List then 9642 return True; 9643 9644 -- A special case of the above is when both the pragma and 9645 -- the initial declaration appear in different lists of a 9646 -- package spec, protected definition, or a task definition. 9647 9648 -- package Pack is 9649 -- procedure Proc; 9650 -- private 9651 -- pragma Inline_Always (Proc); 9652 -- end Pack; 9653 9654 elsif Nkind_In (Context, N_Package_Specification, 9655 N_Protected_Definition, 9656 N_Task_Definition) 9657 and then Init_List = Visible_Declarations (Context) 9658 and then Prag_List = Private_Declarations (Context) 9659 then 9660 return True; 9661 end if; 9662 end if; 9663 9664 return False; 9665 end Declarative_List_OK; 9666 9667 ------------------------ 9668 -- Subprogram_Body_OK -- 9669 ------------------------ 9670 9671 function Subprogram_Body_OK return Boolean is 9672 Body_Decl : Node_Id; 9673 9674 begin 9675 -- The pragma appears within the declarative list of a stand- 9676 -- alone subprogram body. 9677 9678 -- procedure Stand_Alone_Body is 9679 -- pragma Inline_Always (Stand_Alone_Body); 9680 -- begin 9681 -- ... 9682 -- end Stand_Alone_Body; 9683 9684 -- The compiler creates a dummy spec in this case, however the 9685 -- pragma remains within the declarative list of the body. 9686 9687 if Nkind (Spec_Decl) = N_Subprogram_Declaration 9688 and then not Comes_From_Source (Spec_Decl) 9689 and then Present (Corresponding_Body (Spec_Decl)) 9690 then 9691 Body_Decl := 9692 Unit_Declaration_Node (Corresponding_Body (Spec_Decl)); 9693 9694 if Present (Declarations (Body_Decl)) 9695 and then Is_List_Member (N) 9696 and then List_Containing (N) = Declarations (Body_Decl) 9697 then 9698 return True; 9699 end if; 9700 end if; 9701 9702 return False; 9703 end Subprogram_Body_OK; 9704 9705 -- Start of processing for Check_Inline_Always_Placement 9706 9707 begin 9708 -- This check is relevant only for pragma Inline_Always 9709 9710 if Pname /= Name_Inline_Always then 9711 return; 9712 9713 -- Nothing to do when the pragma is internally generated on the 9714 -- assumption that it is properly placed. 9715 9716 elsif not Comes_From_Source (N) then 9717 return; 9718 9719 -- Nothing to do for internally generated subprograms that act 9720 -- as accidental homonyms of a source subprogram being inlined. 9721 9722 elsif not Comes_From_Source (Spec_Id) then 9723 return; 9724 9725 -- Nothing to do for generic formal subprograms that act as 9726 -- homonyms of another source subprogram being inlined. 9727 9728 elsif Is_Formal_Subprogram (Spec_Id) then 9729 return; 9730 9731 elsif Compilation_Unit_OK 9732 or else Declarative_List_OK 9733 or else Subprogram_Body_OK 9734 then 9735 return; 9736 end if; 9737 9738 -- At this point it is known that the pragma applies to or appears 9739 -- within a completing body, a completing stub, or a subunit. 9740 9741 Error_Msg_Name_1 := Pname; 9742 Error_Msg_Name_2 := Chars (Spec_Id); 9743 Error_Msg_Sloc := Sloc (Spec_Id); 9744 9745 Error_Msg_N 9746 ("pragma % must appear on initial declaration of subprogram " 9747 & "% defined #", N); 9748 end Check_Inline_Always_Placement; 9749 9750 --------------------------- 9751 -- Inlining_Not_Possible -- 9752 --------------------------- 9753 9754 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is 9755 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 9756 Stats : Node_Id; 9757 9758 begin 9759 if Nkind (Decl) = N_Subprogram_Body then 9760 Stats := Handled_Statement_Sequence (Decl); 9761 return Present (Exception_Handlers (Stats)) 9762 or else Present (At_End_Proc (Stats)); 9763 9764 elsif Nkind (Decl) = N_Subprogram_Declaration 9765 and then Present (Corresponding_Body (Decl)) 9766 then 9767 if Analyzed (Corresponding_Body (Decl)) then 9768 Error_Msg_N ("pragma appears too late, ignored??", N); 9769 return True; 9770 9771 -- If the subprogram is a renaming as body, the body is just a 9772 -- call to the renamed subprogram, and inlining is trivially 9773 -- possible. 9774 9775 elsif 9776 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = 9777 N_Subprogram_Renaming_Declaration 9778 then 9779 return False; 9780 9781 else 9782 Stats := 9783 Handled_Statement_Sequence 9784 (Unit_Declaration_Node (Corresponding_Body (Decl))); 9785 9786 return 9787 Present (Exception_Handlers (Stats)) 9788 or else Present (At_End_Proc (Stats)); 9789 end if; 9790 9791 else 9792 -- If body is not available, assume the best, the check is 9793 -- performed again when compiling enclosing package bodies. 9794 9795 return False; 9796 end if; 9797 end Inlining_Not_Possible; 9798 9799 ----------------- 9800 -- Make_Inline -- 9801 ----------------- 9802 9803 procedure Make_Inline (Subp : Entity_Id) is 9804 Kind : constant Entity_Kind := Ekind (Subp); 9805 Inner_Subp : Entity_Id := Subp; 9806 9807 begin 9808 -- Ignore if bad type, avoid cascaded error 9809 9810 if Etype (Subp) = Any_Type then 9811 Applies := True; 9812 return; 9813 9814 -- If inlining is not possible, for now do not treat as an error 9815 9816 elsif Status /= Suppressed 9817 and then Front_End_Inlining 9818 and then Inlining_Not_Possible (Subp) 9819 then 9820 Applies := True; 9821 return; 9822 9823 -- Here we have a candidate for inlining, but we must exclude 9824 -- derived operations. Otherwise we would end up trying to inline 9825 -- a phantom declaration, and the result would be to drag in a 9826 -- body which has no direct inlining associated with it. That 9827 -- would not only be inefficient but would also result in the 9828 -- backend doing cross-unit inlining in cases where it was 9829 -- definitely inappropriate to do so. 9830 9831 -- However, a simple Comes_From_Source test is insufficient, since 9832 -- we do want to allow inlining of generic instances which also do 9833 -- not come from source. We also need to recognize specs generated 9834 -- by the front-end for bodies that carry the pragma. Finally, 9835 -- predefined operators do not come from source but are not 9836 -- inlineable either. 9837 9838 elsif Is_Generic_Instance (Subp) 9839 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration 9840 then 9841 null; 9842 9843 elsif not Comes_From_Source (Subp) 9844 and then Scope (Subp) /= Standard_Standard 9845 then 9846 Applies := True; 9847 return; 9848 end if; 9849 9850 -- The referenced entity must either be the enclosing entity, or 9851 -- an entity declared within the current open scope. 9852 9853 if Present (Scope (Subp)) 9854 and then Scope (Subp) /= Current_Scope 9855 and then Subp /= Current_Scope 9856 then 9857 Error_Pragma_Arg 9858 ("argument of% must be entity in current scope", Assoc); 9859 return; 9860 end if; 9861 9862 -- Processing for procedure, operator or function. If subprogram 9863 -- is aliased (as for an instance) indicate that the renamed 9864 -- entity (if declared in the same unit) is inlined. 9865 -- If this is the anonymous subprogram created for a subprogram 9866 -- instance, the inlining applies to it directly. Otherwise we 9867 -- retrieve it as the alias of the visible subprogram instance. 9868 9869 if Is_Subprogram (Subp) then 9870 9871 -- Ensure that pragma Inline_Always is associated with the 9872 -- initial declaration of the subprogram. 9873 9874 Check_Inline_Always_Placement (Subp); 9875 9876 if Is_Wrapper_Package (Scope (Subp)) then 9877 Inner_Subp := Subp; 9878 else 9879 Inner_Subp := Ultimate_Alias (Inner_Subp); 9880 end if; 9881 9882 if In_Same_Source_Unit (Subp, Inner_Subp) then 9883 Set_Inline_Flags (Inner_Subp); 9884 9885 Decl := Parent (Parent (Inner_Subp)); 9886 9887 if Nkind (Decl) = N_Subprogram_Declaration 9888 and then Present (Corresponding_Body (Decl)) 9889 then 9890 Set_Inline_Flags (Corresponding_Body (Decl)); 9891 9892 elsif Is_Generic_Instance (Subp) 9893 and then Comes_From_Source (Subp) 9894 then 9895 -- Indicate that the body needs to be created for 9896 -- inlining subsequent calls. The instantiation node 9897 -- follows the declaration of the wrapper package 9898 -- created for it. The subprogram that requires the 9899 -- body is the anonymous one in the wrapper package. 9900 9901 if Scope (Subp) /= Standard_Standard 9902 and then 9903 Need_Subprogram_Instance_Body 9904 (Next (Unit_Declaration_Node 9905 (Scope (Alias (Subp)))), Subp) 9906 then 9907 null; 9908 end if; 9909 9910 -- Inline is a program unit pragma (RM 10.1.5) and cannot 9911 -- appear in a formal part to apply to a formal subprogram. 9912 -- Do not apply check within an instance or a formal package 9913 -- the test will have been applied to the original generic. 9914 9915 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration 9916 and then List_Containing (Decl) = List_Containing (N) 9917 and then not In_Instance 9918 then 9919 Error_Msg_N 9920 ("Inline cannot apply to a formal subprogram", N); 9921 9922 -- If Subp is a renaming, it is the renamed entity that 9923 -- will appear in any call, and be inlined. However, for 9924 -- ASIS uses it is convenient to indicate that the renaming 9925 -- itself is an inlined subprogram, so that some gnatcheck 9926 -- rules can be applied in the absence of expansion. 9927 9928 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then 9929 Set_Inline_Flags (Subp); 9930 end if; 9931 end if; 9932 9933 Applies := True; 9934 9935 -- For a generic subprogram set flag as well, for use at the point 9936 -- of instantiation, to determine whether the body should be 9937 -- generated. 9938 9939 elsif Is_Generic_Subprogram (Subp) then 9940 Set_Inline_Flags (Subp); 9941 Applies := True; 9942 9943 -- Literals are by definition inlined 9944 9945 elsif Kind = E_Enumeration_Literal then 9946 null; 9947 9948 -- Anything else is an error 9949 9950 else 9951 Error_Pragma_Arg 9952 ("expect subprogram name for pragma%", Assoc); 9953 end if; 9954 end Make_Inline; 9955 9956 ---------------------- 9957 -- Set_Inline_Flags -- 9958 ---------------------- 9959 9960 procedure Set_Inline_Flags (Subp : Entity_Id) is 9961 begin 9962 -- First set the Has_Pragma_XXX flags and issue the appropriate 9963 -- errors and warnings for suspicious combinations. 9964 9965 if Prag_Id = Pragma_No_Inline then 9966 if Has_Pragma_Inline_Always (Subp) then 9967 Error_Msg_N 9968 ("Inline_Always and No_Inline are mutually exclusive", N); 9969 elsif Has_Pragma_Inline (Subp) then 9970 Error_Msg_NE 9971 ("Inline and No_Inline both specified for& ??", 9972 N, Entity (Subp_Id)); 9973 end if; 9974 9975 Set_Has_Pragma_No_Inline (Subp); 9976 else 9977 if Prag_Id = Pragma_Inline_Always then 9978 if Has_Pragma_No_Inline (Subp) then 9979 Error_Msg_N 9980 ("Inline_Always and No_Inline are mutually exclusive", 9981 N); 9982 end if; 9983 9984 Set_Has_Pragma_Inline_Always (Subp); 9985 else 9986 if Has_Pragma_No_Inline (Subp) then 9987 Error_Msg_NE 9988 ("Inline and No_Inline both specified for& ??", 9989 N, Entity (Subp_Id)); 9990 end if; 9991 end if; 9992 9993 Set_Has_Pragma_Inline (Subp); 9994 end if; 9995 9996 -- Then adjust the Is_Inlined flag. It can never be set if the 9997 -- subprogram is subject to pragma No_Inline. 9998 9999 case Status is 10000 when Suppressed => 10001 Set_Is_Inlined (Subp, False); 10002 10003 when Disabled => 10004 null; 10005 10006 when Enabled => 10007 if not Has_Pragma_No_Inline (Subp) then 10008 Set_Is_Inlined (Subp, True); 10009 end if; 10010 end case; 10011 10012 -- A pragma that applies to a Ghost entity becomes Ghost for the 10013 -- purposes of legality checks and removal of ignored Ghost code. 10014 10015 Mark_Ghost_Pragma (N, Subp); 10016 10017 -- Capture the entity of the first Ghost subprogram being 10018 -- processed for error detection purposes. 10019 10020 if Is_Ghost_Entity (Subp) then 10021 if No (Ghost_Id) then 10022 Ghost_Id := Subp; 10023 end if; 10024 10025 -- Otherwise the subprogram is non-Ghost. It is illegal to mix 10026 -- references to Ghost and non-Ghost entities (SPARK RM 6.9). 10027 10028 elsif Present (Ghost_Id) and then not Ghost_Error_Posted then 10029 Ghost_Error_Posted := True; 10030 10031 Error_Msg_Name_1 := Pname; 10032 Error_Msg_N 10033 ("pragma % cannot mention ghost and non-ghost subprograms", 10034 N); 10035 10036 Error_Msg_Sloc := Sloc (Ghost_Id); 10037 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 10038 10039 Error_Msg_Sloc := Sloc (Subp); 10040 Error_Msg_NE ("\& # declared as non-ghost", N, Subp); 10041 end if; 10042 end Set_Inline_Flags; 10043 10044 -- Start of processing for Process_Inline 10045 10046 begin 10047 -- An inlined subprogram may grant access to its private enclosing 10048 -- context depending on the placement of its body. From elaboration 10049 -- point of view, the flow of execution may enter this private 10050 -- context, and then reach an external unit, thus producing a 10051 -- dependency on that external unit. For such a path to be properly 10052 -- discovered and encoded in the ALI file of the main unit, let the 10053 -- ABE mechanism process the body of the main unit, and encode all 10054 -- relevant invocation constructs and the relations between them. 10055 10056 Mark_Save_Invocation_Graph_Of_Body; 10057 10058 Check_No_Identifiers; 10059 Check_At_Least_N_Arguments (1); 10060 10061 if Status = Enabled then 10062 Inline_Processing_Required := True; 10063 end if; 10064 10065 Assoc := Arg1; 10066 while Present (Assoc) loop 10067 Subp_Id := Get_Pragma_Arg (Assoc); 10068 Analyze (Subp_Id); 10069 Applies := False; 10070 10071 if Is_Entity_Name (Subp_Id) then 10072 Subp := Entity (Subp_Id); 10073 10074 if Subp = Any_Id then 10075 10076 -- If previous error, avoid cascaded errors 10077 10078 Check_Error_Detected; 10079 Applies := True; 10080 10081 else 10082 Make_Inline (Subp); 10083 10084 -- For the pragma case, climb homonym chain. This is 10085 -- what implements allowing the pragma in the renaming 10086 -- case, with the result applying to the ancestors, and 10087 -- also allows Inline to apply to all previous homonyms. 10088 10089 if not From_Aspect_Specification (N) then 10090 while Present (Homonym (Subp)) 10091 and then Scope (Homonym (Subp)) = Current_Scope 10092 loop 10093 Make_Inline (Homonym (Subp)); 10094 Subp := Homonym (Subp); 10095 end loop; 10096 end if; 10097 end if; 10098 end if; 10099 10100 if not Applies then 10101 Error_Pragma_Arg ("inappropriate argument for pragma%", Assoc); 10102 end if; 10103 10104 Next (Assoc); 10105 end loop; 10106 10107 -- If the context is a package declaration, the pragma indicates 10108 -- that inlining will require the presence of the corresponding 10109 -- body. (this may be further refined). 10110 10111 if not In_Instance 10112 and then Nkind (Unit (Cunit (Current_Sem_Unit))) = 10113 N_Package_Declaration 10114 then 10115 Set_Body_Needed_For_Inlining (Cunit_Entity (Current_Sem_Unit)); 10116 end if; 10117 end Process_Inline; 10118 10119 ---------------------------- 10120 -- Process_Interface_Name -- 10121 ---------------------------- 10122 10123 procedure Process_Interface_Name 10124 (Subprogram_Def : Entity_Id; 10125 Ext_Arg : Node_Id; 10126 Link_Arg : Node_Id; 10127 Prag : Node_Id) 10128 is 10129 Ext_Nam : Node_Id; 10130 Link_Nam : Node_Id; 10131 String_Val : String_Id; 10132 10133 procedure Check_Form_Of_Interface_Name (SN : Node_Id); 10134 -- SN is a string literal node for an interface name. This routine 10135 -- performs some minimal checks that the name is reasonable. In 10136 -- particular that no spaces or other obviously incorrect characters 10137 -- appear. This is only a warning, since any characters are allowed. 10138 10139 ---------------------------------- 10140 -- Check_Form_Of_Interface_Name -- 10141 ---------------------------------- 10142 10143 procedure Check_Form_Of_Interface_Name (SN : Node_Id) is 10144 S : constant String_Id := Strval (Expr_Value_S (SN)); 10145 SL : constant Nat := String_Length (S); 10146 C : Char_Code; 10147 10148 begin 10149 if SL = 0 then 10150 Error_Msg_N ("interface name cannot be null string", SN); 10151 end if; 10152 10153 for J in 1 .. SL loop 10154 C := Get_String_Char (S, J); 10155 10156 -- Look for dubious character and issue unconditional warning. 10157 -- Definitely dubious if not in character range. 10158 10159 if not In_Character_Range (C) 10160 10161 -- Commas, spaces and (back)slashes are dubious 10162 10163 or else Get_Character (C) = ',' 10164 or else Get_Character (C) = '\' 10165 or else Get_Character (C) = ' ' 10166 or else Get_Character (C) = '/' 10167 then 10168 Error_Msg 10169 ("??interface name contains illegal character", 10170 Sloc (SN) + Source_Ptr (J)); 10171 end if; 10172 end loop; 10173 end Check_Form_Of_Interface_Name; 10174 10175 -- Start of processing for Process_Interface_Name 10176 10177 begin 10178 -- If we are looking at a pragma that comes from an aspect then it 10179 -- needs to have its corresponding aspect argument expressions 10180 -- analyzed in addition to the generated pragma so that aspects 10181 -- within generic units get properly resolved. 10182 10183 if Present (Prag) and then From_Aspect_Specification (Prag) then 10184 declare 10185 Asp : constant Node_Id := Corresponding_Aspect (Prag); 10186 Dummy_1 : Node_Id; 10187 Dummy_2 : Node_Id; 10188 Dummy_3 : Node_Id; 10189 EN : Node_Id; 10190 LN : Node_Id; 10191 10192 begin 10193 -- Obtain all interfacing aspects used to construct the pragma 10194 10195 Get_Interfacing_Aspects 10196 (Asp, Dummy_1, EN, Dummy_2, Dummy_3, LN); 10197 10198 -- Analyze the expression of aspect External_Name 10199 10200 if Present (EN) then 10201 Analyze (Expression (EN)); 10202 end if; 10203 10204 -- Analyze the expressio of aspect Link_Name 10205 10206 if Present (LN) then 10207 Analyze (Expression (LN)); 10208 end if; 10209 end; 10210 end if; 10211 10212 if No (Link_Arg) then 10213 if No (Ext_Arg) then 10214 return; 10215 10216 elsif Chars (Ext_Arg) = Name_Link_Name then 10217 Ext_Nam := Empty; 10218 Link_Nam := Expression (Ext_Arg); 10219 10220 else 10221 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 10222 Ext_Nam := Expression (Ext_Arg); 10223 Link_Nam := Empty; 10224 end if; 10225 10226 else 10227 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 10228 Check_Optional_Identifier (Link_Arg, Name_Link_Name); 10229 Ext_Nam := Expression (Ext_Arg); 10230 Link_Nam := Expression (Link_Arg); 10231 end if; 10232 10233 -- Check expressions for external name and link name are static 10234 10235 if Present (Ext_Nam) then 10236 Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String); 10237 Check_Form_Of_Interface_Name (Ext_Nam); 10238 10239 -- Verify that external name is not the name of a local entity, 10240 -- which would hide the imported one and could lead to run-time 10241 -- surprises. The problem can only arise for entities declared in 10242 -- a package body (otherwise the external name is fully qualified 10243 -- and will not conflict). 10244 10245 declare 10246 Nam : Name_Id; 10247 E : Entity_Id; 10248 Par : Node_Id; 10249 10250 begin 10251 if Prag_Id = Pragma_Import then 10252 Nam := String_To_Name (Strval (Expr_Value_S (Ext_Nam))); 10253 E := Entity_Id (Get_Name_Table_Int (Nam)); 10254 10255 if Nam /= Chars (Subprogram_Def) 10256 and then Present (E) 10257 and then not Is_Overloadable (E) 10258 and then Is_Immediately_Visible (E) 10259 and then not Is_Imported (E) 10260 and then Ekind (Scope (E)) = E_Package 10261 then 10262 Par := Parent (E); 10263 while Present (Par) loop 10264 if Nkind (Par) = N_Package_Body then 10265 Error_Msg_Sloc := Sloc (E); 10266 Error_Msg_NE 10267 ("imported entity is hidden by & declared#", 10268 Ext_Arg, E); 10269 exit; 10270 end if; 10271 10272 Par := Parent (Par); 10273 end loop; 10274 end if; 10275 end if; 10276 end; 10277 end if; 10278 10279 if Present (Link_Nam) then 10280 Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String); 10281 Check_Form_Of_Interface_Name (Link_Nam); 10282 end if; 10283 10284 -- If there is no link name, just set the external name 10285 10286 if No (Link_Nam) then 10287 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); 10288 10289 -- For the Link_Name case, the given literal is preceded by an 10290 -- asterisk, which indicates to GCC that the given name should be 10291 -- taken literally, and in particular that no prepending of 10292 -- underlines should occur, even in systems where this is the 10293 -- normal default. 10294 10295 else 10296 Start_String; 10297 Store_String_Char (Get_Char_Code ('*')); 10298 String_Val := Strval (Expr_Value_S (Link_Nam)); 10299 Store_String_Chars (String_Val); 10300 Link_Nam := 10301 Make_String_Literal (Sloc (Link_Nam), 10302 Strval => End_String); 10303 end if; 10304 10305 -- Set the interface name. If the entity is a generic instance, use 10306 -- its alias, which is the callable entity. 10307 10308 if Is_Generic_Instance (Subprogram_Def) then 10309 Set_Encoded_Interface_Name 10310 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); 10311 else 10312 Set_Encoded_Interface_Name 10313 (Get_Base_Subprogram (Subprogram_Def), Link_Nam); 10314 end if; 10315 10316 Check_Duplicated_Export_Name (Link_Nam); 10317 end Process_Interface_Name; 10318 10319 ----------------------------------------- 10320 -- Process_Interrupt_Or_Attach_Handler -- 10321 ----------------------------------------- 10322 10323 procedure Process_Interrupt_Or_Attach_Handler is 10324 Handler : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1)); 10325 Prot_Typ : constant Entity_Id := Scope (Handler); 10326 10327 begin 10328 -- A pragma that applies to a Ghost entity becomes Ghost for the 10329 -- purposes of legality checks and removal of ignored Ghost code. 10330 10331 Mark_Ghost_Pragma (N, Handler); 10332 Set_Is_Interrupt_Handler (Handler); 10333 10334 pragma Assert (Ekind (Prot_Typ) = E_Protected_Type); 10335 10336 Record_Rep_Item (Prot_Typ, N); 10337 10338 -- Chain the pragma on the contract for completeness 10339 10340 Add_Contract_Item (N, Handler); 10341 end Process_Interrupt_Or_Attach_Handler; 10342 10343 -------------------------------------------------- 10344 -- Process_Restrictions_Or_Restriction_Warnings -- 10345 -------------------------------------------------- 10346 10347 -- Note: some of the simple identifier cases were handled in par-prag, 10348 -- but it is harmless (and more straightforward) to simply handle all 10349 -- cases here, even if it means we repeat a bit of work in some cases. 10350 10351 procedure Process_Restrictions_Or_Restriction_Warnings 10352 (Warn : Boolean) 10353 is 10354 Arg : Node_Id; 10355 R_Id : Restriction_Id; 10356 Id : Name_Id; 10357 Expr : Node_Id; 10358 Val : Uint; 10359 10360 begin 10361 -- Ignore all Restrictions pragmas in CodePeer mode 10362 10363 if CodePeer_Mode then 10364 return; 10365 end if; 10366 10367 Check_Ada_83_Warning; 10368 Check_At_Least_N_Arguments (1); 10369 Check_Valid_Configuration_Pragma; 10370 10371 Arg := Arg1; 10372 while Present (Arg) loop 10373 Id := Chars (Arg); 10374 Expr := Get_Pragma_Arg (Arg); 10375 10376 -- Case of no restriction identifier present 10377 10378 if Id = No_Name then 10379 if Nkind (Expr) /= N_Identifier then 10380 Error_Pragma_Arg 10381 ("invalid form for restriction", Arg); 10382 end if; 10383 10384 R_Id := 10385 Get_Restriction_Id 10386 (Process_Restriction_Synonyms (Expr)); 10387 10388 if R_Id not in All_Boolean_Restrictions then 10389 Error_Msg_Name_1 := Pname; 10390 Error_Msg_N 10391 ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); 10392 10393 -- Check for possible misspelling 10394 10395 for J in Restriction_Id loop 10396 declare 10397 Rnm : constant String := Restriction_Id'Image (J); 10398 10399 begin 10400 Name_Buffer (1 .. Rnm'Length) := Rnm; 10401 Name_Len := Rnm'Length; 10402 Set_Casing (All_Lower_Case); 10403 10404 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then 10405 Set_Casing 10406 (Identifier_Casing 10407 (Source_Index (Current_Sem_Unit))); 10408 Error_Msg_String (1 .. Rnm'Length) := 10409 Name_Buffer (1 .. Name_Len); 10410 Error_Msg_Strlen := Rnm'Length; 10411 Error_Msg_N -- CODEFIX 10412 ("\possible misspelling of ""~""", 10413 Get_Pragma_Arg (Arg)); 10414 exit; 10415 end if; 10416 end; 10417 end loop; 10418 10419 raise Pragma_Exit; 10420 end if; 10421 10422 if Implementation_Restriction (R_Id) then 10423 Check_Restriction (No_Implementation_Restrictions, Arg); 10424 end if; 10425 10426 -- Special processing for No_Elaboration_Code restriction 10427 10428 if R_Id = No_Elaboration_Code then 10429 10430 -- Restriction is only recognized within a configuration 10431 -- pragma file, or within a unit of the main extended 10432 -- program. Note: the test for Main_Unit is needed to 10433 -- properly include the case of configuration pragma files. 10434 10435 if not (Current_Sem_Unit = Main_Unit 10436 or else In_Extended_Main_Source_Unit (N)) 10437 then 10438 return; 10439 10440 -- Don't allow in a subunit unless already specified in 10441 -- body or spec. 10442 10443 elsif Nkind (Parent (N)) = N_Compilation_Unit 10444 and then Nkind (Unit (Parent (N))) = N_Subunit 10445 and then not Restriction_Active (No_Elaboration_Code) 10446 then 10447 Error_Msg_N 10448 ("invalid specification of ""No_Elaboration_Code""", 10449 N); 10450 Error_Msg_N 10451 ("\restriction cannot be specified in a subunit", N); 10452 Error_Msg_N 10453 ("\unless also specified in body or spec", N); 10454 return; 10455 10456 -- If we accept a No_Elaboration_Code restriction, then it 10457 -- needs to be added to the configuration restriction set so 10458 -- that we get proper application to other units in the main 10459 -- extended source as required. 10460 10461 else 10462 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 10463 end if; 10464 end if; 10465 10466 -- If this is a warning, then set the warning unless we already 10467 -- have a real restriction active (we never want a warning to 10468 -- override a real restriction). 10469 10470 if Warn then 10471 if not Restriction_Active (R_Id) then 10472 Set_Restriction (R_Id, N); 10473 Restriction_Warnings (R_Id) := True; 10474 end if; 10475 10476 -- If real restriction case, then set it and make sure that the 10477 -- restriction warning flag is off, since a real restriction 10478 -- always overrides a warning. 10479 10480 else 10481 Set_Restriction (R_Id, N); 10482 Restriction_Warnings (R_Id) := False; 10483 end if; 10484 10485 -- Check for obsolescent restrictions in Ada 2005 mode 10486 10487 if not Warn 10488 and then Ada_Version >= Ada_2005 10489 and then (R_Id = No_Asynchronous_Control 10490 or else 10491 R_Id = No_Unchecked_Deallocation 10492 or else 10493 R_Id = No_Unchecked_Conversion) 10494 then 10495 Check_Restriction (No_Obsolescent_Features, N); 10496 end if; 10497 10498 -- A very special case that must be processed here: pragma 10499 -- Restrictions (No_Exceptions) turns off all run-time 10500 -- checking. This is a bit dubious in terms of the formal 10501 -- language definition, but it is what is intended by RM 10502 -- H.4(12). Restriction_Warnings never affects generated code 10503 -- so this is done only in the real restriction case. 10504 10505 -- Atomic_Synchronization is not a real check, so it is not 10506 -- affected by this processing). 10507 10508 -- Ignore the effect of pragma Restrictions (No_Exceptions) on 10509 -- run-time checks in CodePeer and GNATprove modes: we want to 10510 -- generate checks for analysis purposes, as set respectively 10511 -- by -gnatC and -gnatd.F 10512 10513 if not Warn 10514 and then not (CodePeer_Mode or GNATprove_Mode) 10515 and then R_Id = No_Exceptions 10516 then 10517 for J in Scope_Suppress.Suppress'Range loop 10518 if J /= Atomic_Synchronization then 10519 Scope_Suppress.Suppress (J) := True; 10520 end if; 10521 end loop; 10522 end if; 10523 10524 -- Case of No_Dependence => unit-name. Note that the parser 10525 -- already made the necessary entry in the No_Dependence table. 10526 10527 elsif Id = Name_No_Dependence then 10528 if not OK_No_Dependence_Unit_Name (Expr) then 10529 raise Pragma_Exit; 10530 end if; 10531 10532 -- Case of No_Specification_Of_Aspect => aspect-identifier 10533 10534 elsif Id = Name_No_Specification_Of_Aspect then 10535 declare 10536 A_Id : Aspect_Id; 10537 10538 begin 10539 if Nkind (Expr) /= N_Identifier then 10540 A_Id := No_Aspect; 10541 else 10542 A_Id := Get_Aspect_Id (Chars (Expr)); 10543 end if; 10544 10545 if A_Id = No_Aspect then 10546 Error_Pragma_Arg ("invalid restriction name", Arg); 10547 else 10548 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); 10549 end if; 10550 end; 10551 10552 -- Case of No_Use_Of_Attribute => attribute-identifier 10553 10554 elsif Id = Name_No_Use_Of_Attribute then 10555 if Nkind (Expr) /= N_Identifier 10556 or else not Is_Attribute_Name (Chars (Expr)) 10557 then 10558 Error_Msg_N ("unknown attribute name??", Expr); 10559 10560 else 10561 Set_Restriction_No_Use_Of_Attribute (Expr, Warn); 10562 end if; 10563 10564 -- Case of No_Use_Of_Entity => fully-qualified-name 10565 10566 elsif Id = Name_No_Use_Of_Entity then 10567 10568 -- Restriction is only recognized within a configuration 10569 -- pragma file, or within a unit of the main extended 10570 -- program. Note: the test for Main_Unit is needed to 10571 -- properly include the case of configuration pragma files. 10572 10573 if Current_Sem_Unit = Main_Unit 10574 or else In_Extended_Main_Source_Unit (N) 10575 then 10576 if not OK_No_Dependence_Unit_Name (Expr) then 10577 Error_Msg_N ("wrong form for entity name", Expr); 10578 else 10579 Set_Restriction_No_Use_Of_Entity 10580 (Expr, Warn, No_Profile); 10581 end if; 10582 end if; 10583 10584 -- Case of No_Use_Of_Pragma => pragma-identifier 10585 10586 elsif Id = Name_No_Use_Of_Pragma then 10587 if Nkind (Expr) /= N_Identifier 10588 or else not Is_Pragma_Name (Chars (Expr)) 10589 then 10590 Error_Msg_N ("unknown pragma name??", Expr); 10591 else 10592 Set_Restriction_No_Use_Of_Pragma (Expr, Warn); 10593 end if; 10594 10595 -- All other cases of restriction identifier present 10596 10597 else 10598 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); 10599 Analyze_And_Resolve (Expr, Any_Integer); 10600 10601 if R_Id not in All_Parameter_Restrictions then 10602 Error_Pragma_Arg 10603 ("invalid restriction parameter identifier", Arg); 10604 10605 elsif not Is_OK_Static_Expression (Expr) then 10606 Flag_Non_Static_Expr 10607 ("value must be static expression!", Expr); 10608 raise Pragma_Exit; 10609 10610 elsif not Is_Integer_Type (Etype (Expr)) 10611 or else Expr_Value (Expr) < 0 10612 then 10613 Error_Pragma_Arg 10614 ("value must be non-negative integer", Arg); 10615 end if; 10616 10617 -- Restriction pragma is active 10618 10619 Val := Expr_Value (Expr); 10620 10621 if not UI_Is_In_Int_Range (Val) then 10622 Error_Pragma_Arg 10623 ("pragma ignored, value too large??", Arg); 10624 end if; 10625 10626 -- Warning case. If the real restriction is active, then we 10627 -- ignore the request, since warning never overrides a real 10628 -- restriction. Otherwise we set the proper warning. Note that 10629 -- this circuit sets the warning again if it is already set, 10630 -- which is what we want, since the constant may have changed. 10631 10632 if Warn then 10633 if not Restriction_Active (R_Id) then 10634 Set_Restriction 10635 (R_Id, N, Integer (UI_To_Int (Val))); 10636 Restriction_Warnings (R_Id) := True; 10637 end if; 10638 10639 -- Real restriction case, set restriction and make sure warning 10640 -- flag is off since real restriction always overrides warning. 10641 10642 else 10643 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); 10644 Restriction_Warnings (R_Id) := False; 10645 end if; 10646 end if; 10647 10648 Next (Arg); 10649 end loop; 10650 end Process_Restrictions_Or_Restriction_Warnings; 10651 10652 --------------------------------- 10653 -- Process_Suppress_Unsuppress -- 10654 --------------------------------- 10655 10656 -- Note: this procedure makes entries in the check suppress data 10657 -- structures managed by Sem. See spec of package Sem for full 10658 -- details on how we handle recording of check suppression. 10659 10660 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is 10661 C : Check_Id; 10662 E : Entity_Id; 10663 E_Id : Node_Id; 10664 10665 In_Package_Spec : constant Boolean := 10666 Is_Package_Or_Generic_Package (Current_Scope) 10667 and then not In_Package_Body (Current_Scope); 10668 10669 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); 10670 -- Used to suppress a single check on the given entity 10671 10672 -------------------------------- 10673 -- Suppress_Unsuppress_Echeck -- 10674 -------------------------------- 10675 10676 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is 10677 begin 10678 -- Check for error of trying to set atomic synchronization for 10679 -- a non-atomic variable. 10680 10681 if C = Atomic_Synchronization 10682 and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) 10683 then 10684 Error_Msg_N 10685 ("pragma & requires atomic type or variable", 10686 Pragma_Identifier (Original_Node (N))); 10687 end if; 10688 10689 Set_Checks_May_Be_Suppressed (E); 10690 10691 if In_Package_Spec then 10692 Push_Global_Suppress_Stack_Entry 10693 (Entity => E, 10694 Check => C, 10695 Suppress => Suppress_Case); 10696 else 10697 Push_Local_Suppress_Stack_Entry 10698 (Entity => E, 10699 Check => C, 10700 Suppress => Suppress_Case); 10701 end if; 10702 10703 -- If this is a first subtype, and the base type is distinct, 10704 -- then also set the suppress flags on the base type. 10705 10706 if Is_First_Subtype (E) and then Etype (E) /= E then 10707 Suppress_Unsuppress_Echeck (Etype (E), C); 10708 end if; 10709 end Suppress_Unsuppress_Echeck; 10710 10711 -- Start of processing for Process_Suppress_Unsuppress 10712 10713 begin 10714 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes 10715 -- on user code: we want to generate checks for analysis purposes, as 10716 -- set respectively by -gnatC and -gnatd.F 10717 10718 if Comes_From_Source (N) 10719 and then (CodePeer_Mode or GNATprove_Mode) 10720 then 10721 return; 10722 end if; 10723 10724 -- Suppress/Unsuppress can appear as a configuration pragma, or in a 10725 -- declarative part or a package spec (RM 11.5(5)). 10726 10727 if not Is_Configuration_Pragma then 10728 Check_Is_In_Decl_Part_Or_Package_Spec; 10729 end if; 10730 10731 Check_At_Least_N_Arguments (1); 10732 Check_At_Most_N_Arguments (2); 10733 Check_No_Identifier (Arg1); 10734 Check_Arg_Is_Identifier (Arg1); 10735 10736 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); 10737 10738 if C = No_Check_Id then 10739 Error_Pragma_Arg 10740 ("argument of pragma% is not valid check name", Arg1); 10741 end if; 10742 10743 -- Warn that suppress of Elaboration_Check has no effect in SPARK 10744 10745 if C = Elaboration_Check and then SPARK_Mode = On then 10746 Error_Pragma_Arg 10747 ("Suppress of Elaboration_Check ignored in SPARK??", 10748 "\elaboration checking rules are statically enforced " 10749 & "(SPARK RM 7.7)", Arg1); 10750 end if; 10751 10752 -- One-argument case 10753 10754 if Arg_Count = 1 then 10755 10756 -- Make an entry in the local scope suppress table. This is the 10757 -- table that directly shows the current value of the scope 10758 -- suppress check for any check id value. 10759 10760 if C = All_Checks then 10761 10762 -- For All_Checks, we set all specific predefined checks with 10763 -- the exception of Elaboration_Check, which is handled 10764 -- specially because of not wanting All_Checks to have the 10765 -- effect of deactivating static elaboration order processing. 10766 -- Atomic_Synchronization is also not affected, since this is 10767 -- not a real check. 10768 10769 for J in Scope_Suppress.Suppress'Range loop 10770 if J /= Elaboration_Check 10771 and then 10772 J /= Atomic_Synchronization 10773 then 10774 Scope_Suppress.Suppress (J) := Suppress_Case; 10775 end if; 10776 end loop; 10777 10778 -- If not All_Checks, and predefined check, then set appropriate 10779 -- scope entry. Note that we will set Elaboration_Check if this 10780 -- is explicitly specified. Atomic_Synchronization is allowed 10781 -- only if internally generated and entity is atomic. 10782 10783 elsif C in Predefined_Check_Id 10784 and then (not Comes_From_Source (N) 10785 or else C /= Atomic_Synchronization) 10786 then 10787 Scope_Suppress.Suppress (C) := Suppress_Case; 10788 end if; 10789 10790 -- Also make an entry in the Local_Entity_Suppress table 10791 10792 Push_Local_Suppress_Stack_Entry 10793 (Entity => Empty, 10794 Check => C, 10795 Suppress => Suppress_Case); 10796 10797 -- Case of two arguments present, where the check is suppressed for 10798 -- a specified entity (given as the second argument of the pragma) 10799 10800 else 10801 -- This is obsolescent in Ada 2005 mode 10802 10803 if Ada_Version >= Ada_2005 then 10804 Check_Restriction (No_Obsolescent_Features, Arg2); 10805 end if; 10806 10807 Check_Optional_Identifier (Arg2, Name_On); 10808 E_Id := Get_Pragma_Arg (Arg2); 10809 Analyze (E_Id); 10810 10811 if not Is_Entity_Name (E_Id) then 10812 Error_Pragma_Arg 10813 ("second argument of pragma% must be entity name", Arg2); 10814 end if; 10815 10816 E := Entity (E_Id); 10817 10818 if E = Any_Id then 10819 return; 10820 end if; 10821 10822 -- A pragma that applies to a Ghost entity becomes Ghost for the 10823 -- purposes of legality checks and removal of ignored Ghost code. 10824 10825 Mark_Ghost_Pragma (N, E); 10826 10827 -- Enforce RM 11.5(7) which requires that for a pragma that 10828 -- appears within a package spec, the named entity must be 10829 -- within the package spec. We allow the package name itself 10830 -- to be mentioned since that makes sense, although it is not 10831 -- strictly allowed by 11.5(7). 10832 10833 if In_Package_Spec 10834 and then E /= Current_Scope 10835 and then Scope (E) /= Current_Scope 10836 then 10837 Error_Pragma_Arg 10838 ("entity in pragma% is not in package spec (RM 11.5(7))", 10839 Arg2); 10840 end if; 10841 10842 -- Loop through homonyms. As noted below, in the case of a package 10843 -- spec, only homonyms within the package spec are considered. 10844 10845 loop 10846 Suppress_Unsuppress_Echeck (E, C); 10847 10848 if Is_Generic_Instance (E) 10849 and then Is_Subprogram (E) 10850 and then Present (Alias (E)) 10851 then 10852 Suppress_Unsuppress_Echeck (Alias (E), C); 10853 end if; 10854 10855 -- Move to next homonym if not aspect spec case 10856 10857 exit when From_Aspect_Specification (N); 10858 E := Homonym (E); 10859 exit when No (E); 10860 10861 -- If we are within a package specification, the pragma only 10862 -- applies to homonyms in the same scope. 10863 10864 exit when In_Package_Spec 10865 and then Scope (E) /= Current_Scope; 10866 end loop; 10867 end if; 10868 end Process_Suppress_Unsuppress; 10869 10870 ------------------------------- 10871 -- Record_Independence_Check -- 10872 ------------------------------- 10873 10874 procedure Record_Independence_Check (N : Node_Id; E : Entity_Id) is 10875 pragma Unreferenced (N, E); 10876 begin 10877 -- For GCC back ends the validation is done a priori 10878 -- ??? This code is dead, might be useful in the future 10879 10880 -- if not AAMP_On_Target then 10881 -- return; 10882 -- end if; 10883 10884 -- Independence_Checks.Append ((N, E)); 10885 10886 return; 10887 end Record_Independence_Check; 10888 10889 ------------------ 10890 -- Set_Exported -- 10891 ------------------ 10892 10893 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is 10894 begin 10895 if Is_Imported (E) then 10896 Error_Pragma_Arg 10897 ("cannot export entity& that was previously imported", Arg); 10898 10899 elsif Present (Address_Clause (E)) 10900 and then not Relaxed_RM_Semantics 10901 then 10902 Error_Pragma_Arg 10903 ("cannot export entity& that has an address clause", Arg); 10904 end if; 10905 10906 Set_Is_Exported (E); 10907 10908 -- Generate a reference for entity explicitly, because the 10909 -- identifier may be overloaded and name resolution will not 10910 -- generate one. 10911 10912 Generate_Reference (E, Arg); 10913 10914 -- Deal with exporting non-library level entity 10915 10916 if not Is_Library_Level_Entity (E) then 10917 10918 -- Not allowed at all for subprograms 10919 10920 if Is_Subprogram (E) then 10921 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); 10922 10923 -- Otherwise set public and statically allocated 10924 10925 else 10926 Set_Is_Public (E); 10927 Set_Is_Statically_Allocated (E); 10928 10929 -- Warn if the corresponding W flag is set 10930 10931 if Warn_On_Export_Import 10932 10933 -- Only do this for something that was in the source. Not 10934 -- clear if this can be False now (there used for sure to be 10935 -- cases on some systems where it was False), but anyway the 10936 -- test is harmless if not needed, so it is retained. 10937 10938 and then Comes_From_Source (Arg) 10939 then 10940 Error_Msg_NE 10941 ("?x?& has been made static as a result of Export", 10942 Arg, E); 10943 Error_Msg_N 10944 ("\?x?this usage is non-standard and non-portable", 10945 Arg); 10946 end if; 10947 end if; 10948 end if; 10949 10950 if Warn_On_Export_Import and then Is_Type (E) then 10951 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); 10952 end if; 10953 10954 if Warn_On_Export_Import and Inside_A_Generic then 10955 Error_Msg_NE 10956 ("all instances of& will have the same external name?x?", 10957 Arg, E); 10958 end if; 10959 end Set_Exported; 10960 10961 ---------------------------------------------- 10962 -- Set_Extended_Import_Export_External_Name -- 10963 ---------------------------------------------- 10964 10965 procedure Set_Extended_Import_Export_External_Name 10966 (Internal_Ent : Entity_Id; 10967 Arg_External : Node_Id) 10968 is 10969 Old_Name : constant Node_Id := Interface_Name (Internal_Ent); 10970 New_Name : Node_Id; 10971 10972 begin 10973 if No (Arg_External) then 10974 return; 10975 end if; 10976 10977 Check_Arg_Is_External_Name (Arg_External); 10978 10979 if Nkind (Arg_External) = N_String_Literal then 10980 if String_Length (Strval (Arg_External)) = 0 then 10981 return; 10982 else 10983 New_Name := Adjust_External_Name_Case (Arg_External); 10984 end if; 10985 10986 elsif Nkind (Arg_External) = N_Identifier then 10987 New_Name := Get_Default_External_Name (Arg_External); 10988 10989 -- Check_Arg_Is_External_Name should let through only identifiers and 10990 -- string literals or static string expressions (which are folded to 10991 -- string literals). 10992 10993 else 10994 raise Program_Error; 10995 end if; 10996 10997 -- If we already have an external name set (by a prior normal Import 10998 -- or Export pragma), then the external names must match 10999 11000 if Present (Interface_Name (Internal_Ent)) then 11001 11002 -- Ignore mismatching names in CodePeer mode, to support some 11003 -- old compilers which would export the same procedure under 11004 -- different names, e.g: 11005 -- procedure P; 11006 -- pragma Export_Procedure (P, "a"); 11007 -- pragma Export_Procedure (P, "b"); 11008 11009 if CodePeer_Mode then 11010 return; 11011 end if; 11012 11013 Check_Matching_Internal_Names : declare 11014 S1 : constant String_Id := Strval (Old_Name); 11015 S2 : constant String_Id := Strval (New_Name); 11016 11017 procedure Mismatch; 11018 pragma No_Return (Mismatch); 11019 -- Called if names do not match 11020 11021 -------------- 11022 -- Mismatch -- 11023 -------------- 11024 11025 procedure Mismatch is 11026 begin 11027 Error_Msg_Sloc := Sloc (Old_Name); 11028 Error_Pragma_Arg 11029 ("external name does not match that given #", 11030 Arg_External); 11031 end Mismatch; 11032 11033 -- Start of processing for Check_Matching_Internal_Names 11034 11035 begin 11036 if String_Length (S1) /= String_Length (S2) then 11037 Mismatch; 11038 11039 else 11040 for J in 1 .. String_Length (S1) loop 11041 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then 11042 Mismatch; 11043 end if; 11044 end loop; 11045 end if; 11046 end Check_Matching_Internal_Names; 11047 11048 -- Otherwise set the given name 11049 11050 else 11051 Set_Encoded_Interface_Name (Internal_Ent, New_Name); 11052 Check_Duplicated_Export_Name (New_Name); 11053 end if; 11054 end Set_Extended_Import_Export_External_Name; 11055 11056 ------------------ 11057 -- Set_Imported -- 11058 ------------------ 11059 11060 procedure Set_Imported (E : Entity_Id) is 11061 begin 11062 -- Error message if already imported or exported 11063 11064 if Is_Exported (E) or else Is_Imported (E) then 11065 11066 -- Error if being set Exported twice 11067 11068 if Is_Exported (E) then 11069 Error_Msg_NE ("entity& was previously exported", N, E); 11070 11071 -- Ignore error in CodePeer mode where we treat all imported 11072 -- subprograms as unknown. 11073 11074 elsif CodePeer_Mode then 11075 goto OK; 11076 11077 -- OK if Import/Interface case 11078 11079 elsif Import_Interface_Present (N) then 11080 goto OK; 11081 11082 -- Error if being set Imported twice 11083 11084 else 11085 Error_Msg_NE ("entity& was previously imported", N, E); 11086 end if; 11087 11088 Error_Msg_Name_1 := Pname; 11089 Error_Msg_N 11090 ("\(pragma% applies to all previous entities)", N); 11091 11092 Error_Msg_Sloc := Sloc (E); 11093 Error_Msg_NE ("\import not allowed for& declared#", N, E); 11094 11095 -- Here if not previously imported or exported, OK to import 11096 11097 else 11098 Set_Is_Imported (E); 11099 11100 -- For subprogram, set Import_Pragma field 11101 11102 if Is_Subprogram (E) then 11103 Set_Import_Pragma (E, N); 11104 end if; 11105 11106 -- If the entity is an object that is not at the library level, 11107 -- then it is statically allocated. We do not worry about objects 11108 -- with address clauses in this context since they are not really 11109 -- imported in the linker sense. 11110 11111 if Is_Object (E) 11112 and then not Is_Library_Level_Entity (E) 11113 and then No (Address_Clause (E)) 11114 then 11115 Set_Is_Statically_Allocated (E); 11116 end if; 11117 end if; 11118 11119 <<OK>> null; 11120 end Set_Imported; 11121 11122 ------------------------- 11123 -- Set_Mechanism_Value -- 11124 ------------------------- 11125 11126 -- Note: the mechanism name has not been analyzed (and cannot indeed be 11127 -- analyzed, since it is semantic nonsense), so we get it in the exact 11128 -- form created by the parser. 11129 11130 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is 11131 procedure Bad_Mechanism; 11132 pragma No_Return (Bad_Mechanism); 11133 -- Signal bad mechanism name 11134 11135 ------------------- 11136 -- Bad_Mechanism -- 11137 ------------------- 11138 11139 procedure Bad_Mechanism is 11140 begin 11141 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); 11142 end Bad_Mechanism; 11143 11144 -- Start of processing for Set_Mechanism_Value 11145 11146 begin 11147 if Mechanism (Ent) /= Default_Mechanism then 11148 Error_Msg_NE 11149 ("mechanism for & has already been set", Mech_Name, Ent); 11150 end if; 11151 11152 -- MECHANISM_NAME ::= value | reference 11153 11154 if Nkind (Mech_Name) = N_Identifier then 11155 if Chars (Mech_Name) = Name_Value then 11156 Set_Mechanism (Ent, By_Copy); 11157 return; 11158 11159 elsif Chars (Mech_Name) = Name_Reference then 11160 Set_Mechanism (Ent, By_Reference); 11161 return; 11162 11163 elsif Chars (Mech_Name) = Name_Copy then 11164 Error_Pragma_Arg 11165 ("bad mechanism name, Value assumed", Mech_Name); 11166 11167 else 11168 Bad_Mechanism; 11169 end if; 11170 11171 else 11172 Bad_Mechanism; 11173 end if; 11174 end Set_Mechanism_Value; 11175 11176 -------------------------- 11177 -- Set_Rational_Profile -- 11178 -------------------------- 11179 11180 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and 11181 -- extension to the semantics of renaming declarations. 11182 11183 procedure Set_Rational_Profile is 11184 begin 11185 Implicit_Packing := True; 11186 Overriding_Renamings := True; 11187 Use_VADS_Size := True; 11188 end Set_Rational_Profile; 11189 11190 --------------------------- 11191 -- Set_Ravenscar_Profile -- 11192 --------------------------- 11193 11194 -- The tasks to be done here are 11195 11196 -- Set required policies 11197 11198 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 11199 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles) 11200 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities) 11201 -- (For GNAT_Ravenscar_EDF profile) 11202 -- pragma Locking_Policy (Ceiling_Locking) 11203 11204 -- Set Detect_Blocking mode 11205 11206 -- Set required restrictions (see System.Rident for detailed list) 11207 11208 -- Set the No_Dependence rules 11209 -- No_Dependence => Ada.Asynchronous_Task_Control 11210 -- No_Dependence => Ada.Calendar 11211 -- No_Dependence => Ada.Execution_Time.Group_Budget 11212 -- No_Dependence => Ada.Execution_Time.Timers 11213 -- No_Dependence => Ada.Task_Attributes 11214 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 11215 11216 procedure Set_Ravenscar_Profile (Profile : Profile_Name; N : Node_Id) is 11217 procedure Set_Error_Msg_To_Profile_Name; 11218 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the 11219 -- profile. 11220 11221 ----------------------------------- 11222 -- Set_Error_Msg_To_Profile_Name -- 11223 ----------------------------------- 11224 11225 procedure Set_Error_Msg_To_Profile_Name is 11226 Prof_Nam : constant Node_Id := 11227 Get_Pragma_Arg 11228 (First (Pragma_Argument_Associations (N))); 11229 11230 begin 11231 Get_Name_String (Chars (Prof_Nam)); 11232 Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam)); 11233 Error_Msg_Strlen := Name_Len; 11234 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); 11235 end Set_Error_Msg_To_Profile_Name; 11236 11237 -- Local variables 11238 11239 Nod : Node_Id; 11240 Pref : Node_Id; 11241 Pref_Id : Node_Id; 11242 Sel_Id : Node_Id; 11243 11244 Profile_Dispatching_Policy : Character; 11245 11246 -- Start of processing for Set_Ravenscar_Profile 11247 11248 begin 11249 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities) 11250 11251 if Profile = GNAT_Ravenscar_EDF then 11252 Profile_Dispatching_Policy := 'E'; 11253 11254 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 11255 11256 else 11257 Profile_Dispatching_Policy := 'F'; 11258 end if; 11259 11260 if Task_Dispatching_Policy /= ' ' 11261 and then Task_Dispatching_Policy /= Profile_Dispatching_Policy 11262 then 11263 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 11264 Set_Error_Msg_To_Profile_Name; 11265 Error_Pragma ("Profile (~) incompatible with policy#"); 11266 11267 -- Set the FIFO_Within_Priorities policy, but always preserve 11268 -- System_Location since we like the error message with the run time 11269 -- name. 11270 11271 else 11272 Task_Dispatching_Policy := Profile_Dispatching_Policy; 11273 11274 if Task_Dispatching_Policy_Sloc /= System_Location then 11275 Task_Dispatching_Policy_Sloc := Loc; 11276 end if; 11277 end if; 11278 11279 -- pragma Locking_Policy (Ceiling_Locking) 11280 11281 if Locking_Policy /= ' ' 11282 and then Locking_Policy /= 'C' 11283 then 11284 Error_Msg_Sloc := Locking_Policy_Sloc; 11285 Set_Error_Msg_To_Profile_Name; 11286 Error_Pragma ("Profile (~) incompatible with policy#"); 11287 11288 -- Set the Ceiling_Locking policy, but preserve System_Location since 11289 -- we like the error message with the run time name. 11290 11291 else 11292 Locking_Policy := 'C'; 11293 11294 if Locking_Policy_Sloc /= System_Location then 11295 Locking_Policy_Sloc := Loc; 11296 end if; 11297 end if; 11298 11299 -- pragma Detect_Blocking 11300 11301 Detect_Blocking := True; 11302 11303 -- Set the corresponding restrictions 11304 11305 Set_Profile_Restrictions 11306 (Profile, N, Warn => Treat_Restrictions_As_Warnings); 11307 11308 -- Set the No_Dependence restrictions 11309 11310 -- The following No_Dependence restrictions: 11311 -- No_Dependence => Ada.Asynchronous_Task_Control 11312 -- No_Dependence => Ada.Calendar 11313 -- No_Dependence => Ada.Task_Attributes 11314 -- are already set by previous call to Set_Profile_Restrictions. 11315 11316 -- Set the following restrictions which were added to Ada 2005: 11317 -- No_Dependence => Ada.Execution_Time.Group_Budget 11318 -- No_Dependence => Ada.Execution_Time.Timers 11319 11320 if Ada_Version >= Ada_2005 then 11321 Pref_Id := Make_Identifier (Loc, Name_Find ("ada")); 11322 Sel_Id := Make_Identifier (Loc, Name_Find ("execution_time")); 11323 11324 Pref := 11325 Make_Selected_Component 11326 (Sloc => Loc, 11327 Prefix => Pref_Id, 11328 Selector_Name => Sel_Id); 11329 11330 Sel_Id := Make_Identifier (Loc, Name_Find ("group_budgets")); 11331 11332 Nod := 11333 Make_Selected_Component 11334 (Sloc => Loc, 11335 Prefix => Pref, 11336 Selector_Name => Sel_Id); 11337 11338 Set_Restriction_No_Dependence 11339 (Unit => Nod, 11340 Warn => Treat_Restrictions_As_Warnings, 11341 Profile => Ravenscar); 11342 11343 Sel_Id := Make_Identifier (Loc, Name_Find ("timers")); 11344 11345 Nod := 11346 Make_Selected_Component 11347 (Sloc => Loc, 11348 Prefix => Pref, 11349 Selector_Name => Sel_Id); 11350 11351 Set_Restriction_No_Dependence 11352 (Unit => Nod, 11353 Warn => Treat_Restrictions_As_Warnings, 11354 Profile => Ravenscar); 11355 end if; 11356 11357 -- Set the following restriction which was added to Ada 2012 (see 11358 -- AI-0171): 11359 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 11360 11361 if Ada_Version >= Ada_2012 then 11362 Pref_Id := Make_Identifier (Loc, Name_Find ("system")); 11363 Sel_Id := Make_Identifier (Loc, Name_Find ("multiprocessors")); 11364 11365 Pref := 11366 Make_Selected_Component 11367 (Sloc => Loc, 11368 Prefix => Pref_Id, 11369 Selector_Name => Sel_Id); 11370 11371 Sel_Id := Make_Identifier (Loc, Name_Find ("dispatching_domains")); 11372 11373 Nod := 11374 Make_Selected_Component 11375 (Sloc => Loc, 11376 Prefix => Pref, 11377 Selector_Name => Sel_Id); 11378 11379 Set_Restriction_No_Dependence 11380 (Unit => Nod, 11381 Warn => Treat_Restrictions_As_Warnings, 11382 Profile => Ravenscar); 11383 end if; 11384 end Set_Ravenscar_Profile; 11385 11386 ----------------------------------- 11387 -- Validate_Acc_Condition_Clause -- 11388 ----------------------------------- 11389 11390 procedure Validate_Acc_Condition_Clause (Clause : Node_Id) is 11391 begin 11392 Analyze_And_Resolve (Clause); 11393 11394 if not Is_Boolean_Type (Etype (Clause)) then 11395 Error_Pragma ("expected a boolean"); 11396 end if; 11397 end Validate_Acc_Condition_Clause; 11398 11399 ------------------------------ 11400 -- Validate_Acc_Data_Clause -- 11401 ------------------------------ 11402 11403 procedure Validate_Acc_Data_Clause (Clause : Node_Id) is 11404 Expr : Node_Id; 11405 11406 begin 11407 Expr := Acc_First (Clause); 11408 while Present (Expr) loop 11409 if Nkind (Expr) /= N_Identifier then 11410 Error_Pragma ("expected an identifer"); 11411 end if; 11412 11413 Analyze_And_Resolve (Expr); 11414 11415 Expr := Acc_Next (Expr); 11416 end loop; 11417 end Validate_Acc_Data_Clause; 11418 11419 ---------------------------------- 11420 -- Validate_Acc_Int_Expr_Clause -- 11421 ---------------------------------- 11422 11423 procedure Validate_Acc_Int_Expr_Clause (Clause : Node_Id) is 11424 begin 11425 Analyze_And_Resolve (Clause); 11426 11427 if not Is_Integer_Type (Etype (Clause)) then 11428 Error_Pragma_Arg ("expected an integer", Clause); 11429 end if; 11430 end Validate_Acc_Int_Expr_Clause; 11431 11432 --------------------------------------- 11433 -- Validate_Acc_Int_Expr_List_Clause -- 11434 --------------------------------------- 11435 11436 procedure Validate_Acc_Int_Expr_List_Clause (Clause : Node_Id) is 11437 Expr : Node_Id; 11438 11439 begin 11440 Expr := Acc_First (Clause); 11441 while Present (Expr) loop 11442 Analyze_And_Resolve (Expr); 11443 11444 if not Is_Integer_Type (Etype (Expr)) then 11445 Error_Pragma ("expected an integer"); 11446 end if; 11447 11448 Expr := Acc_Next (Expr); 11449 end loop; 11450 end Validate_Acc_Int_Expr_List_Clause; 11451 11452 -------------------------------- 11453 -- Validate_Acc_Loop_Collapse -- 11454 -------------------------------- 11455 11456 procedure Validate_Acc_Loop_Collapse (Clause : Node_Id) is 11457 Count : Uint; 11458 Par_Loop : Node_Id; 11459 Stmt : Node_Id; 11460 11461 begin 11462 -- Make sure the argument is a positive integer 11463 11464 Analyze_And_Resolve (Clause); 11465 11466 Count := Static_Integer (Clause); 11467 if Count = No_Uint or else Count < 1 then 11468 Error_Pragma_Arg ("expected a positive integer", Clause); 11469 end if; 11470 11471 -- Then, make sure we have at least Count-1 tightly-nested loops 11472 -- (i.e. loops with no statements in between). 11473 11474 Par_Loop := Parent (Parent (Parent (Clause))); 11475 Stmt := First (Statements (Par_Loop)); 11476 11477 -- Skip first pragmas in the parent loop 11478 11479 while Present (Stmt) and then Nkind (Stmt) = N_Pragma loop 11480 Next (Stmt); 11481 end loop; 11482 11483 if not Present (Next (Stmt)) then 11484 while Nkind (Stmt) = N_Loop_Statement and Count > 1 loop 11485 Stmt := First (Statements (Stmt)); 11486 exit when Present (Next (Stmt)); 11487 11488 Count := Count - 1; 11489 end loop; 11490 end if; 11491 11492 if Count > 1 then 11493 Error_Pragma_Arg 11494 ("Collapse argument too high or loops not tightly nested", 11495 Clause); 11496 end if; 11497 end Validate_Acc_Loop_Collapse; 11498 11499 ---------------------------- 11500 -- Validate_Acc_Loop_Gang -- 11501 ---------------------------- 11502 11503 procedure Validate_Acc_Loop_Gang (Clause : Node_Id) is 11504 begin 11505 Error_Pragma_Arg ("Loop_Gang not implemented", Clause); 11506 end Validate_Acc_Loop_Gang; 11507 11508 ------------------------------ 11509 -- Validate_Acc_Loop_Vector -- 11510 ------------------------------ 11511 11512 procedure Validate_Acc_Loop_Vector (Clause : Node_Id) is 11513 begin 11514 Error_Pragma_Arg ("Loop_Vector not implemented", Clause); 11515 end Validate_Acc_Loop_Vector; 11516 11517 ------------------------------- 11518 -- Validate_Acc_Loop_Worker -- 11519 ------------------------------- 11520 11521 procedure Validate_Acc_Loop_Worker (Clause : Node_Id) is 11522 begin 11523 Error_Pragma_Arg ("Loop_Worker not implemented", Clause); 11524 end Validate_Acc_Loop_Worker; 11525 11526 --------------------------------- 11527 -- Validate_Acc_Name_Reduction -- 11528 --------------------------------- 11529 11530 procedure Validate_Acc_Name_Reduction (Clause : Node_Id) is 11531 11532 -- ??? On top of the following operations, the OpenAcc spec adds the 11533 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and 11534 -- ".neqv" for Fortran. Can we, should we and how do we support them 11535 -- in Ada? 11536 11537 type Reduction_Op is (Add_Op, Mul_Op, Max_Op, Min_Op, And_Op, Or_Op); 11538 11539 function To_Reduction_Op (Op : String) return Reduction_Op; 11540 -- Convert operator Op described by a String into its corresponding 11541 -- enumeration value. 11542 11543 --------------------- 11544 -- To_Reduction_Op -- 11545 --------------------- 11546 11547 function To_Reduction_Op (Op : String) return Reduction_Op is 11548 begin 11549 if Op = "+" then 11550 return Add_Op; 11551 11552 elsif Op = "*" then 11553 return Mul_Op; 11554 11555 elsif Op = "max" then 11556 return Max_Op; 11557 11558 elsif Op = "min" then 11559 return Min_Op; 11560 11561 elsif Op = "and" then 11562 return And_Op; 11563 11564 elsif Op = "or" then 11565 return Or_Op; 11566 11567 else 11568 Error_Pragma ("unsuported reduction operation"); 11569 end if; 11570 end To_Reduction_Op; 11571 11572 -- Local variables 11573 11574 Seen : constant Elist_Id := New_Elmt_List; 11575 11576 Expr : Node_Id; 11577 Reduc_Op : Node_Id; 11578 Reduc_Var : Node_Id; 11579 11580 -- Start of processing for Validate_Acc_Name_Reduction 11581 11582 begin 11583 -- Reduction operations appear in the following form: 11584 -- ("+" => (a, b), "*" => c) 11585 11586 Expr := First (Component_Associations (Clause)); 11587 while Present (Expr) loop 11588 Reduc_Op := First (Choices (Expr)); 11589 String_To_Name_Buffer (Strval (Reduc_Op)); 11590 11591 case To_Reduction_Op (Name_Buffer (1 .. Name_Len)) is 11592 when Add_Op 11593 | Mul_Op 11594 | Max_Op 11595 | Min_Op 11596 => 11597 Reduc_Var := Acc_First (Expression (Expr)); 11598 while Present (Reduc_Var) loop 11599 Analyze_And_Resolve (Reduc_Var); 11600 11601 if Contains (Seen, Entity (Reduc_Var)) then 11602 Error_Pragma ("variable used in multiple reductions"); 11603 11604 else 11605 if Nkind (Reduc_Var) /= N_Identifier 11606 or not Is_Numeric_Type (Etype (Reduc_Var)) 11607 then 11608 Error_Pragma 11609 ("expected an identifier for a Numeric"); 11610 end if; 11611 11612 Append_Elmt (Entity (Reduc_Var), Seen); 11613 end if; 11614 11615 Reduc_Var := Acc_Next (Reduc_Var); 11616 end loop; 11617 11618 when And_Op 11619 | Or_Op 11620 => 11621 Reduc_Var := Acc_First (Expression (Expr)); 11622 while Present (Reduc_Var) loop 11623 Analyze_And_Resolve (Reduc_Var); 11624 11625 if Contains (Seen, Entity (Reduc_Var)) then 11626 Error_Pragma ("variable used in multiple reductions"); 11627 11628 else 11629 if Nkind (Reduc_Var) /= N_Identifier 11630 or not Is_Boolean_Type (Etype (Reduc_Var)) 11631 then 11632 Error_Pragma 11633 ("expected a variable of type boolean"); 11634 end if; 11635 11636 Append_Elmt (Entity (Reduc_Var), Seen); 11637 end if; 11638 11639 Reduc_Var := Acc_Next (Reduc_Var); 11640 end loop; 11641 end case; 11642 11643 Next (Expr); 11644 end loop; 11645 end Validate_Acc_Name_Reduction; 11646 11647 ----------------------------------- 11648 -- Validate_Acc_Size_Expressions -- 11649 ----------------------------------- 11650 11651 procedure Validate_Acc_Size_Expressions (Clause : Node_Id) is 11652 function Validate_Size_Expr (Expr : Node_Id) return Boolean; 11653 -- A size expr is either an integer expression or "*" 11654 11655 ------------------------ 11656 -- Validate_Size_Expr -- 11657 ------------------------ 11658 11659 function Validate_Size_Expr (Expr : Node_Id) return Boolean is 11660 begin 11661 if Nkind (Expr) = N_Operator_Symbol then 11662 return Get_String_Char (Strval (Expr), 1) = Get_Char_Code ('*'); 11663 end if; 11664 11665 Analyze_And_Resolve (Expr); 11666 11667 return Is_Integer_Type (Etype (Expr)); 11668 end Validate_Size_Expr; 11669 11670 -- Local variables 11671 11672 Expr : Node_Id; 11673 11674 -- Start of processing for Validate_Acc_Size_Expressions 11675 11676 begin 11677 Expr := Acc_First (Clause); 11678 while Present (Expr) loop 11679 if not Validate_Size_Expr (Expr) then 11680 Error_Pragma 11681 ("Size expressions should be either integers or '*'"); 11682 end if; 11683 11684 Expr := Acc_Next (Expr); 11685 end loop; 11686 end Validate_Acc_Size_Expressions; 11687 11688 -- Start of processing for Analyze_Pragma 11689 11690 begin 11691 -- The following code is a defense against recursion. Not clear that 11692 -- this can happen legitimately, but perhaps some error situations can 11693 -- cause it, and we did see this recursion during testing. 11694 11695 if Analyzed (N) then 11696 return; 11697 else 11698 Set_Analyzed (N); 11699 end if; 11700 11701 Check_Restriction_No_Use_Of_Pragma (N); 11702 11703 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma 11704 -- Default_Scalar_Storage_Order if the -gnatI switch was given. 11705 11706 if Should_Ignore_Pragma_Sem (N) 11707 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order 11708 and then Ignore_Rep_Clauses) 11709 then 11710 return; 11711 end if; 11712 11713 -- Deal with unrecognized pragma 11714 11715 if not Is_Pragma_Name (Pname) then 11716 if Warn_On_Unrecognized_Pragma then 11717 Error_Msg_Name_1 := Pname; 11718 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N)); 11719 11720 for PN in First_Pragma_Name .. Last_Pragma_Name loop 11721 if Is_Bad_Spelling_Of (Pname, PN) then 11722 Error_Msg_Name_1 := PN; 11723 Error_Msg_N -- CODEFIX 11724 ("\?g?possible misspelling of %!", Pragma_Identifier (N)); 11725 exit; 11726 end if; 11727 end loop; 11728 end if; 11729 11730 return; 11731 end if; 11732 11733 -- Here to start processing for recognized pragma 11734 11735 Pname := Original_Aspect_Pragma_Name (N); 11736 11737 -- Capture setting of Opt.Uneval_Old 11738 11739 case Opt.Uneval_Old is 11740 when 'A' => 11741 Set_Uneval_Old_Accept (N); 11742 11743 when 'E' => 11744 null; 11745 11746 when 'W' => 11747 Set_Uneval_Old_Warn (N); 11748 11749 when others => 11750 raise Program_Error; 11751 end case; 11752 11753 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored 11754 -- is already set, indicating that we have already checked the policy 11755 -- at the right point. This happens for example in the case of a pragma 11756 -- that is derived from an Aspect. 11757 11758 if Is_Ignored (N) or else Is_Checked (N) then 11759 null; 11760 11761 -- For a pragma that is a rewriting of another pragma, copy the 11762 -- Is_Checked/Is_Ignored status from the rewritten pragma. 11763 11764 elsif Is_Rewrite_Substitution (N) 11765 and then Nkind (Original_Node (N)) = N_Pragma 11766 then 11767 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 11768 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 11769 11770 -- Otherwise query the applicable policy at this point 11771 11772 else 11773 Check_Applicable_Policy (N); 11774 11775 -- If pragma is disabled, rewrite as NULL and skip analysis 11776 11777 if Is_Disabled (N) then 11778 Rewrite (N, Make_Null_Statement (Loc)); 11779 Analyze (N); 11780 raise Pragma_Exit; 11781 end if; 11782 end if; 11783 11784 -- Preset arguments 11785 11786 Arg_Count := 0; 11787 Arg1 := Empty; 11788 Arg2 := Empty; 11789 Arg3 := Empty; 11790 Arg4 := Empty; 11791 11792 if Present (Pragma_Argument_Associations (N)) then 11793 Arg_Count := List_Length (Pragma_Argument_Associations (N)); 11794 Arg1 := First (Pragma_Argument_Associations (N)); 11795 11796 if Present (Arg1) then 11797 Arg2 := Next (Arg1); 11798 11799 if Present (Arg2) then 11800 Arg3 := Next (Arg2); 11801 11802 if Present (Arg3) then 11803 Arg4 := Next (Arg3); 11804 end if; 11805 end if; 11806 end if; 11807 end if; 11808 11809 -- An enumeration type defines the pragmas that are supported by the 11810 -- implementation. Get_Pragma_Id (in package Prag) transforms a name 11811 -- into the corresponding enumeration value for the following case. 11812 11813 case Prag_Id is 11814 11815 ----------------- 11816 -- Abort_Defer -- 11817 ----------------- 11818 11819 -- pragma Abort_Defer; 11820 11821 when Pragma_Abort_Defer => 11822 GNAT_Pragma; 11823 Check_Arg_Count (0); 11824 11825 -- The only required semantic processing is to check the 11826 -- placement. This pragma must appear at the start of the 11827 -- statement sequence of a handled sequence of statements. 11828 11829 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 11830 or else N /= First (Statements (Parent (N))) 11831 then 11832 Pragma_Misplaced; 11833 end if; 11834 11835 -------------------- 11836 -- Abstract_State -- 11837 -------------------- 11838 11839 -- pragma Abstract_State (ABSTRACT_STATE_LIST); 11840 11841 -- ABSTRACT_STATE_LIST ::= 11842 -- null 11843 -- | STATE_NAME_WITH_OPTIONS 11844 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS}) 11845 11846 -- STATE_NAME_WITH_OPTIONS ::= 11847 -- STATE_NAME 11848 -- | (STATE_NAME with OPTION_LIST) 11849 11850 -- OPTION_LIST ::= OPTION {, OPTION} 11851 11852 -- OPTION ::= 11853 -- SIMPLE_OPTION 11854 -- | NAME_VALUE_OPTION 11855 11856 -- SIMPLE_OPTION ::= Ghost | Synchronous 11857 11858 -- NAME_VALUE_OPTION ::= 11859 -- Part_Of => ABSTRACT_STATE 11860 -- | External [=> EXTERNAL_PROPERTY_LIST] 11861 11862 -- EXTERNAL_PROPERTY_LIST ::= 11863 -- EXTERNAL_PROPERTY 11864 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY}) 11865 11866 -- EXTERNAL_PROPERTY ::= 11867 -- Async_Readers [=> boolean_EXPRESSION] 11868 -- | Async_Writers [=> boolean_EXPRESSION] 11869 -- | Effective_Reads [=> boolean_EXPRESSION] 11870 -- | Effective_Writes [=> boolean_EXPRESSION] 11871 -- others => boolean_EXPRESSION 11872 11873 -- STATE_NAME ::= defining_identifier 11874 11875 -- ABSTRACT_STATE ::= name 11876 11877 -- Characteristics: 11878 11879 -- * Analysis - The annotation is fully analyzed immediately upon 11880 -- elaboration as it cannot forward reference entities. 11881 11882 -- * Expansion - None. 11883 11884 -- * Template - The annotation utilizes the generic template of the 11885 -- related package declaration. 11886 11887 -- * Globals - The annotation cannot reference global entities. 11888 11889 -- * Instance - The annotation is instantiated automatically when 11890 -- the related generic package is instantiated. 11891 11892 when Pragma_Abstract_State => Abstract_State : declare 11893 Missing_Parentheses : Boolean := False; 11894 -- Flag set when a state declaration with options is not properly 11895 -- parenthesized. 11896 11897 -- Flags used to verify the consistency of states 11898 11899 Non_Null_Seen : Boolean := False; 11900 Null_Seen : Boolean := False; 11901 11902 procedure Analyze_Abstract_State 11903 (State : Node_Id; 11904 Pack_Id : Entity_Id); 11905 -- Verify the legality of a single state declaration. Create and 11906 -- decorate a state abstraction entity and introduce it into the 11907 -- visibility chain. Pack_Id denotes the entity or the related 11908 -- package where pragma Abstract_State appears. 11909 11910 procedure Malformed_State_Error (State : Node_Id); 11911 -- Emit an error concerning the illegal declaration of abstract 11912 -- state State. This routine diagnoses syntax errors that lead to 11913 -- a different parse tree. The error is issued regardless of the 11914 -- SPARK mode in effect. 11915 11916 ---------------------------- 11917 -- Analyze_Abstract_State -- 11918 ---------------------------- 11919 11920 procedure Analyze_Abstract_State 11921 (State : Node_Id; 11922 Pack_Id : Entity_Id) 11923 is 11924 -- Flags used to verify the consistency of options 11925 11926 AR_Seen : Boolean := False; 11927 AW_Seen : Boolean := False; 11928 ER_Seen : Boolean := False; 11929 EW_Seen : Boolean := False; 11930 External_Seen : Boolean := False; 11931 Ghost_Seen : Boolean := False; 11932 Others_Seen : Boolean := False; 11933 Part_Of_Seen : Boolean := False; 11934 Synchronous_Seen : Boolean := False; 11935 11936 -- Flags used to store the static value of all external states' 11937 -- expressions. 11938 11939 AR_Val : Boolean := False; 11940 AW_Val : Boolean := False; 11941 ER_Val : Boolean := False; 11942 EW_Val : Boolean := False; 11943 11944 State_Id : Entity_Id := Empty; 11945 -- The entity to be generated for the current state declaration 11946 11947 procedure Analyze_External_Option (Opt : Node_Id); 11948 -- Verify the legality of option External 11949 11950 procedure Analyze_External_Property 11951 (Prop : Node_Id; 11952 Expr : Node_Id := Empty); 11953 -- Verify the legailty of a single external property. Prop 11954 -- denotes the external property. Expr is the expression used 11955 -- to set the property. 11956 11957 procedure Analyze_Part_Of_Option (Opt : Node_Id); 11958 -- Verify the legality of option Part_Of 11959 11960 procedure Check_Duplicate_Option 11961 (Opt : Node_Id; 11962 Status : in out Boolean); 11963 -- Flag Status denotes whether a particular option has been 11964 -- seen while processing a state. This routine verifies that 11965 -- Opt is not a duplicate option and sets the flag Status 11966 -- (SPARK RM 7.1.4(1)). 11967 11968 procedure Check_Duplicate_Property 11969 (Prop : Node_Id; 11970 Status : in out Boolean); 11971 -- Flag Status denotes whether a particular property has been 11972 -- seen while processing option External. This routine verifies 11973 -- that Prop is not a duplicate property and sets flag Status. 11974 -- Opt is not a duplicate property and sets the flag Status. 11975 -- (SPARK RM 7.1.4(2)) 11976 11977 procedure Check_Ghost_Synchronous; 11978 -- Ensure that the abstract state is not subject to both Ghost 11979 -- and Synchronous simple options. Emit an error if this is the 11980 -- case. 11981 11982 procedure Create_Abstract_State 11983 (Nam : Name_Id; 11984 Decl : Node_Id; 11985 Loc : Source_Ptr; 11986 Is_Null : Boolean); 11987 -- Generate an abstract state entity with name Nam and enter it 11988 -- into visibility. Decl is the "declaration" of the state as 11989 -- it appears in pragma Abstract_State. Loc is the location of 11990 -- the related state "declaration". Flag Is_Null should be set 11991 -- when the associated Abstract_State pragma defines a null 11992 -- state. 11993 11994 ----------------------------- 11995 -- Analyze_External_Option -- 11996 ----------------------------- 11997 11998 procedure Analyze_External_Option (Opt : Node_Id) is 11999 Errors : constant Nat := Serious_Errors_Detected; 12000 Prop : Node_Id; 12001 Props : Node_Id := Empty; 12002 12003 begin 12004 if Nkind (Opt) = N_Component_Association then 12005 Props := Expression (Opt); 12006 end if; 12007 12008 -- External state with properties 12009 12010 if Present (Props) then 12011 12012 -- Multiple properties appear as an aggregate 12013 12014 if Nkind (Props) = N_Aggregate then 12015 12016 -- Simple property form 12017 12018 Prop := First (Expressions (Props)); 12019 while Present (Prop) loop 12020 Analyze_External_Property (Prop); 12021 Next (Prop); 12022 end loop; 12023 12024 -- Property with expression form 12025 12026 Prop := First (Component_Associations (Props)); 12027 while Present (Prop) loop 12028 Analyze_External_Property 12029 (Prop => First (Choices (Prop)), 12030 Expr => Expression (Prop)); 12031 12032 Next (Prop); 12033 end loop; 12034 12035 -- Single property 12036 12037 else 12038 Analyze_External_Property (Props); 12039 end if; 12040 12041 -- An external state defined without any properties defaults 12042 -- all properties to True. 12043 12044 else 12045 AR_Val := True; 12046 AW_Val := True; 12047 ER_Val := True; 12048 EW_Val := True; 12049 end if; 12050 12051 -- Once all external properties have been processed, verify 12052 -- their mutual interaction. Do not perform the check when 12053 -- at least one of the properties is illegal as this will 12054 -- produce a bogus error. 12055 12056 if Errors = Serious_Errors_Detected then 12057 Check_External_Properties 12058 (State, AR_Val, AW_Val, ER_Val, EW_Val); 12059 end if; 12060 end Analyze_External_Option; 12061 12062 ------------------------------- 12063 -- Analyze_External_Property -- 12064 ------------------------------- 12065 12066 procedure Analyze_External_Property 12067 (Prop : Node_Id; 12068 Expr : Node_Id := Empty) 12069 is 12070 Expr_Val : Boolean; 12071 12072 begin 12073 -- Check the placement of "others" (if available) 12074 12075 if Nkind (Prop) = N_Others_Choice then 12076 if Others_Seen then 12077 SPARK_Msg_N 12078 ("only one others choice allowed in option External", 12079 Prop); 12080 else 12081 Others_Seen := True; 12082 end if; 12083 12084 elsif Others_Seen then 12085 SPARK_Msg_N 12086 ("others must be the last property in option External", 12087 Prop); 12088 12089 -- The only remaining legal options are the four predefined 12090 -- external properties. 12091 12092 elsif Nkind (Prop) = N_Identifier 12093 and then Nam_In (Chars (Prop), Name_Async_Readers, 12094 Name_Async_Writers, 12095 Name_Effective_Reads, 12096 Name_Effective_Writes) 12097 then 12098 null; 12099 12100 -- Otherwise the construct is not a valid property 12101 12102 else 12103 SPARK_Msg_N ("invalid external state property", Prop); 12104 return; 12105 end if; 12106 12107 -- Ensure that the expression of the external state property 12108 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)). 12109 12110 if Present (Expr) then 12111 Analyze_And_Resolve (Expr, Standard_Boolean); 12112 12113 if Is_OK_Static_Expression (Expr) then 12114 Expr_Val := Is_True (Expr_Value (Expr)); 12115 else 12116 SPARK_Msg_N 12117 ("expression of external state property must be " 12118 & "static", Expr); 12119 return; 12120 end if; 12121 12122 -- The lack of expression defaults the property to True 12123 12124 else 12125 Expr_Val := True; 12126 end if; 12127 12128 -- Named properties 12129 12130 if Nkind (Prop) = N_Identifier then 12131 if Chars (Prop) = Name_Async_Readers then 12132 Check_Duplicate_Property (Prop, AR_Seen); 12133 AR_Val := Expr_Val; 12134 12135 elsif Chars (Prop) = Name_Async_Writers then 12136 Check_Duplicate_Property (Prop, AW_Seen); 12137 AW_Val := Expr_Val; 12138 12139 elsif Chars (Prop) = Name_Effective_Reads then 12140 Check_Duplicate_Property (Prop, ER_Seen); 12141 ER_Val := Expr_Val; 12142 12143 else 12144 Check_Duplicate_Property (Prop, EW_Seen); 12145 EW_Val := Expr_Val; 12146 end if; 12147 12148 -- The handling of property "others" must take into account 12149 -- all other named properties that have been encountered so 12150 -- far. Only those that have not been seen are affected by 12151 -- "others". 12152 12153 else 12154 if not AR_Seen then 12155 AR_Val := Expr_Val; 12156 end if; 12157 12158 if not AW_Seen then 12159 AW_Val := Expr_Val; 12160 end if; 12161 12162 if not ER_Seen then 12163 ER_Val := Expr_Val; 12164 end if; 12165 12166 if not EW_Seen then 12167 EW_Val := Expr_Val; 12168 end if; 12169 end if; 12170 end Analyze_External_Property; 12171 12172 ---------------------------- 12173 -- Analyze_Part_Of_Option -- 12174 ---------------------------- 12175 12176 procedure Analyze_Part_Of_Option (Opt : Node_Id) is 12177 Encap : constant Node_Id := Expression (Opt); 12178 Constits : Elist_Id; 12179 Encap_Id : Entity_Id; 12180 Legal : Boolean; 12181 12182 begin 12183 Check_Duplicate_Option (Opt, Part_Of_Seen); 12184 12185 Analyze_Part_Of 12186 (Indic => First (Choices (Opt)), 12187 Item_Id => State_Id, 12188 Encap => Encap, 12189 Encap_Id => Encap_Id, 12190 Legal => Legal); 12191 12192 -- The Part_Of indicator transforms the abstract state into 12193 -- a constituent of the encapsulating state or single 12194 -- concurrent type. 12195 12196 if Legal then 12197 pragma Assert (Present (Encap_Id)); 12198 Constits := Part_Of_Constituents (Encap_Id); 12199 12200 if No (Constits) then 12201 Constits := New_Elmt_List; 12202 Set_Part_Of_Constituents (Encap_Id, Constits); 12203 end if; 12204 12205 Append_Elmt (State_Id, Constits); 12206 Set_Encapsulating_State (State_Id, Encap_Id); 12207 end if; 12208 end Analyze_Part_Of_Option; 12209 12210 ---------------------------- 12211 -- Check_Duplicate_Option -- 12212 ---------------------------- 12213 12214 procedure Check_Duplicate_Option 12215 (Opt : Node_Id; 12216 Status : in out Boolean) 12217 is 12218 begin 12219 if Status then 12220 SPARK_Msg_N ("duplicate state option", Opt); 12221 end if; 12222 12223 Status := True; 12224 end Check_Duplicate_Option; 12225 12226 ------------------------------ 12227 -- Check_Duplicate_Property -- 12228 ------------------------------ 12229 12230 procedure Check_Duplicate_Property 12231 (Prop : Node_Id; 12232 Status : in out Boolean) 12233 is 12234 begin 12235 if Status then 12236 SPARK_Msg_N ("duplicate external property", Prop); 12237 end if; 12238 12239 Status := True; 12240 end Check_Duplicate_Property; 12241 12242 ----------------------------- 12243 -- Check_Ghost_Synchronous -- 12244 ----------------------------- 12245 12246 procedure Check_Ghost_Synchronous is 12247 begin 12248 -- A synchronized abstract state cannot be Ghost and vice 12249 -- versa (SPARK RM 6.9(19)). 12250 12251 if Ghost_Seen and Synchronous_Seen then 12252 SPARK_Msg_N ("synchronized state cannot be ghost", State); 12253 end if; 12254 end Check_Ghost_Synchronous; 12255 12256 --------------------------- 12257 -- Create_Abstract_State -- 12258 --------------------------- 12259 12260 procedure Create_Abstract_State 12261 (Nam : Name_Id; 12262 Decl : Node_Id; 12263 Loc : Source_Ptr; 12264 Is_Null : Boolean) 12265 is 12266 begin 12267 -- The abstract state may be semi-declared when the related 12268 -- package was withed through a limited with clause. In that 12269 -- case reuse the entity to fully declare the state. 12270 12271 if Present (Decl) and then Present (Entity (Decl)) then 12272 State_Id := Entity (Decl); 12273 12274 -- Otherwise the elaboration of pragma Abstract_State 12275 -- declares the state. 12276 12277 else 12278 State_Id := Make_Defining_Identifier (Loc, Nam); 12279 12280 if Present (Decl) then 12281 Set_Entity (Decl, State_Id); 12282 end if; 12283 end if; 12284 12285 -- Null states never come from source 12286 12287 Set_Comes_From_Source (State_Id, not Is_Null); 12288 Set_Parent (State_Id, State); 12289 Set_Ekind (State_Id, E_Abstract_State); 12290 Set_Etype (State_Id, Standard_Void_Type); 12291 Set_Encapsulating_State (State_Id, Empty); 12292 12293 -- Set the SPARK mode from the current context 12294 12295 Set_SPARK_Pragma (State_Id, SPARK_Mode_Pragma); 12296 Set_SPARK_Pragma_Inherited (State_Id); 12297 12298 -- An abstract state declared within a Ghost region becomes 12299 -- Ghost (SPARK RM 6.9(2)). 12300 12301 if Ghost_Mode > None or else Is_Ghost_Entity (Pack_Id) then 12302 Set_Is_Ghost_Entity (State_Id); 12303 end if; 12304 12305 -- Establish a link between the state declaration and the 12306 -- abstract state entity. Note that a null state remains as 12307 -- N_Null and does not carry any linkages. 12308 12309 if not Is_Null then 12310 if Present (Decl) then 12311 Set_Entity (Decl, State_Id); 12312 Set_Etype (Decl, Standard_Void_Type); 12313 end if; 12314 12315 -- Every non-null state must be defined, nameable and 12316 -- resolvable. 12317 12318 Push_Scope (Pack_Id); 12319 Generate_Definition (State_Id); 12320 Enter_Name (State_Id); 12321 Pop_Scope; 12322 end if; 12323 end Create_Abstract_State; 12324 12325 -- Local variables 12326 12327 Opt : Node_Id; 12328 Opt_Nam : Node_Id; 12329 12330 -- Start of processing for Analyze_Abstract_State 12331 12332 begin 12333 -- A package with a null abstract state is not allowed to 12334 -- declare additional states. 12335 12336 if Null_Seen then 12337 SPARK_Msg_NE 12338 ("package & has null abstract state", State, Pack_Id); 12339 12340 -- Null states appear as internally generated entities 12341 12342 elsif Nkind (State) = N_Null then 12343 Create_Abstract_State 12344 (Nam => New_Internal_Name ('S'), 12345 Decl => Empty, 12346 Loc => Sloc (State), 12347 Is_Null => True); 12348 Null_Seen := True; 12349 12350 -- Catch a case where a null state appears in a list of 12351 -- non-null states. 12352 12353 if Non_Null_Seen then 12354 SPARK_Msg_NE 12355 ("package & has non-null abstract state", 12356 State, Pack_Id); 12357 end if; 12358 12359 -- Simple state declaration 12360 12361 elsif Nkind (State) = N_Identifier then 12362 Create_Abstract_State 12363 (Nam => Chars (State), 12364 Decl => State, 12365 Loc => Sloc (State), 12366 Is_Null => False); 12367 Non_Null_Seen := True; 12368 12369 -- State declaration with various options. This construct 12370 -- appears as an extension aggregate in the tree. 12371 12372 elsif Nkind (State) = N_Extension_Aggregate then 12373 if Nkind (Ancestor_Part (State)) = N_Identifier then 12374 Create_Abstract_State 12375 (Nam => Chars (Ancestor_Part (State)), 12376 Decl => Ancestor_Part (State), 12377 Loc => Sloc (Ancestor_Part (State)), 12378 Is_Null => False); 12379 Non_Null_Seen := True; 12380 else 12381 SPARK_Msg_N 12382 ("state name must be an identifier", 12383 Ancestor_Part (State)); 12384 end if; 12385 12386 -- Options External, Ghost and Synchronous appear as 12387 -- expressions. 12388 12389 Opt := First (Expressions (State)); 12390 while Present (Opt) loop 12391 if Nkind (Opt) = N_Identifier then 12392 12393 -- External 12394 12395 if Chars (Opt) = Name_External then 12396 Check_Duplicate_Option (Opt, External_Seen); 12397 Analyze_External_Option (Opt); 12398 12399 -- Ghost 12400 12401 elsif Chars (Opt) = Name_Ghost then 12402 Check_Duplicate_Option (Opt, Ghost_Seen); 12403 Check_Ghost_Synchronous; 12404 12405 if Present (State_Id) then 12406 Set_Is_Ghost_Entity (State_Id); 12407 end if; 12408 12409 -- Synchronous 12410 12411 elsif Chars (Opt) = Name_Synchronous then 12412 Check_Duplicate_Option (Opt, Synchronous_Seen); 12413 Check_Ghost_Synchronous; 12414 12415 -- Option Part_Of without an encapsulating state is 12416 -- illegal (SPARK RM 7.1.4(8)). 12417 12418 elsif Chars (Opt) = Name_Part_Of then 12419 SPARK_Msg_N 12420 ("indicator Part_Of must denote abstract state, " 12421 & "single protected type or single task type", 12422 Opt); 12423 12424 -- Do not emit an error message when a previous state 12425 -- declaration with options was not parenthesized as 12426 -- the option is actually another state declaration. 12427 -- 12428 -- with Abstract_State 12429 -- (State_1 with ..., -- missing parentheses 12430 -- (State_2 with ...), 12431 -- State_3) -- ok state declaration 12432 12433 elsif Missing_Parentheses then 12434 null; 12435 12436 -- Otherwise the option is not allowed. Note that it 12437 -- is not possible to distinguish between an option 12438 -- and a state declaration when a previous state with 12439 -- options not properly parentheses. 12440 -- 12441 -- with Abstract_State 12442 -- (State_1 with ..., -- missing parentheses 12443 -- State_2); -- could be an option 12444 12445 else 12446 SPARK_Msg_N 12447 ("simple option not allowed in state declaration", 12448 Opt); 12449 end if; 12450 12451 -- Catch a case where missing parentheses around a state 12452 -- declaration with options cause a subsequent state 12453 -- declaration with options to be treated as an option. 12454 -- 12455 -- with Abstract_State 12456 -- (State_1 with ..., -- missing parentheses 12457 -- (State_2 with ...)) 12458 12459 elsif Nkind (Opt) = N_Extension_Aggregate then 12460 Missing_Parentheses := True; 12461 SPARK_Msg_N 12462 ("state declaration must be parenthesized", 12463 Ancestor_Part (State)); 12464 12465 -- Otherwise the option is malformed 12466 12467 else 12468 SPARK_Msg_N ("malformed option", Opt); 12469 end if; 12470 12471 Next (Opt); 12472 end loop; 12473 12474 -- Options External and Part_Of appear as component 12475 -- associations. 12476 12477 Opt := First (Component_Associations (State)); 12478 while Present (Opt) loop 12479 Opt_Nam := First (Choices (Opt)); 12480 12481 if Nkind (Opt_Nam) = N_Identifier then 12482 if Chars (Opt_Nam) = Name_External then 12483 Analyze_External_Option (Opt); 12484 12485 elsif Chars (Opt_Nam) = Name_Part_Of then 12486 Analyze_Part_Of_Option (Opt); 12487 12488 else 12489 SPARK_Msg_N ("invalid state option", Opt); 12490 end if; 12491 else 12492 SPARK_Msg_N ("invalid state option", Opt); 12493 end if; 12494 12495 Next (Opt); 12496 end loop; 12497 12498 -- Any other attempt to declare a state is illegal 12499 12500 else 12501 Malformed_State_Error (State); 12502 return; 12503 end if; 12504 12505 -- Guard against a junk state. In such cases no entity is 12506 -- generated and the subsequent checks cannot be applied. 12507 12508 if Present (State_Id) then 12509 12510 -- Verify whether the state does not introduce an illegal 12511 -- hidden state within a package subject to a null abstract 12512 -- state. 12513 12514 Check_No_Hidden_State (State_Id); 12515 12516 -- Check whether the lack of option Part_Of agrees with the 12517 -- placement of the abstract state with respect to the state 12518 -- space. 12519 12520 if not Part_Of_Seen then 12521 Check_Missing_Part_Of (State_Id); 12522 end if; 12523 12524 -- Associate the state with its related package 12525 12526 if No (Abstract_States (Pack_Id)) then 12527 Set_Abstract_States (Pack_Id, New_Elmt_List); 12528 end if; 12529 12530 Append_Elmt (State_Id, Abstract_States (Pack_Id)); 12531 end if; 12532 end Analyze_Abstract_State; 12533 12534 --------------------------- 12535 -- Malformed_State_Error -- 12536 --------------------------- 12537 12538 procedure Malformed_State_Error (State : Node_Id) is 12539 begin 12540 Error_Msg_N ("malformed abstract state declaration", State); 12541 12542 -- An abstract state with a simple option is being declared 12543 -- with "=>" rather than the legal "with". The state appears 12544 -- as a component association. 12545 12546 if Nkind (State) = N_Component_Association then 12547 Error_Msg_N ("\use WITH to specify simple option", State); 12548 end if; 12549 end Malformed_State_Error; 12550 12551 -- Local variables 12552 12553 Pack_Decl : Node_Id; 12554 Pack_Id : Entity_Id; 12555 State : Node_Id; 12556 States : Node_Id; 12557 12558 -- Start of processing for Abstract_State 12559 12560 begin 12561 GNAT_Pragma; 12562 Check_No_Identifiers; 12563 Check_Arg_Count (1); 12564 12565 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 12566 12567 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 12568 N_Package_Declaration) 12569 then 12570 Pragma_Misplaced; 12571 return; 12572 end if; 12573 12574 Pack_Id := Defining_Entity (Pack_Decl); 12575 12576 -- A pragma that applies to a Ghost entity becomes Ghost for the 12577 -- purposes of legality checks and removal of ignored Ghost code. 12578 12579 Mark_Ghost_Pragma (N, Pack_Id); 12580 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id)); 12581 12582 -- Chain the pragma on the contract for completeness 12583 12584 Add_Contract_Item (N, Pack_Id); 12585 12586 -- The legality checks of pragmas Abstract_State, Initializes, and 12587 -- Initial_Condition are affected by the SPARK mode in effect. In 12588 -- addition, these three pragmas are subject to an inherent order: 12589 12590 -- 1) Abstract_State 12591 -- 2) Initializes 12592 -- 3) Initial_Condition 12593 12594 -- Analyze all these pragmas in the order outlined above 12595 12596 Analyze_If_Present (Pragma_SPARK_Mode); 12597 States := Expression (Get_Argument (N, Pack_Id)); 12598 12599 -- Multiple non-null abstract states appear as an aggregate 12600 12601 if Nkind (States) = N_Aggregate then 12602 State := First (Expressions (States)); 12603 while Present (State) loop 12604 Analyze_Abstract_State (State, Pack_Id); 12605 Next (State); 12606 end loop; 12607 12608 -- An abstract state with a simple option is being illegaly 12609 -- declared with "=>" rather than "with". In this case the 12610 -- state declaration appears as a component association. 12611 12612 if Present (Component_Associations (States)) then 12613 State := First (Component_Associations (States)); 12614 while Present (State) loop 12615 Malformed_State_Error (State); 12616 Next (State); 12617 end loop; 12618 end if; 12619 12620 -- Various forms of a single abstract state. Note that these may 12621 -- include malformed state declarations. 12622 12623 else 12624 Analyze_Abstract_State (States, Pack_Id); 12625 end if; 12626 12627 Analyze_If_Present (Pragma_Initializes); 12628 Analyze_If_Present (Pragma_Initial_Condition); 12629 end Abstract_State; 12630 12631 -------------- 12632 -- Acc_Data -- 12633 -------------- 12634 12635 when Pragma_Acc_Data => Acc_Data : declare 12636 Clause_Names : constant Name_List := 12637 (Name_Attach, 12638 Name_Copy, 12639 Name_Copy_In, 12640 Name_Copy_Out, 12641 Name_Create, 12642 Name_Delete, 12643 Name_Detach, 12644 Name_Device_Ptr, 12645 Name_No_Create, 12646 Name_Present); 12647 12648 Clause : Node_Id; 12649 Clauses : Args_List (Clause_Names'Range); 12650 12651 begin 12652 if not OpenAcc_Enabled then 12653 return; 12654 end if; 12655 12656 GNAT_Pragma; 12657 12658 if Nkind (Parent (N)) /= N_Loop_Statement then 12659 Error_Pragma 12660 ("Acc_Data pragma should be placed in loop or block " 12661 & "statements"); 12662 end if; 12663 12664 Gather_Associations (Clause_Names, Clauses); 12665 12666 for Id in Clause_Names'First .. Clause_Names'Last loop 12667 Clause := Clauses (Id); 12668 12669 if Present (Clause) then 12670 case Clause_Names (Id) is 12671 when Name_Copy 12672 | Name_Copy_In 12673 | Name_Copy_Out 12674 | Name_Create 12675 | Name_Device_Ptr 12676 | Name_Present 12677 => 12678 Validate_Acc_Data_Clause (Clause); 12679 12680 when Name_Attach 12681 | Name_Detach 12682 | Name_Delete 12683 | Name_No_Create 12684 => 12685 Error_Pragma ("unsupported pragma clause"); 12686 12687 when others => 12688 raise Program_Error; 12689 end case; 12690 end if; 12691 end loop; 12692 12693 Set_Is_OpenAcc_Environment (Parent (N)); 12694 end Acc_Data; 12695 12696 -------------- 12697 -- Acc_Loop -- 12698 -------------- 12699 12700 when Pragma_Acc_Loop => Acc_Loop : declare 12701 Clause_Names : constant Name_List := 12702 (Name_Auto, 12703 Name_Collapse, 12704 Name_Gang, 12705 Name_Independent, 12706 Name_Acc_Private, 12707 Name_Reduction, 12708 Name_Seq, 12709 Name_Tile, 12710 Name_Vector, 12711 Name_Worker); 12712 12713 Clause : Node_Id; 12714 Clauses : Args_List (Clause_Names'Range); 12715 Par : Node_Id; 12716 12717 begin 12718 if not OpenAcc_Enabled then 12719 return; 12720 end if; 12721 12722 GNAT_Pragma; 12723 12724 -- Make sure the pragma is in an openacc construct 12725 12726 Check_Loop_Pragma_Placement; 12727 12728 Par := Parent (N); 12729 while Present (Par) 12730 and then (Nkind (Par) /= N_Loop_Statement 12731 or else not Is_OpenAcc_Environment (Par)) 12732 loop 12733 Par := Parent (Par); 12734 end loop; 12735 12736 if not Is_OpenAcc_Environment (Par) then 12737 Error_Pragma 12738 ("Acc_Loop directive must be associated with an OpenAcc " 12739 & "construct region"); 12740 end if; 12741 12742 Gather_Associations (Clause_Names, Clauses); 12743 12744 for Id in Clause_Names'First .. Clause_Names'Last loop 12745 Clause := Clauses (Id); 12746 12747 if Present (Clause) then 12748 case Clause_Names (Id) is 12749 when Name_Auto 12750 | Name_Independent 12751 | Name_Seq 12752 => 12753 null; 12754 12755 when Name_Collapse => 12756 Validate_Acc_Loop_Collapse (Clause); 12757 12758 when Name_Gang => 12759 Validate_Acc_Loop_Gang (Clause); 12760 12761 when Name_Acc_Private => 12762 Validate_Acc_Data_Clause (Clause); 12763 12764 when Name_Reduction => 12765 Validate_Acc_Name_Reduction (Clause); 12766 12767 when Name_Tile => 12768 Validate_Acc_Size_Expressions (Clause); 12769 12770 when Name_Vector => 12771 Validate_Acc_Loop_Vector (Clause); 12772 12773 when Name_Worker => 12774 Validate_Acc_Loop_Worker (Clause); 12775 12776 when others => 12777 raise Program_Error; 12778 end case; 12779 end if; 12780 end loop; 12781 12782 Set_Is_OpenAcc_Loop (Parent (N)); 12783 end Acc_Loop; 12784 12785 ---------------------------------- 12786 -- Acc_Parallel and Acc_Kernels -- 12787 ---------------------------------- 12788 12789 when Pragma_Acc_Parallel 12790 | Pragma_Acc_Kernels 12791 => 12792 Acc_Kernels_Or_Parallel : declare 12793 Clause_Names : constant Name_List := 12794 (Name_Acc_If, 12795 Name_Async, 12796 Name_Copy, 12797 Name_Copy_In, 12798 Name_Copy_Out, 12799 Name_Create, 12800 Name_Default, 12801 Name_Device_Ptr, 12802 Name_Device_Type, 12803 Name_Num_Gangs, 12804 Name_Num_Workers, 12805 Name_Present, 12806 Name_Vector_Length, 12807 Name_Wait, 12808 12809 -- Parallel only 12810 12811 Name_Acc_Private, 12812 Name_First_Private, 12813 Name_Reduction, 12814 12815 -- Kernels only 12816 12817 Name_Attach, 12818 Name_No_Create); 12819 12820 Clause : Node_Id; 12821 Clauses : Args_List (Clause_Names'Range); 12822 12823 begin 12824 if not OpenAcc_Enabled then 12825 return; 12826 end if; 12827 12828 GNAT_Pragma; 12829 Check_Loop_Pragma_Placement; 12830 12831 if Nkind (Parent (N)) /= N_Loop_Statement then 12832 Error_Pragma 12833 ("pragma should be placed in loop or block statements"); 12834 end if; 12835 12836 Gather_Associations (Clause_Names, Clauses); 12837 12838 for Id in Clause_Names'First .. Clause_Names'Last loop 12839 Clause := Clauses (Id); 12840 12841 if Present (Clause) then 12842 if Chars (Parent (Clause)) = No_Name then 12843 Error_Pragma ("all arguments should be associations"); 12844 else 12845 case Clause_Names (Id) is 12846 12847 -- Note: According to the OpenAcc Standard v2.6, 12848 -- Async's argument should be optional. Because this 12849 -- complicates parsing the clause, the argument is 12850 -- made mandatory. The standard defines two negative 12851 -- values, acc_async_noval and acc_async_sync. When 12852 -- given acc_async_noval as value, the clause should 12853 -- behave as if no argument was given. According to 12854 -- the standard, acc_async_noval is defined in header 12855 -- files for C and Fortran, thus this value should 12856 -- probably be defined in the OpenAcc Ada library once 12857 -- it is implemented. 12858 12859 when Name_Async 12860 | Name_Num_Gangs 12861 | Name_Num_Workers 12862 | Name_Vector_Length 12863 => 12864 Validate_Acc_Int_Expr_Clause (Clause); 12865 12866 when Name_Acc_If => 12867 Validate_Acc_Condition_Clause (Clause); 12868 12869 -- Unsupported by GCC 12870 12871 when Name_Attach 12872 | Name_No_Create 12873 => 12874 Error_Pragma ("unsupported clause"); 12875 12876 when Name_Acc_Private 12877 | Name_First_Private 12878 => 12879 if Prag_Id /= Pragma_Acc_Parallel then 12880 Error_Pragma 12881 ("argument is only available for 'Parallel' " 12882 & "construct"); 12883 else 12884 Validate_Acc_Data_Clause (Clause); 12885 end if; 12886 12887 when Name_Copy 12888 | Name_Copy_In 12889 | Name_Copy_Out 12890 | Name_Create 12891 | Name_Device_Ptr 12892 | Name_Present 12893 => 12894 Validate_Acc_Data_Clause (Clause); 12895 12896 when Name_Reduction => 12897 if Prag_Id /= Pragma_Acc_Parallel then 12898 Error_Pragma 12899 ("argument is only available for 'Parallel' " 12900 & "construct"); 12901 else 12902 Validate_Acc_Name_Reduction (Clause); 12903 end if; 12904 12905 when Name_Default => 12906 if Chars (Clause) /= Name_None then 12907 Error_Pragma ("expected none"); 12908 end if; 12909 12910 when Name_Device_Type => 12911 Error_Pragma ("unsupported pragma clause"); 12912 12913 -- Similar to Name_Async, Name_Wait's arguments should 12914 -- be optional. However, this can be simulated using 12915 -- acc_async_noval, hence, we do not bother making the 12916 -- argument optional for now. 12917 12918 when Name_Wait => 12919 Validate_Acc_Int_Expr_List_Clause (Clause); 12920 12921 when others => 12922 raise Program_Error; 12923 end case; 12924 end if; 12925 end if; 12926 end loop; 12927 12928 Set_Is_OpenAcc_Environment (Parent (N)); 12929 end Acc_Kernels_Or_Parallel; 12930 12931 ------------ 12932 -- Ada_83 -- 12933 ------------ 12934 12935 -- pragma Ada_83; 12936 12937 -- Note: this pragma also has some specific processing in Par.Prag 12938 -- because we want to set the Ada version mode during parsing. 12939 12940 when Pragma_Ada_83 => 12941 GNAT_Pragma; 12942 Check_Arg_Count (0); 12943 12944 -- We really should check unconditionally for proper configuration 12945 -- pragma placement, since we really don't want mixed Ada modes 12946 -- within a single unit, and the GNAT reference manual has always 12947 -- said this was a configuration pragma, but we did not check and 12948 -- are hesitant to add the check now. 12949 12950 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 12951 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 12952 -- or Ada 2012 mode. 12953 12954 if Ada_Version >= Ada_2005 then 12955 Check_Valid_Configuration_Pragma; 12956 end if; 12957 12958 -- Now set Ada 83 mode 12959 12960 if Latest_Ada_Only then 12961 Error_Pragma ("??pragma% ignored"); 12962 else 12963 Ada_Version := Ada_83; 12964 Ada_Version_Explicit := Ada_83; 12965 Ada_Version_Pragma := N; 12966 end if; 12967 12968 ------------ 12969 -- Ada_95 -- 12970 ------------ 12971 12972 -- pragma Ada_95; 12973 12974 -- Note: this pragma also has some specific processing in Par.Prag 12975 -- because we want to set the Ada 83 version mode during parsing. 12976 12977 when Pragma_Ada_95 => 12978 GNAT_Pragma; 12979 Check_Arg_Count (0); 12980 12981 -- We really should check unconditionally for proper configuration 12982 -- pragma placement, since we really don't want mixed Ada modes 12983 -- within a single unit, and the GNAT reference manual has always 12984 -- said this was a configuration pragma, but we did not check and 12985 -- are hesitant to add the check now. 12986 12987 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 12988 -- or Ada 95, so we must check if we are in Ada 2005 mode. 12989 12990 if Ada_Version >= Ada_2005 then 12991 Check_Valid_Configuration_Pragma; 12992 end if; 12993 12994 -- Now set Ada 95 mode 12995 12996 if Latest_Ada_Only then 12997 Error_Pragma ("??pragma% ignored"); 12998 else 12999 Ada_Version := Ada_95; 13000 Ada_Version_Explicit := Ada_95; 13001 Ada_Version_Pragma := N; 13002 end if; 13003 13004 --------------------- 13005 -- Ada_05/Ada_2005 -- 13006 --------------------- 13007 13008 -- pragma Ada_05; 13009 -- pragma Ada_05 (LOCAL_NAME); 13010 13011 -- pragma Ada_2005; 13012 -- pragma Ada_2005 (LOCAL_NAME): 13013 13014 -- Note: these pragmas also have some specific processing in Par.Prag 13015 -- because we want to set the Ada 2005 version mode during parsing. 13016 13017 -- The one argument form is used for managing the transition from 13018 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked 13019 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95 13020 -- mode will generate a warning. In addition, in Ada_83 or Ada_95 13021 -- mode, a preference rule is established which does not choose 13022 -- such an entity unless it is unambiguously specified. This avoids 13023 -- extra subprograms marked this way from generating ambiguities in 13024 -- otherwise legal pre-Ada_2005 programs. The one argument form is 13025 -- intended for exclusive use in the GNAT run-time library. 13026 13027 when Pragma_Ada_05 13028 | Pragma_Ada_2005 13029 => 13030 declare 13031 E_Id : Node_Id; 13032 13033 begin 13034 GNAT_Pragma; 13035 13036 if Arg_Count = 1 then 13037 Check_Arg_Is_Local_Name (Arg1); 13038 E_Id := Get_Pragma_Arg (Arg1); 13039 13040 if Etype (E_Id) = Any_Type then 13041 return; 13042 end if; 13043 13044 Set_Is_Ada_2005_Only (Entity (E_Id)); 13045 Record_Rep_Item (Entity (E_Id), N); 13046 13047 else 13048 Check_Arg_Count (0); 13049 13050 -- For Ada_2005 we unconditionally enforce the documented 13051 -- configuration pragma placement, since we do not want to 13052 -- tolerate mixed modes in a unit involving Ada 2005. That 13053 -- would cause real difficulties for those cases where there 13054 -- are incompatibilities between Ada 95 and Ada 2005. 13055 13056 Check_Valid_Configuration_Pragma; 13057 13058 -- Now set appropriate Ada mode 13059 13060 if Latest_Ada_Only then 13061 Error_Pragma ("??pragma% ignored"); 13062 else 13063 Ada_Version := Ada_2005; 13064 Ada_Version_Explicit := Ada_2005; 13065 Ada_Version_Pragma := N; 13066 end if; 13067 end if; 13068 end; 13069 13070 --------------------- 13071 -- Ada_12/Ada_2012 -- 13072 --------------------- 13073 13074 -- pragma Ada_12; 13075 -- pragma Ada_12 (LOCAL_NAME); 13076 13077 -- pragma Ada_2012; 13078 -- pragma Ada_2012 (LOCAL_NAME): 13079 13080 -- Note: these pragmas also have some specific processing in Par.Prag 13081 -- because we want to set the Ada 2012 version mode during parsing. 13082 13083 -- The one argument form is used for managing the transition from Ada 13084 -- 2005 to Ada 2012 in the run-time library. If an entity is marked 13085 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012 13086 -- mode will generate a warning. In addition, in any pre-Ada_2012 13087 -- mode, a preference rule is established which does not choose 13088 -- such an entity unless it is unambiguously specified. This avoids 13089 -- extra subprograms marked this way from generating ambiguities in 13090 -- otherwise legal pre-Ada_2012 programs. The one argument form is 13091 -- intended for exclusive use in the GNAT run-time library. 13092 13093 when Pragma_Ada_12 13094 | Pragma_Ada_2012 13095 => 13096 declare 13097 E_Id : Node_Id; 13098 13099 begin 13100 GNAT_Pragma; 13101 13102 if Arg_Count = 1 then 13103 Check_Arg_Is_Local_Name (Arg1); 13104 E_Id := Get_Pragma_Arg (Arg1); 13105 13106 if Etype (E_Id) = Any_Type then 13107 return; 13108 end if; 13109 13110 Set_Is_Ada_2012_Only (Entity (E_Id)); 13111 Record_Rep_Item (Entity (E_Id), N); 13112 13113 else 13114 Check_Arg_Count (0); 13115 13116 -- For Ada_2012 we unconditionally enforce the documented 13117 -- configuration pragma placement, since we do not want to 13118 -- tolerate mixed modes in a unit involving Ada 2012. That 13119 -- would cause real difficulties for those cases where there 13120 -- are incompatibilities between Ada 95 and Ada 2012. We could 13121 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. 13122 13123 Check_Valid_Configuration_Pragma; 13124 13125 -- Now set appropriate Ada mode 13126 13127 Ada_Version := Ada_2012; 13128 Ada_Version_Explicit := Ada_2012; 13129 Ada_Version_Pragma := N; 13130 end if; 13131 end; 13132 13133 -------------- 13134 -- Ada_2020 -- 13135 -------------- 13136 13137 -- pragma Ada_2020; 13138 13139 -- Note: this pragma also has some specific processing in Par.Prag 13140 -- because we want to set the Ada 2020 version mode during parsing. 13141 13142 when Pragma_Ada_2020 => 13143 GNAT_Pragma; 13144 13145 Check_Arg_Count (0); 13146 13147 Check_Valid_Configuration_Pragma; 13148 13149 -- Now set appropriate Ada mode 13150 13151 Ada_Version := Ada_2020; 13152 Ada_Version_Explicit := Ada_2020; 13153 Ada_Version_Pragma := N; 13154 13155 ------------------------------------- 13156 -- Aggregate_Individually_Assign -- 13157 ------------------------------------- 13158 13159 -- pragma Aggregate_Individually_Assign; 13160 13161 when Pragma_Aggregate_Individually_Assign => 13162 GNAT_Pragma; 13163 Check_Arg_Count (0); 13164 Check_Valid_Configuration_Pragma; 13165 Aggregate_Individually_Assign := True; 13166 13167 ---------------------- 13168 -- All_Calls_Remote -- 13169 ---------------------- 13170 13171 -- pragma All_Calls_Remote [(library_package_NAME)]; 13172 13173 when Pragma_All_Calls_Remote => All_Calls_Remote : declare 13174 Lib_Entity : Entity_Id; 13175 13176 begin 13177 Check_Ada_83_Warning; 13178 Check_Valid_Library_Unit_Pragma; 13179 13180 if Nkind (N) = N_Null_Statement then 13181 return; 13182 end if; 13183 13184 Lib_Entity := Find_Lib_Unit_Name; 13185 13186 -- A pragma that applies to a Ghost entity becomes Ghost for the 13187 -- purposes of legality checks and removal of ignored Ghost code. 13188 13189 Mark_Ghost_Pragma (N, Lib_Entity); 13190 13191 -- This pragma should only apply to a RCI unit (RM E.2.3(23)) 13192 13193 if Present (Lib_Entity) and then not Debug_Flag_U then 13194 if not Is_Remote_Call_Interface (Lib_Entity) then 13195 Error_Pragma ("pragma% only apply to rci unit"); 13196 13197 -- Set flag for entity of the library unit 13198 13199 else 13200 Set_Has_All_Calls_Remote (Lib_Entity); 13201 end if; 13202 end if; 13203 end All_Calls_Remote; 13204 13205 --------------------------- 13206 -- Allow_Integer_Address -- 13207 --------------------------- 13208 13209 -- pragma Allow_Integer_Address; 13210 13211 when Pragma_Allow_Integer_Address => 13212 GNAT_Pragma; 13213 Check_Valid_Configuration_Pragma; 13214 Check_Arg_Count (0); 13215 13216 -- If Address is a private type, then set the flag to allow 13217 -- integer address values. If Address is not private, then this 13218 -- pragma has no purpose, so it is simply ignored. Not clear if 13219 -- there are any such targets now. 13220 13221 if Opt.Address_Is_Private then 13222 Opt.Allow_Integer_Address := True; 13223 end if; 13224 13225 -------------- 13226 -- Annotate -- 13227 -------------- 13228 13229 -- pragma Annotate 13230 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]); 13231 -- ARG ::= NAME | EXPRESSION 13232 13233 -- The first two arguments are by convention intended to refer to an 13234 -- external tool and a tool-specific function. These arguments are 13235 -- not analyzed. 13236 13237 when Pragma_Annotate => Annotate : declare 13238 Arg : Node_Id; 13239 Expr : Node_Id; 13240 Nam_Arg : Node_Id; 13241 13242 -------------------------- 13243 -- Inferred_String_Type -- 13244 -------------------------- 13245 13246 function Preferred_String_Type (Expr : Node_Id) return Entity_Id; 13247 -- Infer the type to use for a string literal or a concatentation 13248 -- of operands whose types can be inferred. For such expressions, 13249 -- returns the "narrowest" of the three predefined string types 13250 -- that can represent the characters occurring in the expression. 13251 -- For other expressions, returns Empty. 13252 13253 function Preferred_String_Type (Expr : Node_Id) return Entity_Id is 13254 begin 13255 case Nkind (Expr) is 13256 when N_String_Literal => 13257 if Has_Wide_Wide_Character (Expr) then 13258 return Standard_Wide_Wide_String; 13259 elsif Has_Wide_Character (Expr) then 13260 return Standard_Wide_String; 13261 else 13262 return Standard_String; 13263 end if; 13264 13265 when N_Op_Concat => 13266 declare 13267 L_Type : constant Entity_Id 13268 := Preferred_String_Type (Left_Opnd (Expr)); 13269 R_Type : constant Entity_Id 13270 := Preferred_String_Type (Right_Opnd (Expr)); 13271 13272 Type_Table : constant array (1 .. 4) of Entity_Id 13273 := (Empty, 13274 Standard_Wide_Wide_String, 13275 Standard_Wide_String, 13276 Standard_String); 13277 begin 13278 for Idx in Type_Table'Range loop 13279 if (L_Type = Type_Table (Idx)) or 13280 (R_Type = Type_Table (Idx)) 13281 then 13282 return Type_Table (Idx); 13283 end if; 13284 end loop; 13285 raise Program_Error; 13286 end; 13287 13288 when others => 13289 return Empty; 13290 end case; 13291 end Preferred_String_Type; 13292 begin 13293 GNAT_Pragma; 13294 Check_At_Least_N_Arguments (1); 13295 13296 Nam_Arg := Last (Pragma_Argument_Associations (N)); 13297 13298 -- Determine whether the last argument is "Entity => local_NAME" 13299 -- and if it is, perform the required semantic checks. Remove the 13300 -- argument from further processing. 13301 13302 if Nkind (Nam_Arg) = N_Pragma_Argument_Association 13303 and then Chars (Nam_Arg) = Name_Entity 13304 then 13305 Check_Arg_Is_Local_Name (Nam_Arg); 13306 Arg_Count := Arg_Count - 1; 13307 13308 -- A pragma that applies to a Ghost entity becomes Ghost for 13309 -- the purposes of legality checks and removal of ignored Ghost 13310 -- code. 13311 13312 if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg)) 13313 and then Present (Entity (Get_Pragma_Arg (Nam_Arg))) 13314 then 13315 Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg))); 13316 end if; 13317 13318 -- Not allowed in compiler units (bootstrap issues) 13319 13320 Check_Compiler_Unit ("Entity for pragma Annotate", N); 13321 end if; 13322 13323 -- Continue the processing with last argument removed for now 13324 13325 Check_Arg_Is_Identifier (Arg1); 13326 Check_No_Identifiers; 13327 Store_Note (N); 13328 13329 -- The second parameter is optional, it is never analyzed 13330 13331 if No (Arg2) then 13332 null; 13333 13334 -- Otherwise there is a second parameter 13335 13336 else 13337 -- The second parameter must be an identifier 13338 13339 Check_Arg_Is_Identifier (Arg2); 13340 13341 -- Process the remaining parameters (if any) 13342 13343 Arg := Next (Arg2); 13344 while Present (Arg) loop 13345 Expr := Get_Pragma_Arg (Arg); 13346 Analyze (Expr); 13347 13348 if Is_Entity_Name (Expr) then 13349 null; 13350 13351 -- For string literals and concatenations of string literals 13352 -- we assume Standard_String as the type, unless the string 13353 -- contains wide or wide_wide characters. 13354 13355 elsif Present (Preferred_String_Type (Expr)) then 13356 Resolve (Expr, Preferred_String_Type (Expr)); 13357 13358 elsif Is_Overloaded (Expr) then 13359 Error_Pragma_Arg ("ambiguous argument for pragma%", Expr); 13360 13361 else 13362 Resolve (Expr); 13363 end if; 13364 13365 Next (Arg); 13366 end loop; 13367 end if; 13368 end Annotate; 13369 13370 ------------------------------------------------- 13371 -- Assert/Assert_And_Cut/Assume/Loop_Invariant -- 13372 ------------------------------------------------- 13373 13374 -- pragma Assert 13375 -- ( [Check => ] Boolean_EXPRESSION 13376 -- [, [Message =>] Static_String_EXPRESSION]); 13377 13378 -- pragma Assert_And_Cut 13379 -- ( [Check => ] Boolean_EXPRESSION 13380 -- [, [Message =>] Static_String_EXPRESSION]); 13381 13382 -- pragma Assume 13383 -- ( [Check => ] Boolean_EXPRESSION 13384 -- [, [Message =>] Static_String_EXPRESSION]); 13385 13386 -- pragma Loop_Invariant 13387 -- ( [Check => ] Boolean_EXPRESSION 13388 -- [, [Message =>] Static_String_EXPRESSION]); 13389 13390 when Pragma_Assert 13391 | Pragma_Assert_And_Cut 13392 | Pragma_Assume 13393 | Pragma_Loop_Invariant 13394 => 13395 Assert : declare 13396 function Contains_Loop_Entry (Expr : Node_Id) return Boolean; 13397 -- Determine whether expression Expr contains a Loop_Entry 13398 -- attribute reference. 13399 13400 ------------------------- 13401 -- Contains_Loop_Entry -- 13402 ------------------------- 13403 13404 function Contains_Loop_Entry (Expr : Node_Id) return Boolean is 13405 Has_Loop_Entry : Boolean := False; 13406 13407 function Process (N : Node_Id) return Traverse_Result; 13408 -- Process function for traversal to look for Loop_Entry 13409 13410 ------------- 13411 -- Process -- 13412 ------------- 13413 13414 function Process (N : Node_Id) return Traverse_Result is 13415 begin 13416 if Nkind (N) = N_Attribute_Reference 13417 and then Attribute_Name (N) = Name_Loop_Entry 13418 then 13419 Has_Loop_Entry := True; 13420 return Abandon; 13421 else 13422 return OK; 13423 end if; 13424 end Process; 13425 13426 procedure Traverse is new Traverse_Proc (Process); 13427 13428 -- Start of processing for Contains_Loop_Entry 13429 13430 begin 13431 Traverse (Expr); 13432 return Has_Loop_Entry; 13433 end Contains_Loop_Entry; 13434 13435 -- Local variables 13436 13437 Expr : Node_Id; 13438 New_Args : List_Id; 13439 13440 -- Start of processing for Assert 13441 13442 begin 13443 -- Assert is an Ada 2005 RM-defined pragma 13444 13445 if Prag_Id = Pragma_Assert then 13446 Ada_2005_Pragma; 13447 13448 -- The remaining ones are GNAT pragmas 13449 13450 else 13451 GNAT_Pragma; 13452 end if; 13453 13454 Check_At_Least_N_Arguments (1); 13455 Check_At_Most_N_Arguments (2); 13456 Check_Arg_Order ((Name_Check, Name_Message)); 13457 Check_Optional_Identifier (Arg1, Name_Check); 13458 Expr := Get_Pragma_Arg (Arg1); 13459 13460 -- Special processing for Loop_Invariant, Loop_Variant or for 13461 -- other cases where a Loop_Entry attribute is present. If the 13462 -- assertion pragma contains attribute Loop_Entry, ensure that 13463 -- the related pragma is within a loop. 13464 13465 if Prag_Id = Pragma_Loop_Invariant 13466 or else Prag_Id = Pragma_Loop_Variant 13467 or else Contains_Loop_Entry (Expr) 13468 then 13469 Check_Loop_Pragma_Placement; 13470 13471 -- Perform preanalysis to deal with embedded Loop_Entry 13472 -- attributes. 13473 13474 Preanalyze_Assert_Expression (Expr, Any_Boolean); 13475 end if; 13476 13477 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating 13478 -- a corresponding Check pragma: 13479 13480 -- pragma Check (name, condition [, msg]); 13481 13482 -- Where name is the identifier matching the pragma name. So 13483 -- rewrite pragma in this manner, transfer the message argument 13484 -- if present, and analyze the result 13485 13486 -- Note: When dealing with a semantically analyzed tree, the 13487 -- information that a Check node N corresponds to a source Assert, 13488 -- Assume, or Assert_And_Cut pragma can be retrieved from the 13489 -- pragma kind of Original_Node(N). 13490 13491 New_Args := New_List ( 13492 Make_Pragma_Argument_Association (Loc, 13493 Expression => Make_Identifier (Loc, Pname)), 13494 Make_Pragma_Argument_Association (Sloc (Expr), 13495 Expression => Expr)); 13496 13497 if Arg_Count > 1 then 13498 Check_Optional_Identifier (Arg2, Name_Message); 13499 13500 -- Provide semantic annnotations for optional argument, for 13501 -- ASIS use, before rewriting. 13502 13503 Preanalyze_And_Resolve (Expression (Arg2), Standard_String); 13504 Append_To (New_Args, New_Copy_Tree (Arg2)); 13505 end if; 13506 13507 -- Rewrite as Check pragma 13508 13509 Rewrite (N, 13510 Make_Pragma (Loc, 13511 Chars => Name_Check, 13512 Pragma_Argument_Associations => New_Args)); 13513 13514 Analyze (N); 13515 end Assert; 13516 13517 ---------------------- 13518 -- Assertion_Policy -- 13519 ---------------------- 13520 13521 -- pragma Assertion_Policy (POLICY_IDENTIFIER); 13522 13523 -- The following form is Ada 2012 only, but we allow it in all modes 13524 13525 -- Pragma Assertion_Policy ( 13526 -- ASSERTION_KIND => POLICY_IDENTIFIER 13527 -- {, ASSERTION_KIND => POLICY_IDENTIFIER}); 13528 13529 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND 13530 13531 -- RM_ASSERTION_KIND ::= Assert | 13532 -- Static_Predicate | 13533 -- Dynamic_Predicate | 13534 -- Pre | 13535 -- Pre'Class | 13536 -- Post | 13537 -- Post'Class | 13538 -- Type_Invariant | 13539 -- Type_Invariant'Class 13540 13541 -- ID_ASSERTION_KIND ::= Assert_And_Cut | 13542 -- Assume | 13543 -- Contract_Cases | 13544 -- Debug | 13545 -- Default_Initial_Condition | 13546 -- Ghost | 13547 -- Initial_Condition | 13548 -- Loop_Invariant | 13549 -- Loop_Variant | 13550 -- Postcondition | 13551 -- Precondition | 13552 -- Predicate | 13553 -- Refined_Post | 13554 -- Statement_Assertions 13555 13556 -- Note: The RM_ASSERTION_KIND list is language-defined, and the 13557 -- ID_ASSERTION_KIND list contains implementation-defined additions 13558 -- recognized by GNAT. The effect is to control the behavior of 13559 -- identically named aspects and pragmas, depending on the specified 13560 -- policy identifier: 13561 13562 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible 13563 13564 -- Note: Check and Ignore are language-defined. Disable is a GNAT 13565 -- implementation-defined addition that results in totally ignoring 13566 -- the corresponding assertion. If Disable is specified, then the 13567 -- argument of the assertion is not even analyzed. This is useful 13568 -- when the aspect/pragma argument references entities in a with'ed 13569 -- package that is replaced by a dummy package in the final build. 13570 13571 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class, 13572 -- and Type_Invariant'Class were recognized by the parser and 13573 -- transformed into references to the special internal identifiers 13574 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special 13575 -- processing is required here. 13576 13577 when Pragma_Assertion_Policy => Assertion_Policy : declare 13578 procedure Resolve_Suppressible (Policy : Node_Id); 13579 -- Converts the assertion policy 'Suppressible' to either Check or 13580 -- Ignore based on whether checks are suppressed via -gnatp. 13581 13582 -------------------------- 13583 -- Resolve_Suppressible -- 13584 -------------------------- 13585 13586 procedure Resolve_Suppressible (Policy : Node_Id) is 13587 Arg : constant Node_Id := Get_Pragma_Arg (Policy); 13588 Nam : Name_Id; 13589 13590 begin 13591 -- Transform policy argument Suppressible into either Ignore or 13592 -- Check depending on whether checks are enabled or suppressed. 13593 13594 if Chars (Arg) = Name_Suppressible then 13595 if Suppress_Checks then 13596 Nam := Name_Ignore; 13597 else 13598 Nam := Name_Check; 13599 end if; 13600 13601 Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam)); 13602 end if; 13603 end Resolve_Suppressible; 13604 13605 -- Local variables 13606 13607 Arg : Node_Id; 13608 Kind : Name_Id; 13609 LocP : Source_Ptr; 13610 Policy : Node_Id; 13611 13612 begin 13613 Ada_2005_Pragma; 13614 13615 -- This can always appear as a configuration pragma 13616 13617 if Is_Configuration_Pragma then 13618 null; 13619 13620 -- It can also appear in a declarative part or package spec in Ada 13621 -- 2012 mode. We allow this in other modes, but in that case we 13622 -- consider that we have an Ada 2012 pragma on our hands. 13623 13624 else 13625 Check_Is_In_Decl_Part_Or_Package_Spec; 13626 Ada_2012_Pragma; 13627 end if; 13628 13629 -- One argument case with no identifier (first form above) 13630 13631 if Arg_Count = 1 13632 and then (Nkind (Arg1) /= N_Pragma_Argument_Association 13633 or else Chars (Arg1) = No_Name) 13634 then 13635 Check_Arg_Is_One_Of (Arg1, 13636 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible); 13637 13638 Resolve_Suppressible (Arg1); 13639 13640 -- Treat one argument Assertion_Policy as equivalent to: 13641 13642 -- pragma Check_Policy (Assertion, policy) 13643 13644 -- So rewrite pragma in that manner and link on to the chain 13645 -- of Check_Policy pragmas, marking the pragma as analyzed. 13646 13647 Policy := Get_Pragma_Arg (Arg1); 13648 13649 Rewrite (N, 13650 Make_Pragma (Loc, 13651 Chars => Name_Check_Policy, 13652 Pragma_Argument_Associations => New_List ( 13653 Make_Pragma_Argument_Association (Loc, 13654 Expression => Make_Identifier (Loc, Name_Assertion)), 13655 13656 Make_Pragma_Argument_Association (Loc, 13657 Expression => 13658 Make_Identifier (Sloc (Policy), Chars (Policy)))))); 13659 Analyze (N); 13660 13661 -- Here if we have two or more arguments 13662 13663 else 13664 Check_At_Least_N_Arguments (1); 13665 Ada_2012_Pragma; 13666 13667 -- Loop through arguments 13668 13669 Arg := Arg1; 13670 while Present (Arg) loop 13671 LocP := Sloc (Arg); 13672 13673 -- Kind must be specified 13674 13675 if Nkind (Arg) /= N_Pragma_Argument_Association 13676 or else Chars (Arg) = No_Name 13677 then 13678 Error_Pragma_Arg 13679 ("missing assertion kind for pragma%", Arg); 13680 end if; 13681 13682 -- Check Kind and Policy have allowed forms 13683 13684 Kind := Chars (Arg); 13685 Policy := Get_Pragma_Arg (Arg); 13686 13687 if not Is_Valid_Assertion_Kind (Kind) then 13688 Error_Pragma_Arg 13689 ("invalid assertion kind for pragma%", Arg); 13690 end if; 13691 13692 Check_Arg_Is_One_Of (Arg, 13693 Name_Check, Name_Disable, Name_Ignore, Name_Suppressible); 13694 13695 Resolve_Suppressible (Arg); 13696 13697 if Kind = Name_Ghost then 13698 13699 -- The Ghost policy must be either Check or Ignore 13700 -- (SPARK RM 6.9(6)). 13701 13702 if not Nam_In (Chars (Policy), Name_Check, 13703 Name_Ignore) 13704 then 13705 Error_Pragma_Arg 13706 ("argument of pragma % Ghost must be Check or " 13707 & "Ignore", Policy); 13708 end if; 13709 13710 -- Pragma Assertion_Policy specifying a Ghost policy 13711 -- cannot occur within a Ghost subprogram or package 13712 -- (SPARK RM 6.9(14)). 13713 13714 if Ghost_Mode > None then 13715 Error_Pragma 13716 ("pragma % cannot appear within ghost subprogram or " 13717 & "package"); 13718 end if; 13719 end if; 13720 13721 -- Rewrite the Assertion_Policy pragma as a series of 13722 -- Check_Policy pragmas of the form: 13723 13724 -- Check_Policy (Kind, Policy); 13725 13726 -- Note: the insertion of the pragmas cannot be done with 13727 -- Insert_Action because in the configuration case, there 13728 -- are no scopes on the scope stack and the mechanism will 13729 -- fail. 13730 13731 Insert_Before_And_Analyze (N, 13732 Make_Pragma (LocP, 13733 Chars => Name_Check_Policy, 13734 Pragma_Argument_Associations => New_List ( 13735 Make_Pragma_Argument_Association (LocP, 13736 Expression => Make_Identifier (LocP, Kind)), 13737 Make_Pragma_Argument_Association (LocP, 13738 Expression => Policy)))); 13739 13740 Arg := Next (Arg); 13741 end loop; 13742 13743 -- Rewrite the Assertion_Policy pragma as null since we have 13744 -- now inserted all the equivalent Check pragmas. 13745 13746 Rewrite (N, Make_Null_Statement (Loc)); 13747 Analyze (N); 13748 end if; 13749 end Assertion_Policy; 13750 13751 ------------------------------ 13752 -- Assume_No_Invalid_Values -- 13753 ------------------------------ 13754 13755 -- pragma Assume_No_Invalid_Values (On | Off); 13756 13757 when Pragma_Assume_No_Invalid_Values => 13758 GNAT_Pragma; 13759 Check_Valid_Configuration_Pragma; 13760 Check_Arg_Count (1); 13761 Check_No_Identifiers; 13762 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 13763 13764 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 13765 Assume_No_Invalid_Values := True; 13766 else 13767 Assume_No_Invalid_Values := False; 13768 end if; 13769 13770 -------------------------- 13771 -- Attribute_Definition -- 13772 -------------------------- 13773 13774 -- pragma Attribute_Definition 13775 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, 13776 -- [Entity =>] LOCAL_NAME, 13777 -- [Expression =>] EXPRESSION | NAME); 13778 13779 when Pragma_Attribute_Definition => Attribute_Definition : declare 13780 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); 13781 Aname : Name_Id; 13782 13783 begin 13784 GNAT_Pragma; 13785 Check_Arg_Count (3); 13786 Check_Optional_Identifier (Arg1, "attribute"); 13787 Check_Optional_Identifier (Arg2, "entity"); 13788 Check_Optional_Identifier (Arg3, "expression"); 13789 13790 if Nkind (Attribute_Designator) /= N_Identifier then 13791 Error_Msg_N ("attribute name expected", Attribute_Designator); 13792 return; 13793 end if; 13794 13795 Check_Arg_Is_Local_Name (Arg2); 13796 13797 -- If the attribute is not recognized, then issue a warning (not 13798 -- an error), and ignore the pragma. 13799 13800 Aname := Chars (Attribute_Designator); 13801 13802 if not Is_Attribute_Name (Aname) then 13803 Bad_Attribute (Attribute_Designator, Aname, Warn => True); 13804 return; 13805 end if; 13806 13807 -- Otherwise, rewrite the pragma as an attribute definition clause 13808 13809 Rewrite (N, 13810 Make_Attribute_Definition_Clause (Loc, 13811 Name => Get_Pragma_Arg (Arg2), 13812 Chars => Aname, 13813 Expression => Get_Pragma_Arg (Arg3))); 13814 Analyze (N); 13815 end Attribute_Definition; 13816 13817 ------------------------------------------------------------------ 13818 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- 13819 -- No_Caching -- 13820 ------------------------------------------------------------------ 13821 13822 -- pragma Async_Readers [ (boolean_EXPRESSION) ]; 13823 -- pragma Async_Writers [ (boolean_EXPRESSION) ]; 13824 -- pragma Effective_Reads [ (boolean_EXPRESSION) ]; 13825 -- pragma Effective_Writes [ (boolean_EXPRESSION) ]; 13826 -- pragma No_Caching [ (boolean_EXPRESSION) ]; 13827 13828 when Pragma_Async_Readers 13829 | Pragma_Async_Writers 13830 | Pragma_Effective_Reads 13831 | Pragma_Effective_Writes 13832 | Pragma_No_Caching 13833 => 13834 Async_Effective : declare 13835 Obj_Decl : Node_Id; 13836 Obj_Id : Entity_Id; 13837 13838 begin 13839 GNAT_Pragma; 13840 Check_No_Identifiers; 13841 Check_At_Most_N_Arguments (1); 13842 13843 Obj_Decl := Find_Related_Context (N, Do_Checks => True); 13844 13845 -- Object declaration 13846 13847 if Nkind (Obj_Decl) /= N_Object_Declaration then 13848 Pragma_Misplaced; 13849 return; 13850 end if; 13851 13852 Obj_Id := Defining_Entity (Obj_Decl); 13853 13854 -- Perform minimal verification to ensure that the argument is at 13855 -- least a variable. Subsequent finer grained checks will be done 13856 -- at the end of the declarative region the contains the pragma. 13857 13858 if Ekind (Obj_Id) = E_Variable then 13859 13860 -- A pragma that applies to a Ghost entity becomes Ghost for 13861 -- the purposes of legality checks and removal of ignored Ghost 13862 -- code. 13863 13864 Mark_Ghost_Pragma (N, Obj_Id); 13865 13866 -- Chain the pragma on the contract for further processing by 13867 -- Analyze_External_Property_In_Decl_Part. 13868 13869 Add_Contract_Item (N, Obj_Id); 13870 13871 -- Analyze the Boolean expression (if any) 13872 13873 if Present (Arg1) then 13874 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 13875 end if; 13876 13877 -- Otherwise the external property applies to a constant 13878 13879 else 13880 Error_Pragma ("pragma % must apply to a volatile object"); 13881 end if; 13882 end Async_Effective; 13883 13884 ------------------ 13885 -- Asynchronous -- 13886 ------------------ 13887 13888 -- pragma Asynchronous (LOCAL_NAME); 13889 13890 when Pragma_Asynchronous => Asynchronous : declare 13891 C_Ent : Entity_Id; 13892 Decl : Node_Id; 13893 Formal : Entity_Id; 13894 L : List_Id; 13895 Nm : Entity_Id; 13896 S : Node_Id; 13897 13898 procedure Process_Async_Pragma; 13899 -- Common processing for procedure and access-to-procedure case 13900 13901 -------------------------- 13902 -- Process_Async_Pragma -- 13903 -------------------------- 13904 13905 procedure Process_Async_Pragma is 13906 begin 13907 if No (L) then 13908 Set_Is_Asynchronous (Nm); 13909 return; 13910 end if; 13911 13912 -- The formals should be of mode IN (RM E.4.1(6)) 13913 13914 S := First (L); 13915 while Present (S) loop 13916 Formal := Defining_Identifier (S); 13917 13918 if Nkind (Formal) = N_Defining_Identifier 13919 and then Ekind (Formal) /= E_In_Parameter 13920 then 13921 Error_Pragma_Arg 13922 ("pragma% procedure can only have IN parameter", 13923 Arg1); 13924 end if; 13925 13926 Next (S); 13927 end loop; 13928 13929 Set_Is_Asynchronous (Nm); 13930 end Process_Async_Pragma; 13931 13932 -- Start of processing for pragma Asynchronous 13933 13934 begin 13935 Check_Ada_83_Warning; 13936 Check_No_Identifiers; 13937 Check_Arg_Count (1); 13938 Check_Arg_Is_Local_Name (Arg1); 13939 13940 if Debug_Flag_U then 13941 return; 13942 end if; 13943 13944 C_Ent := Cunit_Entity (Current_Sem_Unit); 13945 Analyze (Get_Pragma_Arg (Arg1)); 13946 Nm := Entity (Get_Pragma_Arg (Arg1)); 13947 13948 -- A pragma that applies to a Ghost entity becomes Ghost for the 13949 -- purposes of legality checks and removal of ignored Ghost code. 13950 13951 Mark_Ghost_Pragma (N, Nm); 13952 13953 if not Is_Remote_Call_Interface (C_Ent) 13954 and then not Is_Remote_Types (C_Ent) 13955 then 13956 -- This pragma should only appear in an RCI or Remote Types 13957 -- unit (RM E.4.1(4)). 13958 13959 Error_Pragma 13960 ("pragma% not in Remote_Call_Interface or Remote_Types unit"); 13961 end if; 13962 13963 if Ekind (Nm) = E_Procedure 13964 and then Nkind (Parent (Nm)) = N_Procedure_Specification 13965 then 13966 if not Is_Remote_Call_Interface (Nm) then 13967 Error_Pragma_Arg 13968 ("pragma% cannot be applied on non-remote procedure", 13969 Arg1); 13970 end if; 13971 13972 L := Parameter_Specifications (Parent (Nm)); 13973 Process_Async_Pragma; 13974 return; 13975 13976 elsif Ekind (Nm) = E_Function then 13977 Error_Pragma_Arg 13978 ("pragma% cannot be applied to function", Arg1); 13979 13980 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then 13981 if Is_Record_Type (Nm) then 13982 13983 -- A record type that is the Equivalent_Type for a remote 13984 -- access-to-subprogram type. 13985 13986 Decl := Declaration_Node (Corresponding_Remote_Type (Nm)); 13987 13988 else 13989 -- A non-expanded RAS type (distribution is not enabled) 13990 13991 Decl := Declaration_Node (Nm); 13992 end if; 13993 13994 if Nkind (Decl) = N_Full_Type_Declaration 13995 and then Nkind (Type_Definition (Decl)) = 13996 N_Access_Procedure_Definition 13997 then 13998 L := Parameter_Specifications (Type_Definition (Decl)); 13999 Process_Async_Pragma; 14000 14001 if Is_Asynchronous (Nm) 14002 and then Expander_Active 14003 and then Get_PCS_Name /= Name_No_DSA 14004 then 14005 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); 14006 end if; 14007 14008 else 14009 Error_Pragma_Arg 14010 ("pragma% cannot reference access-to-function type", 14011 Arg1); 14012 end if; 14013 14014 -- Only other possibility is Access-to-class-wide type 14015 14016 elsif Is_Access_Type (Nm) 14017 and then Is_Class_Wide_Type (Designated_Type (Nm)) 14018 then 14019 Check_First_Subtype (Arg1); 14020 Set_Is_Asynchronous (Nm); 14021 if Expander_Active then 14022 RACW_Type_Is_Asynchronous (Nm); 14023 end if; 14024 14025 else 14026 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); 14027 end if; 14028 end Asynchronous; 14029 14030 ------------ 14031 -- Atomic -- 14032 ------------ 14033 14034 -- pragma Atomic (LOCAL_NAME); 14035 14036 when Pragma_Atomic => 14037 Process_Atomic_Independent_Shared_Volatile; 14038 14039 ----------------------- 14040 -- Atomic_Components -- 14041 ----------------------- 14042 14043 -- pragma Atomic_Components (array_LOCAL_NAME); 14044 14045 -- This processing is shared by Volatile_Components 14046 14047 when Pragma_Atomic_Components 14048 | Pragma_Volatile_Components 14049 => 14050 Atomic_Components : declare 14051 D : Node_Id; 14052 E : Entity_Id; 14053 E_Id : Node_Id; 14054 14055 begin 14056 Check_Ada_83_Warning; 14057 Check_No_Identifiers; 14058 Check_Arg_Count (1); 14059 Check_Arg_Is_Local_Name (Arg1); 14060 E_Id := Get_Pragma_Arg (Arg1); 14061 14062 if Etype (E_Id) = Any_Type then 14063 return; 14064 end if; 14065 14066 E := Entity (E_Id); 14067 14068 -- A pragma that applies to a Ghost entity becomes Ghost for the 14069 -- purposes of legality checks and removal of ignored Ghost code. 14070 14071 Mark_Ghost_Pragma (N, E); 14072 Check_Duplicate_Pragma (E); 14073 14074 if Rep_Item_Too_Early (E, N) 14075 or else 14076 Rep_Item_Too_Late (E, N) 14077 then 14078 return; 14079 end if; 14080 14081 D := Declaration_Node (E); 14082 14083 if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E)) 14084 or else 14085 (Nkind (D) = N_Object_Declaration 14086 and then (Ekind (E) = E_Constant 14087 or else 14088 Ekind (E) = E_Variable) 14089 and then Nkind (Object_Definition (D)) = 14090 N_Constrained_Array_Definition) 14091 or else 14092 (Ada_Version >= Ada_2020 14093 and then Nkind (D) = N_Formal_Type_Declaration) 14094 then 14095 -- The flag is set on the base type, or on the object 14096 14097 if Nkind (D) = N_Full_Type_Declaration then 14098 E := Base_Type (E); 14099 end if; 14100 14101 -- Atomic implies both Independent and Volatile 14102 14103 if Prag_Id = Pragma_Atomic_Components then 14104 if Ada_Version >= Ada_2020 then 14105 Check_Atomic_VFA 14106 (Component_Type (Etype (E)), VFA => False); 14107 end if; 14108 14109 Set_Has_Atomic_Components (E); 14110 Set_Has_Independent_Components (E); 14111 end if; 14112 14113 Set_Has_Volatile_Components (E); 14114 14115 else 14116 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 14117 end if; 14118 end Atomic_Components; 14119 14120 -------------------- 14121 -- Attach_Handler -- 14122 -------------------- 14123 14124 -- pragma Attach_Handler (handler_NAME, EXPRESSION); 14125 14126 when Pragma_Attach_Handler => 14127 Check_Ada_83_Warning; 14128 Check_No_Identifiers; 14129 Check_Arg_Count (2); 14130 14131 if No_Run_Time_Mode then 14132 Error_Msg_CRT ("Attach_Handler pragma", N); 14133 else 14134 Check_Interrupt_Or_Attach_Handler; 14135 14136 -- The expression that designates the attribute may depend on a 14137 -- discriminant, and is therefore a per-object expression, to 14138 -- be expanded in the init proc. If expansion is enabled, then 14139 -- perform semantic checks on a copy only. 14140 14141 declare 14142 Temp : Node_Id; 14143 Typ : Node_Id; 14144 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2); 14145 14146 begin 14147 -- In Relaxed_RM_Semantics mode, we allow any static 14148 -- integer value, for compatibility with other compilers. 14149 14150 if Relaxed_RM_Semantics 14151 and then Nkind (Parg2) = N_Integer_Literal 14152 then 14153 Typ := Standard_Integer; 14154 else 14155 Typ := RTE (RE_Interrupt_ID); 14156 end if; 14157 14158 if Expander_Active then 14159 Temp := New_Copy_Tree (Parg2); 14160 Set_Parent (Temp, N); 14161 Preanalyze_And_Resolve (Temp, Typ); 14162 else 14163 Analyze (Parg2); 14164 Resolve (Parg2, Typ); 14165 end if; 14166 end; 14167 14168 Process_Interrupt_Or_Attach_Handler; 14169 end if; 14170 14171 -------------------- 14172 -- C_Pass_By_Copy -- 14173 -------------------- 14174 14175 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); 14176 14177 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare 14178 Arg : Node_Id; 14179 Val : Uint; 14180 14181 begin 14182 GNAT_Pragma; 14183 Check_Valid_Configuration_Pragma; 14184 Check_Arg_Count (1); 14185 Check_Optional_Identifier (Arg1, "max_size"); 14186 14187 Arg := Get_Pragma_Arg (Arg1); 14188 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer); 14189 14190 Val := Expr_Value (Arg); 14191 14192 if Val <= 0 then 14193 Error_Pragma_Arg 14194 ("maximum size for pragma% must be positive", Arg1); 14195 14196 elsif UI_Is_In_Int_Range (Val) then 14197 Default_C_Record_Mechanism := UI_To_Int (Val); 14198 14199 -- If a giant value is given, Int'Last will do well enough. 14200 -- If sometime someone complains that a record larger than 14201 -- two gigabytes is not copied, we will worry about it then. 14202 14203 else 14204 Default_C_Record_Mechanism := Mechanism_Type'Last; 14205 end if; 14206 end C_Pass_By_Copy; 14207 14208 ----------- 14209 -- Check -- 14210 ----------- 14211 14212 -- pragma Check ([Name =>] CHECK_KIND, 14213 -- [Check =>] Boolean_EXPRESSION 14214 -- [,[Message =>] String_EXPRESSION]); 14215 14216 -- CHECK_KIND ::= IDENTIFIER | 14217 -- Pre'Class | 14218 -- Post'Class | 14219 -- Invariant'Class | 14220 -- Type_Invariant'Class 14221 14222 -- The identifiers Assertions and Statement_Assertions are not 14223 -- allowed, since they have special meaning for Check_Policy. 14224 14225 -- WARNING: The code below manages Ghost regions. Return statements 14226 -- must be replaced by gotos which jump to the end of the code and 14227 -- restore the Ghost mode. 14228 14229 when Pragma_Check => Check : declare 14230 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 14231 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 14232 -- Save the Ghost-related attributes to restore on exit 14233 14234 Cname : Name_Id; 14235 Eloc : Source_Ptr; 14236 Expr : Node_Id; 14237 Str : Node_Id; 14238 pragma Warnings (Off, Str); 14239 14240 begin 14241 -- Pragma Check is Ghost when it applies to a Ghost entity. Set 14242 -- the mode now to ensure that any nodes generated during analysis 14243 -- and expansion are marked as Ghost. 14244 14245 Set_Ghost_Mode (N); 14246 14247 GNAT_Pragma; 14248 Check_At_Least_N_Arguments (2); 14249 Check_At_Most_N_Arguments (3); 14250 Check_Optional_Identifier (Arg1, Name_Name); 14251 Check_Optional_Identifier (Arg2, Name_Check); 14252 14253 if Arg_Count = 3 then 14254 Check_Optional_Identifier (Arg3, Name_Message); 14255 Str := Get_Pragma_Arg (Arg3); 14256 end if; 14257 14258 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1)); 14259 Check_Arg_Is_Identifier (Arg1); 14260 Cname := Chars (Get_Pragma_Arg (Arg1)); 14261 14262 -- Check forbidden name Assertions or Statement_Assertions 14263 14264 case Cname is 14265 when Name_Assertions => 14266 Error_Pragma_Arg 14267 ("""Assertions"" is not allowed as a check kind for " 14268 & "pragma%", Arg1); 14269 14270 when Name_Statement_Assertions => 14271 Error_Pragma_Arg 14272 ("""Statement_Assertions"" is not allowed as a check kind " 14273 & "for pragma%", Arg1); 14274 14275 when others => 14276 null; 14277 end case; 14278 14279 -- Check applicable policy. We skip this if Checked/Ignored status 14280 -- is already set (e.g. in the case of a pragma from an aspect). 14281 14282 if Is_Checked (N) or else Is_Ignored (N) then 14283 null; 14284 14285 -- For a non-source pragma that is a rewriting of another pragma, 14286 -- copy the Is_Checked/Ignored status from the rewritten pragma. 14287 14288 elsif Is_Rewrite_Substitution (N) 14289 and then Nkind (Original_Node (N)) = N_Pragma 14290 then 14291 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 14292 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 14293 14294 -- Otherwise query the applicable policy at this point 14295 14296 else 14297 case Check_Kind (Cname) is 14298 when Name_Ignore => 14299 Set_Is_Ignored (N, True); 14300 Set_Is_Checked (N, False); 14301 14302 when Name_Check => 14303 Set_Is_Ignored (N, False); 14304 Set_Is_Checked (N, True); 14305 14306 -- For disable, rewrite pragma as null statement and skip 14307 -- rest of the analysis of the pragma. 14308 14309 when Name_Disable => 14310 Rewrite (N, Make_Null_Statement (Loc)); 14311 Analyze (N); 14312 raise Pragma_Exit; 14313 14314 -- No other possibilities 14315 14316 when others => 14317 raise Program_Error; 14318 end case; 14319 end if; 14320 14321 -- If check kind was not Disable, then continue pragma analysis 14322 14323 Expr := Get_Pragma_Arg (Arg2); 14324 14325 -- Mark the pragma (or, if rewritten from an aspect, the original 14326 -- aspect) as enabled. Nothing to do for an internally generated 14327 -- check for a dynamic predicate. 14328 14329 if Is_Checked (N) 14330 and then not Split_PPC (N) 14331 and then Cname /= Name_Dynamic_Predicate 14332 then 14333 Set_SCO_Pragma_Enabled (Loc); 14334 end if; 14335 14336 -- Deal with analyzing the string argument. If checks are not 14337 -- on we don't want any expansion (since such expansion would 14338 -- not get properly deleted) but we do want to analyze (to get 14339 -- proper references). The Preanalyze_And_Resolve routine does 14340 -- just what we want. Ditto if pragma is active, because it will 14341 -- be rewritten as an if-statement whose analysis will complete 14342 -- analysis and expansion of the string message. This makes a 14343 -- difference in the unusual case where the expression for the 14344 -- string may have a side effect, such as raising an exception. 14345 -- This is mandated by RM 11.4.2, which specifies that the string 14346 -- expression is only evaluated if the check fails and 14347 -- Assertion_Error is to be raised. 14348 14349 if Arg_Count = 3 then 14350 Preanalyze_And_Resolve (Str, Standard_String); 14351 end if; 14352 14353 -- Now you might think we could just do the same with the Boolean 14354 -- expression if checks are off (and expansion is on) and then 14355 -- rewrite the check as a null statement. This would work but we 14356 -- would lose the useful warnings about an assertion being bound 14357 -- to fail even if assertions are turned off. 14358 14359 -- So instead we wrap the boolean expression in an if statement 14360 -- that looks like: 14361 14362 -- if False and then condition then 14363 -- null; 14364 -- end if; 14365 14366 -- The reason we do this rewriting during semantic analysis rather 14367 -- than as part of normal expansion is that we cannot analyze and 14368 -- expand the code for the boolean expression directly, or it may 14369 -- cause insertion of actions that would escape the attempt to 14370 -- suppress the check code. 14371 14372 -- Note that the Sloc for the if statement corresponds to the 14373 -- argument condition, not the pragma itself. The reason for 14374 -- this is that we may generate a warning if the condition is 14375 -- False at compile time, and we do not want to delete this 14376 -- warning when we delete the if statement. 14377 14378 if Expander_Active and Is_Ignored (N) then 14379 Eloc := Sloc (Expr); 14380 14381 Rewrite (N, 14382 Make_If_Statement (Eloc, 14383 Condition => 14384 Make_And_Then (Eloc, 14385 Left_Opnd => Make_Identifier (Eloc, Name_False), 14386 Right_Opnd => Expr), 14387 Then_Statements => New_List ( 14388 Make_Null_Statement (Eloc)))); 14389 14390 -- Now go ahead and analyze the if statement 14391 14392 In_Assertion_Expr := In_Assertion_Expr + 1; 14393 14394 -- One rather special treatment. If we are now in Eliminated 14395 -- overflow mode, then suppress overflow checking since we do 14396 -- not want to drag in the bignum stuff if we are in Ignore 14397 -- mode anyway. This is particularly important if we are using 14398 -- a configurable run time that does not support bignum ops. 14399 14400 if Scope_Suppress.Overflow_Mode_Assertions = Eliminated then 14401 declare 14402 Svo : constant Boolean := 14403 Scope_Suppress.Suppress (Overflow_Check); 14404 begin 14405 Scope_Suppress.Overflow_Mode_Assertions := Strict; 14406 Scope_Suppress.Suppress (Overflow_Check) := True; 14407 Analyze (N); 14408 Scope_Suppress.Suppress (Overflow_Check) := Svo; 14409 Scope_Suppress.Overflow_Mode_Assertions := Eliminated; 14410 end; 14411 14412 -- Not that special case 14413 14414 else 14415 Analyze (N); 14416 end if; 14417 14418 -- All done with this check 14419 14420 In_Assertion_Expr := In_Assertion_Expr - 1; 14421 14422 -- Check is active or expansion not active. In these cases we can 14423 -- just go ahead and analyze the boolean with no worries. 14424 14425 else 14426 In_Assertion_Expr := In_Assertion_Expr + 1; 14427 Analyze_And_Resolve (Expr, Any_Boolean); 14428 In_Assertion_Expr := In_Assertion_Expr - 1; 14429 end if; 14430 14431 Restore_Ghost_Region (Saved_GM, Saved_IGR); 14432 end Check; 14433 14434 -------------------------- 14435 -- Check_Float_Overflow -- 14436 -------------------------- 14437 14438 -- pragma Check_Float_Overflow; 14439 14440 when Pragma_Check_Float_Overflow => 14441 GNAT_Pragma; 14442 Check_Valid_Configuration_Pragma; 14443 Check_Arg_Count (0); 14444 Check_Float_Overflow := not Machine_Overflows_On_Target; 14445 14446 ---------------- 14447 -- Check_Name -- 14448 ---------------- 14449 14450 -- pragma Check_Name (check_IDENTIFIER); 14451 14452 when Pragma_Check_Name => 14453 GNAT_Pragma; 14454 Check_No_Identifiers; 14455 Check_Valid_Configuration_Pragma; 14456 Check_Arg_Count (1); 14457 Check_Arg_Is_Identifier (Arg1); 14458 14459 declare 14460 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 14461 14462 begin 14463 for J in Check_Names.First .. Check_Names.Last loop 14464 if Check_Names.Table (J) = Nam then 14465 return; 14466 end if; 14467 end loop; 14468 14469 Check_Names.Append (Nam); 14470 end; 14471 14472 ------------------ 14473 -- Check_Policy -- 14474 ------------------ 14475 14476 -- This is the old style syntax, which is still allowed in all modes: 14477 14478 -- pragma Check_Policy ([Name =>] CHECK_KIND 14479 -- [Policy =>] POLICY_IDENTIFIER); 14480 14481 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore 14482 14483 -- CHECK_KIND ::= IDENTIFIER | 14484 -- Pre'Class | 14485 -- Post'Class | 14486 -- Type_Invariant'Class | 14487 -- Invariant'Class 14488 14489 -- This is the new style syntax, compatible with Assertion_Policy 14490 -- and also allowed in all modes. 14491 14492 -- Pragma Check_Policy ( 14493 -- CHECK_KIND => POLICY_IDENTIFIER 14494 -- {, CHECK_KIND => POLICY_IDENTIFIER}); 14495 14496 -- Note: the identifiers Name and Policy are not allowed as 14497 -- Check_Kind values. This avoids ambiguities between the old and 14498 -- new form syntax. 14499 14500 when Pragma_Check_Policy => Check_Policy : declare 14501 Kind : Node_Id; 14502 14503 begin 14504 GNAT_Pragma; 14505 Check_At_Least_N_Arguments (1); 14506 14507 -- A Check_Policy pragma can appear either as a configuration 14508 -- pragma, or in a declarative part or a package spec (see RM 14509 -- 11.5(5) for rules for Suppress/Unsuppress which are also 14510 -- followed for Check_Policy). 14511 14512 if not Is_Configuration_Pragma then 14513 Check_Is_In_Decl_Part_Or_Package_Spec; 14514 end if; 14515 14516 -- Figure out if we have the old or new syntax. We have the 14517 -- old syntax if the first argument has no identifier, or the 14518 -- identifier is Name. 14519 14520 if Nkind (Arg1) /= N_Pragma_Argument_Association 14521 or else Nam_In (Chars (Arg1), No_Name, Name_Name) 14522 then 14523 -- Old syntax 14524 14525 Check_Arg_Count (2); 14526 Check_Optional_Identifier (Arg1, Name_Name); 14527 Kind := Get_Pragma_Arg (Arg1); 14528 Rewrite_Assertion_Kind (Kind, 14529 From_Policy => Comes_From_Source (N)); 14530 Check_Arg_Is_Identifier (Arg1); 14531 14532 -- Check forbidden check kind 14533 14534 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then 14535 Error_Msg_Name_2 := Chars (Kind); 14536 Error_Pragma_Arg 14537 ("pragma% does not allow% as check name", Arg1); 14538 end if; 14539 14540 -- Check policy 14541 14542 Check_Optional_Identifier (Arg2, Name_Policy); 14543 Check_Arg_Is_One_Of 14544 (Arg2, 14545 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); 14546 14547 -- And chain pragma on the Check_Policy_List for search 14548 14549 Set_Next_Pragma (N, Opt.Check_Policy_List); 14550 Opt.Check_Policy_List := N; 14551 14552 -- For the new syntax, what we do is to convert each argument to 14553 -- an old syntax equivalent. We do that because we want to chain 14554 -- old style Check_Policy pragmas for the search (we don't want 14555 -- to have to deal with multiple arguments in the search). 14556 14557 else 14558 declare 14559 Arg : Node_Id; 14560 Argx : Node_Id; 14561 LocP : Source_Ptr; 14562 New_P : Node_Id; 14563 14564 begin 14565 Arg := Arg1; 14566 while Present (Arg) loop 14567 LocP := Sloc (Arg); 14568 Argx := Get_Pragma_Arg (Arg); 14569 14570 -- Kind must be specified 14571 14572 if Nkind (Arg) /= N_Pragma_Argument_Association 14573 or else Chars (Arg) = No_Name 14574 then 14575 Error_Pragma_Arg 14576 ("missing assertion kind for pragma%", Arg); 14577 end if; 14578 14579 -- Construct equivalent old form syntax Check_Policy 14580 -- pragma and insert it to get remaining checks. 14581 14582 New_P := 14583 Make_Pragma (LocP, 14584 Chars => Name_Check_Policy, 14585 Pragma_Argument_Associations => New_List ( 14586 Make_Pragma_Argument_Association (LocP, 14587 Expression => 14588 Make_Identifier (LocP, Chars (Arg))), 14589 Make_Pragma_Argument_Association (Sloc (Argx), 14590 Expression => Argx))); 14591 14592 Arg := Next (Arg); 14593 14594 -- For a configuration pragma, insert old form in 14595 -- the corresponding file. 14596 14597 if Is_Configuration_Pragma then 14598 Insert_After (N, New_P); 14599 Analyze (New_P); 14600 14601 else 14602 Insert_Action (N, New_P); 14603 end if; 14604 end loop; 14605 14606 -- Rewrite original Check_Policy pragma to null, since we 14607 -- have converted it into a series of old syntax pragmas. 14608 14609 Rewrite (N, Make_Null_Statement (Loc)); 14610 Analyze (N); 14611 end; 14612 end if; 14613 end Check_Policy; 14614 14615 ------------- 14616 -- Comment -- 14617 ------------- 14618 14619 -- pragma Comment (static_string_EXPRESSION) 14620 14621 -- Processing for pragma Comment shares the circuitry for pragma 14622 -- Ident. The only differences are that Ident enforces a limit of 31 14623 -- characters on its argument, and also enforces limitations on 14624 -- placement for DEC compatibility. Pragma Comment shares neither of 14625 -- these restrictions. 14626 14627 ------------------- 14628 -- Common_Object -- 14629 ------------------- 14630 14631 -- pragma Common_Object ( 14632 -- [Internal =>] LOCAL_NAME 14633 -- [, [External =>] EXTERNAL_SYMBOL] 14634 -- [, [Size =>] EXTERNAL_SYMBOL]); 14635 14636 -- Processing for this pragma is shared with Psect_Object 14637 14638 ---------------------------------------------- 14639 -- Compile_Time_Error, Compile_Time_Warning -- 14640 ---------------------------------------------- 14641 14642 -- pragma Compile_Time_Error 14643 -- (boolean_EXPRESSION, static_string_EXPRESSION); 14644 14645 -- pragma Compile_Time_Warning 14646 -- (boolean_EXPRESSION, static_string_EXPRESSION); 14647 14648 when Pragma_Compile_Time_Error | Pragma_Compile_Time_Warning => 14649 GNAT_Pragma; 14650 Process_Compile_Time_Warning_Or_Error; 14651 14652 --------------------------- 14653 -- Compiler_Unit_Warning -- 14654 --------------------------- 14655 14656 -- pragma Compiler_Unit_Warning; 14657 14658 -- Historical note 14659 14660 -- Originally, we had only pragma Compiler_Unit, and it resulted in 14661 -- errors not warnings. This means that we had introduced a big extra 14662 -- inertia to compiler changes, since even if we implemented a new 14663 -- feature, and even if all versions to be used for bootstrapping 14664 -- implemented this new feature, we could not use it, since old 14665 -- compilers would give errors for using this feature in units 14666 -- having Compiler_Unit pragmas. 14667 14668 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the 14669 -- problem. We no longer have any units mentioning Compiler_Unit, 14670 -- so old compilers see Compiler_Unit_Warning which is unrecognized, 14671 -- and thus generates a warning which can be ignored. So that deals 14672 -- with the problem of old compilers not implementing the newer form 14673 -- of the pragma. 14674 14675 -- Newer compilers recognize the new pragma, but generate warning 14676 -- messages instead of errors, which again can be ignored in the 14677 -- case of an old compiler which implements a wanted new feature 14678 -- but at the time felt like warning about it for older compilers. 14679 14680 -- We retain Compiler_Unit so that new compilers can be used to build 14681 -- older run-times that use this pragma. That's an unusual case, but 14682 -- it's easy enough to handle, so why not? 14683 14684 when Pragma_Compiler_Unit 14685 | Pragma_Compiler_Unit_Warning 14686 => 14687 GNAT_Pragma; 14688 Check_Arg_Count (0); 14689 14690 -- Only recognized in main unit 14691 14692 if Current_Sem_Unit = Main_Unit then 14693 Compiler_Unit := True; 14694 end if; 14695 14696 ----------------------------- 14697 -- Complete_Representation -- 14698 ----------------------------- 14699 14700 -- pragma Complete_Representation; 14701 14702 when Pragma_Complete_Representation => 14703 GNAT_Pragma; 14704 Check_Arg_Count (0); 14705 14706 if Nkind (Parent (N)) /= N_Record_Representation_Clause then 14707 Error_Pragma 14708 ("pragma & must appear within record representation clause"); 14709 end if; 14710 14711 ---------------------------- 14712 -- Complex_Representation -- 14713 ---------------------------- 14714 14715 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); 14716 14717 when Pragma_Complex_Representation => Complex_Representation : declare 14718 E_Id : Entity_Id; 14719 E : Entity_Id; 14720 Ent : Entity_Id; 14721 14722 begin 14723 GNAT_Pragma; 14724 Check_Arg_Count (1); 14725 Check_Optional_Identifier (Arg1, Name_Entity); 14726 Check_Arg_Is_Local_Name (Arg1); 14727 E_Id := Get_Pragma_Arg (Arg1); 14728 14729 if Etype (E_Id) = Any_Type then 14730 return; 14731 end if; 14732 14733 E := Entity (E_Id); 14734 14735 if not Is_Record_Type (E) then 14736 Error_Pragma_Arg 14737 ("argument for pragma% must be record type", Arg1); 14738 end if; 14739 14740 Ent := First_Entity (E); 14741 14742 if No (Ent) 14743 or else No (Next_Entity (Ent)) 14744 or else Present (Next_Entity (Next_Entity (Ent))) 14745 or else not Is_Floating_Point_Type (Etype (Ent)) 14746 or else Etype (Ent) /= Etype (Next_Entity (Ent)) 14747 then 14748 Error_Pragma_Arg 14749 ("record for pragma% must have two fields of the same " 14750 & "floating-point type", Arg1); 14751 14752 else 14753 Set_Has_Complex_Representation (Base_Type (E)); 14754 14755 -- We need to treat the type has having a non-standard 14756 -- representation, for back-end purposes, even though in 14757 -- general a complex will have the default representation 14758 -- of a record with two real components. 14759 14760 Set_Has_Non_Standard_Rep (Base_Type (E)); 14761 end if; 14762 end Complex_Representation; 14763 14764 ------------------------- 14765 -- Component_Alignment -- 14766 ------------------------- 14767 14768 -- pragma Component_Alignment ( 14769 -- [Form =>] ALIGNMENT_CHOICE 14770 -- [, [Name =>] type_LOCAL_NAME]); 14771 -- 14772 -- ALIGNMENT_CHOICE ::= 14773 -- Component_Size 14774 -- | Component_Size_4 14775 -- | Storage_Unit 14776 -- | Default 14777 14778 when Pragma_Component_Alignment => Component_AlignmentP : declare 14779 Args : Args_List (1 .. 2); 14780 Names : constant Name_List (1 .. 2) := ( 14781 Name_Form, 14782 Name_Name); 14783 14784 Form : Node_Id renames Args (1); 14785 Name : Node_Id renames Args (2); 14786 14787 Atype : Component_Alignment_Kind; 14788 Typ : Entity_Id; 14789 14790 begin 14791 GNAT_Pragma; 14792 Gather_Associations (Names, Args); 14793 14794 if No (Form) then 14795 Error_Pragma ("missing Form argument for pragma%"); 14796 end if; 14797 14798 Check_Arg_Is_Identifier (Form); 14799 14800 -- Get proper alignment, note that Default = Component_Size on all 14801 -- machines we have so far, and we want to set this value rather 14802 -- than the default value to indicate that it has been explicitly 14803 -- set (and thus will not get overridden by the default component 14804 -- alignment for the current scope) 14805 14806 if Chars (Form) = Name_Component_Size then 14807 Atype := Calign_Component_Size; 14808 14809 elsif Chars (Form) = Name_Component_Size_4 then 14810 Atype := Calign_Component_Size_4; 14811 14812 elsif Chars (Form) = Name_Default then 14813 Atype := Calign_Component_Size; 14814 14815 elsif Chars (Form) = Name_Storage_Unit then 14816 Atype := Calign_Storage_Unit; 14817 14818 else 14819 Error_Pragma_Arg 14820 ("invalid Form parameter for pragma%", Form); 14821 end if; 14822 14823 -- The pragma appears in a configuration file 14824 14825 if No (Parent (N)) then 14826 Check_Valid_Configuration_Pragma; 14827 14828 -- Capture the component alignment in a global variable when 14829 -- the pragma appears in a configuration file. Note that the 14830 -- scope stack is empty at this point and cannot be used to 14831 -- store the alignment value. 14832 14833 Configuration_Component_Alignment := Atype; 14834 14835 -- Case with no name, supplied, affects scope table entry 14836 14837 elsif No (Name) then 14838 Scope_Stack.Table 14839 (Scope_Stack.Last).Component_Alignment_Default := Atype; 14840 14841 -- Case of name supplied 14842 14843 else 14844 Check_Arg_Is_Local_Name (Name); 14845 Find_Type (Name); 14846 Typ := Entity (Name); 14847 14848 if Typ = Any_Type 14849 or else Rep_Item_Too_Early (Typ, N) 14850 then 14851 return; 14852 else 14853 Typ := Underlying_Type (Typ); 14854 end if; 14855 14856 if not Is_Record_Type (Typ) 14857 and then not Is_Array_Type (Typ) 14858 then 14859 Error_Pragma_Arg 14860 ("Name parameter of pragma% must identify record or " 14861 & "array type", Name); 14862 end if; 14863 14864 -- An explicit Component_Alignment pragma overrides an 14865 -- implicit pragma Pack, but not an explicit one. 14866 14867 if not Has_Pragma_Pack (Base_Type (Typ)) then 14868 Set_Is_Packed (Base_Type (Typ), False); 14869 Set_Component_Alignment (Base_Type (Typ), Atype); 14870 end if; 14871 end if; 14872 end Component_AlignmentP; 14873 14874 -------------------------------- 14875 -- Constant_After_Elaboration -- 14876 -------------------------------- 14877 14878 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ]; 14879 14880 when Pragma_Constant_After_Elaboration => Constant_After_Elaboration : 14881 declare 14882 Obj_Decl : Node_Id; 14883 Obj_Id : Entity_Id; 14884 14885 begin 14886 GNAT_Pragma; 14887 Check_No_Identifiers; 14888 Check_At_Most_N_Arguments (1); 14889 14890 Obj_Decl := Find_Related_Context (N, Do_Checks => True); 14891 14892 if Nkind (Obj_Decl) /= N_Object_Declaration then 14893 Pragma_Misplaced; 14894 return; 14895 end if; 14896 14897 Obj_Id := Defining_Entity (Obj_Decl); 14898 14899 -- The object declaration must be a library-level variable which 14900 -- is either explicitly initialized or obtains a value during the 14901 -- elaboration of a package body (SPARK RM 3.3.1). 14902 14903 if Ekind (Obj_Id) = E_Variable then 14904 if not Is_Library_Level_Entity (Obj_Id) then 14905 Error_Pragma 14906 ("pragma % must apply to a library level variable"); 14907 return; 14908 end if; 14909 14910 -- Otherwise the pragma applies to a constant, which is illegal 14911 14912 else 14913 Error_Pragma ("pragma % must apply to a variable declaration"); 14914 return; 14915 end if; 14916 14917 -- A pragma that applies to a Ghost entity becomes Ghost for the 14918 -- purposes of legality checks and removal of ignored Ghost code. 14919 14920 Mark_Ghost_Pragma (N, Obj_Id); 14921 14922 -- Chain the pragma on the contract for completeness 14923 14924 Add_Contract_Item (N, Obj_Id); 14925 14926 -- Analyze the Boolean expression (if any) 14927 14928 if Present (Arg1) then 14929 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 14930 end if; 14931 end Constant_After_Elaboration; 14932 14933 -------------------- 14934 -- Contract_Cases -- 14935 -------------------- 14936 14937 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE)); 14938 14939 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE 14940 14941 -- CASE_GUARD ::= boolean_EXPRESSION | others 14942 14943 -- CONSEQUENCE ::= boolean_EXPRESSION 14944 14945 -- Characteristics: 14946 14947 -- * Analysis - The annotation undergoes initial checks to verify 14948 -- the legal placement and context. Secondary checks preanalyze the 14949 -- expressions in: 14950 14951 -- Analyze_Contract_Cases_In_Decl_Part 14952 14953 -- * Expansion - The annotation is expanded during the expansion of 14954 -- the related subprogram [body] contract as performed in: 14955 14956 -- Expand_Subprogram_Contract 14957 14958 -- * Template - The annotation utilizes the generic template of the 14959 -- related subprogram [body] when it is: 14960 14961 -- aspect on subprogram declaration 14962 -- aspect on stand-alone subprogram body 14963 -- pragma on stand-alone subprogram body 14964 14965 -- The annotation must prepare its own template when it is: 14966 14967 -- pragma on subprogram declaration 14968 14969 -- * Globals - Capture of global references must occur after full 14970 -- analysis. 14971 14972 -- * Instance - The annotation is instantiated automatically when 14973 -- the related generic subprogram [body] is instantiated except for 14974 -- the "pragma on subprogram declaration" case. In that scenario 14975 -- the annotation must instantiate itself. 14976 14977 when Pragma_Contract_Cases => Contract_Cases : declare 14978 Spec_Id : Entity_Id; 14979 Subp_Decl : Node_Id; 14980 Subp_Spec : Node_Id; 14981 14982 begin 14983 GNAT_Pragma; 14984 Check_No_Identifiers; 14985 Check_Arg_Count (1); 14986 14987 -- Ensure the proper placement of the pragma. Contract_Cases must 14988 -- be associated with a subprogram declaration or a body that acts 14989 -- as a spec. 14990 14991 Subp_Decl := 14992 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 14993 14994 -- Entry 14995 14996 if Nkind (Subp_Decl) = N_Entry_Declaration then 14997 null; 14998 14999 -- Generic subprogram 15000 15001 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 15002 null; 15003 15004 -- Body acts as spec 15005 15006 elsif Nkind (Subp_Decl) = N_Subprogram_Body 15007 and then No (Corresponding_Spec (Subp_Decl)) 15008 then 15009 null; 15010 15011 -- Body stub acts as spec 15012 15013 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 15014 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 15015 then 15016 null; 15017 15018 -- Subprogram 15019 15020 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 15021 Subp_Spec := Specification (Subp_Decl); 15022 15023 -- Pragma Contract_Cases is forbidden on null procedures, as 15024 -- this may lead to potential ambiguities in behavior when 15025 -- interface null procedures are involved. 15026 15027 if Nkind (Subp_Spec) = N_Procedure_Specification 15028 and then Null_Present (Subp_Spec) 15029 then 15030 Error_Msg_N (Fix_Error 15031 ("pragma % cannot apply to null procedure"), N); 15032 return; 15033 end if; 15034 15035 else 15036 Pragma_Misplaced; 15037 return; 15038 end if; 15039 15040 Spec_Id := Unique_Defining_Entity (Subp_Decl); 15041 15042 -- A pragma that applies to a Ghost entity becomes Ghost for the 15043 -- purposes of legality checks and removal of ignored Ghost code. 15044 15045 Mark_Ghost_Pragma (N, Spec_Id); 15046 Ensure_Aggregate_Form (Get_Argument (N, Spec_Id)); 15047 15048 -- Chain the pragma on the contract for further processing by 15049 -- Analyze_Contract_Cases_In_Decl_Part. 15050 15051 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 15052 15053 -- Fully analyze the pragma when it appears inside an entry 15054 -- or subprogram body because it cannot benefit from forward 15055 -- references. 15056 15057 if Nkind_In (Subp_Decl, N_Entry_Body, 15058 N_Subprogram_Body, 15059 N_Subprogram_Body_Stub) 15060 then 15061 -- The legality checks of pragma Contract_Cases are affected by 15062 -- the SPARK mode in effect and the volatility of the context. 15063 -- Analyze all pragmas in a specific order. 15064 15065 Analyze_If_Present (Pragma_SPARK_Mode); 15066 Analyze_If_Present (Pragma_Volatile_Function); 15067 Analyze_Contract_Cases_In_Decl_Part (N); 15068 end if; 15069 end Contract_Cases; 15070 15071 ---------------- 15072 -- Controlled -- 15073 ---------------- 15074 15075 -- pragma Controlled (first_subtype_LOCAL_NAME); 15076 15077 when Pragma_Controlled => Controlled : declare 15078 Arg : Node_Id; 15079 15080 begin 15081 Check_No_Identifiers; 15082 Check_Arg_Count (1); 15083 Check_Arg_Is_Local_Name (Arg1); 15084 Arg := Get_Pragma_Arg (Arg1); 15085 15086 if not Is_Entity_Name (Arg) 15087 or else not Is_Access_Type (Entity (Arg)) 15088 then 15089 Error_Pragma_Arg ("pragma% requires access type", Arg1); 15090 else 15091 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); 15092 end if; 15093 end Controlled; 15094 15095 ---------------- 15096 -- Convention -- 15097 ---------------- 15098 15099 -- pragma Convention ([Convention =>] convention_IDENTIFIER, 15100 -- [Entity =>] LOCAL_NAME); 15101 15102 when Pragma_Convention => Convention : declare 15103 C : Convention_Id; 15104 E : Entity_Id; 15105 pragma Warnings (Off, C); 15106 pragma Warnings (Off, E); 15107 15108 begin 15109 Check_Arg_Order ((Name_Convention, Name_Entity)); 15110 Check_Ada_83_Warning; 15111 Check_Arg_Count (2); 15112 Process_Convention (C, E); 15113 15114 -- A pragma that applies to a Ghost entity becomes Ghost for the 15115 -- purposes of legality checks and removal of ignored Ghost code. 15116 15117 Mark_Ghost_Pragma (N, E); 15118 end Convention; 15119 15120 --------------------------- 15121 -- Convention_Identifier -- 15122 --------------------------- 15123 15124 -- pragma Convention_Identifier ([Name =>] IDENTIFIER, 15125 -- [Convention =>] convention_IDENTIFIER); 15126 15127 when Pragma_Convention_Identifier => Convention_Identifier : declare 15128 Idnam : Name_Id; 15129 Cname : Name_Id; 15130 15131 begin 15132 GNAT_Pragma; 15133 Check_Arg_Order ((Name_Name, Name_Convention)); 15134 Check_Arg_Count (2); 15135 Check_Optional_Identifier (Arg1, Name_Name); 15136 Check_Optional_Identifier (Arg2, Name_Convention); 15137 Check_Arg_Is_Identifier (Arg1); 15138 Check_Arg_Is_Identifier (Arg2); 15139 Idnam := Chars (Get_Pragma_Arg (Arg1)); 15140 Cname := Chars (Get_Pragma_Arg (Arg2)); 15141 15142 if Is_Convention_Name (Cname) then 15143 Record_Convention_Identifier 15144 (Idnam, Get_Convention_Id (Cname)); 15145 else 15146 Error_Pragma_Arg 15147 ("second arg for % pragma must be convention", Arg2); 15148 end if; 15149 end Convention_Identifier; 15150 15151 --------------- 15152 -- CPP_Class -- 15153 --------------- 15154 15155 -- pragma CPP_Class ([Entity =>] LOCAL_NAME) 15156 15157 when Pragma_CPP_Class => 15158 GNAT_Pragma; 15159 15160 if Warn_On_Obsolescent_Feature then 15161 Error_Msg_N 15162 ("'G'N'A'T pragma cpp'_class is now obsolete and has no " 15163 & "effect; replace it by pragma import?j?", N); 15164 end if; 15165 15166 Check_Arg_Count (1); 15167 15168 Rewrite (N, 15169 Make_Pragma (Loc, 15170 Chars => Name_Import, 15171 Pragma_Argument_Associations => New_List ( 15172 Make_Pragma_Argument_Association (Loc, 15173 Expression => Make_Identifier (Loc, Name_CPP)), 15174 New_Copy (First (Pragma_Argument_Associations (N)))))); 15175 Analyze (N); 15176 15177 --------------------- 15178 -- CPP_Constructor -- 15179 --------------------- 15180 15181 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME 15182 -- [, [External_Name =>] static_string_EXPRESSION ] 15183 -- [, [Link_Name =>] static_string_EXPRESSION ]); 15184 15185 when Pragma_CPP_Constructor => CPP_Constructor : declare 15186 Elmt : Elmt_Id; 15187 Id : Entity_Id; 15188 Def_Id : Entity_Id; 15189 Tag_Typ : Entity_Id; 15190 15191 begin 15192 GNAT_Pragma; 15193 Check_At_Least_N_Arguments (1); 15194 Check_At_Most_N_Arguments (3); 15195 Check_Optional_Identifier (Arg1, Name_Entity); 15196 Check_Arg_Is_Local_Name (Arg1); 15197 15198 Id := Get_Pragma_Arg (Arg1); 15199 Find_Program_Unit_Name (Id); 15200 15201 -- If we did not find the name, we are done 15202 15203 if Etype (Id) = Any_Type then 15204 return; 15205 end if; 15206 15207 Def_Id := Entity (Id); 15208 15209 -- Check if already defined as constructor 15210 15211 if Is_Constructor (Def_Id) then 15212 Error_Msg_N 15213 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1); 15214 return; 15215 end if; 15216 15217 if Ekind (Def_Id) = E_Function 15218 and then (Is_CPP_Class (Etype (Def_Id)) 15219 or else (Is_Class_Wide_Type (Etype (Def_Id)) 15220 and then 15221 Is_CPP_Class (Root_Type (Etype (Def_Id))))) 15222 then 15223 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then 15224 Error_Msg_N 15225 ("'C'P'P constructor must be defined in the scope of " 15226 & "its returned type", Arg1); 15227 end if; 15228 15229 if Arg_Count >= 2 then 15230 Set_Imported (Def_Id); 15231 Set_Is_Public (Def_Id); 15232 Process_Interface_Name (Def_Id, Arg2, Arg3, N); 15233 end if; 15234 15235 Set_Has_Completion (Def_Id); 15236 Set_Is_Constructor (Def_Id); 15237 Set_Convention (Def_Id, Convention_CPP); 15238 15239 -- Imported C++ constructors are not dispatching primitives 15240 -- because in C++ they don't have a dispatch table slot. 15241 -- However, in Ada the constructor has the profile of a 15242 -- function that returns a tagged type and therefore it has 15243 -- been treated as a primitive operation during semantic 15244 -- analysis. We now remove it from the list of primitive 15245 -- operations of the type. 15246 15247 if Is_Tagged_Type (Etype (Def_Id)) 15248 and then not Is_Class_Wide_Type (Etype (Def_Id)) 15249 and then Is_Dispatching_Operation (Def_Id) 15250 then 15251 Tag_Typ := Etype (Def_Id); 15252 15253 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 15254 while Present (Elmt) and then Node (Elmt) /= Def_Id loop 15255 Next_Elmt (Elmt); 15256 end loop; 15257 15258 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); 15259 Set_Is_Dispatching_Operation (Def_Id, False); 15260 end if; 15261 15262 -- For backward compatibility, if the constructor returns a 15263 -- class wide type, and we internally change the return type to 15264 -- the corresponding root type. 15265 15266 if Is_Class_Wide_Type (Etype (Def_Id)) then 15267 Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); 15268 end if; 15269 else 15270 Error_Pragma_Arg 15271 ("pragma% requires function returning a 'C'P'P_Class type", 15272 Arg1); 15273 end if; 15274 end CPP_Constructor; 15275 15276 ----------------- 15277 -- CPP_Virtual -- 15278 ----------------- 15279 15280 when Pragma_CPP_Virtual => 15281 GNAT_Pragma; 15282 15283 if Warn_On_Obsolescent_Feature then 15284 Error_Msg_N 15285 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no " 15286 & "effect?j?", N); 15287 end if; 15288 15289 ---------------- 15290 -- CPP_Vtable -- 15291 ---------------- 15292 15293 when Pragma_CPP_Vtable => 15294 GNAT_Pragma; 15295 15296 if Warn_On_Obsolescent_Feature then 15297 Error_Msg_N 15298 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no " 15299 & "effect?j?", N); 15300 end if; 15301 15302 --------- 15303 -- CPU -- 15304 --------- 15305 15306 -- pragma CPU (EXPRESSION); 15307 15308 when Pragma_CPU => CPU : declare 15309 P : constant Node_Id := Parent (N); 15310 Arg : Node_Id; 15311 Ent : Entity_Id; 15312 15313 begin 15314 Ada_2012_Pragma; 15315 Check_No_Identifiers; 15316 Check_Arg_Count (1); 15317 15318 -- Subprogram case 15319 15320 if Nkind (P) = N_Subprogram_Body then 15321 Check_In_Main_Program; 15322 15323 Arg := Get_Pragma_Arg (Arg1); 15324 Analyze_And_Resolve (Arg, Any_Integer); 15325 15326 Ent := Defining_Unit_Name (Specification (P)); 15327 15328 if Nkind (Ent) = N_Defining_Program_Unit_Name then 15329 Ent := Defining_Identifier (Ent); 15330 end if; 15331 15332 -- Must be static 15333 15334 if not Is_OK_Static_Expression (Arg) then 15335 Flag_Non_Static_Expr 15336 ("main subprogram affinity is not static!", Arg); 15337 raise Pragma_Exit; 15338 15339 -- If constraint error, then we already signalled an error 15340 15341 elsif Raises_Constraint_Error (Arg) then 15342 null; 15343 15344 -- Otherwise check in range 15345 15346 else 15347 declare 15348 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); 15349 -- This is the entity System.Multiprocessors.CPU_Range; 15350 15351 Val : constant Uint := Expr_Value (Arg); 15352 15353 begin 15354 if Val < Expr_Value (Type_Low_Bound (CPU_Id)) 15355 or else 15356 Val > Expr_Value (Type_High_Bound (CPU_Id)) 15357 then 15358 Error_Pragma_Arg 15359 ("main subprogram CPU is out of range", Arg1); 15360 end if; 15361 end; 15362 end if; 15363 15364 Set_Main_CPU 15365 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 15366 15367 -- Task case 15368 15369 elsif Nkind (P) = N_Task_Definition then 15370 Arg := Get_Pragma_Arg (Arg1); 15371 Ent := Defining_Identifier (Parent (P)); 15372 15373 -- The expression must be analyzed in the special manner 15374 -- described in "Handling of Default and Per-Object 15375 -- Expressions" in sem.ads. 15376 15377 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); 15378 15379 -- Anything else is incorrect 15380 15381 else 15382 Pragma_Misplaced; 15383 end if; 15384 15385 -- Check duplicate pragma before we chain the pragma in the Rep 15386 -- Item chain of Ent. 15387 15388 Check_Duplicate_Pragma (Ent); 15389 Record_Rep_Item (Ent, N); 15390 end CPU; 15391 15392 -------------------- 15393 -- Deadline_Floor -- 15394 -------------------- 15395 15396 -- pragma Deadline_Floor (time_span_EXPRESSION); 15397 15398 when Pragma_Deadline_Floor => Deadline_Floor : declare 15399 P : constant Node_Id := Parent (N); 15400 Arg : Node_Id; 15401 Ent : Entity_Id; 15402 15403 begin 15404 GNAT_Pragma; 15405 Check_No_Identifiers; 15406 Check_Arg_Count (1); 15407 15408 Arg := Get_Pragma_Arg (Arg1); 15409 15410 -- The expression must be analyzed in the special manner described 15411 -- in "Handling of Default and Per-Object Expressions" in sem.ads. 15412 15413 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); 15414 15415 -- Only protected types allowed 15416 15417 if Nkind (P) /= N_Protected_Definition then 15418 Pragma_Misplaced; 15419 15420 else 15421 Ent := Defining_Identifier (Parent (P)); 15422 15423 -- Check duplicate pragma before we chain the pragma in the Rep 15424 -- Item chain of Ent. 15425 15426 Check_Duplicate_Pragma (Ent); 15427 Record_Rep_Item (Ent, N); 15428 end if; 15429 end Deadline_Floor; 15430 15431 ----------- 15432 -- Debug -- 15433 ----------- 15434 15435 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); 15436 15437 when Pragma_Debug => Debug : declare 15438 Cond : Node_Id; 15439 Call : Node_Id; 15440 15441 begin 15442 GNAT_Pragma; 15443 15444 -- The condition for executing the call is that the expander 15445 -- is active and that we are not ignoring this debug pragma. 15446 15447 Cond := 15448 New_Occurrence_Of 15449 (Boolean_Literals 15450 (Expander_Active and then not Is_Ignored (N)), 15451 Loc); 15452 15453 if not Is_Ignored (N) then 15454 Set_SCO_Pragma_Enabled (Loc); 15455 end if; 15456 15457 if Arg_Count = 2 then 15458 Cond := 15459 Make_And_Then (Loc, 15460 Left_Opnd => Relocate_Node (Cond), 15461 Right_Opnd => Get_Pragma_Arg (Arg1)); 15462 Call := Get_Pragma_Arg (Arg2); 15463 else 15464 Call := Get_Pragma_Arg (Arg1); 15465 end if; 15466 15467 if Nkind_In (Call, N_Expanded_Name, 15468 N_Function_Call, 15469 N_Identifier, 15470 N_Indexed_Component, 15471 N_Selected_Component) 15472 then 15473 -- If this pragma Debug comes from source, its argument was 15474 -- parsed as a name form (which is syntactically identical). 15475 -- In a generic context a parameterless call will be left as 15476 -- an expanded name (if global) or selected_component if local. 15477 -- Change it to a procedure call statement now. 15478 15479 Change_Name_To_Procedure_Call_Statement (Call); 15480 15481 elsif Nkind (Call) = N_Procedure_Call_Statement then 15482 15483 -- Already in the form of a procedure call statement: nothing 15484 -- to do (could happen in case of an internally generated 15485 -- pragma Debug). 15486 15487 null; 15488 15489 else 15490 -- All other cases: diagnose error 15491 15492 Error_Msg 15493 ("argument of pragma ""Debug"" is not procedure call", 15494 Sloc (Call)); 15495 return; 15496 end if; 15497 15498 -- Rewrite into a conditional with an appropriate condition. We 15499 -- wrap the procedure call in a block so that overhead from e.g. 15500 -- use of the secondary stack does not generate execution overhead 15501 -- for suppressed conditions. 15502 15503 -- Normally the analysis that follows will freeze the subprogram 15504 -- being called. However, if the call is to a null procedure, 15505 -- we want to freeze it before creating the block, because the 15506 -- analysis that follows may be done with expansion disabled, in 15507 -- which case the body will not be generated, leading to spurious 15508 -- errors. 15509 15510 if Nkind (Call) = N_Procedure_Call_Statement 15511 and then Is_Entity_Name (Name (Call)) 15512 then 15513 Analyze (Name (Call)); 15514 Freeze_Before (N, Entity (Name (Call))); 15515 end if; 15516 15517 Rewrite (N, 15518 Make_Implicit_If_Statement (N, 15519 Condition => Cond, 15520 Then_Statements => New_List ( 15521 Make_Block_Statement (Loc, 15522 Handled_Statement_Sequence => 15523 Make_Handled_Sequence_Of_Statements (Loc, 15524 Statements => New_List (Relocate_Node (Call))))))); 15525 Analyze (N); 15526 15527 -- Ignore pragma Debug in GNATprove mode. Do this rewriting 15528 -- after analysis of the normally rewritten node, to capture all 15529 -- references to entities, which avoids issuing wrong warnings 15530 -- about unused entities. 15531 15532 if GNATprove_Mode then 15533 Rewrite (N, Make_Null_Statement (Loc)); 15534 end if; 15535 end Debug; 15536 15537 ------------------ 15538 -- Debug_Policy -- 15539 ------------------ 15540 15541 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore) 15542 15543 when Pragma_Debug_Policy => 15544 GNAT_Pragma; 15545 Check_Arg_Count (1); 15546 Check_No_Identifiers; 15547 Check_Arg_Is_Identifier (Arg1); 15548 15549 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so 15550 -- rewrite it that way, and let the rest of the checking come 15551 -- from analyzing the rewritten pragma. 15552 15553 Rewrite (N, 15554 Make_Pragma (Loc, 15555 Chars => Name_Check_Policy, 15556 Pragma_Argument_Associations => New_List ( 15557 Make_Pragma_Argument_Association (Loc, 15558 Expression => Make_Identifier (Loc, Name_Debug)), 15559 15560 Make_Pragma_Argument_Association (Loc, 15561 Expression => Get_Pragma_Arg (Arg1))))); 15562 Analyze (N); 15563 15564 ------------------------------- 15565 -- Default_Initial_Condition -- 15566 ------------------------------- 15567 15568 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ]; 15569 15570 when Pragma_Default_Initial_Condition => DIC : declare 15571 Discard : Boolean; 15572 Stmt : Node_Id; 15573 Typ : Entity_Id; 15574 15575 begin 15576 GNAT_Pragma; 15577 Check_No_Identifiers; 15578 Check_At_Most_N_Arguments (1); 15579 15580 Typ := Empty; 15581 Stmt := Prev (N); 15582 while Present (Stmt) loop 15583 15584 -- Skip prior pragmas, but check for duplicates 15585 15586 if Nkind (Stmt) = N_Pragma then 15587 if Pragma_Name (Stmt) = Pname then 15588 Duplication_Error 15589 (Prag => N, 15590 Prev => Stmt); 15591 raise Pragma_Exit; 15592 end if; 15593 15594 -- Skip internally generated code. Note that derived type 15595 -- declarations of untagged types with discriminants are 15596 -- rewritten as private type declarations. 15597 15598 elsif not Comes_From_Source (Stmt) 15599 and then Nkind (Stmt) /= N_Private_Type_Declaration 15600 then 15601 null; 15602 15603 -- The associated private type [extension] has been found, stop 15604 -- the search. 15605 15606 elsif Nkind_In (Stmt, N_Private_Extension_Declaration, 15607 N_Private_Type_Declaration) 15608 then 15609 Typ := Defining_Entity (Stmt); 15610 exit; 15611 15612 -- The pragma does not apply to a legal construct, issue an 15613 -- error and stop the analysis. 15614 15615 else 15616 Pragma_Misplaced; 15617 return; 15618 end if; 15619 15620 Stmt := Prev (Stmt); 15621 end loop; 15622 15623 -- The pragma does not apply to a legal construct, issue an error 15624 -- and stop the analysis. 15625 15626 if No (Typ) then 15627 Pragma_Misplaced; 15628 return; 15629 end if; 15630 15631 -- A pragma that applies to a Ghost entity becomes Ghost for the 15632 -- purposes of legality checks and removal of ignored Ghost code. 15633 15634 Mark_Ghost_Pragma (N, Typ); 15635 15636 -- The pragma signals that the type defines its own DIC assertion 15637 -- expression. 15638 15639 Set_Has_Own_DIC (Typ); 15640 15641 -- Chain the pragma on the rep item chain for further processing 15642 15643 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 15644 15645 -- Create the declaration of the procedure which verifies the 15646 -- assertion expression of pragma DIC at runtime. 15647 15648 Build_DIC_Procedure_Declaration (Typ); 15649 end DIC; 15650 15651 ---------------------------------- 15652 -- Default_Scalar_Storage_Order -- 15653 ---------------------------------- 15654 15655 -- pragma Default_Scalar_Storage_Order 15656 -- (High_Order_First | Low_Order_First); 15657 15658 when Pragma_Default_Scalar_Storage_Order => DSSO : declare 15659 Default : Character; 15660 15661 begin 15662 GNAT_Pragma; 15663 Check_Arg_Count (1); 15664 15665 -- Default_Scalar_Storage_Order can appear as a configuration 15666 -- pragma, or in a declarative part of a package spec. 15667 15668 if not Is_Configuration_Pragma then 15669 Check_Is_In_Decl_Part_Or_Package_Spec; 15670 end if; 15671 15672 Check_No_Identifiers; 15673 Check_Arg_Is_One_Of 15674 (Arg1, Name_High_Order_First, Name_Low_Order_First); 15675 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 15676 Default := Fold_Upper (Name_Buffer (1)); 15677 15678 if not Support_Nondefault_SSO_On_Target 15679 and then (Ttypes.Bytes_Big_Endian /= (Default = 'H')) 15680 then 15681 if Warn_On_Unrecognized_Pragma then 15682 Error_Msg_N 15683 ("non-default Scalar_Storage_Order not supported " 15684 & "on target?g?", N); 15685 Error_Msg_N 15686 ("\pragma Default_Scalar_Storage_Order ignored?g?", N); 15687 end if; 15688 15689 -- Here set the specified default 15690 15691 else 15692 Opt.Default_SSO := Default; 15693 end if; 15694 end DSSO; 15695 15696 -------------------------- 15697 -- Default_Storage_Pool -- 15698 -------------------------- 15699 15700 -- pragma Default_Storage_Pool (storage_pool_NAME | null); 15701 15702 when Pragma_Default_Storage_Pool => Default_Storage_Pool : declare 15703 Pool : Node_Id; 15704 15705 begin 15706 Ada_2012_Pragma; 15707 Check_Arg_Count (1); 15708 15709 -- Default_Storage_Pool can appear as a configuration pragma, or 15710 -- in a declarative part of a package spec. 15711 15712 if not Is_Configuration_Pragma then 15713 Check_Is_In_Decl_Part_Or_Package_Spec; 15714 end if; 15715 15716 if From_Aspect_Specification (N) then 15717 declare 15718 E : constant Entity_Id := Entity (Corresponding_Aspect (N)); 15719 begin 15720 if not In_Open_Scopes (E) then 15721 Error_Msg_N 15722 ("aspect must apply to package or subprogram", N); 15723 end if; 15724 end; 15725 end if; 15726 15727 if Present (Arg1) then 15728 Pool := Get_Pragma_Arg (Arg1); 15729 15730 -- Case of Default_Storage_Pool (null); 15731 15732 if Nkind (Pool) = N_Null then 15733 Analyze (Pool); 15734 15735 -- This is an odd case, this is not really an expression, 15736 -- so we don't have a type for it. So just set the type to 15737 -- Empty. 15738 15739 Set_Etype (Pool, Empty); 15740 15741 -- Case of Default_Storage_Pool (storage_pool_NAME); 15742 15743 else 15744 -- If it's a configuration pragma, then the only allowed 15745 -- argument is "null". 15746 15747 if Is_Configuration_Pragma then 15748 Error_Pragma_Arg ("NULL expected", Arg1); 15749 end if; 15750 15751 -- The expected type for a non-"null" argument is 15752 -- Root_Storage_Pool'Class, and the pool must be a variable. 15753 15754 Analyze_And_Resolve 15755 (Pool, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 15756 15757 if Is_Variable (Pool) then 15758 15759 -- A pragma that applies to a Ghost entity becomes Ghost 15760 -- for the purposes of legality checks and removal of 15761 -- ignored Ghost code. 15762 15763 Mark_Ghost_Pragma (N, Entity (Pool)); 15764 15765 else 15766 Error_Pragma_Arg 15767 ("default storage pool must be a variable", Arg1); 15768 end if; 15769 end if; 15770 15771 -- Record the pool name (or null). Freeze.Freeze_Entity for an 15772 -- access type will use this information to set the appropriate 15773 -- attributes of the access type. If the pragma appears in a 15774 -- generic unit it is ignored, given that it may refer to a 15775 -- local entity. 15776 15777 if not Inside_A_Generic then 15778 Default_Pool := Pool; 15779 end if; 15780 end if; 15781 end Default_Storage_Pool; 15782 15783 ------------- 15784 -- Depends -- 15785 ------------- 15786 15787 -- pragma Depends (DEPENDENCY_RELATION); 15788 15789 -- DEPENDENCY_RELATION ::= 15790 -- null 15791 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}) 15792 15793 -- DEPENDENCY_CLAUSE ::= 15794 -- OUTPUT_LIST =>[+] INPUT_LIST 15795 -- | NULL_DEPENDENCY_CLAUSE 15796 15797 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 15798 15799 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 15800 15801 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 15802 15803 -- OUTPUT ::= NAME | FUNCTION_RESULT 15804 -- INPUT ::= NAME 15805 15806 -- where FUNCTION_RESULT is a function Result attribute_reference 15807 15808 -- Characteristics: 15809 15810 -- * Analysis - The annotation undergoes initial checks to verify 15811 -- the legal placement and context. Secondary checks fully analyze 15812 -- the dependency clauses in: 15813 15814 -- Analyze_Depends_In_Decl_Part 15815 15816 -- * Expansion - None. 15817 15818 -- * Template - The annotation utilizes the generic template of the 15819 -- related subprogram [body] when it is: 15820 15821 -- aspect on subprogram declaration 15822 -- aspect on stand-alone subprogram body 15823 -- pragma on stand-alone subprogram body 15824 15825 -- The annotation must prepare its own template when it is: 15826 15827 -- pragma on subprogram declaration 15828 15829 -- * Globals - Capture of global references must occur after full 15830 -- analysis. 15831 15832 -- * Instance - The annotation is instantiated automatically when 15833 -- the related generic subprogram [body] is instantiated except for 15834 -- the "pragma on subprogram declaration" case. In that scenario 15835 -- the annotation must instantiate itself. 15836 15837 when Pragma_Depends => Depends : declare 15838 Legal : Boolean; 15839 Spec_Id : Entity_Id; 15840 Subp_Decl : Node_Id; 15841 15842 begin 15843 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); 15844 15845 if Legal then 15846 15847 -- Chain the pragma on the contract for further processing by 15848 -- Analyze_Depends_In_Decl_Part. 15849 15850 Add_Contract_Item (N, Spec_Id); 15851 15852 -- Fully analyze the pragma when it appears inside an entry 15853 -- or subprogram body because it cannot benefit from forward 15854 -- references. 15855 15856 if Nkind_In (Subp_Decl, N_Entry_Body, 15857 N_Subprogram_Body, 15858 N_Subprogram_Body_Stub) 15859 then 15860 -- The legality checks of pragmas Depends and Global are 15861 -- affected by the SPARK mode in effect and the volatility 15862 -- of the context. In addition these two pragmas are subject 15863 -- to an inherent order: 15864 15865 -- 1) Global 15866 -- 2) Depends 15867 15868 -- Analyze all these pragmas in the order outlined above 15869 15870 Analyze_If_Present (Pragma_SPARK_Mode); 15871 Analyze_If_Present (Pragma_Volatile_Function); 15872 Analyze_If_Present (Pragma_Global); 15873 Analyze_Depends_In_Decl_Part (N); 15874 end if; 15875 end if; 15876 end Depends; 15877 15878 --------------------- 15879 -- Detect_Blocking -- 15880 --------------------- 15881 15882 -- pragma Detect_Blocking; 15883 15884 when Pragma_Detect_Blocking => 15885 Ada_2005_Pragma; 15886 Check_Arg_Count (0); 15887 Check_Valid_Configuration_Pragma; 15888 Detect_Blocking := True; 15889 15890 ------------------------------------ 15891 -- Disable_Atomic_Synchronization -- 15892 ------------------------------------ 15893 15894 -- pragma Disable_Atomic_Synchronization [(Entity)]; 15895 15896 when Pragma_Disable_Atomic_Synchronization => 15897 GNAT_Pragma; 15898 Process_Disable_Enable_Atomic_Sync (Name_Suppress); 15899 15900 ------------------- 15901 -- Discard_Names -- 15902 ------------------- 15903 15904 -- pragma Discard_Names [([On =>] LOCAL_NAME)]; 15905 15906 when Pragma_Discard_Names => Discard_Names : declare 15907 E : Entity_Id; 15908 E_Id : Node_Id; 15909 15910 begin 15911 Check_Ada_83_Warning; 15912 15913 -- Deal with configuration pragma case 15914 15915 if Arg_Count = 0 and then Is_Configuration_Pragma then 15916 Global_Discard_Names := True; 15917 return; 15918 15919 -- Otherwise, check correct appropriate context 15920 15921 else 15922 Check_Is_In_Decl_Part_Or_Package_Spec; 15923 15924 if Arg_Count = 0 then 15925 15926 -- If there is no parameter, then from now on this pragma 15927 -- applies to any enumeration, exception or tagged type 15928 -- defined in the current declarative part, and recursively 15929 -- to any nested scope. 15930 15931 Set_Discard_Names (Current_Scope); 15932 return; 15933 15934 else 15935 Check_Arg_Count (1); 15936 Check_Optional_Identifier (Arg1, Name_On); 15937 Check_Arg_Is_Local_Name (Arg1); 15938 15939 E_Id := Get_Pragma_Arg (Arg1); 15940 15941 if Etype (E_Id) = Any_Type then 15942 return; 15943 end if; 15944 15945 E := Entity (E_Id); 15946 15947 -- A pragma that applies to a Ghost entity becomes Ghost for 15948 -- the purposes of legality checks and removal of ignored 15949 -- Ghost code. 15950 15951 Mark_Ghost_Pragma (N, E); 15952 15953 if (Is_First_Subtype (E) 15954 and then 15955 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) 15956 or else Ekind (E) = E_Exception 15957 then 15958 Set_Discard_Names (E); 15959 Record_Rep_Item (E, N); 15960 15961 else 15962 Error_Pragma_Arg 15963 ("inappropriate entity for pragma%", Arg1); 15964 end if; 15965 end if; 15966 end if; 15967 end Discard_Names; 15968 15969 ------------------------ 15970 -- Dispatching_Domain -- 15971 ------------------------ 15972 15973 -- pragma Dispatching_Domain (EXPRESSION); 15974 15975 when Pragma_Dispatching_Domain => Dispatching_Domain : declare 15976 P : constant Node_Id := Parent (N); 15977 Arg : Node_Id; 15978 Ent : Entity_Id; 15979 15980 begin 15981 Ada_2012_Pragma; 15982 Check_No_Identifiers; 15983 Check_Arg_Count (1); 15984 15985 -- This pragma is born obsolete, but not the aspect 15986 15987 if not From_Aspect_Specification (N) then 15988 Check_Restriction 15989 (No_Obsolescent_Features, Pragma_Identifier (N)); 15990 end if; 15991 15992 if Nkind (P) = N_Task_Definition then 15993 Arg := Get_Pragma_Arg (Arg1); 15994 Ent := Defining_Identifier (Parent (P)); 15995 15996 -- A pragma that applies to a Ghost entity becomes Ghost for 15997 -- the purposes of legality checks and removal of ignored Ghost 15998 -- code. 15999 16000 Mark_Ghost_Pragma (N, Ent); 16001 16002 -- The expression must be analyzed in the special manner 16003 -- described in "Handling of Default and Per-Object 16004 -- Expressions" in sem.ads. 16005 16006 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); 16007 16008 -- Check duplicate pragma before we chain the pragma in the Rep 16009 -- Item chain of Ent. 16010 16011 Check_Duplicate_Pragma (Ent); 16012 Record_Rep_Item (Ent, N); 16013 16014 -- Anything else is incorrect 16015 16016 else 16017 Pragma_Misplaced; 16018 end if; 16019 end Dispatching_Domain; 16020 16021 --------------- 16022 -- Elaborate -- 16023 --------------- 16024 16025 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); 16026 16027 when Pragma_Elaborate => Elaborate : declare 16028 Arg : Node_Id; 16029 Citem : Node_Id; 16030 16031 begin 16032 -- Pragma must be in context items list of a compilation unit 16033 16034 if not Is_In_Context_Clause then 16035 Pragma_Misplaced; 16036 end if; 16037 16038 -- Must be at least one argument 16039 16040 if Arg_Count = 0 then 16041 Error_Pragma ("pragma% requires at least one argument"); 16042 end if; 16043 16044 -- In Ada 83 mode, there can be no items following it in the 16045 -- context list except other pragmas and implicit with clauses 16046 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this 16047 -- placement rule does not apply. 16048 16049 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 16050 Citem := Next (N); 16051 while Present (Citem) loop 16052 if Nkind (Citem) = N_Pragma 16053 or else (Nkind (Citem) = N_With_Clause 16054 and then Implicit_With (Citem)) 16055 then 16056 null; 16057 else 16058 Error_Pragma 16059 ("(Ada 83) pragma% must be at end of context clause"); 16060 end if; 16061 16062 Next (Citem); 16063 end loop; 16064 end if; 16065 16066 -- Finally, the arguments must all be units mentioned in a with 16067 -- clause in the same context clause. Note we already checked (in 16068 -- Par.Prag) that the arguments are all identifiers or selected 16069 -- components. 16070 16071 Arg := Arg1; 16072 Outer : while Present (Arg) loop 16073 Citem := First (List_Containing (N)); 16074 Inner : while Citem /= N loop 16075 if Nkind (Citem) = N_With_Clause 16076 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 16077 then 16078 Set_Elaborate_Present (Citem, True); 16079 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 16080 16081 -- With the pragma present, elaboration calls on 16082 -- subprograms from the named unit need no further 16083 -- checks, as long as the pragma appears in the current 16084 -- compilation unit. If the pragma appears in some unit 16085 -- in the context, there might still be a need for an 16086 -- Elaborate_All_Desirable from the current compilation 16087 -- to the named unit, so we keep the check enabled. This 16088 -- does not apply in SPARK mode, where we allow pragma 16089 -- Elaborate, but we don't trust it to be right so we 16090 -- will still insist on the Elaborate_All. 16091 16092 if Legacy_Elaboration_Checks 16093 and then In_Extended_Main_Source_Unit (N) 16094 and then SPARK_Mode /= On 16095 then 16096 Set_Suppress_Elaboration_Warnings 16097 (Entity (Name (Citem))); 16098 end if; 16099 16100 exit Inner; 16101 end if; 16102 16103 Next (Citem); 16104 end loop Inner; 16105 16106 if Citem = N then 16107 Error_Pragma_Arg 16108 ("argument of pragma% is not withed unit", Arg); 16109 end if; 16110 16111 Next (Arg); 16112 end loop Outer; 16113 end Elaborate; 16114 16115 ------------------- 16116 -- Elaborate_All -- 16117 ------------------- 16118 16119 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); 16120 16121 when Pragma_Elaborate_All => Elaborate_All : declare 16122 Arg : Node_Id; 16123 Citem : Node_Id; 16124 16125 begin 16126 Check_Ada_83_Warning; 16127 16128 -- Pragma must be in context items list of a compilation unit 16129 16130 if not Is_In_Context_Clause then 16131 Pragma_Misplaced; 16132 end if; 16133 16134 -- Must be at least one argument 16135 16136 if Arg_Count = 0 then 16137 Error_Pragma ("pragma% requires at least one argument"); 16138 end if; 16139 16140 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not 16141 -- have to appear at the end of the context clause, but may 16142 -- appear mixed in with other items, even in Ada 83 mode. 16143 16144 -- Final check: the arguments must all be units mentioned in 16145 -- a with clause in the same context clause. Note that we 16146 -- already checked (in Par.Prag) that all the arguments are 16147 -- either identifiers or selected components. 16148 16149 Arg := Arg1; 16150 Outr : while Present (Arg) loop 16151 Citem := First (List_Containing (N)); 16152 Innr : while Citem /= N loop 16153 if Nkind (Citem) = N_With_Clause 16154 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 16155 then 16156 Set_Elaborate_All_Present (Citem, True); 16157 Set_Elab_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 16158 16159 -- Suppress warnings and elaboration checks on the named 16160 -- unit if the pragma is in the current compilation, as 16161 -- for pragma Elaborate. 16162 16163 if Legacy_Elaboration_Checks 16164 and then In_Extended_Main_Source_Unit (N) 16165 then 16166 Set_Suppress_Elaboration_Warnings 16167 (Entity (Name (Citem))); 16168 end if; 16169 16170 exit Innr; 16171 end if; 16172 16173 Next (Citem); 16174 end loop Innr; 16175 16176 if Citem = N then 16177 Set_Error_Posted (N); 16178 Error_Pragma_Arg 16179 ("argument of pragma% is not withed unit", Arg); 16180 end if; 16181 16182 Next (Arg); 16183 end loop Outr; 16184 end Elaborate_All; 16185 16186 -------------------- 16187 -- Elaborate_Body -- 16188 -------------------- 16189 16190 -- pragma Elaborate_Body [( library_unit_NAME )]; 16191 16192 when Pragma_Elaborate_Body => Elaborate_Body : declare 16193 Cunit_Node : Node_Id; 16194 Cunit_Ent : Entity_Id; 16195 16196 begin 16197 Check_Ada_83_Warning; 16198 Check_Valid_Library_Unit_Pragma; 16199 16200 if Nkind (N) = N_Null_Statement then 16201 return; 16202 end if; 16203 16204 Cunit_Node := Cunit (Current_Sem_Unit); 16205 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 16206 16207 -- A pragma that applies to a Ghost entity becomes Ghost for the 16208 -- purposes of legality checks and removal of ignored Ghost code. 16209 16210 Mark_Ghost_Pragma (N, Cunit_Ent); 16211 16212 if Nkind_In (Unit (Cunit_Node), N_Package_Body, 16213 N_Subprogram_Body) 16214 then 16215 Error_Pragma ("pragma% must refer to a spec, not a body"); 16216 else 16217 Set_Body_Required (Cunit_Node); 16218 Set_Has_Pragma_Elaborate_Body (Cunit_Ent); 16219 16220 -- If we are in dynamic elaboration mode, then we suppress 16221 -- elaboration warnings for the unit, since it is definitely 16222 -- fine NOT to do dynamic checks at the first level (and such 16223 -- checks will be suppressed because no elaboration boolean 16224 -- is created for Elaborate_Body packages). 16225 -- 16226 -- But in the static model of elaboration, Elaborate_Body is 16227 -- definitely NOT good enough to ensure elaboration safety on 16228 -- its own, since the body may WITH other units that are not 16229 -- safe from an elaboration point of view, so a client must 16230 -- still do an Elaborate_All on such units. 16231 -- 16232 -- Debug flag -gnatdD restores the old behavior of 3.13, where 16233 -- Elaborate_Body always suppressed elab warnings. 16234 16235 if Legacy_Elaboration_Checks 16236 and then (Dynamic_Elaboration_Checks or Debug_Flag_DD) 16237 then 16238 Set_Suppress_Elaboration_Warnings (Cunit_Ent); 16239 end if; 16240 end if; 16241 end Elaborate_Body; 16242 16243 ------------------------ 16244 -- Elaboration_Checks -- 16245 ------------------------ 16246 16247 -- pragma Elaboration_Checks (Static | Dynamic); 16248 16249 when Pragma_Elaboration_Checks => Elaboration_Checks : declare 16250 procedure Check_Duplicate_Elaboration_Checks_Pragma; 16251 -- Emit an error if the current context list already contains 16252 -- a previous Elaboration_Checks pragma. This routine raises 16253 -- Pragma_Exit if a duplicate is found. 16254 16255 procedure Ignore_Elaboration_Checks_Pragma; 16256 -- Warn that the effects of the pragma are ignored. This routine 16257 -- raises Pragma_Exit. 16258 16259 ----------------------------------------------- 16260 -- Check_Duplicate_Elaboration_Checks_Pragma -- 16261 ----------------------------------------------- 16262 16263 procedure Check_Duplicate_Elaboration_Checks_Pragma is 16264 Item : Node_Id; 16265 16266 begin 16267 Item := Prev (N); 16268 while Present (Item) loop 16269 if Nkind (Item) = N_Pragma 16270 and then Pragma_Name (Item) = Name_Elaboration_Checks 16271 then 16272 Duplication_Error 16273 (Prag => N, 16274 Prev => Item); 16275 raise Pragma_Exit; 16276 end if; 16277 16278 Prev (Item); 16279 end loop; 16280 end Check_Duplicate_Elaboration_Checks_Pragma; 16281 16282 -------------------------------------- 16283 -- Ignore_Elaboration_Checks_Pragma -- 16284 -------------------------------------- 16285 16286 procedure Ignore_Elaboration_Checks_Pragma is 16287 begin 16288 Error_Msg_Name_1 := Pname; 16289 Error_Msg_N ("??effects of pragma % are ignored", N); 16290 Error_Msg_N 16291 ("\place pragma on initial declaration of library unit", N); 16292 16293 raise Pragma_Exit; 16294 end Ignore_Elaboration_Checks_Pragma; 16295 16296 -- Local variables 16297 16298 Context : constant Node_Id := Parent (N); 16299 Unt : Node_Id; 16300 16301 -- Start of processing for Elaboration_Checks 16302 16303 begin 16304 GNAT_Pragma; 16305 Check_Arg_Count (1); 16306 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); 16307 16308 -- The pragma appears in a configuration file 16309 16310 if No (Context) then 16311 Check_Valid_Configuration_Pragma; 16312 Check_Duplicate_Elaboration_Checks_Pragma; 16313 16314 -- The pragma acts as a configuration pragma in a compilation unit 16315 16316 -- pragma Elaboration_Checks (...); 16317 -- package Pack is ...; 16318 16319 elsif Nkind (Context) = N_Compilation_Unit 16320 and then List_Containing (N) = Context_Items (Context) 16321 then 16322 Check_Valid_Configuration_Pragma; 16323 Check_Duplicate_Elaboration_Checks_Pragma; 16324 16325 Unt := Unit (Context); 16326 16327 -- The pragma must appear on the initial declaration of a unit. 16328 -- If this is not the case, warn that the effects of the pragma 16329 -- are ignored. 16330 16331 if Nkind (Unt) = N_Package_Body then 16332 Ignore_Elaboration_Checks_Pragma; 16333 16334 -- Check the Acts_As_Spec flag of the compilation units itself 16335 -- to determine whether the subprogram body completes since it 16336 -- has not been analyzed yet. This is safe because compilation 16337 -- units are not overloadable. 16338 16339 elsif Nkind (Unt) = N_Subprogram_Body 16340 and then not Acts_As_Spec (Context) 16341 then 16342 Ignore_Elaboration_Checks_Pragma; 16343 16344 elsif Nkind (Unt) = N_Subunit then 16345 Ignore_Elaboration_Checks_Pragma; 16346 end if; 16347 16348 -- Otherwise the pragma does not appear at the configuration level 16349 -- and is illegal. 16350 16351 else 16352 Pragma_Misplaced; 16353 end if; 16354 16355 -- At this point the pragma is not a duplicate, and appears in the 16356 -- proper context. Set the elaboration model in effect. 16357 16358 Dynamic_Elaboration_Checks := 16359 Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic; 16360 end Elaboration_Checks; 16361 16362 --------------- 16363 -- Eliminate -- 16364 --------------- 16365 16366 -- pragma Eliminate ( 16367 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, 16368 -- [Entity =>] IDENTIFIER | 16369 -- SELECTED_COMPONENT | 16370 -- STRING_LITERAL] 16371 -- [, Source_Location => SOURCE_TRACE]); 16372 16373 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE 16374 -- SOURCE_TRACE ::= STRING_LITERAL 16375 16376 when Pragma_Eliminate => Eliminate : declare 16377 Args : Args_List (1 .. 5); 16378 Names : constant Name_List (1 .. 5) := ( 16379 Name_Unit_Name, 16380 Name_Entity, 16381 Name_Parameter_Types, 16382 Name_Result_Type, 16383 Name_Source_Location); 16384 16385 -- Note : Parameter_Types and Result_Type are leftovers from 16386 -- prior implementations of the pragma. They are not generated 16387 -- by the gnatelim tool, and play no role in selecting which 16388 -- of a set of overloaded names is chosen for elimination. 16389 16390 Unit_Name : Node_Id renames Args (1); 16391 Entity : Node_Id renames Args (2); 16392 Parameter_Types : Node_Id renames Args (3); 16393 Result_Type : Node_Id renames Args (4); 16394 Source_Location : Node_Id renames Args (5); 16395 16396 begin 16397 GNAT_Pragma; 16398 Check_Valid_Configuration_Pragma; 16399 Gather_Associations (Names, Args); 16400 16401 if No (Unit_Name) then 16402 Error_Pragma ("missing Unit_Name argument for pragma%"); 16403 end if; 16404 16405 if No (Entity) 16406 and then (Present (Parameter_Types) 16407 or else 16408 Present (Result_Type) 16409 or else 16410 Present (Source_Location)) 16411 then 16412 Error_Pragma ("missing Entity argument for pragma%"); 16413 end if; 16414 16415 if (Present (Parameter_Types) 16416 or else 16417 Present (Result_Type)) 16418 and then 16419 Present (Source_Location) 16420 then 16421 Error_Pragma 16422 ("parameter profile and source location cannot be used " 16423 & "together in pragma%"); 16424 end if; 16425 16426 Process_Eliminate_Pragma 16427 (N, 16428 Unit_Name, 16429 Entity, 16430 Parameter_Types, 16431 Result_Type, 16432 Source_Location); 16433 end Eliminate; 16434 16435 ----------------------------------- 16436 -- Enable_Atomic_Synchronization -- 16437 ----------------------------------- 16438 16439 -- pragma Enable_Atomic_Synchronization [(Entity)]; 16440 16441 when Pragma_Enable_Atomic_Synchronization => 16442 GNAT_Pragma; 16443 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress); 16444 16445 ------------ 16446 -- Export -- 16447 ------------ 16448 16449 -- pragma Export ( 16450 -- [ Convention =>] convention_IDENTIFIER, 16451 -- [ Entity =>] LOCAL_NAME 16452 -- [, [External_Name =>] static_string_EXPRESSION ] 16453 -- [, [Link_Name =>] static_string_EXPRESSION ]); 16454 16455 when Pragma_Export => Export : declare 16456 C : Convention_Id; 16457 Def_Id : Entity_Id; 16458 16459 pragma Warnings (Off, C); 16460 16461 begin 16462 Check_Ada_83_Warning; 16463 Check_Arg_Order 16464 ((Name_Convention, 16465 Name_Entity, 16466 Name_External_Name, 16467 Name_Link_Name)); 16468 16469 Check_At_Least_N_Arguments (2); 16470 Check_At_Most_N_Arguments (4); 16471 16472 -- In Relaxed_RM_Semantics, support old Ada 83 style: 16473 -- pragma Export (Entity, "external name"); 16474 16475 if Relaxed_RM_Semantics 16476 and then Arg_Count = 2 16477 and then Nkind (Expression (Arg2)) = N_String_Literal 16478 then 16479 C := Convention_C; 16480 Def_Id := Get_Pragma_Arg (Arg1); 16481 Analyze (Def_Id); 16482 16483 if not Is_Entity_Name (Def_Id) then 16484 Error_Pragma_Arg ("entity name required", Arg1); 16485 end if; 16486 16487 Def_Id := Entity (Def_Id); 16488 Set_Exported (Def_Id, Arg1); 16489 16490 else 16491 Process_Convention (C, Def_Id); 16492 16493 -- A pragma that applies to a Ghost entity becomes Ghost for 16494 -- the purposes of legality checks and removal of ignored Ghost 16495 -- code. 16496 16497 Mark_Ghost_Pragma (N, Def_Id); 16498 16499 if Ekind (Def_Id) /= E_Constant then 16500 Note_Possible_Modification 16501 (Get_Pragma_Arg (Arg2), Sure => False); 16502 end if; 16503 16504 Process_Interface_Name (Def_Id, Arg3, Arg4, N); 16505 Set_Exported (Def_Id, Arg2); 16506 end if; 16507 16508 -- If the entity is a deferred constant, propagate the information 16509 -- to the full view, because gigi elaborates the full view only. 16510 16511 if Ekind (Def_Id) = E_Constant 16512 and then Present (Full_View (Def_Id)) 16513 then 16514 declare 16515 Id2 : constant Entity_Id := Full_View (Def_Id); 16516 begin 16517 Set_Is_Exported (Id2, Is_Exported (Def_Id)); 16518 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); 16519 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); 16520 end; 16521 end if; 16522 end Export; 16523 16524 --------------------- 16525 -- Export_Function -- 16526 --------------------- 16527 16528 -- pragma Export_Function ( 16529 -- [Internal =>] LOCAL_NAME 16530 -- [, [External =>] EXTERNAL_SYMBOL] 16531 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 16532 -- [, [Result_Type =>] TYPE_DESIGNATOR] 16533 -- [, [Mechanism =>] MECHANISM] 16534 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 16535 16536 -- EXTERNAL_SYMBOL ::= 16537 -- IDENTIFIER 16538 -- | static_string_EXPRESSION 16539 16540 -- PARAMETER_TYPES ::= 16541 -- null 16542 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16543 16544 -- TYPE_DESIGNATOR ::= 16545 -- subtype_NAME 16546 -- | subtype_Name ' Access 16547 16548 -- MECHANISM ::= 16549 -- MECHANISM_NAME 16550 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16551 16552 -- MECHANISM_ASSOCIATION ::= 16553 -- [formal_parameter_NAME =>] MECHANISM_NAME 16554 16555 -- MECHANISM_NAME ::= 16556 -- Value 16557 -- | Reference 16558 16559 when Pragma_Export_Function => Export_Function : declare 16560 Args : Args_List (1 .. 6); 16561 Names : constant Name_List (1 .. 6) := ( 16562 Name_Internal, 16563 Name_External, 16564 Name_Parameter_Types, 16565 Name_Result_Type, 16566 Name_Mechanism, 16567 Name_Result_Mechanism); 16568 16569 Internal : Node_Id renames Args (1); 16570 External : Node_Id renames Args (2); 16571 Parameter_Types : Node_Id renames Args (3); 16572 Result_Type : Node_Id renames Args (4); 16573 Mechanism : Node_Id renames Args (5); 16574 Result_Mechanism : Node_Id renames Args (6); 16575 16576 begin 16577 GNAT_Pragma; 16578 Gather_Associations (Names, Args); 16579 Process_Extended_Import_Export_Subprogram_Pragma ( 16580 Arg_Internal => Internal, 16581 Arg_External => External, 16582 Arg_Parameter_Types => Parameter_Types, 16583 Arg_Result_Type => Result_Type, 16584 Arg_Mechanism => Mechanism, 16585 Arg_Result_Mechanism => Result_Mechanism); 16586 end Export_Function; 16587 16588 ------------------- 16589 -- Export_Object -- 16590 ------------------- 16591 16592 -- pragma Export_Object ( 16593 -- [Internal =>] LOCAL_NAME 16594 -- [, [External =>] EXTERNAL_SYMBOL] 16595 -- [, [Size =>] EXTERNAL_SYMBOL]); 16596 16597 -- EXTERNAL_SYMBOL ::= 16598 -- IDENTIFIER 16599 -- | static_string_EXPRESSION 16600 16601 -- PARAMETER_TYPES ::= 16602 -- null 16603 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16604 16605 -- TYPE_DESIGNATOR ::= 16606 -- subtype_NAME 16607 -- | subtype_Name ' Access 16608 16609 -- MECHANISM ::= 16610 -- MECHANISM_NAME 16611 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16612 16613 -- MECHANISM_ASSOCIATION ::= 16614 -- [formal_parameter_NAME =>] MECHANISM_NAME 16615 16616 -- MECHANISM_NAME ::= 16617 -- Value 16618 -- | Reference 16619 16620 when Pragma_Export_Object => Export_Object : declare 16621 Args : Args_List (1 .. 3); 16622 Names : constant Name_List (1 .. 3) := ( 16623 Name_Internal, 16624 Name_External, 16625 Name_Size); 16626 16627 Internal : Node_Id renames Args (1); 16628 External : Node_Id renames Args (2); 16629 Size : Node_Id renames Args (3); 16630 16631 begin 16632 GNAT_Pragma; 16633 Gather_Associations (Names, Args); 16634 Process_Extended_Import_Export_Object_Pragma ( 16635 Arg_Internal => Internal, 16636 Arg_External => External, 16637 Arg_Size => Size); 16638 end Export_Object; 16639 16640 ---------------------- 16641 -- Export_Procedure -- 16642 ---------------------- 16643 16644 -- pragma Export_Procedure ( 16645 -- [Internal =>] LOCAL_NAME 16646 -- [, [External =>] EXTERNAL_SYMBOL] 16647 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 16648 -- [, [Mechanism =>] MECHANISM]); 16649 16650 -- EXTERNAL_SYMBOL ::= 16651 -- IDENTIFIER 16652 -- | static_string_EXPRESSION 16653 16654 -- PARAMETER_TYPES ::= 16655 -- null 16656 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16657 16658 -- TYPE_DESIGNATOR ::= 16659 -- subtype_NAME 16660 -- | subtype_Name ' Access 16661 16662 -- MECHANISM ::= 16663 -- MECHANISM_NAME 16664 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16665 16666 -- MECHANISM_ASSOCIATION ::= 16667 -- [formal_parameter_NAME =>] MECHANISM_NAME 16668 16669 -- MECHANISM_NAME ::= 16670 -- Value 16671 -- | Reference 16672 16673 when Pragma_Export_Procedure => Export_Procedure : declare 16674 Args : Args_List (1 .. 4); 16675 Names : constant Name_List (1 .. 4) := ( 16676 Name_Internal, 16677 Name_External, 16678 Name_Parameter_Types, 16679 Name_Mechanism); 16680 16681 Internal : Node_Id renames Args (1); 16682 External : Node_Id renames Args (2); 16683 Parameter_Types : Node_Id renames Args (3); 16684 Mechanism : Node_Id renames Args (4); 16685 16686 begin 16687 GNAT_Pragma; 16688 Gather_Associations (Names, Args); 16689 Process_Extended_Import_Export_Subprogram_Pragma ( 16690 Arg_Internal => Internal, 16691 Arg_External => External, 16692 Arg_Parameter_Types => Parameter_Types, 16693 Arg_Mechanism => Mechanism); 16694 end Export_Procedure; 16695 16696 ------------------ 16697 -- Export_Value -- 16698 ------------------ 16699 16700 -- pragma Export_Value ( 16701 -- [Value =>] static_integer_EXPRESSION, 16702 -- [Link_Name =>] static_string_EXPRESSION); 16703 16704 when Pragma_Export_Value => 16705 GNAT_Pragma; 16706 Check_Arg_Order ((Name_Value, Name_Link_Name)); 16707 Check_Arg_Count (2); 16708 16709 Check_Optional_Identifier (Arg1, Name_Value); 16710 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); 16711 16712 Check_Optional_Identifier (Arg2, Name_Link_Name); 16713 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 16714 16715 ----------------------------- 16716 -- Export_Valued_Procedure -- 16717 ----------------------------- 16718 16719 -- pragma Export_Valued_Procedure ( 16720 -- [Internal =>] LOCAL_NAME 16721 -- [, [External =>] EXTERNAL_SYMBOL,] 16722 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 16723 -- [, [Mechanism =>] MECHANISM]); 16724 16725 -- EXTERNAL_SYMBOL ::= 16726 -- IDENTIFIER 16727 -- | static_string_EXPRESSION 16728 16729 -- PARAMETER_TYPES ::= 16730 -- null 16731 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 16732 16733 -- TYPE_DESIGNATOR ::= 16734 -- subtype_NAME 16735 -- | subtype_Name ' Access 16736 16737 -- MECHANISM ::= 16738 -- MECHANISM_NAME 16739 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 16740 16741 -- MECHANISM_ASSOCIATION ::= 16742 -- [formal_parameter_NAME =>] MECHANISM_NAME 16743 16744 -- MECHANISM_NAME ::= 16745 -- Value 16746 -- | Reference 16747 16748 when Pragma_Export_Valued_Procedure => 16749 Export_Valued_Procedure : declare 16750 Args : Args_List (1 .. 4); 16751 Names : constant Name_List (1 .. 4) := ( 16752 Name_Internal, 16753 Name_External, 16754 Name_Parameter_Types, 16755 Name_Mechanism); 16756 16757 Internal : Node_Id renames Args (1); 16758 External : Node_Id renames Args (2); 16759 Parameter_Types : Node_Id renames Args (3); 16760 Mechanism : Node_Id renames Args (4); 16761 16762 begin 16763 GNAT_Pragma; 16764 Gather_Associations (Names, Args); 16765 Process_Extended_Import_Export_Subprogram_Pragma ( 16766 Arg_Internal => Internal, 16767 Arg_External => External, 16768 Arg_Parameter_Types => Parameter_Types, 16769 Arg_Mechanism => Mechanism); 16770 end Export_Valued_Procedure; 16771 16772 ------------------- 16773 -- Extend_System -- 16774 ------------------- 16775 16776 -- pragma Extend_System ([Name =>] Identifier); 16777 16778 when Pragma_Extend_System => 16779 GNAT_Pragma; 16780 Check_Valid_Configuration_Pragma; 16781 Check_Arg_Count (1); 16782 Check_Optional_Identifier (Arg1, Name_Name); 16783 Check_Arg_Is_Identifier (Arg1); 16784 16785 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 16786 16787 if Name_Len > 4 16788 and then Name_Buffer (1 .. 4) = "aux_" 16789 then 16790 if Present (System_Extend_Pragma_Arg) then 16791 if Chars (Get_Pragma_Arg (Arg1)) = 16792 Chars (Expression (System_Extend_Pragma_Arg)) 16793 then 16794 null; 16795 else 16796 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg); 16797 Error_Pragma ("pragma% conflicts with that #"); 16798 end if; 16799 16800 else 16801 System_Extend_Pragma_Arg := Arg1; 16802 16803 if not GNAT_Mode then 16804 System_Extend_Unit := Arg1; 16805 end if; 16806 end if; 16807 else 16808 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); 16809 end if; 16810 16811 ------------------------ 16812 -- Extensions_Allowed -- 16813 ------------------------ 16814 16815 -- pragma Extensions_Allowed (ON | OFF); 16816 16817 when Pragma_Extensions_Allowed => 16818 GNAT_Pragma; 16819 Check_Arg_Count (1); 16820 Check_No_Identifiers; 16821 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 16822 16823 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 16824 Extensions_Allowed := True; 16825 Ada_Version := Ada_Version_Type'Last; 16826 16827 else 16828 Extensions_Allowed := False; 16829 Ada_Version := Ada_Version_Explicit; 16830 Ada_Version_Pragma := Empty; 16831 end if; 16832 16833 ------------------------ 16834 -- Extensions_Visible -- 16835 ------------------------ 16836 16837 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ]; 16838 16839 -- Characteristics: 16840 16841 -- * Analysis - The annotation is fully analyzed immediately upon 16842 -- elaboration as its expression must be static. 16843 16844 -- * Expansion - None. 16845 16846 -- * Template - The annotation utilizes the generic template of the 16847 -- related subprogram [body] when it is: 16848 16849 -- aspect on subprogram declaration 16850 -- aspect on stand-alone subprogram body 16851 -- pragma on stand-alone subprogram body 16852 16853 -- The annotation must prepare its own template when it is: 16854 16855 -- pragma on subprogram declaration 16856 16857 -- * Globals - Capture of global references must occur after full 16858 -- analysis. 16859 16860 -- * Instance - The annotation is instantiated automatically when 16861 -- the related generic subprogram [body] is instantiated except for 16862 -- the "pragma on subprogram declaration" case. In that scenario 16863 -- the annotation must instantiate itself. 16864 16865 when Pragma_Extensions_Visible => Extensions_Visible : declare 16866 Formal : Entity_Id; 16867 Has_OK_Formal : Boolean := False; 16868 Spec_Id : Entity_Id; 16869 Subp_Decl : Node_Id; 16870 16871 begin 16872 GNAT_Pragma; 16873 Check_No_Identifiers; 16874 Check_At_Most_N_Arguments (1); 16875 16876 Subp_Decl := 16877 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 16878 16879 -- Abstract subprogram declaration 16880 16881 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 16882 null; 16883 16884 -- Generic subprogram declaration 16885 16886 elsif Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 16887 null; 16888 16889 -- Body acts as spec 16890 16891 elsif Nkind (Subp_Decl) = N_Subprogram_Body 16892 and then No (Corresponding_Spec (Subp_Decl)) 16893 then 16894 null; 16895 16896 -- Body stub acts as spec 16897 16898 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 16899 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 16900 then 16901 null; 16902 16903 -- Subprogram declaration 16904 16905 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 16906 null; 16907 16908 -- Otherwise the pragma is associated with an illegal construct 16909 16910 else 16911 Error_Pragma ("pragma % must apply to a subprogram"); 16912 return; 16913 end if; 16914 16915 -- Mark the pragma as Ghost if the related subprogram is also 16916 -- Ghost. This also ensures that any expansion performed further 16917 -- below will produce Ghost nodes. 16918 16919 Spec_Id := Unique_Defining_Entity (Subp_Decl); 16920 Mark_Ghost_Pragma (N, Spec_Id); 16921 16922 -- Chain the pragma on the contract for completeness 16923 16924 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 16925 16926 -- The legality checks of pragma Extension_Visible are affected 16927 -- by the SPARK mode in effect. Analyze all pragmas in specific 16928 -- order. 16929 16930 Analyze_If_Present (Pragma_SPARK_Mode); 16931 16932 -- Examine the formals of the related subprogram 16933 16934 Formal := First_Formal (Spec_Id); 16935 while Present (Formal) loop 16936 16937 -- At least one of the formals is of a specific tagged type, 16938 -- the pragma is legal. 16939 16940 if Is_Specific_Tagged_Type (Etype (Formal)) then 16941 Has_OK_Formal := True; 16942 exit; 16943 16944 -- A generic subprogram with at least one formal of a private 16945 -- type ensures the legality of the pragma because the actual 16946 -- may be specifically tagged. Note that this is verified by 16947 -- the check above at instantiation time. 16948 16949 elsif Is_Private_Type (Etype (Formal)) 16950 and then Is_Generic_Type (Etype (Formal)) 16951 then 16952 Has_OK_Formal := True; 16953 exit; 16954 end if; 16955 16956 Next_Formal (Formal); 16957 end loop; 16958 16959 if not Has_OK_Formal then 16960 Error_Msg_Name_1 := Pname; 16961 Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N); 16962 Error_Msg_NE 16963 ("\subprogram & lacks parameter of specific tagged or " 16964 & "generic private type", N, Spec_Id); 16965 16966 return; 16967 end if; 16968 16969 -- Analyze the Boolean expression (if any) 16970 16971 if Present (Arg1) then 16972 Check_Static_Boolean_Expression 16973 (Expression (Get_Argument (N, Spec_Id))); 16974 end if; 16975 end Extensions_Visible; 16976 16977 -------------- 16978 -- External -- 16979 -------------- 16980 16981 -- pragma External ( 16982 -- [ Convention =>] convention_IDENTIFIER, 16983 -- [ Entity =>] LOCAL_NAME 16984 -- [, [External_Name =>] static_string_EXPRESSION ] 16985 -- [, [Link_Name =>] static_string_EXPRESSION ]); 16986 16987 when Pragma_External => External : declare 16988 C : Convention_Id; 16989 E : Entity_Id; 16990 pragma Warnings (Off, C); 16991 16992 begin 16993 GNAT_Pragma; 16994 Check_Arg_Order 16995 ((Name_Convention, 16996 Name_Entity, 16997 Name_External_Name, 16998 Name_Link_Name)); 16999 Check_At_Least_N_Arguments (2); 17000 Check_At_Most_N_Arguments (4); 17001 Process_Convention (C, E); 17002 17003 -- A pragma that applies to a Ghost entity becomes Ghost for the 17004 -- purposes of legality checks and removal of ignored Ghost code. 17005 17006 Mark_Ghost_Pragma (N, E); 17007 17008 Note_Possible_Modification 17009 (Get_Pragma_Arg (Arg2), Sure => False); 17010 Process_Interface_Name (E, Arg3, Arg4, N); 17011 Set_Exported (E, Arg2); 17012 end External; 17013 17014 -------------------------- 17015 -- External_Name_Casing -- 17016 -------------------------- 17017 17018 -- pragma External_Name_Casing ( 17019 -- UPPERCASE | LOWERCASE 17020 -- [, AS_IS | UPPERCASE | LOWERCASE]); 17021 17022 when Pragma_External_Name_Casing => 17023 GNAT_Pragma; 17024 Check_No_Identifiers; 17025 17026 if Arg_Count = 2 then 17027 Check_Arg_Is_One_Of 17028 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase); 17029 17030 case Chars (Get_Pragma_Arg (Arg2)) is 17031 when Name_As_Is => 17032 Opt.External_Name_Exp_Casing := As_Is; 17033 17034 when Name_Uppercase => 17035 Opt.External_Name_Exp_Casing := Uppercase; 17036 17037 when Name_Lowercase => 17038 Opt.External_Name_Exp_Casing := Lowercase; 17039 17040 when others => 17041 null; 17042 end case; 17043 17044 else 17045 Check_Arg_Count (1); 17046 end if; 17047 17048 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase); 17049 17050 case Chars (Get_Pragma_Arg (Arg1)) is 17051 when Name_Uppercase => 17052 Opt.External_Name_Imp_Casing := Uppercase; 17053 17054 when Name_Lowercase => 17055 Opt.External_Name_Imp_Casing := Lowercase; 17056 17057 when others => 17058 null; 17059 end case; 17060 17061 --------------- 17062 -- Fast_Math -- 17063 --------------- 17064 17065 -- pragma Fast_Math; 17066 17067 when Pragma_Fast_Math => 17068 GNAT_Pragma; 17069 Check_No_Identifiers; 17070 Check_Valid_Configuration_Pragma; 17071 Fast_Math := True; 17072 17073 -------------------------- 17074 -- Favor_Top_Level -- 17075 -------------------------- 17076 17077 -- pragma Favor_Top_Level (type_NAME); 17078 17079 when Pragma_Favor_Top_Level => Favor_Top_Level : declare 17080 Typ : Entity_Id; 17081 17082 begin 17083 GNAT_Pragma; 17084 Check_No_Identifiers; 17085 Check_Arg_Count (1); 17086 Check_Arg_Is_Local_Name (Arg1); 17087 Typ := Entity (Get_Pragma_Arg (Arg1)); 17088 17089 -- A pragma that applies to a Ghost entity becomes Ghost for the 17090 -- purposes of legality checks and removal of ignored Ghost code. 17091 17092 Mark_Ghost_Pragma (N, Typ); 17093 17094 -- If it's an access-to-subprogram type (in particular, not a 17095 -- subtype), set the flag on that type. 17096 17097 if Is_Access_Subprogram_Type (Typ) then 17098 Set_Can_Use_Internal_Rep (Typ, False); 17099 17100 -- Otherwise it's an error (name denotes the wrong sort of entity) 17101 17102 else 17103 Error_Pragma_Arg 17104 ("access-to-subprogram type expected", 17105 Get_Pragma_Arg (Arg1)); 17106 end if; 17107 end Favor_Top_Level; 17108 17109 --------------------------- 17110 -- Finalize_Storage_Only -- 17111 --------------------------- 17112 17113 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); 17114 17115 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare 17116 Assoc : constant Node_Id := Arg1; 17117 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 17118 Typ : Entity_Id; 17119 17120 begin 17121 GNAT_Pragma; 17122 Check_No_Identifiers; 17123 Check_Arg_Count (1); 17124 Check_Arg_Is_Local_Name (Arg1); 17125 17126 Find_Type (Type_Id); 17127 Typ := Entity (Type_Id); 17128 17129 if Typ = Any_Type 17130 or else Rep_Item_Too_Early (Typ, N) 17131 then 17132 return; 17133 else 17134 Typ := Underlying_Type (Typ); 17135 end if; 17136 17137 if not Is_Controlled (Typ) then 17138 Error_Pragma ("pragma% must specify controlled type"); 17139 end if; 17140 17141 Check_First_Subtype (Arg1); 17142 17143 if Finalize_Storage_Only (Typ) then 17144 Error_Pragma ("duplicate pragma%, only one allowed"); 17145 17146 elsif not Rep_Item_Too_Late (Typ, N) then 17147 Set_Finalize_Storage_Only (Base_Type (Typ), True); 17148 end if; 17149 end Finalize_Storage; 17150 17151 ----------- 17152 -- Ghost -- 17153 ----------- 17154 17155 -- pragma Ghost [ (boolean_EXPRESSION) ]; 17156 17157 when Pragma_Ghost => Ghost : declare 17158 Context : Node_Id; 17159 Expr : Node_Id; 17160 Id : Entity_Id; 17161 Orig_Stmt : Node_Id; 17162 Prev_Id : Entity_Id; 17163 Stmt : Node_Id; 17164 17165 begin 17166 GNAT_Pragma; 17167 Check_No_Identifiers; 17168 Check_At_Most_N_Arguments (1); 17169 17170 Id := Empty; 17171 Stmt := Prev (N); 17172 while Present (Stmt) loop 17173 17174 -- Skip prior pragmas, but check for duplicates 17175 17176 if Nkind (Stmt) = N_Pragma then 17177 if Pragma_Name (Stmt) = Pname then 17178 Duplication_Error 17179 (Prag => N, 17180 Prev => Stmt); 17181 raise Pragma_Exit; 17182 end if; 17183 17184 -- Task unit declared without a definition cannot be subject to 17185 -- pragma Ghost (SPARK RM 6.9(19)). 17186 17187 elsif Nkind_In (Stmt, N_Single_Task_Declaration, 17188 N_Task_Type_Declaration) 17189 then 17190 Error_Pragma ("pragma % cannot apply to a task type"); 17191 return; 17192 17193 -- Skip internally generated code 17194 17195 elsif not Comes_From_Source (Stmt) then 17196 Orig_Stmt := Original_Node (Stmt); 17197 17198 -- When pragma Ghost applies to an untagged derivation, the 17199 -- derivation is transformed into a [sub]type declaration. 17200 17201 if Nkind_In (Stmt, N_Full_Type_Declaration, 17202 N_Subtype_Declaration) 17203 and then Comes_From_Source (Orig_Stmt) 17204 and then Nkind (Orig_Stmt) = N_Full_Type_Declaration 17205 and then Nkind (Type_Definition (Orig_Stmt)) = 17206 N_Derived_Type_Definition 17207 then 17208 Id := Defining_Entity (Stmt); 17209 exit; 17210 17211 -- When pragma Ghost applies to an object declaration which 17212 -- is initialized by means of a function call that returns 17213 -- on the secondary stack, the object declaration becomes a 17214 -- renaming. 17215 17216 elsif Nkind (Stmt) = N_Object_Renaming_Declaration 17217 and then Comes_From_Source (Orig_Stmt) 17218 and then Nkind (Orig_Stmt) = N_Object_Declaration 17219 then 17220 Id := Defining_Entity (Stmt); 17221 exit; 17222 17223 -- When pragma Ghost applies to an expression function, the 17224 -- expression function is transformed into a subprogram. 17225 17226 elsif Nkind (Stmt) = N_Subprogram_Declaration 17227 and then Comes_From_Source (Orig_Stmt) 17228 and then Nkind (Orig_Stmt) = N_Expression_Function 17229 then 17230 Id := Defining_Entity (Stmt); 17231 exit; 17232 end if; 17233 17234 -- The pragma applies to a legal construct, stop the traversal 17235 17236 elsif Nkind_In (Stmt, N_Abstract_Subprogram_Declaration, 17237 N_Full_Type_Declaration, 17238 N_Generic_Subprogram_Declaration, 17239 N_Object_Declaration, 17240 N_Private_Extension_Declaration, 17241 N_Private_Type_Declaration, 17242 N_Subprogram_Declaration, 17243 N_Subtype_Declaration) 17244 then 17245 Id := Defining_Entity (Stmt); 17246 exit; 17247 17248 -- The pragma does not apply to a legal construct, issue an 17249 -- error and stop the analysis. 17250 17251 else 17252 Error_Pragma 17253 ("pragma % must apply to an object, package, subprogram " 17254 & "or type"); 17255 return; 17256 end if; 17257 17258 Stmt := Prev (Stmt); 17259 end loop; 17260 17261 Context := Parent (N); 17262 17263 -- Handle compilation units 17264 17265 if Nkind (Context) = N_Compilation_Unit_Aux then 17266 Context := Unit (Parent (Context)); 17267 end if; 17268 17269 -- Protected and task types cannot be subject to pragma Ghost 17270 -- (SPARK RM 6.9(19)). 17271 17272 if Nkind_In (Context, N_Protected_Body, N_Protected_Definition) 17273 then 17274 Error_Pragma ("pragma % cannot apply to a protected type"); 17275 return; 17276 17277 elsif Nkind_In (Context, N_Task_Body, N_Task_Definition) then 17278 Error_Pragma ("pragma % cannot apply to a task type"); 17279 return; 17280 end if; 17281 17282 if No (Id) then 17283 17284 -- When pragma Ghost is associated with a [generic] package, it 17285 -- appears in the visible declarations. 17286 17287 if Nkind (Context) = N_Package_Specification 17288 and then Present (Visible_Declarations (Context)) 17289 and then List_Containing (N) = Visible_Declarations (Context) 17290 then 17291 Id := Defining_Entity (Context); 17292 17293 -- Pragma Ghost applies to a stand-alone subprogram body 17294 17295 elsif Nkind (Context) = N_Subprogram_Body 17296 and then No (Corresponding_Spec (Context)) 17297 then 17298 Id := Defining_Entity (Context); 17299 17300 -- Pragma Ghost applies to a subprogram declaration that acts 17301 -- as a compilation unit. 17302 17303 elsif Nkind (Context) = N_Subprogram_Declaration then 17304 Id := Defining_Entity (Context); 17305 17306 -- Pragma Ghost applies to a generic subprogram 17307 17308 elsif Nkind (Context) = N_Generic_Subprogram_Declaration then 17309 Id := Defining_Entity (Specification (Context)); 17310 end if; 17311 end if; 17312 17313 if No (Id) then 17314 Error_Pragma 17315 ("pragma % must apply to an object, package, subprogram or " 17316 & "type"); 17317 return; 17318 end if; 17319 17320 -- Handle completions of types and constants that are subject to 17321 -- pragma Ghost. 17322 17323 if Is_Record_Type (Id) or else Ekind (Id) = E_Constant then 17324 Prev_Id := Incomplete_Or_Partial_View (Id); 17325 17326 if Present (Prev_Id) and then not Is_Ghost_Entity (Prev_Id) then 17327 Error_Msg_Name_1 := Pname; 17328 17329 -- The full declaration of a deferred constant cannot be 17330 -- subject to pragma Ghost unless the deferred declaration 17331 -- is also Ghost (SPARK RM 6.9(9)). 17332 17333 if Ekind (Prev_Id) = E_Constant then 17334 Error_Msg_Name_1 := Pname; 17335 Error_Msg_NE (Fix_Error 17336 ("pragma % must apply to declaration of deferred " 17337 & "constant &"), N, Id); 17338 return; 17339 17340 -- Pragma Ghost may appear on the full view of an incomplete 17341 -- type because the incomplete declaration lacks aspects and 17342 -- cannot be subject to pragma Ghost. 17343 17344 elsif Ekind (Prev_Id) = E_Incomplete_Type then 17345 null; 17346 17347 -- The full declaration of a type cannot be subject to 17348 -- pragma Ghost unless the partial view is also Ghost 17349 -- (SPARK RM 6.9(9)). 17350 17351 else 17352 Error_Msg_NE (Fix_Error 17353 ("pragma % must apply to partial view of type &"), 17354 N, Id); 17355 return; 17356 end if; 17357 end if; 17358 17359 -- A synchronized object cannot be subject to pragma Ghost 17360 -- (SPARK RM 6.9(19)). 17361 17362 elsif Ekind (Id) = E_Variable then 17363 if Is_Protected_Type (Etype (Id)) then 17364 Error_Pragma ("pragma % cannot apply to a protected object"); 17365 return; 17366 17367 elsif Is_Task_Type (Etype (Id)) then 17368 Error_Pragma ("pragma % cannot apply to a task object"); 17369 return; 17370 end if; 17371 end if; 17372 17373 -- Analyze the Boolean expression (if any) 17374 17375 if Present (Arg1) then 17376 Expr := Get_Pragma_Arg (Arg1); 17377 17378 Analyze_And_Resolve (Expr, Standard_Boolean); 17379 17380 if Is_OK_Static_Expression (Expr) then 17381 17382 -- "Ghostness" cannot be turned off once enabled within a 17383 -- region (SPARK RM 6.9(6)). 17384 17385 if Is_False (Expr_Value (Expr)) 17386 and then Ghost_Mode > None 17387 then 17388 Error_Pragma 17389 ("pragma % with value False cannot appear in enabled " 17390 & "ghost region"); 17391 return; 17392 end if; 17393 17394 -- Otherwie the expression is not static 17395 17396 else 17397 Error_Pragma_Arg 17398 ("expression of pragma % must be static", Expr); 17399 return; 17400 end if; 17401 end if; 17402 17403 Set_Is_Ghost_Entity (Id); 17404 end Ghost; 17405 17406 ------------ 17407 -- Global -- 17408 ------------ 17409 17410 -- pragma Global (GLOBAL_SPECIFICATION); 17411 17412 -- GLOBAL_SPECIFICATION ::= 17413 -- null 17414 -- | (GLOBAL_LIST) 17415 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}) 17416 17417 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 17418 17419 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 17420 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 17421 -- GLOBAL_ITEM ::= NAME 17422 17423 -- Characteristics: 17424 17425 -- * Analysis - The annotation undergoes initial checks to verify 17426 -- the legal placement and context. Secondary checks fully analyze 17427 -- the dependency clauses in: 17428 17429 -- Analyze_Global_In_Decl_Part 17430 17431 -- * Expansion - None. 17432 17433 -- * Template - The annotation utilizes the generic template of the 17434 -- related subprogram [body] when it is: 17435 17436 -- aspect on subprogram declaration 17437 -- aspect on stand-alone subprogram body 17438 -- pragma on stand-alone subprogram body 17439 17440 -- The annotation must prepare its own template when it is: 17441 17442 -- pragma on subprogram declaration 17443 17444 -- * Globals - Capture of global references must occur after full 17445 -- analysis. 17446 17447 -- * Instance - The annotation is instantiated automatically when 17448 -- the related generic subprogram [body] is instantiated except for 17449 -- the "pragma on subprogram declaration" case. In that scenario 17450 -- the annotation must instantiate itself. 17451 17452 when Pragma_Global => Global : declare 17453 Legal : Boolean; 17454 Spec_Id : Entity_Id; 17455 Subp_Decl : Node_Id; 17456 17457 begin 17458 Analyze_Depends_Global (Spec_Id, Subp_Decl, Legal); 17459 17460 if Legal then 17461 17462 -- Chain the pragma on the contract for further processing by 17463 -- Analyze_Global_In_Decl_Part. 17464 17465 Add_Contract_Item (N, Spec_Id); 17466 17467 -- Fully analyze the pragma when it appears inside an entry 17468 -- or subprogram body because it cannot benefit from forward 17469 -- references. 17470 17471 if Nkind_In (Subp_Decl, N_Entry_Body, 17472 N_Subprogram_Body, 17473 N_Subprogram_Body_Stub) 17474 then 17475 -- The legality checks of pragmas Depends and Global are 17476 -- affected by the SPARK mode in effect and the volatility 17477 -- of the context. In addition these two pragmas are subject 17478 -- to an inherent order: 17479 17480 -- 1) Global 17481 -- 2) Depends 17482 17483 -- Analyze all these pragmas in the order outlined above 17484 17485 Analyze_If_Present (Pragma_SPARK_Mode); 17486 Analyze_If_Present (Pragma_Volatile_Function); 17487 Analyze_Global_In_Decl_Part (N); 17488 Analyze_If_Present (Pragma_Depends); 17489 end if; 17490 end if; 17491 end Global; 17492 17493 ----------- 17494 -- Ident -- 17495 ----------- 17496 17497 -- pragma Ident (static_string_EXPRESSION) 17498 17499 -- Note: pragma Comment shares this processing. Pragma Ident is 17500 -- identical in effect to pragma Commment. 17501 17502 when Pragma_Comment 17503 | Pragma_Ident 17504 => 17505 Ident : declare 17506 Str : Node_Id; 17507 17508 begin 17509 GNAT_Pragma; 17510 Check_Arg_Count (1); 17511 Check_No_Identifiers; 17512 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 17513 Store_Note (N); 17514 17515 Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); 17516 17517 declare 17518 CS : Node_Id; 17519 GP : Node_Id; 17520 17521 begin 17522 GP := Parent (Parent (N)); 17523 17524 if Nkind_In (GP, N_Package_Declaration, 17525 N_Generic_Package_Declaration) 17526 then 17527 GP := Parent (GP); 17528 end if; 17529 17530 -- If we have a compilation unit, then record the ident value, 17531 -- checking for improper duplication. 17532 17533 if Nkind (GP) = N_Compilation_Unit then 17534 CS := Ident_String (Current_Sem_Unit); 17535 17536 if Present (CS) then 17537 17538 -- If we have multiple instances, concatenate them, but 17539 -- not in ASIS, where we want the original tree. 17540 17541 if not ASIS_Mode then 17542 Start_String (Strval (CS)); 17543 Store_String_Char (' '); 17544 Store_String_Chars (Strval (Str)); 17545 Set_Strval (CS, End_String); 17546 end if; 17547 17548 else 17549 Set_Ident_String (Current_Sem_Unit, Str); 17550 end if; 17551 17552 -- For subunits, we just ignore the Ident, since in GNAT these 17553 -- are not separate object files, and hence not separate units 17554 -- in the unit table. 17555 17556 elsif Nkind (GP) = N_Subunit then 17557 null; 17558 end if; 17559 end; 17560 end Ident; 17561 17562 ------------------- 17563 -- Ignore_Pragma -- 17564 ------------------- 17565 17566 -- pragma Ignore_Pragma (pragma_IDENTIFIER); 17567 17568 -- Entirely handled in the parser, nothing to do here 17569 17570 when Pragma_Ignore_Pragma => 17571 null; 17572 17573 ---------------------------- 17574 -- Implementation_Defined -- 17575 ---------------------------- 17576 17577 -- pragma Implementation_Defined (LOCAL_NAME); 17578 17579 -- Marks previously declared entity as implementation defined. For 17580 -- an overloaded entity, applies to the most recent homonym. 17581 17582 -- pragma Implementation_Defined; 17583 17584 -- The form with no arguments appears anywhere within a scope, most 17585 -- typically a package spec, and indicates that all entities that are 17586 -- defined within the package spec are Implementation_Defined. 17587 17588 when Pragma_Implementation_Defined => Implementation_Defined : declare 17589 Ent : Entity_Id; 17590 17591 begin 17592 GNAT_Pragma; 17593 Check_No_Identifiers; 17594 17595 -- Form with no arguments 17596 17597 if Arg_Count = 0 then 17598 Set_Is_Implementation_Defined (Current_Scope); 17599 17600 -- Form with one argument 17601 17602 else 17603 Check_Arg_Count (1); 17604 Check_Arg_Is_Local_Name (Arg1); 17605 Ent := Entity (Get_Pragma_Arg (Arg1)); 17606 Set_Is_Implementation_Defined (Ent); 17607 end if; 17608 end Implementation_Defined; 17609 17610 ----------------- 17611 -- Implemented -- 17612 ----------------- 17613 17614 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND); 17615 17616 -- IMPLEMENTATION_KIND ::= 17617 -- By_Entry | By_Protected_Procedure | By_Any | Optional 17618 17619 -- "By_Any" and "Optional" are treated as synonyms in order to 17620 -- support Ada 2012 aspect Synchronization. 17621 17622 when Pragma_Implemented => Implemented : declare 17623 Proc_Id : Entity_Id; 17624 Typ : Entity_Id; 17625 17626 begin 17627 Ada_2012_Pragma; 17628 Check_Arg_Count (2); 17629 Check_No_Identifiers; 17630 Check_Arg_Is_Identifier (Arg1); 17631 Check_Arg_Is_Local_Name (Arg1); 17632 Check_Arg_Is_One_Of (Arg2, 17633 Name_By_Any, 17634 Name_By_Entry, 17635 Name_By_Protected_Procedure, 17636 Name_Optional); 17637 17638 -- Extract the name of the local procedure 17639 17640 Proc_Id := Entity (Get_Pragma_Arg (Arg1)); 17641 17642 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a 17643 -- primitive procedure of a synchronized tagged type. 17644 17645 if Ekind (Proc_Id) = E_Procedure 17646 and then Is_Primitive (Proc_Id) 17647 and then Present (First_Formal (Proc_Id)) 17648 then 17649 Typ := Etype (First_Formal (Proc_Id)); 17650 17651 if Is_Tagged_Type (Typ) 17652 and then 17653 17654 -- Check for a protected, a synchronized or a task interface 17655 17656 ((Is_Interface (Typ) 17657 and then Is_Synchronized_Interface (Typ)) 17658 17659 -- Check for a protected type or a task type that implements 17660 -- an interface. 17661 17662 or else 17663 (Is_Concurrent_Record_Type (Typ) 17664 and then Present (Interfaces (Typ))) 17665 17666 -- In analysis-only mode, examine original protected type 17667 17668 or else 17669 (Nkind (Parent (Typ)) = N_Protected_Type_Declaration 17670 and then Present (Interface_List (Parent (Typ)))) 17671 17672 -- Check for a private record extension with keyword 17673 -- "synchronized". 17674 17675 or else 17676 (Ekind_In (Typ, E_Record_Type_With_Private, 17677 E_Record_Subtype_With_Private) 17678 and then Synchronized_Present (Parent (Typ)))) 17679 then 17680 null; 17681 else 17682 Error_Pragma_Arg 17683 ("controlling formal must be of synchronized tagged type", 17684 Arg1); 17685 return; 17686 end if; 17687 17688 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind 17689 -- By_Protected_Procedure to the primitive procedure of a task 17690 -- interface. 17691 17692 if Chars (Arg2) = Name_By_Protected_Procedure 17693 and then Is_Interface (Typ) 17694 and then Is_Task_Interface (Typ) 17695 then 17696 Error_Pragma_Arg 17697 ("implementation kind By_Protected_Procedure cannot be " 17698 & "applied to a task interface primitive", Arg2); 17699 return; 17700 end if; 17701 17702 -- Procedures declared inside a protected type must be accepted 17703 17704 elsif Ekind (Proc_Id) = E_Procedure 17705 and then Is_Protected_Type (Scope (Proc_Id)) 17706 then 17707 null; 17708 17709 -- The first argument is not a primitive procedure 17710 17711 else 17712 Error_Pragma_Arg 17713 ("pragma % must be applied to a primitive procedure", Arg1); 17714 return; 17715 end if; 17716 17717 Record_Rep_Item (Proc_Id, N); 17718 end Implemented; 17719 17720 ---------------------- 17721 -- Implicit_Packing -- 17722 ---------------------- 17723 17724 -- pragma Implicit_Packing; 17725 17726 when Pragma_Implicit_Packing => 17727 GNAT_Pragma; 17728 Check_Arg_Count (0); 17729 Implicit_Packing := True; 17730 17731 ------------ 17732 -- Import -- 17733 ------------ 17734 17735 -- pragma Import ( 17736 -- [Convention =>] convention_IDENTIFIER, 17737 -- [Entity =>] LOCAL_NAME 17738 -- [, [External_Name =>] static_string_EXPRESSION ] 17739 -- [, [Link_Name =>] static_string_EXPRESSION ]); 17740 17741 when Pragma_Import => 17742 Check_Ada_83_Warning; 17743 Check_Arg_Order 17744 ((Name_Convention, 17745 Name_Entity, 17746 Name_External_Name, 17747 Name_Link_Name)); 17748 17749 Check_At_Least_N_Arguments (2); 17750 Check_At_Most_N_Arguments (4); 17751 Process_Import_Or_Interface; 17752 17753 --------------------- 17754 -- Import_Function -- 17755 --------------------- 17756 17757 -- pragma Import_Function ( 17758 -- [Internal =>] LOCAL_NAME, 17759 -- [, [External =>] EXTERNAL_SYMBOL] 17760 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 17761 -- [, [Result_Type =>] SUBTYPE_MARK] 17762 -- [, [Mechanism =>] MECHANISM] 17763 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 17764 17765 -- EXTERNAL_SYMBOL ::= 17766 -- IDENTIFIER 17767 -- | static_string_EXPRESSION 17768 17769 -- PARAMETER_TYPES ::= 17770 -- null 17771 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 17772 17773 -- TYPE_DESIGNATOR ::= 17774 -- subtype_NAME 17775 -- | subtype_Name ' Access 17776 17777 -- MECHANISM ::= 17778 -- MECHANISM_NAME 17779 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 17780 17781 -- MECHANISM_ASSOCIATION ::= 17782 -- [formal_parameter_NAME =>] MECHANISM_NAME 17783 17784 -- MECHANISM_NAME ::= 17785 -- Value 17786 -- | Reference 17787 17788 when Pragma_Import_Function => Import_Function : declare 17789 Args : Args_List (1 .. 6); 17790 Names : constant Name_List (1 .. 6) := ( 17791 Name_Internal, 17792 Name_External, 17793 Name_Parameter_Types, 17794 Name_Result_Type, 17795 Name_Mechanism, 17796 Name_Result_Mechanism); 17797 17798 Internal : Node_Id renames Args (1); 17799 External : Node_Id renames Args (2); 17800 Parameter_Types : Node_Id renames Args (3); 17801 Result_Type : Node_Id renames Args (4); 17802 Mechanism : Node_Id renames Args (5); 17803 Result_Mechanism : Node_Id renames Args (6); 17804 17805 begin 17806 GNAT_Pragma; 17807 Gather_Associations (Names, Args); 17808 Process_Extended_Import_Export_Subprogram_Pragma ( 17809 Arg_Internal => Internal, 17810 Arg_External => External, 17811 Arg_Parameter_Types => Parameter_Types, 17812 Arg_Result_Type => Result_Type, 17813 Arg_Mechanism => Mechanism, 17814 Arg_Result_Mechanism => Result_Mechanism); 17815 end Import_Function; 17816 17817 ------------------- 17818 -- Import_Object -- 17819 ------------------- 17820 17821 -- pragma Import_Object ( 17822 -- [Internal =>] LOCAL_NAME 17823 -- [, [External =>] EXTERNAL_SYMBOL] 17824 -- [, [Size =>] EXTERNAL_SYMBOL]); 17825 17826 -- EXTERNAL_SYMBOL ::= 17827 -- IDENTIFIER 17828 -- | static_string_EXPRESSION 17829 17830 when Pragma_Import_Object => Import_Object : declare 17831 Args : Args_List (1 .. 3); 17832 Names : constant Name_List (1 .. 3) := ( 17833 Name_Internal, 17834 Name_External, 17835 Name_Size); 17836 17837 Internal : Node_Id renames Args (1); 17838 External : Node_Id renames Args (2); 17839 Size : Node_Id renames Args (3); 17840 17841 begin 17842 GNAT_Pragma; 17843 Gather_Associations (Names, Args); 17844 Process_Extended_Import_Export_Object_Pragma ( 17845 Arg_Internal => Internal, 17846 Arg_External => External, 17847 Arg_Size => Size); 17848 end Import_Object; 17849 17850 ---------------------- 17851 -- Import_Procedure -- 17852 ---------------------- 17853 17854 -- pragma Import_Procedure ( 17855 -- [Internal =>] LOCAL_NAME 17856 -- [, [External =>] EXTERNAL_SYMBOL] 17857 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 17858 -- [, [Mechanism =>] MECHANISM]); 17859 17860 -- EXTERNAL_SYMBOL ::= 17861 -- IDENTIFIER 17862 -- | static_string_EXPRESSION 17863 17864 -- PARAMETER_TYPES ::= 17865 -- null 17866 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 17867 17868 -- TYPE_DESIGNATOR ::= 17869 -- subtype_NAME 17870 -- | subtype_Name ' Access 17871 17872 -- MECHANISM ::= 17873 -- MECHANISM_NAME 17874 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 17875 17876 -- MECHANISM_ASSOCIATION ::= 17877 -- [formal_parameter_NAME =>] MECHANISM_NAME 17878 17879 -- MECHANISM_NAME ::= 17880 -- Value 17881 -- | Reference 17882 17883 when Pragma_Import_Procedure => Import_Procedure : declare 17884 Args : Args_List (1 .. 4); 17885 Names : constant Name_List (1 .. 4) := ( 17886 Name_Internal, 17887 Name_External, 17888 Name_Parameter_Types, 17889 Name_Mechanism); 17890 17891 Internal : Node_Id renames Args (1); 17892 External : Node_Id renames Args (2); 17893 Parameter_Types : Node_Id renames Args (3); 17894 Mechanism : Node_Id renames Args (4); 17895 17896 begin 17897 GNAT_Pragma; 17898 Gather_Associations (Names, Args); 17899 Process_Extended_Import_Export_Subprogram_Pragma ( 17900 Arg_Internal => Internal, 17901 Arg_External => External, 17902 Arg_Parameter_Types => Parameter_Types, 17903 Arg_Mechanism => Mechanism); 17904 end Import_Procedure; 17905 17906 ----------------------------- 17907 -- Import_Valued_Procedure -- 17908 ----------------------------- 17909 17910 -- pragma Import_Valued_Procedure ( 17911 -- [Internal =>] LOCAL_NAME 17912 -- [, [External =>] EXTERNAL_SYMBOL] 17913 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 17914 -- [, [Mechanism =>] MECHANISM]); 17915 17916 -- EXTERNAL_SYMBOL ::= 17917 -- IDENTIFIER 17918 -- | static_string_EXPRESSION 17919 17920 -- PARAMETER_TYPES ::= 17921 -- null 17922 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 17923 17924 -- TYPE_DESIGNATOR ::= 17925 -- subtype_NAME 17926 -- | subtype_Name ' Access 17927 17928 -- MECHANISM ::= 17929 -- MECHANISM_NAME 17930 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 17931 17932 -- MECHANISM_ASSOCIATION ::= 17933 -- [formal_parameter_NAME =>] MECHANISM_NAME 17934 17935 -- MECHANISM_NAME ::= 17936 -- Value 17937 -- | Reference 17938 17939 when Pragma_Import_Valued_Procedure => 17940 Import_Valued_Procedure : declare 17941 Args : Args_List (1 .. 4); 17942 Names : constant Name_List (1 .. 4) := ( 17943 Name_Internal, 17944 Name_External, 17945 Name_Parameter_Types, 17946 Name_Mechanism); 17947 17948 Internal : Node_Id renames Args (1); 17949 External : Node_Id renames Args (2); 17950 Parameter_Types : Node_Id renames Args (3); 17951 Mechanism : Node_Id renames Args (4); 17952 17953 begin 17954 GNAT_Pragma; 17955 Gather_Associations (Names, Args); 17956 Process_Extended_Import_Export_Subprogram_Pragma ( 17957 Arg_Internal => Internal, 17958 Arg_External => External, 17959 Arg_Parameter_Types => Parameter_Types, 17960 Arg_Mechanism => Mechanism); 17961 end Import_Valued_Procedure; 17962 17963 ----------------- 17964 -- Independent -- 17965 ----------------- 17966 17967 -- pragma Independent (LOCAL_NAME); 17968 17969 when Pragma_Independent => 17970 Process_Atomic_Independent_Shared_Volatile; 17971 17972 ---------------------------- 17973 -- Independent_Components -- 17974 ---------------------------- 17975 17976 -- pragma Independent_Components (array_or_record_LOCAL_NAME); 17977 17978 when Pragma_Independent_Components => Independent_Components : declare 17979 C : Node_Id; 17980 D : Node_Id; 17981 E_Id : Node_Id; 17982 E : Entity_Id; 17983 17984 begin 17985 Check_Ada_83_Warning; 17986 Ada_2012_Pragma; 17987 Check_No_Identifiers; 17988 Check_Arg_Count (1); 17989 Check_Arg_Is_Local_Name (Arg1); 17990 E_Id := Get_Pragma_Arg (Arg1); 17991 17992 if Etype (E_Id) = Any_Type then 17993 return; 17994 end if; 17995 17996 E := Entity (E_Id); 17997 17998 -- A record type with a self-referential component of anonymous 17999 -- access type is given an incomplete view in order to handle the 18000 -- self reference: 18001 -- 18002 -- type Rec is record 18003 -- Self : access Rec; 18004 -- end record; 18005 -- 18006 -- becomes 18007 -- 18008 -- type Rec; 18009 -- type Ptr is access Rec; 18010 -- type Rec is record 18011 -- Self : Ptr; 18012 -- end record; 18013 -- 18014 -- Since the incomplete view is now the initial view of the type, 18015 -- the argument of the pragma will reference the incomplete view, 18016 -- but this view is illegal according to the semantics of the 18017 -- pragma. 18018 -- 18019 -- Obtain the full view of an internally-generated incomplete type 18020 -- only. This way an attempt to associate the pragma with a source 18021 -- incomplete type is still caught. 18022 18023 if Ekind (E) = E_Incomplete_Type 18024 and then not Comes_From_Source (E) 18025 and then Present (Full_View (E)) 18026 then 18027 E := Full_View (E); 18028 end if; 18029 18030 -- A pragma that applies to a Ghost entity becomes Ghost for the 18031 -- purposes of legality checks and removal of ignored Ghost code. 18032 18033 Mark_Ghost_Pragma (N, E); 18034 18035 -- Check duplicate before we chain ourselves 18036 18037 Check_Duplicate_Pragma (E); 18038 18039 -- Check appropriate entity 18040 18041 if Rep_Item_Too_Early (E, N) 18042 or else 18043 Rep_Item_Too_Late (E, N) 18044 then 18045 return; 18046 end if; 18047 18048 D := Declaration_Node (E); 18049 18050 -- The flag is set on the base type, or on the object 18051 18052 if Nkind (D) = N_Full_Type_Declaration 18053 and then (Is_Array_Type (E) or else Is_Record_Type (E)) 18054 then 18055 Set_Has_Independent_Components (Base_Type (E)); 18056 Record_Independence_Check (N, Base_Type (E)); 18057 18058 -- For record type, set all components independent 18059 18060 if Is_Record_Type (E) then 18061 C := First_Component (E); 18062 while Present (C) loop 18063 Set_Is_Independent (C); 18064 Next_Component (C); 18065 end loop; 18066 end if; 18067 18068 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 18069 and then Nkind (D) = N_Object_Declaration 18070 and then Nkind (Object_Definition (D)) = 18071 N_Constrained_Array_Definition 18072 then 18073 Set_Has_Independent_Components (E); 18074 Record_Independence_Check (N, E); 18075 18076 else 18077 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 18078 end if; 18079 end Independent_Components; 18080 18081 ----------------------- 18082 -- Initial_Condition -- 18083 ----------------------- 18084 18085 -- pragma Initial_Condition (boolean_EXPRESSION); 18086 18087 -- Characteristics: 18088 18089 -- * Analysis - The annotation undergoes initial checks to verify 18090 -- the legal placement and context. Secondary checks preanalyze the 18091 -- expression in: 18092 18093 -- Analyze_Initial_Condition_In_Decl_Part 18094 18095 -- * Expansion - The annotation is expanded during the expansion of 18096 -- the package body whose declaration is subject to the annotation 18097 -- as done in: 18098 18099 -- Expand_Pragma_Initial_Condition 18100 18101 -- * Template - The annotation utilizes the generic template of the 18102 -- related package declaration. 18103 18104 -- * Globals - Capture of global references must occur after full 18105 -- analysis. 18106 18107 -- * Instance - The annotation is instantiated automatically when 18108 -- the related generic package is instantiated. 18109 18110 when Pragma_Initial_Condition => Initial_Condition : declare 18111 Pack_Decl : Node_Id; 18112 Pack_Id : Entity_Id; 18113 18114 begin 18115 GNAT_Pragma; 18116 Check_No_Identifiers; 18117 Check_Arg_Count (1); 18118 18119 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 18120 18121 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 18122 N_Package_Declaration) 18123 then 18124 Pragma_Misplaced; 18125 return; 18126 end if; 18127 18128 Pack_Id := Defining_Entity (Pack_Decl); 18129 18130 -- A pragma that applies to a Ghost entity becomes Ghost for the 18131 -- purposes of legality checks and removal of ignored Ghost code. 18132 18133 Mark_Ghost_Pragma (N, Pack_Id); 18134 18135 -- Chain the pragma on the contract for further processing by 18136 -- Analyze_Initial_Condition_In_Decl_Part. 18137 18138 Add_Contract_Item (N, Pack_Id); 18139 18140 -- The legality checks of pragmas Abstract_State, Initializes, and 18141 -- Initial_Condition are affected by the SPARK mode in effect. In 18142 -- addition, these three pragmas are subject to an inherent order: 18143 18144 -- 1) Abstract_State 18145 -- 2) Initializes 18146 -- 3) Initial_Condition 18147 18148 -- Analyze all these pragmas in the order outlined above 18149 18150 Analyze_If_Present (Pragma_SPARK_Mode); 18151 Analyze_If_Present (Pragma_Abstract_State); 18152 Analyze_If_Present (Pragma_Initializes); 18153 end Initial_Condition; 18154 18155 ------------------------ 18156 -- Initialize_Scalars -- 18157 ------------------------ 18158 18159 -- pragma Initialize_Scalars 18160 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ]; 18161 18162 -- TYPE_VALUE_PAIR ::= 18163 -- SCALAR_TYPE => static_EXPRESSION 18164 18165 -- SCALAR_TYPE := 18166 -- Short_Float 18167 -- | Float 18168 -- | Long_Float 18169 -- | Long_Long_Flat 18170 -- | Signed_8 18171 -- | Signed_16 18172 -- | Signed_32 18173 -- | Signed_64 18174 -- | Unsigned_8 18175 -- | Unsigned_16 18176 -- | Unsigned_32 18177 -- | Unsigned_64 18178 18179 when Pragma_Initialize_Scalars => Do_Initialize_Scalars : declare 18180 Seen : array (Scalar_Id) of Node_Id := (others => Empty); 18181 -- This collection holds the individual pairs which specify the 18182 -- invalid values of their respective scalar types. 18183 18184 procedure Analyze_Float_Value 18185 (Scal_Typ : Float_Scalar_Id; 18186 Val_Expr : Node_Id); 18187 -- Analyze a type value pair associated with float type Scal_Typ 18188 -- and expression Val_Expr. 18189 18190 procedure Analyze_Integer_Value 18191 (Scal_Typ : Integer_Scalar_Id; 18192 Val_Expr : Node_Id); 18193 -- Analyze a type value pair associated with integer type Scal_Typ 18194 -- and expression Val_Expr. 18195 18196 procedure Analyze_Type_Value_Pair (Pair : Node_Id); 18197 -- Analyze type value pair Pair 18198 18199 ------------------------- 18200 -- Analyze_Float_Value -- 18201 ------------------------- 18202 18203 procedure Analyze_Float_Value 18204 (Scal_Typ : Float_Scalar_Id; 18205 Val_Expr : Node_Id) 18206 is 18207 begin 18208 Analyze_And_Resolve (Val_Expr, Any_Real); 18209 18210 if Is_OK_Static_Expression (Val_Expr) then 18211 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value_R (Val_Expr)); 18212 18213 else 18214 Error_Msg_Name_1 := Scal_Typ; 18215 Error_Msg_N ("value for type % must be static", Val_Expr); 18216 end if; 18217 end Analyze_Float_Value; 18218 18219 --------------------------- 18220 -- Analyze_Integer_Value -- 18221 --------------------------- 18222 18223 procedure Analyze_Integer_Value 18224 (Scal_Typ : Integer_Scalar_Id; 18225 Val_Expr : Node_Id) 18226 is 18227 begin 18228 Analyze_And_Resolve (Val_Expr, Any_Integer); 18229 18230 if Is_OK_Static_Expression (Val_Expr) then 18231 Set_Invalid_Scalar_Value (Scal_Typ, Expr_Value (Val_Expr)); 18232 18233 else 18234 Error_Msg_Name_1 := Scal_Typ; 18235 Error_Msg_N ("value for type % must be static", Val_Expr); 18236 end if; 18237 end Analyze_Integer_Value; 18238 18239 ----------------------------- 18240 -- Analyze_Type_Value_Pair -- 18241 ----------------------------- 18242 18243 procedure Analyze_Type_Value_Pair (Pair : Node_Id) is 18244 Scal_Typ : constant Name_Id := Chars (Pair); 18245 Val_Expr : constant Node_Id := Expression (Pair); 18246 Prev_Pair : Node_Id; 18247 18248 begin 18249 if Scal_Typ in Scalar_Id then 18250 Prev_Pair := Seen (Scal_Typ); 18251 18252 -- Prevent multiple attempts to set a value for a scalar 18253 -- type. 18254 18255 if Present (Prev_Pair) then 18256 Error_Msg_Name_1 := Scal_Typ; 18257 Error_Msg_N 18258 ("cannot specify multiple invalid values for type %", 18259 Pair); 18260 18261 Error_Msg_Sloc := Sloc (Prev_Pair); 18262 Error_Msg_N ("previous value set #", Pair); 18263 18264 -- Ignore the effects of the pair, but do not halt the 18265 -- analysis of the pragma altogether. 18266 18267 return; 18268 18269 -- Otherwise capture the first pair for this scalar type 18270 18271 else 18272 Seen (Scal_Typ) := Pair; 18273 end if; 18274 18275 if Scal_Typ in Float_Scalar_Id then 18276 Analyze_Float_Value (Scal_Typ, Val_Expr); 18277 18278 else pragma Assert (Scal_Typ in Integer_Scalar_Id); 18279 Analyze_Integer_Value (Scal_Typ, Val_Expr); 18280 end if; 18281 18282 -- Otherwise the scalar family is illegal 18283 18284 else 18285 Error_Msg_Name_1 := Pname; 18286 Error_Msg_N 18287 ("argument of pragma % must denote valid scalar family", 18288 Pair); 18289 end if; 18290 end Analyze_Type_Value_Pair; 18291 18292 -- Local variables 18293 18294 Pairs : constant List_Id := Pragma_Argument_Associations (N); 18295 Pair : Node_Id; 18296 18297 -- Start of processing for Do_Initialize_Scalars 18298 18299 begin 18300 GNAT_Pragma; 18301 Check_Valid_Configuration_Pragma; 18302 Check_Restriction (No_Initialize_Scalars, N); 18303 18304 -- Ignore the effects of the pragma when No_Initialize_Scalars is 18305 -- in effect. 18306 18307 if Restriction_Active (No_Initialize_Scalars) then 18308 null; 18309 18310 -- Initialize_Scalars creates false positives in CodePeer, and 18311 -- incorrect negative results in GNATprove mode, so ignore this 18312 -- pragma in these modes. 18313 18314 elsif CodePeer_Mode or GNATprove_Mode then 18315 null; 18316 18317 -- Otherwise analyze the pragma 18318 18319 else 18320 if Present (Pairs) then 18321 18322 -- Install Standard in order to provide access to primitive 18323 -- types in case the expressions contain attributes such as 18324 -- Integer'Last. 18325 18326 Push_Scope (Standard_Standard); 18327 18328 Pair := First (Pairs); 18329 while Present (Pair) loop 18330 Analyze_Type_Value_Pair (Pair); 18331 Next (Pair); 18332 end loop; 18333 18334 -- Remove Standard 18335 18336 Pop_Scope; 18337 end if; 18338 18339 Init_Or_Norm_Scalars := True; 18340 Initialize_Scalars := True; 18341 end if; 18342 end Do_Initialize_Scalars; 18343 18344 ----------------- 18345 -- Initializes -- 18346 ----------------- 18347 18348 -- pragma Initializes (INITIALIZATION_LIST); 18349 18350 -- INITIALIZATION_LIST ::= 18351 -- null 18352 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM}) 18353 18354 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST] 18355 18356 -- INPUT_LIST ::= 18357 -- null 18358 -- | INPUT 18359 -- | (INPUT {, INPUT}) 18360 18361 -- INPUT ::= name 18362 18363 -- Characteristics: 18364 18365 -- * Analysis - The annotation undergoes initial checks to verify 18366 -- the legal placement and context. Secondary checks preanalyze the 18367 -- expression in: 18368 18369 -- Analyze_Initializes_In_Decl_Part 18370 18371 -- * Expansion - None. 18372 18373 -- * Template - The annotation utilizes the generic template of the 18374 -- related package declaration. 18375 18376 -- * Globals - Capture of global references must occur after full 18377 -- analysis. 18378 18379 -- * Instance - The annotation is instantiated automatically when 18380 -- the related generic package is instantiated. 18381 18382 when Pragma_Initializes => Initializes : declare 18383 Pack_Decl : Node_Id; 18384 Pack_Id : Entity_Id; 18385 18386 begin 18387 GNAT_Pragma; 18388 Check_No_Identifiers; 18389 Check_Arg_Count (1); 18390 18391 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 18392 18393 if not Nkind_In (Pack_Decl, N_Generic_Package_Declaration, 18394 N_Package_Declaration) 18395 then 18396 Pragma_Misplaced; 18397 return; 18398 end if; 18399 18400 Pack_Id := Defining_Entity (Pack_Decl); 18401 18402 -- A pragma that applies to a Ghost entity becomes Ghost for the 18403 -- purposes of legality checks and removal of ignored Ghost code. 18404 18405 Mark_Ghost_Pragma (N, Pack_Id); 18406 Ensure_Aggregate_Form (Get_Argument (N, Pack_Id)); 18407 18408 -- Chain the pragma on the contract for further processing by 18409 -- Analyze_Initializes_In_Decl_Part. 18410 18411 Add_Contract_Item (N, Pack_Id); 18412 18413 -- The legality checks of pragmas Abstract_State, Initializes, and 18414 -- Initial_Condition are affected by the SPARK mode in effect. In 18415 -- addition, these three pragmas are subject to an inherent order: 18416 18417 -- 1) Abstract_State 18418 -- 2) Initializes 18419 -- 3) Initial_Condition 18420 18421 -- Analyze all these pragmas in the order outlined above 18422 18423 Analyze_If_Present (Pragma_SPARK_Mode); 18424 Analyze_If_Present (Pragma_Abstract_State); 18425 Analyze_If_Present (Pragma_Initial_Condition); 18426 end Initializes; 18427 18428 ------------ 18429 -- Inline -- 18430 ------------ 18431 18432 -- pragma Inline ( NAME {, NAME} ); 18433 18434 when Pragma_Inline => 18435 18436 -- Pragma always active unless in GNATprove mode. It is disabled 18437 -- in GNATprove mode because frontend inlining is applied 18438 -- independently of pragmas Inline and Inline_Always for 18439 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode 18440 -- in inline.ads. 18441 18442 if not GNATprove_Mode then 18443 18444 -- Inline status is Enabled if option -gnatn is specified. 18445 -- However this status determines only the value of the 18446 -- Is_Inlined flag on the subprogram and does not prevent 18447 -- the pragma itself from being recorded for later use, 18448 -- in particular for a later modification of Is_Inlined 18449 -- independently of the -gnatn option. 18450 18451 -- In other words, if -gnatn is specified for a unit, then 18452 -- all Inline pragmas processed for the compilation of this 18453 -- unit, including those in the spec of other units, are 18454 -- activated, so subprograms will be inlined across units. 18455 18456 -- If -gnatn is not specified, no Inline pragma is activated 18457 -- here, which means that subprograms will not be inlined 18458 -- across units. The Is_Inlined flag will nevertheless be 18459 -- set later when bodies are analyzed, so subprograms will 18460 -- be inlined within the unit. 18461 18462 if Inline_Active then 18463 Process_Inline (Enabled); 18464 else 18465 Process_Inline (Disabled); 18466 end if; 18467 end if; 18468 18469 ------------------- 18470 -- Inline_Always -- 18471 ------------------- 18472 18473 -- pragma Inline_Always ( NAME {, NAME} ); 18474 18475 when Pragma_Inline_Always => 18476 GNAT_Pragma; 18477 18478 -- Pragma always active unless in CodePeer mode or GNATprove 18479 -- mode. It is disabled in CodePeer mode because inlining is 18480 -- not helpful, and enabling it caused walk order issues. It 18481 -- is disabled in GNATprove mode because frontend inlining is 18482 -- applied independently of pragmas Inline and Inline_Always for 18483 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in 18484 -- inline.ads. 18485 18486 if not CodePeer_Mode and not GNATprove_Mode then 18487 Process_Inline (Enabled); 18488 end if; 18489 18490 -------------------- 18491 -- Inline_Generic -- 18492 -------------------- 18493 18494 -- pragma Inline_Generic (NAME {, NAME}); 18495 18496 when Pragma_Inline_Generic => 18497 GNAT_Pragma; 18498 Process_Generic_List; 18499 18500 ---------------------- 18501 -- Inspection_Point -- 18502 ---------------------- 18503 18504 -- pragma Inspection_Point [(object_NAME {, object_NAME})]; 18505 18506 when Pragma_Inspection_Point => Inspection_Point : declare 18507 Arg : Node_Id; 18508 Exp : Node_Id; 18509 18510 begin 18511 ip; 18512 18513 if Arg_Count > 0 then 18514 Arg := Arg1; 18515 loop 18516 Exp := Get_Pragma_Arg (Arg); 18517 Analyze (Exp); 18518 18519 if not Is_Entity_Name (Exp) 18520 or else not Is_Object (Entity (Exp)) 18521 then 18522 Error_Pragma_Arg ("object name required", Arg); 18523 end if; 18524 18525 Next (Arg); 18526 exit when No (Arg); 18527 end loop; 18528 end if; 18529 end Inspection_Point; 18530 18531 --------------- 18532 -- Interface -- 18533 --------------- 18534 18535 -- pragma Interface ( 18536 -- [ Convention =>] convention_IDENTIFIER, 18537 -- [ Entity =>] LOCAL_NAME 18538 -- [, [External_Name =>] static_string_EXPRESSION ] 18539 -- [, [Link_Name =>] static_string_EXPRESSION ]); 18540 18541 when Pragma_Interface => 18542 GNAT_Pragma; 18543 Check_Arg_Order 18544 ((Name_Convention, 18545 Name_Entity, 18546 Name_External_Name, 18547 Name_Link_Name)); 18548 Check_At_Least_N_Arguments (2); 18549 Check_At_Most_N_Arguments (4); 18550 Process_Import_Or_Interface; 18551 18552 -- In Ada 2005, the permission to use Interface (a reserved word) 18553 -- as a pragma name is considered an obsolescent feature, and this 18554 -- pragma was already obsolescent in Ada 95. 18555 18556 if Ada_Version >= Ada_95 then 18557 Check_Restriction 18558 (No_Obsolescent_Features, Pragma_Identifier (N)); 18559 18560 if Warn_On_Obsolescent_Feature then 18561 Error_Msg_N 18562 ("pragma Interface is an obsolescent feature?j?", N); 18563 Error_Msg_N 18564 ("|use pragma Import instead?j?", N); 18565 end if; 18566 end if; 18567 18568 -------------------- 18569 -- Interface_Name -- 18570 -------------------- 18571 18572 -- pragma Interface_Name ( 18573 -- [ Entity =>] LOCAL_NAME 18574 -- [,[External_Name =>] static_string_EXPRESSION ] 18575 -- [,[Link_Name =>] static_string_EXPRESSION ]); 18576 18577 when Pragma_Interface_Name => Interface_Name : declare 18578 Id : Node_Id; 18579 Def_Id : Entity_Id; 18580 Hom_Id : Entity_Id; 18581 Found : Boolean; 18582 18583 begin 18584 GNAT_Pragma; 18585 Check_Arg_Order 18586 ((Name_Entity, Name_External_Name, Name_Link_Name)); 18587 Check_At_Least_N_Arguments (2); 18588 Check_At_Most_N_Arguments (3); 18589 Id := Get_Pragma_Arg (Arg1); 18590 Analyze (Id); 18591 18592 -- This is obsolete from Ada 95 on, but it is an implementation 18593 -- defined pragma, so we do not consider that it violates the 18594 -- restriction (No_Obsolescent_Features). 18595 18596 if Ada_Version >= Ada_95 then 18597 if Warn_On_Obsolescent_Feature then 18598 Error_Msg_N 18599 ("pragma Interface_Name is an obsolescent feature?j?", N); 18600 Error_Msg_N 18601 ("|use pragma Import instead?j?", N); 18602 end if; 18603 end if; 18604 18605 if not Is_Entity_Name (Id) then 18606 Error_Pragma_Arg 18607 ("first argument for pragma% must be entity name", Arg1); 18608 elsif Etype (Id) = Any_Type then 18609 return; 18610 else 18611 Def_Id := Entity (Id); 18612 end if; 18613 18614 -- Special DEC-compatible processing for the object case, forces 18615 -- object to be imported. 18616 18617 if Ekind (Def_Id) = E_Variable then 18618 Kill_Size_Check_Code (Def_Id); 18619 Note_Possible_Modification (Id, Sure => False); 18620 18621 -- Initialization is not allowed for imported variable 18622 18623 if Present (Expression (Parent (Def_Id))) 18624 and then Comes_From_Source (Expression (Parent (Def_Id))) 18625 then 18626 Error_Msg_Sloc := Sloc (Def_Id); 18627 Error_Pragma_Arg 18628 ("no initialization allowed for declaration of& #", 18629 Arg2); 18630 18631 else 18632 -- For compatibility, support VADS usage of providing both 18633 -- pragmas Interface and Interface_Name to obtain the effect 18634 -- of a single Import pragma. 18635 18636 if Is_Imported (Def_Id) 18637 and then Present (First_Rep_Item (Def_Id)) 18638 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma 18639 and then Pragma_Name (First_Rep_Item (Def_Id)) = 18640 Name_Interface 18641 then 18642 null; 18643 else 18644 Set_Imported (Def_Id); 18645 end if; 18646 18647 Set_Is_Public (Def_Id); 18648 Process_Interface_Name (Def_Id, Arg2, Arg3, N); 18649 end if; 18650 18651 -- Otherwise must be subprogram 18652 18653 elsif not Is_Subprogram (Def_Id) then 18654 Error_Pragma_Arg 18655 ("argument of pragma% is not subprogram", Arg1); 18656 18657 else 18658 Check_At_Most_N_Arguments (3); 18659 Hom_Id := Def_Id; 18660 Found := False; 18661 18662 -- Loop through homonyms 18663 18664 loop 18665 Def_Id := Get_Base_Subprogram (Hom_Id); 18666 18667 if Is_Imported (Def_Id) then 18668 Process_Interface_Name (Def_Id, Arg2, Arg3, N); 18669 Found := True; 18670 end if; 18671 18672 exit when From_Aspect_Specification (N); 18673 Hom_Id := Homonym (Hom_Id); 18674 18675 exit when No (Hom_Id) 18676 or else Scope (Hom_Id) /= Current_Scope; 18677 end loop; 18678 18679 if not Found then 18680 Error_Pragma_Arg 18681 ("argument of pragma% is not imported subprogram", 18682 Arg1); 18683 end if; 18684 end if; 18685 end Interface_Name; 18686 18687 ----------------------- 18688 -- Interrupt_Handler -- 18689 ----------------------- 18690 18691 -- pragma Interrupt_Handler (handler_NAME); 18692 18693 when Pragma_Interrupt_Handler => 18694 Check_Ada_83_Warning; 18695 Check_Arg_Count (1); 18696 Check_No_Identifiers; 18697 18698 if No_Run_Time_Mode then 18699 Error_Msg_CRT ("Interrupt_Handler pragma", N); 18700 else 18701 Check_Interrupt_Or_Attach_Handler; 18702 Process_Interrupt_Or_Attach_Handler; 18703 end if; 18704 18705 ------------------------ 18706 -- Interrupt_Priority -- 18707 ------------------------ 18708 18709 -- pragma Interrupt_Priority [(EXPRESSION)]; 18710 18711 when Pragma_Interrupt_Priority => Interrupt_Priority : declare 18712 P : constant Node_Id := Parent (N); 18713 Arg : Node_Id; 18714 Ent : Entity_Id; 18715 18716 begin 18717 Check_Ada_83_Warning; 18718 18719 if Arg_Count /= 0 then 18720 Arg := Get_Pragma_Arg (Arg1); 18721 Check_Arg_Count (1); 18722 Check_No_Identifiers; 18723 18724 -- The expression must be analyzed in the special manner 18725 -- described in "Handling of Default and Per-Object 18726 -- Expressions" in sem.ads. 18727 18728 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); 18729 end if; 18730 18731 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then 18732 Pragma_Misplaced; 18733 return; 18734 18735 else 18736 Ent := Defining_Identifier (Parent (P)); 18737 18738 -- Check duplicate pragma before we chain the pragma in the Rep 18739 -- Item chain of Ent. 18740 18741 Check_Duplicate_Pragma (Ent); 18742 Record_Rep_Item (Ent, N); 18743 18744 -- Check the No_Task_At_Interrupt_Priority restriction 18745 18746 if Nkind (P) = N_Task_Definition then 18747 Check_Restriction (No_Task_At_Interrupt_Priority, N); 18748 end if; 18749 end if; 18750 end Interrupt_Priority; 18751 18752 --------------------- 18753 -- Interrupt_State -- 18754 --------------------- 18755 18756 -- pragma Interrupt_State ( 18757 -- [Name =>] INTERRUPT_ID, 18758 -- [State =>] INTERRUPT_STATE); 18759 18760 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION 18761 -- INTERRUPT_STATE => System | Runtime | User 18762 18763 -- Note: if the interrupt id is given as an identifier, then it must 18764 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is 18765 -- given as a static integer expression which must be in the range of 18766 -- Ada.Interrupts.Interrupt_ID. 18767 18768 when Pragma_Interrupt_State => Interrupt_State : declare 18769 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); 18770 -- This is the entity Ada.Interrupts.Interrupt_ID; 18771 18772 State_Type : Character; 18773 -- Set to 's'/'r'/'u' for System/Runtime/User 18774 18775 IST_Num : Pos; 18776 -- Index to entry in Interrupt_States table 18777 18778 Int_Val : Uint; 18779 -- Value of interrupt 18780 18781 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); 18782 -- The first argument to the pragma 18783 18784 Int_Ent : Entity_Id; 18785 -- Interrupt entity in Ada.Interrupts.Names 18786 18787 begin 18788 GNAT_Pragma; 18789 Check_Arg_Order ((Name_Name, Name_State)); 18790 Check_Arg_Count (2); 18791 18792 Check_Optional_Identifier (Arg1, Name_Name); 18793 Check_Optional_Identifier (Arg2, Name_State); 18794 Check_Arg_Is_Identifier (Arg2); 18795 18796 -- First argument is identifier 18797 18798 if Nkind (Arg1X) = N_Identifier then 18799 18800 -- Search list of names in Ada.Interrupts.Names 18801 18802 Int_Ent := First_Entity (RTE (RE_Names)); 18803 loop 18804 if No (Int_Ent) then 18805 Error_Pragma_Arg ("invalid interrupt name", Arg1); 18806 18807 elsif Chars (Int_Ent) = Chars (Arg1X) then 18808 Int_Val := Expr_Value (Constant_Value (Int_Ent)); 18809 exit; 18810 end if; 18811 18812 Next_Entity (Int_Ent); 18813 end loop; 18814 18815 -- First argument is not an identifier, so it must be a static 18816 -- expression of type Ada.Interrupts.Interrupt_ID. 18817 18818 else 18819 Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); 18820 Int_Val := Expr_Value (Arg1X); 18821 18822 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) 18823 or else 18824 Int_Val > Expr_Value (Type_High_Bound (Int_Id)) 18825 then 18826 Error_Pragma_Arg 18827 ("value not in range of type " 18828 & """Ada.Interrupts.Interrupt_'I'D""", Arg1); 18829 end if; 18830 end if; 18831 18832 -- Check OK state 18833 18834 case Chars (Get_Pragma_Arg (Arg2)) is 18835 when Name_Runtime => State_Type := 'r'; 18836 when Name_System => State_Type := 's'; 18837 when Name_User => State_Type := 'u'; 18838 18839 when others => 18840 Error_Pragma_Arg ("invalid interrupt state", Arg2); 18841 end case; 18842 18843 -- Check if entry is already stored 18844 18845 IST_Num := Interrupt_States.First; 18846 loop 18847 -- If entry not found, add it 18848 18849 if IST_Num > Interrupt_States.Last then 18850 Interrupt_States.Append 18851 ((Interrupt_Number => UI_To_Int (Int_Val), 18852 Interrupt_State => State_Type, 18853 Pragma_Loc => Loc)); 18854 exit; 18855 18856 -- Case of entry for the same entry 18857 18858 elsif Int_Val = Interrupt_States.Table (IST_Num). 18859 Interrupt_Number 18860 then 18861 -- If state matches, done, no need to make redundant entry 18862 18863 exit when 18864 State_Type = Interrupt_States.Table (IST_Num). 18865 Interrupt_State; 18866 18867 -- Otherwise if state does not match, error 18868 18869 Error_Msg_Sloc := 18870 Interrupt_States.Table (IST_Num).Pragma_Loc; 18871 Error_Pragma_Arg 18872 ("state conflicts with that given #", Arg2); 18873 exit; 18874 end if; 18875 18876 IST_Num := IST_Num + 1; 18877 end loop; 18878 end Interrupt_State; 18879 18880 --------------- 18881 -- Invariant -- 18882 --------------- 18883 18884 -- pragma Invariant 18885 -- ([Entity =>] type_LOCAL_NAME, 18886 -- [Check =>] EXPRESSION 18887 -- [,[Message =>] String_Expression]); 18888 18889 when Pragma_Invariant => Invariant : declare 18890 Discard : Boolean; 18891 Typ : Entity_Id; 18892 Typ_Arg : Node_Id; 18893 18894 begin 18895 GNAT_Pragma; 18896 Check_At_Least_N_Arguments (2); 18897 Check_At_Most_N_Arguments (3); 18898 Check_Optional_Identifier (Arg1, Name_Entity); 18899 Check_Optional_Identifier (Arg2, Name_Check); 18900 18901 if Arg_Count = 3 then 18902 Check_Optional_Identifier (Arg3, Name_Message); 18903 Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); 18904 end if; 18905 18906 Check_Arg_Is_Local_Name (Arg1); 18907 18908 Typ_Arg := Get_Pragma_Arg (Arg1); 18909 Find_Type (Typ_Arg); 18910 Typ := Entity (Typ_Arg); 18911 18912 -- Nothing to do of the related type is erroneous in some way 18913 18914 if Typ = Any_Type then 18915 return; 18916 18917 -- AI12-0041: Invariants are allowed in interface types 18918 18919 elsif Is_Interface (Typ) then 18920 null; 18921 18922 -- An invariant must apply to a private type, or appear in the 18923 -- private part of a package spec and apply to a completion. 18924 -- a class-wide invariant can only appear on a private declaration 18925 -- or private extension, not a completion. 18926 18927 -- A [class-wide] invariant may be associated a [limited] private 18928 -- type or a private extension. 18929 18930 elsif Ekind_In (Typ, E_Limited_Private_Type, 18931 E_Private_Type, 18932 E_Record_Type_With_Private) 18933 then 18934 null; 18935 18936 -- A non-class-wide invariant may be associated with the full view 18937 -- of a [limited] private type or a private extension. 18938 18939 elsif Has_Private_Declaration (Typ) 18940 and then not Class_Present (N) 18941 then 18942 null; 18943 18944 -- A class-wide invariant may appear on the partial view only 18945 18946 elsif Class_Present (N) then 18947 Error_Pragma_Arg 18948 ("pragma % only allowed for private type", Arg1); 18949 return; 18950 18951 -- A regular invariant may appear on both views 18952 18953 else 18954 Error_Pragma_Arg 18955 ("pragma % only allowed for private type or corresponding " 18956 & "full view", Arg1); 18957 return; 18958 end if; 18959 18960 -- An invariant associated with an abstract type (this includes 18961 -- interfaces) must be class-wide. 18962 18963 if Is_Abstract_Type (Typ) and then not Class_Present (N) then 18964 Error_Pragma_Arg 18965 ("pragma % not allowed for abstract type", Arg1); 18966 return; 18967 end if; 18968 18969 -- A pragma that applies to a Ghost entity becomes Ghost for the 18970 -- purposes of legality checks and removal of ignored Ghost code. 18971 18972 Mark_Ghost_Pragma (N, Typ); 18973 18974 -- The pragma defines a type-specific invariant, the type is said 18975 -- to have invariants of its "own". 18976 18977 Set_Has_Own_Invariants (Typ); 18978 18979 -- Set the Invariants_Ignored flag if that policy is in effect 18980 18981 Set_Invariants_Ignored (Typ, 18982 Present (Check_Policy_List) 18983 and then 18984 (Policy_In_Effect (Name_Invariant) = Name_Ignore 18985 and then 18986 Policy_In_Effect (Name_Type_Invariant) = Name_Ignore)); 18987 18988 -- If the invariant is class-wide, then it can be inherited by 18989 -- derived or interface implementing types. The type is said to 18990 -- have "inheritable" invariants. 18991 18992 if Class_Present (N) then 18993 Set_Has_Inheritable_Invariants (Typ); 18994 end if; 18995 18996 -- Chain the pragma on to the rep item chain, for processing when 18997 -- the type is frozen. 18998 18999 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 19000 19001 -- Create the declaration of the invariant procedure that will 19002 -- verify the invariant at run time. Interfaces are treated as the 19003 -- partial view of a private type in order to achieve uniformity 19004 -- with the general case. As a result, an interface receives only 19005 -- a "partial" invariant procedure, which is never called. 19006 19007 Build_Invariant_Procedure_Declaration 19008 (Typ => Typ, 19009 Partial_Invariant => Is_Interface (Typ)); 19010 end Invariant; 19011 19012 ---------------- 19013 -- Keep_Names -- 19014 ---------------- 19015 19016 -- pragma Keep_Names ([On => ] LOCAL_NAME); 19017 19018 when Pragma_Keep_Names => Keep_Names : declare 19019 Arg : Node_Id; 19020 19021 begin 19022 GNAT_Pragma; 19023 Check_Arg_Count (1); 19024 Check_Optional_Identifier (Arg1, Name_On); 19025 Check_Arg_Is_Local_Name (Arg1); 19026 19027 Arg := Get_Pragma_Arg (Arg1); 19028 Analyze (Arg); 19029 19030 if Etype (Arg) = Any_Type then 19031 return; 19032 end if; 19033 19034 if not Is_Entity_Name (Arg) 19035 or else Ekind (Entity (Arg)) /= E_Enumeration_Type 19036 then 19037 Error_Pragma_Arg 19038 ("pragma% requires a local enumeration type", Arg1); 19039 end if; 19040 19041 Set_Discard_Names (Entity (Arg), False); 19042 end Keep_Names; 19043 19044 ------------- 19045 -- License -- 19046 ------------- 19047 19048 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL); 19049 19050 when Pragma_License => 19051 GNAT_Pragma; 19052 19053 -- Do not analyze pragma any further in CodePeer mode, to avoid 19054 -- extraneous errors in this implementation-dependent pragma, 19055 -- which has a different profile on other compilers. 19056 19057 if CodePeer_Mode then 19058 return; 19059 end if; 19060 19061 Check_Arg_Count (1); 19062 Check_No_Identifiers; 19063 Check_Valid_Configuration_Pragma; 19064 Check_Arg_Is_Identifier (Arg1); 19065 19066 declare 19067 Sind : constant Source_File_Index := 19068 Source_Index (Current_Sem_Unit); 19069 19070 begin 19071 case Chars (Get_Pragma_Arg (Arg1)) is 19072 when Name_GPL => 19073 Set_License (Sind, GPL); 19074 19075 when Name_Modified_GPL => 19076 Set_License (Sind, Modified_GPL); 19077 19078 when Name_Restricted => 19079 Set_License (Sind, Restricted); 19080 19081 when Name_Unrestricted => 19082 Set_License (Sind, Unrestricted); 19083 19084 when others => 19085 Error_Pragma_Arg ("invalid license name", Arg1); 19086 end case; 19087 end; 19088 19089 --------------- 19090 -- Link_With -- 19091 --------------- 19092 19093 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION}); 19094 19095 when Pragma_Link_With => Link_With : declare 19096 Arg : Node_Id; 19097 19098 begin 19099 GNAT_Pragma; 19100 19101 if Operating_Mode = Generate_Code 19102 and then In_Extended_Main_Source_Unit (N) 19103 then 19104 Check_At_Least_N_Arguments (1); 19105 Check_No_Identifiers; 19106 Check_Is_In_Decl_Part_Or_Package_Spec; 19107 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 19108 Start_String; 19109 19110 Arg := Arg1; 19111 while Present (Arg) loop 19112 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); 19113 19114 -- Store argument, converting sequences of spaces to a 19115 -- single null character (this is one of the differences 19116 -- in processing between Link_With and Linker_Options). 19117 19118 Arg_Store : declare 19119 C : constant Char_Code := Get_Char_Code (' '); 19120 S : constant String_Id := 19121 Strval (Expr_Value_S (Get_Pragma_Arg (Arg))); 19122 L : constant Nat := String_Length (S); 19123 F : Nat := 1; 19124 19125 procedure Skip_Spaces; 19126 -- Advance F past any spaces 19127 19128 ----------------- 19129 -- Skip_Spaces -- 19130 ----------------- 19131 19132 procedure Skip_Spaces is 19133 begin 19134 while F <= L and then Get_String_Char (S, F) = C loop 19135 F := F + 1; 19136 end loop; 19137 end Skip_Spaces; 19138 19139 -- Start of processing for Arg_Store 19140 19141 begin 19142 Skip_Spaces; -- skip leading spaces 19143 19144 -- Loop through characters, changing any embedded 19145 -- sequence of spaces to a single null character (this 19146 -- is how Link_With/Linker_Options differ) 19147 19148 while F <= L loop 19149 if Get_String_Char (S, F) = C then 19150 Skip_Spaces; 19151 exit when F > L; 19152 Store_String_Char (ASCII.NUL); 19153 19154 else 19155 Store_String_Char (Get_String_Char (S, F)); 19156 F := F + 1; 19157 end if; 19158 end loop; 19159 end Arg_Store; 19160 19161 Arg := Next (Arg); 19162 19163 if Present (Arg) then 19164 Store_String_Char (ASCII.NUL); 19165 end if; 19166 end loop; 19167 19168 Store_Linker_Option_String (End_String); 19169 end if; 19170 end Link_With; 19171 19172 ------------------ 19173 -- Linker_Alias -- 19174 ------------------ 19175 19176 -- pragma Linker_Alias ( 19177 -- [Entity =>] LOCAL_NAME 19178 -- [Target =>] static_string_EXPRESSION); 19179 19180 when Pragma_Linker_Alias => 19181 GNAT_Pragma; 19182 Check_Arg_Order ((Name_Entity, Name_Target)); 19183 Check_Arg_Count (2); 19184 Check_Optional_Identifier (Arg1, Name_Entity); 19185 Check_Optional_Identifier (Arg2, Name_Target); 19186 Check_Arg_Is_Library_Level_Local_Name (Arg1); 19187 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 19188 19189 -- The only processing required is to link this item on to the 19190 -- list of rep items for the given entity. This is accomplished 19191 -- by the call to Rep_Item_Too_Late (when no error is detected 19192 -- and False is returned). 19193 19194 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then 19195 return; 19196 else 19197 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 19198 end if; 19199 19200 ------------------------ 19201 -- Linker_Constructor -- 19202 ------------------------ 19203 19204 -- pragma Linker_Constructor (procedure_LOCAL_NAME); 19205 19206 -- Code is shared with Linker_Destructor 19207 19208 ----------------------- 19209 -- Linker_Destructor -- 19210 ----------------------- 19211 19212 -- pragma Linker_Destructor (procedure_LOCAL_NAME); 19213 19214 when Pragma_Linker_Constructor 19215 | Pragma_Linker_Destructor 19216 => 19217 Linker_Constructor : declare 19218 Arg1_X : Node_Id; 19219 Proc : Entity_Id; 19220 19221 begin 19222 GNAT_Pragma; 19223 Check_Arg_Count (1); 19224 Check_No_Identifiers; 19225 Check_Arg_Is_Local_Name (Arg1); 19226 Arg1_X := Get_Pragma_Arg (Arg1); 19227 Analyze (Arg1_X); 19228 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 19229 19230 if not Is_Library_Level_Entity (Proc) then 19231 Error_Pragma_Arg 19232 ("argument for pragma% must be library level entity", Arg1); 19233 end if; 19234 19235 -- The only processing required is to link this item on to the 19236 -- list of rep items for the given entity. This is accomplished 19237 -- by the call to Rep_Item_Too_Late (when no error is detected 19238 -- and False is returned). 19239 19240 if Rep_Item_Too_Late (Proc, N) then 19241 return; 19242 else 19243 Set_Has_Gigi_Rep_Item (Proc); 19244 end if; 19245 end Linker_Constructor; 19246 19247 -------------------- 19248 -- Linker_Options -- 19249 -------------------- 19250 19251 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); 19252 19253 when Pragma_Linker_Options => Linker_Options : declare 19254 Arg : Node_Id; 19255 19256 begin 19257 Check_Ada_83_Warning; 19258 Check_No_Identifiers; 19259 Check_Arg_Count (1); 19260 Check_Is_In_Decl_Part_Or_Package_Spec; 19261 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 19262 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); 19263 19264 Arg := Arg2; 19265 while Present (Arg) loop 19266 Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); 19267 Store_String_Char (ASCII.NUL); 19268 Store_String_Chars 19269 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); 19270 Arg := Next (Arg); 19271 end loop; 19272 19273 if Operating_Mode = Generate_Code 19274 and then In_Extended_Main_Source_Unit (N) 19275 then 19276 Store_Linker_Option_String (End_String); 19277 end if; 19278 end Linker_Options; 19279 19280 -------------------- 19281 -- Linker_Section -- 19282 -------------------- 19283 19284 -- pragma Linker_Section ( 19285 -- [Entity =>] LOCAL_NAME 19286 -- [Section =>] static_string_EXPRESSION); 19287 19288 when Pragma_Linker_Section => Linker_Section : declare 19289 Arg : Node_Id; 19290 Ent : Entity_Id; 19291 LPE : Node_Id; 19292 19293 Ghost_Error_Posted : Boolean := False; 19294 -- Flag set when an error concerning the illegal mix of Ghost and 19295 -- non-Ghost subprograms is emitted. 19296 19297 Ghost_Id : Entity_Id := Empty; 19298 -- The entity of the first Ghost subprogram encountered while 19299 -- processing the arguments of the pragma. 19300 19301 begin 19302 GNAT_Pragma; 19303 Check_Arg_Order ((Name_Entity, Name_Section)); 19304 Check_Arg_Count (2); 19305 Check_Optional_Identifier (Arg1, Name_Entity); 19306 Check_Optional_Identifier (Arg2, Name_Section); 19307 Check_Arg_Is_Library_Level_Local_Name (Arg1); 19308 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 19309 19310 -- Check kind of entity 19311 19312 Arg := Get_Pragma_Arg (Arg1); 19313 Ent := Entity (Arg); 19314 19315 case Ekind (Ent) is 19316 19317 -- Objects (constants and variables) and types. For these cases 19318 -- all we need to do is to set the Linker_Section_pragma field, 19319 -- checking that we do not have a duplicate. 19320 19321 when Type_Kind 19322 | E_Constant 19323 | E_Variable 19324 => 19325 LPE := Linker_Section_Pragma (Ent); 19326 19327 if Present (LPE) then 19328 Error_Msg_Sloc := Sloc (LPE); 19329 Error_Msg_NE 19330 ("Linker_Section already specified for &#", Arg1, Ent); 19331 end if; 19332 19333 Set_Linker_Section_Pragma (Ent, N); 19334 19335 -- A pragma that applies to a Ghost entity becomes Ghost for 19336 -- the purposes of legality checks and removal of ignored 19337 -- Ghost code. 19338 19339 Mark_Ghost_Pragma (N, Ent); 19340 19341 -- Subprograms 19342 19343 when Subprogram_Kind => 19344 19345 -- Aspect case, entity already set 19346 19347 if From_Aspect_Specification (N) then 19348 Set_Linker_Section_Pragma 19349 (Entity (Corresponding_Aspect (N)), N); 19350 19351 -- Propagate it to its ultimate aliased entity to 19352 -- facilitate the backend processing this attribute 19353 -- in instantiations of generic subprograms. 19354 19355 if Present (Alias (Entity (Corresponding_Aspect (N)))) 19356 then 19357 Set_Linker_Section_Pragma 19358 (Ultimate_Alias 19359 (Entity (Corresponding_Aspect (N))), N); 19360 end if; 19361 19362 -- Pragma case, we must climb the homonym chain, but skip 19363 -- any for which the linker section is already set. 19364 19365 else 19366 loop 19367 if No (Linker_Section_Pragma (Ent)) then 19368 Set_Linker_Section_Pragma (Ent, N); 19369 19370 -- Propagate it to its ultimate aliased entity to 19371 -- facilitate the backend processing this attribute 19372 -- in instantiations of generic subprograms. 19373 19374 if Present (Alias (Ent)) then 19375 Set_Linker_Section_Pragma 19376 (Ultimate_Alias (Ent), N); 19377 end if; 19378 19379 -- A pragma that applies to a Ghost entity becomes 19380 -- Ghost for the purposes of legality checks and 19381 -- removal of ignored Ghost code. 19382 19383 Mark_Ghost_Pragma (N, Ent); 19384 19385 -- Capture the entity of the first Ghost subprogram 19386 -- being processed for error detection purposes. 19387 19388 if Is_Ghost_Entity (Ent) then 19389 if No (Ghost_Id) then 19390 Ghost_Id := Ent; 19391 end if; 19392 19393 -- Otherwise the subprogram is non-Ghost. It is 19394 -- illegal to mix references to Ghost and non-Ghost 19395 -- entities (SPARK RM 6.9). 19396 19397 elsif Present (Ghost_Id) 19398 and then not Ghost_Error_Posted 19399 then 19400 Ghost_Error_Posted := True; 19401 19402 Error_Msg_Name_1 := Pname; 19403 Error_Msg_N 19404 ("pragma % cannot mention ghost and " 19405 & "non-ghost subprograms", N); 19406 19407 Error_Msg_Sloc := Sloc (Ghost_Id); 19408 Error_Msg_NE 19409 ("\& # declared as ghost", N, Ghost_Id); 19410 19411 Error_Msg_Sloc := Sloc (Ent); 19412 Error_Msg_NE 19413 ("\& # declared as non-ghost", N, Ent); 19414 end if; 19415 end if; 19416 19417 Ent := Homonym (Ent); 19418 exit when No (Ent) 19419 or else Scope (Ent) /= Current_Scope; 19420 end loop; 19421 end if; 19422 19423 -- All other cases are illegal 19424 19425 when others => 19426 Error_Pragma_Arg 19427 ("pragma% applies only to objects, subprograms, and types", 19428 Arg1); 19429 end case; 19430 end Linker_Section; 19431 19432 ---------- 19433 -- List -- 19434 ---------- 19435 19436 -- pragma List (On | Off) 19437 19438 -- There is nothing to do here, since we did all the processing for 19439 -- this pragma in Par.Prag (so that it works properly even in syntax 19440 -- only mode). 19441 19442 when Pragma_List => 19443 null; 19444 19445 --------------- 19446 -- Lock_Free -- 19447 --------------- 19448 19449 -- pragma Lock_Free [(Boolean_EXPRESSION)]; 19450 19451 when Pragma_Lock_Free => Lock_Free : declare 19452 P : constant Node_Id := Parent (N); 19453 Arg : Node_Id; 19454 Ent : Entity_Id; 19455 Val : Boolean; 19456 19457 begin 19458 Check_No_Identifiers; 19459 Check_At_Most_N_Arguments (1); 19460 19461 -- Protected definition case 19462 19463 if Nkind (P) = N_Protected_Definition then 19464 Ent := Defining_Identifier (Parent (P)); 19465 19466 -- One argument 19467 19468 if Arg_Count = 1 then 19469 Arg := Get_Pragma_Arg (Arg1); 19470 Val := Is_True (Static_Boolean (Arg)); 19471 19472 -- No arguments (expression is considered to be True) 19473 19474 else 19475 Val := True; 19476 end if; 19477 19478 -- Check duplicate pragma before we chain the pragma in the Rep 19479 -- Item chain of Ent. 19480 19481 Check_Duplicate_Pragma (Ent); 19482 Record_Rep_Item (Ent, N); 19483 Set_Uses_Lock_Free (Ent, Val); 19484 19485 -- Anything else is incorrect placement 19486 19487 else 19488 Pragma_Misplaced; 19489 end if; 19490 end Lock_Free; 19491 19492 -------------------- 19493 -- Locking_Policy -- 19494 -------------------- 19495 19496 -- pragma Locking_Policy (policy_IDENTIFIER); 19497 19498 when Pragma_Locking_Policy => declare 19499 subtype LP_Range is Name_Id 19500 range First_Locking_Policy_Name .. Last_Locking_Policy_Name; 19501 LP_Val : LP_Range; 19502 LP : Character; 19503 19504 begin 19505 Check_Ada_83_Warning; 19506 Check_Arg_Count (1); 19507 Check_No_Identifiers; 19508 Check_Arg_Is_Locking_Policy (Arg1); 19509 Check_Valid_Configuration_Pragma; 19510 LP_Val := Chars (Get_Pragma_Arg (Arg1)); 19511 19512 case LP_Val is 19513 when Name_Ceiling_Locking => LP := 'C'; 19514 when Name_Concurrent_Readers_Locking => LP := 'R'; 19515 when Name_Inheritance_Locking => LP := 'I'; 19516 end case; 19517 19518 if Locking_Policy /= ' ' 19519 and then Locking_Policy /= LP 19520 then 19521 Error_Msg_Sloc := Locking_Policy_Sloc; 19522 Error_Pragma ("locking policy incompatible with policy#"); 19523 19524 -- Set new policy, but always preserve System_Location since we 19525 -- like the error message with the run time name. 19526 19527 else 19528 Locking_Policy := LP; 19529 19530 if Locking_Policy_Sloc /= System_Location then 19531 Locking_Policy_Sloc := Loc; 19532 end if; 19533 end if; 19534 end; 19535 19536 ------------------- 19537 -- Loop_Optimize -- 19538 ------------------- 19539 19540 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } ); 19541 19542 -- OPTIMIZATION_HINT ::= 19543 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector 19544 19545 when Pragma_Loop_Optimize => Loop_Optimize : declare 19546 Hint : Node_Id; 19547 19548 begin 19549 GNAT_Pragma; 19550 Check_At_Least_N_Arguments (1); 19551 Check_No_Identifiers; 19552 19553 Hint := First (Pragma_Argument_Associations (N)); 19554 while Present (Hint) loop 19555 Check_Arg_Is_One_Of (Hint, Name_Ivdep, 19556 Name_No_Unroll, 19557 Name_Unroll, 19558 Name_No_Vector, 19559 Name_Vector); 19560 Next (Hint); 19561 end loop; 19562 19563 Check_Loop_Pragma_Placement; 19564 end Loop_Optimize; 19565 19566 ------------------ 19567 -- Loop_Variant -- 19568 ------------------ 19569 19570 -- pragma Loop_Variant 19571 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } ); 19572 19573 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION 19574 19575 -- CHANGE_DIRECTION ::= Increases | Decreases 19576 19577 when Pragma_Loop_Variant => Loop_Variant : declare 19578 Variant : Node_Id; 19579 19580 begin 19581 GNAT_Pragma; 19582 Check_At_Least_N_Arguments (1); 19583 Check_Loop_Pragma_Placement; 19584 19585 -- Process all increasing / decreasing expressions 19586 19587 Variant := First (Pragma_Argument_Associations (N)); 19588 while Present (Variant) loop 19589 if Chars (Variant) = No_Name then 19590 Error_Pragma_Arg_Ident ("expect name `Increases`", Variant); 19591 19592 elsif not Nam_In (Chars (Variant), Name_Decreases, 19593 Name_Increases) 19594 then 19595 declare 19596 Name : String := Get_Name_String (Chars (Variant)); 19597 19598 begin 19599 -- It is a common mistake to write "Increasing" for 19600 -- "Increases" or "Decreasing" for "Decreases". Recognize 19601 -- specially names starting with "incr" or "decr" to 19602 -- suggest the corresponding name. 19603 19604 System.Case_Util.To_Lower (Name); 19605 19606 if Name'Length >= 4 19607 and then Name (1 .. 4) = "incr" 19608 then 19609 Error_Pragma_Arg_Ident 19610 ("expect name `Increases`", Variant); 19611 19612 elsif Name'Length >= 4 19613 and then Name (1 .. 4) = "decr" 19614 then 19615 Error_Pragma_Arg_Ident 19616 ("expect name `Decreases`", Variant); 19617 19618 else 19619 Error_Pragma_Arg_Ident 19620 ("expect name `Increases` or `Decreases`", Variant); 19621 end if; 19622 end; 19623 end if; 19624 19625 Preanalyze_Assert_Expression 19626 (Expression (Variant), Any_Discrete); 19627 19628 Next (Variant); 19629 end loop; 19630 end Loop_Variant; 19631 19632 ----------------------- 19633 -- Machine_Attribute -- 19634 ----------------------- 19635 19636 -- pragma Machine_Attribute ( 19637 -- [Entity =>] LOCAL_NAME, 19638 -- [Attribute_Name =>] static_string_EXPRESSION 19639 -- [, [Info =>] static_EXPRESSION {, static_EXPRESSION}] ); 19640 19641 when Pragma_Machine_Attribute => Machine_Attribute : declare 19642 Arg : Node_Id; 19643 Def_Id : Entity_Id; 19644 19645 begin 19646 GNAT_Pragma; 19647 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info)); 19648 19649 if Arg_Count >= 3 then 19650 Check_Optional_Identifier (Arg3, Name_Info); 19651 Arg := Arg3; 19652 while Present (Arg) loop 19653 Check_Arg_Is_OK_Static_Expression (Arg); 19654 Arg := Next (Arg); 19655 end loop; 19656 else 19657 Check_Arg_Count (2); 19658 end if; 19659 19660 Check_Optional_Identifier (Arg1, Name_Entity); 19661 Check_Optional_Identifier (Arg2, Name_Attribute_Name); 19662 Check_Arg_Is_Local_Name (Arg1); 19663 Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); 19664 Def_Id := Entity (Get_Pragma_Arg (Arg1)); 19665 19666 if Is_Access_Type (Def_Id) then 19667 Def_Id := Designated_Type (Def_Id); 19668 end if; 19669 19670 if Rep_Item_Too_Early (Def_Id, N) then 19671 return; 19672 end if; 19673 19674 Def_Id := Underlying_Type (Def_Id); 19675 19676 -- The only processing required is to link this item on to the 19677 -- list of rep items for the given entity. This is accomplished 19678 -- by the call to Rep_Item_Too_Late (when no error is detected 19679 -- and False is returned). 19680 19681 if Rep_Item_Too_Late (Def_Id, N) then 19682 return; 19683 else 19684 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 19685 end if; 19686 end Machine_Attribute; 19687 19688 ---------- 19689 -- Main -- 19690 ---------- 19691 19692 -- pragma Main 19693 -- (MAIN_OPTION [, MAIN_OPTION]); 19694 19695 -- MAIN_OPTION ::= 19696 -- [STACK_SIZE =>] static_integer_EXPRESSION 19697 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION 19698 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION 19699 19700 when Pragma_Main => Main : declare 19701 Args : Args_List (1 .. 3); 19702 Names : constant Name_List (1 .. 3) := ( 19703 Name_Stack_Size, 19704 Name_Task_Stack_Size_Default, 19705 Name_Time_Slicing_Enabled); 19706 19707 Nod : Node_Id; 19708 19709 begin 19710 GNAT_Pragma; 19711 Gather_Associations (Names, Args); 19712 19713 for J in 1 .. 2 loop 19714 if Present (Args (J)) then 19715 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); 19716 end if; 19717 end loop; 19718 19719 if Present (Args (3)) then 19720 Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean); 19721 end if; 19722 19723 Nod := Next (N); 19724 while Present (Nod) loop 19725 if Nkind (Nod) = N_Pragma 19726 and then Pragma_Name (Nod) = Name_Main 19727 then 19728 Error_Msg_Name_1 := Pname; 19729 Error_Msg_N ("duplicate pragma% not permitted", Nod); 19730 end if; 19731 19732 Next (Nod); 19733 end loop; 19734 end Main; 19735 19736 ------------------ 19737 -- Main_Storage -- 19738 ------------------ 19739 19740 -- pragma Main_Storage 19741 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); 19742 19743 -- MAIN_STORAGE_OPTION ::= 19744 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION 19745 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION 19746 19747 when Pragma_Main_Storage => Main_Storage : declare 19748 Args : Args_List (1 .. 2); 19749 Names : constant Name_List (1 .. 2) := ( 19750 Name_Working_Storage, 19751 Name_Top_Guard); 19752 19753 Nod : Node_Id; 19754 19755 begin 19756 GNAT_Pragma; 19757 Gather_Associations (Names, Args); 19758 19759 for J in 1 .. 2 loop 19760 if Present (Args (J)) then 19761 Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); 19762 end if; 19763 end loop; 19764 19765 Check_In_Main_Program; 19766 19767 Nod := Next (N); 19768 while Present (Nod) loop 19769 if Nkind (Nod) = N_Pragma 19770 and then Pragma_Name (Nod) = Name_Main_Storage 19771 then 19772 Error_Msg_Name_1 := Pname; 19773 Error_Msg_N ("duplicate pragma% not permitted", Nod); 19774 end if; 19775 19776 Next (Nod); 19777 end loop; 19778 end Main_Storage; 19779 19780 ---------------------------- 19781 -- Max_Entry_Queue_Length -- 19782 ---------------------------- 19783 19784 -- pragma Max_Entry_Queue_Length (static_integer_EXPRESSION); 19785 19786 -- This processing is shared by Pragma_Max_Entry_Queue_Depth and 19787 -- Pragma_Max_Queue_Length. 19788 19789 when Pragma_Max_Entry_Queue_Length 19790 | Pragma_Max_Entry_Queue_Depth 19791 | Pragma_Max_Queue_Length 19792 => 19793 Max_Entry_Queue_Length : declare 19794 Arg : Node_Id; 19795 Entry_Decl : Node_Id; 19796 Entry_Id : Entity_Id; 19797 Val : Uint; 19798 19799 begin 19800 if Prag_Id = Pragma_Max_Entry_Queue_Depth 19801 or else Prag_Id = Pragma_Max_Queue_Length 19802 then 19803 GNAT_Pragma; 19804 end if; 19805 19806 Check_Arg_Count (1); 19807 19808 Entry_Decl := 19809 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 19810 19811 -- Entry declaration 19812 19813 if Nkind (Entry_Decl) = N_Entry_Declaration then 19814 19815 -- Entry illegally within a task 19816 19817 if Nkind (Parent (N)) = N_Task_Definition then 19818 Error_Pragma ("pragma % cannot apply to task entries"); 19819 return; 19820 end if; 19821 19822 Entry_Id := Defining_Entity (Entry_Decl); 19823 19824 -- Otherwise the pragma is associated with an illegal construct 19825 19826 else 19827 Error_Pragma ("pragma % must apply to a protected entry"); 19828 return; 19829 end if; 19830 19831 -- Mark the pragma as Ghost if the related subprogram is also 19832 -- Ghost. This also ensures that any expansion performed further 19833 -- below will produce Ghost nodes. 19834 19835 Mark_Ghost_Pragma (N, Entry_Id); 19836 19837 -- Analyze the Integer expression 19838 19839 Arg := Get_Pragma_Arg (Arg1); 19840 Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer); 19841 19842 Val := Expr_Value (Arg); 19843 19844 if Val < -1 then 19845 Error_Pragma_Arg 19846 ("argument for pragma% cannot be less than -1", Arg1); 19847 19848 elsif not UI_Is_In_Int_Range (Val) then 19849 Error_Pragma_Arg 19850 ("argument for pragma% out of range of Integer", Arg1); 19851 19852 end if; 19853 19854 Record_Rep_Item (Entry_Id, N); 19855 end Max_Entry_Queue_Length; 19856 19857 ----------------- 19858 -- Memory_Size -- 19859 ----------------- 19860 19861 -- pragma Memory_Size (NUMERIC_LITERAL) 19862 19863 when Pragma_Memory_Size => 19864 GNAT_Pragma; 19865 19866 -- Memory size is simply ignored 19867 19868 Check_No_Identifiers; 19869 Check_Arg_Count (1); 19870 Check_Arg_Is_Integer_Literal (Arg1); 19871 19872 ------------- 19873 -- No_Body -- 19874 ------------- 19875 19876 -- pragma No_Body; 19877 19878 -- The only correct use of this pragma is on its own in a file, in 19879 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body 19880 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to 19881 -- check for a file containing nothing but a No_Body pragma). If we 19882 -- attempt to process it during normal semantics processing, it means 19883 -- it was misplaced. 19884 19885 when Pragma_No_Body => 19886 GNAT_Pragma; 19887 Pragma_Misplaced; 19888 19889 ----------------------------- 19890 -- No_Elaboration_Code_All -- 19891 ----------------------------- 19892 19893 -- pragma No_Elaboration_Code_All; 19894 19895 when Pragma_No_Elaboration_Code_All => 19896 GNAT_Pragma; 19897 Check_Valid_Library_Unit_Pragma; 19898 19899 if Nkind (N) = N_Null_Statement then 19900 return; 19901 end if; 19902 19903 -- Must appear for a spec or generic spec 19904 19905 if not Nkind_In (Unit (Cunit (Current_Sem_Unit)), 19906 N_Generic_Package_Declaration, 19907 N_Generic_Subprogram_Declaration, 19908 N_Package_Declaration, 19909 N_Subprogram_Declaration) 19910 then 19911 Error_Pragma 19912 (Fix_Error 19913 ("pragma% can only occur for package " 19914 & "or subprogram spec")); 19915 end if; 19916 19917 -- Set flag in unit table 19918 19919 Set_No_Elab_Code_All (Current_Sem_Unit); 19920 19921 -- Set restriction No_Elaboration_Code if this is the main unit 19922 19923 if Current_Sem_Unit = Main_Unit then 19924 Set_Restriction (No_Elaboration_Code, N); 19925 end if; 19926 19927 -- If we are in the main unit or in an extended main source unit, 19928 -- then we also add it to the configuration restrictions so that 19929 -- it will apply to all units in the extended main source. 19930 19931 if Current_Sem_Unit = Main_Unit 19932 or else In_Extended_Main_Source_Unit (N) 19933 then 19934 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 19935 end if; 19936 19937 -- If in main extended unit, activate transitive with test 19938 19939 if In_Extended_Main_Source_Unit (N) then 19940 Opt.No_Elab_Code_All_Pragma := N; 19941 end if; 19942 19943 ----------------------------- 19944 -- No_Component_Reordering -- 19945 ----------------------------- 19946 19947 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)]; 19948 19949 when Pragma_No_Component_Reordering => No_Comp_Reordering : declare 19950 E : Entity_Id; 19951 E_Id : Node_Id; 19952 19953 begin 19954 GNAT_Pragma; 19955 Check_At_Most_N_Arguments (1); 19956 19957 if Arg_Count = 0 then 19958 Check_Valid_Configuration_Pragma; 19959 Opt.No_Component_Reordering := True; 19960 19961 else 19962 Check_Optional_Identifier (Arg2, Name_Entity); 19963 Check_Arg_Is_Local_Name (Arg1); 19964 E_Id := Get_Pragma_Arg (Arg1); 19965 19966 if Etype (E_Id) = Any_Type then 19967 return; 19968 end if; 19969 19970 E := Entity (E_Id); 19971 19972 if not Is_Record_Type (E) then 19973 Error_Pragma_Arg ("pragma% requires record type", Arg1); 19974 end if; 19975 19976 Set_No_Reordering (Base_Type (E)); 19977 end if; 19978 end No_Comp_Reordering; 19979 19980 -------------------------- 19981 -- No_Heap_Finalization -- 19982 -------------------------- 19983 19984 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ]; 19985 19986 when Pragma_No_Heap_Finalization => No_Heap_Finalization : declare 19987 Context : constant Node_Id := Parent (N); 19988 Typ_Arg : constant Node_Id := Get_Pragma_Arg (Arg1); 19989 Prev : Node_Id; 19990 Typ : Entity_Id; 19991 19992 begin 19993 GNAT_Pragma; 19994 Check_No_Identifiers; 19995 19996 -- The pragma appears in a configuration file 19997 19998 if No (Context) then 19999 Check_Arg_Count (0); 20000 Check_Valid_Configuration_Pragma; 20001 20002 -- Detect a duplicate pragma 20003 20004 if Present (No_Heap_Finalization_Pragma) then 20005 Duplication_Error 20006 (Prag => N, 20007 Prev => No_Heap_Finalization_Pragma); 20008 raise Pragma_Exit; 20009 end if; 20010 20011 No_Heap_Finalization_Pragma := N; 20012 20013 -- Otherwise the pragma should be associated with a library-level 20014 -- named access-to-object type. 20015 20016 else 20017 Check_Arg_Count (1); 20018 Check_Arg_Is_Local_Name (Arg1); 20019 20020 Find_Type (Typ_Arg); 20021 Typ := Entity (Typ_Arg); 20022 20023 -- The type being subjected to the pragma is erroneous 20024 20025 if Typ = Any_Type then 20026 Error_Pragma ("cannot find type referenced by pragma %"); 20027 20028 -- The pragma is applied to an incomplete or generic formal 20029 -- type way too early. 20030 20031 elsif Rep_Item_Too_Early (Typ, N) then 20032 return; 20033 20034 else 20035 Typ := Underlying_Type (Typ); 20036 end if; 20037 20038 -- The pragma must apply to an access-to-object type 20039 20040 if Ekind_In (Typ, E_Access_Type, E_General_Access_Type) then 20041 null; 20042 20043 -- Give a detailed error message on all other access type kinds 20044 20045 elsif Ekind (Typ) = E_Access_Protected_Subprogram_Type then 20046 Error_Pragma 20047 ("pragma % cannot apply to access protected subprogram " 20048 & "type"); 20049 20050 elsif Ekind (Typ) = E_Access_Subprogram_Type then 20051 Error_Pragma 20052 ("pragma % cannot apply to access subprogram type"); 20053 20054 elsif Is_Anonymous_Access_Type (Typ) then 20055 Error_Pragma 20056 ("pragma % cannot apply to anonymous access type"); 20057 20058 -- Give a general error message in case the pragma applies to a 20059 -- non-access type. 20060 20061 else 20062 Error_Pragma 20063 ("pragma % must apply to library level access type"); 20064 end if; 20065 20066 -- At this point the argument denotes an access-to-object type. 20067 -- Ensure that the type is declared at the library level. 20068 20069 if Is_Library_Level_Entity (Typ) then 20070 null; 20071 20072 -- Quietly ignore an access-to-object type originally declared 20073 -- at the library level within a generic, but instantiated at 20074 -- a non-library level. As a result the access-to-object type 20075 -- "loses" its No_Heap_Finalization property. 20076 20077 elsif In_Instance then 20078 raise Pragma_Exit; 20079 20080 else 20081 Error_Pragma 20082 ("pragma % must apply to library level access type"); 20083 end if; 20084 20085 -- Detect a duplicate pragma 20086 20087 if Present (No_Heap_Finalization_Pragma) then 20088 Duplication_Error 20089 (Prag => N, 20090 Prev => No_Heap_Finalization_Pragma); 20091 raise Pragma_Exit; 20092 20093 else 20094 Prev := Get_Pragma (Typ, Pragma_No_Heap_Finalization); 20095 20096 if Present (Prev) then 20097 Duplication_Error 20098 (Prag => N, 20099 Prev => Prev); 20100 raise Pragma_Exit; 20101 end if; 20102 end if; 20103 20104 Record_Rep_Item (Typ, N); 20105 end if; 20106 end No_Heap_Finalization; 20107 20108 --------------- 20109 -- No_Inline -- 20110 --------------- 20111 20112 -- pragma No_Inline ( NAME {, NAME} ); 20113 20114 when Pragma_No_Inline => 20115 GNAT_Pragma; 20116 Process_Inline (Suppressed); 20117 20118 --------------- 20119 -- No_Return -- 20120 --------------- 20121 20122 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name}); 20123 20124 when Pragma_No_Return => No_Return : declare 20125 Arg : Node_Id; 20126 E : Entity_Id; 20127 Found : Boolean; 20128 Id : Node_Id; 20129 20130 Ghost_Error_Posted : Boolean := False; 20131 -- Flag set when an error concerning the illegal mix of Ghost and 20132 -- non-Ghost subprograms is emitted. 20133 20134 Ghost_Id : Entity_Id := Empty; 20135 -- The entity of the first Ghost procedure encountered while 20136 -- processing the arguments of the pragma. 20137 20138 begin 20139 Ada_2005_Pragma; 20140 Check_At_Least_N_Arguments (1); 20141 20142 -- Loop through arguments of pragma 20143 20144 Arg := Arg1; 20145 while Present (Arg) loop 20146 Check_Arg_Is_Local_Name (Arg); 20147 Id := Get_Pragma_Arg (Arg); 20148 Analyze (Id); 20149 20150 if not Is_Entity_Name (Id) then 20151 Error_Pragma_Arg ("entity name required", Arg); 20152 end if; 20153 20154 if Etype (Id) = Any_Type then 20155 raise Pragma_Exit; 20156 end if; 20157 20158 -- Loop to find matching procedures 20159 20160 E := Entity (Id); 20161 20162 Found := False; 20163 while Present (E) 20164 and then Scope (E) = Current_Scope 20165 loop 20166 if Ekind_In (E, E_Generic_Procedure, E_Procedure) then 20167 20168 -- Check that the pragma is not applied to a body. 20169 -- First check the specless body case, to give a 20170 -- different error message. These checks do not apply 20171 -- if Relaxed_RM_Semantics, to accommodate other Ada 20172 -- compilers. Disable these checks under -gnatd.J. 20173 20174 if not Debug_Flag_Dot_JJ then 20175 if Nkind (Parent (Declaration_Node (E))) = 20176 N_Subprogram_Body 20177 and then not Relaxed_RM_Semantics 20178 then 20179 Error_Pragma 20180 ("pragma% requires separate spec and must come " 20181 & "before body"); 20182 end if; 20183 20184 -- Now the "specful" body case 20185 20186 if Rep_Item_Too_Late (E, N) then 20187 raise Pragma_Exit; 20188 end if; 20189 end if; 20190 20191 Set_No_Return (E); 20192 20193 -- A pragma that applies to a Ghost entity becomes Ghost 20194 -- for the purposes of legality checks and removal of 20195 -- ignored Ghost code. 20196 20197 Mark_Ghost_Pragma (N, E); 20198 20199 -- Capture the entity of the first Ghost procedure being 20200 -- processed for error detection purposes. 20201 20202 if Is_Ghost_Entity (E) then 20203 if No (Ghost_Id) then 20204 Ghost_Id := E; 20205 end if; 20206 20207 -- Otherwise the subprogram is non-Ghost. It is illegal 20208 -- to mix references to Ghost and non-Ghost entities 20209 -- (SPARK RM 6.9). 20210 20211 elsif Present (Ghost_Id) 20212 and then not Ghost_Error_Posted 20213 then 20214 Ghost_Error_Posted := True; 20215 20216 Error_Msg_Name_1 := Pname; 20217 Error_Msg_N 20218 ("pragma % cannot mention ghost and non-ghost " 20219 & "procedures", N); 20220 20221 Error_Msg_Sloc := Sloc (Ghost_Id); 20222 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 20223 20224 Error_Msg_Sloc := Sloc (E); 20225 Error_Msg_NE ("\& # declared as non-ghost", N, E); 20226 end if; 20227 20228 -- Set flag on any alias as well 20229 20230 if Is_Overloadable (E) and then Present (Alias (E)) then 20231 Set_No_Return (Alias (E)); 20232 end if; 20233 20234 Found := True; 20235 end if; 20236 20237 exit when From_Aspect_Specification (N); 20238 E := Homonym (E); 20239 end loop; 20240 20241 -- If entity in not in current scope it may be the enclosing 20242 -- suprogram body to which the aspect applies. 20243 20244 if not Found then 20245 if Entity (Id) = Current_Scope 20246 and then From_Aspect_Specification (N) 20247 then 20248 Set_No_Return (Entity (Id)); 20249 else 20250 Error_Pragma_Arg ("no procedure& found for pragma%", Arg); 20251 end if; 20252 end if; 20253 20254 Next (Arg); 20255 end loop; 20256 end No_Return; 20257 20258 ----------------- 20259 -- No_Run_Time -- 20260 ----------------- 20261 20262 -- pragma No_Run_Time; 20263 20264 -- Note: this pragma is retained for backwards compatibility. See 20265 -- body of Rtsfind for full details on its handling. 20266 20267 when Pragma_No_Run_Time => 20268 GNAT_Pragma; 20269 Check_Valid_Configuration_Pragma; 20270 Check_Arg_Count (0); 20271 20272 -- Remove backward compatibility if Build_Type is FSF or GPL and 20273 -- generate a warning. 20274 20275 declare 20276 Ignore : constant Boolean := Build_Type in FSF .. GPL; 20277 begin 20278 if Ignore then 20279 Error_Pragma ("pragma% is ignored, has no effect??"); 20280 else 20281 No_Run_Time_Mode := True; 20282 Configurable_Run_Time_Mode := True; 20283 20284 -- Set Duration to 32 bits if word size is 32 20285 20286 if Ttypes.System_Word_Size = 32 then 20287 Duration_32_Bits_On_Target := True; 20288 end if; 20289 20290 -- Set appropriate restrictions 20291 20292 Set_Restriction (No_Finalization, N); 20293 Set_Restriction (No_Exception_Handlers, N); 20294 Set_Restriction (Max_Tasks, N, 0); 20295 Set_Restriction (No_Tasking, N); 20296 end if; 20297 end; 20298 20299 ----------------------- 20300 -- No_Tagged_Streams -- 20301 ----------------------- 20302 20303 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)]; 20304 20305 when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare 20306 E : Entity_Id; 20307 E_Id : Node_Id; 20308 20309 begin 20310 GNAT_Pragma; 20311 Check_At_Most_N_Arguments (1); 20312 20313 -- One argument case 20314 20315 if Arg_Count = 1 then 20316 Check_Optional_Identifier (Arg1, Name_Entity); 20317 Check_Arg_Is_Local_Name (Arg1); 20318 E_Id := Get_Pragma_Arg (Arg1); 20319 20320 if Etype (E_Id) = Any_Type then 20321 return; 20322 end if; 20323 20324 E := Entity (E_Id); 20325 20326 Check_Duplicate_Pragma (E); 20327 20328 if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then 20329 Error_Pragma_Arg 20330 ("argument for pragma% must be root tagged type", Arg1); 20331 end if; 20332 20333 if Rep_Item_Too_Early (E, N) 20334 or else 20335 Rep_Item_Too_Late (E, N) 20336 then 20337 return; 20338 else 20339 Set_No_Tagged_Streams_Pragma (E, N); 20340 end if; 20341 20342 -- Zero argument case 20343 20344 else 20345 Check_Is_In_Decl_Part_Or_Package_Spec; 20346 No_Tagged_Streams := N; 20347 end if; 20348 end No_Tagged_Strms; 20349 20350 ------------------------ 20351 -- No_Strict_Aliasing -- 20352 ------------------------ 20353 20354 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; 20355 20356 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare 20357 E : Entity_Id; 20358 E_Id : Node_Id; 20359 20360 begin 20361 GNAT_Pragma; 20362 Check_At_Most_N_Arguments (1); 20363 20364 if Arg_Count = 0 then 20365 Check_Valid_Configuration_Pragma; 20366 Opt.No_Strict_Aliasing := True; 20367 20368 else 20369 Check_Optional_Identifier (Arg2, Name_Entity); 20370 Check_Arg_Is_Local_Name (Arg1); 20371 E_Id := Get_Pragma_Arg (Arg1); 20372 20373 if Etype (E_Id) = Any_Type then 20374 return; 20375 end if; 20376 20377 E := Entity (E_Id); 20378 20379 if not Is_Access_Type (E) then 20380 Error_Pragma_Arg ("pragma% requires access type", Arg1); 20381 end if; 20382 20383 Set_No_Strict_Aliasing (Base_Type (E)); 20384 end if; 20385 end No_Strict_Aliasing; 20386 20387 ----------------------- 20388 -- Normalize_Scalars -- 20389 ----------------------- 20390 20391 -- pragma Normalize_Scalars; 20392 20393 when Pragma_Normalize_Scalars => 20394 Check_Ada_83_Warning; 20395 Check_Arg_Count (0); 20396 Check_Valid_Configuration_Pragma; 20397 20398 -- Normalize_Scalars creates false positives in CodePeer, and 20399 -- incorrect negative results in GNATprove mode, so ignore this 20400 -- pragma in these modes. 20401 20402 if not (CodePeer_Mode or GNATprove_Mode) then 20403 Normalize_Scalars := True; 20404 Init_Or_Norm_Scalars := True; 20405 end if; 20406 20407 ----------------- 20408 -- Obsolescent -- 20409 ----------------- 20410 20411 -- pragma Obsolescent; 20412 20413 -- pragma Obsolescent ( 20414 -- [Message =>] static_string_EXPRESSION 20415 -- [,[Version =>] Ada_05]]); 20416 20417 -- pragma Obsolescent ( 20418 -- [Entity =>] NAME 20419 -- [,[Message =>] static_string_EXPRESSION 20420 -- [,[Version =>] Ada_05]] ); 20421 20422 when Pragma_Obsolescent => Obsolescent : declare 20423 Decl : Node_Id; 20424 Ename : Node_Id; 20425 20426 procedure Set_Obsolescent (E : Entity_Id); 20427 -- Given an entity Ent, mark it as obsolescent if appropriate 20428 20429 --------------------- 20430 -- Set_Obsolescent -- 20431 --------------------- 20432 20433 procedure Set_Obsolescent (E : Entity_Id) is 20434 Active : Boolean; 20435 Ent : Entity_Id; 20436 S : String_Id; 20437 20438 begin 20439 Active := True; 20440 Ent := E; 20441 20442 -- A pragma that applies to a Ghost entity becomes Ghost for 20443 -- the purposes of legality checks and removal of ignored Ghost 20444 -- code. 20445 20446 Mark_Ghost_Pragma (N, E); 20447 20448 -- Entity name was given 20449 20450 if Present (Ename) then 20451 20452 -- If entity name matches, we are fine. Save entity in 20453 -- pragma argument, for ASIS use. 20454 20455 if Chars (Ename) = Chars (Ent) then 20456 Set_Entity (Ename, Ent); 20457 Generate_Reference (Ent, Ename); 20458 20459 -- If entity name does not match, only possibility is an 20460 -- enumeration literal from an enumeration type declaration. 20461 20462 elsif Ekind (Ent) /= E_Enumeration_Type then 20463 Error_Pragma 20464 ("pragma % entity name does not match declaration"); 20465 20466 else 20467 Ent := First_Literal (E); 20468 loop 20469 if No (Ent) then 20470 Error_Pragma 20471 ("pragma % entity name does not match any " 20472 & "enumeration literal"); 20473 20474 elsif Chars (Ent) = Chars (Ename) then 20475 Set_Entity (Ename, Ent); 20476 Generate_Reference (Ent, Ename); 20477 exit; 20478 20479 else 20480 Ent := Next_Literal (Ent); 20481 end if; 20482 end loop; 20483 end if; 20484 end if; 20485 20486 -- Ent points to entity to be marked 20487 20488 if Arg_Count >= 1 then 20489 20490 -- Deal with static string argument 20491 20492 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 20493 S := Strval (Get_Pragma_Arg (Arg1)); 20494 20495 for J in 1 .. String_Length (S) loop 20496 if not In_Character_Range (Get_String_Char (S, J)) then 20497 Error_Pragma_Arg 20498 ("pragma% argument does not allow wide characters", 20499 Arg1); 20500 end if; 20501 end loop; 20502 20503 Obsolescent_Warnings.Append 20504 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1)))); 20505 20506 -- Check for Ada_05 parameter 20507 20508 if Arg_Count /= 1 then 20509 Check_Arg_Count (2); 20510 20511 declare 20512 Argx : constant Node_Id := Get_Pragma_Arg (Arg2); 20513 20514 begin 20515 Check_Arg_Is_Identifier (Argx); 20516 20517 if Chars (Argx) /= Name_Ada_05 then 20518 Error_Msg_Name_2 := Name_Ada_05; 20519 Error_Pragma_Arg 20520 ("only allowed argument for pragma% is %", Argx); 20521 end if; 20522 20523 if Ada_Version_Explicit < Ada_2005 20524 or else not Warn_On_Ada_2005_Compatibility 20525 then 20526 Active := False; 20527 end if; 20528 end; 20529 end if; 20530 end if; 20531 20532 -- Set flag if pragma active 20533 20534 if Active then 20535 Set_Is_Obsolescent (Ent); 20536 end if; 20537 20538 return; 20539 end Set_Obsolescent; 20540 20541 -- Start of processing for pragma Obsolescent 20542 20543 begin 20544 GNAT_Pragma; 20545 20546 Check_At_Most_N_Arguments (3); 20547 20548 -- See if first argument specifies an entity name 20549 20550 if Arg_Count >= 1 20551 and then 20552 (Chars (Arg1) = Name_Entity 20553 or else 20554 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, 20555 N_Identifier, 20556 N_Operator_Symbol)) 20557 then 20558 Ename := Get_Pragma_Arg (Arg1); 20559 20560 -- Eliminate first argument, so we can share processing 20561 20562 Arg1 := Arg2; 20563 Arg2 := Arg3; 20564 Arg_Count := Arg_Count - 1; 20565 20566 -- No Entity name argument given 20567 20568 else 20569 Ename := Empty; 20570 end if; 20571 20572 if Arg_Count >= 1 then 20573 Check_Optional_Identifier (Arg1, Name_Message); 20574 20575 if Arg_Count = 2 then 20576 Check_Optional_Identifier (Arg2, Name_Version); 20577 end if; 20578 end if; 20579 20580 -- Get immediately preceding declaration 20581 20582 Decl := Prev (N); 20583 while Present (Decl) and then Nkind (Decl) = N_Pragma loop 20584 Prev (Decl); 20585 end loop; 20586 20587 -- Cases where we do not follow anything other than another pragma 20588 20589 if No (Decl) then 20590 20591 -- First case: library level compilation unit declaration with 20592 -- the pragma immediately following the declaration. 20593 20594 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 20595 Set_Obsolescent 20596 (Defining_Entity (Unit (Parent (Parent (N))))); 20597 return; 20598 20599 -- Case 2: library unit placement for package 20600 20601 else 20602 declare 20603 Ent : constant Entity_Id := Find_Lib_Unit_Name; 20604 begin 20605 if Is_Package_Or_Generic_Package (Ent) then 20606 Set_Obsolescent (Ent); 20607 return; 20608 end if; 20609 end; 20610 end if; 20611 20612 -- Cases where we must follow a declaration, including an 20613 -- abstract subprogram declaration, which is not in the 20614 -- other node subtypes. 20615 20616 else 20617 if Nkind (Decl) not in N_Declaration 20618 and then Nkind (Decl) not in N_Later_Decl_Item 20619 and then Nkind (Decl) not in N_Generic_Declaration 20620 and then Nkind (Decl) not in N_Renaming_Declaration 20621 and then Nkind (Decl) /= N_Abstract_Subprogram_Declaration 20622 then 20623 Error_Pragma 20624 ("pragma% misplaced, " 20625 & "must immediately follow a declaration"); 20626 20627 else 20628 Set_Obsolescent (Defining_Entity (Decl)); 20629 return; 20630 end if; 20631 end if; 20632 end Obsolescent; 20633 20634 -------------- 20635 -- Optimize -- 20636 -------------- 20637 20638 -- pragma Optimize (Time | Space | Off); 20639 20640 -- The actual check for optimize is done in Gigi. Note that this 20641 -- pragma does not actually change the optimization setting, it 20642 -- simply checks that it is consistent with the pragma. 20643 20644 when Pragma_Optimize => 20645 Check_No_Identifiers; 20646 Check_Arg_Count (1); 20647 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); 20648 20649 ------------------------ 20650 -- Optimize_Alignment -- 20651 ------------------------ 20652 20653 -- pragma Optimize_Alignment (Time | Space | Off); 20654 20655 when Pragma_Optimize_Alignment => Optimize_Alignment : begin 20656 GNAT_Pragma; 20657 Check_No_Identifiers; 20658 Check_Arg_Count (1); 20659 Check_Valid_Configuration_Pragma; 20660 20661 declare 20662 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 20663 begin 20664 case Nam is 20665 when Name_Off => Opt.Optimize_Alignment := 'O'; 20666 when Name_Space => Opt.Optimize_Alignment := 'S'; 20667 when Name_Time => Opt.Optimize_Alignment := 'T'; 20668 20669 when others => 20670 Error_Pragma_Arg ("invalid argument for pragma%", Arg1); 20671 end case; 20672 end; 20673 20674 -- Set indication that mode is set locally. If we are in fact in a 20675 -- configuration pragma file, this setting is harmless since the 20676 -- switch will get reset anyway at the start of each unit. 20677 20678 Optimize_Alignment_Local := True; 20679 end Optimize_Alignment; 20680 20681 ------------- 20682 -- Ordered -- 20683 ------------- 20684 20685 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); 20686 20687 when Pragma_Ordered => Ordered : declare 20688 Assoc : constant Node_Id := Arg1; 20689 Type_Id : Node_Id; 20690 Typ : Entity_Id; 20691 20692 begin 20693 GNAT_Pragma; 20694 Check_No_Identifiers; 20695 Check_Arg_Count (1); 20696 Check_Arg_Is_Local_Name (Arg1); 20697 20698 Type_Id := Get_Pragma_Arg (Assoc); 20699 Find_Type (Type_Id); 20700 Typ := Entity (Type_Id); 20701 20702 if Typ = Any_Type then 20703 return; 20704 else 20705 Typ := Underlying_Type (Typ); 20706 end if; 20707 20708 if not Is_Enumeration_Type (Typ) then 20709 Error_Pragma ("pragma% must specify enumeration type"); 20710 end if; 20711 20712 Check_First_Subtype (Arg1); 20713 Set_Has_Pragma_Ordered (Base_Type (Typ)); 20714 end Ordered; 20715 20716 ------------------- 20717 -- Overflow_Mode -- 20718 ------------------- 20719 20720 -- pragma Overflow_Mode 20721 -- ([General => ] MODE [, [Assertions => ] MODE]); 20722 20723 -- MODE := STRICT | MINIMIZED | ELIMINATED 20724 20725 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64 20726 -- since System.Bignums makes this assumption. This is true of nearly 20727 -- all (all?) targets. 20728 20729 when Pragma_Overflow_Mode => Overflow_Mode : declare 20730 function Get_Overflow_Mode 20731 (Name : Name_Id; 20732 Arg : Node_Id) return Overflow_Mode_Type; 20733 -- Function to process one pragma argument, Arg. If an identifier 20734 -- is present, it must be Name. Mode type is returned if a valid 20735 -- argument exists, otherwise an error is signalled. 20736 20737 ----------------------- 20738 -- Get_Overflow_Mode -- 20739 ----------------------- 20740 20741 function Get_Overflow_Mode 20742 (Name : Name_Id; 20743 Arg : Node_Id) return Overflow_Mode_Type 20744 is 20745 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 20746 20747 begin 20748 Check_Optional_Identifier (Arg, Name); 20749 Check_Arg_Is_Identifier (Argx); 20750 20751 if Chars (Argx) = Name_Strict then 20752 return Strict; 20753 20754 elsif Chars (Argx) = Name_Minimized then 20755 return Minimized; 20756 20757 elsif Chars (Argx) = Name_Eliminated then 20758 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then 20759 Error_Pragma_Arg 20760 ("Eliminated not implemented on this target", Argx); 20761 else 20762 return Eliminated; 20763 end if; 20764 20765 else 20766 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 20767 end if; 20768 end Get_Overflow_Mode; 20769 20770 -- Start of processing for Overflow_Mode 20771 20772 begin 20773 GNAT_Pragma; 20774 Check_At_Least_N_Arguments (1); 20775 Check_At_Most_N_Arguments (2); 20776 20777 -- Process first argument 20778 20779 Scope_Suppress.Overflow_Mode_General := 20780 Get_Overflow_Mode (Name_General, Arg1); 20781 20782 -- Case of only one argument 20783 20784 if Arg_Count = 1 then 20785 Scope_Suppress.Overflow_Mode_Assertions := 20786 Scope_Suppress.Overflow_Mode_General; 20787 20788 -- Case of two arguments present 20789 20790 else 20791 Scope_Suppress.Overflow_Mode_Assertions := 20792 Get_Overflow_Mode (Name_Assertions, Arg2); 20793 end if; 20794 end Overflow_Mode; 20795 20796 -------------------------- 20797 -- Overriding Renamings -- 20798 -------------------------- 20799 20800 -- pragma Overriding_Renamings; 20801 20802 when Pragma_Overriding_Renamings => 20803 GNAT_Pragma; 20804 Check_Arg_Count (0); 20805 Check_Valid_Configuration_Pragma; 20806 Overriding_Renamings := True; 20807 20808 ---------- 20809 -- Pack -- 20810 ---------- 20811 20812 -- pragma Pack (first_subtype_LOCAL_NAME); 20813 20814 when Pragma_Pack => Pack : declare 20815 Assoc : constant Node_Id := Arg1; 20816 Ctyp : Entity_Id; 20817 Ignore : Boolean := False; 20818 Typ : Entity_Id; 20819 Type_Id : Node_Id; 20820 20821 begin 20822 Check_No_Identifiers; 20823 Check_Arg_Count (1); 20824 Check_Arg_Is_Local_Name (Arg1); 20825 Type_Id := Get_Pragma_Arg (Assoc); 20826 20827 if not Is_Entity_Name (Type_Id) 20828 or else not Is_Type (Entity (Type_Id)) 20829 then 20830 Error_Pragma_Arg 20831 ("argument for pragma% must be type or subtype", Arg1); 20832 end if; 20833 20834 Find_Type (Type_Id); 20835 Typ := Entity (Type_Id); 20836 20837 if Typ = Any_Type 20838 or else Rep_Item_Too_Early (Typ, N) 20839 then 20840 return; 20841 else 20842 Typ := Underlying_Type (Typ); 20843 end if; 20844 20845 -- A pragma that applies to a Ghost entity becomes Ghost for the 20846 -- purposes of legality checks and removal of ignored Ghost code. 20847 20848 Mark_Ghost_Pragma (N, Typ); 20849 20850 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then 20851 Error_Pragma ("pragma% must specify array or record type"); 20852 end if; 20853 20854 Check_First_Subtype (Arg1); 20855 Check_Duplicate_Pragma (Typ); 20856 20857 -- Array type 20858 20859 if Is_Array_Type (Typ) then 20860 Ctyp := Component_Type (Typ); 20861 20862 -- Ignore pack that does nothing 20863 20864 if Known_Static_Esize (Ctyp) 20865 and then Known_Static_RM_Size (Ctyp) 20866 and then Esize (Ctyp) = RM_Size (Ctyp) 20867 and then Addressable (Esize (Ctyp)) 20868 then 20869 Ignore := True; 20870 end if; 20871 20872 -- Process OK pragma Pack. Note that if there is a separate 20873 -- component clause present, the Pack will be cancelled. This 20874 -- processing is in Freeze. 20875 20876 if not Rep_Item_Too_Late (Typ, N) then 20877 20878 -- In CodePeer mode, we do not need complex front-end 20879 -- expansions related to pragma Pack, so disable handling 20880 -- of pragma Pack. 20881 20882 if CodePeer_Mode then 20883 null; 20884 20885 -- Normal case where we do the pack action 20886 20887 else 20888 if not Ignore then 20889 Set_Is_Packed (Base_Type (Typ)); 20890 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 20891 end if; 20892 20893 Set_Has_Pragma_Pack (Base_Type (Typ)); 20894 end if; 20895 end if; 20896 20897 -- For record types, the pack is always effective 20898 20899 else pragma Assert (Is_Record_Type (Typ)); 20900 if not Rep_Item_Too_Late (Typ, N) then 20901 Set_Is_Packed (Base_Type (Typ)); 20902 Set_Has_Pragma_Pack (Base_Type (Typ)); 20903 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 20904 end if; 20905 end if; 20906 end Pack; 20907 20908 ---------- 20909 -- Page -- 20910 ---------- 20911 20912 -- pragma Page; 20913 20914 -- There is nothing to do here, since we did all the processing for 20915 -- this pragma in Par.Prag (so that it works properly even in syntax 20916 -- only mode). 20917 20918 when Pragma_Page => 20919 null; 20920 20921 ------------- 20922 -- Part_Of -- 20923 ------------- 20924 20925 -- pragma Part_Of (ABSTRACT_STATE); 20926 20927 -- ABSTRACT_STATE ::= NAME 20928 20929 when Pragma_Part_Of => Part_Of : declare 20930 procedure Propagate_Part_Of 20931 (Pack_Id : Entity_Id; 20932 State_Id : Entity_Id; 20933 Instance : Node_Id); 20934 -- Propagate the Part_Of indicator to all abstract states and 20935 -- objects declared in the visible state space of a package 20936 -- denoted by Pack_Id. State_Id is the encapsulating state. 20937 -- Instance is the package instantiation node. 20938 20939 ----------------------- 20940 -- Propagate_Part_Of -- 20941 ----------------------- 20942 20943 procedure Propagate_Part_Of 20944 (Pack_Id : Entity_Id; 20945 State_Id : Entity_Id; 20946 Instance : Node_Id) 20947 is 20948 Has_Item : Boolean := False; 20949 -- Flag set when the visible state space contains at least one 20950 -- abstract state or variable. 20951 20952 procedure Propagate_Part_Of (Pack_Id : Entity_Id); 20953 -- Propagate the Part_Of indicator to all abstract states and 20954 -- objects declared in the visible state space of a package 20955 -- denoted by Pack_Id. 20956 20957 ----------------------- 20958 -- Propagate_Part_Of -- 20959 ----------------------- 20960 20961 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is 20962 Constits : Elist_Id; 20963 Item_Id : Entity_Id; 20964 20965 begin 20966 -- Traverse the entity chain of the package and set relevant 20967 -- attributes of abstract states and objects declared in the 20968 -- visible state space of the package. 20969 20970 Item_Id := First_Entity (Pack_Id); 20971 while Present (Item_Id) 20972 and then not In_Private_Part (Item_Id) 20973 loop 20974 -- Do not consider internally generated items 20975 20976 if not Comes_From_Source (Item_Id) then 20977 null; 20978 20979 -- Do not consider generic formals or their corresponding 20980 -- actuals because they are not part of a visible state. 20981 -- Note that both entities are marked as hidden. 20982 20983 elsif Is_Hidden (Item_Id) then 20984 null; 20985 20986 -- The Part_Of indicator turns an abstract state or an 20987 -- object into a constituent of the encapsulating state. 20988 -- Note that constants are considered here even though 20989 -- they may not depend on variable input. This check is 20990 -- left to the SPARK prover. 20991 20992 elsif Ekind_In (Item_Id, E_Abstract_State, 20993 E_Constant, 20994 E_Variable) 20995 then 20996 Has_Item := True; 20997 Constits := Part_Of_Constituents (State_Id); 20998 20999 if No (Constits) then 21000 Constits := New_Elmt_List; 21001 Set_Part_Of_Constituents (State_Id, Constits); 21002 end if; 21003 21004 Append_Elmt (Item_Id, Constits); 21005 Set_Encapsulating_State (Item_Id, State_Id); 21006 21007 -- Recursively handle nested packages and instantiations 21008 21009 elsif Ekind (Item_Id) = E_Package then 21010 Propagate_Part_Of (Item_Id); 21011 end if; 21012 21013 Next_Entity (Item_Id); 21014 end loop; 21015 end Propagate_Part_Of; 21016 21017 -- Start of processing for Propagate_Part_Of 21018 21019 begin 21020 Propagate_Part_Of (Pack_Id); 21021 21022 -- Detect a package instantiation that is subject to a Part_Of 21023 -- indicator, but has no visible state. 21024 21025 if not Has_Item then 21026 SPARK_Msg_NE 21027 ("package instantiation & has Part_Of indicator but " 21028 & "lacks visible state", Instance, Pack_Id); 21029 end if; 21030 end Propagate_Part_Of; 21031 21032 -- Local variables 21033 21034 Constits : Elist_Id; 21035 Encap : Node_Id; 21036 Encap_Id : Entity_Id; 21037 Item_Id : Entity_Id; 21038 Legal : Boolean; 21039 Stmt : Node_Id; 21040 21041 -- Start of processing for Part_Of 21042 21043 begin 21044 GNAT_Pragma; 21045 Check_No_Identifiers; 21046 Check_Arg_Count (1); 21047 21048 Stmt := Find_Related_Context (N, Do_Checks => True); 21049 21050 -- Object declaration 21051 21052 if Nkind (Stmt) = N_Object_Declaration then 21053 null; 21054 21055 -- Package instantiation 21056 21057 elsif Nkind (Stmt) = N_Package_Instantiation then 21058 null; 21059 21060 -- Single concurrent type declaration 21061 21062 elsif Is_Single_Concurrent_Type_Declaration (Stmt) then 21063 null; 21064 21065 -- Otherwise the pragma is associated with an illegal construct 21066 21067 else 21068 Pragma_Misplaced; 21069 return; 21070 end if; 21071 21072 -- Extract the entity of the related object declaration or package 21073 -- instantiation. In the case of the instantiation, use the entity 21074 -- of the instance spec. 21075 21076 if Nkind (Stmt) = N_Package_Instantiation then 21077 Stmt := Instance_Spec (Stmt); 21078 end if; 21079 21080 Item_Id := Defining_Entity (Stmt); 21081 21082 -- A pragma that applies to a Ghost entity becomes Ghost for the 21083 -- purposes of legality checks and removal of ignored Ghost code. 21084 21085 Mark_Ghost_Pragma (N, Item_Id); 21086 21087 -- Chain the pragma on the contract for further processing by 21088 -- Analyze_Part_Of_In_Decl_Part or for completeness. 21089 21090 Add_Contract_Item (N, Item_Id); 21091 21092 -- A variable may act as constituent of a single concurrent type 21093 -- which in turn could be declared after the variable. Due to this 21094 -- discrepancy, the full analysis of indicator Part_Of is delayed 21095 -- until the end of the enclosing declarative region (see routine 21096 -- Analyze_Part_Of_In_Decl_Part). 21097 21098 if Ekind (Item_Id) = E_Variable then 21099 null; 21100 21101 -- Otherwise indicator Part_Of applies to a constant or a package 21102 -- instantiation. 21103 21104 else 21105 Encap := Get_Pragma_Arg (Arg1); 21106 21107 -- Detect any discrepancies between the placement of the 21108 -- constant or package instantiation with respect to state 21109 -- space and the encapsulating state. 21110 21111 Analyze_Part_Of 21112 (Indic => N, 21113 Item_Id => Item_Id, 21114 Encap => Encap, 21115 Encap_Id => Encap_Id, 21116 Legal => Legal); 21117 21118 if Legal then 21119 pragma Assert (Present (Encap_Id)); 21120 21121 if Ekind (Item_Id) = E_Constant then 21122 Constits := Part_Of_Constituents (Encap_Id); 21123 21124 if No (Constits) then 21125 Constits := New_Elmt_List; 21126 Set_Part_Of_Constituents (Encap_Id, Constits); 21127 end if; 21128 21129 Append_Elmt (Item_Id, Constits); 21130 Set_Encapsulating_State (Item_Id, Encap_Id); 21131 21132 -- Propagate the Part_Of indicator to the visible state 21133 -- space of the package instantiation. 21134 21135 else 21136 Propagate_Part_Of 21137 (Pack_Id => Item_Id, 21138 State_Id => Encap_Id, 21139 Instance => Stmt); 21140 end if; 21141 end if; 21142 end if; 21143 end Part_Of; 21144 21145 ---------------------------------- 21146 -- Partition_Elaboration_Policy -- 21147 ---------------------------------- 21148 21149 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER); 21150 21151 when Pragma_Partition_Elaboration_Policy => PEP : declare 21152 subtype PEP_Range is Name_Id 21153 range First_Partition_Elaboration_Policy_Name 21154 .. Last_Partition_Elaboration_Policy_Name; 21155 PEP_Val : PEP_Range; 21156 PEP : Character; 21157 21158 begin 21159 Ada_2005_Pragma; 21160 Check_Arg_Count (1); 21161 Check_No_Identifiers; 21162 Check_Arg_Is_Partition_Elaboration_Policy (Arg1); 21163 Check_Valid_Configuration_Pragma; 21164 PEP_Val := Chars (Get_Pragma_Arg (Arg1)); 21165 21166 case PEP_Val is 21167 when Name_Concurrent => PEP := 'C'; 21168 when Name_Sequential => PEP := 'S'; 21169 end case; 21170 21171 if Partition_Elaboration_Policy /= ' ' 21172 and then Partition_Elaboration_Policy /= PEP 21173 then 21174 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc; 21175 Error_Pragma 21176 ("partition elaboration policy incompatible with policy#"); 21177 21178 -- Set new policy, but always preserve System_Location since we 21179 -- like the error message with the run time name. 21180 21181 else 21182 Partition_Elaboration_Policy := PEP; 21183 21184 if Partition_Elaboration_Policy_Sloc /= System_Location then 21185 Partition_Elaboration_Policy_Sloc := Loc; 21186 end if; 21187 end if; 21188 end PEP; 21189 21190 ------------- 21191 -- Passive -- 21192 ------------- 21193 21194 -- pragma Passive [(PASSIVE_FORM)]; 21195 21196 -- PASSIVE_FORM ::= Semaphore | No 21197 21198 when Pragma_Passive => 21199 GNAT_Pragma; 21200 21201 if Nkind (Parent (N)) /= N_Task_Definition then 21202 Error_Pragma ("pragma% must be within task definition"); 21203 end if; 21204 21205 if Arg_Count /= 0 then 21206 Check_Arg_Count (1); 21207 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); 21208 end if; 21209 21210 ---------------------------------- 21211 -- Preelaborable_Initialization -- 21212 ---------------------------------- 21213 21214 -- pragma Preelaborable_Initialization (DIRECT_NAME); 21215 21216 when Pragma_Preelaborable_Initialization => Preelab_Init : declare 21217 Ent : Entity_Id; 21218 21219 begin 21220 Ada_2005_Pragma; 21221 Check_Arg_Count (1); 21222 Check_No_Identifiers; 21223 Check_Arg_Is_Identifier (Arg1); 21224 Check_Arg_Is_Local_Name (Arg1); 21225 Check_First_Subtype (Arg1); 21226 Ent := Entity (Get_Pragma_Arg (Arg1)); 21227 21228 -- A pragma that applies to a Ghost entity becomes Ghost for the 21229 -- purposes of legality checks and removal of ignored Ghost code. 21230 21231 Mark_Ghost_Pragma (N, Ent); 21232 21233 -- The pragma may come from an aspect on a private declaration, 21234 -- even if the freeze point at which this is analyzed in the 21235 -- private part after the full view. 21236 21237 if Has_Private_Declaration (Ent) 21238 and then From_Aspect_Specification (N) 21239 then 21240 null; 21241 21242 -- Check appropriate type argument 21243 21244 elsif Is_Private_Type (Ent) 21245 or else Is_Protected_Type (Ent) 21246 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)) 21247 21248 -- AI05-0028: The pragma applies to all composite types. Note 21249 -- that we apply this binding interpretation to earlier versions 21250 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable 21251 -- choice since there are other compilers that do the same. 21252 21253 or else Is_Composite_Type (Ent) 21254 then 21255 null; 21256 21257 else 21258 Error_Pragma_Arg 21259 ("pragma % can only be applied to private, formal derived, " 21260 & "protected, or composite type", Arg1); 21261 end if; 21262 21263 -- Give an error if the pragma is applied to a protected type that 21264 -- does not qualify (due to having entries, or due to components 21265 -- that do not qualify). 21266 21267 if Is_Protected_Type (Ent) 21268 and then not Has_Preelaborable_Initialization (Ent) 21269 then 21270 Error_Msg_N 21271 ("protected type & does not have preelaborable " 21272 & "initialization", Ent); 21273 21274 -- Otherwise mark the type as definitely having preelaborable 21275 -- initialization. 21276 21277 else 21278 Set_Known_To_Have_Preelab_Init (Ent); 21279 end if; 21280 21281 if Has_Pragma_Preelab_Init (Ent) 21282 and then Warn_On_Redundant_Constructs 21283 then 21284 Error_Pragma ("?r?duplicate pragma%!"); 21285 else 21286 Set_Has_Pragma_Preelab_Init (Ent); 21287 end if; 21288 end Preelab_Init; 21289 21290 -------------------- 21291 -- Persistent_BSS -- 21292 -------------------- 21293 21294 -- pragma Persistent_BSS [(object_NAME)]; 21295 21296 when Pragma_Persistent_BSS => Persistent_BSS : declare 21297 Decl : Node_Id; 21298 Ent : Entity_Id; 21299 Prag : Node_Id; 21300 21301 begin 21302 GNAT_Pragma; 21303 Check_At_Most_N_Arguments (1); 21304 21305 -- Case of application to specific object (one argument) 21306 21307 if Arg_Count = 1 then 21308 Check_Arg_Is_Library_Level_Local_Name (Arg1); 21309 21310 if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) 21311 or else not 21312 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, 21313 E_Constant) 21314 then 21315 Error_Pragma_Arg ("pragma% only applies to objects", Arg1); 21316 end if; 21317 21318 Ent := Entity (Get_Pragma_Arg (Arg1)); 21319 21320 -- A pragma that applies to a Ghost entity becomes Ghost for 21321 -- the purposes of legality checks and removal of ignored Ghost 21322 -- code. 21323 21324 Mark_Ghost_Pragma (N, Ent); 21325 21326 -- Check for duplication before inserting in list of 21327 -- representation items. 21328 21329 Check_Duplicate_Pragma (Ent); 21330 21331 if Rep_Item_Too_Late (Ent, N) then 21332 return; 21333 end if; 21334 21335 Decl := Parent (Ent); 21336 21337 if Present (Expression (Decl)) then 21338 -- Variables in Persistent_BSS cannot be initialized, so 21339 -- turn off any initialization that might be caused by 21340 -- pragmas Initialize_Scalars or Normalize_Scalars. 21341 21342 if Kill_Range_Check (Expression (Decl)) then 21343 Prag := 21344 Make_Pragma (Loc, 21345 Name_Suppress_Initialization, 21346 Pragma_Argument_Associations => New_List ( 21347 Make_Pragma_Argument_Association (Loc, 21348 Expression => New_Occurrence_Of (Ent, Loc)))); 21349 Insert_Before (N, Prag); 21350 Analyze (Prag); 21351 21352 else 21353 Error_Pragma_Arg 21354 ("object for pragma% cannot have initialization", Arg1); 21355 end if; 21356 end if; 21357 21358 if not Is_Potentially_Persistent_Type (Etype (Ent)) then 21359 Error_Pragma_Arg 21360 ("object type for pragma% is not potentially persistent", 21361 Arg1); 21362 end if; 21363 21364 Prag := 21365 Make_Linker_Section_Pragma 21366 (Ent, Loc, ".persistent.bss"); 21367 Insert_After (N, Prag); 21368 Analyze (Prag); 21369 21370 -- Case of use as configuration pragma with no arguments 21371 21372 else 21373 Check_Valid_Configuration_Pragma; 21374 Persistent_BSS_Mode := True; 21375 end if; 21376 end Persistent_BSS; 21377 21378 -------------------- 21379 -- Rename_Pragma -- 21380 -------------------- 21381 21382 -- pragma Rename_Pragma ( 21383 -- [New_Name =>] IDENTIFIER, 21384 -- [Renamed =>] pragma_IDENTIFIER); 21385 21386 when Pragma_Rename_Pragma => Rename_Pragma : declare 21387 New_Name : constant Node_Id := Get_Pragma_Arg (Arg1); 21388 Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2); 21389 21390 begin 21391 GNAT_Pragma; 21392 Check_Valid_Configuration_Pragma; 21393 Check_Arg_Count (2); 21394 Check_Optional_Identifier (Arg1, Name_New_Name); 21395 Check_Optional_Identifier (Arg2, Name_Renamed); 21396 21397 if Nkind (New_Name) /= N_Identifier then 21398 Error_Pragma_Arg ("identifier expected", Arg1); 21399 end if; 21400 21401 if Nkind (Old_Name) /= N_Identifier then 21402 Error_Pragma_Arg ("identifier expected", Arg2); 21403 end if; 21404 21405 -- The New_Name arg should not be an existing pragma (but we allow 21406 -- it; it's just a warning). The Old_Name arg must be an existing 21407 -- pragma. 21408 21409 if Is_Pragma_Name (Chars (New_Name)) then 21410 Error_Pragma_Arg ("??pragma is already defined", Arg1); 21411 end if; 21412 21413 if not Is_Pragma_Name (Chars (Old_Name)) then 21414 Error_Pragma_Arg ("existing pragma name expected", Arg1); 21415 end if; 21416 21417 Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name)); 21418 end Rename_Pragma; 21419 21420 ------------- 21421 -- Polling -- 21422 ------------- 21423 21424 -- pragma Polling (ON | OFF); 21425 21426 when Pragma_Polling => 21427 GNAT_Pragma; 21428 Check_Arg_Count (1); 21429 Check_No_Identifiers; 21430 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 21431 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); 21432 21433 ----------------------------------- 21434 -- Post/Post_Class/Postcondition -- 21435 ----------------------------------- 21436 21437 -- pragma Post (Boolean_EXPRESSION); 21438 -- pragma Post_Class (Boolean_EXPRESSION); 21439 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION 21440 -- [,[Message =>] String_EXPRESSION]); 21441 21442 -- Characteristics: 21443 21444 -- * Analysis - The annotation undergoes initial checks to verify 21445 -- the legal placement and context. Secondary checks preanalyze the 21446 -- expression in: 21447 21448 -- Analyze_Pre_Post_Condition_In_Decl_Part 21449 21450 -- * Expansion - The annotation is expanded during the expansion of 21451 -- the related subprogram [body] contract as performed in: 21452 21453 -- Expand_Subprogram_Contract 21454 21455 -- * Template - The annotation utilizes the generic template of the 21456 -- related subprogram [body] when it is: 21457 21458 -- aspect on subprogram declaration 21459 -- aspect on stand-alone subprogram body 21460 -- pragma on stand-alone subprogram body 21461 21462 -- The annotation must prepare its own template when it is: 21463 21464 -- pragma on subprogram declaration 21465 21466 -- * Globals - Capture of global references must occur after full 21467 -- analysis. 21468 21469 -- * Instance - The annotation is instantiated automatically when 21470 -- the related generic subprogram [body] is instantiated except for 21471 -- the "pragma on subprogram declaration" case. In that scenario 21472 -- the annotation must instantiate itself. 21473 21474 when Pragma_Post 21475 | Pragma_Post_Class 21476 | Pragma_Postcondition 21477 => 21478 Analyze_Pre_Post_Condition; 21479 21480 -------------------------------- 21481 -- Pre/Pre_Class/Precondition -- 21482 -------------------------------- 21483 21484 -- pragma Pre (Boolean_EXPRESSION); 21485 -- pragma Pre_Class (Boolean_EXPRESSION); 21486 -- pragma Precondition ([Check =>] Boolean_EXPRESSION 21487 -- [,[Message =>] String_EXPRESSION]); 21488 21489 -- Characteristics: 21490 21491 -- * Analysis - The annotation undergoes initial checks to verify 21492 -- the legal placement and context. Secondary checks preanalyze the 21493 -- expression in: 21494 21495 -- Analyze_Pre_Post_Condition_In_Decl_Part 21496 21497 -- * Expansion - The annotation is expanded during the expansion of 21498 -- the related subprogram [body] contract as performed in: 21499 21500 -- Expand_Subprogram_Contract 21501 21502 -- * Template - The annotation utilizes the generic template of the 21503 -- related subprogram [body] when it is: 21504 21505 -- aspect on subprogram declaration 21506 -- aspect on stand-alone subprogram body 21507 -- pragma on stand-alone subprogram body 21508 21509 -- The annotation must prepare its own template when it is: 21510 21511 -- pragma on subprogram declaration 21512 21513 -- * Globals - Capture of global references must occur after full 21514 -- analysis. 21515 21516 -- * Instance - The annotation is instantiated automatically when 21517 -- the related generic subprogram [body] is instantiated except for 21518 -- the "pragma on subprogram declaration" case. In that scenario 21519 -- the annotation must instantiate itself. 21520 21521 when Pragma_Pre 21522 | Pragma_Pre_Class 21523 | Pragma_Precondition 21524 => 21525 Analyze_Pre_Post_Condition; 21526 21527 --------------- 21528 -- Predicate -- 21529 --------------- 21530 21531 -- pragma Predicate 21532 -- ([Entity =>] type_LOCAL_NAME, 21533 -- [Check =>] boolean_EXPRESSION); 21534 21535 when Pragma_Predicate => Predicate : declare 21536 Discard : Boolean; 21537 Typ : Entity_Id; 21538 Type_Id : Node_Id; 21539 21540 begin 21541 GNAT_Pragma; 21542 Check_Arg_Count (2); 21543 Check_Optional_Identifier (Arg1, Name_Entity); 21544 Check_Optional_Identifier (Arg2, Name_Check); 21545 21546 Check_Arg_Is_Local_Name (Arg1); 21547 21548 Type_Id := Get_Pragma_Arg (Arg1); 21549 Find_Type (Type_Id); 21550 Typ := Entity (Type_Id); 21551 21552 if Typ = Any_Type then 21553 return; 21554 end if; 21555 21556 -- A pragma that applies to a Ghost entity becomes Ghost for the 21557 -- purposes of legality checks and removal of ignored Ghost code. 21558 21559 Mark_Ghost_Pragma (N, Typ); 21560 21561 -- The remaining processing is simply to link the pragma on to 21562 -- the rep item chain, for processing when the type is frozen. 21563 -- This is accomplished by a call to Rep_Item_Too_Late. We also 21564 -- mark the type as having predicates. 21565 21566 -- If the current policy for predicate checking is Ignore mark the 21567 -- subtype accordingly. In the case of predicates we consider them 21568 -- enabled unless Ignore is specified (either directly or with a 21569 -- general Assertion_Policy pragma) to preserve existing warnings. 21570 21571 Set_Has_Predicates (Typ); 21572 21573 -- Indicate that the pragma must be processed at the point the 21574 -- type is frozen, as is done for the corresponding aspect. 21575 21576 Set_Has_Delayed_Aspects (Typ); 21577 Set_Has_Delayed_Freeze (Typ); 21578 21579 Set_Predicates_Ignored (Typ, 21580 Present (Check_Policy_List) 21581 and then 21582 Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore); 21583 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 21584 end Predicate; 21585 21586 ----------------------- 21587 -- Predicate_Failure -- 21588 ----------------------- 21589 21590 -- pragma Predicate_Failure 21591 -- ([Entity =>] type_LOCAL_NAME, 21592 -- [Message =>] string_EXPRESSION); 21593 21594 when Pragma_Predicate_Failure => Predicate_Failure : declare 21595 Discard : Boolean; 21596 Typ : Entity_Id; 21597 Type_Id : Node_Id; 21598 21599 begin 21600 GNAT_Pragma; 21601 Check_Arg_Count (2); 21602 Check_Optional_Identifier (Arg1, Name_Entity); 21603 Check_Optional_Identifier (Arg2, Name_Message); 21604 21605 Check_Arg_Is_Local_Name (Arg1); 21606 21607 Type_Id := Get_Pragma_Arg (Arg1); 21608 Find_Type (Type_Id); 21609 Typ := Entity (Type_Id); 21610 21611 if Typ = Any_Type then 21612 return; 21613 end if; 21614 21615 -- A pragma that applies to a Ghost entity becomes Ghost for the 21616 -- purposes of legality checks and removal of ignored Ghost code. 21617 21618 Mark_Ghost_Pragma (N, Typ); 21619 21620 -- The remaining processing is simply to link the pragma on to 21621 -- the rep item chain, for processing when the type is frozen. 21622 -- This is accomplished by a call to Rep_Item_Too_Late. 21623 21624 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 21625 end Predicate_Failure; 21626 21627 ------------------ 21628 -- Preelaborate -- 21629 ------------------ 21630 21631 -- pragma Preelaborate [(library_unit_NAME)]; 21632 21633 -- Set the flag Is_Preelaborated of program unit name entity 21634 21635 when Pragma_Preelaborate => Preelaborate : declare 21636 Pa : constant Node_Id := Parent (N); 21637 Pk : constant Node_Kind := Nkind (Pa); 21638 Ent : Entity_Id; 21639 21640 begin 21641 Check_Ada_83_Warning; 21642 Check_Valid_Library_Unit_Pragma; 21643 21644 if Nkind (N) = N_Null_Statement then 21645 return; 21646 end if; 21647 21648 Ent := Find_Lib_Unit_Name; 21649 21650 -- A pragma that applies to a Ghost entity becomes Ghost for the 21651 -- purposes of legality checks and removal of ignored Ghost code. 21652 21653 Mark_Ghost_Pragma (N, Ent); 21654 Check_Duplicate_Pragma (Ent); 21655 21656 -- This filters out pragmas inside generic parents that show up 21657 -- inside instantiations. Pragmas that come from aspects in the 21658 -- unit are not ignored. 21659 21660 if Present (Ent) then 21661 if Pk = N_Package_Specification 21662 and then Present (Generic_Parent (Pa)) 21663 and then not From_Aspect_Specification (N) 21664 then 21665 null; 21666 21667 else 21668 if not Debug_Flag_U then 21669 Set_Is_Preelaborated (Ent); 21670 21671 if Legacy_Elaboration_Checks then 21672 Set_Suppress_Elaboration_Warnings (Ent); 21673 end if; 21674 end if; 21675 end if; 21676 end if; 21677 end Preelaborate; 21678 21679 ------------------------------- 21680 -- Prefix_Exception_Messages -- 21681 ------------------------------- 21682 21683 -- pragma Prefix_Exception_Messages; 21684 21685 when Pragma_Prefix_Exception_Messages => 21686 GNAT_Pragma; 21687 Check_Valid_Configuration_Pragma; 21688 Check_Arg_Count (0); 21689 Prefix_Exception_Messages := True; 21690 21691 -------------- 21692 -- Priority -- 21693 -------------- 21694 21695 -- pragma Priority (EXPRESSION); 21696 21697 when Pragma_Priority => Priority : declare 21698 P : constant Node_Id := Parent (N); 21699 Arg : Node_Id; 21700 Ent : Entity_Id; 21701 21702 begin 21703 Check_No_Identifiers; 21704 Check_Arg_Count (1); 21705 21706 -- Subprogram case 21707 21708 if Nkind (P) = N_Subprogram_Body then 21709 Check_In_Main_Program; 21710 21711 Ent := Defining_Unit_Name (Specification (P)); 21712 21713 if Nkind (Ent) = N_Defining_Program_Unit_Name then 21714 Ent := Defining_Identifier (Ent); 21715 end if; 21716 21717 Arg := Get_Pragma_Arg (Arg1); 21718 Analyze_And_Resolve (Arg, Standard_Integer); 21719 21720 -- Must be static 21721 21722 if not Is_OK_Static_Expression (Arg) then 21723 Flag_Non_Static_Expr 21724 ("main subprogram priority is not static!", Arg); 21725 raise Pragma_Exit; 21726 21727 -- If constraint error, then we already signalled an error 21728 21729 elsif Raises_Constraint_Error (Arg) then 21730 null; 21731 21732 -- Otherwise check in range except if Relaxed_RM_Semantics 21733 -- where we ignore the value if out of range. 21734 21735 else 21736 if not Relaxed_RM_Semantics 21737 and then not Is_In_Range (Arg, RTE (RE_Priority)) 21738 then 21739 Error_Pragma_Arg 21740 ("main subprogram priority is out of range", Arg1); 21741 else 21742 Set_Main_Priority 21743 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 21744 end if; 21745 end if; 21746 21747 -- Load an arbitrary entity from System.Tasking.Stages or 21748 -- System.Tasking.Restricted.Stages (depending on the 21749 -- supported profile) to make sure that one of these packages 21750 -- is implicitly with'ed, since we need to have the tasking 21751 -- run time active for the pragma Priority to have any effect. 21752 -- Previously we with'ed the package System.Tasking, but this 21753 -- package does not trigger the required initialization of the 21754 -- run-time library. 21755 21756 declare 21757 Discard : Entity_Id; 21758 pragma Warnings (Off, Discard); 21759 begin 21760 if Restricted_Profile then 21761 Discard := RTE (RE_Activate_Restricted_Tasks); 21762 else 21763 Discard := RTE (RE_Activate_Tasks); 21764 end if; 21765 end; 21766 21767 -- Task or Protected, must be of type Integer 21768 21769 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then 21770 Arg := Get_Pragma_Arg (Arg1); 21771 Ent := Defining_Identifier (Parent (P)); 21772 21773 -- The expression must be analyzed in the special manner 21774 -- described in "Handling of Default and Per-Object 21775 -- Expressions" in sem.ads. 21776 21777 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); 21778 21779 if not Is_OK_Static_Expression (Arg) then 21780 Check_Restriction (Static_Priorities, Arg); 21781 end if; 21782 21783 -- Anything else is incorrect 21784 21785 else 21786 Pragma_Misplaced; 21787 end if; 21788 21789 -- Check duplicate pragma before we chain the pragma in the Rep 21790 -- Item chain of Ent. 21791 21792 Check_Duplicate_Pragma (Ent); 21793 Record_Rep_Item (Ent, N); 21794 end Priority; 21795 21796 ----------------------------------- 21797 -- Priority_Specific_Dispatching -- 21798 ----------------------------------- 21799 21800 -- pragma Priority_Specific_Dispatching ( 21801 -- policy_IDENTIFIER, 21802 -- first_priority_EXPRESSION, 21803 -- last_priority_EXPRESSION); 21804 21805 when Pragma_Priority_Specific_Dispatching => 21806 Priority_Specific_Dispatching : declare 21807 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority); 21808 -- This is the entity System.Any_Priority; 21809 21810 DP : Character; 21811 Lower_Bound : Node_Id; 21812 Upper_Bound : Node_Id; 21813 Lower_Val : Uint; 21814 Upper_Val : Uint; 21815 21816 begin 21817 Ada_2005_Pragma; 21818 Check_Arg_Count (3); 21819 Check_No_Identifiers; 21820 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 21821 Check_Valid_Configuration_Pragma; 21822 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 21823 DP := Fold_Upper (Name_Buffer (1)); 21824 21825 Lower_Bound := Get_Pragma_Arg (Arg2); 21826 Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer); 21827 Lower_Val := Expr_Value (Lower_Bound); 21828 21829 Upper_Bound := Get_Pragma_Arg (Arg3); 21830 Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer); 21831 Upper_Val := Expr_Value (Upper_Bound); 21832 21833 -- It is not allowed to use Task_Dispatching_Policy and 21834 -- Priority_Specific_Dispatching in the same partition. 21835 21836 if Task_Dispatching_Policy /= ' ' then 21837 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 21838 Error_Pragma 21839 ("pragma% incompatible with Task_Dispatching_Policy#"); 21840 21841 -- Check lower bound in range 21842 21843 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 21844 or else 21845 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id)) 21846 then 21847 Error_Pragma_Arg 21848 ("first_priority is out of range", Arg2); 21849 21850 -- Check upper bound in range 21851 21852 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 21853 or else 21854 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id)) 21855 then 21856 Error_Pragma_Arg 21857 ("last_priority is out of range", Arg3); 21858 21859 -- Check that the priority range is valid 21860 21861 elsif Lower_Val > Upper_Val then 21862 Error_Pragma 21863 ("last_priority_expression must be greater than or equal to " 21864 & "first_priority_expression"); 21865 21866 -- Store the new policy, but always preserve System_Location since 21867 -- we like the error message with the run-time name. 21868 21869 else 21870 -- Check overlapping in the priority ranges specified in other 21871 -- Priority_Specific_Dispatching pragmas within the same 21872 -- partition. We can only check those we know about. 21873 21874 for J in 21875 Specific_Dispatching.First .. Specific_Dispatching.Last 21876 loop 21877 if Specific_Dispatching.Table (J).First_Priority in 21878 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 21879 or else Specific_Dispatching.Table (J).Last_Priority in 21880 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 21881 then 21882 Error_Msg_Sloc := 21883 Specific_Dispatching.Table (J).Pragma_Loc; 21884 Error_Pragma 21885 ("priority range overlaps with " 21886 & "Priority_Specific_Dispatching#"); 21887 end if; 21888 end loop; 21889 21890 -- The use of Priority_Specific_Dispatching is incompatible 21891 -- with Task_Dispatching_Policy. 21892 21893 if Task_Dispatching_Policy /= ' ' then 21894 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 21895 Error_Pragma 21896 ("Priority_Specific_Dispatching incompatible " 21897 & "with Task_Dispatching_Policy#"); 21898 end if; 21899 21900 -- The use of Priority_Specific_Dispatching forces ceiling 21901 -- locking policy. 21902 21903 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then 21904 Error_Msg_Sloc := Locking_Policy_Sloc; 21905 Error_Pragma 21906 ("Priority_Specific_Dispatching incompatible " 21907 & "with Locking_Policy#"); 21908 21909 -- Set the Ceiling_Locking policy, but preserve System_Location 21910 -- since we like the error message with the run time name. 21911 21912 else 21913 Locking_Policy := 'C'; 21914 21915 if Locking_Policy_Sloc /= System_Location then 21916 Locking_Policy_Sloc := Loc; 21917 end if; 21918 end if; 21919 21920 -- Add entry in the table 21921 21922 Specific_Dispatching.Append 21923 ((Dispatching_Policy => DP, 21924 First_Priority => UI_To_Int (Lower_Val), 21925 Last_Priority => UI_To_Int (Upper_Val), 21926 Pragma_Loc => Loc)); 21927 end if; 21928 end Priority_Specific_Dispatching; 21929 21930 ------------- 21931 -- Profile -- 21932 ------------- 21933 21934 -- pragma Profile (profile_IDENTIFIER); 21935 21936 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational 21937 21938 when Pragma_Profile => 21939 Ada_2005_Pragma; 21940 Check_Arg_Count (1); 21941 Check_Valid_Configuration_Pragma; 21942 Check_No_Identifiers; 21943 21944 declare 21945 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 21946 21947 begin 21948 if Chars (Argx) = Name_Ravenscar then 21949 Set_Ravenscar_Profile (Ravenscar, N); 21950 21951 elsif Chars (Argx) = Name_Gnat_Extended_Ravenscar then 21952 Set_Ravenscar_Profile (GNAT_Extended_Ravenscar, N); 21953 21954 elsif Chars (Argx) = Name_Gnat_Ravenscar_EDF then 21955 Set_Ravenscar_Profile (GNAT_Ravenscar_EDF, N); 21956 21957 elsif Chars (Argx) = Name_Restricted then 21958 Set_Profile_Restrictions 21959 (Restricted, 21960 N, Warn => Treat_Restrictions_As_Warnings); 21961 21962 elsif Chars (Argx) = Name_Rational then 21963 Set_Rational_Profile; 21964 21965 elsif Chars (Argx) = Name_No_Implementation_Extensions then 21966 Set_Profile_Restrictions 21967 (No_Implementation_Extensions, 21968 N, Warn => Treat_Restrictions_As_Warnings); 21969 21970 else 21971 Error_Pragma_Arg ("& is not a valid profile", Argx); 21972 end if; 21973 end; 21974 21975 ---------------------- 21976 -- Profile_Warnings -- 21977 ---------------------- 21978 21979 -- pragma Profile_Warnings (profile_IDENTIFIER); 21980 21981 -- profile_IDENTIFIER => Restricted | Ravenscar 21982 21983 when Pragma_Profile_Warnings => 21984 GNAT_Pragma; 21985 Check_Arg_Count (1); 21986 Check_Valid_Configuration_Pragma; 21987 Check_No_Identifiers; 21988 21989 declare 21990 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 21991 21992 begin 21993 if Chars (Argx) = Name_Ravenscar then 21994 Set_Profile_Restrictions (Ravenscar, N, Warn => True); 21995 21996 elsif Chars (Argx) = Name_Restricted then 21997 Set_Profile_Restrictions (Restricted, N, Warn => True); 21998 21999 elsif Chars (Argx) = Name_No_Implementation_Extensions then 22000 Set_Profile_Restrictions 22001 (No_Implementation_Extensions, N, Warn => True); 22002 22003 else 22004 Error_Pragma_Arg ("& is not a valid profile", Argx); 22005 end if; 22006 end; 22007 22008 -------------------------- 22009 -- Propagate_Exceptions -- 22010 -------------------------- 22011 22012 -- pragma Propagate_Exceptions; 22013 22014 -- Note: this pragma is obsolete and has no effect 22015 22016 when Pragma_Propagate_Exceptions => 22017 GNAT_Pragma; 22018 Check_Arg_Count (0); 22019 22020 if Warn_On_Obsolescent_Feature then 22021 Error_Msg_N 22022 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " & 22023 "and has no effect?j?", N); 22024 end if; 22025 22026 ----------------------------- 22027 -- Provide_Shift_Operators -- 22028 ----------------------------- 22029 22030 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME); 22031 22032 when Pragma_Provide_Shift_Operators => 22033 Provide_Shift_Operators : declare 22034 Ent : Entity_Id; 22035 22036 procedure Declare_Shift_Operator (Nam : Name_Id); 22037 -- Insert declaration and pragma Instrinsic for named shift op 22038 22039 ---------------------------- 22040 -- Declare_Shift_Operator -- 22041 ---------------------------- 22042 22043 procedure Declare_Shift_Operator (Nam : Name_Id) is 22044 Func : Node_Id; 22045 Import : Node_Id; 22046 22047 begin 22048 Func := 22049 Make_Subprogram_Declaration (Loc, 22050 Make_Function_Specification (Loc, 22051 Defining_Unit_Name => 22052 Make_Defining_Identifier (Loc, Chars => Nam), 22053 22054 Result_Definition => 22055 Make_Identifier (Loc, Chars => Chars (Ent)), 22056 22057 Parameter_Specifications => New_List ( 22058 Make_Parameter_Specification (Loc, 22059 Defining_Identifier => 22060 Make_Defining_Identifier (Loc, Name_Value), 22061 Parameter_Type => 22062 Make_Identifier (Loc, Chars => Chars (Ent))), 22063 22064 Make_Parameter_Specification (Loc, 22065 Defining_Identifier => 22066 Make_Defining_Identifier (Loc, Name_Amount), 22067 Parameter_Type => 22068 New_Occurrence_Of (Standard_Natural, Loc))))); 22069 22070 Import := 22071 Make_Pragma (Loc, 22072 Chars => Name_Import, 22073 Pragma_Argument_Associations => New_List ( 22074 Make_Pragma_Argument_Association (Loc, 22075 Expression => Make_Identifier (Loc, Name_Intrinsic)), 22076 Make_Pragma_Argument_Association (Loc, 22077 Expression => Make_Identifier (Loc, Nam)))); 22078 22079 Insert_After (N, Import); 22080 Insert_After (N, Func); 22081 end Declare_Shift_Operator; 22082 22083 -- Start of processing for Provide_Shift_Operators 22084 22085 begin 22086 GNAT_Pragma; 22087 Check_Arg_Count (1); 22088 Check_Arg_Is_Local_Name (Arg1); 22089 22090 Arg1 := Get_Pragma_Arg (Arg1); 22091 22092 -- We must have an entity name 22093 22094 if not Is_Entity_Name (Arg1) then 22095 Error_Pragma_Arg 22096 ("pragma % must apply to integer first subtype", Arg1); 22097 end if; 22098 22099 -- If no Entity, means there was a prior error so ignore 22100 22101 if Present (Entity (Arg1)) then 22102 Ent := Entity (Arg1); 22103 22104 -- Apply error checks 22105 22106 if not Is_First_Subtype (Ent) then 22107 Error_Pragma_Arg 22108 ("cannot apply pragma %", 22109 "\& is not a first subtype", 22110 Arg1); 22111 22112 elsif not Is_Integer_Type (Ent) then 22113 Error_Pragma_Arg 22114 ("cannot apply pragma %", 22115 "\& is not an integer type", 22116 Arg1); 22117 22118 elsif Has_Shift_Operator (Ent) then 22119 Error_Pragma_Arg 22120 ("cannot apply pragma %", 22121 "\& already has declared shift operators", 22122 Arg1); 22123 22124 elsif Is_Frozen (Ent) then 22125 Error_Pragma_Arg 22126 ("pragma % appears too late", 22127 "\& is already frozen", 22128 Arg1); 22129 end if; 22130 22131 -- Now declare the operators. We do this during analysis rather 22132 -- than expansion, since we want the operators available if we 22133 -- are operating in -gnatc or ASIS mode. 22134 22135 Declare_Shift_Operator (Name_Rotate_Left); 22136 Declare_Shift_Operator (Name_Rotate_Right); 22137 Declare_Shift_Operator (Name_Shift_Left); 22138 Declare_Shift_Operator (Name_Shift_Right); 22139 Declare_Shift_Operator (Name_Shift_Right_Arithmetic); 22140 end if; 22141 end Provide_Shift_Operators; 22142 22143 ------------------ 22144 -- Psect_Object -- 22145 ------------------ 22146 22147 -- pragma Psect_Object ( 22148 -- [Internal =>] LOCAL_NAME, 22149 -- [, [External =>] EXTERNAL_SYMBOL] 22150 -- [, [Size =>] EXTERNAL_SYMBOL]); 22151 22152 when Pragma_Common_Object 22153 | Pragma_Psect_Object 22154 => 22155 Psect_Object : declare 22156 Args : Args_List (1 .. 3); 22157 Names : constant Name_List (1 .. 3) := ( 22158 Name_Internal, 22159 Name_External, 22160 Name_Size); 22161 22162 Internal : Node_Id renames Args (1); 22163 External : Node_Id renames Args (2); 22164 Size : Node_Id renames Args (3); 22165 22166 Def_Id : Entity_Id; 22167 22168 procedure Check_Arg (Arg : Node_Id); 22169 -- Checks that argument is either a string literal or an 22170 -- identifier, and posts error message if not. 22171 22172 --------------- 22173 -- Check_Arg -- 22174 --------------- 22175 22176 procedure Check_Arg (Arg : Node_Id) is 22177 begin 22178 if not Nkind_In (Original_Node (Arg), 22179 N_String_Literal, 22180 N_Identifier) 22181 then 22182 Error_Pragma_Arg 22183 ("inappropriate argument for pragma %", Arg); 22184 end if; 22185 end Check_Arg; 22186 22187 -- Start of processing for Common_Object/Psect_Object 22188 22189 begin 22190 GNAT_Pragma; 22191 Gather_Associations (Names, Args); 22192 Process_Extended_Import_Export_Internal_Arg (Internal); 22193 22194 Def_Id := Entity (Internal); 22195 22196 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 22197 Error_Pragma_Arg 22198 ("pragma% must designate an object", Internal); 22199 end if; 22200 22201 Check_Arg (Internal); 22202 22203 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then 22204 Error_Pragma_Arg 22205 ("cannot use pragma% for imported/exported object", 22206 Internal); 22207 end if; 22208 22209 if Is_Concurrent_Type (Etype (Internal)) then 22210 Error_Pragma_Arg 22211 ("cannot specify pragma % for task/protected object", 22212 Internal); 22213 end if; 22214 22215 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 22216 or else 22217 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 22218 then 22219 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N); 22220 end if; 22221 22222 if Ekind (Def_Id) = E_Constant then 22223 Error_Pragma_Arg 22224 ("cannot specify pragma % for a constant", Internal); 22225 end if; 22226 22227 if Is_Record_Type (Etype (Internal)) then 22228 declare 22229 Ent : Entity_Id; 22230 Decl : Entity_Id; 22231 22232 begin 22233 Ent := First_Entity (Etype (Internal)); 22234 while Present (Ent) loop 22235 Decl := Declaration_Node (Ent); 22236 22237 if Ekind (Ent) = E_Component 22238 and then Nkind (Decl) = N_Component_Declaration 22239 and then Present (Expression (Decl)) 22240 and then Warn_On_Export_Import 22241 then 22242 Error_Msg_N 22243 ("?x?object for pragma % has defaults", Internal); 22244 exit; 22245 22246 else 22247 Next_Entity (Ent); 22248 end if; 22249 end loop; 22250 end; 22251 end if; 22252 22253 if Present (Size) then 22254 Check_Arg (Size); 22255 end if; 22256 22257 if Present (External) then 22258 Check_Arg_Is_External_Name (External); 22259 end if; 22260 22261 -- If all error tests pass, link pragma on to the rep item chain 22262 22263 Record_Rep_Item (Def_Id, N); 22264 end Psect_Object; 22265 22266 ---------- 22267 -- Pure -- 22268 ---------- 22269 22270 -- pragma Pure [(library_unit_NAME)]; 22271 22272 when Pragma_Pure => Pure : declare 22273 Ent : Entity_Id; 22274 22275 begin 22276 Check_Ada_83_Warning; 22277 22278 -- If the pragma comes from a subprogram instantiation, nothing to 22279 -- check, this can happen at any level of nesting. 22280 22281 if Is_Wrapper_Package (Current_Scope) then 22282 return; 22283 else 22284 Check_Valid_Library_Unit_Pragma; 22285 end if; 22286 22287 if Nkind (N) = N_Null_Statement then 22288 return; 22289 end if; 22290 22291 Ent := Find_Lib_Unit_Name; 22292 22293 -- A pragma that applies to a Ghost entity becomes Ghost for the 22294 -- purposes of legality checks and removal of ignored Ghost code. 22295 22296 Mark_Ghost_Pragma (N, Ent); 22297 22298 if not Debug_Flag_U then 22299 Set_Is_Pure (Ent); 22300 Set_Has_Pragma_Pure (Ent); 22301 22302 if Legacy_Elaboration_Checks then 22303 Set_Suppress_Elaboration_Warnings (Ent); 22304 end if; 22305 end if; 22306 end Pure; 22307 22308 ------------------- 22309 -- Pure_Function -- 22310 ------------------- 22311 22312 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME); 22313 22314 when Pragma_Pure_Function => Pure_Function : declare 22315 Def_Id : Entity_Id; 22316 E : Entity_Id; 22317 E_Id : Node_Id; 22318 Effective : Boolean := False; 22319 Orig_Def : Entity_Id; 22320 Same_Decl : Boolean := False; 22321 22322 begin 22323 GNAT_Pragma; 22324 Check_Arg_Count (1); 22325 Check_Optional_Identifier (Arg1, Name_Entity); 22326 Check_Arg_Is_Local_Name (Arg1); 22327 E_Id := Get_Pragma_Arg (Arg1); 22328 22329 if Etype (E_Id) = Any_Type then 22330 return; 22331 end if; 22332 22333 -- Loop through homonyms (overloadings) of referenced entity 22334 22335 E := Entity (E_Id); 22336 22337 -- A pragma that applies to a Ghost entity becomes Ghost for the 22338 -- purposes of legality checks and removal of ignored Ghost code. 22339 22340 Mark_Ghost_Pragma (N, E); 22341 22342 if Present (E) then 22343 loop 22344 Def_Id := Get_Base_Subprogram (E); 22345 22346 if not Ekind_In (Def_Id, E_Function, 22347 E_Generic_Function, 22348 E_Operator) 22349 then 22350 Error_Pragma_Arg 22351 ("pragma% requires a function name", Arg1); 22352 end if; 22353 22354 -- When we have a generic function we must jump up a level 22355 -- to the declaration of the wrapper package itself. 22356 22357 Orig_Def := Def_Id; 22358 22359 if Is_Generic_Instance (Def_Id) then 22360 while Nkind (Orig_Def) /= N_Package_Declaration loop 22361 Orig_Def := Parent (Orig_Def); 22362 end loop; 22363 end if; 22364 22365 if In_Same_Declarative_Part (Parent (N), Orig_Def) then 22366 Same_Decl := True; 22367 Set_Is_Pure (Def_Id); 22368 22369 if not Has_Pragma_Pure_Function (Def_Id) then 22370 Set_Has_Pragma_Pure_Function (Def_Id); 22371 Effective := True; 22372 end if; 22373 end if; 22374 22375 exit when From_Aspect_Specification (N); 22376 E := Homonym (E); 22377 exit when No (E) or else Scope (E) /= Current_Scope; 22378 end loop; 22379 22380 if not Effective 22381 and then Warn_On_Redundant_Constructs 22382 then 22383 Error_Msg_NE 22384 ("pragma Pure_Function on& is redundant?r?", 22385 N, Entity (E_Id)); 22386 22387 elsif not Same_Decl then 22388 Error_Pragma_Arg 22389 ("pragma% argument must be in same declarative part", 22390 Arg1); 22391 end if; 22392 end if; 22393 end Pure_Function; 22394 22395 -------------------- 22396 -- Queuing_Policy -- 22397 -------------------- 22398 22399 -- pragma Queuing_Policy (policy_IDENTIFIER); 22400 22401 when Pragma_Queuing_Policy => declare 22402 QP : Character; 22403 22404 begin 22405 Check_Ada_83_Warning; 22406 Check_Arg_Count (1); 22407 Check_No_Identifiers; 22408 Check_Arg_Is_Queuing_Policy (Arg1); 22409 Check_Valid_Configuration_Pragma; 22410 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 22411 QP := Fold_Upper (Name_Buffer (1)); 22412 22413 if Queuing_Policy /= ' ' 22414 and then Queuing_Policy /= QP 22415 then 22416 Error_Msg_Sloc := Queuing_Policy_Sloc; 22417 Error_Pragma ("queuing policy incompatible with policy#"); 22418 22419 -- Set new policy, but always preserve System_Location since we 22420 -- like the error message with the run time name. 22421 22422 else 22423 Queuing_Policy := QP; 22424 22425 if Queuing_Policy_Sloc /= System_Location then 22426 Queuing_Policy_Sloc := Loc; 22427 end if; 22428 end if; 22429 end; 22430 22431 -------------- 22432 -- Rational -- 22433 -------------- 22434 22435 -- pragma Rational, for compatibility with foreign compiler 22436 22437 when Pragma_Rational => 22438 Set_Rational_Profile; 22439 22440 --------------------- 22441 -- Refined_Depends -- 22442 --------------------- 22443 22444 -- pragma Refined_Depends (DEPENDENCY_RELATION); 22445 22446 -- DEPENDENCY_RELATION ::= 22447 -- null 22448 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE}) 22449 22450 -- DEPENDENCY_CLAUSE ::= 22451 -- OUTPUT_LIST =>[+] INPUT_LIST 22452 -- | NULL_DEPENDENCY_CLAUSE 22453 22454 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 22455 22456 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 22457 22458 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 22459 22460 -- OUTPUT ::= NAME | FUNCTION_RESULT 22461 -- INPUT ::= NAME 22462 22463 -- where FUNCTION_RESULT is a function Result attribute_reference 22464 22465 -- Characteristics: 22466 22467 -- * Analysis - The annotation undergoes initial checks to verify 22468 -- the legal placement and context. Secondary checks fully analyze 22469 -- the dependency clauses/global list in: 22470 22471 -- Analyze_Refined_Depends_In_Decl_Part 22472 22473 -- * Expansion - None. 22474 22475 -- * Template - The annotation utilizes the generic template of the 22476 -- related subprogram body. 22477 22478 -- * Globals - Capture of global references must occur after full 22479 -- analysis. 22480 22481 -- * Instance - The annotation is instantiated automatically when 22482 -- the related generic subprogram body is instantiated. 22483 22484 when Pragma_Refined_Depends => Refined_Depends : declare 22485 Body_Id : Entity_Id; 22486 Legal : Boolean; 22487 Spec_Id : Entity_Id; 22488 22489 begin 22490 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 22491 22492 if Legal then 22493 22494 -- Chain the pragma on the contract for further processing by 22495 -- Analyze_Refined_Depends_In_Decl_Part. 22496 22497 Add_Contract_Item (N, Body_Id); 22498 22499 -- The legality checks of pragmas Refined_Depends and 22500 -- Refined_Global are affected by the SPARK mode in effect and 22501 -- the volatility of the context. In addition these two pragmas 22502 -- are subject to an inherent order: 22503 22504 -- 1) Refined_Global 22505 -- 2) Refined_Depends 22506 22507 -- Analyze all these pragmas in the order outlined above 22508 22509 Analyze_If_Present (Pragma_SPARK_Mode); 22510 Analyze_If_Present (Pragma_Volatile_Function); 22511 Analyze_If_Present (Pragma_Refined_Global); 22512 Analyze_Refined_Depends_In_Decl_Part (N); 22513 end if; 22514 end Refined_Depends; 22515 22516 -------------------- 22517 -- Refined_Global -- 22518 -------------------- 22519 22520 -- pragma Refined_Global (GLOBAL_SPECIFICATION); 22521 22522 -- GLOBAL_SPECIFICATION ::= 22523 -- null 22524 -- | (GLOBAL_LIST) 22525 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST}) 22526 22527 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 22528 22529 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 22530 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 22531 -- GLOBAL_ITEM ::= NAME 22532 22533 -- Characteristics: 22534 22535 -- * Analysis - The annotation undergoes initial checks to verify 22536 -- the legal placement and context. Secondary checks fully analyze 22537 -- the dependency clauses/global list in: 22538 22539 -- Analyze_Refined_Global_In_Decl_Part 22540 22541 -- * Expansion - None. 22542 22543 -- * Template - The annotation utilizes the generic template of the 22544 -- related subprogram body. 22545 22546 -- * Globals - Capture of global references must occur after full 22547 -- analysis. 22548 22549 -- * Instance - The annotation is instantiated automatically when 22550 -- the related generic subprogram body is instantiated. 22551 22552 when Pragma_Refined_Global => Refined_Global : declare 22553 Body_Id : Entity_Id; 22554 Legal : Boolean; 22555 Spec_Id : Entity_Id; 22556 22557 begin 22558 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 22559 22560 if Legal then 22561 22562 -- Chain the pragma on the contract for further processing by 22563 -- Analyze_Refined_Global_In_Decl_Part. 22564 22565 Add_Contract_Item (N, Body_Id); 22566 22567 -- The legality checks of pragmas Refined_Depends and 22568 -- Refined_Global are affected by the SPARK mode in effect and 22569 -- the volatility of the context. In addition these two pragmas 22570 -- are subject to an inherent order: 22571 22572 -- 1) Refined_Global 22573 -- 2) Refined_Depends 22574 22575 -- Analyze all these pragmas in the order outlined above 22576 22577 Analyze_If_Present (Pragma_SPARK_Mode); 22578 Analyze_If_Present (Pragma_Volatile_Function); 22579 Analyze_Refined_Global_In_Decl_Part (N); 22580 Analyze_If_Present (Pragma_Refined_Depends); 22581 end if; 22582 end Refined_Global; 22583 22584 ------------------ 22585 -- Refined_Post -- 22586 ------------------ 22587 22588 -- pragma Refined_Post (boolean_EXPRESSION); 22589 22590 -- Characteristics: 22591 22592 -- * Analysis - The annotation is fully analyzed immediately upon 22593 -- elaboration as it cannot forward reference entities. 22594 22595 -- * Expansion - The annotation is expanded during the expansion of 22596 -- the related subprogram body contract as performed in: 22597 22598 -- Expand_Subprogram_Contract 22599 22600 -- * Template - The annotation utilizes the generic template of the 22601 -- related subprogram body. 22602 22603 -- * Globals - Capture of global references must occur after full 22604 -- analysis. 22605 22606 -- * Instance - The annotation is instantiated automatically when 22607 -- the related generic subprogram body is instantiated. 22608 22609 when Pragma_Refined_Post => Refined_Post : declare 22610 Body_Id : Entity_Id; 22611 Legal : Boolean; 22612 Spec_Id : Entity_Id; 22613 22614 begin 22615 Analyze_Refined_Depends_Global_Post (Spec_Id, Body_Id, Legal); 22616 22617 -- Fully analyze the pragma when it appears inside a subprogram 22618 -- body because it cannot benefit from forward references. 22619 22620 if Legal then 22621 22622 -- Chain the pragma on the contract for completeness 22623 22624 Add_Contract_Item (N, Body_Id); 22625 22626 -- The legality checks of pragma Refined_Post are affected by 22627 -- the SPARK mode in effect and the volatility of the context. 22628 -- Analyze all pragmas in a specific order. 22629 22630 Analyze_If_Present (Pragma_SPARK_Mode); 22631 Analyze_If_Present (Pragma_Volatile_Function); 22632 Analyze_Pre_Post_Condition_In_Decl_Part (N); 22633 22634 -- Currently it is not possible to inline pre/postconditions on 22635 -- a subprogram subject to pragma Inline_Always. 22636 22637 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 22638 end if; 22639 end Refined_Post; 22640 22641 ------------------- 22642 -- Refined_State -- 22643 ------------------- 22644 22645 -- pragma Refined_State (REFINEMENT_LIST); 22646 22647 -- REFINEMENT_LIST ::= 22648 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE}) 22649 22650 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST 22651 22652 -- CONSTITUENT_LIST ::= 22653 -- null 22654 -- | CONSTITUENT 22655 -- | (CONSTITUENT {, CONSTITUENT}) 22656 22657 -- CONSTITUENT ::= object_NAME | state_NAME 22658 22659 -- Characteristics: 22660 22661 -- * Analysis - The annotation undergoes initial checks to verify 22662 -- the legal placement and context. Secondary checks preanalyze the 22663 -- refinement clauses in: 22664 22665 -- Analyze_Refined_State_In_Decl_Part 22666 22667 -- * Expansion - None. 22668 22669 -- * Template - The annotation utilizes the template of the related 22670 -- package body. 22671 22672 -- * Globals - Capture of global references must occur after full 22673 -- analysis. 22674 22675 -- * Instance - The annotation is instantiated automatically when 22676 -- the related generic package body is instantiated. 22677 22678 when Pragma_Refined_State => Refined_State : declare 22679 Pack_Decl : Node_Id; 22680 Spec_Id : Entity_Id; 22681 22682 begin 22683 GNAT_Pragma; 22684 Check_No_Identifiers; 22685 Check_Arg_Count (1); 22686 22687 Pack_Decl := Find_Related_Package_Or_Body (N, Do_Checks => True); 22688 22689 if Nkind (Pack_Decl) /= N_Package_Body then 22690 Pragma_Misplaced; 22691 return; 22692 end if; 22693 22694 Spec_Id := Corresponding_Spec (Pack_Decl); 22695 22696 -- A pragma that applies to a Ghost entity becomes Ghost for the 22697 -- purposes of legality checks and removal of ignored Ghost code. 22698 22699 Mark_Ghost_Pragma (N, Spec_Id); 22700 22701 -- Chain the pragma on the contract for further processing by 22702 -- Analyze_Refined_State_In_Decl_Part. 22703 22704 Add_Contract_Item (N, Defining_Entity (Pack_Decl)); 22705 22706 -- The legality checks of pragma Refined_State are affected by the 22707 -- SPARK mode in effect. Analyze all pragmas in a specific order. 22708 22709 Analyze_If_Present (Pragma_SPARK_Mode); 22710 22711 -- State refinement is allowed only when the corresponding package 22712 -- declaration has non-null pragma Abstract_State. Refinement not 22713 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)). 22714 22715 if SPARK_Mode /= Off 22716 and then 22717 (No (Abstract_States (Spec_Id)) 22718 or else Has_Null_Abstract_State (Spec_Id)) 22719 then 22720 Error_Msg_NE 22721 ("useless refinement, package & does not define abstract " 22722 & "states", N, Spec_Id); 22723 return; 22724 end if; 22725 end Refined_State; 22726 22727 ----------------------- 22728 -- Relative_Deadline -- 22729 ----------------------- 22730 22731 -- pragma Relative_Deadline (time_span_EXPRESSION); 22732 22733 when Pragma_Relative_Deadline => Relative_Deadline : declare 22734 P : constant Node_Id := Parent (N); 22735 Arg : Node_Id; 22736 22737 begin 22738 Ada_2005_Pragma; 22739 Check_No_Identifiers; 22740 Check_Arg_Count (1); 22741 22742 Arg := Get_Pragma_Arg (Arg1); 22743 22744 -- The expression must be analyzed in the special manner described 22745 -- in "Handling of Default and Per-Object Expressions" in sem.ads. 22746 22747 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); 22748 22749 -- Subprogram case 22750 22751 if Nkind (P) = N_Subprogram_Body then 22752 Check_In_Main_Program; 22753 22754 -- Only Task and subprogram cases allowed 22755 22756 elsif Nkind (P) /= N_Task_Definition then 22757 Pragma_Misplaced; 22758 end if; 22759 22760 -- Check duplicate pragma before we set the corresponding flag 22761 22762 if Has_Relative_Deadline_Pragma (P) then 22763 Error_Pragma ("duplicate pragma% not allowed"); 22764 end if; 22765 22766 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that 22767 -- Relative_Deadline pragma node cannot be inserted in the Rep 22768 -- Item chain of Ent since it is rewritten by the expander as a 22769 -- procedure call statement that will break the chain. 22770 22771 Set_Has_Relative_Deadline_Pragma (P); 22772 end Relative_Deadline; 22773 22774 ------------------------ 22775 -- Remote_Access_Type -- 22776 ------------------------ 22777 22778 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME); 22779 22780 when Pragma_Remote_Access_Type => Remote_Access_Type : declare 22781 E : Entity_Id; 22782 22783 begin 22784 GNAT_Pragma; 22785 Check_Arg_Count (1); 22786 Check_Optional_Identifier (Arg1, Name_Entity); 22787 Check_Arg_Is_Local_Name (Arg1); 22788 22789 E := Entity (Get_Pragma_Arg (Arg1)); 22790 22791 -- A pragma that applies to a Ghost entity becomes Ghost for the 22792 -- purposes of legality checks and removal of ignored Ghost code. 22793 22794 Mark_Ghost_Pragma (N, E); 22795 22796 if Nkind (Parent (E)) = N_Formal_Type_Declaration 22797 and then Ekind (E) = E_General_Access_Type 22798 and then Is_Class_Wide_Type (Directly_Designated_Type (E)) 22799 and then Scope (Root_Type (Directly_Designated_Type (E))) 22800 = Scope (E) 22801 and then Is_Valid_Remote_Object_Type 22802 (Root_Type (Directly_Designated_Type (E))) 22803 then 22804 Set_Is_Remote_Types (E); 22805 22806 else 22807 Error_Pragma_Arg 22808 ("pragma% applies only to formal access-to-class-wide types", 22809 Arg1); 22810 end if; 22811 end Remote_Access_Type; 22812 22813 --------------------------- 22814 -- Remote_Call_Interface -- 22815 --------------------------- 22816 22817 -- pragma Remote_Call_Interface [(library_unit_NAME)]; 22818 22819 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare 22820 Cunit_Node : Node_Id; 22821 Cunit_Ent : Entity_Id; 22822 K : Node_Kind; 22823 22824 begin 22825 Check_Ada_83_Warning; 22826 Check_Valid_Library_Unit_Pragma; 22827 22828 if Nkind (N) = N_Null_Statement then 22829 return; 22830 end if; 22831 22832 Cunit_Node := Cunit (Current_Sem_Unit); 22833 K := Nkind (Unit (Cunit_Node)); 22834 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 22835 22836 -- A pragma that applies to a Ghost entity becomes Ghost for the 22837 -- purposes of legality checks and removal of ignored Ghost code. 22838 22839 Mark_Ghost_Pragma (N, Cunit_Ent); 22840 22841 if K = N_Package_Declaration 22842 or else K = N_Generic_Package_Declaration 22843 or else K = N_Subprogram_Declaration 22844 or else K = N_Generic_Subprogram_Declaration 22845 or else (K = N_Subprogram_Body 22846 and then Acts_As_Spec (Unit (Cunit_Node))) 22847 then 22848 null; 22849 else 22850 Error_Pragma ( 22851 "pragma% must apply to package or subprogram declaration"); 22852 end if; 22853 22854 Set_Is_Remote_Call_Interface (Cunit_Ent); 22855 end Remote_Call_Interface; 22856 22857 ------------------ 22858 -- Remote_Types -- 22859 ------------------ 22860 22861 -- pragma Remote_Types [(library_unit_NAME)]; 22862 22863 when Pragma_Remote_Types => Remote_Types : declare 22864 Cunit_Node : Node_Id; 22865 Cunit_Ent : Entity_Id; 22866 22867 begin 22868 Check_Ada_83_Warning; 22869 Check_Valid_Library_Unit_Pragma; 22870 22871 if Nkind (N) = N_Null_Statement then 22872 return; 22873 end if; 22874 22875 Cunit_Node := Cunit (Current_Sem_Unit); 22876 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 22877 22878 -- A pragma that applies to a Ghost entity becomes Ghost for the 22879 -- purposes of legality checks and removal of ignored Ghost code. 22880 22881 Mark_Ghost_Pragma (N, Cunit_Ent); 22882 22883 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 22884 N_Generic_Package_Declaration) 22885 then 22886 Error_Pragma 22887 ("pragma% can only apply to a package declaration"); 22888 end if; 22889 22890 Set_Is_Remote_Types (Cunit_Ent); 22891 end Remote_Types; 22892 22893 --------------- 22894 -- Ravenscar -- 22895 --------------- 22896 22897 -- pragma Ravenscar; 22898 22899 when Pragma_Ravenscar => 22900 GNAT_Pragma; 22901 Check_Arg_Count (0); 22902 Check_Valid_Configuration_Pragma; 22903 Set_Ravenscar_Profile (Ravenscar, N); 22904 22905 if Warn_On_Obsolescent_Feature then 22906 Error_Msg_N 22907 ("pragma Ravenscar is an obsolescent feature?j?", N); 22908 Error_Msg_N 22909 ("|use pragma Profile (Ravenscar) instead?j?", N); 22910 end if; 22911 22912 ------------------------- 22913 -- Restricted_Run_Time -- 22914 ------------------------- 22915 22916 -- pragma Restricted_Run_Time; 22917 22918 when Pragma_Restricted_Run_Time => 22919 GNAT_Pragma; 22920 Check_Arg_Count (0); 22921 Check_Valid_Configuration_Pragma; 22922 Set_Profile_Restrictions 22923 (Restricted, N, Warn => Treat_Restrictions_As_Warnings); 22924 22925 if Warn_On_Obsolescent_Feature then 22926 Error_Msg_N 22927 ("pragma Restricted_Run_Time is an obsolescent feature?j?", 22928 N); 22929 Error_Msg_N 22930 ("|use pragma Profile (Restricted) instead?j?", N); 22931 end if; 22932 22933 ------------------ 22934 -- Restrictions -- 22935 ------------------ 22936 22937 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 22938 22939 -- RESTRICTION ::= 22940 -- restriction_IDENTIFIER 22941 -- | restriction_parameter_IDENTIFIER => EXPRESSION 22942 22943 when Pragma_Restrictions => 22944 Process_Restrictions_Or_Restriction_Warnings 22945 (Warn => Treat_Restrictions_As_Warnings); 22946 22947 -------------------------- 22948 -- Restriction_Warnings -- 22949 -------------------------- 22950 22951 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 22952 22953 -- RESTRICTION ::= 22954 -- restriction_IDENTIFIER 22955 -- | restriction_parameter_IDENTIFIER => EXPRESSION 22956 22957 when Pragma_Restriction_Warnings => 22958 GNAT_Pragma; 22959 Process_Restrictions_Or_Restriction_Warnings (Warn => True); 22960 22961 ---------------- 22962 -- Reviewable -- 22963 ---------------- 22964 22965 -- pragma Reviewable; 22966 22967 when Pragma_Reviewable => 22968 Check_Ada_83_Warning; 22969 Check_Arg_Count (0); 22970 22971 -- Call dummy debugging function rv. This is done to assist front 22972 -- end debugging. By placing a Reviewable pragma in the source 22973 -- program, a breakpoint on rv catches this place in the source, 22974 -- allowing convenient stepping to the point of interest. 22975 22976 rv; 22977 22978 -------------------------- 22979 -- Secondary_Stack_Size -- 22980 -------------------------- 22981 22982 -- pragma Secondary_Stack_Size (EXPRESSION); 22983 22984 when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare 22985 P : constant Node_Id := Parent (N); 22986 Arg : Node_Id; 22987 Ent : Entity_Id; 22988 22989 begin 22990 GNAT_Pragma; 22991 Check_No_Identifiers; 22992 Check_Arg_Count (1); 22993 22994 if Nkind (P) = N_Task_Definition then 22995 Arg := Get_Pragma_Arg (Arg1); 22996 Ent := Defining_Identifier (Parent (P)); 22997 22998 -- The expression must be analyzed in the special manner 22999 -- described in "Handling of Default Expressions" in sem.ads. 23000 23001 Preanalyze_Spec_Expression (Arg, Any_Integer); 23002 23003 -- The pragma cannot appear if the No_Secondary_Stack 23004 -- restriction is in effect. 23005 23006 Check_Restriction (No_Secondary_Stack, Arg); 23007 23008 -- Anything else is incorrect 23009 23010 else 23011 Pragma_Misplaced; 23012 end if; 23013 23014 -- Check duplicate pragma before we chain the pragma in the Rep 23015 -- Item chain of Ent. 23016 23017 Check_Duplicate_Pragma (Ent); 23018 Record_Rep_Item (Ent, N); 23019 end Secondary_Stack_Size; 23020 23021 -------------------------- 23022 -- Short_Circuit_And_Or -- 23023 -------------------------- 23024 23025 -- pragma Short_Circuit_And_Or; 23026 23027 when Pragma_Short_Circuit_And_Or => 23028 GNAT_Pragma; 23029 Check_Arg_Count (0); 23030 Check_Valid_Configuration_Pragma; 23031 Short_Circuit_And_Or := True; 23032 23033 ------------------- 23034 -- Share_Generic -- 23035 ------------------- 23036 23037 -- pragma Share_Generic (GNAME {, GNAME}); 23038 23039 -- GNAME ::= generic_unit_NAME | generic_instance_NAME 23040 23041 when Pragma_Share_Generic => 23042 GNAT_Pragma; 23043 Process_Generic_List; 23044 23045 ------------ 23046 -- Shared -- 23047 ------------ 23048 23049 -- pragma Shared (LOCAL_NAME); 23050 23051 when Pragma_Shared => 23052 GNAT_Pragma; 23053 Process_Atomic_Independent_Shared_Volatile; 23054 23055 -------------------- 23056 -- Shared_Passive -- 23057 -------------------- 23058 23059 -- pragma Shared_Passive [(library_unit_NAME)]; 23060 23061 -- Set the flag Is_Shared_Passive of program unit name entity 23062 23063 when Pragma_Shared_Passive => Shared_Passive : declare 23064 Cunit_Node : Node_Id; 23065 Cunit_Ent : Entity_Id; 23066 23067 begin 23068 Check_Ada_83_Warning; 23069 Check_Valid_Library_Unit_Pragma; 23070 23071 if Nkind (N) = N_Null_Statement then 23072 return; 23073 end if; 23074 23075 Cunit_Node := Cunit (Current_Sem_Unit); 23076 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 23077 23078 -- A pragma that applies to a Ghost entity becomes Ghost for the 23079 -- purposes of legality checks and removal of ignored Ghost code. 23080 23081 Mark_Ghost_Pragma (N, Cunit_Ent); 23082 23083 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 23084 N_Generic_Package_Declaration) 23085 then 23086 Error_Pragma 23087 ("pragma% can only apply to a package declaration"); 23088 end if; 23089 23090 Set_Is_Shared_Passive (Cunit_Ent); 23091 end Shared_Passive; 23092 23093 ----------------------- 23094 -- Short_Descriptors -- 23095 ----------------------- 23096 23097 -- pragma Short_Descriptors; 23098 23099 -- Recognize and validate, but otherwise ignore 23100 23101 when Pragma_Short_Descriptors => 23102 GNAT_Pragma; 23103 Check_Arg_Count (0); 23104 Check_Valid_Configuration_Pragma; 23105 23106 ------------------------------ 23107 -- Simple_Storage_Pool_Type -- 23108 ------------------------------ 23109 23110 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME); 23111 23112 when Pragma_Simple_Storage_Pool_Type => 23113 Simple_Storage_Pool_Type : declare 23114 Typ : Entity_Id; 23115 Type_Id : Node_Id; 23116 23117 begin 23118 GNAT_Pragma; 23119 Check_Arg_Count (1); 23120 Check_Arg_Is_Library_Level_Local_Name (Arg1); 23121 23122 Type_Id := Get_Pragma_Arg (Arg1); 23123 Find_Type (Type_Id); 23124 Typ := Entity (Type_Id); 23125 23126 if Typ = Any_Type then 23127 return; 23128 end if; 23129 23130 -- A pragma that applies to a Ghost entity becomes Ghost for the 23131 -- purposes of legality checks and removal of ignored Ghost code. 23132 23133 Mark_Ghost_Pragma (N, Typ); 23134 23135 -- We require the pragma to apply to a type declared in a package 23136 -- declaration, but not (immediately) within a package body. 23137 23138 if Ekind (Current_Scope) /= E_Package 23139 or else In_Package_Body (Current_Scope) 23140 then 23141 Error_Pragma 23142 ("pragma% can only apply to type declared immediately " 23143 & "within a package declaration"); 23144 end if; 23145 23146 -- A simple storage pool type must be an immutably limited record 23147 -- or private type. If the pragma is given for a private type, 23148 -- the full type is similarly restricted (which is checked later 23149 -- in Freeze_Entity). 23150 23151 if Is_Record_Type (Typ) 23152 and then not Is_Limited_View (Typ) 23153 then 23154 Error_Pragma 23155 ("pragma% can only apply to explicitly limited record type"); 23156 23157 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then 23158 Error_Pragma 23159 ("pragma% can only apply to a private type that is limited"); 23160 23161 elsif not Is_Record_Type (Typ) 23162 and then not Is_Private_Type (Typ) 23163 then 23164 Error_Pragma 23165 ("pragma% can only apply to limited record or private type"); 23166 end if; 23167 23168 Record_Rep_Item (Typ, N); 23169 end Simple_Storage_Pool_Type; 23170 23171 ---------------------- 23172 -- Source_File_Name -- 23173 ---------------------- 23174 23175 -- There are five forms for this pragma: 23176 23177 -- pragma Source_File_Name ( 23178 -- [UNIT_NAME =>] unit_NAME, 23179 -- BODY_FILE_NAME => STRING_LITERAL 23180 -- [, [INDEX =>] INTEGER_LITERAL]); 23181 23182 -- pragma Source_File_Name ( 23183 -- [UNIT_NAME =>] unit_NAME, 23184 -- SPEC_FILE_NAME => STRING_LITERAL 23185 -- [, [INDEX =>] INTEGER_LITERAL]); 23186 23187 -- pragma Source_File_Name ( 23188 -- BODY_FILE_NAME => STRING_LITERAL 23189 -- [, DOT_REPLACEMENT => STRING_LITERAL] 23190 -- [, CASING => CASING_SPEC]); 23191 23192 -- pragma Source_File_Name ( 23193 -- SPEC_FILE_NAME => STRING_LITERAL 23194 -- [, DOT_REPLACEMENT => STRING_LITERAL] 23195 -- [, CASING => CASING_SPEC]); 23196 23197 -- pragma Source_File_Name ( 23198 -- SUBUNIT_FILE_NAME => STRING_LITERAL 23199 -- [, DOT_REPLACEMENT => STRING_LITERAL] 23200 -- [, CASING => CASING_SPEC]); 23201 23202 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 23203 23204 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 23205 -- Source_File_Name (SFN), however their usage is exclusive: SFN can 23206 -- only be used when no project file is used, while SFNP can only be 23207 -- used when a project file is used. 23208 23209 -- No processing here. Processing was completed during parsing, since 23210 -- we need to have file names set as early as possible. Units are 23211 -- loaded well before semantic processing starts. 23212 23213 -- The only processing we defer to this point is the check for 23214 -- correct placement. 23215 23216 when Pragma_Source_File_Name => 23217 GNAT_Pragma; 23218 Check_Valid_Configuration_Pragma; 23219 23220 ------------------------------ 23221 -- Source_File_Name_Project -- 23222 ------------------------------ 23223 23224 -- See Source_File_Name for syntax 23225 23226 -- No processing here. Processing was completed during parsing, since 23227 -- we need to have file names set as early as possible. Units are 23228 -- loaded well before semantic processing starts. 23229 23230 -- The only processing we defer to this point is the check for 23231 -- correct placement. 23232 23233 when Pragma_Source_File_Name_Project => 23234 GNAT_Pragma; 23235 Check_Valid_Configuration_Pragma; 23236 23237 -- Check that a pragma Source_File_Name_Project is used only in a 23238 -- configuration pragmas file. 23239 23240 -- Pragmas Source_File_Name_Project should only be generated by 23241 -- the Project Manager in configuration pragmas files. 23242 23243 -- This is really an ugly test. It seems to depend on some 23244 -- accidental and undocumented property. At the very least it 23245 -- needs to be documented, but it would be better to have a 23246 -- clean way of testing if we are in a configuration file??? 23247 23248 if Present (Parent (N)) then 23249 Error_Pragma 23250 ("pragma% can only appear in a configuration pragmas file"); 23251 end if; 23252 23253 ---------------------- 23254 -- Source_Reference -- 23255 ---------------------- 23256 23257 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); 23258 23259 -- Nothing to do, all processing completed in Par.Prag, since we need 23260 -- the information for possible parser messages that are output. 23261 23262 when Pragma_Source_Reference => 23263 GNAT_Pragma; 23264 23265 ---------------- 23266 -- SPARK_Mode -- 23267 ---------------- 23268 23269 -- pragma SPARK_Mode [(On | Off)]; 23270 23271 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare 23272 Mode_Id : SPARK_Mode_Type; 23273 23274 procedure Check_Pragma_Conformance 23275 (Context_Pragma : Node_Id; 23276 Entity : Entity_Id; 23277 Entity_Pragma : Node_Id); 23278 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode 23279 -- conformance of pragma N depending the following scenarios: 23280 -- 23281 -- If pragma Context_Pragma is not Empty, verify that pragma N is 23282 -- compatible with the pragma Context_Pragma that was inherited 23283 -- from the context: 23284 -- * If the mode of Context_Pragma is ON, then the new mode can 23285 -- be anything. 23286 -- * If the mode of Context_Pragma is OFF, then the only allowed 23287 -- new mode is also OFF. Emit error if this is not the case. 23288 -- 23289 -- If Entity is not Empty, verify that pragma N is compatible with 23290 -- pragma Entity_Pragma that belongs to Entity. 23291 -- * If Entity_Pragma is Empty, always issue an error as this 23292 -- corresponds to the case where a previous section of Entity 23293 -- has no SPARK_Mode set. 23294 -- * If the mode of Entity_Pragma is ON, then the new mode can 23295 -- be anything. 23296 -- * If the mode of Entity_Pragma is OFF, then the only allowed 23297 -- new mode is also OFF. Emit error if this is not the case. 23298 23299 procedure Check_Library_Level_Entity (E : Entity_Id); 23300 -- Subsidiary to routines Process_xxx. Verify that the related 23301 -- entity E subject to pragma SPARK_Mode is library-level. 23302 23303 procedure Process_Body (Decl : Node_Id); 23304 -- Verify the legality of pragma SPARK_Mode when it appears as the 23305 -- top of the body declarations of entry, package, protected unit, 23306 -- subprogram or task unit body denoted by Decl. 23307 23308 procedure Process_Overloadable (Decl : Node_Id); 23309 -- Verify the legality of pragma SPARK_Mode when it applies to an 23310 -- entry or [generic] subprogram declaration denoted by Decl. 23311 23312 procedure Process_Private_Part (Decl : Node_Id); 23313 -- Verify the legality of pragma SPARK_Mode when it appears at the 23314 -- top of the private declarations of a package spec, protected or 23315 -- task unit declaration denoted by Decl. 23316 23317 procedure Process_Statement_Part (Decl : Node_Id); 23318 -- Verify the legality of pragma SPARK_Mode when it appears at the 23319 -- top of the statement sequence of a package body denoted by node 23320 -- Decl. 23321 23322 procedure Process_Visible_Part (Decl : Node_Id); 23323 -- Verify the legality of pragma SPARK_Mode when it appears at the 23324 -- top of the visible declarations of a package spec, protected or 23325 -- task unit declaration denoted by Decl. The routine is also used 23326 -- on protected or task units declared without a definition. 23327 23328 procedure Set_SPARK_Context; 23329 -- Subsidiary to routines Process_xxx. Set the global variables 23330 -- which represent the mode of the context from pragma N. Ensure 23331 -- that Dynamic_Elaboration_Checks are off if the new mode is On. 23332 23333 ------------------------------ 23334 -- Check_Pragma_Conformance -- 23335 ------------------------------ 23336 23337 procedure Check_Pragma_Conformance 23338 (Context_Pragma : Node_Id; 23339 Entity : Entity_Id; 23340 Entity_Pragma : Node_Id) 23341 is 23342 Err_Id : Entity_Id; 23343 Err_N : Node_Id; 23344 23345 begin 23346 -- The current pragma may appear without an argument. If this 23347 -- is the case, associate all error messages with the pragma 23348 -- itself. 23349 23350 if Present (Arg1) then 23351 Err_N := Arg1; 23352 else 23353 Err_N := N; 23354 end if; 23355 23356 -- The mode of the current pragma is compared against that of 23357 -- an enclosing context. 23358 23359 if Present (Context_Pragma) then 23360 pragma Assert (Nkind (Context_Pragma) = N_Pragma); 23361 23362 -- Issue an error if the new mode is less restrictive than 23363 -- that of the context. 23364 23365 if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off 23366 and then Get_SPARK_Mode_From_Annotation (N) = On 23367 then 23368 Error_Msg_N 23369 ("cannot change SPARK_Mode from Off to On", Err_N); 23370 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); 23371 Error_Msg_N ("\SPARK_Mode was set to Off#", Err_N); 23372 raise Pragma_Exit; 23373 end if; 23374 end if; 23375 23376 -- The mode of the current pragma is compared against that of 23377 -- an initial package, protected type, subprogram or task type 23378 -- declaration. 23379 23380 if Present (Entity) then 23381 23382 -- A simple protected or task type is transformed into an 23383 -- anonymous type whose name cannot be used to issue error 23384 -- messages. Recover the original entity of the type. 23385 23386 if Ekind_In (Entity, E_Protected_Type, E_Task_Type) then 23387 Err_Id := 23388 Defining_Entity 23389 (Original_Node (Unit_Declaration_Node (Entity))); 23390 else 23391 Err_Id := Entity; 23392 end if; 23393 23394 -- Both the initial declaration and the completion carry 23395 -- SPARK_Mode pragmas. 23396 23397 if Present (Entity_Pragma) then 23398 pragma Assert (Nkind (Entity_Pragma) = N_Pragma); 23399 23400 -- Issue an error if the new mode is less restrictive 23401 -- than that of the initial declaration. 23402 23403 if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off 23404 and then Get_SPARK_Mode_From_Annotation (N) = On 23405 then 23406 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); 23407 Error_Msg_Sloc := Sloc (Entity_Pragma); 23408 Error_Msg_NE 23409 ("\value Off was set for SPARK_Mode on&#", 23410 Err_N, Err_Id); 23411 raise Pragma_Exit; 23412 end if; 23413 23414 -- Otherwise the initial declaration lacks a SPARK_Mode 23415 -- pragma in which case the current pragma is illegal as 23416 -- it cannot "complete". 23417 23418 else 23419 Error_Msg_N ("incorrect use of SPARK_Mode", Err_N); 23420 Error_Msg_Sloc := Sloc (Err_Id); 23421 Error_Msg_NE 23422 ("\no value was set for SPARK_Mode on&#", 23423 Err_N, Err_Id); 23424 raise Pragma_Exit; 23425 end if; 23426 end if; 23427 end Check_Pragma_Conformance; 23428 23429 -------------------------------- 23430 -- Check_Library_Level_Entity -- 23431 -------------------------------- 23432 23433 procedure Check_Library_Level_Entity (E : Entity_Id) is 23434 procedure Add_Entity_To_Name_Buffer; 23435 -- Add the E_Kind of entity E to the name buffer 23436 23437 ------------------------------- 23438 -- Add_Entity_To_Name_Buffer -- 23439 ------------------------------- 23440 23441 procedure Add_Entity_To_Name_Buffer is 23442 begin 23443 if Ekind_In (E, E_Entry, E_Entry_Family) then 23444 Add_Str_To_Name_Buffer ("entry"); 23445 23446 elsif Ekind_In (E, E_Generic_Package, 23447 E_Package, 23448 E_Package_Body) 23449 then 23450 Add_Str_To_Name_Buffer ("package"); 23451 23452 elsif Ekind_In (E, E_Protected_Body, E_Protected_Type) then 23453 Add_Str_To_Name_Buffer ("protected type"); 23454 23455 elsif Ekind_In (E, E_Function, 23456 E_Generic_Function, 23457 E_Generic_Procedure, 23458 E_Procedure, 23459 E_Subprogram_Body) 23460 then 23461 Add_Str_To_Name_Buffer ("subprogram"); 23462 23463 else 23464 pragma Assert (Ekind_In (E, E_Task_Body, E_Task_Type)); 23465 Add_Str_To_Name_Buffer ("task type"); 23466 end if; 23467 end Add_Entity_To_Name_Buffer; 23468 23469 -- Local variables 23470 23471 Msg_1 : constant String := "incorrect placement of pragma%"; 23472 Msg_2 : Name_Id; 23473 23474 -- Start of processing for Check_Library_Level_Entity 23475 23476 begin 23477 -- A SPARK_Mode of On shall only apply to library-level 23478 -- entities, except for those in generic instances, which are 23479 -- ignored (even if the entity gets SPARK_Mode pragma attached 23480 -- in the AST, its effect is not taken into account unless the 23481 -- context already provides SPARK_Mode of On in GNATprove). 23482 23483 if Get_SPARK_Mode_From_Annotation (N) = On 23484 and then not Is_Library_Level_Entity (E) 23485 and then Instantiation_Location (Sloc (N)) = No_Location 23486 then 23487 Error_Msg_Name_1 := Pname; 23488 Error_Msg_N (Fix_Error (Msg_1), N); 23489 23490 Name_Len := 0; 23491 Add_Str_To_Name_Buffer ("\& is not a library-level "); 23492 Add_Entity_To_Name_Buffer; 23493 23494 Msg_2 := Name_Find; 23495 Error_Msg_NE (Get_Name_String (Msg_2), N, E); 23496 23497 raise Pragma_Exit; 23498 end if; 23499 end Check_Library_Level_Entity; 23500 23501 ------------------ 23502 -- Process_Body -- 23503 ------------------ 23504 23505 procedure Process_Body (Decl : Node_Id) is 23506 Body_Id : constant Entity_Id := Defining_Entity (Decl); 23507 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Decl); 23508 23509 begin 23510 -- Ignore pragma when applied to the special body created for 23511 -- inlining, recognized by its internal name _Parent. 23512 23513 if Chars (Body_Id) = Name_uParent then 23514 return; 23515 end if; 23516 23517 Check_Library_Level_Entity (Body_Id); 23518 23519 -- For entry bodies, verify the legality against: 23520 -- * The mode of the context 23521 -- * The mode of the spec (if any) 23522 23523 if Nkind_In (Decl, N_Entry_Body, N_Subprogram_Body) then 23524 23525 -- A stand-alone subprogram body 23526 23527 if Body_Id = Spec_Id then 23528 Check_Pragma_Conformance 23529 (Context_Pragma => SPARK_Pragma (Body_Id), 23530 Entity => Empty, 23531 Entity_Pragma => Empty); 23532 23533 -- An entry or subprogram body that completes a previous 23534 -- declaration. 23535 23536 else 23537 Check_Pragma_Conformance 23538 (Context_Pragma => SPARK_Pragma (Body_Id), 23539 Entity => Spec_Id, 23540 Entity_Pragma => SPARK_Pragma (Spec_Id)); 23541 end if; 23542 23543 Set_SPARK_Context; 23544 Set_SPARK_Pragma (Body_Id, N); 23545 Set_SPARK_Pragma_Inherited (Body_Id, False); 23546 23547 -- For package bodies, verify the legality against: 23548 -- * The mode of the context 23549 -- * The mode of the private part 23550 23551 -- This case is separated from protected and task bodies 23552 -- because the statement part of the package body inherits 23553 -- the mode of the body declarations. 23554 23555 elsif Nkind (Decl) = N_Package_Body then 23556 Check_Pragma_Conformance 23557 (Context_Pragma => SPARK_Pragma (Body_Id), 23558 Entity => Spec_Id, 23559 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); 23560 23561 Set_SPARK_Context; 23562 Set_SPARK_Pragma (Body_Id, N); 23563 Set_SPARK_Pragma_Inherited (Body_Id, False); 23564 Set_SPARK_Aux_Pragma (Body_Id, N); 23565 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); 23566 23567 -- For protected and task bodies, verify the legality against: 23568 -- * The mode of the context 23569 -- * The mode of the private part 23570 23571 else 23572 pragma Assert 23573 (Nkind_In (Decl, N_Protected_Body, N_Task_Body)); 23574 23575 Check_Pragma_Conformance 23576 (Context_Pragma => SPARK_Pragma (Body_Id), 23577 Entity => Spec_Id, 23578 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id)); 23579 23580 Set_SPARK_Context; 23581 Set_SPARK_Pragma (Body_Id, N); 23582 Set_SPARK_Pragma_Inherited (Body_Id, False); 23583 end if; 23584 end Process_Body; 23585 23586 -------------------------- 23587 -- Process_Overloadable -- 23588 -------------------------- 23589 23590 procedure Process_Overloadable (Decl : Node_Id) is 23591 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 23592 Spec_Typ : constant Entity_Id := Etype (Spec_Id); 23593 23594 begin 23595 Check_Library_Level_Entity (Spec_Id); 23596 23597 -- Verify the legality against: 23598 -- * The mode of the context 23599 23600 Check_Pragma_Conformance 23601 (Context_Pragma => SPARK_Pragma (Spec_Id), 23602 Entity => Empty, 23603 Entity_Pragma => Empty); 23604 23605 Set_SPARK_Pragma (Spec_Id, N); 23606 Set_SPARK_Pragma_Inherited (Spec_Id, False); 23607 23608 -- When the pragma applies to the anonymous object created for 23609 -- a single task type, decorate the type as well. This scenario 23610 -- arises when the single task type lacks a task definition, 23611 -- therefore there is no issue with respect to a potential 23612 -- pragma SPARK_Mode in the private part. 23613 23614 -- task type Anon_Task_Typ; 23615 -- Obj : Anon_Task_Typ; 23616 -- pragma SPARK_Mode ...; 23617 23618 if Is_Single_Task_Object (Spec_Id) then 23619 Set_SPARK_Pragma (Spec_Typ, N); 23620 Set_SPARK_Pragma_Inherited (Spec_Typ, False); 23621 Set_SPARK_Aux_Pragma (Spec_Typ, N); 23622 Set_SPARK_Aux_Pragma_Inherited (Spec_Typ, True); 23623 end if; 23624 end Process_Overloadable; 23625 23626 -------------------------- 23627 -- Process_Private_Part -- 23628 -------------------------- 23629 23630 procedure Process_Private_Part (Decl : Node_Id) is 23631 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 23632 23633 begin 23634 Check_Library_Level_Entity (Spec_Id); 23635 23636 -- Verify the legality against: 23637 -- * The mode of the visible declarations 23638 23639 Check_Pragma_Conformance 23640 (Context_Pragma => Empty, 23641 Entity => Spec_Id, 23642 Entity_Pragma => SPARK_Pragma (Spec_Id)); 23643 23644 Set_SPARK_Context; 23645 Set_SPARK_Aux_Pragma (Spec_Id, N); 23646 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); 23647 end Process_Private_Part; 23648 23649 ---------------------------- 23650 -- Process_Statement_Part -- 23651 ---------------------------- 23652 23653 procedure Process_Statement_Part (Decl : Node_Id) is 23654 Body_Id : constant Entity_Id := Defining_Entity (Decl); 23655 23656 begin 23657 Check_Library_Level_Entity (Body_Id); 23658 23659 -- Verify the legality against: 23660 -- * The mode of the body declarations 23661 23662 Check_Pragma_Conformance 23663 (Context_Pragma => Empty, 23664 Entity => Body_Id, 23665 Entity_Pragma => SPARK_Pragma (Body_Id)); 23666 23667 Set_SPARK_Context; 23668 Set_SPARK_Aux_Pragma (Body_Id, N); 23669 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); 23670 end Process_Statement_Part; 23671 23672 -------------------------- 23673 -- Process_Visible_Part -- 23674 -------------------------- 23675 23676 procedure Process_Visible_Part (Decl : Node_Id) is 23677 Spec_Id : constant Entity_Id := Defining_Entity (Decl); 23678 Obj_Id : Entity_Id; 23679 23680 begin 23681 Check_Library_Level_Entity (Spec_Id); 23682 23683 -- Verify the legality against: 23684 -- * The mode of the context 23685 23686 Check_Pragma_Conformance 23687 (Context_Pragma => SPARK_Pragma (Spec_Id), 23688 Entity => Empty, 23689 Entity_Pragma => Empty); 23690 23691 -- A task unit declared without a definition does not set the 23692 -- SPARK_Mode of the context because the task does not have any 23693 -- entries that could inherit the mode. 23694 23695 if not Nkind_In (Decl, N_Single_Task_Declaration, 23696 N_Task_Type_Declaration) 23697 then 23698 Set_SPARK_Context; 23699 end if; 23700 23701 Set_SPARK_Pragma (Spec_Id, N); 23702 Set_SPARK_Pragma_Inherited (Spec_Id, False); 23703 Set_SPARK_Aux_Pragma (Spec_Id, N); 23704 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); 23705 23706 -- When the pragma applies to a single protected or task type, 23707 -- decorate the corresponding anonymous object as well. 23708 23709 -- protected Anon_Prot_Typ is 23710 -- pragma SPARK_Mode ...; 23711 -- ... 23712 -- end Anon_Prot_Typ; 23713 23714 -- Obj : Anon_Prot_Typ; 23715 23716 if Is_Single_Concurrent_Type (Spec_Id) then 23717 Obj_Id := Anonymous_Object (Spec_Id); 23718 23719 Set_SPARK_Pragma (Obj_Id, N); 23720 Set_SPARK_Pragma_Inherited (Obj_Id, False); 23721 end if; 23722 end Process_Visible_Part; 23723 23724 ----------------------- 23725 -- Set_SPARK_Context -- 23726 ----------------------- 23727 23728 procedure Set_SPARK_Context is 23729 begin 23730 SPARK_Mode := Mode_Id; 23731 SPARK_Mode_Pragma := N; 23732 end Set_SPARK_Context; 23733 23734 -- Local variables 23735 23736 Context : Node_Id; 23737 Mode : Name_Id; 23738 Stmt : Node_Id; 23739 23740 -- Start of processing for Do_SPARK_Mode 23741 23742 begin 23743 -- When a SPARK_Mode pragma appears inside an instantiation whose 23744 -- enclosing context has SPARK_Mode set to "off", the pragma has 23745 -- no semantic effect. 23746 23747 if Ignore_SPARK_Mode_Pragmas_In_Instance then 23748 Rewrite (N, Make_Null_Statement (Loc)); 23749 Analyze (N); 23750 return; 23751 end if; 23752 23753 GNAT_Pragma; 23754 Check_No_Identifiers; 23755 Check_At_Most_N_Arguments (1); 23756 23757 -- Check the legality of the mode (no argument = ON) 23758 23759 if Arg_Count = 1 then 23760 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 23761 Mode := Chars (Get_Pragma_Arg (Arg1)); 23762 else 23763 Mode := Name_On; 23764 end if; 23765 23766 Mode_Id := Get_SPARK_Mode_Type (Mode); 23767 Context := Parent (N); 23768 23769 -- The pragma appears in a configuration file 23770 23771 if No (Context) then 23772 Check_Valid_Configuration_Pragma; 23773 23774 if Present (SPARK_Mode_Pragma) then 23775 Duplication_Error 23776 (Prag => N, 23777 Prev => SPARK_Mode_Pragma); 23778 raise Pragma_Exit; 23779 end if; 23780 23781 Set_SPARK_Context; 23782 23783 -- The pragma acts as a configuration pragma in a compilation unit 23784 23785 -- pragma SPARK_Mode ...; 23786 -- package Pack is ...; 23787 23788 elsif Nkind (Context) = N_Compilation_Unit 23789 and then List_Containing (N) = Context_Items (Context) 23790 then 23791 Check_Valid_Configuration_Pragma; 23792 Set_SPARK_Context; 23793 23794 -- Otherwise the placement of the pragma within the tree dictates 23795 -- its associated construct. Inspect the declarative list where 23796 -- the pragma resides to find a potential construct. 23797 23798 else 23799 Stmt := Prev (N); 23800 while Present (Stmt) loop 23801 23802 -- Skip prior pragmas, but check for duplicates. Note that 23803 -- this also takes care of pragmas generated for aspects. 23804 23805 if Nkind (Stmt) = N_Pragma then 23806 if Pragma_Name (Stmt) = Pname then 23807 Duplication_Error 23808 (Prag => N, 23809 Prev => Stmt); 23810 raise Pragma_Exit; 23811 end if; 23812 23813 -- The pragma applies to an expression function that has 23814 -- already been rewritten into a subprogram declaration. 23815 23816 -- function Expr_Func return ... is (...); 23817 -- pragma SPARK_Mode ...; 23818 23819 elsif Nkind (Stmt) = N_Subprogram_Declaration 23820 and then Nkind (Original_Node (Stmt)) = 23821 N_Expression_Function 23822 then 23823 Process_Overloadable (Stmt); 23824 return; 23825 23826 -- The pragma applies to the anonymous object created for a 23827 -- single concurrent type. 23828 23829 -- protected type Anon_Prot_Typ ...; 23830 -- Obj : Anon_Prot_Typ; 23831 -- pragma SPARK_Mode ...; 23832 23833 elsif Nkind (Stmt) = N_Object_Declaration 23834 and then Is_Single_Concurrent_Object 23835 (Defining_Entity (Stmt)) 23836 then 23837 Process_Overloadable (Stmt); 23838 return; 23839 23840 -- Skip internally generated code 23841 23842 elsif not Comes_From_Source (Stmt) then 23843 null; 23844 23845 -- The pragma applies to an entry or [generic] subprogram 23846 -- declaration. 23847 23848 -- entry Ent ...; 23849 -- pragma SPARK_Mode ...; 23850 23851 -- [generic] 23852 -- procedure Proc ...; 23853 -- pragma SPARK_Mode ...; 23854 23855 elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, 23856 N_Subprogram_Declaration) 23857 or else (Nkind (Stmt) = N_Entry_Declaration 23858 and then Is_Protected_Type 23859 (Scope (Defining_Entity (Stmt)))) 23860 then 23861 Process_Overloadable (Stmt); 23862 return; 23863 23864 -- Otherwise the pragma does not apply to a legal construct 23865 -- or it does not appear at the top of a declarative or a 23866 -- statement list. Issue an error and stop the analysis. 23867 23868 else 23869 Pragma_Misplaced; 23870 exit; 23871 end if; 23872 23873 Prev (Stmt); 23874 end loop; 23875 23876 -- The pragma applies to a package or a subprogram that acts as 23877 -- a compilation unit. 23878 23879 -- procedure Proc ...; 23880 -- pragma SPARK_Mode ...; 23881 23882 if Nkind (Context) = N_Compilation_Unit_Aux then 23883 Context := Unit (Parent (Context)); 23884 end if; 23885 23886 -- The pragma appears at the top of entry, package, protected 23887 -- unit, subprogram or task unit body declarations. 23888 23889 -- entry Ent when ... is 23890 -- pragma SPARK_Mode ...; 23891 23892 -- package body Pack is 23893 -- pragma SPARK_Mode ...; 23894 23895 -- procedure Proc ... is 23896 -- pragma SPARK_Mode; 23897 23898 -- protected body Prot is 23899 -- pragma SPARK_Mode ...; 23900 23901 if Nkind_In (Context, N_Entry_Body, 23902 N_Package_Body, 23903 N_Protected_Body, 23904 N_Subprogram_Body, 23905 N_Task_Body) 23906 then 23907 Process_Body (Context); 23908 23909 -- The pragma appears at the top of the visible or private 23910 -- declaration of a package spec, protected or task unit. 23911 23912 -- package Pack is 23913 -- pragma SPARK_Mode ...; 23914 -- private 23915 -- pragma SPARK_Mode ...; 23916 23917 -- protected [type] Prot is 23918 -- pragma SPARK_Mode ...; 23919 -- private 23920 -- pragma SPARK_Mode ...; 23921 23922 elsif Nkind_In (Context, N_Package_Specification, 23923 N_Protected_Definition, 23924 N_Task_Definition) 23925 then 23926 if List_Containing (N) = Visible_Declarations (Context) then 23927 Process_Visible_Part (Parent (Context)); 23928 else 23929 Process_Private_Part (Parent (Context)); 23930 end if; 23931 23932 -- The pragma appears at the top of package body statements 23933 23934 -- package body Pack is 23935 -- begin 23936 -- pragma SPARK_Mode; 23937 23938 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements 23939 and then Nkind (Parent (Context)) = N_Package_Body 23940 then 23941 Process_Statement_Part (Parent (Context)); 23942 23943 -- The pragma appeared as an aspect of a [generic] subprogram 23944 -- declaration that acts as a compilation unit. 23945 23946 -- [generic] 23947 -- procedure Proc ...; 23948 -- pragma SPARK_Mode ...; 23949 23950 elsif Nkind_In (Context, N_Generic_Subprogram_Declaration, 23951 N_Subprogram_Declaration) 23952 then 23953 Process_Overloadable (Context); 23954 23955 -- The pragma does not apply to a legal construct, issue error 23956 23957 else 23958 Pragma_Misplaced; 23959 end if; 23960 end if; 23961 end Do_SPARK_Mode; 23962 23963 -------------------------------- 23964 -- Static_Elaboration_Desired -- 23965 -------------------------------- 23966 23967 -- pragma Static_Elaboration_Desired (DIRECT_NAME); 23968 23969 when Pragma_Static_Elaboration_Desired => 23970 GNAT_Pragma; 23971 Check_At_Most_N_Arguments (1); 23972 23973 if Is_Compilation_Unit (Current_Scope) 23974 and then Ekind (Current_Scope) = E_Package 23975 then 23976 Set_Static_Elaboration_Desired (Current_Scope, True); 23977 else 23978 Error_Pragma ("pragma% must apply to a library-level package"); 23979 end if; 23980 23981 ------------------ 23982 -- Storage_Size -- 23983 ------------------ 23984 23985 -- pragma Storage_Size (EXPRESSION); 23986 23987 when Pragma_Storage_Size => Storage_Size : declare 23988 P : constant Node_Id := Parent (N); 23989 Arg : Node_Id; 23990 23991 begin 23992 Check_No_Identifiers; 23993 Check_Arg_Count (1); 23994 23995 -- The expression must be analyzed in the special manner described 23996 -- in "Handling of Default Expressions" in sem.ads. 23997 23998 Arg := Get_Pragma_Arg (Arg1); 23999 Preanalyze_Spec_Expression (Arg, Any_Integer); 24000 24001 if not Is_OK_Static_Expression (Arg) then 24002 Check_Restriction (Static_Storage_Size, Arg); 24003 end if; 24004 24005 if Nkind (P) /= N_Task_Definition then 24006 Pragma_Misplaced; 24007 return; 24008 24009 else 24010 if Has_Storage_Size_Pragma (P) then 24011 Error_Pragma ("duplicate pragma% not allowed"); 24012 else 24013 Set_Has_Storage_Size_Pragma (P, True); 24014 end if; 24015 24016 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 24017 end if; 24018 end Storage_Size; 24019 24020 ------------------ 24021 -- Storage_Unit -- 24022 ------------------ 24023 24024 -- pragma Storage_Unit (NUMERIC_LITERAL); 24025 24026 -- Only permitted argument is System'Storage_Unit value 24027 24028 when Pragma_Storage_Unit => 24029 Check_No_Identifiers; 24030 Check_Arg_Count (1); 24031 Check_Arg_Is_Integer_Literal (Arg1); 24032 24033 if Intval (Get_Pragma_Arg (Arg1)) /= 24034 UI_From_Int (Ttypes.System_Storage_Unit) 24035 then 24036 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); 24037 Error_Pragma_Arg 24038 ("the only allowed argument for pragma% is ^", Arg1); 24039 end if; 24040 24041 -------------------- 24042 -- Stream_Convert -- 24043 -------------------- 24044 24045 -- pragma Stream_Convert ( 24046 -- [Entity =>] type_LOCAL_NAME, 24047 -- [Read =>] function_NAME, 24048 -- [Write =>] function NAME); 24049 24050 when Pragma_Stream_Convert => Stream_Convert : declare 24051 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); 24052 -- Check that the given argument is the name of a local function 24053 -- of one argument that is not overloaded earlier in the current 24054 -- local scope. A check is also made that the argument is a 24055 -- function with one parameter. 24056 24057 -------------------------------------- 24058 -- Check_OK_Stream_Convert_Function -- 24059 -------------------------------------- 24060 24061 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is 24062 Ent : Entity_Id; 24063 24064 begin 24065 Check_Arg_Is_Local_Name (Arg); 24066 Ent := Entity (Get_Pragma_Arg (Arg)); 24067 24068 if Has_Homonym (Ent) then 24069 Error_Pragma_Arg 24070 ("argument for pragma% may not be overloaded", Arg); 24071 end if; 24072 24073 if Ekind (Ent) /= E_Function 24074 or else No (First_Formal (Ent)) 24075 or else Present (Next_Formal (First_Formal (Ent))) 24076 then 24077 Error_Pragma_Arg 24078 ("argument for pragma% must be function of one argument", 24079 Arg); 24080 end if; 24081 end Check_OK_Stream_Convert_Function; 24082 24083 -- Start of processing for Stream_Convert 24084 24085 begin 24086 GNAT_Pragma; 24087 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write)); 24088 Check_Arg_Count (3); 24089 Check_Optional_Identifier (Arg1, Name_Entity); 24090 Check_Optional_Identifier (Arg2, Name_Read); 24091 Check_Optional_Identifier (Arg3, Name_Write); 24092 Check_Arg_Is_Local_Name (Arg1); 24093 Check_OK_Stream_Convert_Function (Arg2); 24094 Check_OK_Stream_Convert_Function (Arg3); 24095 24096 declare 24097 Typ : constant Entity_Id := 24098 Underlying_Type (Entity (Get_Pragma_Arg (Arg1))); 24099 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2)); 24100 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3)); 24101 24102 begin 24103 Check_First_Subtype (Arg1); 24104 24105 -- Check for too early or too late. Note that we don't enforce 24106 -- the rule about primitive operations in this case, since, as 24107 -- is the case for explicit stream attributes themselves, these 24108 -- restrictions are not appropriate. Note that the chaining of 24109 -- the pragma by Rep_Item_Too_Late is actually the critical 24110 -- processing done for this pragma. 24111 24112 if Rep_Item_Too_Early (Typ, N) 24113 or else 24114 Rep_Item_Too_Late (Typ, N, FOnly => True) 24115 then 24116 return; 24117 end if; 24118 24119 -- Return if previous error 24120 24121 if Etype (Typ) = Any_Type 24122 or else 24123 Etype (Read) = Any_Type 24124 or else 24125 Etype (Write) = Any_Type 24126 then 24127 return; 24128 end if; 24129 24130 -- Error checks 24131 24132 if Underlying_Type (Etype (Read)) /= Typ then 24133 Error_Pragma_Arg 24134 ("incorrect return type for function&", Arg2); 24135 end if; 24136 24137 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then 24138 Error_Pragma_Arg 24139 ("incorrect parameter type for function&", Arg3); 24140 end if; 24141 24142 if Underlying_Type (Etype (First_Formal (Read))) /= 24143 Underlying_Type (Etype (Write)) 24144 then 24145 Error_Pragma_Arg 24146 ("result type of & does not match Read parameter type", 24147 Arg3); 24148 end if; 24149 end; 24150 end Stream_Convert; 24151 24152 ------------------ 24153 -- Style_Checks -- 24154 ------------------ 24155 24156 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 24157 24158 -- This is processed by the parser since some of the style checks 24159 -- take place during source scanning and parsing. This means that 24160 -- we don't need to issue error messages here. 24161 24162 when Pragma_Style_Checks => Style_Checks : declare 24163 A : constant Node_Id := Get_Pragma_Arg (Arg1); 24164 S : String_Id; 24165 C : Char_Code; 24166 24167 begin 24168 GNAT_Pragma; 24169 Check_No_Identifiers; 24170 24171 -- Two argument form 24172 24173 if Arg_Count = 2 then 24174 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 24175 24176 declare 24177 E_Id : Node_Id; 24178 E : Entity_Id; 24179 24180 begin 24181 E_Id := Get_Pragma_Arg (Arg2); 24182 Analyze (E_Id); 24183 24184 if not Is_Entity_Name (E_Id) then 24185 Error_Pragma_Arg 24186 ("second argument of pragma% must be entity name", 24187 Arg2); 24188 end if; 24189 24190 E := Entity (E_Id); 24191 24192 if not Ignore_Style_Checks_Pragmas then 24193 if E = Any_Id then 24194 return; 24195 else 24196 loop 24197 Set_Suppress_Style_Checks 24198 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off); 24199 exit when No (Homonym (E)); 24200 E := Homonym (E); 24201 end loop; 24202 end if; 24203 end if; 24204 end; 24205 24206 -- One argument form 24207 24208 else 24209 Check_Arg_Count (1); 24210 24211 if Nkind (A) = N_String_Literal then 24212 S := Strval (A); 24213 24214 declare 24215 Slen : constant Natural := Natural (String_Length (S)); 24216 Options : String (1 .. Slen); 24217 J : Positive; 24218 24219 begin 24220 J := 1; 24221 loop 24222 C := Get_String_Char (S, Pos (J)); 24223 exit when not In_Character_Range (C); 24224 Options (J) := Get_Character (C); 24225 24226 -- If at end of string, set options. As per discussion 24227 -- above, no need to check for errors, since we issued 24228 -- them in the parser. 24229 24230 if J = Slen then 24231 if not Ignore_Style_Checks_Pragmas then 24232 Set_Style_Check_Options (Options); 24233 end if; 24234 24235 exit; 24236 end if; 24237 24238 J := J + 1; 24239 end loop; 24240 end; 24241 24242 elsif Nkind (A) = N_Identifier then 24243 if Chars (A) = Name_All_Checks then 24244 if not Ignore_Style_Checks_Pragmas then 24245 if GNAT_Mode then 24246 Set_GNAT_Style_Check_Options; 24247 else 24248 Set_Default_Style_Check_Options; 24249 end if; 24250 end if; 24251 24252 elsif Chars (A) = Name_On then 24253 if not Ignore_Style_Checks_Pragmas then 24254 Style_Check := True; 24255 end if; 24256 24257 elsif Chars (A) = Name_Off then 24258 if not Ignore_Style_Checks_Pragmas then 24259 Style_Check := False; 24260 end if; 24261 end if; 24262 end if; 24263 end if; 24264 end Style_Checks; 24265 24266 -------------- 24267 -- Subtitle -- 24268 -------------- 24269 24270 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL); 24271 24272 when Pragma_Subtitle => 24273 GNAT_Pragma; 24274 Check_Arg_Count (1); 24275 Check_Optional_Identifier (Arg1, Name_Subtitle); 24276 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 24277 Store_Note (N); 24278 24279 -------------- 24280 -- Suppress -- 24281 -------------- 24282 24283 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); 24284 24285 when Pragma_Suppress => 24286 Process_Suppress_Unsuppress (Suppress_Case => True); 24287 24288 ------------------ 24289 -- Suppress_All -- 24290 ------------------ 24291 24292 -- pragma Suppress_All; 24293 24294 -- The only check made here is that the pragma has no arguments. 24295 -- There are no placement rules, and the processing required (setting 24296 -- the Has_Pragma_Suppress_All flag in the compilation unit node was 24297 -- taken care of by the parser). Process_Compilation_Unit_Pragmas 24298 -- then creates and inserts a pragma Suppress (All_Checks). 24299 24300 when Pragma_Suppress_All => 24301 GNAT_Pragma; 24302 Check_Arg_Count (0); 24303 24304 ------------------------- 24305 -- Suppress_Debug_Info -- 24306 ------------------------- 24307 24308 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME); 24309 24310 when Pragma_Suppress_Debug_Info => Suppress_Debug_Info : declare 24311 Nam_Id : Entity_Id; 24312 24313 begin 24314 GNAT_Pragma; 24315 Check_Arg_Count (1); 24316 Check_Optional_Identifier (Arg1, Name_Entity); 24317 Check_Arg_Is_Local_Name (Arg1); 24318 24319 Nam_Id := Entity (Get_Pragma_Arg (Arg1)); 24320 24321 -- A pragma that applies to a Ghost entity becomes Ghost for the 24322 -- purposes of legality checks and removal of ignored Ghost code. 24323 24324 Mark_Ghost_Pragma (N, Nam_Id); 24325 Set_Debug_Info_Off (Nam_Id); 24326 end Suppress_Debug_Info; 24327 24328 ---------------------------------- 24329 -- Suppress_Exception_Locations -- 24330 ---------------------------------- 24331 24332 -- pragma Suppress_Exception_Locations; 24333 24334 when Pragma_Suppress_Exception_Locations => 24335 GNAT_Pragma; 24336 Check_Arg_Count (0); 24337 Check_Valid_Configuration_Pragma; 24338 Exception_Locations_Suppressed := True; 24339 24340 ----------------------------- 24341 -- Suppress_Initialization -- 24342 ----------------------------- 24343 24344 -- pragma Suppress_Initialization ([Entity =>] type_Name); 24345 24346 when Pragma_Suppress_Initialization => Suppress_Init : declare 24347 E : Entity_Id; 24348 E_Id : Node_Id; 24349 24350 begin 24351 GNAT_Pragma; 24352 Check_Arg_Count (1); 24353 Check_Optional_Identifier (Arg1, Name_Entity); 24354 Check_Arg_Is_Local_Name (Arg1); 24355 24356 E_Id := Get_Pragma_Arg (Arg1); 24357 24358 if Etype (E_Id) = Any_Type then 24359 return; 24360 end if; 24361 24362 E := Entity (E_Id); 24363 24364 -- A pragma that applies to a Ghost entity becomes Ghost for the 24365 -- purposes of legality checks and removal of ignored Ghost code. 24366 24367 Mark_Ghost_Pragma (N, E); 24368 24369 if not Is_Type (E) and then Ekind (E) /= E_Variable then 24370 Error_Pragma_Arg 24371 ("pragma% requires variable, type or subtype", Arg1); 24372 end if; 24373 24374 if Rep_Item_Too_Early (E, N) 24375 or else 24376 Rep_Item_Too_Late (E, N, FOnly => True) 24377 then 24378 return; 24379 end if; 24380 24381 -- For incomplete/private type, set flag on full view 24382 24383 if Is_Incomplete_Or_Private_Type (E) then 24384 if No (Full_View (Base_Type (E))) then 24385 Error_Pragma_Arg 24386 ("argument of pragma% cannot be an incomplete type", Arg1); 24387 else 24388 Set_Suppress_Initialization (Full_View (E)); 24389 end if; 24390 24391 -- For first subtype, set flag on base type 24392 24393 elsif Is_First_Subtype (E) then 24394 Set_Suppress_Initialization (Base_Type (E)); 24395 24396 -- For other than first subtype, set flag on subtype or variable 24397 24398 else 24399 Set_Suppress_Initialization (E); 24400 end if; 24401 end Suppress_Init; 24402 24403 ----------------- 24404 -- System_Name -- 24405 ----------------- 24406 24407 -- pragma System_Name (DIRECT_NAME); 24408 24409 -- Syntax check: one argument, which must be the identifier GNAT or 24410 -- the identifier GCC, no other identifiers are acceptable. 24411 24412 when Pragma_System_Name => 24413 GNAT_Pragma; 24414 Check_No_Identifiers; 24415 Check_Arg_Count (1); 24416 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); 24417 24418 ----------------------------- 24419 -- Task_Dispatching_Policy -- 24420 ----------------------------- 24421 24422 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER); 24423 24424 when Pragma_Task_Dispatching_Policy => declare 24425 DP : Character; 24426 24427 begin 24428 Check_Ada_83_Warning; 24429 Check_Arg_Count (1); 24430 Check_No_Identifiers; 24431 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 24432 Check_Valid_Configuration_Pragma; 24433 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 24434 DP := Fold_Upper (Name_Buffer (1)); 24435 24436 if Task_Dispatching_Policy /= ' ' 24437 and then Task_Dispatching_Policy /= DP 24438 then 24439 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 24440 Error_Pragma 24441 ("task dispatching policy incompatible with policy#"); 24442 24443 -- Set new policy, but always preserve System_Location since we 24444 -- like the error message with the run time name. 24445 24446 else 24447 Task_Dispatching_Policy := DP; 24448 24449 if Task_Dispatching_Policy_Sloc /= System_Location then 24450 Task_Dispatching_Policy_Sloc := Loc; 24451 end if; 24452 end if; 24453 end; 24454 24455 --------------- 24456 -- Task_Info -- 24457 --------------- 24458 24459 -- pragma Task_Info (EXPRESSION); 24460 24461 when Pragma_Task_Info => Task_Info : declare 24462 P : constant Node_Id := Parent (N); 24463 Ent : Entity_Id; 24464 24465 begin 24466 GNAT_Pragma; 24467 24468 if Warn_On_Obsolescent_Feature then 24469 Error_Msg_N 24470 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U " 24471 & "instead?j?", N); 24472 end if; 24473 24474 if Nkind (P) /= N_Task_Definition then 24475 Error_Pragma ("pragma% must appear in task definition"); 24476 end if; 24477 24478 Check_No_Identifiers; 24479 Check_Arg_Count (1); 24480 24481 Analyze_And_Resolve 24482 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type)); 24483 24484 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then 24485 return; 24486 end if; 24487 24488 Ent := Defining_Identifier (Parent (P)); 24489 24490 -- Check duplicate pragma before we chain the pragma in the Rep 24491 -- Item chain of Ent. 24492 24493 if Has_Rep_Pragma 24494 (Ent, Name_Task_Info, Check_Parents => False) 24495 then 24496 Error_Pragma ("duplicate pragma% not allowed"); 24497 end if; 24498 24499 Record_Rep_Item (Ent, N); 24500 end Task_Info; 24501 24502 --------------- 24503 -- Task_Name -- 24504 --------------- 24505 24506 -- pragma Task_Name (string_EXPRESSION); 24507 24508 when Pragma_Task_Name => Task_Name : declare 24509 P : constant Node_Id := Parent (N); 24510 Arg : Node_Id; 24511 Ent : Entity_Id; 24512 24513 begin 24514 Check_No_Identifiers; 24515 Check_Arg_Count (1); 24516 24517 Arg := Get_Pragma_Arg (Arg1); 24518 24519 -- The expression is used in the call to Create_Task, and must be 24520 -- expanded there, not in the context of the current spec. It must 24521 -- however be analyzed to capture global references, in case it 24522 -- appears in a generic context. 24523 24524 Preanalyze_And_Resolve (Arg, Standard_String); 24525 24526 if Nkind (P) /= N_Task_Definition then 24527 Pragma_Misplaced; 24528 end if; 24529 24530 Ent := Defining_Identifier (Parent (P)); 24531 24532 -- Check duplicate pragma before we chain the pragma in the Rep 24533 -- Item chain of Ent. 24534 24535 if Has_Rep_Pragma 24536 (Ent, Name_Task_Name, Check_Parents => False) 24537 then 24538 Error_Pragma ("duplicate pragma% not allowed"); 24539 end if; 24540 24541 Record_Rep_Item (Ent, N); 24542 end Task_Name; 24543 24544 ------------------ 24545 -- Task_Storage -- 24546 ------------------ 24547 24548 -- pragma Task_Storage ( 24549 -- [Task_Type =>] LOCAL_NAME, 24550 -- [Top_Guard =>] static_integer_EXPRESSION); 24551 24552 when Pragma_Task_Storage => Task_Storage : declare 24553 Args : Args_List (1 .. 2); 24554 Names : constant Name_List (1 .. 2) := ( 24555 Name_Task_Type, 24556 Name_Top_Guard); 24557 24558 Task_Type : Node_Id renames Args (1); 24559 Top_Guard : Node_Id renames Args (2); 24560 24561 Ent : Entity_Id; 24562 24563 begin 24564 GNAT_Pragma; 24565 Gather_Associations (Names, Args); 24566 24567 if No (Task_Type) then 24568 Error_Pragma 24569 ("missing task_type argument for pragma%"); 24570 end if; 24571 24572 Check_Arg_Is_Local_Name (Task_Type); 24573 24574 Ent := Entity (Task_Type); 24575 24576 if not Is_Task_Type (Ent) then 24577 Error_Pragma_Arg 24578 ("argument for pragma% must be task type", Task_Type); 24579 end if; 24580 24581 if No (Top_Guard) then 24582 Error_Pragma_Arg 24583 ("pragma% takes two arguments", Task_Type); 24584 else 24585 Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer); 24586 end if; 24587 24588 Check_First_Subtype (Task_Type); 24589 24590 if Rep_Item_Too_Late (Ent, N) then 24591 raise Pragma_Exit; 24592 end if; 24593 end Task_Storage; 24594 24595 --------------- 24596 -- Test_Case -- 24597 --------------- 24598 24599 -- pragma Test_Case 24600 -- ([Name =>] Static_String_EXPRESSION 24601 -- ,[Mode =>] MODE_TYPE 24602 -- [, Requires => Boolean_EXPRESSION] 24603 -- [, Ensures => Boolean_EXPRESSION]); 24604 24605 -- MODE_TYPE ::= Nominal | Robustness 24606 24607 -- Characteristics: 24608 24609 -- * Analysis - The annotation undergoes initial checks to verify 24610 -- the legal placement and context. Secondary checks preanalyze the 24611 -- expressions in: 24612 24613 -- Analyze_Test_Case_In_Decl_Part 24614 24615 -- * Expansion - None. 24616 24617 -- * Template - The annotation utilizes the generic template of the 24618 -- related subprogram when it is: 24619 24620 -- aspect on subprogram declaration 24621 24622 -- The annotation must prepare its own template when it is: 24623 24624 -- pragma on subprogram declaration 24625 24626 -- * Globals - Capture of global references must occur after full 24627 -- analysis. 24628 24629 -- * Instance - The annotation is instantiated automatically when 24630 -- the related generic subprogram is instantiated except for the 24631 -- "pragma on subprogram declaration" case. In that scenario the 24632 -- annotation must instantiate itself. 24633 24634 when Pragma_Test_Case => Test_Case : declare 24635 procedure Check_Distinct_Name (Subp_Id : Entity_Id); 24636 -- Ensure that the contract of subprogram Subp_Id does not contain 24637 -- another Test_Case pragma with the same Name as the current one. 24638 24639 ------------------------- 24640 -- Check_Distinct_Name -- 24641 ------------------------- 24642 24643 procedure Check_Distinct_Name (Subp_Id : Entity_Id) is 24644 Items : constant Node_Id := Contract (Subp_Id); 24645 Name : constant String_Id := Get_Name_From_CTC_Pragma (N); 24646 Prag : Node_Id; 24647 24648 begin 24649 -- Inspect all Test_Case pragma of the related subprogram 24650 -- looking for one with a duplicate "Name" argument. 24651 24652 if Present (Items) then 24653 Prag := Contract_Test_Cases (Items); 24654 while Present (Prag) loop 24655 if Pragma_Name (Prag) = Name_Test_Case 24656 and then Prag /= N 24657 and then String_Equal 24658 (Name, Get_Name_From_CTC_Pragma (Prag)) 24659 then 24660 Error_Msg_Sloc := Sloc (Prag); 24661 Error_Pragma ("name for pragma % is already used #"); 24662 end if; 24663 24664 Prag := Next_Pragma (Prag); 24665 end loop; 24666 end if; 24667 end Check_Distinct_Name; 24668 24669 -- Local variables 24670 24671 Pack_Decl : constant Node_Id := Unit (Cunit (Current_Sem_Unit)); 24672 Asp_Arg : Node_Id; 24673 Context : Node_Id; 24674 Subp_Decl : Node_Id; 24675 Subp_Id : Entity_Id; 24676 24677 -- Start of processing for Test_Case 24678 24679 begin 24680 GNAT_Pragma; 24681 Check_At_Least_N_Arguments (2); 24682 Check_At_Most_N_Arguments (4); 24683 Check_Arg_Order 24684 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); 24685 24686 -- Argument "Name" 24687 24688 Check_Optional_Identifier (Arg1, Name_Name); 24689 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); 24690 24691 -- Argument "Mode" 24692 24693 Check_Optional_Identifier (Arg2, Name_Mode); 24694 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); 24695 24696 -- Arguments "Requires" and "Ensures" 24697 24698 if Present (Arg3) then 24699 if Present (Arg4) then 24700 Check_Identifier (Arg3, Name_Requires); 24701 Check_Identifier (Arg4, Name_Ensures); 24702 else 24703 Check_Identifier_Is_One_Of 24704 (Arg3, Name_Requires, Name_Ensures); 24705 end if; 24706 end if; 24707 24708 -- Pragma Test_Case must be associated with a subprogram declared 24709 -- in a library-level package. First determine whether the current 24710 -- compilation unit is a legal context. 24711 24712 if Nkind_In (Pack_Decl, N_Package_Declaration, 24713 N_Generic_Package_Declaration) 24714 then 24715 null; 24716 24717 -- Otherwise the placement is illegal 24718 24719 else 24720 Error_Pragma 24721 ("pragma % must be specified within a package declaration"); 24722 return; 24723 end if; 24724 24725 Subp_Decl := Find_Related_Declaration_Or_Body (N); 24726 24727 -- Find the enclosing context 24728 24729 Context := Parent (Subp_Decl); 24730 24731 if Present (Context) then 24732 Context := Parent (Context); 24733 end if; 24734 24735 -- Verify the placement of the pragma 24736 24737 if Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration then 24738 Error_Pragma 24739 ("pragma % cannot be applied to abstract subprogram"); 24740 return; 24741 24742 elsif Nkind (Subp_Decl) = N_Entry_Declaration then 24743 Error_Pragma ("pragma % cannot be applied to entry"); 24744 return; 24745 24746 -- The context is a [generic] subprogram declared at the top level 24747 -- of the [generic] package unit. 24748 24749 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, 24750 N_Subprogram_Declaration) 24751 and then Present (Context) 24752 and then Nkind_In (Context, N_Generic_Package_Declaration, 24753 N_Package_Declaration) 24754 then 24755 null; 24756 24757 -- Otherwise the placement is illegal 24758 24759 else 24760 Error_Pragma 24761 ("pragma % must be applied to a library-level subprogram " 24762 & "declaration"); 24763 return; 24764 end if; 24765 24766 Subp_Id := Defining_Entity (Subp_Decl); 24767 24768 -- A pragma that applies to a Ghost entity becomes Ghost for the 24769 -- purposes of legality checks and removal of ignored Ghost code. 24770 24771 Mark_Ghost_Pragma (N, Subp_Id); 24772 24773 -- Chain the pragma on the contract for further processing by 24774 -- Analyze_Test_Case_In_Decl_Part. 24775 24776 Add_Contract_Item (N, Subp_Id); 24777 24778 -- Preanalyze the original aspect argument "Name" for ASIS or for 24779 -- a generic subprogram to properly capture global references. 24780 24781 if ASIS_Mode or else Is_Generic_Subprogram (Subp_Id) then 24782 Asp_Arg := Test_Case_Arg (N, Name_Name, From_Aspect => True); 24783 24784 if Present (Asp_Arg) then 24785 24786 -- The argument appears with an identifier in association 24787 -- form. 24788 24789 if Nkind (Asp_Arg) = N_Component_Association then 24790 Asp_Arg := Expression (Asp_Arg); 24791 end if; 24792 24793 Check_Expr_Is_OK_Static_Expression 24794 (Asp_Arg, Standard_String); 24795 end if; 24796 end if; 24797 24798 -- Ensure that the all Test_Case pragmas of the related subprogram 24799 -- have distinct names. 24800 24801 Check_Distinct_Name (Subp_Id); 24802 24803 -- Fully analyze the pragma when it appears inside an entry 24804 -- or subprogram body because it cannot benefit from forward 24805 -- references. 24806 24807 if Nkind_In (Subp_Decl, N_Entry_Body, 24808 N_Subprogram_Body, 24809 N_Subprogram_Body_Stub) 24810 then 24811 -- The legality checks of pragma Test_Case are affected by the 24812 -- SPARK mode in effect and the volatility of the context. 24813 -- Analyze all pragmas in a specific order. 24814 24815 Analyze_If_Present (Pragma_SPARK_Mode); 24816 Analyze_If_Present (Pragma_Volatile_Function); 24817 Analyze_Test_Case_In_Decl_Part (N); 24818 end if; 24819 end Test_Case; 24820 24821 -------------------------- 24822 -- Thread_Local_Storage -- 24823 -------------------------- 24824 24825 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); 24826 24827 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare 24828 E : Entity_Id; 24829 Id : Node_Id; 24830 24831 begin 24832 GNAT_Pragma; 24833 Check_Arg_Count (1); 24834 Check_Optional_Identifier (Arg1, Name_Entity); 24835 Check_Arg_Is_Library_Level_Local_Name (Arg1); 24836 24837 Id := Get_Pragma_Arg (Arg1); 24838 Analyze (Id); 24839 24840 if not Is_Entity_Name (Id) 24841 or else Ekind (Entity (Id)) /= E_Variable 24842 then 24843 Error_Pragma_Arg ("local variable name required", Arg1); 24844 end if; 24845 24846 E := Entity (Id); 24847 24848 -- A pragma that applies to a Ghost entity becomes Ghost for the 24849 -- purposes of legality checks and removal of ignored Ghost code. 24850 24851 Mark_Ghost_Pragma (N, E); 24852 24853 if Rep_Item_Too_Early (E, N) 24854 or else 24855 Rep_Item_Too_Late (E, N) 24856 then 24857 raise Pragma_Exit; 24858 end if; 24859 24860 Set_Has_Pragma_Thread_Local_Storage (E); 24861 Set_Has_Gigi_Rep_Item (E); 24862 end Thread_Local_Storage; 24863 24864 ---------------- 24865 -- Time_Slice -- 24866 ---------------- 24867 24868 -- pragma Time_Slice (static_duration_EXPRESSION); 24869 24870 when Pragma_Time_Slice => Time_Slice : declare 24871 Val : Ureal; 24872 Nod : Node_Id; 24873 24874 begin 24875 GNAT_Pragma; 24876 Check_Arg_Count (1); 24877 Check_No_Identifiers; 24878 Check_In_Main_Program; 24879 Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration); 24880 24881 if not Error_Posted (Arg1) then 24882 Nod := Next (N); 24883 while Present (Nod) loop 24884 if Nkind (Nod) = N_Pragma 24885 and then Pragma_Name (Nod) = Name_Time_Slice 24886 then 24887 Error_Msg_Name_1 := Pname; 24888 Error_Msg_N ("duplicate pragma% not permitted", Nod); 24889 end if; 24890 24891 Next (Nod); 24892 end loop; 24893 end if; 24894 24895 -- Process only if in main unit 24896 24897 if Get_Source_Unit (Loc) = Main_Unit then 24898 Opt.Time_Slice_Set := True; 24899 Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); 24900 24901 if Val <= Ureal_0 then 24902 Opt.Time_Slice_Value := 0; 24903 24904 elsif Val > UR_From_Uint (UI_From_Int (1000)) then 24905 Opt.Time_Slice_Value := 1_000_000_000; 24906 24907 else 24908 Opt.Time_Slice_Value := 24909 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000))); 24910 end if; 24911 end if; 24912 end Time_Slice; 24913 24914 ----------- 24915 -- Title -- 24916 ----------- 24917 24918 -- pragma Title (TITLING_OPTION [, TITLING OPTION]); 24919 24920 -- TITLING_OPTION ::= 24921 -- [Title =>] STRING_LITERAL 24922 -- | [Subtitle =>] STRING_LITERAL 24923 24924 when Pragma_Title => Title : declare 24925 Args : Args_List (1 .. 2); 24926 Names : constant Name_List (1 .. 2) := ( 24927 Name_Title, 24928 Name_Subtitle); 24929 24930 begin 24931 GNAT_Pragma; 24932 Gather_Associations (Names, Args); 24933 Store_Note (N); 24934 24935 for J in 1 .. 2 loop 24936 if Present (Args (J)) then 24937 Check_Arg_Is_OK_Static_Expression 24938 (Args (J), Standard_String); 24939 end if; 24940 end loop; 24941 end Title; 24942 24943 ---------------------------- 24944 -- Type_Invariant[_Class] -- 24945 ---------------------------- 24946 24947 -- pragma Type_Invariant[_Class] 24948 -- ([Entity =>] type_LOCAL_NAME, 24949 -- [Check =>] EXPRESSION); 24950 24951 when Pragma_Type_Invariant 24952 | Pragma_Type_Invariant_Class 24953 => 24954 Type_Invariant : declare 24955 I_Pragma : Node_Id; 24956 24957 begin 24958 Check_Arg_Count (2); 24959 24960 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma, 24961 -- setting Class_Present for the Type_Invariant_Class case. 24962 24963 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class); 24964 I_Pragma := New_Copy (N); 24965 Set_Pragma_Identifier 24966 (I_Pragma, Make_Identifier (Loc, Name_Invariant)); 24967 Rewrite (N, I_Pragma); 24968 Set_Analyzed (N, False); 24969 Analyze (N); 24970 end Type_Invariant; 24971 24972 --------------------- 24973 -- Unchecked_Union -- 24974 --------------------- 24975 24976 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) 24977 24978 when Pragma_Unchecked_Union => Unchecked_Union : declare 24979 Assoc : constant Node_Id := Arg1; 24980 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 24981 Clist : Node_Id; 24982 Comp : Node_Id; 24983 Tdef : Node_Id; 24984 Typ : Entity_Id; 24985 Variant : Node_Id; 24986 Vpart : Node_Id; 24987 24988 begin 24989 Ada_2005_Pragma; 24990 Check_No_Identifiers; 24991 Check_Arg_Count (1); 24992 Check_Arg_Is_Local_Name (Arg1); 24993 24994 Find_Type (Type_Id); 24995 24996 Typ := Entity (Type_Id); 24997 24998 -- A pragma that applies to a Ghost entity becomes Ghost for the 24999 -- purposes of legality checks and removal of ignored Ghost code. 25000 25001 Mark_Ghost_Pragma (N, Typ); 25002 25003 if Typ = Any_Type 25004 or else Rep_Item_Too_Early (Typ, N) 25005 then 25006 return; 25007 else 25008 Typ := Underlying_Type (Typ); 25009 end if; 25010 25011 if Rep_Item_Too_Late (Typ, N) then 25012 return; 25013 end if; 25014 25015 Check_First_Subtype (Arg1); 25016 25017 -- Note remaining cases are references to a type in the current 25018 -- declarative part. If we find an error, we post the error on 25019 -- the relevant type declaration at an appropriate point. 25020 25021 if not Is_Record_Type (Typ) then 25022 Error_Msg_N ("unchecked union must be record type", Typ); 25023 return; 25024 25025 elsif Is_Tagged_Type (Typ) then 25026 Error_Msg_N ("unchecked union must not be tagged", Typ); 25027 return; 25028 25029 elsif not Has_Discriminants (Typ) then 25030 Error_Msg_N 25031 ("unchecked union must have one discriminant", Typ); 25032 return; 25033 25034 -- Note: in previous versions of GNAT we used to check for limited 25035 -- types and give an error, but in fact the standard does allow 25036 -- Unchecked_Union on limited types, so this check was removed. 25037 25038 -- Similarly, GNAT used to require that all discriminants have 25039 -- default values, but this is not mandated by the RM. 25040 25041 -- Proceed with basic error checks completed 25042 25043 else 25044 Tdef := Type_Definition (Declaration_Node (Typ)); 25045 Clist := Component_List (Tdef); 25046 25047 -- Check presence of component list and variant part 25048 25049 if No (Clist) or else No (Variant_Part (Clist)) then 25050 Error_Msg_N 25051 ("unchecked union must have variant part", Tdef); 25052 return; 25053 end if; 25054 25055 -- Check components 25056 25057 Comp := First_Non_Pragma (Component_Items (Clist)); 25058 while Present (Comp) loop 25059 Check_Component (Comp, Typ); 25060 Next_Non_Pragma (Comp); 25061 end loop; 25062 25063 -- Check variant part 25064 25065 Vpart := Variant_Part (Clist); 25066 25067 Variant := First_Non_Pragma (Variants (Vpart)); 25068 while Present (Variant) loop 25069 Check_Variant (Variant, Typ); 25070 Next_Non_Pragma (Variant); 25071 end loop; 25072 end if; 25073 25074 Set_Is_Unchecked_Union (Typ); 25075 Set_Convention (Typ, Convention_C); 25076 Set_Has_Unchecked_Union (Base_Type (Typ)); 25077 Set_Is_Unchecked_Union (Base_Type (Typ)); 25078 end Unchecked_Union; 25079 25080 ---------------------------- 25081 -- Unevaluated_Use_Of_Old -- 25082 ---------------------------- 25083 25084 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow); 25085 25086 when Pragma_Unevaluated_Use_Of_Old => 25087 GNAT_Pragma; 25088 Check_Arg_Count (1); 25089 Check_No_Identifiers; 25090 Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow); 25091 25092 -- Suppress/Unsuppress can appear as a configuration pragma, or in 25093 -- a declarative part or a package spec. 25094 25095 if not Is_Configuration_Pragma then 25096 Check_Is_In_Decl_Part_Or_Package_Spec; 25097 end if; 25098 25099 -- Store proper setting of Uneval_Old 25100 25101 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 25102 Uneval_Old := Fold_Upper (Name_Buffer (1)); 25103 25104 ------------------------ 25105 -- Unimplemented_Unit -- 25106 ------------------------ 25107 25108 -- pragma Unimplemented_Unit; 25109 25110 -- Note: this only gives an error if we are generating code, or if 25111 -- we are in a generic library unit (where the pragma appears in the 25112 -- body, not in the spec). 25113 25114 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare 25115 Cunitent : constant Entity_Id := 25116 Cunit_Entity (Get_Source_Unit (Loc)); 25117 Ent_Kind : constant Entity_Kind := Ekind (Cunitent); 25118 25119 begin 25120 GNAT_Pragma; 25121 Check_Arg_Count (0); 25122 25123 if Operating_Mode = Generate_Code 25124 or else Ent_Kind = E_Generic_Function 25125 or else Ent_Kind = E_Generic_Procedure 25126 or else Ent_Kind = E_Generic_Package 25127 then 25128 Get_Name_String (Chars (Cunitent)); 25129 Set_Casing (Mixed_Case); 25130 Write_Str (Name_Buffer (1 .. Name_Len)); 25131 Write_Str (" is not supported in this configuration"); 25132 Write_Eol; 25133 raise Unrecoverable_Error; 25134 end if; 25135 end Unimplemented_Unit; 25136 25137 ------------------------ 25138 -- Universal_Aliasing -- 25139 ------------------------ 25140 25141 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)]; 25142 25143 when Pragma_Universal_Aliasing => Universal_Alias : declare 25144 E : Entity_Id; 25145 E_Id : Node_Id; 25146 25147 begin 25148 GNAT_Pragma; 25149 Check_Arg_Count (1); 25150 Check_Optional_Identifier (Arg2, Name_Entity); 25151 Check_Arg_Is_Local_Name (Arg1); 25152 E_Id := Get_Pragma_Arg (Arg1); 25153 25154 if Etype (E_Id) = Any_Type then 25155 return; 25156 end if; 25157 25158 E := Entity (E_Id); 25159 25160 if not Is_Type (E) then 25161 Error_Pragma_Arg ("pragma% requires type", Arg1); 25162 end if; 25163 25164 -- A pragma that applies to a Ghost entity becomes Ghost for the 25165 -- purposes of legality checks and removal of ignored Ghost code. 25166 25167 Mark_Ghost_Pragma (N, E); 25168 Set_Universal_Aliasing (Base_Type (E)); 25169 Record_Rep_Item (E, N); 25170 end Universal_Alias; 25171 25172 -------------------- 25173 -- Universal_Data -- 25174 -------------------- 25175 25176 -- pragma Universal_Data [(library_unit_NAME)]; 25177 25178 when Pragma_Universal_Data => 25179 GNAT_Pragma; 25180 Error_Pragma ("??pragma% ignored (applies only to AAMP)"); 25181 25182 ---------------- 25183 -- Unmodified -- 25184 ---------------- 25185 25186 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME}); 25187 25188 when Pragma_Unmodified => 25189 Analyze_Unmodified_Or_Unused; 25190 25191 ------------------ 25192 -- Unreferenced -- 25193 ------------------ 25194 25195 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME}); 25196 25197 -- or when used in a context clause: 25198 25199 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME} 25200 25201 when Pragma_Unreferenced => 25202 Analyze_Unreferenced_Or_Unused; 25203 25204 -------------------------- 25205 -- Unreferenced_Objects -- 25206 -------------------------- 25207 25208 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME}); 25209 25210 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare 25211 Arg : Node_Id; 25212 Arg_Expr : Node_Id; 25213 Arg_Id : Entity_Id; 25214 25215 Ghost_Error_Posted : Boolean := False; 25216 -- Flag set when an error concerning the illegal mix of Ghost and 25217 -- non-Ghost types is emitted. 25218 25219 Ghost_Id : Entity_Id := Empty; 25220 -- The entity of the first Ghost type encountered while processing 25221 -- the arguments of the pragma. 25222 25223 begin 25224 GNAT_Pragma; 25225 Check_At_Least_N_Arguments (1); 25226 25227 Arg := Arg1; 25228 while Present (Arg) loop 25229 Check_No_Identifier (Arg); 25230 Check_Arg_Is_Local_Name (Arg); 25231 Arg_Expr := Get_Pragma_Arg (Arg); 25232 25233 if Is_Entity_Name (Arg_Expr) then 25234 Arg_Id := Entity (Arg_Expr); 25235 25236 if Is_Type (Arg_Id) then 25237 Set_Has_Pragma_Unreferenced_Objects (Arg_Id); 25238 25239 -- A pragma that applies to a Ghost entity becomes Ghost 25240 -- for the purposes of legality checks and removal of 25241 -- ignored Ghost code. 25242 25243 Mark_Ghost_Pragma (N, Arg_Id); 25244 25245 -- Capture the entity of the first Ghost type being 25246 -- processed for error detection purposes. 25247 25248 if Is_Ghost_Entity (Arg_Id) then 25249 if No (Ghost_Id) then 25250 Ghost_Id := Arg_Id; 25251 end if; 25252 25253 -- Otherwise the type is non-Ghost. It is illegal to mix 25254 -- references to Ghost and non-Ghost entities 25255 -- (SPARK RM 6.9). 25256 25257 elsif Present (Ghost_Id) 25258 and then not Ghost_Error_Posted 25259 then 25260 Ghost_Error_Posted := True; 25261 25262 Error_Msg_Name_1 := Pname; 25263 Error_Msg_N 25264 ("pragma % cannot mention ghost and non-ghost types", 25265 N); 25266 25267 Error_Msg_Sloc := Sloc (Ghost_Id); 25268 Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); 25269 25270 Error_Msg_Sloc := Sloc (Arg_Id); 25271 Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id); 25272 end if; 25273 else 25274 Error_Pragma_Arg 25275 ("argument for pragma% must be type or subtype", Arg); 25276 end if; 25277 else 25278 Error_Pragma_Arg 25279 ("argument for pragma% must be type or subtype", Arg); 25280 end if; 25281 25282 Next (Arg); 25283 end loop; 25284 end Unreferenced_Objects; 25285 25286 ------------------------------ 25287 -- Unreserve_All_Interrupts -- 25288 ------------------------------ 25289 25290 -- pragma Unreserve_All_Interrupts; 25291 25292 when Pragma_Unreserve_All_Interrupts => 25293 GNAT_Pragma; 25294 Check_Arg_Count (0); 25295 25296 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then 25297 Unreserve_All_Interrupts := True; 25298 end if; 25299 25300 ---------------- 25301 -- Unsuppress -- 25302 ---------------- 25303 25304 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); 25305 25306 when Pragma_Unsuppress => 25307 Ada_2005_Pragma; 25308 Process_Suppress_Unsuppress (Suppress_Case => False); 25309 25310 ------------ 25311 -- Unused -- 25312 ------------ 25313 25314 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME}); 25315 25316 when Pragma_Unused => 25317 Analyze_Unmodified_Or_Unused (Is_Unused => True); 25318 Analyze_Unreferenced_Or_Unused (Is_Unused => True); 25319 25320 ------------------- 25321 -- Use_VADS_Size -- 25322 ------------------- 25323 25324 -- pragma Use_VADS_Size; 25325 25326 when Pragma_Use_VADS_Size => 25327 GNAT_Pragma; 25328 Check_Arg_Count (0); 25329 Check_Valid_Configuration_Pragma; 25330 Use_VADS_Size := True; 25331 25332 --------------------- 25333 -- Validity_Checks -- 25334 --------------------- 25335 25336 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 25337 25338 when Pragma_Validity_Checks => Validity_Checks : declare 25339 A : constant Node_Id := Get_Pragma_Arg (Arg1); 25340 S : String_Id; 25341 C : Char_Code; 25342 25343 begin 25344 GNAT_Pragma; 25345 Check_Arg_Count (1); 25346 Check_No_Identifiers; 25347 25348 -- Pragma always active unless in CodePeer or GNATprove modes, 25349 -- which use a fixed configuration of validity checks. 25350 25351 if not (CodePeer_Mode or GNATprove_Mode) then 25352 if Nkind (A) = N_String_Literal then 25353 S := Strval (A); 25354 25355 declare 25356 Slen : constant Natural := Natural (String_Length (S)); 25357 Options : String (1 .. Slen); 25358 J : Positive; 25359 25360 begin 25361 -- Couldn't we use a for loop here over Options'Range??? 25362 25363 J := 1; 25364 loop 25365 C := Get_String_Char (S, Pos (J)); 25366 25367 -- This is a weird test, it skips setting validity 25368 -- checks entirely if any element of S is out of 25369 -- range of Character, what is that about ??? 25370 25371 exit when not In_Character_Range (C); 25372 Options (J) := Get_Character (C); 25373 25374 if J = Slen then 25375 Set_Validity_Check_Options (Options); 25376 exit; 25377 else 25378 J := J + 1; 25379 end if; 25380 end loop; 25381 end; 25382 25383 elsif Nkind (A) = N_Identifier then 25384 if Chars (A) = Name_All_Checks then 25385 Set_Validity_Check_Options ("a"); 25386 elsif Chars (A) = Name_On then 25387 Validity_Checks_On := True; 25388 elsif Chars (A) = Name_Off then 25389 Validity_Checks_On := False; 25390 end if; 25391 end if; 25392 end if; 25393 end Validity_Checks; 25394 25395 -------------- 25396 -- Volatile -- 25397 -------------- 25398 25399 -- pragma Volatile (LOCAL_NAME); 25400 25401 when Pragma_Volatile => 25402 Process_Atomic_Independent_Shared_Volatile; 25403 25404 ------------------------- 25405 -- Volatile_Components -- 25406 ------------------------- 25407 25408 -- pragma Volatile_Components (array_LOCAL_NAME); 25409 25410 -- Volatile is handled by the same circuit as Atomic_Components 25411 25412 -------------------------- 25413 -- Volatile_Full_Access -- 25414 -------------------------- 25415 25416 -- pragma Volatile_Full_Access (LOCAL_NAME); 25417 25418 when Pragma_Volatile_Full_Access => 25419 GNAT_Pragma; 25420 Process_Atomic_Independent_Shared_Volatile; 25421 25422 ----------------------- 25423 -- Volatile_Function -- 25424 ----------------------- 25425 25426 -- pragma Volatile_Function [ (boolean_EXPRESSION) ]; 25427 25428 when Pragma_Volatile_Function => Volatile_Function : declare 25429 Over_Id : Entity_Id; 25430 Spec_Id : Entity_Id; 25431 Subp_Decl : Node_Id; 25432 25433 begin 25434 GNAT_Pragma; 25435 Check_No_Identifiers; 25436 Check_At_Most_N_Arguments (1); 25437 25438 Subp_Decl := 25439 Find_Related_Declaration_Or_Body (N, Do_Checks => True); 25440 25441 -- Generic subprogram 25442 25443 if Nkind (Subp_Decl) = N_Generic_Subprogram_Declaration then 25444 null; 25445 25446 -- Body acts as spec 25447 25448 elsif Nkind (Subp_Decl) = N_Subprogram_Body 25449 and then No (Corresponding_Spec (Subp_Decl)) 25450 then 25451 null; 25452 25453 -- Body stub acts as spec 25454 25455 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 25456 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 25457 then 25458 null; 25459 25460 -- Subprogram 25461 25462 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration then 25463 null; 25464 25465 else 25466 Pragma_Misplaced; 25467 return; 25468 end if; 25469 25470 Spec_Id := Unique_Defining_Entity (Subp_Decl); 25471 25472 if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 25473 Pragma_Misplaced; 25474 return; 25475 end if; 25476 25477 -- A pragma that applies to a Ghost entity becomes Ghost for the 25478 -- purposes of legality checks and removal of ignored Ghost code. 25479 25480 Mark_Ghost_Pragma (N, Spec_Id); 25481 25482 -- Chain the pragma on the contract for completeness 25483 25484 Add_Contract_Item (N, Spec_Id); 25485 25486 -- The legality checks of pragma Volatile_Function are affected by 25487 -- the SPARK mode in effect. Analyze all pragmas in a specific 25488 -- order. 25489 25490 Analyze_If_Present (Pragma_SPARK_Mode); 25491 25492 -- A volatile function cannot override a non-volatile function 25493 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed 25494 -- in New_Overloaded_Entity, however at that point the pragma has 25495 -- not been processed yet. 25496 25497 Over_Id := Overridden_Operation (Spec_Id); 25498 25499 if Present (Over_Id) 25500 and then not Is_Volatile_Function (Over_Id) 25501 then 25502 Error_Msg_N 25503 ("incompatible volatile function values in effect", Spec_Id); 25504 25505 Error_Msg_Sloc := Sloc (Over_Id); 25506 Error_Msg_N 25507 ("\& declared # with Volatile_Function value False", 25508 Spec_Id); 25509 25510 Error_Msg_Sloc := Sloc (Spec_Id); 25511 Error_Msg_N 25512 ("\overridden # with Volatile_Function value True", 25513 Spec_Id); 25514 end if; 25515 25516 -- Analyze the Boolean expression (if any) 25517 25518 if Present (Arg1) then 25519 Check_Static_Boolean_Expression (Get_Pragma_Arg (Arg1)); 25520 end if; 25521 end Volatile_Function; 25522 25523 ---------------------- 25524 -- Warning_As_Error -- 25525 ---------------------- 25526 25527 -- pragma Warning_As_Error (static_string_EXPRESSION); 25528 25529 when Pragma_Warning_As_Error => 25530 GNAT_Pragma; 25531 Check_Arg_Count (1); 25532 Check_No_Identifiers; 25533 Check_Valid_Configuration_Pragma; 25534 25535 if not Is_Static_String_Expression (Arg1) then 25536 Error_Pragma_Arg 25537 ("argument of pragma% must be static string expression", 25538 Arg1); 25539 25540 -- OK static string expression 25541 25542 else 25543 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1; 25544 Warnings_As_Errors (Warnings_As_Errors_Count) := 25545 new String'(Acquire_Warning_Match_String 25546 (Expr_Value_S (Get_Pragma_Arg (Arg1)))); 25547 end if; 25548 25549 -------------- 25550 -- Warnings -- 25551 -------------- 25552 25553 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); 25554 25555 -- DETAILS ::= On | Off 25556 -- DETAILS ::= On | Off, local_NAME 25557 -- DETAILS ::= static_string_EXPRESSION 25558 -- DETAILS ::= On | Off, static_string_EXPRESSION 25559 25560 -- TOOL_NAME ::= GNAT | GNATProve 25561 25562 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} 25563 25564 -- Note: If the first argument matches an allowed tool name, it is 25565 -- always considered to be a tool name, even if there is a string 25566 -- variable of that name. 25567 25568 -- Note if the second argument of DETAILS is a local_NAME then the 25569 -- second form is always understood. If the intention is to use 25570 -- the fourth form, then you can write NAME & "" to force the 25571 -- intepretation as a static_string_EXPRESSION. 25572 25573 when Pragma_Warnings => Warnings : declare 25574 Reason : String_Id; 25575 25576 begin 25577 GNAT_Pragma; 25578 Check_At_Least_N_Arguments (1); 25579 25580 -- See if last argument is labeled Reason. If so, make sure we 25581 -- have a string literal or a concatenation of string literals, 25582 -- and acquire the REASON string. Then remove the REASON argument 25583 -- by decreasing Num_Args by one; Remaining processing looks only 25584 -- at first Num_Args arguments). 25585 25586 declare 25587 Last_Arg : constant Node_Id := 25588 Last (Pragma_Argument_Associations (N)); 25589 25590 begin 25591 if Nkind (Last_Arg) = N_Pragma_Argument_Association 25592 and then Chars (Last_Arg) = Name_Reason 25593 then 25594 Start_String; 25595 Get_Reason_String (Get_Pragma_Arg (Last_Arg)); 25596 Reason := End_String; 25597 Arg_Count := Arg_Count - 1; 25598 25599 -- Not allowed in compiler units (bootstrap issues) 25600 25601 Check_Compiler_Unit ("Reason for pragma Warnings", N); 25602 25603 -- No REASON string, set null string as reason 25604 25605 else 25606 Reason := Null_String_Id; 25607 end if; 25608 end; 25609 25610 -- Now proceed with REASON taken care of and eliminated 25611 25612 Check_No_Identifiers; 25613 25614 -- If debug flag -gnatd.i is set, pragma is ignored 25615 25616 if Debug_Flag_Dot_I then 25617 return; 25618 end if; 25619 25620 -- Process various forms of the pragma 25621 25622 declare 25623 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 25624 Shifted_Args : List_Id; 25625 25626 begin 25627 -- See if first argument is a tool name, currently either 25628 -- GNAT or GNATprove. If so, either ignore the pragma if the 25629 -- tool used does not match, or continue as if no tool name 25630 -- was given otherwise, by shifting the arguments. 25631 25632 if Nkind (Argx) = N_Identifier 25633 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove) 25634 then 25635 if Chars (Argx) = Name_Gnat then 25636 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then 25637 Rewrite (N, Make_Null_Statement (Loc)); 25638 Analyze (N); 25639 raise Pragma_Exit; 25640 end if; 25641 25642 elsif Chars (Argx) = Name_Gnatprove then 25643 if not GNATprove_Mode then 25644 Rewrite (N, Make_Null_Statement (Loc)); 25645 Analyze (N); 25646 raise Pragma_Exit; 25647 end if; 25648 25649 else 25650 raise Program_Error; 25651 end if; 25652 25653 -- At this point, the pragma Warnings applies to the tool, 25654 -- so continue with shifted arguments. 25655 25656 Arg_Count := Arg_Count - 1; 25657 25658 if Arg_Count = 1 then 25659 Shifted_Args := New_List (New_Copy (Arg2)); 25660 elsif Arg_Count = 2 then 25661 Shifted_Args := New_List (New_Copy (Arg2), 25662 New_Copy (Arg3)); 25663 elsif Arg_Count = 3 then 25664 Shifted_Args := New_List (New_Copy (Arg2), 25665 New_Copy (Arg3), 25666 New_Copy (Arg4)); 25667 else 25668 raise Program_Error; 25669 end if; 25670 25671 Rewrite (N, 25672 Make_Pragma (Loc, 25673 Chars => Name_Warnings, 25674 Pragma_Argument_Associations => Shifted_Args)); 25675 Analyze (N); 25676 raise Pragma_Exit; 25677 end if; 25678 25679 -- One argument case 25680 25681 if Arg_Count = 1 then 25682 25683 -- On/Off one argument case was processed by parser 25684 25685 if Nkind (Argx) = N_Identifier 25686 and then Nam_In (Chars (Argx), Name_On, Name_Off) 25687 then 25688 null; 25689 25690 -- One argument case must be ON/OFF or static string expr 25691 25692 elsif not Is_Static_String_Expression (Arg1) then 25693 Error_Pragma_Arg 25694 ("argument of pragma% must be On/Off or static string " 25695 & "expression", Arg1); 25696 25697 -- One argument string expression case 25698 25699 else 25700 declare 25701 Lit : constant Node_Id := Expr_Value_S (Argx); 25702 Str : constant String_Id := Strval (Lit); 25703 Len : constant Nat := String_Length (Str); 25704 C : Char_Code; 25705 J : Nat; 25706 OK : Boolean; 25707 Chr : Character; 25708 25709 begin 25710 J := 1; 25711 while J <= Len loop 25712 C := Get_String_Char (Str, J); 25713 OK := In_Character_Range (C); 25714 25715 if OK then 25716 Chr := Get_Character (C); 25717 25718 -- Dash case: only -Wxxx is accepted 25719 25720 if J = 1 25721 and then J < Len 25722 and then Chr = '-' 25723 then 25724 J := J + 1; 25725 C := Get_String_Char (Str, J); 25726 Chr := Get_Character (C); 25727 exit when Chr = 'W'; 25728 OK := False; 25729 25730 -- Dot case 25731 25732 elsif J < Len and then Chr = '.' then 25733 J := J + 1; 25734 C := Get_String_Char (Str, J); 25735 Chr := Get_Character (C); 25736 25737 if not Set_Dot_Warning_Switch (Chr) then 25738 Error_Pragma_Arg 25739 ("invalid warning switch character " 25740 & '.' & Chr, Arg1); 25741 end if; 25742 25743 -- Non-Dot case 25744 25745 else 25746 OK := Set_Warning_Switch (Chr); 25747 end if; 25748 25749 if not OK then 25750 Error_Pragma_Arg 25751 ("invalid warning switch character " & Chr, 25752 Arg1); 25753 end if; 25754 25755 else 25756 Error_Pragma_Arg 25757 ("invalid wide character in warning switch ", 25758 Arg1); 25759 end if; 25760 25761 J := J + 1; 25762 end loop; 25763 end; 25764 end if; 25765 25766 -- Two or more arguments (must be two) 25767 25768 else 25769 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 25770 Check_Arg_Count (2); 25771 25772 declare 25773 E_Id : Node_Id; 25774 E : Entity_Id; 25775 Err : Boolean; 25776 25777 begin 25778 E_Id := Get_Pragma_Arg (Arg2); 25779 Analyze (E_Id); 25780 25781 -- In the expansion of an inlined body, a reference to 25782 -- the formal may be wrapped in a conversion if the 25783 -- actual is a conversion. Retrieve the real entity name. 25784 25785 if (In_Instance_Body or In_Inlined_Body) 25786 and then Nkind (E_Id) = N_Unchecked_Type_Conversion 25787 then 25788 E_Id := Expression (E_Id); 25789 end if; 25790 25791 -- Entity name case 25792 25793 if Is_Entity_Name (E_Id) then 25794 E := Entity (E_Id); 25795 25796 if E = Any_Id then 25797 return; 25798 else 25799 loop 25800 Set_Warnings_Off 25801 (E, (Chars (Get_Pragma_Arg (Arg1)) = 25802 Name_Off)); 25803 25804 -- Suppress elaboration warnings if the entity 25805 -- denotes an elaboration target. 25806 25807 if Is_Elaboration_Target (E) then 25808 Set_Is_Elaboration_Warnings_OK_Id (E, False); 25809 end if; 25810 25811 -- For OFF case, make entry in warnings off 25812 -- pragma table for later processing. But we do 25813 -- not do that within an instance, since these 25814 -- warnings are about what is needed in the 25815 -- template, not an instance of it. 25816 25817 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off 25818 and then Warn_On_Warnings_Off 25819 and then not In_Instance 25820 then 25821 Warnings_Off_Pragmas.Append ((N, E, Reason)); 25822 end if; 25823 25824 if Is_Enumeration_Type (E) then 25825 declare 25826 Lit : Entity_Id; 25827 begin 25828 Lit := First_Literal (E); 25829 while Present (Lit) loop 25830 Set_Warnings_Off (Lit); 25831 Next_Literal (Lit); 25832 end loop; 25833 end; 25834 end if; 25835 25836 exit when No (Homonym (E)); 25837 E := Homonym (E); 25838 end loop; 25839 end if; 25840 25841 -- Error if not entity or static string expression case 25842 25843 elsif not Is_Static_String_Expression (Arg2) then 25844 Error_Pragma_Arg 25845 ("second argument of pragma% must be entity name " 25846 & "or static string expression", Arg2); 25847 25848 -- Static string expression case 25849 25850 else 25851 -- Note on configuration pragma case: If this is a 25852 -- configuration pragma, then for an OFF pragma, we 25853 -- just set Config True in the call, which is all 25854 -- that needs to be done. For the case of ON, this 25855 -- is normally an error, unless it is canceling the 25856 -- effect of a previous OFF pragma in the same file. 25857 -- In any other case, an error will be signalled (ON 25858 -- with no matching OFF). 25859 25860 -- Note: We set Used if we are inside a generic to 25861 -- disable the test that the non-config case actually 25862 -- cancels a warning. That's because we can't be sure 25863 -- there isn't an instantiation in some other unit 25864 -- where a warning is suppressed. 25865 25866 -- We could do a little better here by checking if the 25867 -- generic unit we are inside is public, but for now 25868 -- we don't bother with that refinement. 25869 25870 declare 25871 Message : constant String := 25872 Acquire_Warning_Match_String 25873 (Expr_Value_S (Get_Pragma_Arg (Arg2))); 25874 begin 25875 if Chars (Argx) = Name_Off then 25876 Set_Specific_Warning_Off 25877 (Loc, Message, Reason, 25878 Config => Is_Configuration_Pragma, 25879 Used => Inside_A_Generic or else In_Instance); 25880 25881 elsif Chars (Argx) = Name_On then 25882 Set_Specific_Warning_On (Loc, Message, Err); 25883 25884 if Err then 25885 Error_Msg 25886 ("??pragma Warnings On with no matching " 25887 & "Warnings Off", Loc); 25888 end if; 25889 end if; 25890 end; 25891 end if; 25892 end; 25893 end if; 25894 end; 25895 end Warnings; 25896 25897 ------------------- 25898 -- Weak_External -- 25899 ------------------- 25900 25901 -- pragma Weak_External ([Entity =>] LOCAL_NAME); 25902 25903 when Pragma_Weak_External => Weak_External : declare 25904 Ent : Entity_Id; 25905 25906 begin 25907 GNAT_Pragma; 25908 Check_Arg_Count (1); 25909 Check_Optional_Identifier (Arg1, Name_Entity); 25910 Check_Arg_Is_Library_Level_Local_Name (Arg1); 25911 Ent := Entity (Get_Pragma_Arg (Arg1)); 25912 25913 if Rep_Item_Too_Early (Ent, N) then 25914 return; 25915 else 25916 Ent := Underlying_Type (Ent); 25917 end if; 25918 25919 -- The pragma applies to entities with addresses 25920 25921 if Is_Type (Ent) then 25922 Error_Pragma ("pragma applies to objects and subprograms"); 25923 end if; 25924 25925 -- The only processing required is to link this item on to the 25926 -- list of rep items for the given entity. This is accomplished 25927 -- by the call to Rep_Item_Too_Late (when no error is detected 25928 -- and False is returned). 25929 25930 if Rep_Item_Too_Late (Ent, N) then 25931 return; 25932 else 25933 Set_Has_Gigi_Rep_Item (Ent); 25934 end if; 25935 end Weak_External; 25936 25937 ----------------------------- 25938 -- Wide_Character_Encoding -- 25939 ----------------------------- 25940 25941 -- pragma Wide_Character_Encoding (IDENTIFIER); 25942 25943 when Pragma_Wide_Character_Encoding => 25944 GNAT_Pragma; 25945 25946 -- Nothing to do, handled in parser. Note that we do not enforce 25947 -- configuration pragma placement, this pragma can appear at any 25948 -- place in the source, allowing mixed encodings within a single 25949 -- source program. 25950 25951 null; 25952 25953 -------------------- 25954 -- Unknown_Pragma -- 25955 -------------------- 25956 25957 -- Should be impossible, since the case of an unknown pragma is 25958 -- separately processed before the case statement is entered. 25959 25960 when Unknown_Pragma => 25961 raise Program_Error; 25962 end case; 25963 25964 -- AI05-0144: detect dangerous order dependence. Disabled for now, 25965 -- until AI is formally approved. 25966 25967 -- Check_Order_Dependence; 25968 25969 exception 25970 when Pragma_Exit => null; 25971 end Analyze_Pragma; 25972 25973 --------------------------------------------- 25974 -- Analyze_Pre_Post_Condition_In_Decl_Part -- 25975 --------------------------------------------- 25976 25977 -- WARNING: This routine manages Ghost regions. Return statements must be 25978 -- replaced by gotos which jump to the end of the routine and restore the 25979 -- Ghost mode. 25980 25981 procedure Analyze_Pre_Post_Condition_In_Decl_Part 25982 (N : Node_Id; 25983 Freeze_Id : Entity_Id := Empty) 25984 is 25985 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 25986 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 25987 25988 Disp_Typ : Entity_Id; 25989 -- The dispatching type of the subprogram subject to the pre- or 25990 -- postcondition. 25991 25992 function Check_References (Nod : Node_Id) return Traverse_Result; 25993 -- Check that expression Nod does not mention non-primitives of the 25994 -- type, global objects of the type, or other illegalities described 25995 -- and implied by AI12-0113. 25996 25997 ---------------------- 25998 -- Check_References -- 25999 ---------------------- 26000 26001 function Check_References (Nod : Node_Id) return Traverse_Result is 26002 begin 26003 if Nkind (Nod) = N_Function_Call 26004 and then Is_Entity_Name (Name (Nod)) 26005 then 26006 declare 26007 Func : constant Entity_Id := Entity (Name (Nod)); 26008 Form : Entity_Id; 26009 26010 begin 26011 -- An operation of the type must be a primitive 26012 26013 if No (Find_Dispatching_Type (Func)) then 26014 Form := First_Formal (Func); 26015 while Present (Form) loop 26016 if Etype (Form) = Disp_Typ then 26017 Error_Msg_NE 26018 ("operation in class-wide condition must be " 26019 & "primitive of &", Nod, Disp_Typ); 26020 end if; 26021 26022 Next_Formal (Form); 26023 end loop; 26024 26025 -- A return object of the type is illegal as well 26026 26027 if Etype (Func) = Disp_Typ 26028 or else Etype (Func) = Class_Wide_Type (Disp_Typ) 26029 then 26030 Error_Msg_NE 26031 ("operation in class-wide condition must be primitive " 26032 & "of &", Nod, Disp_Typ); 26033 end if; 26034 26035 -- Otherwise we have a call to an overridden primitive, and we 26036 -- will create a common class-wide clone for the body of 26037 -- original operation and its eventual inherited versions. If 26038 -- the original operation dispatches on result it is never 26039 -- inherited and there is no need for a clone. There is not 26040 -- need for a clone either in GNATprove mode, as cases that 26041 -- would require it are rejected (when an inherited primitive 26042 -- calls an overridden operation in a class-wide contract), and 26043 -- the clone would make proof impossible in some cases. 26044 26045 elsif not Is_Abstract_Subprogram (Spec_Id) 26046 and then No (Class_Wide_Clone (Spec_Id)) 26047 and then not Has_Controlling_Result (Spec_Id) 26048 and then not GNATprove_Mode 26049 then 26050 Build_Class_Wide_Clone_Decl (Spec_Id); 26051 end if; 26052 end; 26053 26054 elsif Is_Entity_Name (Nod) 26055 and then 26056 (Etype (Nod) = Disp_Typ 26057 or else Etype (Nod) = Class_Wide_Type (Disp_Typ)) 26058 and then Ekind_In (Entity (Nod), E_Constant, E_Variable) 26059 then 26060 Error_Msg_NE 26061 ("object in class-wide condition must be formal of type &", 26062 Nod, Disp_Typ); 26063 26064 elsif Nkind (Nod) = N_Explicit_Dereference 26065 and then (Etype (Nod) = Disp_Typ 26066 or else Etype (Nod) = Class_Wide_Type (Disp_Typ)) 26067 and then (not Is_Entity_Name (Prefix (Nod)) 26068 or else not Is_Formal (Entity (Prefix (Nod)))) 26069 then 26070 Error_Msg_NE 26071 ("operation in class-wide condition must be primitive of &", 26072 Nod, Disp_Typ); 26073 end if; 26074 26075 return OK; 26076 end Check_References; 26077 26078 procedure Check_Class_Wide_Condition is 26079 new Traverse_Proc (Check_References); 26080 26081 -- Local variables 26082 26083 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 26084 26085 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; 26086 Saved_IGR : constant Node_Id := Ignored_Ghost_Region; 26087 -- Save the Ghost-related attributes to restore on exit 26088 26089 Errors : Nat; 26090 Restore_Scope : Boolean := False; 26091 26092 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part 26093 26094 begin 26095 -- Do not analyze the pragma multiple times 26096 26097 if Is_Analyzed_Pragma (N) then 26098 return; 26099 end if; 26100 26101 -- Set the Ghost mode in effect from the pragma. Due to the delayed 26102 -- analysis of the pragma, the Ghost mode at point of declaration and 26103 -- point of analysis may not necessarily be the same. Use the mode in 26104 -- effect at the point of declaration. 26105 26106 Set_Ghost_Mode (N); 26107 26108 -- Ensure that the subprogram and its formals are visible when analyzing 26109 -- the expression of the pragma. 26110 26111 if not In_Open_Scopes (Spec_Id) then 26112 Restore_Scope := True; 26113 Push_Scope (Spec_Id); 26114 26115 if Is_Generic_Subprogram (Spec_Id) then 26116 Install_Generic_Formals (Spec_Id); 26117 else 26118 Install_Formals (Spec_Id); 26119 end if; 26120 end if; 26121 26122 Errors := Serious_Errors_Detected; 26123 Preanalyze_Assert_Expression (Expr, Standard_Boolean); 26124 26125 -- Emit a clarification message when the expression contains at least 26126 -- one undefined reference, possibly due to contract freezing. 26127 26128 if Errors /= Serious_Errors_Detected 26129 and then Present (Freeze_Id) 26130 and then Has_Undefined_Reference (Expr) 26131 then 26132 Contract_Freeze_Error (Spec_Id, Freeze_Id); 26133 end if; 26134 26135 if Class_Present (N) then 26136 26137 -- Verify that a class-wide condition is legal, i.e. the operation is 26138 -- a primitive of a tagged type. Note that a generic subprogram is 26139 -- not a primitive operation. 26140 26141 Disp_Typ := Find_Dispatching_Type (Spec_Id); 26142 26143 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then 26144 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N); 26145 26146 if From_Aspect_Specification (N) then 26147 Error_Msg_N 26148 ("aspect % can only be specified for a primitive operation " 26149 & "of a tagged type", Corresponding_Aspect (N)); 26150 26151 -- The pragma is a source construct 26152 26153 else 26154 Error_Msg_N 26155 ("pragma % can only be specified for a primitive operation " 26156 & "of a tagged type", N); 26157 end if; 26158 26159 -- Remaining semantic checks require a full tree traversal 26160 26161 else 26162 Check_Class_Wide_Condition (Expr); 26163 end if; 26164 26165 end if; 26166 26167 if Restore_Scope then 26168 End_Scope; 26169 end if; 26170 26171 -- If analysis of the condition indicates that a class-wide clone 26172 -- has been created, build and analyze its declaration. 26173 26174 if Is_Subprogram (Spec_Id) 26175 and then Present (Class_Wide_Clone (Spec_Id)) 26176 then 26177 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id))); 26178 end if; 26179 26180 -- Currently it is not possible to inline pre/postconditions on a 26181 -- subprogram subject to pragma Inline_Always. 26182 26183 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 26184 Set_Is_Analyzed_Pragma (N); 26185 26186 Restore_Ghost_Region (Saved_GM, Saved_IGR); 26187 end Analyze_Pre_Post_Condition_In_Decl_Part; 26188 26189 ------------------------------------------ 26190 -- Analyze_Refined_Depends_In_Decl_Part -- 26191 ------------------------------------------ 26192 26193 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is 26194 procedure Check_Dependency_Clause 26195 (Spec_Id : Entity_Id; 26196 Dep_Clause : Node_Id; 26197 Dep_States : Elist_Id; 26198 Refinements : List_Id; 26199 Matched_Items : in out Elist_Id); 26200 -- Try to match a single dependency clause Dep_Clause against one or 26201 -- more refinement clauses found in list Refinements. Each successful 26202 -- match eliminates at least one refinement clause from Refinements. 26203 -- Spec_Id denotes the entity of the related subprogram. Dep_States 26204 -- denotes the entities of all abstract states which appear in pragma 26205 -- Depends. Matched_Items contains the entities of all successfully 26206 -- matched items found in pragma Depends. 26207 26208 procedure Check_Output_States 26209 (Spec_Inputs : Elist_Id; 26210 Spec_Outputs : Elist_Id; 26211 Body_Inputs : Elist_Id; 26212 Body_Outputs : Elist_Id); 26213 -- Determine whether pragma Depends contains an output state with a 26214 -- visible refinement and if so, ensure that pragma Refined_Depends 26215 -- mentions all its constituents as outputs. Spec_Inputs and 26216 -- Spec_Outputs denote the inputs and outputs of the subprogram spec 26217 -- synthesized from pragma Depends. Body_Inputs and Body_Outputs denote 26218 -- the inputs and outputs of the subprogram body synthesized from pragma 26219 -- Refined_Depends. 26220 26221 function Collect_States (Clauses : List_Id) return Elist_Id; 26222 -- Given a normalized list of dependencies obtained from calling 26223 -- Normalize_Clauses, return a list containing the entities of all 26224 -- states appearing in dependencies. It helps in checking refinements 26225 -- involving a state and a corresponding constituent which is not a 26226 -- direct constituent of the state. 26227 26228 procedure Normalize_Clauses (Clauses : List_Id); 26229 -- Given a list of dependence or refinement clauses Clauses, normalize 26230 -- each clause by creating multiple dependencies with exactly one input 26231 -- and one output. 26232 26233 procedure Remove_Extra_Clauses 26234 (Clauses : List_Id; 26235 Matched_Items : Elist_Id); 26236 -- Given a list of refinement clauses Clauses, remove all clauses whose 26237 -- inputs and/or outputs have been previously matched. See the body for 26238 -- all special cases. Matched_Items contains the entities of all matched 26239 -- items found in pragma Depends. 26240 26241 procedure Report_Extra_Clauses (Clauses : List_Id); 26242 -- Emit an error for each extra clause found in list Clauses 26243 26244 ----------------------------- 26245 -- Check_Dependency_Clause -- 26246 ----------------------------- 26247 26248 procedure Check_Dependency_Clause 26249 (Spec_Id : Entity_Id; 26250 Dep_Clause : Node_Id; 26251 Dep_States : Elist_Id; 26252 Refinements : List_Id; 26253 Matched_Items : in out Elist_Id) 26254 is 26255 Dep_Input : constant Node_Id := Expression (Dep_Clause); 26256 Dep_Output : constant Node_Id := First (Choices (Dep_Clause)); 26257 26258 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean; 26259 -- Determine whether dependency item Dep_Item has been matched in a 26260 -- previous clause. 26261 26262 function Is_In_Out_State_Clause return Boolean; 26263 -- Determine whether dependence clause Dep_Clause denotes an abstract 26264 -- state that depends on itself (State => State). 26265 26266 function Is_Null_Refined_State (Item : Node_Id) return Boolean; 26267 -- Determine whether item Item denotes an abstract state with visible 26268 -- null refinement. 26269 26270 procedure Match_Items 26271 (Dep_Item : Node_Id; 26272 Ref_Item : Node_Id; 26273 Matched : out Boolean); 26274 -- Try to match dependence item Dep_Item against refinement item 26275 -- Ref_Item. To match against a possible null refinement (see 2, 9), 26276 -- set Ref_Item to Empty. Flag Matched is set to True when one of 26277 -- the following conformance scenarios is in effect: 26278 -- 1) Both items denote null 26279 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case) 26280 -- 3) Both items denote attribute 'Result 26281 -- 4) Both items denote the same object 26282 -- 5) Both items denote the same formal parameter 26283 -- 6) Both items denote the same current instance of a type 26284 -- 7) Both items denote the same discriminant 26285 -- 8) Dep_Item is an abstract state with visible null refinement 26286 -- and Ref_Item denotes null. 26287 -- 9) Dep_Item is an abstract state with visible null refinement 26288 -- and Ref_Item is Empty (special case). 26289 -- 10) Dep_Item is an abstract state with full or partial visible 26290 -- non-null refinement and Ref_Item denotes one of its 26291 -- constituents. 26292 -- 11) Dep_Item is an abstract state without a full visible 26293 -- refinement and Ref_Item denotes the same state. 26294 -- When scenario 10 is in effect, the entity of the abstract state 26295 -- denoted by Dep_Item is added to list Refined_States. 26296 26297 procedure Record_Item (Item_Id : Entity_Id); 26298 -- Store the entity of an item denoted by Item_Id in Matched_Items 26299 26300 ------------------------ 26301 -- Is_Already_Matched -- 26302 ------------------------ 26303 26304 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is 26305 Item_Id : Entity_Id := Empty; 26306 26307 begin 26308 -- When the dependency item denotes attribute 'Result, check for 26309 -- the entity of the related subprogram. 26310 26311 if Is_Attribute_Result (Dep_Item) then 26312 Item_Id := Spec_Id; 26313 26314 elsif Is_Entity_Name (Dep_Item) then 26315 Item_Id := Available_View (Entity_Of (Dep_Item)); 26316 end if; 26317 26318 return 26319 Present (Item_Id) and then Contains (Matched_Items, Item_Id); 26320 end Is_Already_Matched; 26321 26322 ---------------------------- 26323 -- Is_In_Out_State_Clause -- 26324 ---------------------------- 26325 26326 function Is_In_Out_State_Clause return Boolean is 26327 Dep_Input_Id : Entity_Id; 26328 Dep_Output_Id : Entity_Id; 26329 26330 begin 26331 -- Detect the following clause: 26332 -- State => State 26333 26334 if Is_Entity_Name (Dep_Input) 26335 and then Is_Entity_Name (Dep_Output) 26336 then 26337 -- Handle abstract views generated for limited with clauses 26338 26339 Dep_Input_Id := Available_View (Entity_Of (Dep_Input)); 26340 Dep_Output_Id := Available_View (Entity_Of (Dep_Output)); 26341 26342 return 26343 Ekind (Dep_Input_Id) = E_Abstract_State 26344 and then Dep_Input_Id = Dep_Output_Id; 26345 else 26346 return False; 26347 end if; 26348 end Is_In_Out_State_Clause; 26349 26350 --------------------------- 26351 -- Is_Null_Refined_State -- 26352 --------------------------- 26353 26354 function Is_Null_Refined_State (Item : Node_Id) return Boolean is 26355 Item_Id : Entity_Id; 26356 26357 begin 26358 if Is_Entity_Name (Item) then 26359 26360 -- Handle abstract views generated for limited with clauses 26361 26362 Item_Id := Available_View (Entity_Of (Item)); 26363 26364 return 26365 Ekind (Item_Id) = E_Abstract_State 26366 and then Has_Null_Visible_Refinement (Item_Id); 26367 else 26368 return False; 26369 end if; 26370 end Is_Null_Refined_State; 26371 26372 ----------------- 26373 -- Match_Items -- 26374 ----------------- 26375 26376 procedure Match_Items 26377 (Dep_Item : Node_Id; 26378 Ref_Item : Node_Id; 26379 Matched : out Boolean) 26380 is 26381 Dep_Item_Id : Entity_Id; 26382 Ref_Item_Id : Entity_Id; 26383 26384 begin 26385 -- Assume that the two items do not match 26386 26387 Matched := False; 26388 26389 -- A null matches null or Empty (special case) 26390 26391 if Nkind (Dep_Item) = N_Null 26392 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null) 26393 then 26394 Matched := True; 26395 26396 -- Attribute 'Result matches attribute 'Result 26397 26398 elsif Is_Attribute_Result (Dep_Item) 26399 and then Is_Attribute_Result (Ref_Item) 26400 then 26401 -- Put the entity of the related function on the list of 26402 -- matched items because attribute 'Result does not carry 26403 -- an entity similar to states and constituents. 26404 26405 Record_Item (Spec_Id); 26406 Matched := True; 26407 26408 -- Abstract states, current instances of concurrent types, 26409 -- discriminants, formal parameters and objects. 26410 26411 elsif Is_Entity_Name (Dep_Item) then 26412 26413 -- Handle abstract views generated for limited with clauses 26414 26415 Dep_Item_Id := Available_View (Entity_Of (Dep_Item)); 26416 26417 if Ekind (Dep_Item_Id) = E_Abstract_State then 26418 26419 -- An abstract state with visible null refinement matches 26420 -- null or Empty (special case). 26421 26422 if Has_Null_Visible_Refinement (Dep_Item_Id) 26423 and then (No (Ref_Item) or else Nkind (Ref_Item) = N_Null) 26424 then 26425 Record_Item (Dep_Item_Id); 26426 Matched := True; 26427 26428 -- An abstract state with visible non-null refinement 26429 -- matches one of its constituents, or itself for an 26430 -- abstract state with partial visible refinement. 26431 26432 elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then 26433 if Is_Entity_Name (Ref_Item) then 26434 Ref_Item_Id := Entity_Of (Ref_Item); 26435 26436 if Ekind_In (Ref_Item_Id, E_Abstract_State, 26437 E_Constant, 26438 E_Variable) 26439 and then Present (Encapsulating_State (Ref_Item_Id)) 26440 and then Find_Encapsulating_State 26441 (Dep_States, Ref_Item_Id) = Dep_Item_Id 26442 then 26443 Record_Item (Dep_Item_Id); 26444 Matched := True; 26445 26446 elsif not Has_Visible_Refinement (Dep_Item_Id) 26447 and then Ref_Item_Id = Dep_Item_Id 26448 then 26449 Record_Item (Dep_Item_Id); 26450 Matched := True; 26451 end if; 26452 end if; 26453 26454 -- An abstract state without a visible refinement matches 26455 -- itself. 26456 26457 elsif Is_Entity_Name (Ref_Item) 26458 and then Entity_Of (Ref_Item) = Dep_Item_Id 26459 then 26460 Record_Item (Dep_Item_Id); 26461 Matched := True; 26462 end if; 26463 26464 -- A current instance of a concurrent type, discriminant, 26465 -- formal parameter or an object matches itself. 26466 26467 elsif Is_Entity_Name (Ref_Item) 26468 and then Entity_Of (Ref_Item) = Dep_Item_Id 26469 then 26470 Record_Item (Dep_Item_Id); 26471 Matched := True; 26472 end if; 26473 end if; 26474 end Match_Items; 26475 26476 ----------------- 26477 -- Record_Item -- 26478 ----------------- 26479 26480 procedure Record_Item (Item_Id : Entity_Id) is 26481 begin 26482 if No (Matched_Items) then 26483 Matched_Items := New_Elmt_List; 26484 end if; 26485 26486 Append_Unique_Elmt (Item_Id, Matched_Items); 26487 end Record_Item; 26488 26489 -- Local variables 26490 26491 Clause_Matched : Boolean := False; 26492 Dummy : Boolean := False; 26493 Inputs_Match : Boolean; 26494 Next_Ref_Clause : Node_Id; 26495 Outputs_Match : Boolean; 26496 Ref_Clause : Node_Id; 26497 Ref_Input : Node_Id; 26498 Ref_Output : Node_Id; 26499 26500 -- Start of processing for Check_Dependency_Clause 26501 26502 begin 26503 -- Do not perform this check in an instance because it was already 26504 -- performed successfully in the generic template. 26505 26506 if In_Instance then 26507 return; 26508 end if; 26509 26510 -- Examine all refinement clauses and compare them against the 26511 -- dependence clause. 26512 26513 Ref_Clause := First (Refinements); 26514 while Present (Ref_Clause) loop 26515 Next_Ref_Clause := Next (Ref_Clause); 26516 26517 -- Obtain the attributes of the current refinement clause 26518 26519 Ref_Input := Expression (Ref_Clause); 26520 Ref_Output := First (Choices (Ref_Clause)); 26521 26522 -- The current refinement clause matches the dependence clause 26523 -- when both outputs match and both inputs match. See routine 26524 -- Match_Items for all possible conformance scenarios. 26525 26526 -- Depends Dep_Output => Dep_Input 26527 -- ^ ^ 26528 -- match ? match ? 26529 -- v v 26530 -- Refined_Depends Ref_Output => Ref_Input 26531 26532 Match_Items 26533 (Dep_Item => Dep_Input, 26534 Ref_Item => Ref_Input, 26535 Matched => Inputs_Match); 26536 26537 Match_Items 26538 (Dep_Item => Dep_Output, 26539 Ref_Item => Ref_Output, 26540 Matched => Outputs_Match); 26541 26542 -- An In_Out state clause may be matched against a refinement with 26543 -- a null input or null output as long as the non-null side of the 26544 -- relation contains a valid constituent of the In_Out_State. 26545 26546 if Is_In_Out_State_Clause then 26547 26548 -- Depends => (State => State) 26549 -- Refined_Depends => (null => Constit) -- OK 26550 26551 if Inputs_Match 26552 and then not Outputs_Match 26553 and then Nkind (Ref_Output) = N_Null 26554 then 26555 Outputs_Match := True; 26556 end if; 26557 26558 -- Depends => (State => State) 26559 -- Refined_Depends => (Constit => null) -- OK 26560 26561 if not Inputs_Match 26562 and then Outputs_Match 26563 and then Nkind (Ref_Input) = N_Null 26564 then 26565 Inputs_Match := True; 26566 end if; 26567 end if; 26568 26569 -- The current refinement clause is legally constructed following 26570 -- the rules in SPARK RM 7.2.5, therefore it can be removed from 26571 -- the pool of candidates. The seach continues because a single 26572 -- dependence clause may have multiple matching refinements. 26573 26574 if Inputs_Match and Outputs_Match then 26575 Clause_Matched := True; 26576 Remove (Ref_Clause); 26577 end if; 26578 26579 Ref_Clause := Next_Ref_Clause; 26580 end loop; 26581 26582 -- Depending on the order or composition of refinement clauses, an 26583 -- In_Out state clause may not be directly refinable. 26584 26585 -- Refined_State => (State => (Constit_1, Constit_2)) 26586 -- Depends => ((Output, State) => (Input, State)) 26587 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2) 26588 26589 -- Matching normalized clause (State => State) fails because there is 26590 -- no direct refinement capable of satisfying this relation. Another 26591 -- similar case arises when clauses (Constit_1 => Input) and (Output 26592 -- => Constit_2) are matched first, leaving no candidates for clause 26593 -- (State => State). Both scenarios are legal as long as one of the 26594 -- previous clauses mentioned a valid constituent of State. 26595 26596 if not Clause_Matched 26597 and then Is_In_Out_State_Clause 26598 and then Is_Already_Matched (Dep_Input) 26599 then 26600 Clause_Matched := True; 26601 end if; 26602 26603 -- A clause where the input is an abstract state with visible null 26604 -- refinement or a 'Result attribute is implicitly matched when the 26605 -- output has already been matched in a previous clause. 26606 26607 -- Refined_State => (State => null) 26608 -- Depends => (Output => State) -- implicitly OK 26609 -- Refined_Depends => (Output => ...) 26610 -- Depends => (...'Result => State) -- implicitly OK 26611 -- Refined_Depends => (...'Result => ...) 26612 26613 if not Clause_Matched 26614 and then Is_Null_Refined_State (Dep_Input) 26615 and then Is_Already_Matched (Dep_Output) 26616 then 26617 Clause_Matched := True; 26618 end if; 26619 26620 -- A clause where the output is an abstract state with visible null 26621 -- refinement is implicitly matched when the input has already been 26622 -- matched in a previous clause. 26623 26624 -- Refined_State => (State => null) 26625 -- Depends => (State => Input) -- implicitly OK 26626 -- Refined_Depends => (... => Input) 26627 26628 if not Clause_Matched 26629 and then Is_Null_Refined_State (Dep_Output) 26630 and then Is_Already_Matched (Dep_Input) 26631 then 26632 Clause_Matched := True; 26633 end if; 26634 26635 -- At this point either all refinement clauses have been examined or 26636 -- pragma Refined_Depends contains a solitary null. Only an abstract 26637 -- state with null refinement can possibly match these cases. 26638 26639 -- Refined_State => (State => null) 26640 -- Depends => (State => null) 26641 -- Refined_Depends => null -- OK 26642 26643 if not Clause_Matched then 26644 Match_Items 26645 (Dep_Item => Dep_Input, 26646 Ref_Item => Empty, 26647 Matched => Inputs_Match); 26648 26649 Match_Items 26650 (Dep_Item => Dep_Output, 26651 Ref_Item => Empty, 26652 Matched => Outputs_Match); 26653 26654 Clause_Matched := Inputs_Match and Outputs_Match; 26655 end if; 26656 26657 -- If the contents of Refined_Depends are legal, then the current 26658 -- dependence clause should be satisfied either by an explicit match 26659 -- or by one of the special cases. 26660 26661 if not Clause_Matched then 26662 SPARK_Msg_NE 26663 (Fix_Msg (Spec_Id, "dependence clause of subprogram & has no " 26664 & "matching refinement in body"), Dep_Clause, Spec_Id); 26665 end if; 26666 end Check_Dependency_Clause; 26667 26668 ------------------------- 26669 -- Check_Output_States -- 26670 ------------------------- 26671 26672 procedure Check_Output_States 26673 (Spec_Inputs : Elist_Id; 26674 Spec_Outputs : Elist_Id; 26675 Body_Inputs : Elist_Id; 26676 Body_Outputs : Elist_Id) 26677 is 26678 procedure Check_Constituent_Usage (State_Id : Entity_Id); 26679 -- Determine whether all constituents of state State_Id with full 26680 -- visible refinement are used as outputs in pragma Refined_Depends. 26681 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)). 26682 26683 ----------------------------- 26684 -- Check_Constituent_Usage -- 26685 ----------------------------- 26686 26687 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 26688 Constits : constant Elist_Id := 26689 Partial_Refinement_Constituents (State_Id); 26690 Constit_Elmt : Elmt_Id; 26691 Constit_Id : Entity_Id; 26692 Only_Partial : constant Boolean := 26693 not Has_Visible_Refinement (State_Id); 26694 Posted : Boolean := False; 26695 26696 begin 26697 if Present (Constits) then 26698 Constit_Elmt := First_Elmt (Constits); 26699 while Present (Constit_Elmt) loop 26700 Constit_Id := Node (Constit_Elmt); 26701 26702 -- Issue an error when a constituent of State_Id is used, 26703 -- and State_Id has only partial visible refinement 26704 -- (SPARK RM 7.2.4(3d)). 26705 26706 if Only_Partial then 26707 if (Present (Body_Inputs) 26708 and then Appears_In (Body_Inputs, Constit_Id)) 26709 or else 26710 (Present (Body_Outputs) 26711 and then Appears_In (Body_Outputs, Constit_Id)) 26712 then 26713 Error_Msg_Name_1 := Chars (State_Id); 26714 SPARK_Msg_NE 26715 ("constituent & of state % cannot be used in " 26716 & "dependence refinement", N, Constit_Id); 26717 Error_Msg_Name_1 := Chars (State_Id); 26718 SPARK_Msg_N ("\use state % instead", N); 26719 end if; 26720 26721 -- The constituent acts as an input (SPARK RM 7.2.5(3)) 26722 26723 elsif Present (Body_Inputs) 26724 and then Appears_In (Body_Inputs, Constit_Id) 26725 then 26726 Error_Msg_Name_1 := Chars (State_Id); 26727 SPARK_Msg_NE 26728 ("constituent & of state % must act as output in " 26729 & "dependence refinement", N, Constit_Id); 26730 26731 -- The constituent is altogether missing (SPARK RM 7.2.5(3)) 26732 26733 elsif No (Body_Outputs) 26734 or else not Appears_In (Body_Outputs, Constit_Id) 26735 then 26736 if not Posted then 26737 Posted := True; 26738 SPARK_Msg_NE 26739 ("output state & must be replaced by all its " 26740 & "constituents in dependence refinement", 26741 N, State_Id); 26742 end if; 26743 26744 SPARK_Msg_NE 26745 ("\constituent & is missing in output list", 26746 N, Constit_Id); 26747 end if; 26748 26749 Next_Elmt (Constit_Elmt); 26750 end loop; 26751 end if; 26752 end Check_Constituent_Usage; 26753 26754 -- Local variables 26755 26756 Item : Node_Id; 26757 Item_Elmt : Elmt_Id; 26758 Item_Id : Entity_Id; 26759 26760 -- Start of processing for Check_Output_States 26761 26762 begin 26763 -- Do not perform this check in an instance because it was already 26764 -- performed successfully in the generic template. 26765 26766 if In_Instance then 26767 null; 26768 26769 -- Inspect the outputs of pragma Depends looking for a state with a 26770 -- visible refinement. 26771 26772 elsif Present (Spec_Outputs) then 26773 Item_Elmt := First_Elmt (Spec_Outputs); 26774 while Present (Item_Elmt) loop 26775 Item := Node (Item_Elmt); 26776 26777 -- Deal with the mixed nature of the input and output lists 26778 26779 if Nkind (Item) = N_Defining_Identifier then 26780 Item_Id := Item; 26781 else 26782 Item_Id := Available_View (Entity_Of (Item)); 26783 end if; 26784 26785 if Ekind (Item_Id) = E_Abstract_State then 26786 26787 -- The state acts as an input-output, skip it 26788 26789 if Present (Spec_Inputs) 26790 and then Appears_In (Spec_Inputs, Item_Id) 26791 then 26792 null; 26793 26794 -- Ensure that all of the constituents are utilized as 26795 -- outputs in pragma Refined_Depends. 26796 26797 elsif Has_Non_Null_Visible_Refinement (Item_Id) then 26798 Check_Constituent_Usage (Item_Id); 26799 end if; 26800 end if; 26801 26802 Next_Elmt (Item_Elmt); 26803 end loop; 26804 end if; 26805 end Check_Output_States; 26806 26807 -------------------- 26808 -- Collect_States -- 26809 -------------------- 26810 26811 function Collect_States (Clauses : List_Id) return Elist_Id is 26812 procedure Collect_State 26813 (Item : Node_Id; 26814 States : in out Elist_Id); 26815 -- Add the entity of Item to list States when it denotes to a state 26816 26817 ------------------- 26818 -- Collect_State -- 26819 ------------------- 26820 26821 procedure Collect_State 26822 (Item : Node_Id; 26823 States : in out Elist_Id) 26824 is 26825 Id : Entity_Id; 26826 26827 begin 26828 if Is_Entity_Name (Item) then 26829 Id := Entity_Of (Item); 26830 26831 if Ekind (Id) = E_Abstract_State then 26832 if No (States) then 26833 States := New_Elmt_List; 26834 end if; 26835 26836 Append_Unique_Elmt (Id, States); 26837 end if; 26838 end if; 26839 end Collect_State; 26840 26841 -- Local variables 26842 26843 Clause : Node_Id; 26844 Input : Node_Id; 26845 Output : Node_Id; 26846 States : Elist_Id := No_Elist; 26847 26848 -- Start of processing for Collect_States 26849 26850 begin 26851 Clause := First (Clauses); 26852 while Present (Clause) loop 26853 Input := Expression (Clause); 26854 Output := First (Choices (Clause)); 26855 26856 Collect_State (Input, States); 26857 Collect_State (Output, States); 26858 26859 Next (Clause); 26860 end loop; 26861 26862 return States; 26863 end Collect_States; 26864 26865 ----------------------- 26866 -- Normalize_Clauses -- 26867 ----------------------- 26868 26869 procedure Normalize_Clauses (Clauses : List_Id) is 26870 procedure Normalize_Inputs (Clause : Node_Id); 26871 -- Normalize clause Clause by creating multiple clauses for each 26872 -- input item of Clause. It is assumed that Clause has exactly one 26873 -- output. The transformation is as follows: 26874 -- 26875 -- Output => (Input_1, Input_2) -- original 26876 -- 26877 -- Output => Input_1 -- normalizations 26878 -- Output => Input_2 26879 26880 procedure Normalize_Outputs (Clause : Node_Id); 26881 -- Normalize clause Clause by creating multiple clause for each 26882 -- output item of Clause. The transformation is as follows: 26883 -- 26884 -- (Output_1, Output_2) => Input -- original 26885 -- 26886 -- Output_1 => Input -- normalization 26887 -- Output_2 => Input 26888 26889 ---------------------- 26890 -- Normalize_Inputs -- 26891 ---------------------- 26892 26893 procedure Normalize_Inputs (Clause : Node_Id) is 26894 Inputs : constant Node_Id := Expression (Clause); 26895 Loc : constant Source_Ptr := Sloc (Clause); 26896 Output : constant List_Id := Choices (Clause); 26897 Last_Input : Node_Id; 26898 Input : Node_Id; 26899 New_Clause : Node_Id; 26900 Next_Input : Node_Id; 26901 26902 begin 26903 -- Normalization is performed only when the original clause has 26904 -- more than one input. Multiple inputs appear as an aggregate. 26905 26906 if Nkind (Inputs) = N_Aggregate then 26907 Last_Input := Last (Expressions (Inputs)); 26908 26909 -- Create a new clause for each input 26910 26911 Input := First (Expressions (Inputs)); 26912 while Present (Input) loop 26913 Next_Input := Next (Input); 26914 26915 -- Unhook the current input from the original input list 26916 -- because it will be relocated to a new clause. 26917 26918 Remove (Input); 26919 26920 -- Special processing for the last input. At this point the 26921 -- original aggregate has been stripped down to one element. 26922 -- Replace the aggregate by the element itself. 26923 26924 if Input = Last_Input then 26925 Rewrite (Inputs, Input); 26926 26927 -- Generate a clause of the form: 26928 -- Output => Input 26929 26930 else 26931 New_Clause := 26932 Make_Component_Association (Loc, 26933 Choices => New_Copy_List_Tree (Output), 26934 Expression => Input); 26935 26936 -- The new clause contains replicated content that has 26937 -- already been analyzed, mark the clause as analyzed. 26938 26939 Set_Analyzed (New_Clause); 26940 Insert_After (Clause, New_Clause); 26941 end if; 26942 26943 Input := Next_Input; 26944 end loop; 26945 end if; 26946 end Normalize_Inputs; 26947 26948 ----------------------- 26949 -- Normalize_Outputs -- 26950 ----------------------- 26951 26952 procedure Normalize_Outputs (Clause : Node_Id) is 26953 Inputs : constant Node_Id := Expression (Clause); 26954 Loc : constant Source_Ptr := Sloc (Clause); 26955 Outputs : constant Node_Id := First (Choices (Clause)); 26956 Last_Output : Node_Id; 26957 New_Clause : Node_Id; 26958 Next_Output : Node_Id; 26959 Output : Node_Id; 26960 26961 begin 26962 -- Multiple outputs appear as an aggregate. Nothing to do when 26963 -- the clause has exactly one output. 26964 26965 if Nkind (Outputs) = N_Aggregate then 26966 Last_Output := Last (Expressions (Outputs)); 26967 26968 -- Create a clause for each output. Note that each time a new 26969 -- clause is created, the original output list slowly shrinks 26970 -- until there is one item left. 26971 26972 Output := First (Expressions (Outputs)); 26973 while Present (Output) loop 26974 Next_Output := Next (Output); 26975 26976 -- Unhook the output from the original output list as it 26977 -- will be relocated to a new clause. 26978 26979 Remove (Output); 26980 26981 -- Special processing for the last output. At this point 26982 -- the original aggregate has been stripped down to one 26983 -- element. Replace the aggregate by the element itself. 26984 26985 if Output = Last_Output then 26986 Rewrite (Outputs, Output); 26987 26988 else 26989 -- Generate a clause of the form: 26990 -- (Output => Inputs) 26991 26992 New_Clause := 26993 Make_Component_Association (Loc, 26994 Choices => New_List (Output), 26995 Expression => New_Copy_Tree (Inputs)); 26996 26997 -- The new clause contains replicated content that has 26998 -- already been analyzed. There is not need to reanalyze 26999 -- them. 27000 27001 Set_Analyzed (New_Clause); 27002 Insert_After (Clause, New_Clause); 27003 end if; 27004 27005 Output := Next_Output; 27006 end loop; 27007 end if; 27008 end Normalize_Outputs; 27009 27010 -- Local variables 27011 27012 Clause : Node_Id; 27013 27014 -- Start of processing for Normalize_Clauses 27015 27016 begin 27017 Clause := First (Clauses); 27018 while Present (Clause) loop 27019 Normalize_Outputs (Clause); 27020 Next (Clause); 27021 end loop; 27022 27023 Clause := First (Clauses); 27024 while Present (Clause) loop 27025 Normalize_Inputs (Clause); 27026 Next (Clause); 27027 end loop; 27028 end Normalize_Clauses; 27029 27030 -------------------------- 27031 -- Remove_Extra_Clauses -- 27032 -------------------------- 27033 27034 procedure Remove_Extra_Clauses 27035 (Clauses : List_Id; 27036 Matched_Items : Elist_Id) 27037 is 27038 Clause : Node_Id; 27039 Input : Node_Id; 27040 Input_Id : Entity_Id; 27041 Next_Clause : Node_Id; 27042 Output : Node_Id; 27043 State_Id : Entity_Id; 27044 27045 begin 27046 Clause := First (Clauses); 27047 while Present (Clause) loop 27048 Next_Clause := Next (Clause); 27049 27050 Input := Expression (Clause); 27051 Output := First (Choices (Clause)); 27052 27053 -- Recognize a clause of the form 27054 27055 -- null => Input 27056 27057 -- where Input is a constituent of a state which was already 27058 -- successfully matched. This clause must be removed because it 27059 -- simply indicates that some of the constituents of the state 27060 -- are not used. 27061 27062 -- Refined_State => (State => (Constit_1, Constit_2)) 27063 -- Depends => (Output => State) 27064 -- Refined_Depends => ((Output => Constit_1), -- State matched 27065 -- (null => Constit_2)) -- OK 27066 27067 if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then 27068 27069 -- Handle abstract views generated for limited with clauses 27070 27071 Input_Id := Available_View (Entity_Of (Input)); 27072 27073 -- The input must be a constituent of a state 27074 27075 if Ekind_In (Input_Id, E_Abstract_State, 27076 E_Constant, 27077 E_Variable) 27078 and then Present (Encapsulating_State (Input_Id)) 27079 then 27080 State_Id := Encapsulating_State (Input_Id); 27081 27082 -- The state must have a non-null visible refinement and be 27083 -- matched in a previous clause. 27084 27085 if Has_Non_Null_Visible_Refinement (State_Id) 27086 and then Contains (Matched_Items, State_Id) 27087 then 27088 Remove (Clause); 27089 end if; 27090 end if; 27091 27092 -- Recognize a clause of the form 27093 27094 -- Output => null 27095 27096 -- where Output is an arbitrary item. This clause must be removed 27097 -- because a null input legitimately matches anything. 27098 27099 elsif Nkind (Input) = N_Null then 27100 Remove (Clause); 27101 end if; 27102 27103 Clause := Next_Clause; 27104 end loop; 27105 end Remove_Extra_Clauses; 27106 27107 -------------------------- 27108 -- Report_Extra_Clauses -- 27109 -------------------------- 27110 27111 procedure Report_Extra_Clauses (Clauses : List_Id) is 27112 Clause : Node_Id; 27113 27114 begin 27115 -- Do not perform this check in an instance because it was already 27116 -- performed successfully in the generic template. 27117 27118 if In_Instance then 27119 null; 27120 27121 elsif Present (Clauses) then 27122 Clause := First (Clauses); 27123 while Present (Clause) loop 27124 SPARK_Msg_N 27125 ("unmatched or extra clause in dependence refinement", 27126 Clause); 27127 27128 Next (Clause); 27129 end loop; 27130 end if; 27131 end Report_Extra_Clauses; 27132 27133 -- Local variables 27134 27135 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 27136 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 27137 Errors : constant Nat := Serious_Errors_Detected; 27138 27139 Clause : Node_Id; 27140 Deps : Node_Id; 27141 Dummy : Boolean; 27142 Refs : Node_Id; 27143 27144 Body_Inputs : Elist_Id := No_Elist; 27145 Body_Outputs : Elist_Id := No_Elist; 27146 -- The inputs and outputs of the subprogram body synthesized from pragma 27147 -- Refined_Depends. 27148 27149 Dependencies : List_Id := No_List; 27150 Depends : Node_Id; 27151 -- The corresponding Depends pragma along with its clauses 27152 27153 Matched_Items : Elist_Id := No_Elist; 27154 -- A list containing the entities of all successfully matched items 27155 -- found in pragma Depends. 27156 27157 Refinements : List_Id := No_List; 27158 -- The clauses of pragma Refined_Depends 27159 27160 Spec_Id : Entity_Id; 27161 -- The entity of the subprogram subject to pragma Refined_Depends 27162 27163 Spec_Inputs : Elist_Id := No_Elist; 27164 Spec_Outputs : Elist_Id := No_Elist; 27165 -- The inputs and outputs of the subprogram spec synthesized from pragma 27166 -- Depends. 27167 27168 States : Elist_Id := No_Elist; 27169 -- A list containing the entities of all states whose constituents 27170 -- appear in pragma Depends. 27171 27172 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part 27173 27174 begin 27175 -- Do not analyze the pragma multiple times 27176 27177 if Is_Analyzed_Pragma (N) then 27178 return; 27179 end if; 27180 27181 Spec_Id := Unique_Defining_Entity (Body_Decl); 27182 27183 -- Use the anonymous object as the proper spec when Refined_Depends 27184 -- applies to the body of a single task type. The object carries the 27185 -- proper Chars as well as all non-refined versions of pragmas. 27186 27187 if Is_Single_Concurrent_Type (Spec_Id) then 27188 Spec_Id := Anonymous_Object (Spec_Id); 27189 end if; 27190 27191 Depends := Get_Pragma (Spec_Id, Pragma_Depends); 27192 27193 -- Subprogram declarations lacks pragma Depends. Refined_Depends is 27194 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)). 27195 27196 if No (Depends) then 27197 SPARK_Msg_NE 27198 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " 27199 & "& lacks aspect or pragma Depends"), N, Spec_Id); 27200 goto Leave; 27201 end if; 27202 27203 Deps := Expression (Get_Argument (Depends, Spec_Id)); 27204 27205 -- A null dependency relation renders the refinement useless because it 27206 -- cannot possibly mention abstract states with visible refinement. Note 27207 -- that the inverse is not true as states may be refined to null 27208 -- (SPARK RM 7.2.5(2)). 27209 27210 if Nkind (Deps) = N_Null then 27211 SPARK_Msg_NE 27212 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " 27213 & "depend on abstract state with visible refinement"), N, Spec_Id); 27214 goto Leave; 27215 end if; 27216 27217 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends. 27218 -- This ensures that the categorization of all refined dependency items 27219 -- is consistent with their role. 27220 27221 Analyze_Depends_In_Decl_Part (N); 27222 27223 -- Do not match dependencies against refinements if Refined_Depends is 27224 -- illegal to avoid emitting misleading error. 27225 27226 if Serious_Errors_Detected = Errors then 27227 27228 -- The related subprogram lacks pragma [Refined_]Global. Synthesize 27229 -- the inputs and outputs of the subprogram spec and body to verify 27230 -- the use of states with visible refinement and their constituents. 27231 27232 if No (Get_Pragma (Spec_Id, Pragma_Global)) 27233 or else No (Get_Pragma (Body_Id, Pragma_Refined_Global)) 27234 then 27235 Collect_Subprogram_Inputs_Outputs 27236 (Subp_Id => Spec_Id, 27237 Synthesize => True, 27238 Subp_Inputs => Spec_Inputs, 27239 Subp_Outputs => Spec_Outputs, 27240 Global_Seen => Dummy); 27241 27242 Collect_Subprogram_Inputs_Outputs 27243 (Subp_Id => Body_Id, 27244 Synthesize => True, 27245 Subp_Inputs => Body_Inputs, 27246 Subp_Outputs => Body_Outputs, 27247 Global_Seen => Dummy); 27248 27249 -- For an output state with a visible refinement, ensure that all 27250 -- constituents appear as outputs in the dependency refinement. 27251 27252 Check_Output_States 27253 (Spec_Inputs => Spec_Inputs, 27254 Spec_Outputs => Spec_Outputs, 27255 Body_Inputs => Body_Inputs, 27256 Body_Outputs => Body_Outputs); 27257 end if; 27258 27259 -- Matching is disabled in ASIS because clauses are not normalized as 27260 -- this is a tree altering activity similar to expansion. 27261 27262 if ASIS_Mode then 27263 goto Leave; 27264 end if; 27265 27266 -- Multiple dependency clauses appear as component associations of an 27267 -- aggregate. Note that the clauses are copied because the algorithm 27268 -- modifies them and this should not be visible in Depends. 27269 27270 pragma Assert (Nkind (Deps) = N_Aggregate); 27271 Dependencies := New_Copy_List_Tree (Component_Associations (Deps)); 27272 Normalize_Clauses (Dependencies); 27273 27274 -- Gather all states which appear in Depends 27275 27276 States := Collect_States (Dependencies); 27277 27278 Refs := Expression (Get_Argument (N, Spec_Id)); 27279 27280 if Nkind (Refs) = N_Null then 27281 Refinements := No_List; 27282 27283 -- Multiple dependency clauses appear as component associations of an 27284 -- aggregate. Note that the clauses are copied because the algorithm 27285 -- modifies them and this should not be visible in Refined_Depends. 27286 27287 else pragma Assert (Nkind (Refs) = N_Aggregate); 27288 Refinements := New_Copy_List_Tree (Component_Associations (Refs)); 27289 Normalize_Clauses (Refinements); 27290 end if; 27291 27292 -- At this point the clauses of pragmas Depends and Refined_Depends 27293 -- have been normalized into simple dependencies between one output 27294 -- and one input. Examine all clauses of pragma Depends looking for 27295 -- matching clauses in pragma Refined_Depends. 27296 27297 Clause := First (Dependencies); 27298 while Present (Clause) loop 27299 Check_Dependency_Clause 27300 (Spec_Id => Spec_Id, 27301 Dep_Clause => Clause, 27302 Dep_States => States, 27303 Refinements => Refinements, 27304 Matched_Items => Matched_Items); 27305 27306 Next (Clause); 27307 end loop; 27308 27309 -- Pragma Refined_Depends may contain multiple clarification clauses 27310 -- which indicate that certain constituents do not influence the data 27311 -- flow in any way. Such clauses must be removed as long as the state 27312 -- has been matched, otherwise they will be incorrectly flagged as 27313 -- unmatched. 27314 27315 -- Refined_State => (State => (Constit_1, Constit_2)) 27316 -- Depends => (Output => State) 27317 -- Refined_Depends => ((Output => Constit_1), -- State matched 27318 -- (null => Constit_2)) -- must be removed 27319 27320 Remove_Extra_Clauses (Refinements, Matched_Items); 27321 27322 if Serious_Errors_Detected = Errors then 27323 Report_Extra_Clauses (Refinements); 27324 end if; 27325 end if; 27326 27327 <<Leave>> 27328 Set_Is_Analyzed_Pragma (N); 27329 end Analyze_Refined_Depends_In_Decl_Part; 27330 27331 ----------------------------------------- 27332 -- Analyze_Refined_Global_In_Decl_Part -- 27333 ----------------------------------------- 27334 27335 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is 27336 Global : Node_Id; 27337 -- The corresponding Global pragma 27338 27339 Has_In_State : Boolean := False; 27340 Has_In_Out_State : Boolean := False; 27341 Has_Out_State : Boolean := False; 27342 Has_Proof_In_State : Boolean := False; 27343 -- These flags are set when the corresponding Global pragma has a state 27344 -- of mode Input, In_Out, Output or Proof_In respectively with a visible 27345 -- refinement. 27346 27347 Has_Null_State : Boolean := False; 27348 -- This flag is set when the corresponding Global pragma has at least 27349 -- one state with a null refinement. 27350 27351 In_Constits : Elist_Id := No_Elist; 27352 In_Out_Constits : Elist_Id := No_Elist; 27353 Out_Constits : Elist_Id := No_Elist; 27354 Proof_In_Constits : Elist_Id := No_Elist; 27355 -- These lists contain the entities of all Input, In_Out, Output and 27356 -- Proof_In constituents that appear in Refined_Global and participate 27357 -- in state refinement. 27358 27359 In_Items : Elist_Id := No_Elist; 27360 In_Out_Items : Elist_Id := No_Elist; 27361 Out_Items : Elist_Id := No_Elist; 27362 Proof_In_Items : Elist_Id := No_Elist; 27363 -- These lists contain the entities of all Input, In_Out, Output and 27364 -- Proof_In items defined in the corresponding Global pragma. 27365 27366 Repeat_Items : Elist_Id := No_Elist; 27367 -- A list of all global items without full visible refinement found 27368 -- in pragma Global. These states should be repeated in the global 27369 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible 27370 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)). 27371 27372 Spec_Id : Entity_Id; 27373 -- The entity of the subprogram subject to pragma Refined_Global 27374 27375 States : Elist_Id := No_Elist; 27376 -- A list of all states with full or partial visible refinement found in 27377 -- pragma Global. 27378 27379 procedure Check_In_Out_States; 27380 -- Determine whether the corresponding Global pragma mentions In_Out 27381 -- states with visible refinement and if so, ensure that one of the 27382 -- following completions apply to the constituents of the state: 27383 -- 1) there is at least one constituent of mode In_Out 27384 -- 2) there is at least one Input and one Output constituent 27385 -- 3) not all constituents are present and one of them is of mode 27386 -- Output. 27387 -- This routine may remove elements from In_Constits, In_Out_Constits, 27388 -- Out_Constits and Proof_In_Constits. 27389 27390 procedure Check_Input_States; 27391 -- Determine whether the corresponding Global pragma mentions Input 27392 -- states with visible refinement and if so, ensure that at least one of 27393 -- its constituents appears as an Input item in Refined_Global. 27394 -- This routine may remove elements from In_Constits, In_Out_Constits, 27395 -- Out_Constits and Proof_In_Constits. 27396 27397 procedure Check_Output_States; 27398 -- Determine whether the corresponding Global pragma mentions Output 27399 -- states with visible refinement and if so, ensure that all of its 27400 -- constituents appear as Output items in Refined_Global. 27401 -- This routine may remove elements from In_Constits, In_Out_Constits, 27402 -- Out_Constits and Proof_In_Constits. 27403 27404 procedure Check_Proof_In_States; 27405 -- Determine whether the corresponding Global pragma mentions Proof_In 27406 -- states with visible refinement and if so, ensure that at least one of 27407 -- its constituents appears as a Proof_In item in Refined_Global. 27408 -- This routine may remove elements from In_Constits, In_Out_Constits, 27409 -- Out_Constits and Proof_In_Constits. 27410 27411 procedure Check_Refined_Global_List 27412 (List : Node_Id; 27413 Global_Mode : Name_Id := Name_Input); 27414 -- Verify the legality of a single global list declaration. Global_Mode 27415 -- denotes the current mode in effect. 27416 27417 procedure Collect_Global_Items 27418 (List : Node_Id; 27419 Mode : Name_Id := Name_Input); 27420 -- Gather all Input, In_Out, Output and Proof_In items from node List 27421 -- and separate them in lists In_Items, In_Out_Items, Out_Items and 27422 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State 27423 -- and Has_Proof_In_State are set when there is at least one abstract 27424 -- state with full or partial visible refinement available in the 27425 -- corresponding mode. Flag Has_Null_State is set when at least state 27426 -- has a null refinement. Mode denotes the current global mode in 27427 -- effect. 27428 27429 function Present_Then_Remove 27430 (List : Elist_Id; 27431 Item : Entity_Id) return Boolean; 27432 -- Search List for a particular entity Item. If Item has been found, 27433 -- remove it from List. This routine is used to strip lists In_Constits, 27434 -- In_Out_Constits and Out_Constits of valid constituents. 27435 27436 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id); 27437 -- Same as function Present_Then_Remove, but do not report the presence 27438 -- of Item in List. 27439 27440 procedure Report_Extra_Constituents; 27441 -- Emit an error for each constituent found in lists In_Constits, 27442 -- In_Out_Constits and Out_Constits. 27443 27444 procedure Report_Missing_Items; 27445 -- Emit an error for each global item not repeated found in list 27446 -- Repeat_Items. 27447 27448 ------------------------- 27449 -- Check_In_Out_States -- 27450 ------------------------- 27451 27452 procedure Check_In_Out_States is 27453 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27454 -- Determine whether one of the following coverage scenarios is in 27455 -- effect: 27456 -- 1) there is at least one constituent of mode In_Out or Output 27457 -- 2) there is at least one pair of constituents with modes Input 27458 -- and Output, or Proof_In and Output. 27459 -- 3) there is at least one constituent of mode Output and not all 27460 -- constituents are present. 27461 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)). 27462 27463 ----------------------------- 27464 -- Check_Constituent_Usage -- 27465 ----------------------------- 27466 27467 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27468 Constits : constant Elist_Id := 27469 Partial_Refinement_Constituents (State_Id); 27470 Constit_Elmt : Elmt_Id; 27471 Constit_Id : Entity_Id; 27472 Has_Missing : Boolean := False; 27473 In_Out_Seen : Boolean := False; 27474 Input_Seen : Boolean := False; 27475 Output_Seen : Boolean := False; 27476 Proof_In_Seen : Boolean := False; 27477 27478 begin 27479 -- Process all the constituents of the state and note their modes 27480 -- within the global refinement. 27481 27482 if Present (Constits) then 27483 Constit_Elmt := First_Elmt (Constits); 27484 while Present (Constit_Elmt) loop 27485 Constit_Id := Node (Constit_Elmt); 27486 27487 if Present_Then_Remove (In_Constits, Constit_Id) then 27488 Input_Seen := True; 27489 27490 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then 27491 In_Out_Seen := True; 27492 27493 elsif Present_Then_Remove (Out_Constits, Constit_Id) then 27494 Output_Seen := True; 27495 27496 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) 27497 then 27498 Proof_In_Seen := True; 27499 27500 else 27501 Has_Missing := True; 27502 end if; 27503 27504 Next_Elmt (Constit_Elmt); 27505 end loop; 27506 end if; 27507 27508 -- An In_Out constituent is a valid completion 27509 27510 if In_Out_Seen then 27511 null; 27512 27513 -- A pair of one Input/Proof_In and one Output constituent is a 27514 -- valid completion. 27515 27516 elsif (Input_Seen or Proof_In_Seen) and Output_Seen then 27517 null; 27518 27519 elsif Output_Seen then 27520 27521 -- A single Output constituent is a valid completion only when 27522 -- some of the other constituents are missing. 27523 27524 if Has_Missing then 27525 null; 27526 27527 -- Otherwise all constituents are of mode Output 27528 27529 else 27530 SPARK_Msg_NE 27531 ("global refinement of state & must include at least one " 27532 & "constituent of mode `In_Out`, `Input`, or `Proof_In`", 27533 N, State_Id); 27534 end if; 27535 27536 -- The state lacks a completion. When full refinement is visible, 27537 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial 27538 -- refinement is visible, emit an error if the abstract state 27539 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where 27540 -- both are utilized, Check_State_And_Constituent_Use. will issue 27541 -- the error. 27542 27543 elsif not Input_Seen 27544 and then not In_Out_Seen 27545 and then not Output_Seen 27546 and then not Proof_In_Seen 27547 then 27548 if Has_Visible_Refinement (State_Id) 27549 or else Contains (Repeat_Items, State_Id) 27550 then 27551 SPARK_Msg_NE 27552 ("missing global refinement of state &", N, State_Id); 27553 end if; 27554 27555 -- Otherwise the state has a malformed completion where at least 27556 -- one of the constituents has a different mode. 27557 27558 else 27559 SPARK_Msg_NE 27560 ("global refinement of state & redefines the mode of its " 27561 & "constituents", N, State_Id); 27562 end if; 27563 end Check_Constituent_Usage; 27564 27565 -- Local variables 27566 27567 Item_Elmt : Elmt_Id; 27568 Item_Id : Entity_Id; 27569 27570 -- Start of processing for Check_In_Out_States 27571 27572 begin 27573 -- Do not perform this check in an instance because it was already 27574 -- performed successfully in the generic template. 27575 27576 if In_Instance then 27577 null; 27578 27579 -- Inspect the In_Out items of the corresponding Global pragma 27580 -- looking for a state with a visible refinement. 27581 27582 elsif Has_In_Out_State and then Present (In_Out_Items) then 27583 Item_Elmt := First_Elmt (In_Out_Items); 27584 while Present (Item_Elmt) loop 27585 Item_Id := Node (Item_Elmt); 27586 27587 -- Ensure that one of the three coverage variants is satisfied 27588 27589 if Ekind (Item_Id) = E_Abstract_State 27590 and then Has_Non_Null_Visible_Refinement (Item_Id) 27591 then 27592 Check_Constituent_Usage (Item_Id); 27593 end if; 27594 27595 Next_Elmt (Item_Elmt); 27596 end loop; 27597 end if; 27598 end Check_In_Out_States; 27599 27600 ------------------------ 27601 -- Check_Input_States -- 27602 ------------------------ 27603 27604 procedure Check_Input_States is 27605 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27606 -- Determine whether at least one constituent of state State_Id with 27607 -- full or partial visible refinement is used and has mode Input. 27608 -- Ensure that the remaining constituents do not have In_Out or 27609 -- Output modes. Emit an error if this is not the case 27610 -- (SPARK RM 7.2.4(5)). 27611 27612 ----------------------------- 27613 -- Check_Constituent_Usage -- 27614 ----------------------------- 27615 27616 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27617 Constits : constant Elist_Id := 27618 Partial_Refinement_Constituents (State_Id); 27619 Constit_Elmt : Elmt_Id; 27620 Constit_Id : Entity_Id; 27621 In_Seen : Boolean := False; 27622 27623 begin 27624 if Present (Constits) then 27625 Constit_Elmt := First_Elmt (Constits); 27626 while Present (Constit_Elmt) loop 27627 Constit_Id := Node (Constit_Elmt); 27628 27629 -- At least one of the constituents appears as an Input 27630 27631 if Present_Then_Remove (In_Constits, Constit_Id) then 27632 In_Seen := True; 27633 27634 -- A Proof_In constituent can refine an Input state as long 27635 -- as there is at least one Input constituent present. 27636 27637 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) 27638 then 27639 null; 27640 27641 -- The constituent appears in the global refinement, but has 27642 -- mode In_Out or Output (SPARK RM 7.2.4(5)). 27643 27644 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) 27645 or else Present_Then_Remove (Out_Constits, Constit_Id) 27646 then 27647 Error_Msg_Name_1 := Chars (State_Id); 27648 SPARK_Msg_NE 27649 ("constituent & of state % must have mode `Input` in " 27650 & "global refinement", N, Constit_Id); 27651 end if; 27652 27653 Next_Elmt (Constit_Elmt); 27654 end loop; 27655 end if; 27656 27657 -- Not one of the constituents appeared as Input. Always emit an 27658 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)). 27659 -- When only partial refinement is visible, emit an error if the 27660 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In 27661 -- the case where both are utilized, an error will be issued in 27662 -- Check_State_And_Constituent_Use. 27663 27664 if not In_Seen 27665 and then (Has_Visible_Refinement (State_Id) 27666 or else Contains (Repeat_Items, State_Id)) 27667 then 27668 SPARK_Msg_NE 27669 ("global refinement of state & must include at least one " 27670 & "constituent of mode `Input`", N, State_Id); 27671 end if; 27672 end Check_Constituent_Usage; 27673 27674 -- Local variables 27675 27676 Item_Elmt : Elmt_Id; 27677 Item_Id : Entity_Id; 27678 27679 -- Start of processing for Check_Input_States 27680 27681 begin 27682 -- Do not perform this check in an instance because it was already 27683 -- performed successfully in the generic template. 27684 27685 if In_Instance then 27686 null; 27687 27688 -- Inspect the Input items of the corresponding Global pragma looking 27689 -- for a state with a visible refinement. 27690 27691 elsif Has_In_State and then Present (In_Items) then 27692 Item_Elmt := First_Elmt (In_Items); 27693 while Present (Item_Elmt) loop 27694 Item_Id := Node (Item_Elmt); 27695 27696 -- When full refinement is visible, ensure that at least one of 27697 -- the constituents is utilized and is of mode Input. When only 27698 -- partial refinement is visible, ensure that either one of 27699 -- the constituents is utilized and is of mode Input, or the 27700 -- abstract state is repeated and no constituent is utilized. 27701 27702 if Ekind (Item_Id) = E_Abstract_State 27703 and then Has_Non_Null_Visible_Refinement (Item_Id) 27704 then 27705 Check_Constituent_Usage (Item_Id); 27706 end if; 27707 27708 Next_Elmt (Item_Elmt); 27709 end loop; 27710 end if; 27711 end Check_Input_States; 27712 27713 ------------------------- 27714 -- Check_Output_States -- 27715 ------------------------- 27716 27717 procedure Check_Output_States is 27718 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27719 -- Determine whether all constituents of state State_Id with full 27720 -- visible refinement are used and have mode Output. Emit an error 27721 -- if this is not the case (SPARK RM 7.2.4(5)). 27722 27723 ----------------------------- 27724 -- Check_Constituent_Usage -- 27725 ----------------------------- 27726 27727 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27728 Constits : constant Elist_Id := 27729 Partial_Refinement_Constituents (State_Id); 27730 Only_Partial : constant Boolean := 27731 not Has_Visible_Refinement (State_Id); 27732 Constit_Elmt : Elmt_Id; 27733 Constit_Id : Entity_Id; 27734 Posted : Boolean := False; 27735 27736 begin 27737 if Present (Constits) then 27738 Constit_Elmt := First_Elmt (Constits); 27739 while Present (Constit_Elmt) loop 27740 Constit_Id := Node (Constit_Elmt); 27741 27742 -- Issue an error when a constituent of State_Id is utilized 27743 -- and State_Id has only partial visible refinement 27744 -- (SPARK RM 7.2.4(3d)). 27745 27746 if Only_Partial then 27747 if Present_Then_Remove (Out_Constits, Constit_Id) 27748 or else Present_Then_Remove (In_Constits, Constit_Id) 27749 or else 27750 Present_Then_Remove (In_Out_Constits, Constit_Id) 27751 or else 27752 Present_Then_Remove (Proof_In_Constits, Constit_Id) 27753 then 27754 Error_Msg_Name_1 := Chars (State_Id); 27755 SPARK_Msg_NE 27756 ("constituent & of state % cannot be used in global " 27757 & "refinement", N, Constit_Id); 27758 Error_Msg_Name_1 := Chars (State_Id); 27759 SPARK_Msg_N ("\use state % instead", N); 27760 end if; 27761 27762 elsif Present_Then_Remove (Out_Constits, Constit_Id) then 27763 null; 27764 27765 -- The constituent appears in the global refinement, but has 27766 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)). 27767 27768 elsif Present_Then_Remove (In_Constits, Constit_Id) 27769 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 27770 or else Present_Then_Remove (Proof_In_Constits, Constit_Id) 27771 then 27772 Error_Msg_Name_1 := Chars (State_Id); 27773 SPARK_Msg_NE 27774 ("constituent & of state % must have mode `Output` in " 27775 & "global refinement", N, Constit_Id); 27776 27777 -- The constituent is altogether missing (SPARK RM 7.2.5(3)) 27778 27779 else 27780 if not Posted then 27781 Posted := True; 27782 SPARK_Msg_NE 27783 ("`Output` state & must be replaced by all its " 27784 & "constituents in global refinement", N, State_Id); 27785 end if; 27786 27787 SPARK_Msg_NE 27788 ("\constituent & is missing in output list", 27789 N, Constit_Id); 27790 end if; 27791 27792 Next_Elmt (Constit_Elmt); 27793 end loop; 27794 end if; 27795 end Check_Constituent_Usage; 27796 27797 -- Local variables 27798 27799 Item_Elmt : Elmt_Id; 27800 Item_Id : Entity_Id; 27801 27802 -- Start of processing for Check_Output_States 27803 27804 begin 27805 -- Do not perform this check in an instance because it was already 27806 -- performed successfully in the generic template. 27807 27808 if In_Instance then 27809 null; 27810 27811 -- Inspect the Output items of the corresponding Global pragma 27812 -- looking for a state with a visible refinement. 27813 27814 elsif Has_Out_State and then Present (Out_Items) then 27815 Item_Elmt := First_Elmt (Out_Items); 27816 while Present (Item_Elmt) loop 27817 Item_Id := Node (Item_Elmt); 27818 27819 -- When full refinement is visible, ensure that all of the 27820 -- constituents are utilized and they have mode Output. When 27821 -- only partial refinement is visible, ensure that no 27822 -- constituent is utilized. 27823 27824 if Ekind (Item_Id) = E_Abstract_State 27825 and then Has_Non_Null_Visible_Refinement (Item_Id) 27826 then 27827 Check_Constituent_Usage (Item_Id); 27828 end if; 27829 27830 Next_Elmt (Item_Elmt); 27831 end loop; 27832 end if; 27833 end Check_Output_States; 27834 27835 --------------------------- 27836 -- Check_Proof_In_States -- 27837 --------------------------- 27838 27839 procedure Check_Proof_In_States is 27840 procedure Check_Constituent_Usage (State_Id : Entity_Id); 27841 -- Determine whether at least one constituent of state State_Id with 27842 -- full or partial visible refinement is used and has mode Proof_In. 27843 -- Ensure that the remaining constituents do not have Input, In_Out, 27844 -- or Output modes. Emit an error if this is not the case 27845 -- (SPARK RM 7.2.4(5)). 27846 27847 ----------------------------- 27848 -- Check_Constituent_Usage -- 27849 ----------------------------- 27850 27851 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 27852 Constits : constant Elist_Id := 27853 Partial_Refinement_Constituents (State_Id); 27854 Constit_Elmt : Elmt_Id; 27855 Constit_Id : Entity_Id; 27856 Proof_In_Seen : Boolean := False; 27857 27858 begin 27859 if Present (Constits) then 27860 Constit_Elmt := First_Elmt (Constits); 27861 while Present (Constit_Elmt) loop 27862 Constit_Id := Node (Constit_Elmt); 27863 27864 -- At least one of the constituents appears as Proof_In 27865 27866 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then 27867 Proof_In_Seen := True; 27868 27869 -- The constituent appears in the global refinement, but has 27870 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)). 27871 27872 elsif Present_Then_Remove (In_Constits, Constit_Id) 27873 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 27874 or else Present_Then_Remove (Out_Constits, Constit_Id) 27875 then 27876 Error_Msg_Name_1 := Chars (State_Id); 27877 SPARK_Msg_NE 27878 ("constituent & of state % must have mode `Proof_In` " 27879 & "in global refinement", N, Constit_Id); 27880 end if; 27881 27882 Next_Elmt (Constit_Elmt); 27883 end loop; 27884 end if; 27885 27886 -- Not one of the constituents appeared as Proof_In. Always emit 27887 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)). 27888 -- When only partial refinement is visible, emit an error if the 27889 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In 27890 -- the case where both are utilized, an error will be issued by 27891 -- Check_State_And_Constituent_Use. 27892 27893 if not Proof_In_Seen 27894 and then (Has_Visible_Refinement (State_Id) 27895 or else Contains (Repeat_Items, State_Id)) 27896 then 27897 SPARK_Msg_NE 27898 ("global refinement of state & must include at least one " 27899 & "constituent of mode `Proof_In`", N, State_Id); 27900 end if; 27901 end Check_Constituent_Usage; 27902 27903 -- Local variables 27904 27905 Item_Elmt : Elmt_Id; 27906 Item_Id : Entity_Id; 27907 27908 -- Start of processing for Check_Proof_In_States 27909 27910 begin 27911 -- Do not perform this check in an instance because it was already 27912 -- performed successfully in the generic template. 27913 27914 if In_Instance then 27915 null; 27916 27917 -- Inspect the Proof_In items of the corresponding Global pragma 27918 -- looking for a state with a visible refinement. 27919 27920 elsif Has_Proof_In_State and then Present (Proof_In_Items) then 27921 Item_Elmt := First_Elmt (Proof_In_Items); 27922 while Present (Item_Elmt) loop 27923 Item_Id := Node (Item_Elmt); 27924 27925 -- Ensure that at least one of the constituents is utilized 27926 -- and is of mode Proof_In. When only partial refinement is 27927 -- visible, ensure that either one of the constituents is 27928 -- utilized and is of mode Proof_In, or the abstract state 27929 -- is repeated and no constituent is utilized. 27930 27931 if Ekind (Item_Id) = E_Abstract_State 27932 and then Has_Non_Null_Visible_Refinement (Item_Id) 27933 then 27934 Check_Constituent_Usage (Item_Id); 27935 end if; 27936 27937 Next_Elmt (Item_Elmt); 27938 end loop; 27939 end if; 27940 end Check_Proof_In_States; 27941 27942 ------------------------------- 27943 -- Check_Refined_Global_List -- 27944 ------------------------------- 27945 27946 procedure Check_Refined_Global_List 27947 (List : Node_Id; 27948 Global_Mode : Name_Id := Name_Input) 27949 is 27950 procedure Check_Refined_Global_Item 27951 (Item : Node_Id; 27952 Global_Mode : Name_Id); 27953 -- Verify the legality of a single global item declaration. Parameter 27954 -- Global_Mode denotes the current mode in effect. 27955 27956 ------------------------------- 27957 -- Check_Refined_Global_Item -- 27958 ------------------------------- 27959 27960 procedure Check_Refined_Global_Item 27961 (Item : Node_Id; 27962 Global_Mode : Name_Id) 27963 is 27964 Item_Id : constant Entity_Id := Entity_Of (Item); 27965 27966 procedure Inconsistent_Mode_Error (Expect : Name_Id); 27967 -- Issue a common error message for all mode mismatches. Expect 27968 -- denotes the expected mode. 27969 27970 ----------------------------- 27971 -- Inconsistent_Mode_Error -- 27972 ----------------------------- 27973 27974 procedure Inconsistent_Mode_Error (Expect : Name_Id) is 27975 begin 27976 SPARK_Msg_NE 27977 ("global item & has inconsistent modes", Item, Item_Id); 27978 27979 Error_Msg_Name_1 := Global_Mode; 27980 Error_Msg_Name_2 := Expect; 27981 SPARK_Msg_N ("\expected mode %, found mode %", Item); 27982 end Inconsistent_Mode_Error; 27983 27984 -- Local variables 27985 27986 Enc_State : Entity_Id := Empty; 27987 -- Encapsulating state for constituent, Empty otherwise 27988 27989 -- Start of processing for Check_Refined_Global_Item 27990 27991 begin 27992 if Ekind_In (Item_Id, E_Abstract_State, 27993 E_Constant, 27994 E_Variable) 27995 then 27996 Enc_State := Find_Encapsulating_State (States, Item_Id); 27997 end if; 27998 27999 -- When the state or object acts as a constituent of another 28000 -- state with a visible refinement, collect it for the state 28001 -- completeness checks performed later on. Note that the item 28002 -- acts as a constituent only when the encapsulating state is 28003 -- present in pragma Global. 28004 28005 if Present (Enc_State) 28006 and then (Has_Visible_Refinement (Enc_State) 28007 or else Has_Partial_Visible_Refinement (Enc_State)) 28008 and then Contains (States, Enc_State) 28009 then 28010 -- If the state has only partial visible refinement, remove it 28011 -- from the list of items that should be repeated from pragma 28012 -- Global. 28013 28014 if not Has_Visible_Refinement (Enc_State) then 28015 Present_Then_Remove (Repeat_Items, Enc_State); 28016 end if; 28017 28018 if Global_Mode = Name_Input then 28019 Append_New_Elmt (Item_Id, In_Constits); 28020 28021 elsif Global_Mode = Name_In_Out then 28022 Append_New_Elmt (Item_Id, In_Out_Constits); 28023 28024 elsif Global_Mode = Name_Output then 28025 Append_New_Elmt (Item_Id, Out_Constits); 28026 28027 elsif Global_Mode = Name_Proof_In then 28028 Append_New_Elmt (Item_Id, Proof_In_Constits); 28029 end if; 28030 28031 -- When not a constituent, ensure that both occurrences of the 28032 -- item in pragmas Global and Refined_Global match. Also remove 28033 -- it when present from the list of items that should be repeated 28034 -- from pragma Global. 28035 28036 else 28037 Present_Then_Remove (Repeat_Items, Item_Id); 28038 28039 if Contains (In_Items, Item_Id) then 28040 if Global_Mode /= Name_Input then 28041 Inconsistent_Mode_Error (Name_Input); 28042 end if; 28043 28044 elsif Contains (In_Out_Items, Item_Id) then 28045 if Global_Mode /= Name_In_Out then 28046 Inconsistent_Mode_Error (Name_In_Out); 28047 end if; 28048 28049 elsif Contains (Out_Items, Item_Id) then 28050 if Global_Mode /= Name_Output then 28051 Inconsistent_Mode_Error (Name_Output); 28052 end if; 28053 28054 elsif Contains (Proof_In_Items, Item_Id) then 28055 null; 28056 28057 -- The item does not appear in the corresponding Global pragma, 28058 -- it must be an extra (SPARK RM 7.2.4(3)). 28059 28060 else 28061 pragma Assert (Present (Global)); 28062 Error_Msg_Sloc := Sloc (Global); 28063 SPARK_Msg_NE 28064 ("extra global item & does not refine or repeat any " 28065 & "global item #", Item, Item_Id); 28066 end if; 28067 end if; 28068 end Check_Refined_Global_Item; 28069 28070 -- Local variables 28071 28072 Item : Node_Id; 28073 28074 -- Start of processing for Check_Refined_Global_List 28075 28076 begin 28077 -- Do not perform this check in an instance because it was already 28078 -- performed successfully in the generic template. 28079 28080 if In_Instance then 28081 null; 28082 28083 elsif Nkind (List) = N_Null then 28084 null; 28085 28086 -- Single global item declaration 28087 28088 elsif Nkind_In (List, N_Expanded_Name, 28089 N_Identifier, 28090 N_Selected_Component) 28091 then 28092 Check_Refined_Global_Item (List, Global_Mode); 28093 28094 -- Simple global list or moded global list declaration 28095 28096 elsif Nkind (List) = N_Aggregate then 28097 28098 -- The declaration of a simple global list appear as a collection 28099 -- of expressions. 28100 28101 if Present (Expressions (List)) then 28102 Item := First (Expressions (List)); 28103 while Present (Item) loop 28104 Check_Refined_Global_Item (Item, Global_Mode); 28105 Next (Item); 28106 end loop; 28107 28108 -- The declaration of a moded global list appears as a collection 28109 -- of component associations where individual choices denote 28110 -- modes. 28111 28112 elsif Present (Component_Associations (List)) then 28113 Item := First (Component_Associations (List)); 28114 while Present (Item) loop 28115 Check_Refined_Global_List 28116 (List => Expression (Item), 28117 Global_Mode => Chars (First (Choices (Item)))); 28118 28119 Next (Item); 28120 end loop; 28121 28122 -- Invalid tree 28123 28124 else 28125 raise Program_Error; 28126 end if; 28127 28128 -- Invalid list 28129 28130 else 28131 raise Program_Error; 28132 end if; 28133 end Check_Refined_Global_List; 28134 28135 -------------------------- 28136 -- Collect_Global_Items -- 28137 -------------------------- 28138 28139 procedure Collect_Global_Items 28140 (List : Node_Id; 28141 Mode : Name_Id := Name_Input) 28142 is 28143 procedure Collect_Global_Item 28144 (Item : Node_Id; 28145 Item_Mode : Name_Id); 28146 -- Add a single item to the appropriate list. Item_Mode denotes the 28147 -- current mode in effect. 28148 28149 ------------------------- 28150 -- Collect_Global_Item -- 28151 ------------------------- 28152 28153 procedure Collect_Global_Item 28154 (Item : Node_Id; 28155 Item_Mode : Name_Id) 28156 is 28157 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item)); 28158 -- The above handles abstract views of variables and states built 28159 -- for limited with clauses. 28160 28161 begin 28162 -- Signal that the global list contains at least one abstract 28163 -- state with a visible refinement. Note that the refinement may 28164 -- be null in which case there are no constituents. 28165 28166 if Ekind (Item_Id) = E_Abstract_State then 28167 if Has_Null_Visible_Refinement (Item_Id) then 28168 Has_Null_State := True; 28169 28170 elsif Has_Non_Null_Visible_Refinement (Item_Id) then 28171 Append_New_Elmt (Item_Id, States); 28172 28173 if Item_Mode = Name_Input then 28174 Has_In_State := True; 28175 elsif Item_Mode = Name_In_Out then 28176 Has_In_Out_State := True; 28177 elsif Item_Mode = Name_Output then 28178 Has_Out_State := True; 28179 elsif Item_Mode = Name_Proof_In then 28180 Has_Proof_In_State := True; 28181 end if; 28182 end if; 28183 end if; 28184 28185 -- Record global items without full visible refinement found in 28186 -- pragma Global which should be repeated in the global refinement 28187 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)). 28188 28189 if Ekind (Item_Id) /= E_Abstract_State 28190 or else not Has_Visible_Refinement (Item_Id) 28191 then 28192 Append_New_Elmt (Item_Id, Repeat_Items); 28193 end if; 28194 28195 -- Add the item to the proper list 28196 28197 if Item_Mode = Name_Input then 28198 Append_New_Elmt (Item_Id, In_Items); 28199 elsif Item_Mode = Name_In_Out then 28200 Append_New_Elmt (Item_Id, In_Out_Items); 28201 elsif Item_Mode = Name_Output then 28202 Append_New_Elmt (Item_Id, Out_Items); 28203 elsif Item_Mode = Name_Proof_In then 28204 Append_New_Elmt (Item_Id, Proof_In_Items); 28205 end if; 28206 end Collect_Global_Item; 28207 28208 -- Local variables 28209 28210 Item : Node_Id; 28211 28212 -- Start of processing for Collect_Global_Items 28213 28214 begin 28215 if Nkind (List) = N_Null then 28216 null; 28217 28218 -- Single global item declaration 28219 28220 elsif Nkind_In (List, N_Expanded_Name, 28221 N_Identifier, 28222 N_Selected_Component) 28223 then 28224 Collect_Global_Item (List, Mode); 28225 28226 -- Single global list or moded global list declaration 28227 28228 elsif Nkind (List) = N_Aggregate then 28229 28230 -- The declaration of a simple global list appear as a collection 28231 -- of expressions. 28232 28233 if Present (Expressions (List)) then 28234 Item := First (Expressions (List)); 28235 while Present (Item) loop 28236 Collect_Global_Item (Item, Mode); 28237 Next (Item); 28238 end loop; 28239 28240 -- The declaration of a moded global list appears as a collection 28241 -- of component associations where individual choices denote mode. 28242 28243 elsif Present (Component_Associations (List)) then 28244 Item := First (Component_Associations (List)); 28245 while Present (Item) loop 28246 Collect_Global_Items 28247 (List => Expression (Item), 28248 Mode => Chars (First (Choices (Item)))); 28249 28250 Next (Item); 28251 end loop; 28252 28253 -- Invalid tree 28254 28255 else 28256 raise Program_Error; 28257 end if; 28258 28259 -- To accommodate partial decoration of disabled SPARK features, this 28260 -- routine may be called with illegal input. If this is the case, do 28261 -- not raise Program_Error. 28262 28263 else 28264 null; 28265 end if; 28266 end Collect_Global_Items; 28267 28268 ------------------------- 28269 -- Present_Then_Remove -- 28270 ------------------------- 28271 28272 function Present_Then_Remove 28273 (List : Elist_Id; 28274 Item : Entity_Id) return Boolean 28275 is 28276 Elmt : Elmt_Id; 28277 28278 begin 28279 if Present (List) then 28280 Elmt := First_Elmt (List); 28281 while Present (Elmt) loop 28282 if Node (Elmt) = Item then 28283 Remove_Elmt (List, Elmt); 28284 return True; 28285 end if; 28286 28287 Next_Elmt (Elmt); 28288 end loop; 28289 end if; 28290 28291 return False; 28292 end Present_Then_Remove; 28293 28294 procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is 28295 Ignore : Boolean; 28296 begin 28297 Ignore := Present_Then_Remove (List, Item); 28298 end Present_Then_Remove; 28299 28300 ------------------------------- 28301 -- Report_Extra_Constituents -- 28302 ------------------------------- 28303 28304 procedure Report_Extra_Constituents is 28305 procedure Report_Extra_Constituents_In_List (List : Elist_Id); 28306 -- Emit an error for every element of List 28307 28308 --------------------------------------- 28309 -- Report_Extra_Constituents_In_List -- 28310 --------------------------------------- 28311 28312 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is 28313 Constit_Elmt : Elmt_Id; 28314 28315 begin 28316 if Present (List) then 28317 Constit_Elmt := First_Elmt (List); 28318 while Present (Constit_Elmt) loop 28319 SPARK_Msg_NE ("extra constituent &", N, Node (Constit_Elmt)); 28320 Next_Elmt (Constit_Elmt); 28321 end loop; 28322 end if; 28323 end Report_Extra_Constituents_In_List; 28324 28325 -- Start of processing for Report_Extra_Constituents 28326 28327 begin 28328 -- Do not perform this check in an instance because it was already 28329 -- performed successfully in the generic template. 28330 28331 if In_Instance then 28332 null; 28333 28334 else 28335 Report_Extra_Constituents_In_List (In_Constits); 28336 Report_Extra_Constituents_In_List (In_Out_Constits); 28337 Report_Extra_Constituents_In_List (Out_Constits); 28338 Report_Extra_Constituents_In_List (Proof_In_Constits); 28339 end if; 28340 end Report_Extra_Constituents; 28341 28342 -------------------------- 28343 -- Report_Missing_Items -- 28344 -------------------------- 28345 28346 procedure Report_Missing_Items is 28347 Item_Elmt : Elmt_Id; 28348 Item_Id : Entity_Id; 28349 28350 begin 28351 -- Do not perform this check in an instance because it was already 28352 -- performed successfully in the generic template. 28353 28354 if In_Instance then 28355 null; 28356 28357 else 28358 if Present (Repeat_Items) then 28359 Item_Elmt := First_Elmt (Repeat_Items); 28360 while Present (Item_Elmt) loop 28361 Item_Id := Node (Item_Elmt); 28362 SPARK_Msg_NE ("missing global item &", N, Item_Id); 28363 Next_Elmt (Item_Elmt); 28364 end loop; 28365 end if; 28366 end if; 28367 end Report_Missing_Items; 28368 28369 -- Local variables 28370 28371 Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 28372 Errors : constant Nat := Serious_Errors_Detected; 28373 Items : Node_Id; 28374 No_Constit : Boolean; 28375 28376 -- Start of processing for Analyze_Refined_Global_In_Decl_Part 28377 28378 begin 28379 -- Do not analyze the pragma multiple times 28380 28381 if Is_Analyzed_Pragma (N) then 28382 return; 28383 end if; 28384 28385 Spec_Id := Unique_Defining_Entity (Body_Decl); 28386 28387 -- Use the anonymous object as the proper spec when Refined_Global 28388 -- applies to the body of a single task type. The object carries the 28389 -- proper Chars as well as all non-refined versions of pragmas. 28390 28391 if Is_Single_Concurrent_Type (Spec_Id) then 28392 Spec_Id := Anonymous_Object (Spec_Id); 28393 end if; 28394 28395 Global := Get_Pragma (Spec_Id, Pragma_Global); 28396 Items := Expression (Get_Argument (N, Spec_Id)); 28397 28398 -- The subprogram declaration lacks pragma Global. This renders 28399 -- Refined_Global useless as there is nothing to refine. 28400 28401 if No (Global) then 28402 SPARK_Msg_NE 28403 (Fix_Msg (Spec_Id, "useless refinement, declaration of subprogram " 28404 & "& lacks aspect or pragma Global"), N, Spec_Id); 28405 goto Leave; 28406 end if; 28407 28408 -- Extract all relevant items from the corresponding Global pragma 28409 28410 Collect_Global_Items (Expression (Get_Argument (Global, Spec_Id))); 28411 28412 -- Package and subprogram bodies are instantiated individually in 28413 -- a separate compiler pass. Due to this mode of instantiation, the 28414 -- refinement of a state may no longer be visible when a subprogram 28415 -- body contract is instantiated. Since the generic template is legal, 28416 -- do not perform this check in the instance to circumvent this oddity. 28417 28418 if In_Instance then 28419 null; 28420 28421 -- Non-instance case 28422 28423 else 28424 -- The corresponding Global pragma must mention at least one 28425 -- state with a visible refinement at the point Refined_Global 28426 -- is processed. States with null refinements need Refined_Global 28427 -- pragma (SPARK RM 7.2.4(2)). 28428 28429 if not Has_In_State 28430 and then not Has_In_Out_State 28431 and then not Has_Out_State 28432 and then not Has_Proof_In_State 28433 and then not Has_Null_State 28434 then 28435 SPARK_Msg_NE 28436 (Fix_Msg (Spec_Id, "useless refinement, subprogram & does not " 28437 & "depend on abstract state with visible refinement"), 28438 N, Spec_Id); 28439 goto Leave; 28440 28441 -- The global refinement of inputs and outputs cannot be null when 28442 -- the corresponding Global pragma contains at least one item except 28443 -- in the case where we have states with null refinements. 28444 28445 elsif Nkind (Items) = N_Null 28446 and then 28447 (Present (In_Items) 28448 or else Present (In_Out_Items) 28449 or else Present (Out_Items) 28450 or else Present (Proof_In_Items)) 28451 and then not Has_Null_State 28452 then 28453 SPARK_Msg_NE 28454 (Fix_Msg (Spec_Id, "refinement cannot be null, subprogram & has " 28455 & "global items"), N, Spec_Id); 28456 goto Leave; 28457 end if; 28458 end if; 28459 28460 -- Analyze Refined_Global as if it behaved as a regular pragma Global. 28461 -- This ensures that the categorization of all refined global items is 28462 -- consistent with their role. 28463 28464 Analyze_Global_In_Decl_Part (N); 28465 28466 -- Perform all refinement checks with respect to completeness and mode 28467 -- matching. 28468 28469 if Serious_Errors_Detected = Errors then 28470 Check_Refined_Global_List (Items); 28471 end if; 28472 28473 -- Store the information that no constituent is used in the global 28474 -- refinement, prior to calling checking procedures which remove items 28475 -- from the list of constituents. 28476 28477 No_Constit := 28478 No (In_Constits) 28479 and then No (In_Out_Constits) 28480 and then No (Out_Constits) 28481 and then No (Proof_In_Constits); 28482 28483 -- For Input states with visible refinement, at least one constituent 28484 -- must be used as an Input in the global refinement. 28485 28486 if Serious_Errors_Detected = Errors then 28487 Check_Input_States; 28488 end if; 28489 28490 -- Verify all possible completion variants for In_Out states with 28491 -- visible refinement. 28492 28493 if Serious_Errors_Detected = Errors then 28494 Check_In_Out_States; 28495 end if; 28496 28497 -- For Output states with visible refinement, all constituents must be 28498 -- used as Outputs in the global refinement. 28499 28500 if Serious_Errors_Detected = Errors then 28501 Check_Output_States; 28502 end if; 28503 28504 -- For Proof_In states with visible refinement, at least one constituent 28505 -- must be used as Proof_In in the global refinement. 28506 28507 if Serious_Errors_Detected = Errors then 28508 Check_Proof_In_States; 28509 end if; 28510 28511 -- Emit errors for all constituents that belong to other states with 28512 -- visible refinement that do not appear in Global. 28513 28514 if Serious_Errors_Detected = Errors then 28515 Report_Extra_Constituents; 28516 end if; 28517 28518 -- Emit errors for all items in Global that are not repeated in the 28519 -- global refinement and for which there is no full visible refinement 28520 -- and, in the case of states with partial visible refinement, no 28521 -- constituent is mentioned in the global refinement. 28522 28523 if Serious_Errors_Detected = Errors then 28524 Report_Missing_Items; 28525 end if; 28526 28527 -- Emit an error if no constituent is used in the global refinement 28528 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise 28529 -- one may be issued by the checking procedures. Do not perform this 28530 -- check in an instance because it was already performed successfully 28531 -- in the generic template. 28532 28533 if Serious_Errors_Detected = Errors 28534 and then not In_Instance 28535 and then not Has_Null_State 28536 and then No_Constit 28537 then 28538 SPARK_Msg_N ("missing refinement", N); 28539 end if; 28540 28541 <<Leave>> 28542 Set_Is_Analyzed_Pragma (N); 28543 end Analyze_Refined_Global_In_Decl_Part; 28544 28545 ---------------------------------------- 28546 -- Analyze_Refined_State_In_Decl_Part -- 28547 ---------------------------------------- 28548 28549 procedure Analyze_Refined_State_In_Decl_Part 28550 (N : Node_Id; 28551 Freeze_Id : Entity_Id := Empty) 28552 is 28553 Body_Decl : constant Node_Id := Find_Related_Package_Or_Body (N); 28554 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl); 28555 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); 28556 28557 Available_States : Elist_Id := No_Elist; 28558 -- A list of all abstract states defined in the package declaration that 28559 -- are available for refinement. The list is used to report unrefined 28560 -- states. 28561 28562 Body_States : Elist_Id := No_Elist; 28563 -- A list of all hidden states that appear in the body of the related 28564 -- package. The list is used to report unused hidden states. 28565 28566 Constituents_Seen : Elist_Id := No_Elist; 28567 -- A list that contains all constituents processed so far. The list is 28568 -- used to detect multiple uses of the same constituent. 28569 28570 Freeze_Posted : Boolean := False; 28571 -- A flag that controls the output of a freezing-related error (see use 28572 -- below). 28573 28574 Refined_States_Seen : Elist_Id := No_Elist; 28575 -- A list that contains all refined states processed so far. The list is 28576 -- used to detect duplicate refinements. 28577 28578 procedure Analyze_Refinement_Clause (Clause : Node_Id); 28579 -- Perform full analysis of a single refinement clause 28580 28581 procedure Report_Unrefined_States (States : Elist_Id); 28582 -- Emit errors for all unrefined abstract states found in list States 28583 28584 ------------------------------- 28585 -- Analyze_Refinement_Clause -- 28586 ------------------------------- 28587 28588 procedure Analyze_Refinement_Clause (Clause : Node_Id) is 28589 AR_Constit : Entity_Id := Empty; 28590 AW_Constit : Entity_Id := Empty; 28591 ER_Constit : Entity_Id := Empty; 28592 EW_Constit : Entity_Id := Empty; 28593 -- The entities of external constituents that contain one of the 28594 -- following enabled properties: Async_Readers, Async_Writers, 28595 -- Effective_Reads and Effective_Writes. 28596 28597 External_Constit_Seen : Boolean := False; 28598 -- Flag used to mark when at least one external constituent is part 28599 -- of the state refinement. 28600 28601 Non_Null_Seen : Boolean := False; 28602 Null_Seen : Boolean := False; 28603 -- Flags used to detect multiple uses of null in a single clause or a 28604 -- mixture of null and non-null constituents. 28605 28606 Part_Of_Constits : Elist_Id := No_Elist; 28607 -- A list of all candidate constituents subject to indicator Part_Of 28608 -- where the encapsulating state is the current state. 28609 28610 State : Node_Id; 28611 State_Id : Entity_Id; 28612 -- The current state being refined 28613 28614 procedure Analyze_Constituent (Constit : Node_Id); 28615 -- Perform full analysis of a single constituent 28616 28617 procedure Check_External_Property 28618 (Prop_Nam : Name_Id; 28619 Enabled : Boolean; 28620 Constit : Entity_Id); 28621 -- Determine whether a property denoted by name Prop_Nam is present 28622 -- in the refined state. Emit an error if this is not the case. Flag 28623 -- Enabled should be set when the property applies to the refined 28624 -- state. Constit denotes the constituent (if any) which introduces 28625 -- the property in the refinement. 28626 28627 procedure Match_State; 28628 -- Determine whether the state being refined appears in list 28629 -- Available_States. Emit an error when attempting to re-refine the 28630 -- state or when the state is not defined in the package declaration, 28631 -- otherwise remove the state from Available_States. 28632 28633 procedure Report_Unused_Constituents (Constits : Elist_Id); 28634 -- Emit errors for all unused Part_Of constituents in list Constits 28635 28636 ------------------------- 28637 -- Analyze_Constituent -- 28638 ------------------------- 28639 28640 procedure Analyze_Constituent (Constit : Node_Id) is 28641 procedure Match_Constituent (Constit_Id : Entity_Id); 28642 -- Determine whether constituent Constit denoted by its entity 28643 -- Constit_Id appears in Body_States. Emit an error when the 28644 -- constituent is not a valid hidden state of the related package 28645 -- or when it is used more than once. Otherwise remove the 28646 -- constituent from Body_States. 28647 28648 ----------------------- 28649 -- Match_Constituent -- 28650 ----------------------- 28651 28652 procedure Match_Constituent (Constit_Id : Entity_Id) is 28653 procedure Collect_Constituent; 28654 -- Verify the legality of constituent Constit_Id and add it to 28655 -- the refinements of State_Id. 28656 28657 ------------------------- 28658 -- Collect_Constituent -- 28659 ------------------------- 28660 28661 procedure Collect_Constituent is 28662 Constits : Elist_Id; 28663 28664 begin 28665 -- The Ghost policy in effect at the point of abstract state 28666 -- declaration and constituent must match (SPARK RM 6.9(15)) 28667 28668 Check_Ghost_Refinement 28669 (State, State_Id, Constit, Constit_Id); 28670 28671 -- A synchronized state must be refined by a synchronized 28672 -- object or another synchronized state (SPARK RM 9.6). 28673 28674 if Is_Synchronized_State (State_Id) 28675 and then not Is_Synchronized_Object (Constit_Id) 28676 and then not Is_Synchronized_State (Constit_Id) 28677 then 28678 SPARK_Msg_NE 28679 ("constituent of synchronized state & must be " 28680 & "synchronized", Constit, State_Id); 28681 end if; 28682 28683 -- Add the constituent to the list of processed items to aid 28684 -- with the detection of duplicates. 28685 28686 Append_New_Elmt (Constit_Id, Constituents_Seen); 28687 28688 -- Collect the constituent in the list of refinement items 28689 -- and establish a relation between the refined state and 28690 -- the item. 28691 28692 Constits := Refinement_Constituents (State_Id); 28693 28694 if No (Constits) then 28695 Constits := New_Elmt_List; 28696 Set_Refinement_Constituents (State_Id, Constits); 28697 end if; 28698 28699 Append_Elmt (Constit_Id, Constits); 28700 Set_Encapsulating_State (Constit_Id, State_Id); 28701 28702 -- The state has at least one legal constituent, mark the 28703 -- start of the refinement region. The region ends when the 28704 -- body declarations end (see routine Analyze_Declarations). 28705 28706 Set_Has_Visible_Refinement (State_Id); 28707 28708 -- When the constituent is external, save its relevant 28709 -- property for further checks. 28710 28711 if Async_Readers_Enabled (Constit_Id) then 28712 AR_Constit := Constit_Id; 28713 External_Constit_Seen := True; 28714 end if; 28715 28716 if Async_Writers_Enabled (Constit_Id) then 28717 AW_Constit := Constit_Id; 28718 External_Constit_Seen := True; 28719 end if; 28720 28721 if Effective_Reads_Enabled (Constit_Id) then 28722 ER_Constit := Constit_Id; 28723 External_Constit_Seen := True; 28724 end if; 28725 28726 if Effective_Writes_Enabled (Constit_Id) then 28727 EW_Constit := Constit_Id; 28728 External_Constit_Seen := True; 28729 end if; 28730 end Collect_Constituent; 28731 28732 -- Local variables 28733 28734 State_Elmt : Elmt_Id; 28735 28736 -- Start of processing for Match_Constituent 28737 28738 begin 28739 -- Detect a duplicate use of a constituent 28740 28741 if Contains (Constituents_Seen, Constit_Id) then 28742 SPARK_Msg_NE 28743 ("duplicate use of constituent &", Constit, Constit_Id); 28744 return; 28745 end if; 28746 28747 -- The constituent is subject to a Part_Of indicator 28748 28749 if Present (Encapsulating_State (Constit_Id)) then 28750 if Encapsulating_State (Constit_Id) = State_Id then 28751 Remove (Part_Of_Constits, Constit_Id); 28752 Collect_Constituent; 28753 28754 -- The constituent is part of another state and is used 28755 -- incorrectly in the refinement of the current state. 28756 28757 else 28758 Error_Msg_Name_1 := Chars (State_Id); 28759 SPARK_Msg_NE 28760 ("& cannot act as constituent of state %", 28761 Constit, Constit_Id); 28762 SPARK_Msg_NE 28763 ("\Part_Of indicator specifies encapsulator &", 28764 Constit, Encapsulating_State (Constit_Id)); 28765 end if; 28766 28767 -- The only other source of legal constituents is the body 28768 -- state space of the related package. 28769 28770 else 28771 if Present (Body_States) then 28772 State_Elmt := First_Elmt (Body_States); 28773 while Present (State_Elmt) loop 28774 28775 -- Consume a valid constituent to signal that it has 28776 -- been encountered. 28777 28778 if Node (State_Elmt) = Constit_Id then 28779 Remove_Elmt (Body_States, State_Elmt); 28780 Collect_Constituent; 28781 return; 28782 end if; 28783 28784 Next_Elmt (State_Elmt); 28785 end loop; 28786 end if; 28787 28788 -- At this point it is known that the constituent is not 28789 -- part of the package hidden state and cannot be used in 28790 -- a refinement (SPARK RM 7.2.2(9)). 28791 28792 Error_Msg_Name_1 := Chars (Spec_Id); 28793 SPARK_Msg_NE 28794 ("cannot use & in refinement, constituent is not a hidden " 28795 & "state of package %", Constit, Constit_Id); 28796 end if; 28797 end Match_Constituent; 28798 28799 -- Local variables 28800 28801 Constit_Id : Entity_Id; 28802 Constits : Elist_Id; 28803 28804 -- Start of processing for Analyze_Constituent 28805 28806 begin 28807 -- Detect multiple uses of null in a single refinement clause or a 28808 -- mixture of null and non-null constituents. 28809 28810 if Nkind (Constit) = N_Null then 28811 if Null_Seen then 28812 SPARK_Msg_N 28813 ("multiple null constituents not allowed", Constit); 28814 28815 elsif Non_Null_Seen then 28816 SPARK_Msg_N 28817 ("cannot mix null and non-null constituents", Constit); 28818 28819 else 28820 Null_Seen := True; 28821 28822 -- Collect the constituent in the list of refinement items 28823 28824 Constits := Refinement_Constituents (State_Id); 28825 28826 if No (Constits) then 28827 Constits := New_Elmt_List; 28828 Set_Refinement_Constituents (State_Id, Constits); 28829 end if; 28830 28831 Append_Elmt (Constit, Constits); 28832 28833 -- The state has at least one legal constituent, mark the 28834 -- start of the refinement region. The region ends when the 28835 -- body declarations end (see Analyze_Declarations). 28836 28837 Set_Has_Visible_Refinement (State_Id); 28838 end if; 28839 28840 -- Non-null constituents 28841 28842 else 28843 Non_Null_Seen := True; 28844 28845 if Null_Seen then 28846 SPARK_Msg_N 28847 ("cannot mix null and non-null constituents", Constit); 28848 end if; 28849 28850 Analyze (Constit); 28851 Resolve_State (Constit); 28852 28853 -- Ensure that the constituent denotes a valid state or a 28854 -- whole object (SPARK RM 7.2.2(5)). 28855 28856 if Is_Entity_Name (Constit) then 28857 Constit_Id := Entity_Of (Constit); 28858 28859 -- When a constituent is declared after a subprogram body 28860 -- that caused freezing of the related contract where 28861 -- pragma Refined_State resides, the constituent appears 28862 -- undefined and carries Any_Id as its entity. 28863 28864 -- package body Pack 28865 -- with Refined_State => (State => Constit) 28866 -- is 28867 -- procedure Proc 28868 -- with Refined_Global => (Input => Constit) 28869 -- is 28870 -- ... 28871 -- end Proc; 28872 28873 -- Constit : ...; 28874 -- end Pack; 28875 28876 if Constit_Id = Any_Id then 28877 SPARK_Msg_NE ("& is undefined", Constit, Constit_Id); 28878 28879 -- Emit a specialized info message when the contract of 28880 -- the related package body was "frozen" by another body. 28881 -- Note that it is not possible to precisely identify why 28882 -- the constituent is undefined because it is not visible 28883 -- when pragma Refined_State is analyzed. This message is 28884 -- a reasonable approximation. 28885 28886 if Present (Freeze_Id) and then not Freeze_Posted then 28887 Freeze_Posted := True; 28888 28889 Error_Msg_Name_1 := Chars (Body_Id); 28890 Error_Msg_Sloc := Sloc (Freeze_Id); 28891 SPARK_Msg_NE 28892 ("body & declared # freezes the contract of %", 28893 N, Freeze_Id); 28894 SPARK_Msg_N 28895 ("\all constituents must be declared before body #", 28896 N); 28897 28898 -- A misplaced constituent is a critical error because 28899 -- pragma Refined_Depends or Refined_Global depends on 28900 -- the proper link between a state and a constituent. 28901 -- Stop the compilation, as this leads to a multitude 28902 -- of misleading cascaded errors. 28903 28904 raise Unrecoverable_Error; 28905 end if; 28906 28907 -- The constituent is a valid state or object 28908 28909 elsif Ekind_In (Constit_Id, E_Abstract_State, 28910 E_Constant, 28911 E_Variable) 28912 then 28913 Match_Constituent (Constit_Id); 28914 28915 -- The variable may eventually become a constituent of a 28916 -- single protected/task type. Record the reference now 28917 -- and verify its legality when analyzing the contract of 28918 -- the variable (SPARK RM 9.3). 28919 28920 if Ekind (Constit_Id) = E_Variable then 28921 Record_Possible_Part_Of_Reference 28922 (Var_Id => Constit_Id, 28923 Ref => Constit); 28924 end if; 28925 28926 -- Otherwise the constituent is illegal 28927 28928 else 28929 SPARK_Msg_NE 28930 ("constituent & must denote object or state", 28931 Constit, Constit_Id); 28932 end if; 28933 28934 -- The constituent is illegal 28935 28936 else 28937 SPARK_Msg_N ("malformed constituent", Constit); 28938 end if; 28939 end if; 28940 end Analyze_Constituent; 28941 28942 ----------------------------- 28943 -- Check_External_Property -- 28944 ----------------------------- 28945 28946 procedure Check_External_Property 28947 (Prop_Nam : Name_Id; 28948 Enabled : Boolean; 28949 Constit : Entity_Id) 28950 is 28951 begin 28952 -- The property is missing in the declaration of the state, but 28953 -- a constituent is introducing it in the state refinement 28954 -- (SPARK RM 7.2.8(2)). 28955 28956 if not Enabled and then Present (Constit) then 28957 Error_Msg_Name_1 := Prop_Nam; 28958 Error_Msg_Name_2 := Chars (State_Id); 28959 SPARK_Msg_NE 28960 ("constituent & introduces external property % in refinement " 28961 & "of state %", State, Constit); 28962 28963 Error_Msg_Sloc := Sloc (State_Id); 28964 SPARK_Msg_N 28965 ("\property is missing in abstract state declaration #", 28966 State); 28967 end if; 28968 end Check_External_Property; 28969 28970 ----------------- 28971 -- Match_State -- 28972 ----------------- 28973 28974 procedure Match_State is 28975 State_Elmt : Elmt_Id; 28976 28977 begin 28978 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8)) 28979 28980 if Contains (Refined_States_Seen, State_Id) then 28981 SPARK_Msg_NE 28982 ("duplicate refinement of state &", State, State_Id); 28983 return; 28984 end if; 28985 28986 -- Inspect the abstract states defined in the package declaration 28987 -- looking for a match. 28988 28989 State_Elmt := First_Elmt (Available_States); 28990 while Present (State_Elmt) loop 28991 28992 -- A valid abstract state is being refined in the body. Add 28993 -- the state to the list of processed refined states to aid 28994 -- with the detection of duplicate refinements. Remove the 28995 -- state from Available_States to signal that it has already 28996 -- been refined. 28997 28998 if Node (State_Elmt) = State_Id then 28999 Append_New_Elmt (State_Id, Refined_States_Seen); 29000 Remove_Elmt (Available_States, State_Elmt); 29001 return; 29002 end if; 29003 29004 Next_Elmt (State_Elmt); 29005 end loop; 29006 29007 -- If we get here, we are refining a state that is not defined in 29008 -- the package declaration. 29009 29010 Error_Msg_Name_1 := Chars (Spec_Id); 29011 SPARK_Msg_NE 29012 ("cannot refine state, & is not defined in package %", 29013 State, State_Id); 29014 end Match_State; 29015 29016 -------------------------------- 29017 -- Report_Unused_Constituents -- 29018 -------------------------------- 29019 29020 procedure Report_Unused_Constituents (Constits : Elist_Id) is 29021 Constit_Elmt : Elmt_Id; 29022 Constit_Id : Entity_Id; 29023 Posted : Boolean := False; 29024 29025 begin 29026 if Present (Constits) then 29027 Constit_Elmt := First_Elmt (Constits); 29028 while Present (Constit_Elmt) loop 29029 Constit_Id := Node (Constit_Elmt); 29030 29031 -- Generate an error message of the form: 29032 29033 -- state ... has unused Part_Of constituents 29034 -- abstract state ... defined at ... 29035 -- constant ... defined at ... 29036 -- variable ... defined at ... 29037 29038 if not Posted then 29039 Posted := True; 29040 SPARK_Msg_NE 29041 ("state & has unused Part_Of constituents", 29042 State, State_Id); 29043 end if; 29044 29045 Error_Msg_Sloc := Sloc (Constit_Id); 29046 29047 if Ekind (Constit_Id) = E_Abstract_State then 29048 SPARK_Msg_NE 29049 ("\abstract state & defined #", State, Constit_Id); 29050 29051 elsif Ekind (Constit_Id) = E_Constant then 29052 SPARK_Msg_NE 29053 ("\constant & defined #", State, Constit_Id); 29054 29055 else 29056 pragma Assert (Ekind (Constit_Id) = E_Variable); 29057 SPARK_Msg_NE ("\variable & defined #", State, Constit_Id); 29058 end if; 29059 29060 Next_Elmt (Constit_Elmt); 29061 end loop; 29062 end if; 29063 end Report_Unused_Constituents; 29064 29065 -- Local declarations 29066 29067 Body_Ref : Node_Id; 29068 Body_Ref_Elmt : Elmt_Id; 29069 Constit : Node_Id; 29070 Extra_State : Node_Id; 29071 29072 -- Start of processing for Analyze_Refinement_Clause 29073 29074 begin 29075 -- A refinement clause appears as a component association where the 29076 -- sole choice is the state and the expressions are the constituents. 29077 -- This is a syntax error, always report. 29078 29079 if Nkind (Clause) /= N_Component_Association then 29080 Error_Msg_N ("malformed state refinement clause", Clause); 29081 return; 29082 end if; 29083 29084 -- Analyze the state name of a refinement clause 29085 29086 State := First (Choices (Clause)); 29087 29088 Analyze (State); 29089 Resolve_State (State); 29090 29091 -- Ensure that the state name denotes a valid abstract state that is 29092 -- defined in the spec of the related package. 29093 29094 if Is_Entity_Name (State) then 29095 State_Id := Entity_Of (State); 29096 29097 -- When the abstract state is undefined, it appears as Any_Id. Do 29098 -- not continue with the analysis of the clause. 29099 29100 if State_Id = Any_Id then 29101 return; 29102 29103 -- Catch any attempts to re-refine a state or refine a state that 29104 -- is not defined in the package declaration. 29105 29106 elsif Ekind (State_Id) = E_Abstract_State then 29107 Match_State; 29108 29109 else 29110 SPARK_Msg_NE ("& must denote abstract state", State, State_Id); 29111 return; 29112 end if; 29113 29114 -- References to a state with visible refinement are illegal. 29115 -- When nested packages are involved, detecting such references is 29116 -- tricky because pragma Refined_State is analyzed later than the 29117 -- offending pragma Depends or Global. References that occur in 29118 -- such nested context are stored in a list. Emit errors for all 29119 -- references found in Body_References (SPARK RM 6.1.4(8)). 29120 29121 if Present (Body_References (State_Id)) then 29122 Body_Ref_Elmt := First_Elmt (Body_References (State_Id)); 29123 while Present (Body_Ref_Elmt) loop 29124 Body_Ref := Node (Body_Ref_Elmt); 29125 29126 SPARK_Msg_N ("reference to & not allowed", Body_Ref); 29127 Error_Msg_Sloc := Sloc (State); 29128 SPARK_Msg_N ("\refinement of & is visible#", Body_Ref); 29129 29130 Next_Elmt (Body_Ref_Elmt); 29131 end loop; 29132 end if; 29133 29134 -- The state name is illegal. This is a syntax error, always report. 29135 29136 else 29137 Error_Msg_N ("malformed state name in refinement clause", State); 29138 return; 29139 end if; 29140 29141 -- A refinement clause may only refine one state at a time 29142 29143 Extra_State := Next (State); 29144 29145 if Present (Extra_State) then 29146 SPARK_Msg_N 29147 ("refinement clause cannot cover multiple states", Extra_State); 29148 end if; 29149 29150 -- Replicate the Part_Of constituents of the refined state because 29151 -- the algorithm will consume items. 29152 29153 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id)); 29154 29155 -- Analyze all constituents of the refinement. Multiple constituents 29156 -- appear as an aggregate. 29157 29158 Constit := Expression (Clause); 29159 29160 if Nkind (Constit) = N_Aggregate then 29161 if Present (Component_Associations (Constit)) then 29162 SPARK_Msg_N 29163 ("constituents of refinement clause must appear in " 29164 & "positional form", Constit); 29165 29166 else pragma Assert (Present (Expressions (Constit))); 29167 Constit := First (Expressions (Constit)); 29168 while Present (Constit) loop 29169 Analyze_Constituent (Constit); 29170 Next (Constit); 29171 end loop; 29172 end if; 29173 29174 -- Various forms of a single constituent. Note that these may include 29175 -- malformed constituents. 29176 29177 else 29178 Analyze_Constituent (Constit); 29179 end if; 29180 29181 -- Verify that external constituents do not introduce new external 29182 -- property in the state refinement (SPARK RM 7.2.8(2)). 29183 29184 if Is_External_State (State_Id) then 29185 Check_External_Property 29186 (Prop_Nam => Name_Async_Readers, 29187 Enabled => Async_Readers_Enabled (State_Id), 29188 Constit => AR_Constit); 29189 29190 Check_External_Property 29191 (Prop_Nam => Name_Async_Writers, 29192 Enabled => Async_Writers_Enabled (State_Id), 29193 Constit => AW_Constit); 29194 29195 Check_External_Property 29196 (Prop_Nam => Name_Effective_Reads, 29197 Enabled => Effective_Reads_Enabled (State_Id), 29198 Constit => ER_Constit); 29199 29200 Check_External_Property 29201 (Prop_Nam => Name_Effective_Writes, 29202 Enabled => Effective_Writes_Enabled (State_Id), 29203 Constit => EW_Constit); 29204 29205 -- When a refined state is not external, it should not have external 29206 -- constituents (SPARK RM 7.2.8(1)). 29207 29208 elsif External_Constit_Seen then 29209 SPARK_Msg_NE 29210 ("non-external state & cannot contain external constituents in " 29211 & "refinement", State, State_Id); 29212 end if; 29213 29214 -- Ensure that all Part_Of candidate constituents have been mentioned 29215 -- in the refinement clause. 29216 29217 Report_Unused_Constituents (Part_Of_Constits); 29218 end Analyze_Refinement_Clause; 29219 29220 ----------------------------- 29221 -- Report_Unrefined_States -- 29222 ----------------------------- 29223 29224 procedure Report_Unrefined_States (States : Elist_Id) is 29225 State_Elmt : Elmt_Id; 29226 29227 begin 29228 if Present (States) then 29229 State_Elmt := First_Elmt (States); 29230 while Present (State_Elmt) loop 29231 SPARK_Msg_N 29232 ("abstract state & must be refined", Node (State_Elmt)); 29233 29234 Next_Elmt (State_Elmt); 29235 end loop; 29236 end if; 29237 end Report_Unrefined_States; 29238 29239 -- Local declarations 29240 29241 Clauses : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); 29242 Clause : Node_Id; 29243 29244 -- Start of processing for Analyze_Refined_State_In_Decl_Part 29245 29246 begin 29247 -- Do not analyze the pragma multiple times 29248 29249 if Is_Analyzed_Pragma (N) then 29250 return; 29251 end if; 29252 29253 -- Save the scenario for examination by the ABE Processing phase 29254 29255 Record_Elaboration_Scenario (N); 29256 29257 -- Replicate the abstract states declared by the package because the 29258 -- matching algorithm will consume states. 29259 29260 Available_States := New_Copy_Elist (Abstract_States (Spec_Id)); 29261 29262 -- Gather all abstract states and objects declared in the visible 29263 -- state space of the package body. These items must be utilized as 29264 -- constituents in a state refinement. 29265 29266 Body_States := Collect_Body_States (Body_Id); 29267 29268 -- Multiple non-null state refinements appear as an aggregate 29269 29270 if Nkind (Clauses) = N_Aggregate then 29271 if Present (Expressions (Clauses)) then 29272 SPARK_Msg_N 29273 ("state refinements must appear as component associations", 29274 Clauses); 29275 29276 else pragma Assert (Present (Component_Associations (Clauses))); 29277 Clause := First (Component_Associations (Clauses)); 29278 while Present (Clause) loop 29279 Analyze_Refinement_Clause (Clause); 29280 Next (Clause); 29281 end loop; 29282 end if; 29283 29284 -- Various forms of a single state refinement. Note that these may 29285 -- include malformed refinements. 29286 29287 else 29288 Analyze_Refinement_Clause (Clauses); 29289 end if; 29290 29291 -- List all abstract states that were left unrefined 29292 29293 Report_Unrefined_States (Available_States); 29294 29295 Set_Is_Analyzed_Pragma (N); 29296 end Analyze_Refined_State_In_Decl_Part; 29297 29298 ------------------------------------ 29299 -- Analyze_Test_Case_In_Decl_Part -- 29300 ------------------------------------ 29301 29302 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id) is 29303 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); 29304 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); 29305 29306 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id); 29307 -- Preanalyze one of the optional arguments "Requires" or "Ensures" 29308 -- denoted by Arg_Nam. 29309 29310 ------------------------------ 29311 -- Preanalyze_Test_Case_Arg -- 29312 ------------------------------ 29313 29314 procedure Preanalyze_Test_Case_Arg (Arg_Nam : Name_Id) is 29315 Arg : Node_Id; 29316 29317 begin 29318 -- Preanalyze the original aspect argument for ASIS or for a generic 29319 -- subprogram to properly capture global references. 29320 29321 if ASIS_Mode or else Is_Generic_Subprogram (Spec_Id) then 29322 Arg := 29323 Test_Case_Arg 29324 (Prag => N, 29325 Arg_Nam => Arg_Nam, 29326 From_Aspect => True); 29327 29328 if Present (Arg) then 29329 Preanalyze_Assert_Expression 29330 (Expression (Arg), Standard_Boolean); 29331 end if; 29332 end if; 29333 29334 Arg := Test_Case_Arg (N, Arg_Nam); 29335 29336 if Present (Arg) then 29337 Preanalyze_Assert_Expression (Expression (Arg), Standard_Boolean); 29338 end if; 29339 end Preanalyze_Test_Case_Arg; 29340 29341 -- Local variables 29342 29343 Restore_Scope : Boolean := False; 29344 29345 -- Start of processing for Analyze_Test_Case_In_Decl_Part 29346 29347 begin 29348 -- Do not analyze the pragma multiple times 29349 29350 if Is_Analyzed_Pragma (N) then 29351 return; 29352 end if; 29353 29354 -- Ensure that the formal parameters are visible when analyzing all 29355 -- clauses. This falls out of the general rule of aspects pertaining 29356 -- to subprogram declarations. 29357 29358 if not In_Open_Scopes (Spec_Id) then 29359 Restore_Scope := True; 29360 Push_Scope (Spec_Id); 29361 29362 if Is_Generic_Subprogram (Spec_Id) then 29363 Install_Generic_Formals (Spec_Id); 29364 else 29365 Install_Formals (Spec_Id); 29366 end if; 29367 end if; 29368 29369 Preanalyze_Test_Case_Arg (Name_Requires); 29370 Preanalyze_Test_Case_Arg (Name_Ensures); 29371 29372 if Restore_Scope then 29373 End_Scope; 29374 end if; 29375 29376 -- Currently it is not possible to inline pre/postconditions on a 29377 -- subprogram subject to pragma Inline_Always. 29378 29379 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id); 29380 29381 Set_Is_Analyzed_Pragma (N); 29382 end Analyze_Test_Case_In_Decl_Part; 29383 29384 ---------------- 29385 -- Appears_In -- 29386 ---------------- 29387 29388 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is 29389 Elmt : Elmt_Id; 29390 Id : Entity_Id; 29391 29392 begin 29393 if Present (List) then 29394 Elmt := First_Elmt (List); 29395 while Present (Elmt) loop 29396 if Nkind (Node (Elmt)) = N_Defining_Identifier then 29397 Id := Node (Elmt); 29398 else 29399 Id := Entity_Of (Node (Elmt)); 29400 end if; 29401 29402 if Id = Item_Id then 29403 return True; 29404 end if; 29405 29406 Next_Elmt (Elmt); 29407 end loop; 29408 end if; 29409 29410 return False; 29411 end Appears_In; 29412 29413 ----------------------------------- 29414 -- Build_Pragma_Check_Equivalent -- 29415 ----------------------------------- 29416 29417 function Build_Pragma_Check_Equivalent 29418 (Prag : Node_Id; 29419 Subp_Id : Entity_Id := Empty; 29420 Inher_Id : Entity_Id := Empty; 29421 Keep_Pragma_Id : Boolean := False) return Node_Id 29422 is 29423 function Suppress_Reference (N : Node_Id) return Traverse_Result; 29424 -- Detect whether node N references a formal parameter subject to 29425 -- pragma Unreferenced. If this is the case, set Comes_From_Source 29426 -- to False to suppress the generation of a reference when analyzing 29427 -- N later on. 29428 29429 ------------------------ 29430 -- Suppress_Reference -- 29431 ------------------------ 29432 29433 function Suppress_Reference (N : Node_Id) return Traverse_Result is 29434 Formal : Entity_Id; 29435 29436 begin 29437 if Is_Entity_Name (N) and then Present (Entity (N)) then 29438 Formal := Entity (N); 29439 29440 -- The formal parameter is subject to pragma Unreferenced. Prevent 29441 -- the generation of references by resetting the Comes_From_Source 29442 -- flag. 29443 29444 if Is_Formal (Formal) 29445 and then Has_Pragma_Unreferenced (Formal) 29446 then 29447 Set_Comes_From_Source (N, False); 29448 end if; 29449 end if; 29450 29451 return OK; 29452 end Suppress_Reference; 29453 29454 procedure Suppress_References is 29455 new Traverse_Proc (Suppress_Reference); 29456 29457 -- Local variables 29458 29459 Loc : constant Source_Ptr := Sloc (Prag); 29460 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 29461 Check_Prag : Node_Id; 29462 Msg_Arg : Node_Id; 29463 Nam : Name_Id; 29464 29465 Needs_Wrapper : Boolean; 29466 pragma Unreferenced (Needs_Wrapper); 29467 29468 -- Start of processing for Build_Pragma_Check_Equivalent 29469 29470 begin 29471 -- When the pre- or postcondition is inherited, map the formals of the 29472 -- inherited subprogram to those of the current subprogram. In addition, 29473 -- map primitive operations of the parent type into the corresponding 29474 -- primitive operations of the descendant. 29475 29476 if Present (Inher_Id) then 29477 pragma Assert (Present (Subp_Id)); 29478 29479 Update_Primitives_Mapping (Inher_Id, Subp_Id); 29480 29481 -- Use generic machinery to copy inherited pragma, as if it were an 29482 -- instantiation, resetting source locations appropriately, so that 29483 -- expressions inside the inherited pragma use chained locations. 29484 -- This is used in particular in GNATprove to locate precisely 29485 -- messages on a given inherited pragma. 29486 29487 Set_Copied_Sloc_For_Inherited_Pragma 29488 (Unit_Declaration_Node (Subp_Id), Inher_Id); 29489 Check_Prag := New_Copy_Tree (Source => Prag); 29490 29491 -- Build the inherited class-wide condition 29492 29493 Build_Class_Wide_Expression 29494 (Prag => Check_Prag, 29495 Subp => Subp_Id, 29496 Par_Subp => Inher_Id, 29497 Adjust_Sloc => True, 29498 Needs_Wrapper => Needs_Wrapper); 29499 29500 -- If not an inherited condition simply copy the original pragma 29501 29502 else 29503 Check_Prag := New_Copy_Tree (Source => Prag); 29504 end if; 29505 29506 -- Mark the pragma as being internally generated and reset the Analyzed 29507 -- flag. 29508 29509 Set_Analyzed (Check_Prag, False); 29510 Set_Comes_From_Source (Check_Prag, False); 29511 29512 -- The tree of the original pragma may contain references to the 29513 -- formal parameters of the related subprogram. At the same time 29514 -- the corresponding body may mark the formals as unreferenced: 29515 29516 -- procedure Proc (Formal : ...) 29517 -- with Pre => Formal ...; 29518 29519 -- procedure Proc (Formal : ...) is 29520 -- pragma Unreferenced (Formal); 29521 -- ... 29522 29523 -- This creates problems because all pragma Check equivalents are 29524 -- analyzed at the end of the body declarations. Since all source 29525 -- references have already been accounted for, reset any references 29526 -- to such formals in the generated pragma Check equivalent. 29527 29528 Suppress_References (Check_Prag); 29529 29530 if Present (Corresponding_Aspect (Prag)) then 29531 Nam := Chars (Identifier (Corresponding_Aspect (Prag))); 29532 else 29533 Nam := Prag_Nam; 29534 end if; 29535 29536 -- Unless Keep_Pragma_Id is True in order to keep the identifier of 29537 -- the copied pragma in the newly created pragma, convert the copy into 29538 -- pragma Check by correcting the name and adding a check_kind argument. 29539 29540 if not Keep_Pragma_Id then 29541 Set_Class_Present (Check_Prag, False); 29542 29543 Set_Pragma_Identifier 29544 (Check_Prag, Make_Identifier (Loc, Name_Check)); 29545 29546 Prepend_To (Pragma_Argument_Associations (Check_Prag), 29547 Make_Pragma_Argument_Association (Loc, 29548 Expression => Make_Identifier (Loc, Nam))); 29549 end if; 29550 29551 -- Update the error message when the pragma is inherited 29552 29553 if Present (Inher_Id) then 29554 Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag)); 29555 29556 if Chars (Msg_Arg) = Name_Message then 29557 String_To_Name_Buffer (Strval (Expression (Msg_Arg))); 29558 29559 -- Insert "inherited" to improve the error message 29560 29561 if Name_Buffer (1 .. 8) = "failed p" then 29562 Insert_Str_In_Name_Buffer ("inherited ", 8); 29563 Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer); 29564 end if; 29565 end if; 29566 end if; 29567 29568 return Check_Prag; 29569 end Build_Pragma_Check_Equivalent; 29570 29571 ----------------------------- 29572 -- Check_Applicable_Policy -- 29573 ----------------------------- 29574 29575 procedure Check_Applicable_Policy (N : Node_Id) is 29576 PP : Node_Id; 29577 Policy : Name_Id; 29578 29579 Ename : constant Name_Id := Original_Aspect_Pragma_Name (N); 29580 29581 begin 29582 -- No effect if not valid assertion kind name 29583 29584 if not Is_Valid_Assertion_Kind (Ename) then 29585 return; 29586 end if; 29587 29588 -- Loop through entries in check policy list 29589 29590 PP := Opt.Check_Policy_List; 29591 while Present (PP) loop 29592 declare 29593 PPA : constant List_Id := Pragma_Argument_Associations (PP); 29594 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 29595 29596 begin 29597 if Ename = Pnm 29598 or else Pnm = Name_Assertion 29599 or else (Pnm = Name_Statement_Assertions 29600 and then Nam_In (Ename, Name_Assert, 29601 Name_Assert_And_Cut, 29602 Name_Assume, 29603 Name_Loop_Invariant, 29604 Name_Loop_Variant)) 29605 then 29606 Policy := Chars (Get_Pragma_Arg (Last (PPA))); 29607 29608 case Policy is 29609 when Name_Ignore 29610 | Name_Off 29611 => 29612 -- In CodePeer mode and GNATprove mode, we need to 29613 -- consider all assertions, unless they are disabled. 29614 -- Force Is_Checked on ignored assertions, in particular 29615 -- because transformations of the AST may depend on 29616 -- assertions being checked (e.g. the translation of 29617 -- attribute 'Loop_Entry). 29618 29619 if CodePeer_Mode or GNATprove_Mode then 29620 Set_Is_Checked (N, True); 29621 Set_Is_Ignored (N, False); 29622 else 29623 Set_Is_Checked (N, False); 29624 Set_Is_Ignored (N, True); 29625 end if; 29626 29627 when Name_Check 29628 | Name_On 29629 => 29630 Set_Is_Checked (N, True); 29631 Set_Is_Ignored (N, False); 29632 29633 when Name_Disable => 29634 Set_Is_Ignored (N, True); 29635 Set_Is_Checked (N, False); 29636 Set_Is_Disabled (N, True); 29637 29638 -- That should be exhaustive, the null here is a defence 29639 -- against a malformed tree from previous errors. 29640 29641 when others => 29642 null; 29643 end case; 29644 29645 return; 29646 end if; 29647 29648 PP := Next_Pragma (PP); 29649 end; 29650 end loop; 29651 29652 -- If there are no specific entries that matched, then we let the 29653 -- setting of assertions govern. Note that this provides the needed 29654 -- compatibility with the RM for the cases of assertion, invariant, 29655 -- precondition, predicate, and postcondition. Note also that 29656 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode. 29657 29658 if Assertions_Enabled then 29659 Set_Is_Checked (N, True); 29660 Set_Is_Ignored (N, False); 29661 else 29662 Set_Is_Checked (N, False); 29663 Set_Is_Ignored (N, True); 29664 end if; 29665 end Check_Applicable_Policy; 29666 29667 ------------------------------- 29668 -- Check_External_Properties -- 29669 ------------------------------- 29670 29671 procedure Check_External_Properties 29672 (Item : Node_Id; 29673 AR : Boolean; 29674 AW : Boolean; 29675 ER : Boolean; 29676 EW : Boolean) 29677 is 29678 begin 29679 -- All properties enabled 29680 29681 if AR and AW and ER and EW then 29682 null; 29683 29684 -- Async_Readers + Effective_Writes 29685 -- Async_Readers + Async_Writers + Effective_Writes 29686 29687 elsif AR and EW and not ER then 29688 null; 29689 29690 -- Async_Writers + Effective_Reads 29691 -- Async_Readers + Async_Writers + Effective_Reads 29692 29693 elsif AW and ER and not EW then 29694 null; 29695 29696 -- Async_Readers + Async_Writers 29697 29698 elsif AR and AW and not ER and not EW then 29699 null; 29700 29701 -- Async_Readers 29702 29703 elsif AR and not AW and not ER and not EW then 29704 null; 29705 29706 -- Async_Writers 29707 29708 elsif AW and not AR and not ER and not EW then 29709 null; 29710 29711 else 29712 SPARK_Msg_N 29713 ("illegal combination of external properties (SPARK RM 7.1.2(6))", 29714 Item); 29715 end if; 29716 end Check_External_Properties; 29717 29718 ---------------- 29719 -- Check_Kind -- 29720 ---------------- 29721 29722 function Check_Kind (Nam : Name_Id) return Name_Id is 29723 PP : Node_Id; 29724 29725 begin 29726 -- Loop through entries in check policy list 29727 29728 PP := Opt.Check_Policy_List; 29729 while Present (PP) loop 29730 declare 29731 PPA : constant List_Id := Pragma_Argument_Associations (PP); 29732 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 29733 29734 begin 29735 if Nam = Pnm 29736 or else (Pnm = Name_Assertion 29737 and then Is_Valid_Assertion_Kind (Nam)) 29738 or else (Pnm = Name_Statement_Assertions 29739 and then Nam_In (Nam, Name_Assert, 29740 Name_Assert_And_Cut, 29741 Name_Assume, 29742 Name_Loop_Invariant, 29743 Name_Loop_Variant)) 29744 then 29745 case (Chars (Get_Pragma_Arg (Last (PPA)))) is 29746 when Name_Check 29747 | Name_On 29748 => 29749 return Name_Check; 29750 29751 when Name_Ignore 29752 | Name_Off 29753 => 29754 return Name_Ignore; 29755 29756 when Name_Disable => 29757 return Name_Disable; 29758 29759 when others => 29760 raise Program_Error; 29761 end case; 29762 29763 else 29764 PP := Next_Pragma (PP); 29765 end if; 29766 end; 29767 end loop; 29768 29769 -- If there are no specific entries that matched, then we let the 29770 -- setting of assertions govern. Note that this provides the needed 29771 -- compatibility with the RM for the cases of assertion, invariant, 29772 -- precondition, predicate, and postcondition. 29773 29774 if Assertions_Enabled then 29775 return Name_Check; 29776 else 29777 return Name_Ignore; 29778 end if; 29779 end Check_Kind; 29780 29781 --------------------------- 29782 -- Check_Missing_Part_Of -- 29783 --------------------------- 29784 29785 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is 29786 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean; 29787 -- Determine whether a package denoted by Pack_Id declares at least one 29788 -- visible state. 29789 29790 ----------------------- 29791 -- Has_Visible_State -- 29792 ----------------------- 29793 29794 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is 29795 Item_Id : Entity_Id; 29796 29797 begin 29798 -- Traverse the entity chain of the package trying to find at least 29799 -- one visible abstract state, variable or a package [instantiation] 29800 -- that declares a visible state. 29801 29802 Item_Id := First_Entity (Pack_Id); 29803 while Present (Item_Id) 29804 and then not In_Private_Part (Item_Id) 29805 loop 29806 -- Do not consider internally generated items 29807 29808 if not Comes_From_Source (Item_Id) then 29809 null; 29810 29811 -- Do not consider generic formals or their corresponding actuals 29812 -- because they are not part of a visible state. Note that both 29813 -- entities are marked as hidden. 29814 29815 elsif Is_Hidden (Item_Id) then 29816 null; 29817 29818 -- A visible state has been found. Note that constants are not 29819 -- considered here because it is not possible to determine whether 29820 -- they depend on variable input. This check is left to the SPARK 29821 -- prover. 29822 29823 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 29824 return True; 29825 29826 -- Recursively peek into nested packages and instantiations 29827 29828 elsif Ekind (Item_Id) = E_Package 29829 and then Has_Visible_State (Item_Id) 29830 then 29831 return True; 29832 end if; 29833 29834 Next_Entity (Item_Id); 29835 end loop; 29836 29837 return False; 29838 end Has_Visible_State; 29839 29840 -- Local variables 29841 29842 Pack_Id : Entity_Id; 29843 Placement : State_Space_Kind; 29844 29845 -- Start of processing for Check_Missing_Part_Of 29846 29847 begin 29848 -- Do not consider abstract states, variables or package instantiations 29849 -- coming from an instance as those always inherit the Part_Of indicator 29850 -- of the instance itself. 29851 29852 if In_Instance then 29853 return; 29854 29855 -- Do not consider internally generated entities as these can never 29856 -- have a Part_Of indicator. 29857 29858 elsif not Comes_From_Source (Item_Id) then 29859 return; 29860 29861 -- Perform these checks only when SPARK_Mode is enabled as they will 29862 -- interfere with standard Ada rules and produce false positives. 29863 29864 elsif SPARK_Mode /= On then 29865 return; 29866 29867 -- Do not consider constants, because the compiler cannot accurately 29868 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and 29869 -- act as a hidden state of a package. 29870 29871 elsif Ekind (Item_Id) = E_Constant then 29872 return; 29873 end if; 29874 29875 -- Find where the abstract state, variable or package instantiation 29876 -- lives with respect to the state space. 29877 29878 Find_Placement_In_State_Space 29879 (Item_Id => Item_Id, 29880 Placement => Placement, 29881 Pack_Id => Pack_Id); 29882 29883 -- Items that appear in a non-package construct (subprogram, block, etc) 29884 -- do not require a Part_Of indicator because they can never act as a 29885 -- hidden state. 29886 29887 if Placement = Not_In_Package then 29888 null; 29889 29890 -- An item declared in the body state space of a package always act as a 29891 -- constituent and does not need explicit Part_Of indicator. 29892 29893 elsif Placement = Body_State_Space then 29894 null; 29895 29896 -- In general an item declared in the visible state space of a package 29897 -- does not require a Part_Of indicator. The only exception is when the 29898 -- related package is a nongeneric private child unit, in which case 29899 -- Part_Of must denote a state in the parent unit or in one of its 29900 -- descendants. 29901 29902 elsif Placement = Visible_State_Space then 29903 if Is_Child_Unit (Pack_Id) 29904 and then not Is_Generic_Unit (Pack_Id) 29905 and then Is_Private_Descendant (Pack_Id) 29906 then 29907 -- A package instantiation does not need a Part_Of indicator when 29908 -- the related generic template has no visible state. 29909 29910 if Ekind (Item_Id) = E_Package 29911 and then Is_Generic_Instance (Item_Id) 29912 and then not Has_Visible_State (Item_Id) 29913 then 29914 null; 29915 29916 -- All other cases require Part_Of 29917 29918 else 29919 Error_Msg_N 29920 ("indicator Part_Of is required in this context " 29921 & "(SPARK RM 7.2.6(3))", Item_Id); 29922 Error_Msg_Name_1 := Chars (Pack_Id); 29923 Error_Msg_N 29924 ("\& is declared in the visible part of private child " 29925 & "unit %", Item_Id); 29926 end if; 29927 end if; 29928 29929 -- When the item appears in the private state space of a package, it 29930 -- must be a part of some state declared by the said package. 29931 29932 else pragma Assert (Placement = Private_State_Space); 29933 29934 -- The related package does not declare a state, the item cannot act 29935 -- as a Part_Of constituent. 29936 29937 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then 29938 null; 29939 29940 -- A package instantiation does not need a Part_Of indicator when the 29941 -- related generic template has no visible state. 29942 29943 elsif Ekind (Item_Id) = E_Package 29944 and then Is_Generic_Instance (Item_Id) 29945 and then not Has_Visible_State (Item_Id) 29946 then 29947 null; 29948 29949 -- All other cases require Part_Of 29950 29951 else 29952 Error_Msg_N 29953 ("indicator Part_Of is required in this context " 29954 & "(SPARK RM 7.2.6(2))", Item_Id); 29955 Error_Msg_Name_1 := Chars (Pack_Id); 29956 Error_Msg_N 29957 ("\& is declared in the private part of package %", Item_Id); 29958 end if; 29959 end if; 29960 end Check_Missing_Part_Of; 29961 29962 --------------------------------------------------- 29963 -- Check_Postcondition_Use_In_Inlined_Subprogram -- 29964 --------------------------------------------------- 29965 29966 procedure Check_Postcondition_Use_In_Inlined_Subprogram 29967 (Prag : Node_Id; 29968 Spec_Id : Entity_Id) 29969 is 29970 begin 29971 if Warn_On_Redundant_Constructs 29972 and then Has_Pragma_Inline_Always (Spec_Id) 29973 and then Assertions_Enabled 29974 then 29975 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag); 29976 29977 if From_Aspect_Specification (Prag) then 29978 Error_Msg_NE 29979 ("aspect % not enforced on inlined subprogram &?r?", 29980 Corresponding_Aspect (Prag), Spec_Id); 29981 else 29982 Error_Msg_NE 29983 ("pragma % not enforced on inlined subprogram &?r?", 29984 Prag, Spec_Id); 29985 end if; 29986 end if; 29987 end Check_Postcondition_Use_In_Inlined_Subprogram; 29988 29989 ------------------------------------- 29990 -- Check_State_And_Constituent_Use -- 29991 ------------------------------------- 29992 29993 procedure Check_State_And_Constituent_Use 29994 (States : Elist_Id; 29995 Constits : Elist_Id; 29996 Context : Node_Id) 29997 is 29998 Constit_Elmt : Elmt_Id; 29999 Constit_Id : Entity_Id; 30000 State_Id : Entity_Id; 30001 30002 begin 30003 -- Nothing to do if there are no states or constituents 30004 30005 if No (States) or else No (Constits) then 30006 return; 30007 end if; 30008 30009 -- Inspect the list of constituents and try to determine whether its 30010 -- encapsulating state is in list States. 30011 30012 Constit_Elmt := First_Elmt (Constits); 30013 while Present (Constit_Elmt) loop 30014 Constit_Id := Node (Constit_Elmt); 30015 30016 -- Determine whether the constituent is part of an encapsulating 30017 -- state that appears in the same context and if this is the case, 30018 -- emit an error (SPARK RM 7.2.6(7)). 30019 30020 State_Id := Find_Encapsulating_State (States, Constit_Id); 30021 30022 if Present (State_Id) then 30023 Error_Msg_Name_1 := Chars (Constit_Id); 30024 SPARK_Msg_NE 30025 ("cannot mention state & and its constituent % in the same " 30026 & "context", Context, State_Id); 30027 exit; 30028 end if; 30029 30030 Next_Elmt (Constit_Elmt); 30031 end loop; 30032 end Check_State_And_Constituent_Use; 30033 30034 --------------------------------------------- 30035 -- Collect_Inherited_Class_Wide_Conditions -- 30036 --------------------------------------------- 30037 30038 procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is 30039 Parent_Subp : constant Entity_Id := 30040 Ultimate_Alias (Overridden_Operation (Subp)); 30041 -- The Overridden_Operation may itself be inherited and as such have no 30042 -- explicit contract. 30043 30044 Prags : constant Node_Id := Contract (Parent_Subp); 30045 In_Spec_Expr : Boolean; 30046 Installed : Boolean; 30047 Prag : Node_Id; 30048 New_Prag : Node_Id; 30049 30050 begin 30051 Installed := False; 30052 30053 -- Iterate over the contract of the overridden subprogram to find all 30054 -- inherited class-wide pre- and postconditions. 30055 30056 if Present (Prags) then 30057 Prag := Pre_Post_Conditions (Prags); 30058 30059 while Present (Prag) loop 30060 if Nam_In (Pragma_Name_Unmapped (Prag), 30061 Name_Precondition, Name_Postcondition) 30062 and then Class_Present (Prag) 30063 then 30064 -- The generated pragma must be analyzed in the context of 30065 -- the subprogram, to make its formals visible. In addition, 30066 -- we must inhibit freezing and full analysis because the 30067 -- controlling type of the subprogram is not frozen yet, and 30068 -- may have further primitives. 30069 30070 if not Installed then 30071 Installed := True; 30072 Push_Scope (Subp); 30073 Install_Formals (Subp); 30074 In_Spec_Expr := In_Spec_Expression; 30075 In_Spec_Expression := True; 30076 end if; 30077 30078 New_Prag := 30079 Build_Pragma_Check_Equivalent 30080 (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True); 30081 30082 Insert_After (Unit_Declaration_Node (Subp), New_Prag); 30083 Preanalyze (New_Prag); 30084 30085 -- Prevent further analysis in subsequent processing of the 30086 -- current list of declarations 30087 30088 Set_Analyzed (New_Prag); 30089 end if; 30090 30091 Prag := Next_Pragma (Prag); 30092 end loop; 30093 30094 if Installed then 30095 In_Spec_Expression := In_Spec_Expr; 30096 End_Scope; 30097 end if; 30098 end if; 30099 end Collect_Inherited_Class_Wide_Conditions; 30100 30101 --------------------------------------- 30102 -- Collect_Subprogram_Inputs_Outputs -- 30103 --------------------------------------- 30104 30105 procedure Collect_Subprogram_Inputs_Outputs 30106 (Subp_Id : Entity_Id; 30107 Synthesize : Boolean := False; 30108 Subp_Inputs : in out Elist_Id; 30109 Subp_Outputs : in out Elist_Id; 30110 Global_Seen : out Boolean) 30111 is 30112 procedure Collect_Dependency_Clause (Clause : Node_Id); 30113 -- Collect all relevant items from a dependency clause 30114 30115 procedure Collect_Global_List 30116 (List : Node_Id; 30117 Mode : Name_Id := Name_Input); 30118 -- Collect all relevant items from a global list 30119 30120 ------------------------------- 30121 -- Collect_Dependency_Clause -- 30122 ------------------------------- 30123 30124 procedure Collect_Dependency_Clause (Clause : Node_Id) is 30125 procedure Collect_Dependency_Item 30126 (Item : Node_Id; 30127 Is_Input : Boolean); 30128 -- Add an item to the proper subprogram input or output collection 30129 30130 ----------------------------- 30131 -- Collect_Dependency_Item -- 30132 ----------------------------- 30133 30134 procedure Collect_Dependency_Item 30135 (Item : Node_Id; 30136 Is_Input : Boolean) 30137 is 30138 Extra : Node_Id; 30139 30140 begin 30141 -- Nothing to collect when the item is null 30142 30143 if Nkind (Item) = N_Null then 30144 null; 30145 30146 -- Ditto for attribute 'Result 30147 30148 elsif Is_Attribute_Result (Item) then 30149 null; 30150 30151 -- Multiple items appear as an aggregate 30152 30153 elsif Nkind (Item) = N_Aggregate then 30154 Extra := First (Expressions (Item)); 30155 while Present (Extra) loop 30156 Collect_Dependency_Item (Extra, Is_Input); 30157 Next (Extra); 30158 end loop; 30159 30160 -- Otherwise this is a solitary item 30161 30162 else 30163 if Is_Input then 30164 Append_New_Elmt (Item, Subp_Inputs); 30165 else 30166 Append_New_Elmt (Item, Subp_Outputs); 30167 end if; 30168 end if; 30169 end Collect_Dependency_Item; 30170 30171 -- Start of processing for Collect_Dependency_Clause 30172 30173 begin 30174 if Nkind (Clause) = N_Null then 30175 null; 30176 30177 -- A dependency clause appears as component association 30178 30179 elsif Nkind (Clause) = N_Component_Association then 30180 Collect_Dependency_Item 30181 (Item => Expression (Clause), 30182 Is_Input => True); 30183 30184 Collect_Dependency_Item 30185 (Item => First (Choices (Clause)), 30186 Is_Input => False); 30187 30188 -- To accommodate partial decoration of disabled SPARK features, this 30189 -- routine may be called with illegal input. If this is the case, do 30190 -- not raise Program_Error. 30191 30192 else 30193 null; 30194 end if; 30195 end Collect_Dependency_Clause; 30196 30197 ------------------------- 30198 -- Collect_Global_List -- 30199 ------------------------- 30200 30201 procedure Collect_Global_List 30202 (List : Node_Id; 30203 Mode : Name_Id := Name_Input) 30204 is 30205 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id); 30206 -- Add an item to the proper subprogram input or output collection 30207 30208 ------------------------- 30209 -- Collect_Global_Item -- 30210 ------------------------- 30211 30212 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is 30213 begin 30214 if Nam_In (Mode, Name_In_Out, Name_Input) then 30215 Append_New_Elmt (Item, Subp_Inputs); 30216 end if; 30217 30218 if Nam_In (Mode, Name_In_Out, Name_Output) then 30219 Append_New_Elmt (Item, Subp_Outputs); 30220 end if; 30221 end Collect_Global_Item; 30222 30223 -- Local variables 30224 30225 Assoc : Node_Id; 30226 Item : Node_Id; 30227 30228 -- Start of processing for Collect_Global_List 30229 30230 begin 30231 if Nkind (List) = N_Null then 30232 null; 30233 30234 -- Single global item declaration 30235 30236 elsif Nkind_In (List, N_Expanded_Name, 30237 N_Identifier, 30238 N_Selected_Component) 30239 then 30240 Collect_Global_Item (List, Mode); 30241 30242 -- Simple global list or moded global list declaration 30243 30244 elsif Nkind (List) = N_Aggregate then 30245 if Present (Expressions (List)) then 30246 Item := First (Expressions (List)); 30247 while Present (Item) loop 30248 Collect_Global_Item (Item, Mode); 30249 Next (Item); 30250 end loop; 30251 30252 else 30253 Assoc := First (Component_Associations (List)); 30254 while Present (Assoc) loop 30255 Collect_Global_List 30256 (List => Expression (Assoc), 30257 Mode => Chars (First (Choices (Assoc)))); 30258 Next (Assoc); 30259 end loop; 30260 end if; 30261 30262 -- To accommodate partial decoration of disabled SPARK features, this 30263 -- routine may be called with illegal input. If this is the case, do 30264 -- not raise Program_Error. 30265 30266 else 30267 null; 30268 end if; 30269 end Collect_Global_List; 30270 30271 -- Local variables 30272 30273 Clause : Node_Id; 30274 Clauses : Node_Id; 30275 Depends : Node_Id; 30276 Formal : Entity_Id; 30277 Global : Node_Id; 30278 Spec_Id : Entity_Id := Empty; 30279 Subp_Decl : Node_Id; 30280 Typ : Entity_Id; 30281 30282 -- Start of processing for Collect_Subprogram_Inputs_Outputs 30283 30284 begin 30285 Global_Seen := False; 30286 30287 -- Process all formal parameters of entries, [generic] subprograms, and 30288 -- their bodies. 30289 30290 if Ekind_In (Subp_Id, E_Entry, 30291 E_Entry_Family, 30292 E_Function, 30293 E_Generic_Function, 30294 E_Generic_Procedure, 30295 E_Procedure, 30296 E_Subprogram_Body) 30297 then 30298 Subp_Decl := Unit_Declaration_Node (Subp_Id); 30299 Spec_Id := Unique_Defining_Entity (Subp_Decl); 30300 30301 -- Process all formal parameters 30302 30303 Formal := First_Entity (Spec_Id); 30304 while Present (Formal) loop 30305 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then 30306 Append_New_Elmt (Formal, Subp_Inputs); 30307 end if; 30308 30309 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then 30310 Append_New_Elmt (Formal, Subp_Outputs); 30311 30312 -- Out parameters can act as inputs when the related type is 30313 -- tagged, unconstrained array, unconstrained record, or record 30314 -- with unconstrained components. 30315 30316 if Ekind (Formal) = E_Out_Parameter 30317 and then Is_Unconstrained_Or_Tagged_Item (Formal) 30318 then 30319 Append_New_Elmt (Formal, Subp_Inputs); 30320 end if; 30321 end if; 30322 30323 Next_Entity (Formal); 30324 end loop; 30325 30326 -- Otherwise the input denotes a task type, a task body, or the 30327 -- anonymous object created for a single task type. 30328 30329 elsif Ekind_In (Subp_Id, E_Task_Type, E_Task_Body) 30330 or else Is_Single_Task_Object (Subp_Id) 30331 then 30332 Subp_Decl := Declaration_Node (Subp_Id); 30333 Spec_Id := Unique_Defining_Entity (Subp_Decl); 30334 end if; 30335 30336 -- When processing an entry, subprogram or task body, look for pragmas 30337 -- Refined_Depends and Refined_Global as they specify the inputs and 30338 -- outputs. 30339 30340 if Is_Entry_Body (Subp_Id) 30341 or else Ekind_In (Subp_Id, E_Subprogram_Body, E_Task_Body) 30342 then 30343 Depends := Get_Pragma (Subp_Id, Pragma_Refined_Depends); 30344 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); 30345 30346 -- Subprogram declaration or stand-alone body case, look for pragmas 30347 -- Depends and Global 30348 30349 else 30350 Depends := Get_Pragma (Spec_Id, Pragma_Depends); 30351 Global := Get_Pragma (Spec_Id, Pragma_Global); 30352 end if; 30353 30354 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends 30355 -- because it provides finer granularity of inputs and outputs. 30356 30357 if Present (Global) then 30358 Global_Seen := True; 30359 Collect_Global_List (Expression (Get_Argument (Global, Spec_Id))); 30360 30361 -- When the related subprogram lacks pragma [Refined_]Global, fall back 30362 -- to [Refined_]Depends if the caller requests this behavior. Synthesize 30363 -- the inputs and outputs from [Refined_]Depends. 30364 30365 elsif Synthesize and then Present (Depends) then 30366 Clauses := Expression (Get_Argument (Depends, Spec_Id)); 30367 30368 -- Multiple dependency clauses appear as an aggregate 30369 30370 if Nkind (Clauses) = N_Aggregate then 30371 Clause := First (Component_Associations (Clauses)); 30372 while Present (Clause) loop 30373 Collect_Dependency_Clause (Clause); 30374 Next (Clause); 30375 end loop; 30376 30377 -- Otherwise this is a single dependency clause 30378 30379 else 30380 Collect_Dependency_Clause (Clauses); 30381 end if; 30382 end if; 30383 30384 -- The current instance of a protected type acts as a formal parameter 30385 -- of mode IN for functions and IN OUT for entries and procedures 30386 -- (SPARK RM 6.1.4). 30387 30388 if Ekind (Scope (Spec_Id)) = E_Protected_Type then 30389 Typ := Scope (Spec_Id); 30390 30391 -- Use the anonymous object when the type is single protected 30392 30393 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then 30394 Typ := Anonymous_Object (Typ); 30395 end if; 30396 30397 Append_New_Elmt (Typ, Subp_Inputs); 30398 30399 if Ekind_In (Spec_Id, E_Entry, E_Entry_Family, E_Procedure) then 30400 Append_New_Elmt (Typ, Subp_Outputs); 30401 end if; 30402 30403 -- The current instance of a task type acts as a formal parameter of 30404 -- mode IN OUT (SPARK RM 6.1.4). 30405 30406 elsif Ekind (Spec_Id) = E_Task_Type then 30407 Typ := Spec_Id; 30408 30409 -- Use the anonymous object when the type is single task 30410 30411 if Is_Single_Concurrent_Type_Declaration (Declaration_Node (Typ)) then 30412 Typ := Anonymous_Object (Typ); 30413 end if; 30414 30415 Append_New_Elmt (Typ, Subp_Inputs); 30416 Append_New_Elmt (Typ, Subp_Outputs); 30417 30418 elsif Is_Single_Task_Object (Spec_Id) then 30419 Append_New_Elmt (Spec_Id, Subp_Inputs); 30420 Append_New_Elmt (Spec_Id, Subp_Outputs); 30421 end if; 30422 end Collect_Subprogram_Inputs_Outputs; 30423 30424 --------------------------- 30425 -- Contract_Freeze_Error -- 30426 --------------------------- 30427 30428 procedure Contract_Freeze_Error 30429 (Contract_Id : Entity_Id; 30430 Freeze_Id : Entity_Id) 30431 is 30432 begin 30433 Error_Msg_Name_1 := Chars (Contract_Id); 30434 Error_Msg_Sloc := Sloc (Freeze_Id); 30435 30436 SPARK_Msg_NE 30437 ("body & declared # freezes the contract of%", Contract_Id, Freeze_Id); 30438 SPARK_Msg_N 30439 ("\all contractual items must be declared before body #", Contract_Id); 30440 end Contract_Freeze_Error; 30441 30442 --------------------------------- 30443 -- Delay_Config_Pragma_Analyze -- 30444 --------------------------------- 30445 30446 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is 30447 begin 30448 return Nam_In (Pragma_Name_Unmapped (N), 30449 Name_Interrupt_State, Name_Priority_Specific_Dispatching); 30450 end Delay_Config_Pragma_Analyze; 30451 30452 ----------------------- 30453 -- Duplication_Error -- 30454 ----------------------- 30455 30456 procedure Duplication_Error (Prag : Node_Id; Prev : Node_Id) is 30457 Prag_From_Asp : constant Boolean := From_Aspect_Specification (Prag); 30458 Prev_From_Asp : constant Boolean := From_Aspect_Specification (Prev); 30459 30460 begin 30461 Error_Msg_Sloc := Sloc (Prev); 30462 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag); 30463 30464 -- Emit a precise message to distinguish between source pragmas and 30465 -- pragmas generated from aspects. The ordering of the two pragmas is 30466 -- the following: 30467 30468 -- Prev -- ok 30469 -- Prag -- duplicate 30470 30471 -- No error is emitted when both pragmas come from aspects because this 30472 -- is already detected by the general aspect analysis mechanism. 30473 30474 if Prag_From_Asp and Prev_From_Asp then 30475 null; 30476 elsif Prag_From_Asp then 30477 Error_Msg_N ("aspect % duplicates pragma declared #", Prag); 30478 elsif Prev_From_Asp then 30479 Error_Msg_N ("pragma % duplicates aspect declared #", Prag); 30480 else 30481 Error_Msg_N ("pragma % duplicates pragma declared #", Prag); 30482 end if; 30483 end Duplication_Error; 30484 30485 ------------------------------ 30486 -- Find_Encapsulating_State -- 30487 ------------------------------ 30488 30489 function Find_Encapsulating_State 30490 (States : Elist_Id; 30491 Constit_Id : Entity_Id) return Entity_Id 30492 is 30493 State_Id : Entity_Id; 30494 30495 begin 30496 -- Since a constituent may be part of a larger constituent set, climb 30497 -- the encapsulating state chain looking for a state that appears in 30498 -- States. 30499 30500 State_Id := Encapsulating_State (Constit_Id); 30501 while Present (State_Id) loop 30502 if Contains (States, State_Id) then 30503 return State_Id; 30504 end if; 30505 30506 State_Id := Encapsulating_State (State_Id); 30507 end loop; 30508 30509 return Empty; 30510 end Find_Encapsulating_State; 30511 30512 -------------------------- 30513 -- Find_Related_Context -- 30514 -------------------------- 30515 30516 function Find_Related_Context 30517 (Prag : Node_Id; 30518 Do_Checks : Boolean := False) return Node_Id 30519 is 30520 Stmt : Node_Id; 30521 30522 begin 30523 Stmt := Prev (Prag); 30524 while Present (Stmt) loop 30525 30526 -- Skip prior pragmas, but check for duplicates 30527 30528 if Nkind (Stmt) = N_Pragma then 30529 if Do_Checks 30530 and then Pragma_Name (Stmt) = Pragma_Name (Prag) 30531 then 30532 Duplication_Error 30533 (Prag => Prag, 30534 Prev => Stmt); 30535 end if; 30536 30537 -- Skip internally generated code 30538 30539 elsif not Comes_From_Source (Stmt) then 30540 30541 -- The anonymous object created for a single concurrent type is a 30542 -- suitable context. 30543 30544 if Nkind (Stmt) = N_Object_Declaration 30545 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) 30546 then 30547 return Stmt; 30548 end if; 30549 30550 -- Return the current source construct 30551 30552 else 30553 return Stmt; 30554 end if; 30555 30556 Prev (Stmt); 30557 end loop; 30558 30559 return Empty; 30560 end Find_Related_Context; 30561 30562 -------------------------------------- 30563 -- Find_Related_Declaration_Or_Body -- 30564 -------------------------------------- 30565 30566 function Find_Related_Declaration_Or_Body 30567 (Prag : Node_Id; 30568 Do_Checks : Boolean := False) return Node_Id 30569 is 30570 Prag_Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag); 30571 30572 procedure Expression_Function_Error; 30573 -- Emit an error concerning pragma Prag that illegaly applies to an 30574 -- expression function. 30575 30576 ------------------------------- 30577 -- Expression_Function_Error -- 30578 ------------------------------- 30579 30580 procedure Expression_Function_Error is 30581 begin 30582 Error_Msg_Name_1 := Prag_Nam; 30583 30584 -- Emit a precise message to distinguish between source pragmas and 30585 -- pragmas generated from aspects. 30586 30587 if From_Aspect_Specification (Prag) then 30588 Error_Msg_N 30589 ("aspect % cannot apply to a stand alone expression function", 30590 Prag); 30591 else 30592 Error_Msg_N 30593 ("pragma % cannot apply to a stand alone expression function", 30594 Prag); 30595 end if; 30596 end Expression_Function_Error; 30597 30598 -- Local variables 30599 30600 Context : constant Node_Id := Parent (Prag); 30601 Stmt : Node_Id; 30602 30603 Look_For_Body : constant Boolean := 30604 Nam_In (Prag_Nam, Name_Refined_Depends, 30605 Name_Refined_Global, 30606 Name_Refined_Post, 30607 Name_Refined_State); 30608 -- Refinement pragmas must be associated with a subprogram body [stub] 30609 30610 -- Start of processing for Find_Related_Declaration_Or_Body 30611 30612 begin 30613 Stmt := Prev (Prag); 30614 while Present (Stmt) loop 30615 30616 -- Skip prior pragmas, but check for duplicates. Pragmas produced 30617 -- by splitting a complex pre/postcondition are not considered to 30618 -- be duplicates. 30619 30620 if Nkind (Stmt) = N_Pragma then 30621 if Do_Checks 30622 and then not Split_PPC (Stmt) 30623 and then Original_Aspect_Pragma_Name (Stmt) = Prag_Nam 30624 then 30625 Duplication_Error 30626 (Prag => Prag, 30627 Prev => Stmt); 30628 end if; 30629 30630 -- Emit an error when a refinement pragma appears on an expression 30631 -- function without a completion. 30632 30633 elsif Do_Checks 30634 and then Look_For_Body 30635 and then Nkind (Stmt) = N_Subprogram_Declaration 30636 and then Nkind (Original_Node (Stmt)) = N_Expression_Function 30637 and then not Has_Completion (Defining_Entity (Stmt)) 30638 then 30639 Expression_Function_Error; 30640 return Empty; 30641 30642 -- The refinement pragma applies to a subprogram body stub 30643 30644 elsif Look_For_Body 30645 and then Nkind (Stmt) = N_Subprogram_Body_Stub 30646 then 30647 return Stmt; 30648 30649 -- Skip internally generated code 30650 30651 elsif not Comes_From_Source (Stmt) then 30652 30653 -- The anonymous object created for a single concurrent type is a 30654 -- suitable context. 30655 30656 if Nkind (Stmt) = N_Object_Declaration 30657 and then Is_Single_Concurrent_Object (Defining_Entity (Stmt)) 30658 then 30659 return Stmt; 30660 30661 elsif Nkind (Stmt) = N_Subprogram_Declaration then 30662 30663 -- The subprogram declaration is an internally generated spec 30664 -- for an expression function. 30665 30666 if Nkind (Original_Node (Stmt)) = N_Expression_Function then 30667 return Stmt; 30668 30669 -- The subprogram declaration is an internally generated spec 30670 -- for a stand-alone subrogram body declared inside a protected 30671 -- body. 30672 30673 elsif Present (Corresponding_Body (Stmt)) 30674 and then Comes_From_Source (Corresponding_Body (Stmt)) 30675 and then Is_Protected_Type (Current_Scope) 30676 then 30677 return Stmt; 30678 30679 -- The subprogram is actually an instance housed within an 30680 -- anonymous wrapper package. 30681 30682 elsif Present (Generic_Parent (Specification (Stmt))) then 30683 return Stmt; 30684 end if; 30685 end if; 30686 30687 -- Return the current construct which is either a subprogram body, 30688 -- a subprogram declaration or is illegal. 30689 30690 else 30691 return Stmt; 30692 end if; 30693 30694 Prev (Stmt); 30695 end loop; 30696 30697 -- If we fall through, then the pragma was either the first declaration 30698 -- or it was preceded by other pragmas and no source constructs. 30699 30700 -- The pragma is associated with a library-level subprogram 30701 30702 if Nkind (Context) = N_Compilation_Unit_Aux then 30703 return Unit (Parent (Context)); 30704 30705 -- The pragma appears inside the declarations of an entry body 30706 30707 elsif Nkind (Context) = N_Entry_Body then 30708 return Context; 30709 30710 -- The pragma appears inside the statements of a subprogram body. This 30711 -- placement is the result of subprogram contract expansion. 30712 30713 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then 30714 return Parent (Context); 30715 30716 -- The pragma appears inside the declarative part of a package body 30717 30718 elsif Nkind (Context) = N_Package_Body then 30719 return Context; 30720 30721 -- The pragma appears inside the declarative part of a subprogram body 30722 30723 elsif Nkind (Context) = N_Subprogram_Body then 30724 return Context; 30725 30726 -- The pragma appears inside the declarative part of a task body 30727 30728 elsif Nkind (Context) = N_Task_Body then 30729 return Context; 30730 30731 -- The pragma appears inside the visible part of a package specification 30732 30733 elsif Nkind (Context) = N_Package_Specification then 30734 return Parent (Context); 30735 30736 -- The pragma is a byproduct of aspect expansion, return the related 30737 -- context of the original aspect. This case has a lower priority as 30738 -- the above circuitry pinpoints precisely the related context. 30739 30740 elsif Present (Corresponding_Aspect (Prag)) then 30741 return Parent (Corresponding_Aspect (Prag)); 30742 30743 -- No candidate subprogram [body] found 30744 30745 else 30746 return Empty; 30747 end if; 30748 end Find_Related_Declaration_Or_Body; 30749 30750 ---------------------------------- 30751 -- Find_Related_Package_Or_Body -- 30752 ---------------------------------- 30753 30754 function Find_Related_Package_Or_Body 30755 (Prag : Node_Id; 30756 Do_Checks : Boolean := False) return Node_Id 30757 is 30758 Context : constant Node_Id := Parent (Prag); 30759 Prag_Nam : constant Name_Id := Pragma_Name (Prag); 30760 Stmt : Node_Id; 30761 30762 begin 30763 Stmt := Prev (Prag); 30764 while Present (Stmt) loop 30765 30766 -- Skip prior pragmas, but check for duplicates 30767 30768 if Nkind (Stmt) = N_Pragma then 30769 if Do_Checks and then Pragma_Name (Stmt) = Prag_Nam then 30770 Duplication_Error 30771 (Prag => Prag, 30772 Prev => Stmt); 30773 end if; 30774 30775 -- Skip internally generated code 30776 30777 elsif not Comes_From_Source (Stmt) then 30778 if Nkind (Stmt) = N_Subprogram_Declaration then 30779 30780 -- The subprogram declaration is an internally generated spec 30781 -- for an expression function. 30782 30783 if Nkind (Original_Node (Stmt)) = N_Expression_Function then 30784 return Stmt; 30785 30786 -- The subprogram is actually an instance housed within an 30787 -- anonymous wrapper package. 30788 30789 elsif Present (Generic_Parent (Specification (Stmt))) then 30790 return Stmt; 30791 end if; 30792 end if; 30793 30794 -- Return the current source construct which is illegal 30795 30796 else 30797 return Stmt; 30798 end if; 30799 30800 Prev (Stmt); 30801 end loop; 30802 30803 -- If we fall through, then the pragma was either the first declaration 30804 -- or it was preceded by other pragmas and no source constructs. 30805 30806 -- The pragma is associated with a package. The immediate context in 30807 -- this case is the specification of the package. 30808 30809 if Nkind (Context) = N_Package_Specification then 30810 return Parent (Context); 30811 30812 -- The pragma appears in the declarations of a package body 30813 30814 elsif Nkind (Context) = N_Package_Body then 30815 return Context; 30816 30817 -- The pragma appears in the statements of a package body 30818 30819 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements 30820 and then Nkind (Parent (Context)) = N_Package_Body 30821 then 30822 return Parent (Context); 30823 30824 -- The pragma is a byproduct of aspect expansion, return the related 30825 -- context of the original aspect. This case has a lower priority as 30826 -- the above circuitry pinpoints precisely the related context. 30827 30828 elsif Present (Corresponding_Aspect (Prag)) then 30829 return Parent (Corresponding_Aspect (Prag)); 30830 30831 -- No candidate package [body] found 30832 30833 else 30834 return Empty; 30835 end if; 30836 end Find_Related_Package_Or_Body; 30837 30838 ------------------ 30839 -- Get_Argument -- 30840 ------------------ 30841 30842 function Get_Argument 30843 (Prag : Node_Id; 30844 Context_Id : Entity_Id := Empty) return Node_Id 30845 is 30846 Args : constant List_Id := Pragma_Argument_Associations (Prag); 30847 30848 begin 30849 -- Use the expression of the original aspect when compiling for ASIS or 30850 -- when analyzing the template of a generic unit. In both cases the 30851 -- aspect's tree must be decorated to allow for ASIS queries or to save 30852 -- the global references in the generic context. 30853 30854 if From_Aspect_Specification (Prag) 30855 and then (ASIS_Mode or else (Present (Context_Id) 30856 and then Is_Generic_Unit (Context_Id))) 30857 then 30858 return Corresponding_Aspect (Prag); 30859 30860 -- Otherwise use the expression of the pragma 30861 30862 elsif Present (Args) then 30863 return First (Args); 30864 30865 else 30866 return Empty; 30867 end if; 30868 end Get_Argument; 30869 30870 ------------------------- 30871 -- Get_Base_Subprogram -- 30872 ------------------------- 30873 30874 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is 30875 begin 30876 -- Follow subprogram renaming chain 30877 30878 if Is_Subprogram (Def_Id) 30879 and then Nkind (Parent (Declaration_Node (Def_Id))) = 30880 N_Subprogram_Renaming_Declaration 30881 and then Present (Alias (Def_Id)) 30882 then 30883 return Alias (Def_Id); 30884 else 30885 return Def_Id; 30886 end if; 30887 end Get_Base_Subprogram; 30888 30889 ----------------------- 30890 -- Get_SPARK_Mode_Type -- 30891 ----------------------- 30892 30893 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is 30894 begin 30895 if N = Name_On then 30896 return On; 30897 elsif N = Name_Off then 30898 return Off; 30899 30900 -- Any other argument is illegal. Assume that no SPARK mode applies to 30901 -- avoid potential cascaded errors. 30902 30903 else 30904 return None; 30905 end if; 30906 end Get_SPARK_Mode_Type; 30907 30908 ------------------------------------ 30909 -- Get_SPARK_Mode_From_Annotation -- 30910 ------------------------------------ 30911 30912 function Get_SPARK_Mode_From_Annotation 30913 (N : Node_Id) return SPARK_Mode_Type 30914 is 30915 Mode : Node_Id; 30916 30917 begin 30918 if Nkind (N) = N_Aspect_Specification then 30919 Mode := Expression (N); 30920 30921 else pragma Assert (Nkind (N) = N_Pragma); 30922 Mode := First (Pragma_Argument_Associations (N)); 30923 30924 if Present (Mode) then 30925 Mode := Get_Pragma_Arg (Mode); 30926 end if; 30927 end if; 30928 30929 -- Aspect or pragma SPARK_Mode specifies an explicit mode 30930 30931 if Present (Mode) then 30932 if Nkind (Mode) = N_Identifier then 30933 return Get_SPARK_Mode_Type (Chars (Mode)); 30934 30935 -- In case of a malformed aspect or pragma, return the default None 30936 30937 else 30938 return None; 30939 end if; 30940 30941 -- Otherwise the lack of an expression defaults SPARK_Mode to On 30942 30943 else 30944 return On; 30945 end if; 30946 end Get_SPARK_Mode_From_Annotation; 30947 30948 --------------------------- 30949 -- Has_Extra_Parentheses -- 30950 --------------------------- 30951 30952 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is 30953 Expr : Node_Id; 30954 30955 begin 30956 -- The aggregate should not have an expression list because a clause 30957 -- is always interpreted as a component association. The only way an 30958 -- expression list can sneak in is by adding extra parentheses around 30959 -- the individual clauses: 30960 30961 -- Depends (Output => Input) -- proper form 30962 -- Depends ((Output => Input)) -- extra parentheses 30963 30964 -- Since the extra parentheses are not allowed by the syntax of the 30965 -- pragma, flag them now to avoid emitting misleading errors down the 30966 -- line. 30967 30968 if Nkind (Clause) = N_Aggregate 30969 and then Present (Expressions (Clause)) 30970 then 30971 Expr := First (Expressions (Clause)); 30972 while Present (Expr) loop 30973 30974 -- A dependency clause surrounded by extra parentheses appears 30975 -- as an aggregate of component associations with an optional 30976 -- Paren_Count set. 30977 30978 if Nkind (Expr) = N_Aggregate 30979 and then Present (Component_Associations (Expr)) 30980 then 30981 SPARK_Msg_N 30982 ("dependency clause contains extra parentheses", Expr); 30983 30984 -- Otherwise the expression is a malformed construct 30985 30986 else 30987 SPARK_Msg_N ("malformed dependency clause", Expr); 30988 end if; 30989 30990 Next (Expr); 30991 end loop; 30992 30993 return True; 30994 end if; 30995 30996 return False; 30997 end Has_Extra_Parentheses; 30998 30999 ---------------- 31000 -- Initialize -- 31001 ---------------- 31002 31003 procedure Initialize is 31004 begin 31005 Externals.Init; 31006 Compile_Time_Warnings_Errors.Init; 31007 end Initialize; 31008 31009 -------- 31010 -- ip -- 31011 -------- 31012 31013 procedure ip is 31014 begin 31015 Dummy := Dummy + 1; 31016 end ip; 31017 31018 ----------------------------- 31019 -- Is_Config_Static_String -- 31020 ----------------------------- 31021 31022 function Is_Config_Static_String (Arg : Node_Id) return Boolean is 31023 31024 function Add_Config_Static_String (Arg : Node_Id) return Boolean; 31025 -- This is an internal recursive function that is just like the outer 31026 -- function except that it adds the string to the name buffer rather 31027 -- than placing the string in the name buffer. 31028 31029 ------------------------------ 31030 -- Add_Config_Static_String -- 31031 ------------------------------ 31032 31033 function Add_Config_Static_String (Arg : Node_Id) return Boolean is 31034 N : Node_Id; 31035 C : Char_Code; 31036 31037 begin 31038 N := Arg; 31039 31040 if Nkind (N) = N_Op_Concat then 31041 if Add_Config_Static_String (Left_Opnd (N)) then 31042 N := Right_Opnd (N); 31043 else 31044 return False; 31045 end if; 31046 end if; 31047 31048 if Nkind (N) /= N_String_Literal then 31049 Error_Msg_N ("string literal expected for pragma argument", N); 31050 return False; 31051 31052 else 31053 for J in 1 .. String_Length (Strval (N)) loop 31054 C := Get_String_Char (Strval (N), J); 31055 31056 if not In_Character_Range (C) then 31057 Error_Msg 31058 ("string literal contains invalid wide character", 31059 Sloc (N) + 1 + Source_Ptr (J)); 31060 return False; 31061 end if; 31062 31063 Add_Char_To_Name_Buffer (Get_Character (C)); 31064 end loop; 31065 end if; 31066 31067 return True; 31068 end Add_Config_Static_String; 31069 31070 -- Start of processing for Is_Config_Static_String 31071 31072 begin 31073 Name_Len := 0; 31074 31075 return Add_Config_Static_String (Arg); 31076 end Is_Config_Static_String; 31077 31078 ------------------------------- 31079 -- Is_Elaboration_SPARK_Mode -- 31080 ------------------------------- 31081 31082 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is 31083 begin 31084 pragma Assert 31085 (Nkind (N) = N_Pragma 31086 and then Pragma_Name (N) = Name_SPARK_Mode 31087 and then Is_List_Member (N)); 31088 31089 -- Pragma SPARK_Mode affects the elaboration of a package body when it 31090 -- appears in the statement part of the body. 31091 31092 return 31093 Present (Parent (N)) 31094 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements 31095 and then List_Containing (N) = Statements (Parent (N)) 31096 and then Present (Parent (Parent (N))) 31097 and then Nkind (Parent (Parent (N))) = N_Package_Body; 31098 end Is_Elaboration_SPARK_Mode; 31099 31100 ----------------------- 31101 -- Is_Enabled_Pragma -- 31102 ----------------------- 31103 31104 function Is_Enabled_Pragma (Prag : Node_Id) return Boolean is 31105 Arg : Node_Id; 31106 31107 begin 31108 if Present (Prag) then 31109 Arg := First (Pragma_Argument_Associations (Prag)); 31110 31111 if Present (Arg) then 31112 return Is_True (Expr_Value (Get_Pragma_Arg (Arg))); 31113 31114 -- The lack of a Boolean argument automatically enables the pragma 31115 31116 else 31117 return True; 31118 end if; 31119 31120 -- The pragma is missing, therefore it is not enabled 31121 31122 else 31123 return False; 31124 end if; 31125 end Is_Enabled_Pragma; 31126 31127 ----------------------------------------- 31128 -- Is_Non_Significant_Pragma_Reference -- 31129 ----------------------------------------- 31130 31131 -- This function makes use of the following static table which indicates 31132 -- whether appearance of some name in a given pragma is to be considered 31133 -- as a reference for the purposes of warnings about unreferenced objects. 31134 31135 -- -1 indicates that appearence in any argument is significant 31136 -- 0 indicates that appearance in any argument is not significant 31137 -- +n indicates that appearance as argument n is significant, but all 31138 -- other arguments are not significant 31139 -- 9n arguments from n on are significant, before n insignificant 31140 31141 Sig_Flags : constant array (Pragma_Id) of Int := 31142 (Pragma_Abort_Defer => -1, 31143 Pragma_Abstract_State => -1, 31144 Pragma_Acc_Data => 0, 31145 Pragma_Acc_Kernels => 0, 31146 Pragma_Acc_Loop => 0, 31147 Pragma_Acc_Parallel => 0, 31148 Pragma_Ada_83 => -1, 31149 Pragma_Ada_95 => -1, 31150 Pragma_Ada_05 => -1, 31151 Pragma_Ada_2005 => -1, 31152 Pragma_Ada_12 => -1, 31153 Pragma_Ada_2012 => -1, 31154 Pragma_Ada_2020 => -1, 31155 Pragma_Aggregate_Individually_Assign => 0, 31156 Pragma_All_Calls_Remote => -1, 31157 Pragma_Allow_Integer_Address => -1, 31158 Pragma_Annotate => 93, 31159 Pragma_Assert => -1, 31160 Pragma_Assert_And_Cut => -1, 31161 Pragma_Assertion_Policy => 0, 31162 Pragma_Assume => -1, 31163 Pragma_Assume_No_Invalid_Values => 0, 31164 Pragma_Async_Readers => 0, 31165 Pragma_Async_Writers => 0, 31166 Pragma_Asynchronous => 0, 31167 Pragma_Atomic => 0, 31168 Pragma_Atomic_Components => 0, 31169 Pragma_Attach_Handler => -1, 31170 Pragma_Attribute_Definition => 92, 31171 Pragma_Check => -1, 31172 Pragma_Check_Float_Overflow => 0, 31173 Pragma_Check_Name => 0, 31174 Pragma_Check_Policy => 0, 31175 Pragma_CPP_Class => 0, 31176 Pragma_CPP_Constructor => 0, 31177 Pragma_CPP_Virtual => 0, 31178 Pragma_CPP_Vtable => 0, 31179 Pragma_CPU => -1, 31180 Pragma_C_Pass_By_Copy => 0, 31181 Pragma_Comment => -1, 31182 Pragma_Common_Object => 0, 31183 Pragma_Compile_Time_Error => -1, 31184 Pragma_Compile_Time_Warning => -1, 31185 Pragma_Compiler_Unit => -1, 31186 Pragma_Compiler_Unit_Warning => -1, 31187 Pragma_Complete_Representation => 0, 31188 Pragma_Complex_Representation => 0, 31189 Pragma_Component_Alignment => 0, 31190 Pragma_Constant_After_Elaboration => 0, 31191 Pragma_Contract_Cases => -1, 31192 Pragma_Controlled => 0, 31193 Pragma_Convention => 0, 31194 Pragma_Convention_Identifier => 0, 31195 Pragma_Deadline_Floor => -1, 31196 Pragma_Debug => -1, 31197 Pragma_Debug_Policy => 0, 31198 Pragma_Detect_Blocking => 0, 31199 Pragma_Default_Initial_Condition => -1, 31200 Pragma_Default_Scalar_Storage_Order => 0, 31201 Pragma_Default_Storage_Pool => 0, 31202 Pragma_Depends => -1, 31203 Pragma_Disable_Atomic_Synchronization => 0, 31204 Pragma_Discard_Names => 0, 31205 Pragma_Dispatching_Domain => -1, 31206 Pragma_Effective_Reads => 0, 31207 Pragma_Effective_Writes => 0, 31208 Pragma_Elaborate => 0, 31209 Pragma_Elaborate_All => 0, 31210 Pragma_Elaborate_Body => 0, 31211 Pragma_Elaboration_Checks => 0, 31212 Pragma_Eliminate => 0, 31213 Pragma_Enable_Atomic_Synchronization => 0, 31214 Pragma_Export => -1, 31215 Pragma_Export_Function => -1, 31216 Pragma_Export_Object => -1, 31217 Pragma_Export_Procedure => -1, 31218 Pragma_Export_Value => -1, 31219 Pragma_Export_Valued_Procedure => -1, 31220 Pragma_Extend_System => -1, 31221 Pragma_Extensions_Allowed => 0, 31222 Pragma_Extensions_Visible => 0, 31223 Pragma_External => -1, 31224 Pragma_Favor_Top_Level => 0, 31225 Pragma_External_Name_Casing => 0, 31226 Pragma_Fast_Math => 0, 31227 Pragma_Finalize_Storage_Only => 0, 31228 Pragma_Ghost => 0, 31229 Pragma_Global => -1, 31230 Pragma_Ident => -1, 31231 Pragma_Ignore_Pragma => 0, 31232 Pragma_Implementation_Defined => -1, 31233 Pragma_Implemented => -1, 31234 Pragma_Implicit_Packing => 0, 31235 Pragma_Import => 93, 31236 Pragma_Import_Function => 0, 31237 Pragma_Import_Object => 0, 31238 Pragma_Import_Procedure => 0, 31239 Pragma_Import_Valued_Procedure => 0, 31240 Pragma_Independent => 0, 31241 Pragma_Independent_Components => 0, 31242 Pragma_Initial_Condition => -1, 31243 Pragma_Initialize_Scalars => 0, 31244 Pragma_Initializes => -1, 31245 Pragma_Inline => 0, 31246 Pragma_Inline_Always => 0, 31247 Pragma_Inline_Generic => 0, 31248 Pragma_Inspection_Point => -1, 31249 Pragma_Interface => 92, 31250 Pragma_Interface_Name => 0, 31251 Pragma_Interrupt_Handler => -1, 31252 Pragma_Interrupt_Priority => -1, 31253 Pragma_Interrupt_State => -1, 31254 Pragma_Invariant => -1, 31255 Pragma_Keep_Names => 0, 31256 Pragma_License => 0, 31257 Pragma_Link_With => -1, 31258 Pragma_Linker_Alias => -1, 31259 Pragma_Linker_Constructor => -1, 31260 Pragma_Linker_Destructor => -1, 31261 Pragma_Linker_Options => -1, 31262 Pragma_Linker_Section => -1, 31263 Pragma_List => 0, 31264 Pragma_Lock_Free => 0, 31265 Pragma_Locking_Policy => 0, 31266 Pragma_Loop_Invariant => -1, 31267 Pragma_Loop_Optimize => 0, 31268 Pragma_Loop_Variant => -1, 31269 Pragma_Machine_Attribute => -1, 31270 Pragma_Main => -1, 31271 Pragma_Main_Storage => -1, 31272 Pragma_Max_Entry_Queue_Depth => 0, 31273 Pragma_Max_Entry_Queue_Length => 0, 31274 Pragma_Max_Queue_Length => 0, 31275 Pragma_Memory_Size => 0, 31276 Pragma_No_Body => 0, 31277 Pragma_No_Caching => 0, 31278 Pragma_No_Component_Reordering => -1, 31279 Pragma_No_Elaboration_Code_All => 0, 31280 Pragma_No_Heap_Finalization => 0, 31281 Pragma_No_Inline => 0, 31282 Pragma_No_Return => 0, 31283 Pragma_No_Run_Time => -1, 31284 Pragma_No_Strict_Aliasing => -1, 31285 Pragma_No_Tagged_Streams => 0, 31286 Pragma_Normalize_Scalars => 0, 31287 Pragma_Obsolescent => 0, 31288 Pragma_Optimize => 0, 31289 Pragma_Optimize_Alignment => 0, 31290 Pragma_Overflow_Mode => 0, 31291 Pragma_Overriding_Renamings => 0, 31292 Pragma_Ordered => 0, 31293 Pragma_Pack => 0, 31294 Pragma_Page => 0, 31295 Pragma_Part_Of => 0, 31296 Pragma_Partition_Elaboration_Policy => 0, 31297 Pragma_Passive => 0, 31298 Pragma_Persistent_BSS => 0, 31299 Pragma_Polling => 0, 31300 Pragma_Prefix_Exception_Messages => 0, 31301 Pragma_Post => -1, 31302 Pragma_Postcondition => -1, 31303 Pragma_Post_Class => -1, 31304 Pragma_Pre => -1, 31305 Pragma_Precondition => -1, 31306 Pragma_Predicate => -1, 31307 Pragma_Predicate_Failure => -1, 31308 Pragma_Preelaborable_Initialization => -1, 31309 Pragma_Preelaborate => 0, 31310 Pragma_Pre_Class => -1, 31311 Pragma_Priority => -1, 31312 Pragma_Priority_Specific_Dispatching => 0, 31313 Pragma_Profile => 0, 31314 Pragma_Profile_Warnings => 0, 31315 Pragma_Propagate_Exceptions => 0, 31316 Pragma_Provide_Shift_Operators => 0, 31317 Pragma_Psect_Object => 0, 31318 Pragma_Pure => 0, 31319 Pragma_Pure_Function => 0, 31320 Pragma_Queuing_Policy => 0, 31321 Pragma_Rational => 0, 31322 Pragma_Ravenscar => 0, 31323 Pragma_Refined_Depends => -1, 31324 Pragma_Refined_Global => -1, 31325 Pragma_Refined_Post => -1, 31326 Pragma_Refined_State => -1, 31327 Pragma_Relative_Deadline => 0, 31328 Pragma_Rename_Pragma => 0, 31329 Pragma_Remote_Access_Type => -1, 31330 Pragma_Remote_Call_Interface => -1, 31331 Pragma_Remote_Types => -1, 31332 Pragma_Restricted_Run_Time => 0, 31333 Pragma_Restriction_Warnings => 0, 31334 Pragma_Restrictions => 0, 31335 Pragma_Reviewable => -1, 31336 Pragma_Secondary_Stack_Size => -1, 31337 Pragma_Short_Circuit_And_Or => 0, 31338 Pragma_Share_Generic => 0, 31339 Pragma_Shared => 0, 31340 Pragma_Shared_Passive => 0, 31341 Pragma_Short_Descriptors => 0, 31342 Pragma_Simple_Storage_Pool_Type => 0, 31343 Pragma_Source_File_Name => 0, 31344 Pragma_Source_File_Name_Project => 0, 31345 Pragma_Source_Reference => 0, 31346 Pragma_SPARK_Mode => 0, 31347 Pragma_Storage_Size => -1, 31348 Pragma_Storage_Unit => 0, 31349 Pragma_Static_Elaboration_Desired => 0, 31350 Pragma_Stream_Convert => 0, 31351 Pragma_Style_Checks => 0, 31352 Pragma_Subtitle => 0, 31353 Pragma_Suppress => 0, 31354 Pragma_Suppress_Exception_Locations => 0, 31355 Pragma_Suppress_All => 0, 31356 Pragma_Suppress_Debug_Info => 0, 31357 Pragma_Suppress_Initialization => 0, 31358 Pragma_System_Name => 0, 31359 Pragma_Task_Dispatching_Policy => 0, 31360 Pragma_Task_Info => -1, 31361 Pragma_Task_Name => -1, 31362 Pragma_Task_Storage => -1, 31363 Pragma_Test_Case => -1, 31364 Pragma_Thread_Local_Storage => -1, 31365 Pragma_Time_Slice => -1, 31366 Pragma_Title => 0, 31367 Pragma_Type_Invariant => -1, 31368 Pragma_Type_Invariant_Class => -1, 31369 Pragma_Unchecked_Union => 0, 31370 Pragma_Unevaluated_Use_Of_Old => 0, 31371 Pragma_Unimplemented_Unit => 0, 31372 Pragma_Universal_Aliasing => 0, 31373 Pragma_Universal_Data => 0, 31374 Pragma_Unmodified => 0, 31375 Pragma_Unreferenced => 0, 31376 Pragma_Unreferenced_Objects => 0, 31377 Pragma_Unreserve_All_Interrupts => 0, 31378 Pragma_Unsuppress => 0, 31379 Pragma_Unused => 0, 31380 Pragma_Use_VADS_Size => 0, 31381 Pragma_Validity_Checks => 0, 31382 Pragma_Volatile => 0, 31383 Pragma_Volatile_Components => 0, 31384 Pragma_Volatile_Full_Access => 0, 31385 Pragma_Volatile_Function => 0, 31386 Pragma_Warning_As_Error => 0, 31387 Pragma_Warnings => 0, 31388 Pragma_Weak_External => 0, 31389 Pragma_Wide_Character_Encoding => 0, 31390 Unknown_Pragma => 0); 31391 31392 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is 31393 Id : Pragma_Id; 31394 P : Node_Id; 31395 C : Int; 31396 AN : Nat; 31397 31398 function Arg_No return Nat; 31399 -- Returns an integer showing what argument we are in. A value of 31400 -- zero means we are not in any of the arguments. 31401 31402 ------------ 31403 -- Arg_No -- 31404 ------------ 31405 31406 function Arg_No return Nat is 31407 A : Node_Id; 31408 N : Nat; 31409 31410 begin 31411 A := First (Pragma_Argument_Associations (Parent (P))); 31412 N := 1; 31413 loop 31414 if No (A) then 31415 return 0; 31416 elsif A = P then 31417 return N; 31418 end if; 31419 31420 Next (A); 31421 N := N + 1; 31422 end loop; 31423 end Arg_No; 31424 31425 -- Start of processing for Non_Significant_Pragma_Reference 31426 31427 begin 31428 P := Parent (N); 31429 31430 if Nkind (P) /= N_Pragma_Argument_Association then 31431 return False; 31432 31433 else 31434 Id := Get_Pragma_Id (Parent (P)); 31435 C := Sig_Flags (Id); 31436 AN := Arg_No; 31437 31438 if AN = 0 then 31439 return False; 31440 end if; 31441 31442 case C is 31443 when -1 => 31444 return False; 31445 31446 when 0 => 31447 return True; 31448 31449 when 92 .. 99 => 31450 return AN < (C - 90); 31451 31452 when others => 31453 return AN /= C; 31454 end case; 31455 end if; 31456 end Is_Non_Significant_Pragma_Reference; 31457 31458 ------------------------------ 31459 -- Is_Pragma_String_Literal -- 31460 ------------------------------ 31461 31462 -- This function returns true if the corresponding pragma argument is a 31463 -- static string expression. These are the only cases in which string 31464 -- literals can appear as pragma arguments. We also allow a string literal 31465 -- as the first argument to pragma Assert (although it will of course 31466 -- always generate a type error). 31467 31468 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is 31469 Pragn : constant Node_Id := Parent (Par); 31470 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); 31471 Pname : constant Name_Id := Pragma_Name (Pragn); 31472 Argn : Natural; 31473 N : Node_Id; 31474 31475 begin 31476 Argn := 1; 31477 N := First (Assoc); 31478 loop 31479 exit when N = Par; 31480 Argn := Argn + 1; 31481 Next (N); 31482 end loop; 31483 31484 if Pname = Name_Assert then 31485 return True; 31486 31487 elsif Pname = Name_Export then 31488 return Argn > 2; 31489 31490 elsif Pname = Name_Ident then 31491 return Argn = 1; 31492 31493 elsif Pname = Name_Import then 31494 return Argn > 2; 31495 31496 elsif Pname = Name_Interface_Name then 31497 return Argn > 1; 31498 31499 elsif Pname = Name_Linker_Alias then 31500 return Argn = 2; 31501 31502 elsif Pname = Name_Linker_Section then 31503 return Argn = 2; 31504 31505 elsif Pname = Name_Machine_Attribute then 31506 return Argn = 2; 31507 31508 elsif Pname = Name_Source_File_Name then 31509 return True; 31510 31511 elsif Pname = Name_Source_Reference then 31512 return Argn = 2; 31513 31514 elsif Pname = Name_Title then 31515 return True; 31516 31517 elsif Pname = Name_Subtitle then 31518 return True; 31519 31520 else 31521 return False; 31522 end if; 31523 end Is_Pragma_String_Literal; 31524 31525 --------------------------- 31526 -- Is_Private_SPARK_Mode -- 31527 --------------------------- 31528 31529 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is 31530 begin 31531 pragma Assert 31532 (Nkind (N) = N_Pragma 31533 and then Pragma_Name (N) = Name_SPARK_Mode 31534 and then Is_List_Member (N)); 31535 31536 -- For pragma SPARK_Mode to be private, it has to appear in the private 31537 -- declarations of a package. 31538 31539 return 31540 Present (Parent (N)) 31541 and then Nkind (Parent (N)) = N_Package_Specification 31542 and then List_Containing (N) = Private_Declarations (Parent (N)); 31543 end Is_Private_SPARK_Mode; 31544 31545 ------------------------------------- 31546 -- Is_Unconstrained_Or_Tagged_Item -- 31547 ------------------------------------- 31548 31549 function Is_Unconstrained_Or_Tagged_Item 31550 (Item : Entity_Id) return Boolean 31551 is 31552 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean; 31553 -- Determine whether record type Typ has at least one unconstrained 31554 -- component. 31555 31556 --------------------------------- 31557 -- Has_Unconstrained_Component -- 31558 --------------------------------- 31559 31560 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is 31561 Comp : Entity_Id; 31562 31563 begin 31564 Comp := First_Component (Typ); 31565 while Present (Comp) loop 31566 if Is_Unconstrained_Or_Tagged_Item (Comp) then 31567 return True; 31568 end if; 31569 31570 Next_Component (Comp); 31571 end loop; 31572 31573 return False; 31574 end Has_Unconstrained_Component; 31575 31576 -- Local variables 31577 31578 Typ : constant Entity_Id := Etype (Item); 31579 31580 -- Start of processing for Is_Unconstrained_Or_Tagged_Item 31581 31582 begin 31583 if Is_Tagged_Type (Typ) then 31584 return True; 31585 31586 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then 31587 return True; 31588 31589 elsif Is_Record_Type (Typ) then 31590 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then 31591 return True; 31592 else 31593 return Has_Unconstrained_Component (Typ); 31594 end if; 31595 31596 elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then 31597 return True; 31598 31599 else 31600 return False; 31601 end if; 31602 end Is_Unconstrained_Or_Tagged_Item; 31603 31604 ----------------------------- 31605 -- Is_Valid_Assertion_Kind -- 31606 ----------------------------- 31607 31608 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is 31609 begin 31610 case Nam is 31611 when 31612 -- RM defined 31613 31614 Name_Assert 31615 | Name_Assertion_Policy 31616 | Name_Static_Predicate 31617 | Name_Dynamic_Predicate 31618 | Name_Pre 31619 | Name_uPre 31620 | Name_Post 31621 | Name_uPost 31622 | Name_Type_Invariant 31623 | Name_uType_Invariant 31624 31625 -- Impl defined 31626 31627 | Name_Assert_And_Cut 31628 | Name_Assume 31629 | Name_Contract_Cases 31630 | Name_Debug 31631 | Name_Default_Initial_Condition 31632 | Name_Ghost 31633 | Name_Initial_Condition 31634 | Name_Invariant 31635 | Name_uInvariant 31636 | Name_Loop_Invariant 31637 | Name_Loop_Variant 31638 | Name_Postcondition 31639 | Name_Precondition 31640 | Name_Predicate 31641 | Name_Refined_Post 31642 | Name_Statement_Assertions 31643 => 31644 return True; 31645 31646 when others => 31647 return False; 31648 end case; 31649 end Is_Valid_Assertion_Kind; 31650 31651 -------------------------------------- 31652 -- Process_Compilation_Unit_Pragmas -- 31653 -------------------------------------- 31654 31655 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is 31656 begin 31657 -- A special check for pragma Suppress_All, a very strange DEC pragma, 31658 -- strange because it comes at the end of the unit. Rational has the 31659 -- same name for a pragma, but treats it as a program unit pragma, In 31660 -- GNAT we just decide to allow it anywhere at all. If it appeared then 31661 -- the flag Has_Pragma_Suppress_All was set on the compilation unit 31662 -- node, and we insert a pragma Suppress (All_Checks) at the start of 31663 -- the context clause to ensure the correct processing. 31664 31665 if Has_Pragma_Suppress_All (N) then 31666 Prepend_To (Context_Items (N), 31667 Make_Pragma (Sloc (N), 31668 Chars => Name_Suppress, 31669 Pragma_Argument_Associations => New_List ( 31670 Make_Pragma_Argument_Association (Sloc (N), 31671 Expression => Make_Identifier (Sloc (N), Name_All_Checks))))); 31672 end if; 31673 31674 -- Nothing else to do at the current time 31675 31676 end Process_Compilation_Unit_Pragmas; 31677 31678 -------------------------------------------- 31679 -- Validate_Compile_Time_Warning_Or_Error -- 31680 -------------------------------------------- 31681 31682 procedure Validate_Compile_Time_Warning_Or_Error 31683 (N : Node_Id; 31684 Eloc : Source_Ptr) 31685 is 31686 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 31687 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 31688 Arg2 : constant Node_Id := Next (Arg1); 31689 31690 begin 31691 Analyze_And_Resolve (Arg1x, Standard_Boolean); 31692 31693 if Compile_Time_Known_Value (Arg1x) then 31694 if Is_True (Expr_Value (Arg1x)) then 31695 31696 -- We have already verified that the second argument is a static 31697 -- string expression. Its string value must be retrieved 31698 -- explicitly if it is a declared constant, otherwise it has 31699 -- been constant-folded previously. 31700 31701 declare 31702 Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 31703 Pname : constant Name_Id := Pragma_Name_Unmapped (N); 31704 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); 31705 Str : constant String_Id := 31706 Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))); 31707 Str_Len : constant Nat := String_Length (Str); 31708 31709 Force : constant Boolean := 31710 Prag_Id = Pragma_Compile_Time_Warning 31711 and then Is_Spec_Name (Unit_Name (Current_Sem_Unit)) 31712 and then (Ekind (Cent) /= E_Package 31713 or else not In_Private_Part (Cent)); 31714 -- Set True if this is the warning case, and we are in the 31715 -- visible part of a package spec, or in a subprogram spec, 31716 -- in which case we want to force the client to see the 31717 -- warning, even though it is not in the main unit. 31718 31719 C : Character; 31720 CC : Char_Code; 31721 Cont : Boolean; 31722 Ptr : Nat; 31723 31724 begin 31725 -- Loop through segments of message separated by line feeds. 31726 -- We output these segments as separate messages with 31727 -- continuation marks for all but the first. 31728 31729 Cont := False; 31730 Ptr := 1; 31731 loop 31732 Error_Msg_Strlen := 0; 31733 31734 -- Loop to copy characters from argument to error message 31735 -- string buffer. 31736 31737 loop 31738 exit when Ptr > Str_Len; 31739 CC := Get_String_Char (Str, Ptr); 31740 Ptr := Ptr + 1; 31741 31742 -- Ignore wide chars ??? else store character 31743 31744 if In_Character_Range (CC) then 31745 C := Get_Character (CC); 31746 exit when C = ASCII.LF; 31747 Error_Msg_Strlen := Error_Msg_Strlen + 1; 31748 Error_Msg_String (Error_Msg_Strlen) := C; 31749 end if; 31750 end loop; 31751 31752 -- Here with one line ready to go 31753 31754 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; 31755 31756 -- If this is a warning in a spec, then we want clients 31757 -- to see the warning, so mark the message with the 31758 -- special sequence !! to force the warning. In the case 31759 -- of a package spec, we do not force this if we are in 31760 -- the private part of the spec. 31761 31762 if Force then 31763 if Cont = False then 31764 Error_Msg ("<<~!!", Eloc); 31765 Cont := True; 31766 else 31767 Error_Msg ("\<<~!!", Eloc); 31768 end if; 31769 31770 -- Error, rather than warning, or in a body, so we do not 31771 -- need to force visibility for client (error will be 31772 -- output in any case, and this is the situation in which 31773 -- we do not want a client to get a warning, since the 31774 -- warning is in the body or the spec private part). 31775 31776 else 31777 if Cont = False then 31778 Error_Msg ("<<~", Eloc); 31779 Cont := True; 31780 else 31781 Error_Msg ("\<<~", Eloc); 31782 end if; 31783 end if; 31784 31785 exit when Ptr > Str_Len; 31786 end loop; 31787 end; 31788 end if; 31789 31790 -- Arg1x is not known at compile time, so issue a warning. This can 31791 -- happen only if the pragma's processing was deferred until after the 31792 -- back end is run (see Process_Compile_Time_Warning_Or_Error). 31793 -- Note that the warning control switch applies to both pragmas. 31794 31795 elsif Warn_On_Unknown_Compile_Time_Warning then 31796 Error_Msg_N ("?condition is not known at compile time", Arg1x); 31797 end if; 31798 end Validate_Compile_Time_Warning_Or_Error; 31799 31800 ------------------------------------ 31801 -- Record_Possible_Body_Reference -- 31802 ------------------------------------ 31803 31804 procedure Record_Possible_Body_Reference 31805 (State_Id : Entity_Id; 31806 Ref : Node_Id) 31807 is 31808 Context : Node_Id; 31809 Spec_Id : Entity_Id; 31810 31811 begin 31812 -- Ensure that we are dealing with a reference to a state 31813 31814 pragma Assert (Ekind (State_Id) = E_Abstract_State); 31815 31816 -- Climb the tree starting from the reference looking for a package body 31817 -- whose spec declares the referenced state. This criteria automatically 31818 -- excludes references in package specs which are legal. Note that it is 31819 -- not wise to emit an error now as the package body may lack pragma 31820 -- Refined_State or the referenced state may not be mentioned in the 31821 -- refinement. This approach avoids the generation of misleading errors. 31822 31823 Context := Ref; 31824 while Present (Context) loop 31825 if Nkind (Context) = N_Package_Body then 31826 Spec_Id := Corresponding_Spec (Context); 31827 31828 if Present (Abstract_States (Spec_Id)) 31829 and then Contains (Abstract_States (Spec_Id), State_Id) 31830 then 31831 if No (Body_References (State_Id)) then 31832 Set_Body_References (State_Id, New_Elmt_List); 31833 end if; 31834 31835 Append_Elmt (Ref, To => Body_References (State_Id)); 31836 exit; 31837 end if; 31838 end if; 31839 31840 Context := Parent (Context); 31841 end loop; 31842 end Record_Possible_Body_Reference; 31843 31844 ------------------------------------------ 31845 -- Relocate_Pragmas_To_Anonymous_Object -- 31846 ------------------------------------------ 31847 31848 procedure Relocate_Pragmas_To_Anonymous_Object 31849 (Typ_Decl : Node_Id; 31850 Obj_Decl : Node_Id) 31851 is 31852 Decl : Node_Id; 31853 Def : Node_Id; 31854 Next_Decl : Node_Id; 31855 31856 begin 31857 if Nkind (Typ_Decl) = N_Protected_Type_Declaration then 31858 Def := Protected_Definition (Typ_Decl); 31859 else 31860 pragma Assert (Nkind (Typ_Decl) = N_Task_Type_Declaration); 31861 Def := Task_Definition (Typ_Decl); 31862 end if; 31863 31864 -- The concurrent definition has a visible declaration list. Inspect it 31865 -- and relocate all canidate pragmas. 31866 31867 if Present (Def) and then Present (Visible_Declarations (Def)) then 31868 Decl := First (Visible_Declarations (Def)); 31869 while Present (Decl) loop 31870 31871 -- Preserve the following declaration for iteration purposes due 31872 -- to possible relocation of a pragma. 31873 31874 Next_Decl := Next (Decl); 31875 31876 if Nkind (Decl) = N_Pragma 31877 and then Pragma_On_Anonymous_Object_OK (Get_Pragma_Id (Decl)) 31878 then 31879 Remove (Decl); 31880 Insert_After (Obj_Decl, Decl); 31881 31882 -- Skip internally generated code 31883 31884 elsif not Comes_From_Source (Decl) then 31885 null; 31886 31887 -- No candidate pragmas are available for relocation 31888 31889 else 31890 exit; 31891 end if; 31892 31893 Decl := Next_Decl; 31894 end loop; 31895 end if; 31896 end Relocate_Pragmas_To_Anonymous_Object; 31897 31898 ------------------------------ 31899 -- Relocate_Pragmas_To_Body -- 31900 ------------------------------ 31901 31902 procedure Relocate_Pragmas_To_Body 31903 (Subp_Body : Node_Id; 31904 Target_Body : Node_Id := Empty) 31905 is 31906 procedure Relocate_Pragma (Prag : Node_Id); 31907 -- Remove a single pragma from its current list and add it to the 31908 -- declarations of the proper body (either Subp_Body or Target_Body). 31909 31910 --------------------- 31911 -- Relocate_Pragma -- 31912 --------------------- 31913 31914 procedure Relocate_Pragma (Prag : Node_Id) is 31915 Decls : List_Id; 31916 Target : Node_Id; 31917 31918 begin 31919 -- When subprogram stubs or expression functions are involves, the 31920 -- destination declaration list belongs to the proper body. 31921 31922 if Present (Target_Body) then 31923 Target := Target_Body; 31924 else 31925 Target := Subp_Body; 31926 end if; 31927 31928 Decls := Declarations (Target); 31929 31930 if No (Decls) then 31931 Decls := New_List; 31932 Set_Declarations (Target, Decls); 31933 end if; 31934 31935 -- Unhook the pragma from its current list 31936 31937 Remove (Prag); 31938 Prepend (Prag, Decls); 31939 end Relocate_Pragma; 31940 31941 -- Local variables 31942 31943 Body_Id : constant Entity_Id := 31944 Defining_Unit_Name (Specification (Subp_Body)); 31945 Next_Stmt : Node_Id; 31946 Stmt : Node_Id; 31947 31948 -- Start of processing for Relocate_Pragmas_To_Body 31949 31950 begin 31951 -- Do not process a body that comes from a separate unit as no construct 31952 -- can possibly follow it. 31953 31954 if not Is_List_Member (Subp_Body) then 31955 return; 31956 31957 -- Do not relocate pragmas that follow a stub if the stub does not have 31958 -- a proper body. 31959 31960 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub 31961 and then No (Target_Body) 31962 then 31963 return; 31964 31965 -- Do not process internally generated routine _Postconditions 31966 31967 elsif Ekind (Body_Id) = E_Procedure 31968 and then Chars (Body_Id) = Name_uPostconditions 31969 then 31970 return; 31971 end if; 31972 31973 -- Look at what is following the body. We are interested in certain kind 31974 -- of pragmas (either from source or byproducts of expansion) that can 31975 -- apply to a body [stub]. 31976 31977 Stmt := Next (Subp_Body); 31978 while Present (Stmt) loop 31979 31980 -- Preserve the following statement for iteration purposes due to a 31981 -- possible relocation of a pragma. 31982 31983 Next_Stmt := Next (Stmt); 31984 31985 -- Move a candidate pragma following the body to the declarations of 31986 -- the body. 31987 31988 if Nkind (Stmt) = N_Pragma 31989 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt)) 31990 then 31991 31992 -- If a source pragma Warnings follows the body, it applies to 31993 -- following statements and does not belong in the body. 31994 31995 if Get_Pragma_Id (Stmt) = Pragma_Warnings 31996 and then Comes_From_Source (Stmt) 31997 then 31998 null; 31999 else 32000 Relocate_Pragma (Stmt); 32001 end if; 32002 32003 -- Skip internally generated code 32004 32005 elsif not Comes_From_Source (Stmt) then 32006 null; 32007 32008 -- No candidate pragmas are available for relocation 32009 32010 else 32011 exit; 32012 end if; 32013 32014 Stmt := Next_Stmt; 32015 end loop; 32016 end Relocate_Pragmas_To_Body; 32017 32018 ------------------- 32019 -- Resolve_State -- 32020 ------------------- 32021 32022 procedure Resolve_State (N : Node_Id) is 32023 Func : Entity_Id; 32024 State : Entity_Id; 32025 32026 begin 32027 if Is_Entity_Name (N) and then Present (Entity (N)) then 32028 Func := Entity (N); 32029 32030 -- Handle overloading of state names by functions. Traverse the 32031 -- homonym chain looking for an abstract state. 32032 32033 if Ekind (Func) = E_Function and then Has_Homonym (Func) then 32034 pragma Assert (Is_Overloaded (N)); 32035 32036 State := Homonym (Func); 32037 while Present (State) loop 32038 if Ekind (State) = E_Abstract_State then 32039 32040 -- Resolve the overloading by setting the proper entity of 32041 -- the reference to that of the state. 32042 32043 Set_Etype (N, Standard_Void_Type); 32044 Set_Entity (N, State); 32045 Set_Is_Overloaded (N, False); 32046 32047 Generate_Reference (State, N); 32048 return; 32049 end if; 32050 32051 State := Homonym (State); 32052 end loop; 32053 32054 -- A function can never act as a state. If the homonym chain does 32055 -- not contain a corresponding state, then something went wrong in 32056 -- the overloading mechanism. 32057 32058 raise Program_Error; 32059 end if; 32060 end if; 32061 end Resolve_State; 32062 32063 ---------------------------- 32064 -- Rewrite_Assertion_Kind -- 32065 ---------------------------- 32066 32067 procedure Rewrite_Assertion_Kind 32068 (N : Node_Id; 32069 From_Policy : Boolean := False) 32070 is 32071 Nam : Name_Id; 32072 32073 begin 32074 Nam := No_Name; 32075 if Nkind (N) = N_Attribute_Reference 32076 and then Attribute_Name (N) = Name_Class 32077 and then Nkind (Prefix (N)) = N_Identifier 32078 then 32079 case Chars (Prefix (N)) is 32080 when Name_Pre => 32081 Nam := Name_uPre; 32082 32083 when Name_Post => 32084 Nam := Name_uPost; 32085 32086 when Name_Type_Invariant => 32087 Nam := Name_uType_Invariant; 32088 32089 when Name_Invariant => 32090 Nam := Name_uInvariant; 32091 32092 when others => 32093 return; 32094 end case; 32095 32096 -- Recommend standard use of aspect names Pre/Post 32097 32098 elsif Nkind (N) = N_Identifier 32099 and then From_Policy 32100 and then Serious_Errors_Detected = 0 32101 and then not ASIS_Mode 32102 then 32103 if Chars (N) = Name_Precondition 32104 or else Chars (N) = Name_Postcondition 32105 then 32106 Error_Msg_N ("Check_Policy is a non-standard pragma??", N); 32107 Error_Msg_N 32108 ("\use Assertion_Policy and aspect names Pre/Post for " 32109 & "Ada2012 conformance?", N); 32110 end if; 32111 32112 return; 32113 end if; 32114 32115 if Nam /= No_Name then 32116 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam)); 32117 end if; 32118 end Rewrite_Assertion_Kind; 32119 32120 -------- 32121 -- rv -- 32122 -------- 32123 32124 procedure rv is 32125 begin 32126 Dummy := Dummy + 1; 32127 end rv; 32128 32129 -------------------------------- 32130 -- Set_Encoded_Interface_Name -- 32131 -------------------------------- 32132 32133 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is 32134 Str : constant String_Id := Strval (S); 32135 Len : constant Nat := String_Length (Str); 32136 CC : Char_Code; 32137 C : Character; 32138 J : Pos; 32139 32140 Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; 32141 32142 procedure Encode; 32143 -- Stores encoded value of character code CC. The encoding we use an 32144 -- underscore followed by four lower case hex digits. 32145 32146 ------------ 32147 -- Encode -- 32148 ------------ 32149 32150 procedure Encode is 32151 begin 32152 Store_String_Char (Get_Char_Code ('_')); 32153 Store_String_Char 32154 (Get_Char_Code (Hex (Integer (CC / 2 ** 12)))); 32155 Store_String_Char 32156 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#)))); 32157 Store_String_Char 32158 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#)))); 32159 Store_String_Char 32160 (Get_Char_Code (Hex (Integer (CC and 16#0F#)))); 32161 end Encode; 32162 32163 -- Start of processing for Set_Encoded_Interface_Name 32164 32165 begin 32166 -- If first character is asterisk, this is a link name, and we leave it 32167 -- completely unmodified. We also ignore null strings (the latter case 32168 -- happens only in error cases). 32169 32170 if Len = 0 32171 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') 32172 then 32173 Set_Interface_Name (E, S); 32174 32175 else 32176 J := 1; 32177 loop 32178 CC := Get_String_Char (Str, J); 32179 32180 exit when not In_Character_Range (CC); 32181 32182 C := Get_Character (CC); 32183 32184 exit when C /= '_' and then C /= '$' 32185 and then C not in '0' .. '9' 32186 and then C not in 'a' .. 'z' 32187 and then C not in 'A' .. 'Z'; 32188 32189 if J = Len then 32190 Set_Interface_Name (E, S); 32191 return; 32192 32193 else 32194 J := J + 1; 32195 end if; 32196 end loop; 32197 32198 -- Here we need to encode. The encoding we use as follows: 32199 -- three underscores + four hex digits (lower case) 32200 32201 Start_String; 32202 32203 for J in 1 .. String_Length (Str) loop 32204 CC := Get_String_Char (Str, J); 32205 32206 if not In_Character_Range (CC) then 32207 Encode; 32208 else 32209 C := Get_Character (CC); 32210 32211 if C = '_' or else C = '$' 32212 or else C in '0' .. '9' 32213 or else C in 'a' .. 'z' 32214 or else C in 'A' .. 'Z' 32215 then 32216 Store_String_Char (CC); 32217 else 32218 Encode; 32219 end if; 32220 end if; 32221 end loop; 32222 32223 Set_Interface_Name (E, 32224 Make_String_Literal (Sloc (S), 32225 Strval => End_String)); 32226 end if; 32227 end Set_Encoded_Interface_Name; 32228 32229 ------------------------ 32230 -- Set_Elab_Unit_Name -- 32231 ------------------------ 32232 32233 procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id) is 32234 Pref : Node_Id; 32235 Scop : Entity_Id; 32236 32237 begin 32238 if Nkind (N) = N_Identifier 32239 and then Nkind (With_Item) = N_Identifier 32240 then 32241 Set_Entity (N, Entity (With_Item)); 32242 32243 elsif Nkind (N) = N_Selected_Component then 32244 Change_Selected_Component_To_Expanded_Name (N); 32245 Set_Entity (N, Entity (With_Item)); 32246 Set_Entity (Selector_Name (N), Entity (N)); 32247 32248 Pref := Prefix (N); 32249 Scop := Scope (Entity (N)); 32250 while Nkind (Pref) = N_Selected_Component loop 32251 Change_Selected_Component_To_Expanded_Name (Pref); 32252 Set_Entity (Selector_Name (Pref), Scop); 32253 Set_Entity (Pref, Scop); 32254 Pref := Prefix (Pref); 32255 Scop := Scope (Scop); 32256 end loop; 32257 32258 Set_Entity (Pref, Scop); 32259 end if; 32260 32261 Generate_Reference (Entity (With_Item), N, Set_Ref => False); 32262 end Set_Elab_Unit_Name; 32263 32264 ------------------- 32265 -- Test_Case_Arg -- 32266 ------------------- 32267 32268 function Test_Case_Arg 32269 (Prag : Node_Id; 32270 Arg_Nam : Name_Id; 32271 From_Aspect : Boolean := False) return Node_Id 32272 is 32273 Aspect : constant Node_Id := Corresponding_Aspect (Prag); 32274 Arg : Node_Id; 32275 Args : Node_Id; 32276 32277 begin 32278 pragma Assert (Nam_In (Arg_Nam, Name_Ensures, 32279 Name_Mode, 32280 Name_Name, 32281 Name_Requires)); 32282 32283 -- The caller requests the aspect argument 32284 32285 if From_Aspect then 32286 if Present (Aspect) 32287 and then Nkind (Expression (Aspect)) = N_Aggregate 32288 then 32289 Args := Expression (Aspect); 32290 32291 -- "Name" and "Mode" may appear without an identifier as a 32292 -- positional association. 32293 32294 if Present (Expressions (Args)) then 32295 Arg := First (Expressions (Args)); 32296 32297 if Present (Arg) and then Arg_Nam = Name_Name then 32298 return Arg; 32299 end if; 32300 32301 -- Skip "Name" 32302 32303 Arg := Next (Arg); 32304 32305 if Present (Arg) and then Arg_Nam = Name_Mode then 32306 return Arg; 32307 end if; 32308 end if; 32309 32310 -- Some or all arguments may appear as component associatons 32311 32312 if Present (Component_Associations (Args)) then 32313 Arg := First (Component_Associations (Args)); 32314 while Present (Arg) loop 32315 if Chars (First (Choices (Arg))) = Arg_Nam then 32316 return Arg; 32317 end if; 32318 32319 Next (Arg); 32320 end loop; 32321 end if; 32322 end if; 32323 32324 -- Otherwise retrieve the argument directly from the pragma 32325 32326 else 32327 Arg := First (Pragma_Argument_Associations (Prag)); 32328 32329 if Present (Arg) and then Arg_Nam = Name_Name then 32330 return Arg; 32331 end if; 32332 32333 -- Skip argument "Name" 32334 32335 Arg := Next (Arg); 32336 32337 if Present (Arg) and then Arg_Nam = Name_Mode then 32338 return Arg; 32339 end if; 32340 32341 -- Skip argument "Mode" 32342 32343 Arg := Next (Arg); 32344 32345 -- Arguments "Requires" and "Ensures" are optional and may not be 32346 -- present at all. 32347 32348 while Present (Arg) loop 32349 if Chars (Arg) = Arg_Nam then 32350 return Arg; 32351 end if; 32352 32353 Next (Arg); 32354 end loop; 32355 end if; 32356 32357 return Empty; 32358 end Test_Case_Arg; 32359 32360 ----------------------------------------- 32361 -- Defer_Compile_Time_Warning_Error_To_BE -- 32362 ----------------------------------------- 32363 32364 procedure Defer_Compile_Time_Warning_Error_To_BE (N : Node_Id) is 32365 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 32366 begin 32367 Compile_Time_Warnings_Errors.Append 32368 (New_Val => CTWE_Entry'(Eloc => Sloc (Arg1), 32369 Scope => Current_Scope, 32370 Prag => N)); 32371 32372 -- If the Boolean expression contains T'Size, and we're not in the main 32373 -- unit being compiled, then we need to copy the pragma into the main 32374 -- unit, because otherwise T'Size might never be computed, leaving it 32375 -- as 0. 32376 32377 if not In_Extended_Main_Code_Unit (N) then 32378 Insert_Library_Level_Action (New_Copy_Tree (N)); 32379 end if; 32380 end Defer_Compile_Time_Warning_Error_To_BE; 32381 32382 ------------------------------------------ 32383 -- Validate_Compile_Time_Warning_Errors -- 32384 ------------------------------------------ 32385 32386 procedure Validate_Compile_Time_Warning_Errors is 32387 procedure Set_Scope (S : Entity_Id); 32388 -- Install all enclosing scopes of S along with S itself 32389 32390 procedure Unset_Scope (S : Entity_Id); 32391 -- Uninstall all enclosing scopes of S along with S itself 32392 32393 --------------- 32394 -- Set_Scope -- 32395 --------------- 32396 32397 procedure Set_Scope (S : Entity_Id) is 32398 begin 32399 if S /= Standard_Standard then 32400 Set_Scope (Scope (S)); 32401 end if; 32402 32403 Push_Scope (S); 32404 end Set_Scope; 32405 32406 ----------------- 32407 -- Unset_Scope -- 32408 ----------------- 32409 32410 procedure Unset_Scope (S : Entity_Id) is 32411 begin 32412 if S /= Standard_Standard then 32413 Unset_Scope (Scope (S)); 32414 end if; 32415 32416 Pop_Scope; 32417 end Unset_Scope; 32418 32419 -- Start of processing for Validate_Compile_Time_Warning_Errors 32420 32421 begin 32422 Expander_Mode_Save_And_Set (False); 32423 In_Compile_Time_Warning_Or_Error := True; 32424 32425 for N in Compile_Time_Warnings_Errors.First .. 32426 Compile_Time_Warnings_Errors.Last 32427 loop 32428 declare 32429 T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N); 32430 32431 begin 32432 Set_Scope (T.Scope); 32433 Reset_Analyzed_Flags (T.Prag); 32434 Validate_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc); 32435 Unset_Scope (T.Scope); 32436 end; 32437 end loop; 32438 32439 In_Compile_Time_Warning_Or_Error := False; 32440 Expander_Mode_Restore; 32441 end Validate_Compile_Time_Warning_Errors; 32442 32443end Sem_Prag; 32444