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-2013, 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 Csets; use Csets; 37with Debug; use Debug; 38with Einfo; use Einfo; 39with Elists; use Elists; 40with Errout; use Errout; 41with Exp_Dist; use Exp_Dist; 42with Exp_Util; use Exp_Util; 43with Freeze; use Freeze; 44with Lib; use Lib; 45with Lib.Writ; use Lib.Writ; 46with Lib.Xref; use Lib.Xref; 47with Namet.Sp; use Namet.Sp; 48with Nlists; use Nlists; 49with Nmake; use Nmake; 50with Output; use Output; 51with Par_SCO; use Par_SCO; 52with Restrict; use Restrict; 53with Rident; use Rident; 54with Rtsfind; use Rtsfind; 55with Sem; use Sem; 56with Sem_Aux; use Sem_Aux; 57with Sem_Ch3; use Sem_Ch3; 58with Sem_Ch6; use Sem_Ch6; 59with Sem_Ch8; use Sem_Ch8; 60with Sem_Ch12; use Sem_Ch12; 61with Sem_Ch13; use Sem_Ch13; 62with Sem_Disp; use Sem_Disp; 63with Sem_Dist; use Sem_Dist; 64with Sem_Elim; use Sem_Elim; 65with Sem_Eval; use Sem_Eval; 66with Sem_Intr; use Sem_Intr; 67with Sem_Mech; use Sem_Mech; 68with Sem_Res; use Sem_Res; 69with Sem_Type; use Sem_Type; 70with Sem_Util; use Sem_Util; 71with Sem_VFpt; use Sem_VFpt; 72with Sem_Warn; use Sem_Warn; 73with Stand; use Stand; 74with Sinfo; use Sinfo; 75with Sinfo.CN; use Sinfo.CN; 76with Sinput; use Sinput; 77with Stringt; use Stringt; 78with Stylesw; use Stylesw; 79with Table; 80with Targparm; use Targparm; 81with Tbuild; use Tbuild; 82with Ttypes; 83with Uintp; use Uintp; 84with Uname; use Uname; 85with Urealp; use Urealp; 86with Validsw; use Validsw; 87with Warnsw; use Warnsw; 88 89package body Sem_Prag is 90 91 ---------------------------------------------- 92 -- Common Handling of Import-Export Pragmas -- 93 ---------------------------------------------- 94 95 -- In the following section, a number of Import_xxx and Export_xxx pragmas 96 -- are defined by GNAT. These are compatible with the DEC pragmas of the 97 -- same name, and all have the following common form and processing: 98 99 -- pragma Export_xxx 100 -- [Internal =>] LOCAL_NAME 101 -- [, [External =>] EXTERNAL_SYMBOL] 102 -- [, other optional parameters ]); 103 104 -- pragma Import_xxx 105 -- [Internal =>] LOCAL_NAME 106 -- [, [External =>] EXTERNAL_SYMBOL] 107 -- [, other optional parameters ]); 108 109 -- EXTERNAL_SYMBOL ::= 110 -- IDENTIFIER 111 -- | static_string_EXPRESSION 112 113 -- The internal LOCAL_NAME designates the entity that is imported or 114 -- exported, and must refer to an entity in the current declarative 115 -- part (as required by the rules for LOCAL_NAME). 116 117 -- The external linker name is designated by the External parameter if 118 -- given, or the Internal parameter if not (if there is no External 119 -- parameter, the External parameter is a copy of the Internal name). 120 121 -- If the External parameter is given as a string, then this string is 122 -- treated as an external name (exactly as though it had been given as an 123 -- External_Name parameter for a normal Import pragma). 124 125 -- If the External parameter is given as an identifier (or there is no 126 -- External parameter, so that the Internal identifier is used), then 127 -- the external name is the characters of the identifier, translated 128 -- to all upper case letters for OpenVMS versions of GNAT, and to all 129 -- lower case letters for all other versions 130 131 -- Note: the external name specified or implied by any of these special 132 -- Import_xxx or Export_xxx pragmas override an external or link name 133 -- specified in a previous Import or Export pragma. 134 135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of 136 -- named notation, following the standard rules for subprogram calls, i.e. 137 -- parameters can be given in any order if named notation is used, and 138 -- positional and named notation can be mixed, subject to the rule that all 139 -- positional parameters must appear first. 140 141 -- Note: All these pragmas are implemented exactly following the DEC design 142 -- and implementation and are intended to be fully compatible with the use 143 -- of these pragmas in the DEC Ada compiler. 144 145 -------------------------------------------- 146 -- Checking for Duplicated External Names -- 147 -------------------------------------------- 148 149 -- It is suspicious if two separate Export pragmas use the same external 150 -- name. The following table is used to diagnose this situation so that 151 -- an appropriate warning can be issued. 152 153 -- The Node_Id stored is for the N_String_Literal node created to hold 154 -- the value of the external name. The Sloc of this node is used to 155 -- cross-reference the location of the duplication. 156 157 package Externals is new Table.Table ( 158 Table_Component_Type => Node_Id, 159 Table_Index_Type => Int, 160 Table_Low_Bound => 0, 161 Table_Initial => 100, 162 Table_Increment => 100, 163 Table_Name => "Name_Externals"); 164 165 ------------------------------------- 166 -- Local Subprograms and Variables -- 167 ------------------------------------- 168 169 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id); 170 -- Subsidiary routine to the analysis of pragmas Depends, Global and 171 -- Refined_State. Append an entity to a list. If the list is empty, create 172 -- a new list. 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 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean; 183 -- Subsidiary to the analysis of pragma Global and pragma Depends. Query 184 -- whether a particular item appears in a mixed list of nodes and entities. 185 -- It is assumed that all nodes in the list have entities. 186 187 procedure Check_Dependence_List_Syntax (List : Node_Id); 188 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends. 189 -- Verify the syntax of dependence relation List. 190 191 procedure Check_Global_List_Syntax (List : Node_Id); 192 -- Subsidiary to the analysis of pragmas Global and Refined_Global. Verify 193 -- the syntax of global list List. 194 195 procedure Check_Item_Syntax (Item : Node_Id); 196 -- Subsidiary to the analysis of pragmas Depends, Global, Initializes, 197 -- Part_Of, Refined_Depends, Refined_Depends and Refined_State. Verify the 198 -- syntax of a SPARK annotation item. 199 200 function Check_Kind (Nam : Name_Id) return Name_Id; 201 -- This function is used in connection with pragmas Assert, Check, 202 -- and assertion aspects and pragmas, to determine if Check pragmas 203 -- (or corresponding assertion aspects or pragmas) are currently active 204 -- as determined by the presence of -gnata on the command line (which 205 -- sets the default), and the appearance of pragmas Check_Policy and 206 -- Assertion_Policy as configuration pragmas either in a configuration 207 -- pragma file, or at the start of the current unit, or locally given 208 -- Check_Policy and Assertion_Policy pragmas that are currently active. 209 -- 210 -- The value returned is one of the names Check, Ignore, Disable (On 211 -- returns Check, and Off returns Ignore). 212 -- 213 -- Note: for assertion kinds Pre'Class, Post'Class, Invariant'Class, 214 -- and Type_Invariant'Class, the name passed is Name_uPre, Name_uPost, 215 -- Name_uInvariant, or Name_uType_Invariant, which corresponds to _Pre, 216 -- _Post, _Invariant, or _Type_Invariant, which are special names used 217 -- in identifiers to represent these attribute references. 218 219 procedure Check_SPARK_Aspect_For_ASIS (N : Node_Id); 220 -- In ASIS mode we need to analyze the original expression in the aspect 221 -- specification. For Initializes, Global, and related SPARK aspects, the 222 -- expression has a sui-generis syntax which may be a list, an expression, 223 -- or an aggregate. 224 225 procedure Check_State_And_Constituent_Use 226 (States : Elist_Id; 227 Constits : Elist_Id; 228 Context : Node_Id); 229 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_] 230 -- Global and Initializes. Determine whether a state from list States and a 231 -- corresponding constituent from list Constits (if any) appear in the same 232 -- context denoted by Context. If this is the case, emit an error. 233 234 procedure Collect_Global_Items 235 (Prag : Node_Id; 236 In_Items : in out Elist_Id; 237 In_Out_Items : in out Elist_Id; 238 Out_Items : in out Elist_Id; 239 Proof_In_Items : in out Elist_Id; 240 Has_In_State : out Boolean; 241 Has_In_Out_State : out Boolean; 242 Has_Out_State : out Boolean; 243 Has_Proof_In_State : out Boolean; 244 Has_Null_State : out Boolean); 245 -- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global. 246 -- Prag denotes pragma [Refined_]Global. Gather all input, in out, output 247 -- and Proof_In items of Prag in lists In_Items, In_Out_Items, Out_Items 248 -- and Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State 249 -- and Has_Proof_In_State are set when there is at least one abstract state 250 -- with visible refinement available in the corresponding mode. Flag 251 -- Has_Null_State is set when at least state has a null refinement. 252 253 procedure Collect_Subprogram_Inputs_Outputs 254 (Subp_Id : Entity_Id; 255 Subp_Inputs : in out Elist_Id; 256 Subp_Outputs : in out Elist_Id; 257 Global_Seen : out Boolean); 258 -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends 259 -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id 260 -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram 261 -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen 262 -- is set when the related subprogram has pragma [Refined_]Global. 263 264 function Find_Related_Subprogram_Or_Body 265 (Prag : Node_Id; 266 Do_Checks : Boolean := False) return Node_Id; 267 -- Subsidiary to the analysis of pragmas Contract_Cases, Depends, Global, 268 -- Refined_Depends, Refined_Global and Refined_Post. Find the declaration 269 -- of the related subprogram [body or stub] subject to pragma Prag. If flag 270 -- Do_Checks is set, the routine reports duplicate pragmas and detects 271 -- improper use of refinement pragmas in stand alone expression functions. 272 -- The returned value depends on the related pragma as follows: 273 -- 1) Pragmas Contract_Cases, Depends and Global yield the corresponding 274 -- N_Subprogram_Declaration node or if the pragma applies to a stand 275 -- alone body, the N_Subprogram_Body node or Empty if illegal. 276 -- 2) Pragmas Refined_Depends, Refined_Global and Refined_Post yield 277 -- N_Subprogram_Body or N_Subprogram_Body_Stub nodes or Empty if 278 -- illegal. 279 280 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; 281 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the 282 -- original one, following the renaming chain) is returned. Otherwise the 283 -- entity is returned unchanged. Should be in Einfo??? 284 285 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type; 286 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram 287 -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type 288 -- SPARK_Mode_Type. 289 290 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean; 291 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends. 292 -- Determine whether dependency clause Clause is surrounded by extra 293 -- parentheses. If this is the case, issue an error message. 294 295 function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean; 296 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of 297 -- pragma Depends. Determine whether the type of dependency item Item is 298 -- tagged, unconstrained array, unconstrained record or a record with at 299 -- least one unconstrained component. 300 301 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id); 302 -- Preanalyze the boolean expressions in the Requires and Ensures arguments 303 -- of a Test_Case pragma if present (possibly Empty). We treat these as 304 -- spec expressions (i.e. similar to a default expression). 305 306 procedure Record_Possible_Body_Reference 307 (State_Id : Entity_Id; 308 Ref : Node_Id); 309 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_] 310 -- Global. Given an abstract state denoted by State_Id and a reference Ref 311 -- to it, determine whether the reference appears in a package body that 312 -- will eventually refine the state. If this is the case, record the 313 -- reference for future checks (see Analyze_Refined_State_In_Decls). 314 315 procedure Resolve_State (N : Node_Id); 316 -- Handle the overloading of state names by functions. When N denotes a 317 -- function, this routine finds the corresponding state and sets the entity 318 -- of N to that of the state. 319 320 procedure Rewrite_Assertion_Kind (N : Node_Id); 321 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class, 322 -- then it is rewritten as an identifier with the corresponding special 323 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas 324 -- Check, Check_Policy. 325 326 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id); 327 -- Place semantic information on the argument of an Elaborate/Elaborate_All 328 -- pragma. Entity name for unit and its parents is taken from item in 329 -- previous with_clause that mentions the unit. 330 331 procedure rv; 332 -- This is a dummy function called by the processing for pragma Reviewable. 333 -- It is there for assisting front end debugging. By placing a Reviewable 334 -- pragma in the source program, a breakpoint on rv catches this place in 335 -- the source, allowing convenient stepping to the point of interest. 336 337 -------------- 338 -- Add_Item -- 339 -------------- 340 341 procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is 342 begin 343 if No (To_List) then 344 To_List := New_Elmt_List; 345 end if; 346 347 Append_Elmt (Item, To_List); 348 end Add_Item; 349 350 ------------------------------- 351 -- Adjust_External_Name_Case -- 352 ------------------------------- 353 354 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is 355 CC : Char_Code; 356 357 begin 358 -- Adjust case of literal if required 359 360 if Opt.External_Name_Exp_Casing = As_Is then 361 return N; 362 363 else 364 -- Copy existing string 365 366 Start_String; 367 368 -- Set proper casing 369 370 for J in 1 .. String_Length (Strval (N)) loop 371 CC := Get_String_Char (Strval (N), J); 372 373 if Opt.External_Name_Exp_Casing = Uppercase 374 and then CC >= Get_Char_Code ('a') 375 and then CC <= Get_Char_Code ('z') 376 then 377 Store_String_Char (CC - 32); 378 379 elsif Opt.External_Name_Exp_Casing = Lowercase 380 and then CC >= Get_Char_Code ('A') 381 and then CC <= Get_Char_Code ('Z') 382 then 383 Store_String_Char (CC + 32); 384 385 else 386 Store_String_Char (CC); 387 end if; 388 end loop; 389 390 return 391 Make_String_Literal (Sloc (N), 392 Strval => End_String); 393 end if; 394 end Adjust_External_Name_Case; 395 396 ----------------------------------------- 397 -- Analyze_Contract_Cases_In_Decl_Part -- 398 ----------------------------------------- 399 400 procedure Analyze_Contract_Cases_In_Decl_Part (N : Node_Id) is 401 Others_Seen : Boolean := False; 402 403 procedure Analyze_Contract_Case (CCase : Node_Id); 404 -- Verify the legality of a single contract case 405 406 --------------------------- 407 -- Analyze_Contract_Case -- 408 --------------------------- 409 410 procedure Analyze_Contract_Case (CCase : Node_Id) is 411 Case_Guard : Node_Id; 412 Conseq : Node_Id; 413 Extra_Guard : Node_Id; 414 415 begin 416 if Nkind (CCase) = N_Component_Association then 417 Case_Guard := First (Choices (CCase)); 418 Conseq := Expression (CCase); 419 420 -- Each contract case must have exactly one case guard 421 422 Extra_Guard := Next (Case_Guard); 423 424 if Present (Extra_Guard) then 425 Error_Msg_N 426 ("contract case must have exactly one case guard", 427 Extra_Guard); 428 end if; 429 430 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1)) 431 432 if Nkind (Case_Guard) = N_Others_Choice then 433 if Others_Seen then 434 Error_Msg_N 435 ("only one others choice allowed in contract cases", 436 Case_Guard); 437 else 438 Others_Seen := True; 439 end if; 440 441 elsif Others_Seen then 442 Error_Msg_N 443 ("others must be the last choice in contract cases", N); 444 end if; 445 446 -- Preanalyze the case guard and consequence 447 448 if Nkind (Case_Guard) /= N_Others_Choice then 449 Preanalyze_Assert_Expression (Case_Guard, Standard_Boolean); 450 end if; 451 452 Preanalyze_Assert_Expression (Conseq, Standard_Boolean); 453 454 -- The contract case is malformed 455 456 else 457 Error_Msg_N ("wrong syntax in contract case", CCase); 458 end if; 459 end Analyze_Contract_Case; 460 461 -- Local variables 462 463 All_Cases : Node_Id; 464 CCase : Node_Id; 465 Subp_Decl : Node_Id; 466 Subp_Id : Entity_Id; 467 468 Restore_Scope : Boolean := False; 469 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit 470 471 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part 472 473 begin 474 Set_Analyzed (N); 475 476 Subp_Decl := Find_Related_Subprogram_Or_Body (N); 477 Subp_Id := Defining_Entity (Subp_Decl); 478 All_Cases := Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 479 480 -- Single and multiple contract cases must appear in aggregate form. If 481 -- this is not the case, then either the parser of the analysis of the 482 -- pragma failed to produce an aggregate. 483 484 pragma Assert (Nkind (All_Cases) = N_Aggregate); 485 486 if No (Component_Associations (All_Cases)) then 487 Error_Msg_N ("wrong syntax for constract cases", N); 488 489 -- Individual contract cases appear as component associations 490 491 else 492 -- Ensure that the formal parameters are visible when analyzing all 493 -- clauses. This falls out of the general rule of aspects pertaining 494 -- to subprogram declarations. Skip the installation for subprogram 495 -- bodies because the formals are already visible. 496 497 if not In_Open_Scopes (Subp_Id) then 498 Restore_Scope := True; 499 Push_Scope (Subp_Id); 500 Install_Formals (Subp_Id); 501 end if; 502 503 CCase := First (Component_Associations (All_Cases)); 504 while Present (CCase) loop 505 Analyze_Contract_Case (CCase); 506 Next (CCase); 507 end loop; 508 509 if Restore_Scope then 510 End_Scope; 511 end if; 512 end if; 513 end Analyze_Contract_Cases_In_Decl_Part; 514 515 ---------------------------------- 516 -- Analyze_Depends_In_Decl_Part -- 517 ---------------------------------- 518 519 procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is 520 Loc : constant Source_Ptr := Sloc (N); 521 522 All_Inputs_Seen : Elist_Id := No_Elist; 523 -- A list containing the entities of all the inputs processed so far. 524 -- The list is populated with unique entities because the same input 525 -- may appear in multiple input lists. 526 527 All_Outputs_Seen : Elist_Id := No_Elist; 528 -- A list containing the entities of all the outputs processed so far. 529 -- The list is populated with unique entities because output items are 530 -- unique in a dependence relation. 531 532 Constits_Seen : Elist_Id := No_Elist; 533 -- A list containing the entities of all constituents processed so far. 534 -- It aids in detecting illegal usage of a state and a corresponding 535 -- constituent in pragma [Refinde_]Depends. 536 537 Global_Seen : Boolean := False; 538 -- A flag set when pragma Global has been processed 539 540 Null_Output_Seen : Boolean := False; 541 -- A flag used to track the legality of a null output 542 543 Result_Seen : Boolean := False; 544 -- A flag set when Subp_Id'Result is processed 545 546 Spec_Id : Entity_Id; 547 -- The entity of the subprogram subject to pragma [Refined_]Depends 548 549 States_Seen : Elist_Id := No_Elist; 550 -- A list containing the entities of all states processed so far. It 551 -- helps in detecting illegal usage of a state and a corresponding 552 -- constituent in pragma [Refined_]Depends. 553 554 Subp_Id : Entity_Id; 555 -- The entity of the subprogram [body or stub] subject to pragma 556 -- [Refined_]Depends. 557 558 Subp_Inputs : Elist_Id := No_Elist; 559 Subp_Outputs : Elist_Id := No_Elist; 560 -- Two lists containing the full set of inputs and output of the related 561 -- subprograms. Note that these lists contain both nodes and entities. 562 563 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id); 564 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind 565 -- to the name buffer. The individual kinds are as follows: 566 -- E_Abstract_State - "state" 567 -- E_In_Parameter - "parameter" 568 -- E_In_Out_Parameter - "parameter" 569 -- E_Out_Parameter - "parameter" 570 -- E_Variable - "global" 571 572 procedure Analyze_Dependency_Clause 573 (Clause : Node_Id; 574 Is_Last : Boolean); 575 -- Verify the legality of a single dependency clause. Flag Is_Last 576 -- denotes whether Clause is the last clause in the relation. 577 578 procedure Check_Function_Return; 579 -- Verify that Funtion'Result appears as one of the outputs 580 -- (SPARK RM 6.1.5(10)). 581 582 procedure Check_Role 583 (Item : Node_Id; 584 Item_Id : Entity_Id; 585 Is_Input : Boolean; 586 Self_Ref : Boolean); 587 -- Ensure that an item fulfils its designated input and/or output role 588 -- as specified by pragma Global (if any) or the enclosing context. If 589 -- this is not the case, emit an error. Item and Item_Id denote the 590 -- attributes of an item. Flag Is_Input should be set when item comes 591 -- from an input list. Flag Self_Ref should be set when the item is an 592 -- output and the dependency clause has operator "+". 593 594 procedure Check_Usage 595 (Subp_Items : Elist_Id; 596 Used_Items : Elist_Id; 597 Is_Input : Boolean); 598 -- Verify that all items from Subp_Items appear in Used_Items. Emit an 599 -- error if this is not the case. 600 601 procedure Normalize_Clause (Clause : Node_Id); 602 -- Remove a self-dependency "+" from the input list of a clause. Split 603 -- a clause with multiple outputs into multiple clauses with a single 604 -- output. 605 606 ----------------------------- 607 -- Add_Item_To_Name_Buffer -- 608 ----------------------------- 609 610 procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id) is 611 begin 612 if Ekind (Item_Id) = E_Abstract_State then 613 Add_Str_To_Name_Buffer ("state"); 614 615 elsif Is_Formal (Item_Id) then 616 Add_Str_To_Name_Buffer ("parameter"); 617 618 elsif Ekind (Item_Id) = E_Variable then 619 Add_Str_To_Name_Buffer ("global"); 620 621 -- The routine should not be called with non-SPARK items 622 623 else 624 raise Program_Error; 625 end if; 626 end Add_Item_To_Name_Buffer; 627 628 ------------------------------- 629 -- Analyze_Dependency_Clause -- 630 ------------------------------- 631 632 procedure Analyze_Dependency_Clause 633 (Clause : Node_Id; 634 Is_Last : Boolean) 635 is 636 procedure Analyze_Input_List (Inputs : Node_Id); 637 -- Verify the legality of a single input list 638 639 procedure Analyze_Input_Output 640 (Item : Node_Id; 641 Is_Input : Boolean; 642 Self_Ref : Boolean; 643 Top_Level : Boolean; 644 Seen : in out Elist_Id; 645 Null_Seen : in out Boolean; 646 Non_Null_Seen : in out Boolean); 647 -- Verify the legality of a single input or output item. Flag 648 -- Is_Input should be set whenever Item is an input, False when it 649 -- denotes an output. Flag Self_Ref should be set when the item is an 650 -- output and the dependency clause has a "+". Flag Top_Level should 651 -- be set whenever Item appears immediately within an input or output 652 -- list. Seen is a collection of all abstract states, variables and 653 -- formals processed so far. Flag Null_Seen denotes whether a null 654 -- input or output has been encountered. Flag Non_Null_Seen denotes 655 -- whether a non-null input or output has been encountered. 656 657 ------------------------ 658 -- Analyze_Input_List -- 659 ------------------------ 660 661 procedure Analyze_Input_List (Inputs : Node_Id) is 662 Inputs_Seen : Elist_Id := No_Elist; 663 -- A list containing the entities of all inputs that appear in the 664 -- current input list. 665 666 Non_Null_Input_Seen : Boolean := False; 667 Null_Input_Seen : Boolean := False; 668 -- Flags used to check the legality of an input list 669 670 Input : Node_Id; 671 672 begin 673 -- Multiple inputs appear as an aggregate 674 675 if Nkind (Inputs) = N_Aggregate then 676 if Present (Component_Associations (Inputs)) then 677 Error_Msg_N 678 ("nested dependency relations not allowed", Inputs); 679 680 elsif Present (Expressions (Inputs)) then 681 Input := First (Expressions (Inputs)); 682 while Present (Input) loop 683 Analyze_Input_Output 684 (Item => Input, 685 Is_Input => True, 686 Self_Ref => False, 687 Top_Level => False, 688 Seen => Inputs_Seen, 689 Null_Seen => Null_Input_Seen, 690 Non_Null_Seen => Non_Null_Input_Seen); 691 692 Next (Input); 693 end loop; 694 695 else 696 Error_Msg_N ("malformed input dependency list", Inputs); 697 end if; 698 699 -- Process a solitary input 700 701 else 702 Analyze_Input_Output 703 (Item => Inputs, 704 Is_Input => True, 705 Self_Ref => False, 706 Top_Level => False, 707 Seen => Inputs_Seen, 708 Null_Seen => Null_Input_Seen, 709 Non_Null_Seen => Non_Null_Input_Seen); 710 end if; 711 712 -- Detect an illegal dependency clause of the form 713 714 -- (null =>[+] null) 715 716 if Null_Output_Seen and then Null_Input_Seen then 717 Error_Msg_N 718 ("null dependency clause cannot have a null input list", 719 Inputs); 720 end if; 721 end Analyze_Input_List; 722 723 -------------------------- 724 -- Analyze_Input_Output -- 725 -------------------------- 726 727 procedure Analyze_Input_Output 728 (Item : Node_Id; 729 Is_Input : Boolean; 730 Self_Ref : Boolean; 731 Top_Level : Boolean; 732 Seen : in out Elist_Id; 733 Null_Seen : in out Boolean; 734 Non_Null_Seen : in out Boolean) 735 is 736 Is_Output : constant Boolean := not Is_Input; 737 Grouped : Node_Id; 738 Item_Id : Entity_Id; 739 740 begin 741 -- Multiple input or output items appear as an aggregate 742 743 if Nkind (Item) = N_Aggregate then 744 if not Top_Level then 745 Error_Msg_N ("nested grouping of items not allowed", Item); 746 747 elsif Present (Component_Associations (Item)) then 748 Error_Msg_N 749 ("nested dependency relations not allowed", Item); 750 751 -- Recursively analyze the grouped items 752 753 elsif Present (Expressions (Item)) then 754 Grouped := First (Expressions (Item)); 755 while Present (Grouped) loop 756 Analyze_Input_Output 757 (Item => Grouped, 758 Is_Input => Is_Input, 759 Self_Ref => Self_Ref, 760 Top_Level => False, 761 Seen => Seen, 762 Null_Seen => Null_Seen, 763 Non_Null_Seen => Non_Null_Seen); 764 765 Next (Grouped); 766 end loop; 767 768 else 769 Error_Msg_N ("malformed dependency list", Item); 770 end if; 771 772 -- Process Function'Result in the context of a dependency clause 773 774 elsif Is_Attribute_Result (Item) then 775 Non_Null_Seen := True; 776 777 -- It is sufficent to analyze the prefix of 'Result in order to 778 -- establish legality of the attribute. 779 780 Analyze (Prefix (Item)); 781 782 -- The prefix of 'Result must denote the function for which 783 -- pragma Depends applies (SPARK RM 6.1.5(11)). 784 785 if not Is_Entity_Name (Prefix (Item)) 786 or else Ekind (Spec_Id) /= E_Function 787 or else Entity (Prefix (Item)) /= Spec_Id 788 then 789 Error_Msg_Name_1 := Name_Result; 790 Error_Msg_N 791 ("prefix of attribute % must denote the enclosing " 792 & "function", Item); 793 794 -- Function'Result is allowed to appear on the output side of a 795 -- dependency clause (SPARK RM 6.1.5(6)). 796 797 elsif Is_Input then 798 Error_Msg_N ("function result cannot act as input", Item); 799 800 elsif Null_Seen then 801 Error_Msg_N 802 ("cannot mix null and non-null dependency items", Item); 803 804 else 805 Result_Seen := True; 806 end if; 807 808 -- Detect multiple uses of null in a single dependency list or 809 -- throughout the whole relation. Verify the placement of a null 810 -- output list relative to the other clauses (SPARK RM 6.1.5(12)). 811 812 elsif Nkind (Item) = N_Null then 813 if Null_Seen then 814 Error_Msg_N 815 ("multiple null dependency relations not allowed", Item); 816 817 elsif Non_Null_Seen then 818 Error_Msg_N 819 ("cannot mix null and non-null dependency items", Item); 820 821 else 822 Null_Seen := True; 823 824 if Is_Output then 825 if not Is_Last then 826 Error_Msg_N 827 ("null output list must be the last clause in a " 828 & "dependency relation", Item); 829 830 -- Catch a useless dependence of the form: 831 -- null =>+ ... 832 833 elsif Self_Ref then 834 Error_Msg_N 835 ("useless dependence, null depends on itself", Item); 836 end if; 837 end if; 838 end if; 839 840 -- Default case 841 842 else 843 Non_Null_Seen := True; 844 845 if Null_Seen then 846 Error_Msg_N ("cannot mix null and non-null items", Item); 847 end if; 848 849 Analyze (Item); 850 Resolve_State (Item); 851 852 -- Find the entity of the item. If this is a renaming, climb 853 -- the renaming chain to reach the root object. Renamings of 854 -- non-entire objects do not yield an entity (Empty). 855 856 Item_Id := Entity_Of (Item); 857 858 if Present (Item_Id) then 859 if Ekind_In (Item_Id, E_Abstract_State, 860 E_In_Parameter, 861 E_In_Out_Parameter, 862 E_Out_Parameter, 863 E_Variable) 864 then 865 -- Ensure that the item fulfils its role as input and/or 866 -- output as specified by pragma Global or the enclosing 867 -- context. 868 869 Check_Role (Item, Item_Id, Is_Input, Self_Ref); 870 871 -- Detect multiple uses of the same state, variable or 872 -- formal parameter. If this is not the case, add the 873 -- item to the list of processed relations. 874 875 if Contains (Seen, Item_Id) then 876 Error_Msg_NE 877 ("duplicate use of item &", Item, Item_Id); 878 else 879 Add_Item (Item_Id, Seen); 880 end if; 881 882 -- Detect illegal use of an input related to a null 883 -- output. Such input items cannot appear in other 884 -- input lists (SPARK RM 6.1.5(13)). 885 886 if Is_Input 887 and then Null_Output_Seen 888 and then Contains (All_Inputs_Seen, Item_Id) 889 then 890 Error_Msg_N 891 ("input of a null output list cannot appear in " 892 & "multiple input lists", Item); 893 end if; 894 895 -- Add an input or a self-referential output to the list 896 -- of all processed inputs. 897 898 if Is_Input or else Self_Ref then 899 Add_Item (Item_Id, All_Inputs_Seen); 900 end if; 901 902 -- State related checks (SPARK RM 6.1.5(3)) 903 904 if Ekind (Item_Id) = E_Abstract_State then 905 if Has_Visible_Refinement (Item_Id) then 906 Error_Msg_NE 907 ("cannot mention state & in global refinement", 908 Item, Item_Id); 909 Error_Msg_N 910 ("\use its constituents instead", Item); 911 return; 912 913 -- If the reference to the abstract state appears in 914 -- an enclosing package body that will eventually 915 -- refine the state, record the reference for future 916 -- checks. 917 918 else 919 Record_Possible_Body_Reference 920 (State_Id => Item_Id, 921 Ref => Item); 922 end if; 923 end if; 924 925 -- When the item renames an entire object, replace the 926 -- item with a reference to the object. 927 928 if Present (Renamed_Object (Entity (Item))) then 929 Rewrite (Item, 930 New_Occurrence_Of (Item_Id, Sloc (Item))); 931 Analyze (Item); 932 end if; 933 934 -- Add the entity of the current item to the list of 935 -- processed items. 936 937 if Ekind (Item_Id) = E_Abstract_State then 938 Add_Item (Item_Id, States_Seen); 939 end if; 940 941 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) 942 and then Present (Encapsulating_State (Item_Id)) 943 then 944 Add_Item (Item_Id, Constits_Seen); 945 end if; 946 947 -- All other input/output items are illegal 948 -- (SPARK RM 6.1.5(1)). 949 950 else 951 Error_Msg_N 952 ("item must denote parameter, variable, or state", 953 Item); 954 end if; 955 956 -- All other input/output items are illegal 957 -- (SPARK RM 6.1.5(1)) 958 959 else 960 Error_Msg_N 961 ("item must denote parameter, variable, or state", 962 Item); 963 end if; 964 end if; 965 end Analyze_Input_Output; 966 967 -- Local variables 968 969 Inputs : Node_Id; 970 Output : Node_Id; 971 Self_Ref : Boolean; 972 973 Non_Null_Output_Seen : Boolean := False; 974 -- Flag used to check the legality of an output list 975 976 -- Start of processing for Analyze_Dependency_Clause 977 978 begin 979 Inputs := Expression (Clause); 980 Self_Ref := False; 981 982 -- An input list with a self-dependency appears as operator "+" where 983 -- the actuals inputs are the right operand. 984 985 if Nkind (Inputs) = N_Op_Plus then 986 Inputs := Right_Opnd (Inputs); 987 Self_Ref := True; 988 end if; 989 990 -- Process the output_list of a dependency_clause 991 992 Output := First (Choices (Clause)); 993 while Present (Output) loop 994 Analyze_Input_Output 995 (Item => Output, 996 Is_Input => False, 997 Self_Ref => Self_Ref, 998 Top_Level => True, 999 Seen => All_Outputs_Seen, 1000 Null_Seen => Null_Output_Seen, 1001 Non_Null_Seen => Non_Null_Output_Seen); 1002 1003 Next (Output); 1004 end loop; 1005 1006 -- Process the input_list of a dependency_clause 1007 1008 Analyze_Input_List (Inputs); 1009 end Analyze_Dependency_Clause; 1010 1011 --------------------------- 1012 -- Check_Function_Return -- 1013 --------------------------- 1014 1015 procedure Check_Function_Return is 1016 begin 1017 if Ekind (Spec_Id) = E_Function and then not Result_Seen then 1018 Error_Msg_NE 1019 ("result of & must appear in exactly one output list", 1020 N, Spec_Id); 1021 end if; 1022 end Check_Function_Return; 1023 1024 ---------------- 1025 -- Check_Role -- 1026 ---------------- 1027 1028 procedure Check_Role 1029 (Item : Node_Id; 1030 Item_Id : Entity_Id; 1031 Is_Input : Boolean; 1032 Self_Ref : Boolean) 1033 is 1034 procedure Find_Role 1035 (Item_Is_Input : out Boolean; 1036 Item_Is_Output : out Boolean); 1037 -- Find the input/output role of Item_Id. Flags Item_Is_Input and 1038 -- Item_Is_Output are set depending on the role. 1039 1040 procedure Role_Error 1041 (Item_Is_Input : Boolean; 1042 Item_Is_Output : Boolean); 1043 -- Emit an error message concerning the incorrect use of Item in 1044 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output 1045 -- denote whether the item is an input and/or an output. 1046 1047 --------------- 1048 -- Find_Role -- 1049 --------------- 1050 1051 procedure Find_Role 1052 (Item_Is_Input : out Boolean; 1053 Item_Is_Output : out Boolean) 1054 is 1055 begin 1056 Item_Is_Input := False; 1057 Item_Is_Output := False; 1058 1059 -- Abstract state cases 1060 1061 if Ekind (Item_Id) = E_Abstract_State then 1062 1063 -- When pragma Global is present, the mode of the state may be 1064 -- further constrained by setting a more restrictive mode. 1065 1066 if Global_Seen then 1067 if Appears_In (Subp_Inputs, Item_Id) then 1068 Item_Is_Input := True; 1069 end if; 1070 1071 if Appears_In (Subp_Outputs, Item_Id) then 1072 Item_Is_Output := True; 1073 end if; 1074 1075 -- Otherwise the state has a default IN OUT mode 1076 1077 else 1078 Item_Is_Input := True; 1079 Item_Is_Output := True; 1080 end if; 1081 1082 -- Parameter cases 1083 1084 elsif Ekind (Item_Id) = E_In_Parameter then 1085 Item_Is_Input := True; 1086 1087 elsif Ekind (Item_Id) = E_In_Out_Parameter then 1088 Item_Is_Input := True; 1089 Item_Is_Output := True; 1090 1091 elsif Ekind (Item_Id) = E_Out_Parameter then 1092 if Scope (Item_Id) = Spec_Id then 1093 1094 -- An OUT parameter of the related subprogram has mode IN 1095 -- if its type is unconstrained or tagged because array 1096 -- bounds, discriminants or tags can be read. 1097 1098 if Is_Unconstrained_Or_Tagged_Item (Item_Id) then 1099 Item_Is_Input := True; 1100 end if; 1101 1102 Item_Is_Output := True; 1103 1104 -- An OUT parameter of an enclosing subprogram behaves as a 1105 -- read-write variable in which case the mode is IN OUT. 1106 1107 else 1108 Item_Is_Input := True; 1109 Item_Is_Output := True; 1110 end if; 1111 1112 -- Variable cases 1113 1114 else pragma Assert (Ekind (Item_Id) = E_Variable); 1115 1116 -- When pragma Global is present, the mode of the variable may 1117 -- be further constrained by setting a more restrictive mode. 1118 1119 if Global_Seen then 1120 1121 -- A variable has mode IN when its type is unconstrained or 1122 -- tagged because array bounds, discriminants or tags can be 1123 -- read. 1124 1125 if Appears_In (Subp_Inputs, Item_Id) 1126 or else Is_Unconstrained_Or_Tagged_Item (Item_Id) 1127 then 1128 Item_Is_Input := True; 1129 end if; 1130 1131 if Appears_In (Subp_Outputs, Item_Id) then 1132 Item_Is_Output := True; 1133 end if; 1134 1135 -- Otherwise the variable has a default IN OUT mode 1136 1137 else 1138 Item_Is_Input := True; 1139 Item_Is_Output := True; 1140 end if; 1141 end if; 1142 end Find_Role; 1143 1144 ---------------- 1145 -- Role_Error -- 1146 ---------------- 1147 1148 procedure Role_Error 1149 (Item_Is_Input : Boolean; 1150 Item_Is_Output : Boolean) 1151 is 1152 Error_Msg : Name_Id; 1153 1154 begin 1155 Name_Len := 0; 1156 1157 -- When the item is not part of the input and the output set of 1158 -- the related subprogram, then it appears as extra in pragma 1159 -- [Refined_]Depends. 1160 1161 if not Item_Is_Input and then not Item_Is_Output then 1162 Add_Item_To_Name_Buffer (Item_Id); 1163 Add_Str_To_Name_Buffer 1164 (" & cannot appear in dependence relation"); 1165 1166 Error_Msg := Name_Find; 1167 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1168 1169 Error_Msg_Name_1 := Chars (Subp_Id); 1170 Error_Msg_NE 1171 ("\& is not part of the input or output set of subprogram %", 1172 Item, Item_Id); 1173 1174 -- The mode of the item and its role in pragma [Refined_]Depends 1175 -- are in conflict. Construct a detailed message explaining the 1176 -- illegality (SPARK RM 6.1.5(5-6)). 1177 1178 else 1179 if Item_Is_Input then 1180 Add_Str_To_Name_Buffer ("read-only"); 1181 else 1182 Add_Str_To_Name_Buffer ("write-only"); 1183 end if; 1184 1185 Add_Char_To_Name_Buffer (' '); 1186 Add_Item_To_Name_Buffer (Item_Id); 1187 Add_Str_To_Name_Buffer (" & cannot appear as "); 1188 1189 if Item_Is_Input then 1190 Add_Str_To_Name_Buffer ("output"); 1191 else 1192 Add_Str_To_Name_Buffer ("input"); 1193 end if; 1194 1195 Add_Str_To_Name_Buffer (" in dependence relation"); 1196 Error_Msg := Name_Find; 1197 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1198 end if; 1199 end Role_Error; 1200 1201 -- Local variables 1202 1203 Item_Is_Input : Boolean; 1204 Item_Is_Output : Boolean; 1205 1206 -- Start of processing for Check_Role 1207 1208 begin 1209 Find_Role (Item_Is_Input, Item_Is_Output); 1210 1211 -- Input item 1212 1213 if Is_Input then 1214 if not Item_Is_Input then 1215 Role_Error (Item_Is_Input, Item_Is_Output); 1216 end if; 1217 1218 -- Self-referential item 1219 1220 elsif Self_Ref then 1221 if not Item_Is_Input or else not Item_Is_Output then 1222 Role_Error (Item_Is_Input, Item_Is_Output); 1223 end if; 1224 1225 -- Output item 1226 1227 elsif not Item_Is_Output then 1228 Role_Error (Item_Is_Input, Item_Is_Output); 1229 end if; 1230 end Check_Role; 1231 1232 ----------------- 1233 -- Check_Usage -- 1234 ----------------- 1235 1236 procedure Check_Usage 1237 (Subp_Items : Elist_Id; 1238 Used_Items : Elist_Id; 1239 Is_Input : Boolean) 1240 is 1241 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id); 1242 -- Emit an error concerning the erroneous usage of an item 1243 1244 ----------------- 1245 -- Usage_Error -- 1246 ----------------- 1247 1248 procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is 1249 Error_Msg : Name_Id; 1250 1251 begin 1252 -- Input case 1253 1254 if Is_Input then 1255 1256 -- Unconstrained and tagged items are not part of the explicit 1257 -- input set of the related subprogram, they do not have to be 1258 -- present in a dependence relation and should not be flagged 1259 -- (SPARK RM 6.1.5(8)). 1260 1261 if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then 1262 Name_Len := 0; 1263 1264 Add_Item_To_Name_Buffer (Item_Id); 1265 Add_Str_To_Name_Buffer 1266 (" & must appear in at least one input dependence list"); 1267 1268 Error_Msg := Name_Find; 1269 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1270 end if; 1271 1272 -- Output case (SPARK RM 6.1.5(10)) 1273 1274 else 1275 Name_Len := 0; 1276 1277 Add_Item_To_Name_Buffer (Item_Id); 1278 Add_Str_To_Name_Buffer 1279 (" & must appear in exactly one output dependence list"); 1280 1281 Error_Msg := Name_Find; 1282 Error_Msg_NE (Get_Name_String (Error_Msg), Item, Item_Id); 1283 end if; 1284 end Usage_Error; 1285 1286 -- Local variables 1287 1288 Elmt : Elmt_Id; 1289 Item : Node_Id; 1290 Item_Id : Entity_Id; 1291 1292 -- Start of processing for Check_Usage 1293 1294 begin 1295 if No (Subp_Items) then 1296 return; 1297 end if; 1298 1299 -- Each input or output of the subprogram must appear in a dependency 1300 -- relation. 1301 1302 Elmt := First_Elmt (Subp_Items); 1303 while Present (Elmt) loop 1304 Item := Node (Elmt); 1305 1306 if Nkind (Item) = N_Defining_Identifier then 1307 Item_Id := Item; 1308 else 1309 Item_Id := Entity_Of (Item); 1310 end if; 1311 1312 -- The item does not appear in a dependency 1313 1314 if Present (Item_Id) 1315 and then not Contains (Used_Items, Item_Id) 1316 then 1317 if Is_Formal (Item_Id) then 1318 Usage_Error (Item, Item_Id); 1319 1320 -- States and global variables are not used properly only when 1321 -- the subprogram is subject to pragma Global. 1322 1323 elsif Global_Seen then 1324 Usage_Error (Item, Item_Id); 1325 end if; 1326 end if; 1327 1328 Next_Elmt (Elmt); 1329 end loop; 1330 end Check_Usage; 1331 1332 ---------------------- 1333 -- Normalize_Clause -- 1334 ---------------------- 1335 1336 procedure Normalize_Clause (Clause : Node_Id) is 1337 procedure Create_Or_Modify_Clause 1338 (Output : Node_Id; 1339 Outputs : Node_Id; 1340 Inputs : Node_Id; 1341 After : Node_Id; 1342 In_Place : Boolean; 1343 Multiple : Boolean); 1344 -- Create a brand new clause to represent the self-reference or 1345 -- modify the input and/or output lists of an existing clause. Output 1346 -- denotes a self-referencial output. Outputs is the output list of a 1347 -- clause. Inputs is the input list of a clause. After denotes the 1348 -- clause after which the new clause is to be inserted. Flag In_Place 1349 -- should be set when normalizing the last output of an output list. 1350 -- Flag Multiple should be set when Output comes from a list with 1351 -- multiple items. 1352 1353 procedure Split_Multiple_Outputs; 1354 -- If Clause contains more than one output, split the clause into 1355 -- multiple clauses with a single output. All new clauses are added 1356 -- after Clause. 1357 1358 ----------------------------- 1359 -- Create_Or_Modify_Clause -- 1360 ----------------------------- 1361 1362 procedure Create_Or_Modify_Clause 1363 (Output : Node_Id; 1364 Outputs : Node_Id; 1365 Inputs : Node_Id; 1366 After : Node_Id; 1367 In_Place : Boolean; 1368 Multiple : Boolean) 1369 is 1370 procedure Propagate_Output 1371 (Output : Node_Id; 1372 Inputs : Node_Id); 1373 -- Handle the various cases of output propagation to the input 1374 -- list. Output denotes a self-referencial output item. Inputs is 1375 -- the input list of a clause. 1376 1377 ---------------------- 1378 -- Propagate_Output -- 1379 ---------------------- 1380 1381 procedure Propagate_Output 1382 (Output : Node_Id; 1383 Inputs : Node_Id) 1384 is 1385 function In_Input_List 1386 (Item : Entity_Id; 1387 Inputs : List_Id) return Boolean; 1388 -- Determine whether a particulat item appears in the input 1389 -- list of a clause. 1390 1391 ------------------- 1392 -- In_Input_List -- 1393 ------------------- 1394 1395 function In_Input_List 1396 (Item : Entity_Id; 1397 Inputs : List_Id) return Boolean 1398 is 1399 Elmt : Node_Id; 1400 1401 begin 1402 Elmt := First (Inputs); 1403 while Present (Elmt) loop 1404 if Entity_Of (Elmt) = Item then 1405 return True; 1406 end if; 1407 1408 Next (Elmt); 1409 end loop; 1410 1411 return False; 1412 end In_Input_List; 1413 1414 -- Local variables 1415 1416 Output_Id : constant Entity_Id := Entity_Of (Output); 1417 Grouped : List_Id; 1418 1419 -- Start of processing for Propagate_Output 1420 1421 begin 1422 -- The clause is of the form: 1423 1424 -- (Output =>+ null) 1425 1426 -- Remove the null input and replace it with a copy of the 1427 -- output: 1428 1429 -- (Output => Output) 1430 1431 if Nkind (Inputs) = N_Null then 1432 Rewrite (Inputs, New_Copy_Tree (Output)); 1433 1434 -- The clause is of the form: 1435 1436 -- (Output =>+ (Input1, ..., InputN)) 1437 1438 -- Determine whether the output is not already mentioned in the 1439 -- input list and if not, add it to the list of inputs: 1440 1441 -- (Output => (Output, Input1, ..., InputN)) 1442 1443 elsif Nkind (Inputs) = N_Aggregate then 1444 Grouped := Expressions (Inputs); 1445 1446 if not In_Input_List 1447 (Item => Output_Id, 1448 Inputs => Grouped) 1449 then 1450 Prepend_To (Grouped, New_Copy_Tree (Output)); 1451 end if; 1452 1453 -- The clause is of the form: 1454 1455 -- (Output =>+ Input) 1456 1457 -- If the input does not mention the output, group the two 1458 -- together: 1459 1460 -- (Output => (Output, Input)) 1461 1462 elsif Entity_Of (Inputs) /= Output_Id then 1463 Rewrite (Inputs, 1464 Make_Aggregate (Loc, 1465 Expressions => New_List ( 1466 New_Copy_Tree (Output), 1467 New_Copy_Tree (Inputs)))); 1468 end if; 1469 end Propagate_Output; 1470 1471 -- Local variables 1472 1473 Loc : constant Source_Ptr := Sloc (Clause); 1474 New_Clause : Node_Id; 1475 1476 -- Start of processing for Create_Or_Modify_Clause 1477 1478 begin 1479 -- A null output depending on itself does not require any 1480 -- normalization. 1481 1482 if Nkind (Output) = N_Null then 1483 return; 1484 1485 -- A function result cannot depend on itself because it cannot 1486 -- appear in the input list of a relation (SPARK RM 6.1.5(10)). 1487 1488 elsif Is_Attribute_Result (Output) then 1489 Error_Msg_N ("function result cannot depend on itself", Output); 1490 return; 1491 end if; 1492 1493 -- When performing the transformation in place, simply add the 1494 -- output to the list of inputs (if not already there). This case 1495 -- arises when dealing with the last output of an output list - 1496 -- we perform the normalization in place to avoid generating a 1497 -- malformed tree. 1498 1499 if In_Place then 1500 Propagate_Output (Output, Inputs); 1501 1502 -- A list with multiple outputs is slowly trimmed until only 1503 -- one element remains. When this happens, replace the 1504 -- aggregate with the element itself. 1505 1506 if Multiple then 1507 Remove (Output); 1508 Rewrite (Outputs, Output); 1509 end if; 1510 1511 -- Default case 1512 1513 else 1514 -- Unchain the output from its output list as it will appear in 1515 -- a new clause. Note that we cannot simply rewrite the output 1516 -- as null because this will violate the semantics of pragma 1517 -- Depends. 1518 1519 Remove (Output); 1520 1521 -- Generate a new clause of the form: 1522 -- (Output => Inputs) 1523 1524 New_Clause := 1525 Make_Component_Association (Loc, 1526 Choices => New_List (Output), 1527 Expression => New_Copy_Tree (Inputs)); 1528 1529 -- The new clause contains replicated content that has already 1530 -- been analyzed. There is not need to reanalyze it or 1531 -- renormalize it again. 1532 1533 Set_Analyzed (New_Clause); 1534 1535 Propagate_Output 1536 (Output => First (Choices (New_Clause)), 1537 Inputs => Expression (New_Clause)); 1538 1539 Insert_After (After, New_Clause); 1540 end if; 1541 end Create_Or_Modify_Clause; 1542 1543 ---------------------------- 1544 -- Split_Multiple_Outputs -- 1545 ---------------------------- 1546 1547 procedure Split_Multiple_Outputs is 1548 Inputs : constant Node_Id := Expression (Clause); 1549 Loc : constant Source_Ptr := Sloc (Clause); 1550 Outputs : constant Node_Id := First (Choices (Clause)); 1551 Last_Output : Node_Id; 1552 Next_Output : Node_Id; 1553 Output : Node_Id; 1554 Split : Node_Id; 1555 1556 -- Start of processing for Split_Multiple_Outputs 1557 1558 begin 1559 -- Multiple outputs appear as an aggregate. Nothing to do when 1560 -- the clause has exactly one output. 1561 1562 if Nkind (Outputs) = N_Aggregate then 1563 Last_Output := Last (Expressions (Outputs)); 1564 1565 -- Create a clause for each output. Note that each time a new 1566 -- clause is created, the original output list slowly shrinks 1567 -- until there is one item left. 1568 1569 Output := First (Expressions (Outputs)); 1570 while Present (Output) loop 1571 Next_Output := Next (Output); 1572 1573 -- Unhook the output from the original output list as it 1574 -- will be relocated to a new clause. 1575 1576 Remove (Output); 1577 1578 -- Special processing for the last output. At this point 1579 -- the original aggregate has been stripped down to one 1580 -- element. Replace the aggregate by the element itself. 1581 1582 if Output = Last_Output then 1583 Rewrite (Outputs, Output); 1584 1585 else 1586 -- Generate a clause of the form: 1587 -- (Output => Inputs) 1588 1589 Split := 1590 Make_Component_Association (Loc, 1591 Choices => New_List (Output), 1592 Expression => New_Copy_Tree (Inputs)); 1593 1594 -- The new clause contains replicated content that has 1595 -- already been analyzed. There is not need to reanalyze 1596 -- them. 1597 1598 Set_Analyzed (Split); 1599 Insert_After (Clause, Split); 1600 end if; 1601 1602 Output := Next_Output; 1603 end loop; 1604 end if; 1605 end Split_Multiple_Outputs; 1606 1607 -- Local variables 1608 1609 Outputs : constant Node_Id := First (Choices (Clause)); 1610 Inputs : Node_Id; 1611 Last_Output : Node_Id; 1612 Next_Output : Node_Id; 1613 Output : Node_Id; 1614 1615 -- Start of processing for Normalize_Clause 1616 1617 begin 1618 -- A self-dependency appears as operator "+". Remove the "+" from the 1619 -- tree by moving the real inputs to their proper place. 1620 1621 if Nkind (Expression (Clause)) = N_Op_Plus then 1622 Rewrite (Expression (Clause), Right_Opnd (Expression (Clause))); 1623 Inputs := Expression (Clause); 1624 1625 -- Multiple outputs appear as an aggregate 1626 1627 if Nkind (Outputs) = N_Aggregate then 1628 Last_Output := Last (Expressions (Outputs)); 1629 1630 Output := First (Expressions (Outputs)); 1631 while Present (Output) loop 1632 1633 -- Normalization may remove an output from its list, 1634 -- preserve the subsequent output now. 1635 1636 Next_Output := Next (Output); 1637 1638 Create_Or_Modify_Clause 1639 (Output => Output, 1640 Outputs => Outputs, 1641 Inputs => Inputs, 1642 After => Clause, 1643 In_Place => Output = Last_Output, 1644 Multiple => True); 1645 1646 Output := Next_Output; 1647 end loop; 1648 1649 -- Solitary output 1650 1651 else 1652 Create_Or_Modify_Clause 1653 (Output => Outputs, 1654 Outputs => Empty, 1655 Inputs => Inputs, 1656 After => Empty, 1657 In_Place => True, 1658 Multiple => False); 1659 end if; 1660 end if; 1661 1662 -- Split a clause with multiple outputs into multiple clauses with a 1663 -- single output. 1664 1665 Split_Multiple_Outputs; 1666 end Normalize_Clause; 1667 1668 -- Local variables 1669 1670 Deps : constant Node_Id := 1671 Get_Pragma_Arg 1672 (First (Pragma_Argument_Associations (N))); 1673 Clause : Node_Id; 1674 Errors : Nat; 1675 Last_Clause : Node_Id; 1676 Subp_Decl : Node_Id; 1677 1678 Restore_Scope : Boolean := False; 1679 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit 1680 1681 -- Start of processing for Analyze_Depends_In_Decl_Part 1682 1683 begin 1684 Set_Analyzed (N); 1685 1686 -- Verify the syntax of pragma Depends when SPARK checks are suppressed. 1687 -- Semantic analysis and normalization are disabled in this mode. 1688 1689 if SPARK_Mode = Off then 1690 Check_Dependence_List_Syntax (Deps); 1691 return; 1692 end if; 1693 1694 Subp_Decl := Find_Related_Subprogram_Or_Body (N); 1695 Subp_Id := Defining_Entity (Subp_Decl); 1696 1697 -- The logic in this routine is used to analyze both pragma Depends and 1698 -- pragma Refined_Depends since they have the same syntax and base 1699 -- semantics. Find the entity of the corresponding spec when analyzing 1700 -- Refined_Depends. 1701 1702 if Nkind (Subp_Decl) = N_Subprogram_Body 1703 and then not Acts_As_Spec (Subp_Decl) 1704 then 1705 Spec_Id := Corresponding_Spec (Subp_Decl); 1706 1707 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then 1708 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 1709 1710 else 1711 Spec_Id := Subp_Id; 1712 end if; 1713 1714 -- Empty dependency list 1715 1716 if Nkind (Deps) = N_Null then 1717 1718 -- Gather all states, variables and formal parameters that the 1719 -- subprogram may depend on. These items are obtained from the 1720 -- parameter profile or pragma [Refined_]Global (if available). 1721 1722 Collect_Subprogram_Inputs_Outputs 1723 (Subp_Id => Subp_Id, 1724 Subp_Inputs => Subp_Inputs, 1725 Subp_Outputs => Subp_Outputs, 1726 Global_Seen => Global_Seen); 1727 1728 -- Verify that every input or output of the subprogram appear in a 1729 -- dependency. 1730 1731 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 1732 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 1733 Check_Function_Return; 1734 1735 -- Dependency clauses appear as component associations of an aggregate 1736 1737 elsif Nkind (Deps) = N_Aggregate then 1738 1739 -- Do not attempt to perform analysis of a syntactically illegal 1740 -- clause as this will lead to misleading errors. 1741 1742 if Has_Extra_Parentheses (Deps) then 1743 return; 1744 end if; 1745 1746 if Present (Component_Associations (Deps)) then 1747 Last_Clause := Last (Component_Associations (Deps)); 1748 1749 -- Gather all states, variables and formal parameters that the 1750 -- subprogram may depend on. These items are obtained from the 1751 -- parameter profile or pragma [Refined_]Global (if available). 1752 1753 Collect_Subprogram_Inputs_Outputs 1754 (Subp_Id => Subp_Id, 1755 Subp_Inputs => Subp_Inputs, 1756 Subp_Outputs => Subp_Outputs, 1757 Global_Seen => Global_Seen); 1758 1759 -- Ensure that the formal parameters are visible when analyzing 1760 -- all clauses. This falls out of the general rule of aspects 1761 -- pertaining to subprogram declarations. Skip the installation 1762 -- for subprogram bodies because the formals are already visible. 1763 1764 if not In_Open_Scopes (Spec_Id) then 1765 Restore_Scope := True; 1766 Push_Scope (Spec_Id); 1767 Install_Formals (Spec_Id); 1768 end if; 1769 1770 Clause := First (Component_Associations (Deps)); 1771 while Present (Clause) loop 1772 Errors := Serious_Errors_Detected; 1773 1774 -- Normalization may create extra clauses that contain 1775 -- replicated input and output names. There is no need to 1776 -- reanalyze them. 1777 1778 if not Analyzed (Clause) then 1779 Set_Analyzed (Clause); 1780 1781 Analyze_Dependency_Clause 1782 (Clause => Clause, 1783 Is_Last => Clause = Last_Clause); 1784 end if; 1785 1786 -- Do not normalize an erroneous clause because the inputs 1787 -- and/or outputs may denote illegal items. Normalization is 1788 -- disabled in ASIS mode as it alters the tree by introducing 1789 -- new nodes similar to expansion. 1790 1791 if Serious_Errors_Detected = Errors and then not ASIS_Mode then 1792 Normalize_Clause (Clause); 1793 end if; 1794 1795 Next (Clause); 1796 end loop; 1797 1798 if Restore_Scope then 1799 End_Scope; 1800 end if; 1801 1802 -- Verify that every input or output of the subprogram appear in a 1803 -- dependency. 1804 1805 Check_Usage (Subp_Inputs, All_Inputs_Seen, True); 1806 Check_Usage (Subp_Outputs, All_Outputs_Seen, False); 1807 Check_Function_Return; 1808 1809 -- The dependency list is malformed 1810 1811 else 1812 Error_Msg_N ("malformed dependency relation", Deps); 1813 return; 1814 end if; 1815 1816 -- The top level dependency relation is malformed 1817 1818 else 1819 Error_Msg_N ("malformed dependency relation", Deps); 1820 return; 1821 end if; 1822 1823 -- Ensure that a state and a corresponding constituent do not appear 1824 -- together in pragma [Refined_]Depends. 1825 1826 Check_State_And_Constituent_Use 1827 (States => States_Seen, 1828 Constits => Constits_Seen, 1829 Context => N); 1830 end Analyze_Depends_In_Decl_Part; 1831 1832 -------------------------------------------- 1833 -- Analyze_External_Property_In_Decl_Part -- 1834 -------------------------------------------- 1835 1836 procedure Analyze_External_Property_In_Decl_Part 1837 (N : Node_Id; 1838 Expr_Val : out Boolean) 1839 is 1840 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 1841 Obj : constant Node_Id := Get_Pragma_Arg (Arg1); 1842 Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1)); 1843 1844 begin 1845 Error_Msg_Name_1 := Pragma_Name (N); 1846 1847 -- The Async / Effective pragmas must apply to a volatile object other 1848 -- than a formal subprogram parameter (SPARK RM 7.1.3(2)). 1849 1850 if Is_SPARK_Volatile_Object (Obj) then 1851 if Is_Entity_Name (Obj) 1852 and then Present (Entity (Obj)) 1853 and then Is_Formal (Entity (Obj)) 1854 then 1855 Error_Msg_N ("external property % cannot apply to parameter", N); 1856 end if; 1857 else 1858 Error_Msg_N 1859 ("external property % must apply to a volatile object", N); 1860 end if; 1861 1862 -- Ensure that the expression (if present) is static Boolean. A missing 1863 -- argument defaults the value to True (SPARK RM 7.1.2(5)). 1864 1865 Expr_Val := True; 1866 1867 if Present (Expr) then 1868 Analyze_And_Resolve (Expr, Standard_Boolean); 1869 1870 if Is_Static_Expression (Expr) then 1871 Expr_Val := Is_True (Expr_Value (Expr)); 1872 else 1873 Error_Msg_Name_1 := Pragma_Name (N); 1874 Error_Msg_N ("expression of % must be static", Expr); 1875 end if; 1876 end if; 1877 end Analyze_External_Property_In_Decl_Part; 1878 1879 --------------------------------- 1880 -- Analyze_Global_In_Decl_Part -- 1881 --------------------------------- 1882 1883 procedure Analyze_Global_In_Decl_Part (N : Node_Id) is 1884 Constits_Seen : Elist_Id := No_Elist; 1885 -- A list containing the entities of all constituents processed so far. 1886 -- It aids in detecting illegal usage of a state and a corresponding 1887 -- constituent in pragma [Refinde_]Global. 1888 1889 Seen : Elist_Id := No_Elist; 1890 -- A list containing the entities of all the items processed so far. It 1891 -- plays a role in detecting distinct entities. 1892 1893 Spec_Id : Entity_Id; 1894 -- The entity of the subprogram subject to pragma [Refined_]Global 1895 1896 States_Seen : Elist_Id := No_Elist; 1897 -- A list containing the entities of all states processed so far. It 1898 -- helps in detecting illegal usage of a state and a corresponding 1899 -- constituent in pragma [Refined_]Global. 1900 1901 Subp_Id : Entity_Id; 1902 -- The entity of the subprogram [body or stub] subject to pragma 1903 -- [Refined_]Global. 1904 1905 In_Out_Seen : Boolean := False; 1906 Input_Seen : Boolean := False; 1907 Output_Seen : Boolean := False; 1908 Proof_Seen : Boolean := False; 1909 -- Flags used to verify the consistency of modes 1910 1911 procedure Analyze_Global_List 1912 (List : Node_Id; 1913 Global_Mode : Name_Id := Name_Input); 1914 -- Verify the legality of a single global list declaration. Global_Mode 1915 -- denotes the current mode in effect. 1916 1917 ------------------------- 1918 -- Analyze_Global_List -- 1919 ------------------------- 1920 1921 procedure Analyze_Global_List 1922 (List : Node_Id; 1923 Global_Mode : Name_Id := Name_Input) 1924 is 1925 procedure Analyze_Global_Item 1926 (Item : Node_Id; 1927 Global_Mode : Name_Id); 1928 -- Verify the legality of a single global item declaration. 1929 -- Global_Mode denotes the current mode in effect. 1930 1931 procedure Check_Duplicate_Mode 1932 (Mode : Node_Id; 1933 Status : in out Boolean); 1934 -- Flag Status denotes whether a particular mode has been seen while 1935 -- processing a global list. This routine verifies that Mode is not a 1936 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)). 1937 1938 procedure Check_Mode_Restriction_In_Enclosing_Context 1939 (Item : Node_Id; 1940 Item_Id : Entity_Id); 1941 -- Verify that an item of mode In_Out or Output does not appear as an 1942 -- input in the Global aspect of an enclosing subprogram. If this is 1943 -- the case, emit an error. Item and Item_Id are respectively the 1944 -- item and its entity. 1945 1946 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); 1947 -- Mode denotes either In_Out or Output. Depending on the kind of the 1948 -- related subprogram, emit an error if those two modes apply to a 1949 -- function (SPARK RM 6.1.4(10)). 1950 1951 ------------------------- 1952 -- Analyze_Global_Item -- 1953 ------------------------- 1954 1955 procedure Analyze_Global_Item 1956 (Item : Node_Id; 1957 Global_Mode : Name_Id) 1958 is 1959 Item_Id : Entity_Id; 1960 1961 begin 1962 -- Detect one of the following cases 1963 1964 -- with Global => (null, Name) 1965 -- with Global => (Name_1, null, Name_2) 1966 -- with Global => (Name, null) 1967 1968 if Nkind (Item) = N_Null then 1969 Error_Msg_N ("cannot mix null and non-null global items", Item); 1970 return; 1971 end if; 1972 1973 Analyze (Item); 1974 Resolve_State (Item); 1975 1976 -- Find the entity of the item. If this is a renaming, climb the 1977 -- renaming chain to reach the root object. Renamings of non- 1978 -- entire objects do not yield an entity (Empty). 1979 1980 Item_Id := Entity_Of (Item); 1981 1982 if Present (Item_Id) then 1983 1984 -- A global item may denote a formal parameter of an enclosing 1985 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to 1986 -- provide a better error diagnostic. 1987 1988 if Is_Formal (Item_Id) then 1989 if Scope (Item_Id) = Spec_Id then 1990 Error_Msg_NE 1991 ("global item cannot reference parameter of subprogram", 1992 Item, Spec_Id); 1993 return; 1994 end if; 1995 1996 -- A constant cannot act as a global item (SPARK RM 6.1.4(7)). 1997 -- Do this check first to provide a better error diagnostic. 1998 1999 elsif Ekind (Item_Id) = E_Constant then 2000 Error_Msg_N ("global item cannot denote a constant", Item); 2001 2002 -- The only legal references are those to abstract states and 2003 -- variables (SPARK RM 6.1.4(4)). 2004 2005 elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 2006 Error_Msg_N 2007 ("global item must denote variable or state", Item); 2008 return; 2009 end if; 2010 2011 -- State related checks 2012 2013 if Ekind (Item_Id) = E_Abstract_State then 2014 2015 -- An abstract state with visible refinement cannot appear 2016 -- in pragma [Refined_]Global as its place must be taken by 2017 -- some of its constituents (SPARK RM 6.1.4(8)). 2018 2019 if Has_Visible_Refinement (Item_Id) then 2020 Error_Msg_NE 2021 ("cannot mention state & in global refinement", 2022 Item, Item_Id); 2023 Error_Msg_N ("\use its constituents instead", Item); 2024 return; 2025 2026 -- If the reference to the abstract state appears in an 2027 -- enclosing package body that will eventually refine the 2028 -- state, record the reference for future checks. 2029 2030 else 2031 Record_Possible_Body_Reference 2032 (State_Id => Item_Id, 2033 Ref => Item); 2034 end if; 2035 2036 -- Variable related checks. These are only relevant when 2037 -- SPARK_Mode is on as they are not standard Ada legality 2038 -- rules. 2039 2040 elsif SPARK_Mode = On 2041 and then Is_SPARK_Volatile_Object (Item_Id) 2042 then 2043 -- A volatile object cannot appear as a global item of a 2044 -- function (SPARK RM 7.1.3(9)). 2045 2046 if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then 2047 Error_Msg_NE 2048 ("volatile object & cannot act as global item of a " 2049 & "function", Item, Item_Id); 2050 return; 2051 2052 -- A volatile object with property Effective_Reads set to 2053 -- True must have mode Output or In_Out. 2054 2055 elsif Effective_Reads_Enabled (Item_Id) 2056 and then Global_Mode = Name_Input 2057 then 2058 Error_Msg_NE 2059 ("volatile object & with property Effective_Reads must " 2060 & "have mode In_Out or Output (SPARK RM 7.1.3(11))", 2061 Item, Item_Id); 2062 return; 2063 end if; 2064 end if; 2065 2066 -- When the item renames an entire object, replace the item 2067 -- with a reference to the object. 2068 2069 if Present (Renamed_Object (Entity (Item))) then 2070 Rewrite (Item, New_Occurrence_Of (Item_Id, Sloc (Item))); 2071 Analyze (Item); 2072 end if; 2073 2074 -- Some form of illegal construct masquerading as a name 2075 -- (SPARK RM 6.1.4(4)). 2076 2077 else 2078 Error_Msg_N ("global item must denote variable or state", Item); 2079 return; 2080 end if; 2081 2082 -- Verify that an output does not appear as an input in an 2083 -- enclosing subprogram. 2084 2085 if Nam_In (Global_Mode, Name_In_Out, Name_Output) then 2086 Check_Mode_Restriction_In_Enclosing_Context (Item, Item_Id); 2087 end if; 2088 2089 -- The same entity might be referenced through various way. 2090 -- Check the entity of the item rather than the item itself 2091 -- (SPARK RM 6.1.4(11)). 2092 2093 if Contains (Seen, Item_Id) then 2094 Error_Msg_N ("duplicate global item", Item); 2095 2096 -- Add the entity of the current item to the list of processed 2097 -- items. 2098 2099 else 2100 Add_Item (Item_Id, Seen); 2101 2102 if Ekind (Item_Id) = E_Abstract_State then 2103 Add_Item (Item_Id, States_Seen); 2104 end if; 2105 2106 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) 2107 and then Present (Encapsulating_State (Item_Id)) 2108 then 2109 Add_Item (Item_Id, Constits_Seen); 2110 end if; 2111 end if; 2112 end Analyze_Global_Item; 2113 2114 -------------------------- 2115 -- Check_Duplicate_Mode -- 2116 -------------------------- 2117 2118 procedure Check_Duplicate_Mode 2119 (Mode : Node_Id; 2120 Status : in out Boolean) 2121 is 2122 begin 2123 if Status then 2124 Error_Msg_N ("duplicate global mode", Mode); 2125 end if; 2126 2127 Status := True; 2128 end Check_Duplicate_Mode; 2129 2130 ------------------------------------------------- 2131 -- Check_Mode_Restriction_In_Enclosing_Context -- 2132 ------------------------------------------------- 2133 2134 procedure Check_Mode_Restriction_In_Enclosing_Context 2135 (Item : Node_Id; 2136 Item_Id : Entity_Id) 2137 is 2138 Context : Entity_Id; 2139 Dummy : Boolean; 2140 Inputs : Elist_Id := No_Elist; 2141 Outputs : Elist_Id := No_Elist; 2142 2143 begin 2144 -- Traverse the scope stack looking for enclosing subprograms 2145 -- subject to pragma [Refined_]Global. 2146 2147 Context := Scope (Subp_Id); 2148 while Present (Context) and then Context /= Standard_Standard loop 2149 if Is_Subprogram (Context) 2150 and then 2151 (Present (Get_Pragma (Context, Pragma_Global)) 2152 or else 2153 Present (Get_Pragma (Context, Pragma_Refined_Global))) 2154 then 2155 Collect_Subprogram_Inputs_Outputs 2156 (Subp_Id => Context, 2157 Subp_Inputs => Inputs, 2158 Subp_Outputs => Outputs, 2159 Global_Seen => Dummy); 2160 2161 -- The item is classified as In_Out or Output but appears as 2162 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)). 2163 2164 if Appears_In (Inputs, Item_Id) 2165 and then not Appears_In (Outputs, Item_Id) 2166 then 2167 Error_Msg_NE 2168 ("global item & cannot have mode In_Out or Output", 2169 Item, Item_Id); 2170 Error_Msg_NE 2171 ("\item already appears as input of subprogram &", 2172 Item, Context); 2173 2174 -- Stop the traversal once an error has been detected 2175 2176 exit; 2177 end if; 2178 end if; 2179 2180 Context := Scope (Context); 2181 end loop; 2182 end Check_Mode_Restriction_In_Enclosing_Context; 2183 2184 ---------------------------------------- 2185 -- Check_Mode_Restriction_In_Function -- 2186 ---------------------------------------- 2187 2188 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is 2189 begin 2190 if Ekind (Spec_Id) = E_Function then 2191 Error_Msg_N 2192 ("global mode & is not applicable to functions", Mode); 2193 end if; 2194 end Check_Mode_Restriction_In_Function; 2195 2196 -- Local variables 2197 2198 Assoc : Node_Id; 2199 Item : Node_Id; 2200 Mode : Node_Id; 2201 2202 -- Start of processing for Analyze_Global_List 2203 2204 begin 2205 if Nkind (List) = N_Null then 2206 Set_Analyzed (List); 2207 2208 -- Single global item declaration 2209 2210 elsif Nkind_In (List, N_Expanded_Name, 2211 N_Identifier, 2212 N_Selected_Component) 2213 then 2214 Analyze_Global_Item (List, Global_Mode); 2215 2216 -- Simple global list or moded global list declaration 2217 2218 elsif Nkind (List) = N_Aggregate then 2219 Set_Analyzed (List); 2220 2221 -- The declaration of a simple global list appear as a collection 2222 -- of expressions. 2223 2224 if Present (Expressions (List)) then 2225 if Present (Component_Associations (List)) then 2226 Error_Msg_N 2227 ("cannot mix moded and non-moded global lists", List); 2228 end if; 2229 2230 Item := First (Expressions (List)); 2231 while Present (Item) loop 2232 Analyze_Global_Item (Item, Global_Mode); 2233 2234 Next (Item); 2235 end loop; 2236 2237 -- The declaration of a moded global list appears as a collection 2238 -- of component associations where individual choices denote 2239 -- modes. 2240 2241 elsif Present (Component_Associations (List)) then 2242 if Present (Expressions (List)) then 2243 Error_Msg_N 2244 ("cannot mix moded and non-moded global lists", List); 2245 end if; 2246 2247 Assoc := First (Component_Associations (List)); 2248 while Present (Assoc) loop 2249 Mode := First (Choices (Assoc)); 2250 2251 if Nkind (Mode) = N_Identifier then 2252 if Chars (Mode) = Name_In_Out then 2253 Check_Duplicate_Mode (Mode, In_Out_Seen); 2254 Check_Mode_Restriction_In_Function (Mode); 2255 2256 elsif Chars (Mode) = Name_Input then 2257 Check_Duplicate_Mode (Mode, Input_Seen); 2258 2259 elsif Chars (Mode) = Name_Output then 2260 Check_Duplicate_Mode (Mode, Output_Seen); 2261 Check_Mode_Restriction_In_Function (Mode); 2262 2263 elsif Chars (Mode) = Name_Proof_In then 2264 Check_Duplicate_Mode (Mode, Proof_Seen); 2265 2266 else 2267 Error_Msg_N ("invalid mode selector", Mode); 2268 end if; 2269 2270 else 2271 Error_Msg_N ("invalid mode selector", Mode); 2272 end if; 2273 2274 -- Items in a moded list appear as a collection of 2275 -- expressions. Reuse the existing machinery to analyze 2276 -- them. 2277 2278 Analyze_Global_List 2279 (List => Expression (Assoc), 2280 Global_Mode => Chars (Mode)); 2281 2282 Next (Assoc); 2283 end loop; 2284 2285 -- Invalid tree 2286 2287 else 2288 raise Program_Error; 2289 end if; 2290 2291 -- Any other attempt to declare a global item is erroneous 2292 2293 else 2294 Error_Msg_N ("malformed global list", List); 2295 end if; 2296 end Analyze_Global_List; 2297 2298 -- Local variables 2299 2300 Items : constant Node_Id := 2301 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 2302 Subp_Decl : Node_Id; 2303 2304 Restore_Scope : Boolean := False; 2305 -- Set True if we do a Push_Scope requiring a Pop_Scope on exit 2306 2307 -- Start of processing for Analyze_Global_In_Decl_List 2308 2309 begin 2310 Set_Analyzed (N); 2311 Check_SPARK_Aspect_For_ASIS (N); 2312 2313 -- Verify the syntax of pragma Global when SPARK checks are suppressed. 2314 -- Semantic analysis is disabled in this mode. 2315 2316 if SPARK_Mode = Off then 2317 Check_Global_List_Syntax (Items); 2318 return; 2319 end if; 2320 2321 Subp_Decl := Find_Related_Subprogram_Or_Body (N); 2322 Subp_Id := Defining_Entity (Subp_Decl); 2323 2324 -- The logic in this routine is used to analyze both pragma Global and 2325 -- pragma Refined_Global since they have the same syntax and base 2326 -- semantics. Find the entity of the corresponding spec when analyzing 2327 -- Refined_Global. 2328 2329 if Nkind (Subp_Decl) = N_Subprogram_Body 2330 and then not Acts_As_Spec (Subp_Decl) 2331 then 2332 Spec_Id := Corresponding_Spec (Subp_Decl); 2333 2334 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub then 2335 Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl); 2336 2337 else 2338 Spec_Id := Subp_Id; 2339 end if; 2340 2341 -- There is nothing to be done for a null global list 2342 2343 if Nkind (Items) = N_Null then 2344 Set_Analyzed (Items); 2345 2346 -- Analyze the various forms of global lists and items. Note that some 2347 -- of these may be malformed in which case the analysis emits error 2348 -- messages. 2349 2350 else 2351 -- Ensure that the formal parameters are visible when processing an 2352 -- item. This falls out of the general rule of aspects pertaining to 2353 -- subprogram declarations. 2354 2355 if not In_Open_Scopes (Spec_Id) then 2356 Restore_Scope := True; 2357 Push_Scope (Spec_Id); 2358 Install_Formals (Spec_Id); 2359 end if; 2360 2361 Analyze_Global_List (Items); 2362 2363 if Restore_Scope then 2364 End_Scope; 2365 end if; 2366 end if; 2367 2368 -- Ensure that a state and a corresponding constituent do not appear 2369 -- together in pragma [Refined_]Global. 2370 2371 Check_State_And_Constituent_Use 2372 (States => States_Seen, 2373 Constits => Constits_Seen, 2374 Context => N); 2375 end Analyze_Global_In_Decl_Part; 2376 2377 -------------------------------------------- 2378 -- Analyze_Initial_Condition_In_Decl_Part -- 2379 -------------------------------------------- 2380 2381 procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is 2382 Expr : constant Node_Id := 2383 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 2384 2385 begin 2386 Set_Analyzed (N); 2387 2388 -- The expression is preanalyzed because it has not been moved to its 2389 -- final place yet. A direct analysis may generate side effects and this 2390 -- is not desired at this point. 2391 2392 Preanalyze_And_Resolve (Expr, Standard_Boolean); 2393 end Analyze_Initial_Condition_In_Decl_Part; 2394 2395 -------------------------------------- 2396 -- Analyze_Initializes_In_Decl_Part -- 2397 -------------------------------------- 2398 2399 procedure Analyze_Initializes_In_Decl_Part (N : Node_Id) is 2400 Pack_Spec : constant Node_Id := Parent (N); 2401 Pack_Id : constant Entity_Id := Defining_Entity (Parent (Pack_Spec)); 2402 2403 Constits_Seen : Elist_Id := No_Elist; 2404 -- A list containing the entities of all constituents processed so far. 2405 -- It aids in detecting illegal usage of a state and a corresponding 2406 -- constituent in pragma Initializes. 2407 2408 Items_Seen : Elist_Id := No_Elist; 2409 -- A list of all initialization items processed so far. This list is 2410 -- used to detect duplicate items. 2411 2412 Non_Null_Seen : Boolean := False; 2413 Null_Seen : Boolean := False; 2414 -- Flags used to check the legality of a null initialization list 2415 2416 States_And_Vars : Elist_Id := No_Elist; 2417 -- A list of all abstract states and variables declared in the visible 2418 -- declarations of the related package. This list is used to detect the 2419 -- legality of initialization items. 2420 2421 States_Seen : Elist_Id := No_Elist; 2422 -- A list containing the entities of all states processed so far. It 2423 -- helps in detecting illegal usage of a state and a corresponding 2424 -- constituent in pragma Initializes. 2425 2426 procedure Analyze_Initialization_Item (Item : Node_Id); 2427 -- Verify the legality of a single initialization item 2428 2429 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id); 2430 -- Verify the legality of a single initialization item followed by a 2431 -- list of input items. 2432 2433 procedure Check_Initialization_List_Syntax (List : Node_Id); 2434 -- Verify the syntax of initialization list List 2435 2436 procedure Collect_States_And_Variables; 2437 -- Inspect the visible declarations of the related package and gather 2438 -- the entities of all abstract states and variables in States_And_Vars. 2439 2440 --------------------------------- 2441 -- Analyze_Initialization_Item -- 2442 --------------------------------- 2443 2444 procedure Analyze_Initialization_Item (Item : Node_Id) is 2445 Item_Id : Entity_Id; 2446 2447 begin 2448 -- Null initialization list 2449 2450 if Nkind (Item) = N_Null then 2451 if Null_Seen then 2452 Error_Msg_N ("multiple null initializations not allowed", Item); 2453 2454 elsif Non_Null_Seen then 2455 Error_Msg_N 2456 ("cannot mix null and non-null initialization items", Item); 2457 else 2458 Null_Seen := True; 2459 end if; 2460 2461 -- Initialization item 2462 2463 else 2464 Non_Null_Seen := True; 2465 2466 if Null_Seen then 2467 Error_Msg_N 2468 ("cannot mix null and non-null initialization items", Item); 2469 end if; 2470 2471 Analyze (Item); 2472 Resolve_State (Item); 2473 2474 if Is_Entity_Name (Item) then 2475 Item_Id := Entity_Of (Item); 2476 2477 if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 2478 2479 -- The state or variable must be declared in the visible 2480 -- declarations of the package (SPARK RM 7.1.5(7)). 2481 2482 if not Contains (States_And_Vars, Item_Id) then 2483 Error_Msg_Name_1 := Chars (Pack_Id); 2484 Error_Msg_NE 2485 ("initialization item & must appear in the visible " 2486 & "declarations of package %", Item, Item_Id); 2487 2488 -- Detect a duplicate use of the same initialization item 2489 -- (SPARK RM 7.1.5(5)). 2490 2491 elsif Contains (Items_Seen, Item_Id) then 2492 Error_Msg_N ("duplicate initialization item", Item); 2493 2494 -- The item is legal, add it to the list of processed states 2495 -- and variables. 2496 2497 else 2498 Add_Item (Item_Id, Items_Seen); 2499 2500 if Ekind (Item_Id) = E_Abstract_State then 2501 Add_Item (Item_Id, States_Seen); 2502 end if; 2503 2504 if Present (Encapsulating_State (Item_Id)) then 2505 Add_Item (Item_Id, Constits_Seen); 2506 end if; 2507 end if; 2508 2509 -- The item references something that is not a state or a 2510 -- variable (SPARK RM 7.1.5(3)). 2511 2512 else 2513 Error_Msg_N 2514 ("initialization item must denote variable or state", 2515 Item); 2516 end if; 2517 2518 -- Some form of illegal construct masquerading as a name 2519 -- (SPARK RM 7.1.5(3)). 2520 2521 else 2522 Error_Msg_N 2523 ("initialization item must denote variable or state", Item); 2524 end if; 2525 end if; 2526 end Analyze_Initialization_Item; 2527 2528 --------------------------------------------- 2529 -- Analyze_Initialization_Item_With_Inputs -- 2530 --------------------------------------------- 2531 2532 procedure Analyze_Initialization_Item_With_Inputs (Item : Node_Id) is 2533 Inputs_Seen : Elist_Id := No_Elist; 2534 -- A list of all inputs processed so far. This list is used to detect 2535 -- duplicate uses of an input. 2536 2537 Non_Null_Seen : Boolean := False; 2538 Null_Seen : Boolean := False; 2539 -- Flags used to check the legality of an input list 2540 2541 procedure Analyze_Input_Item (Input : Node_Id); 2542 -- Verify the legality of a single input item 2543 2544 ------------------------ 2545 -- Analyze_Input_Item -- 2546 ------------------------ 2547 2548 procedure Analyze_Input_Item (Input : Node_Id) is 2549 Input_Id : Entity_Id; 2550 2551 begin 2552 -- Null input list 2553 2554 if Nkind (Input) = N_Null then 2555 if Null_Seen then 2556 Error_Msg_N 2557 ("multiple null initializations not allowed", Item); 2558 2559 elsif Non_Null_Seen then 2560 Error_Msg_N 2561 ("cannot mix null and non-null initialization item", Item); 2562 else 2563 Null_Seen := True; 2564 end if; 2565 2566 -- Input item 2567 2568 else 2569 Non_Null_Seen := True; 2570 2571 if Null_Seen then 2572 Error_Msg_N 2573 ("cannot mix null and non-null initialization item", Item); 2574 end if; 2575 2576 Analyze (Input); 2577 Resolve_State (Input); 2578 2579 if Is_Entity_Name (Input) then 2580 Input_Id := Entity_Of (Input); 2581 2582 if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then 2583 2584 -- The input cannot denote states or variables declared 2585 -- within the related package. 2586 2587 if Within_Scope (Input_Id, Current_Scope) then 2588 Error_Msg_Name_1 := Chars (Pack_Id); 2589 Error_Msg_NE 2590 ("input item & cannot denote a visible variable or " 2591 & "state of package % (SPARK RM 7.1.5(4))", 2592 Input, Input_Id); 2593 2594 -- Detect a duplicate use of the same input item 2595 -- (SPARK RM 7.1.5(5)). 2596 2597 elsif Contains (Inputs_Seen, Input_Id) then 2598 Error_Msg_N ("duplicate input item", Input); 2599 2600 -- Input is legal, add it to the list of processed inputs 2601 2602 else 2603 Add_Item (Input_Id, Inputs_Seen); 2604 2605 if Ekind (Input_Id) = E_Abstract_State then 2606 Add_Item (Input_Id, States_Seen); 2607 end if; 2608 2609 if Present (Encapsulating_State (Input_Id)) then 2610 Add_Item (Input_Id, Constits_Seen); 2611 end if; 2612 end if; 2613 2614 -- The input references something that is not a state or a 2615 -- variable. 2616 2617 else 2618 Error_Msg_N 2619 ("input item must denote variable or state", Input); 2620 end if; 2621 2622 -- Some form of illegal construct masquerading as a name 2623 2624 else 2625 Error_Msg_N 2626 ("input item must denote variable or state", Input); 2627 end if; 2628 end if; 2629 end Analyze_Input_Item; 2630 2631 -- Local variables 2632 2633 Inputs : constant Node_Id := Expression (Item); 2634 Elmt : Node_Id; 2635 Input : Node_Id; 2636 2637 Name_Seen : Boolean := False; 2638 -- A flag used to detect multiple item names 2639 2640 -- Start of processing for Analyze_Initialization_Item_With_Inputs 2641 2642 begin 2643 -- Inspect the name of an item with inputs 2644 2645 Elmt := First (Choices (Item)); 2646 while Present (Elmt) loop 2647 if Name_Seen then 2648 Error_Msg_N ("only one item allowed in initialization", Elmt); 2649 else 2650 Name_Seen := True; 2651 Analyze_Initialization_Item (Elmt); 2652 end if; 2653 2654 Next (Elmt); 2655 end loop; 2656 2657 -- Multiple input items appear as an aggregate 2658 2659 if Nkind (Inputs) = N_Aggregate then 2660 if Present (Expressions (Inputs)) then 2661 Input := First (Expressions (Inputs)); 2662 while Present (Input) loop 2663 Analyze_Input_Item (Input); 2664 Next (Input); 2665 end loop; 2666 end if; 2667 2668 if Present (Component_Associations (Inputs)) then 2669 Error_Msg_N 2670 ("inputs must appear in named association form", Inputs); 2671 end if; 2672 2673 -- Single input item 2674 2675 else 2676 Analyze_Input_Item (Inputs); 2677 end if; 2678 end Analyze_Initialization_Item_With_Inputs; 2679 2680 -------------------------------------- 2681 -- Check_Initialization_List_Syntax -- 2682 -------------------------------------- 2683 2684 procedure Check_Initialization_List_Syntax (List : Node_Id) is 2685 Init : Node_Id; 2686 Input : Node_Id; 2687 2688 begin 2689 -- Null initialization list 2690 2691 if Nkind (List) = N_Null then 2692 null; 2693 2694 elsif Nkind (List) = N_Aggregate then 2695 2696 -- Simple initialization items 2697 2698 if Present (Expressions (List)) then 2699 Init := First (Expressions (List)); 2700 while Present (Init) loop 2701 Check_Item_Syntax (Init); 2702 Next (Init); 2703 end loop; 2704 end if; 2705 2706 -- Initialization items with a input lists 2707 2708 if Present (Component_Associations (List)) then 2709 Init := First (Component_Associations (List)); 2710 while Present (Init) loop 2711 Check_Item_Syntax (First (Choices (Init))); 2712 2713 if Nkind (Expression (Init)) = N_Aggregate 2714 and then Present (Expressions (Expression (Init))) 2715 then 2716 Input := First (Expressions (Expression (Init))); 2717 while Present (Input) loop 2718 Check_Item_Syntax (Input); 2719 Next (Input); 2720 end loop; 2721 2722 else 2723 Error_Msg_N ("malformed initialization item", Init); 2724 end if; 2725 2726 Next (Init); 2727 end loop; 2728 end if; 2729 2730 else 2731 Error_Msg_N ("malformed initialization list", List); 2732 end if; 2733 end Check_Initialization_List_Syntax; 2734 2735 ---------------------------------- 2736 -- Collect_States_And_Variables -- 2737 ---------------------------------- 2738 2739 procedure Collect_States_And_Variables is 2740 Decl : Node_Id; 2741 2742 begin 2743 -- Collect the abstract states defined in the package (if any) 2744 2745 if Present (Abstract_States (Pack_Id)) then 2746 States_And_Vars := New_Copy_Elist (Abstract_States (Pack_Id)); 2747 end if; 2748 2749 -- Collect all variables the appear in the visible declarations of 2750 -- the related package. 2751 2752 if Present (Visible_Declarations (Pack_Spec)) then 2753 Decl := First (Visible_Declarations (Pack_Spec)); 2754 while Present (Decl) loop 2755 if Nkind (Decl) = N_Object_Declaration 2756 and then Ekind (Defining_Entity (Decl)) = E_Variable 2757 and then Comes_From_Source (Decl) 2758 then 2759 Add_Item (Defining_Entity (Decl), States_And_Vars); 2760 end if; 2761 2762 Next (Decl); 2763 end loop; 2764 end if; 2765 end Collect_States_And_Variables; 2766 2767 -- Local variables 2768 2769 Inits : constant Node_Id := 2770 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 2771 Init : Node_Id; 2772 2773 -- Start of processing for Analyze_Initializes_In_Decl_Part 2774 2775 begin 2776 Set_Analyzed (N); 2777 2778 Check_SPARK_Aspect_For_ASIS (N); 2779 2780 -- Nothing to do when the initialization list is empty 2781 2782 if Nkind (Inits) = N_Null then 2783 return; 2784 2785 -- Verify the syntax of pragma Initializes when SPARK checks are 2786 -- suppressed. Semantic analysis is disabled in this mode. 2787 2788 elsif SPARK_Mode = Off then 2789 Check_Initialization_List_Syntax (Inits); 2790 return; 2791 end if; 2792 2793 -- Single and multiple initialization clauses appear as an aggregate. If 2794 -- this is not the case, then either the parser or the analysis of the 2795 -- pragma failed to produce an aggregate. 2796 2797 pragma Assert (Nkind (Inits) = N_Aggregate); 2798 2799 -- Initialize the various lists used during analysis 2800 2801 Collect_States_And_Variables; 2802 2803 if Present (Expressions (Inits)) then 2804 Init := First (Expressions (Inits)); 2805 while Present (Init) loop 2806 Analyze_Initialization_Item (Init); 2807 Next (Init); 2808 end loop; 2809 end if; 2810 2811 if Present (Component_Associations (Inits)) then 2812 Init := First (Component_Associations (Inits)); 2813 while Present (Init) loop 2814 Analyze_Initialization_Item_With_Inputs (Init); 2815 Next (Init); 2816 end loop; 2817 end if; 2818 2819 -- Ensure that a state and a corresponding constituent do not appear 2820 -- together in pragma Initializes. 2821 2822 Check_State_And_Constituent_Use 2823 (States => States_Seen, 2824 Constits => Constits_Seen, 2825 Context => N); 2826 end Analyze_Initializes_In_Decl_Part; 2827 2828 -------------------- 2829 -- Analyze_Pragma -- 2830 -------------------- 2831 2832 -------------------- 2833 -- Analyze_Pragma -- 2834 -------------------- 2835 2836 procedure Analyze_Pragma (N : Node_Id) is 2837 Loc : constant Source_Ptr := Sloc (N); 2838 Prag_Id : Pragma_Id; 2839 2840 Pname : Name_Id; 2841 -- Name of the source pragma, or name of the corresponding aspect for 2842 -- pragmas which originate in a source aspect. In the latter case, the 2843 -- name may be different from the pragma name. 2844 2845 Pragma_Exit : exception; 2846 -- This exception is used to exit pragma processing completely. It 2847 -- is used when an error is detected, and no further processing is 2848 -- required. It is also used if an earlier error has left the tree in 2849 -- a state where the pragma should not be processed. 2850 2851 Arg_Count : Nat; 2852 -- Number of pragma argument associations 2853 2854 Arg1 : Node_Id; 2855 Arg2 : Node_Id; 2856 Arg3 : Node_Id; 2857 Arg4 : Node_Id; 2858 -- First four pragma arguments (pragma argument association nodes, or 2859 -- Empty if the corresponding argument does not exist). 2860 2861 type Name_List is array (Natural range <>) of Name_Id; 2862 type Args_List is array (Natural range <>) of Node_Id; 2863 -- Types used for arguments to Check_Arg_Order and Gather_Associations 2864 2865 procedure Ada_2005_Pragma; 2866 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In 2867 -- Ada 95 mode, these are implementation defined pragmas, so should be 2868 -- caught by the No_Implementation_Pragmas restriction. 2869 2870 procedure Ada_2012_Pragma; 2871 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. 2872 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so 2873 -- should be caught by the No_Implementation_Pragmas restriction. 2874 2875 procedure Analyze_Part_Of 2876 (Item_Id : Entity_Id; 2877 State : Node_Id; 2878 Indic : Node_Id; 2879 Legal : out Boolean); 2880 -- Subsidiary to the analysis of pragmas Abstract_State and Part_Of. 2881 -- Perform full analysis of indicator Part_Of. Item_Id is the entity of 2882 -- an abstract state, variable or package instantiation. State is the 2883 -- encapsulating state. Indic is the Part_Of indicator. Flag Legal is 2884 -- set when the indicator is legal. 2885 2886 procedure Analyze_Refined_Pragma 2887 (Spec_Id : out Entity_Id; 2888 Body_Id : out Entity_Id; 2889 Legal : out Boolean); 2890 -- Subsidiary routine to the analysis of body pragmas Refined_Depends, 2891 -- Refined_Global and Refined_Post. Check the placement and related 2892 -- context of the pragma. Spec_Id is the entity of the related 2893 -- subprogram. Body_Id is the entity of the subprogram body. Flag 2894 -- Legal is set when the pragma is properly placed. 2895 2896 procedure Check_Ada_83_Warning; 2897 -- Issues a warning message for the current pragma if operating in Ada 2898 -- 83 mode (used for language pragmas that are not a standard part of 2899 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use 2900 -- of 95 pragma. 2901 2902 procedure Check_Arg_Count (Required : Nat); 2903 -- Check argument count for pragma is equal to given parameter. If not, 2904 -- then issue an error message and raise Pragma_Exit. 2905 2906 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument 2907 -- Arg which can either be a pragma argument association, in which case 2908 -- the check is applied to the expression of the association or an 2909 -- expression directly. 2910 2911 procedure Check_Arg_Is_External_Name (Arg : Node_Id); 2912 -- Check that an argument has the right form for an EXTERNAL_NAME 2913 -- parameter of an extended import/export pragma. The rule is that the 2914 -- name must be an identifier or string literal (in Ada 83 mode) or a 2915 -- static string expression (in Ada 95 mode). 2916 2917 procedure Check_Arg_Is_Identifier (Arg : Node_Id); 2918 -- Check the specified argument Arg to make sure that it is an 2919 -- identifier. If not give error and raise Pragma_Exit. 2920 2921 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); 2922 -- Check the specified argument Arg to make sure that it is an integer 2923 -- literal. If not give error and raise Pragma_Exit. 2924 2925 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); 2926 -- Check the specified argument Arg to make sure that it has the proper 2927 -- syntactic form for a local name and meets the semantic requirements 2928 -- for a local name. The local name is analyzed as part of the 2929 -- processing for this call. In addition, the local name is required 2930 -- to represent an entity at the library level. 2931 2932 procedure Check_Arg_Is_Local_Name (Arg : Node_Id); 2933 -- Check the specified argument Arg to make sure that it has the proper 2934 -- syntactic form for a local name and meets the semantic requirements 2935 -- for a local name. The local name is analyzed as part of the 2936 -- processing for this call. 2937 2938 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); 2939 -- Check the specified argument Arg to make sure that it is a valid 2940 -- locking policy name. If not give error and raise Pragma_Exit. 2941 2942 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); 2943 -- Check the specified argument Arg to make sure that it is a valid 2944 -- elaboration policy name. If not give error and raise Pragma_Exit. 2945 2946 procedure Check_Arg_Is_One_Of 2947 (Arg : Node_Id; 2948 N1, N2 : Name_Id); 2949 procedure Check_Arg_Is_One_Of 2950 (Arg : Node_Id; 2951 N1, N2, N3 : Name_Id); 2952 procedure Check_Arg_Is_One_Of 2953 (Arg : Node_Id; 2954 N1, N2, N3, N4 : Name_Id); 2955 procedure Check_Arg_Is_One_Of 2956 (Arg : Node_Id; 2957 N1, N2, N3, N4, N5 : Name_Id); 2958 -- Check the specified argument Arg to make sure that it is an 2959 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if 2960 -- present). If not then give error and raise Pragma_Exit. 2961 2962 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); 2963 -- Check the specified argument Arg to make sure that it is a valid 2964 -- queuing policy name. If not give error and raise Pragma_Exit. 2965 2966 procedure Check_Arg_Is_Static_Expression 2967 (Arg : Node_Id; 2968 Typ : Entity_Id := Empty); 2969 -- Check the specified argument Arg to make sure that it is a static 2970 -- expression of the given type (i.e. it will be analyzed and resolved 2971 -- using this type, which can be any valid argument to Resolve, e.g. 2972 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 2973 -- Typ is left Empty, then any static expression is allowed. 2974 2975 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); 2976 -- Check the specified argument Arg to make sure that it is a valid task 2977 -- dispatching policy name. If not give error and raise Pragma_Exit. 2978 2979 procedure Check_Arg_Order (Names : Name_List); 2980 -- Checks for an instance of two arguments with identifiers for the 2981 -- current pragma which are not in the sequence indicated by Names, 2982 -- and if so, generates a fatal message about bad order of arguments. 2983 2984 procedure Check_At_Least_N_Arguments (N : Nat); 2985 -- Check there are at least N arguments present 2986 2987 procedure Check_At_Most_N_Arguments (N : Nat); 2988 -- Check there are no more than N arguments present 2989 2990 procedure Check_Component 2991 (Comp : Node_Id; 2992 UU_Typ : Entity_Id; 2993 In_Variant_Part : Boolean := False); 2994 -- Examine an Unchecked_Union component for correct use of per-object 2995 -- constrained subtypes, and for restrictions on finalizable components. 2996 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part 2997 -- should be set when Comp comes from a record variant. 2998 2999 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id); 3000 -- Subsidiary routine to the analysis of pragmas Abstract_State, 3001 -- Initial_Condition and Initializes. Determine whether pragma First 3002 -- appears before pragma Second. If this is not the case, emit an error. 3003 3004 procedure Check_Duplicate_Pragma (E : Entity_Id); 3005 -- Check if a rep item of the same name as the current pragma is already 3006 -- chained as a rep pragma to the given entity. If so give a message 3007 -- about the duplicate, and then raise Pragma_Exit so does not return. 3008 -- Note that if E is a type, then this routine avoids flagging a pragma 3009 -- which applies to a parent type from which E is derived. 3010 3011 procedure Check_Duplicated_Export_Name (Nam : Node_Id); 3012 -- Nam is an N_String_Literal node containing the external name set by 3013 -- an Import or Export pragma (or extended Import or Export pragma). 3014 -- This procedure checks for possible duplications if this is the export 3015 -- case, and if found, issues an appropriate error message. 3016 3017 procedure Check_Expr_Is_Static_Expression 3018 (Expr : Node_Id; 3019 Typ : Entity_Id := Empty); 3020 -- Check the specified expression Expr to make sure that it is a static 3021 -- expression of the given type (i.e. it will be analyzed and resolved 3022 -- using this type, which can be any valid argument to Resolve, e.g. 3023 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 3024 -- Typ is left Empty, then any static expression is allowed. 3025 3026 procedure Check_First_Subtype (Arg : Node_Id); 3027 -- Checks that Arg, whose expression is an entity name, references a 3028 -- first subtype. 3029 3030 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id); 3031 -- Checks that the given argument has an identifier, and if so, requires 3032 -- it to match the given identifier name. If there is no identifier, or 3033 -- a non-matching identifier, then an error message is given and 3034 -- Pragma_Exit is raised. 3035 3036 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); 3037 -- Checks that the given argument has an identifier, and if so, requires 3038 -- it to match one of the given identifier names. If there is no 3039 -- identifier, or a non-matching identifier, then an error message is 3040 -- given and Pragma_Exit is raised. 3041 3042 procedure Check_In_Main_Program; 3043 -- Common checks for pragmas that appear within a main program 3044 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). 3045 3046 procedure Check_Interrupt_Or_Attach_Handler; 3047 -- Common processing for first argument of pragma Interrupt_Handler or 3048 -- pragma Attach_Handler. 3049 3050 procedure Check_Loop_Pragma_Placement; 3051 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant 3052 -- appear immediately within a construct restricted to loops, and that 3053 -- pragmas Loop_Invariant and Loop_Variant are grouped together. 3054 3055 procedure Check_Is_In_Decl_Part_Or_Package_Spec; 3056 -- Check that pragma appears in a declarative part, or in a package 3057 -- specification, i.e. that it does not occur in a statement sequence 3058 -- in a body. 3059 3060 procedure Check_No_Identifier (Arg : Node_Id); 3061 -- Checks that the given argument does not have an identifier. If 3062 -- an identifier is present, then an error message is issued, and 3063 -- Pragma_Exit is raised. 3064 3065 procedure Check_No_Identifiers; 3066 -- Checks that none of the arguments to the pragma has an identifier. 3067 -- If any argument has an identifier, then an error message is issued, 3068 -- and Pragma_Exit is raised. 3069 3070 procedure Check_No_Link_Name; 3071 -- Checks that no link name is specified 3072 3073 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 3074 -- Checks if the given argument has an identifier, and if so, requires 3075 -- it to match the given identifier name. If there is a non-matching 3076 -- identifier, then an error message is given and Pragma_Exit is raised. 3077 3078 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); 3079 -- Checks if the given argument has an identifier, and if so, requires 3080 -- it to match the given identifier name. If there is a non-matching 3081 -- identifier, then an error message is given and Pragma_Exit is raised. 3082 -- In this version of the procedure, the identifier name is given as 3083 -- a string with lower case letters. 3084 3085 procedure Check_Pre_Post; 3086 -- Called to perform checks for Pre, Pre_Class, Post, Post_Class 3087 -- pragmas. These are processed by transformation to equivalent 3088 -- Precondition and Postcondition pragmas, but Pre and Post need an 3089 -- additional check that they are not used in a subprogram body when 3090 -- there is a separate spec present. 3091 3092 procedure Check_Precondition_Postcondition (In_Body : out Boolean); 3093 -- Called to process a precondition or postcondition pragma. There are 3094 -- three cases: 3095 -- 3096 -- The pragma appears after a subprogram spec 3097 -- 3098 -- If the corresponding check is not enabled, the pragma is analyzed 3099 -- but otherwise ignored and control returns with In_Body set False. 3100 -- 3101 -- If the check is enabled, then the first step is to analyze the 3102 -- pragma, but this is skipped if the subprogram spec appears within 3103 -- a package specification (because this is the case where we delay 3104 -- analysis till the end of the spec). Then (whether or not it was 3105 -- analyzed), the pragma is chained to the subprogram in question 3106 -- (using Pre_Post_Conditions and Next_Pragma) and control returns 3107 -- to the caller with In_Body set False. 3108 -- 3109 -- The pragma appears at the start of subprogram body declarations 3110 -- 3111 -- In this case an immediate return to the caller is made with 3112 -- In_Body set True, and the pragma is NOT analyzed. 3113 -- 3114 -- In all other cases, an error message for bad placement is given 3115 3116 procedure Check_Static_Constraint (Constr : Node_Id); 3117 -- Constr is a constraint from an N_Subtype_Indication node from a 3118 -- component constraint in an Unchecked_Union type. This routine checks 3119 -- that the constraint is static as required by the restrictions for 3120 -- Unchecked_Union. 3121 3122 procedure Check_Test_Case; 3123 -- Called to process a test-case pragma. It starts with checking pragma 3124 -- arguments, and the rest of the treatment is similar to the one for 3125 -- pre- and postcondition in Check_Precondition_Postcondition, except 3126 -- the placement rules for the test-case pragma are stricter. These 3127 -- pragmas may only occur after a subprogram spec declared directly 3128 -- in a package spec unit. In this case, the pragma is chained to the 3129 -- subprogram in question (using Contract_Test_Cases and Next_Pragma) 3130 -- and analysis of the pragma is delayed till the end of the spec. In 3131 -- all other cases, an error message for bad placement is given. 3132 3133 procedure Check_Valid_Configuration_Pragma; 3134 -- Legality checks for placement of a configuration pragma 3135 3136 procedure Check_Valid_Library_Unit_Pragma; 3137 -- Legality checks for library unit pragmas. A special case arises for 3138 -- pragmas in generic instances that come from copies of the original 3139 -- library unit pragmas in the generic templates. In the case of other 3140 -- than library level instantiations these can appear in contexts which 3141 -- would normally be invalid (they only apply to the original template 3142 -- and to library level instantiations), and they are simply ignored, 3143 -- which is implemented by rewriting them as null statements. 3144 3145 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); 3146 -- Check an Unchecked_Union variant for lack of nested variants and 3147 -- presence of at least one component. UU_Typ is the related Unchecked_ 3148 -- Union type. 3149 3150 procedure Ensure_Aggregate_Form (Arg : Node_Id); 3151 -- Subsidiary routine to the processing of pragmas Abstract_State, 3152 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends, 3153 -- Refined_Global and Refined_State. Transform argument Arg into an 3154 -- aggregate if not one already. N_Null is never transformed. 3155 3156 procedure Error_Pragma (Msg : String); 3157 pragma No_Return (Error_Pragma); 3158 -- Outputs error message for current pragma. The message contains a % 3159 -- that will be replaced with the pragma name, and the flag is placed 3160 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine 3161 -- calls Fix_Error (see spec of that procedure for details). 3162 3163 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); 3164 pragma No_Return (Error_Pragma_Arg); 3165 -- Outputs error message for current pragma. The message may contain 3166 -- a % that will be replaced with the pragma name. The parameter Arg 3167 -- may either be a pragma argument association, in which case the flag 3168 -- is placed on the expression of this association, or an expression, 3169 -- in which case the flag is placed directly on the expression. The 3170 -- message is placed using Error_Msg_N, so the message may also contain 3171 -- an & insertion character which will reference the given Arg value. 3172 -- After placing the message, Pragma_Exit is raised. Note: this routine 3173 -- calls Fix_Error (see spec of that procedure for details). 3174 3175 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); 3176 pragma No_Return (Error_Pragma_Arg); 3177 -- Similar to above form of Error_Pragma_Arg except that two messages 3178 -- are provided, the second is a continuation comment starting with \. 3179 3180 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); 3181 pragma No_Return (Error_Pragma_Arg_Ident); 3182 -- Outputs error message for current pragma. The message may contain a % 3183 -- that will be replaced with the pragma name. The parameter Arg must be 3184 -- a pragma argument association with a non-empty identifier (i.e. its 3185 -- Chars field must be set), and the error message is placed on the 3186 -- identifier. The message is placed using Error_Msg_N so the message 3187 -- may also contain an & insertion character which will reference 3188 -- the identifier. After placing the message, Pragma_Exit is raised. 3189 -- Note: this routine calls Fix_Error (see spec of that procedure for 3190 -- details). 3191 3192 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); 3193 pragma No_Return (Error_Pragma_Ref); 3194 -- Outputs error message for current pragma. The message may contain 3195 -- a % that will be replaced with the pragma name. The parameter Ref 3196 -- must be an entity whose name can be referenced by & and sloc by #. 3197 -- After placing the message, Pragma_Exit is raised. Note: this routine 3198 -- calls Fix_Error (see spec of that procedure for details). 3199 3200 function Find_Lib_Unit_Name return Entity_Id; 3201 -- Used for a library unit pragma to find the entity to which the 3202 -- library unit pragma applies, returns the entity found. 3203 3204 procedure Find_Program_Unit_Name (Id : Node_Id); 3205 -- If the pragma is a compilation unit pragma, the id must denote the 3206 -- compilation unit in the same compilation, and the pragma must appear 3207 -- in the list of preceding or trailing pragmas. If it is a program 3208 -- unit pragma that is not a compilation unit pragma, then the 3209 -- identifier must be visible. 3210 3211 function Find_Unique_Parameterless_Procedure 3212 (Name : Entity_Id; 3213 Arg : Node_Id) return Entity_Id; 3214 -- Used for a procedure pragma to find the unique parameterless 3215 -- procedure identified by Name, returns it if it exists, otherwise 3216 -- errors out and uses Arg as the pragma argument for the message. 3217 3218 procedure Fix_Error (Msg : in out String); 3219 -- This is called prior to issuing an error message. Msg is a string 3220 -- that typically contains the substring "pragma". If the pragma comes 3221 -- from an aspect, each such "pragma" substring is replaced with the 3222 -- characters "aspect", and Error_Msg_Name_1 is set to the name of the 3223 -- aspect (which may be different from the pragma name). If the current 3224 -- pragma results from rewriting another pragma, then Error_Msg_Name_1 3225 -- is set to the original pragma name. 3226 3227 procedure Gather_Associations 3228 (Names : Name_List; 3229 Args : out Args_List); 3230 -- This procedure is used to gather the arguments for a pragma that 3231 -- permits arbitrary ordering of parameters using the normal rules 3232 -- for named and positional parameters. The Names argument is a list 3233 -- of Name_Id values that corresponds to the allowed pragma argument 3234 -- association identifiers in order. The result returned in Args is 3235 -- a list of corresponding expressions that are the pragma arguments. 3236 -- Note that this is a list of expressions, not of pragma argument 3237 -- associations (Gather_Associations has completely checked all the 3238 -- optional identifiers when it returns). An entry in Args is Empty 3239 -- on return if the corresponding argument is not present. 3240 3241 procedure GNAT_Pragma; 3242 -- Called for all GNAT defined pragmas to check the relevant restriction 3243 -- (No_Implementation_Pragmas). 3244 3245 function Is_Before_First_Decl 3246 (Pragma_Node : Node_Id; 3247 Decls : List_Id) return Boolean; 3248 -- Return True if Pragma_Node is before the first declarative item in 3249 -- Decls where Decls is the list of declarative items. 3250 3251 function Is_Configuration_Pragma return Boolean; 3252 -- Determines if the placement of the current pragma is appropriate 3253 -- for a configuration pragma. 3254 3255 function Is_In_Context_Clause return Boolean; 3256 -- Returns True if pragma appears within the context clause of a unit, 3257 -- and False for any other placement (does not generate any messages). 3258 3259 function Is_Static_String_Expression (Arg : Node_Id) return Boolean; 3260 -- Analyzes the argument, and determines if it is a static string 3261 -- expression, returns True if so, False if non-static or not String. 3262 3263 procedure Pragma_Misplaced; 3264 pragma No_Return (Pragma_Misplaced); 3265 -- Issue fatal error message for misplaced pragma 3266 3267 procedure Process_Atomic_Shared_Volatile; 3268 -- Common processing for pragmas Atomic, Shared, Volatile. Note that 3269 -- Shared is an obsolete Ada 83 pragma, treated as being identical 3270 -- in effect to pragma Atomic. 3271 3272 procedure Process_Compile_Time_Warning_Or_Error; 3273 -- Common processing for Compile_Time_Error and Compile_Time_Warning 3274 3275 procedure Process_Convention 3276 (C : out Convention_Id; 3277 Ent : out Entity_Id); 3278 -- Common processing for Convention, Interface, Import and Export. 3279 -- Checks first two arguments of pragma, and sets the appropriate 3280 -- convention value in the specified entity or entities. On return 3281 -- C is the convention, Ent is the referenced entity. 3282 3283 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); 3284 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is 3285 -- Name_Suppress for Disable and Name_Unsuppress for Enable. 3286 3287 procedure Process_Extended_Import_Export_Exception_Pragma 3288 (Arg_Internal : Node_Id; 3289 Arg_External : Node_Id; 3290 Arg_Form : Node_Id; 3291 Arg_Code : Node_Id); 3292 -- Common processing for the pragmas Import/Export_Exception. The three 3293 -- arguments correspond to the three named parameters of the pragma. An 3294 -- argument is empty if the corresponding parameter is not present in 3295 -- the pragma. 3296 3297 procedure Process_Extended_Import_Export_Object_Pragma 3298 (Arg_Internal : Node_Id; 3299 Arg_External : Node_Id; 3300 Arg_Size : Node_Id); 3301 -- Common processing for the pragmas Import/Export_Object. The three 3302 -- arguments correspond to the three named parameters of the pragmas. An 3303 -- argument is empty if the corresponding parameter is not present in 3304 -- the pragma. 3305 3306 procedure Process_Extended_Import_Export_Internal_Arg 3307 (Arg_Internal : Node_Id := Empty); 3308 -- Common processing for all extended Import and Export pragmas. The 3309 -- argument is the pragma parameter for the Internal argument. If 3310 -- Arg_Internal is empty or inappropriate, an error message is posted. 3311 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is 3312 -- set to identify the referenced entity. 3313 3314 procedure Process_Extended_Import_Export_Subprogram_Pragma 3315 (Arg_Internal : Node_Id; 3316 Arg_External : Node_Id; 3317 Arg_Parameter_Types : Node_Id; 3318 Arg_Result_Type : Node_Id := Empty; 3319 Arg_Mechanism : Node_Id; 3320 Arg_Result_Mechanism : Node_Id := Empty; 3321 Arg_First_Optional_Parameter : Node_Id := Empty); 3322 -- Common processing for all extended Import and Export pragmas applying 3323 -- to subprograms. The caller omits any arguments that do not apply to 3324 -- the pragma in question (for example, Arg_Result_Type can be non-Empty 3325 -- only in the Import_Function and Export_Function cases). The argument 3326 -- names correspond to the allowed pragma association identifiers. 3327 3328 procedure Process_Generic_List; 3329 -- Common processing for Share_Generic and Inline_Generic 3330 3331 procedure Process_Import_Or_Interface; 3332 -- Common processing for Import of Interface 3333 3334 procedure Process_Import_Predefined_Type; 3335 -- Processing for completing a type with pragma Import. This is used 3336 -- to declare types that match predefined C types, especially for cases 3337 -- without corresponding Ada predefined type. 3338 3339 type Inline_Status is (Suppressed, Disabled, Enabled); 3340 -- Inline status of a subprogram, indicated as follows: 3341 -- Suppressed: inlining is suppressed for the subprogram 3342 -- Disabled: no inlining is requested for the subprogram 3343 -- Enabled: inlining is requested/required for the subprogram 3344 3345 procedure Process_Inline (Status : Inline_Status); 3346 -- Common processing for Inline, Inline_Always and No_Inline. Parameter 3347 -- indicates the inline status specified by the pragma. 3348 3349 procedure Process_Interface_Name 3350 (Subprogram_Def : Entity_Id; 3351 Ext_Arg : Node_Id; 3352 Link_Arg : Node_Id); 3353 -- Given the last two arguments of pragma Import, pragma Export, or 3354 -- pragma Interface_Name, performs validity checks and sets the 3355 -- Interface_Name field of the given subprogram entity to the 3356 -- appropriate external or link name, depending on the arguments given. 3357 -- Ext_Arg is always present, but Link_Arg may be missing. Note that 3358 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and 3359 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg 3360 -- nor Link_Arg is present, the interface name is set to the default 3361 -- from the subprogram name. 3362 3363 procedure Process_Interrupt_Or_Attach_Handler; 3364 -- Common processing for Interrupt and Attach_Handler pragmas 3365 3366 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); 3367 -- Common processing for Restrictions and Restriction_Warnings pragmas. 3368 -- Warn is True for Restriction_Warnings, or for Restrictions if the 3369 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag 3370 -- is not set in the Restrictions case. 3371 3372 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); 3373 -- Common processing for Suppress and Unsuppress. The boolean parameter 3374 -- Suppress_Case is True for the Suppress case, and False for the 3375 -- Unsuppress case. 3376 3377 procedure Set_Exported (E : Entity_Id; Arg : Node_Id); 3378 -- This procedure sets the Is_Exported flag for the given entity, 3379 -- checking that the entity was not previously imported. Arg is 3380 -- the argument that specified the entity. A check is also made 3381 -- for exporting inappropriate entities. 3382 3383 procedure Set_Extended_Import_Export_External_Name 3384 (Internal_Ent : Entity_Id; 3385 Arg_External : Node_Id); 3386 -- Common processing for all extended import export pragmas. The first 3387 -- argument, Internal_Ent, is the internal entity, which has already 3388 -- been checked for validity by the caller. Arg_External is from the 3389 -- Import or Export pragma, and may be null if no External parameter 3390 -- was present. If Arg_External is present and is a non-null string 3391 -- (a null string is treated as the default), then the Interface_Name 3392 -- field of Internal_Ent is set appropriately. 3393 3394 procedure Set_Imported (E : Entity_Id); 3395 -- This procedure sets the Is_Imported flag for the given entity, 3396 -- checking that it is not previously exported or imported. 3397 3398 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); 3399 -- Mech is a parameter passing mechanism (see Import_Function syntax 3400 -- for MECHANISM_NAME). This routine checks that the mechanism argument 3401 -- has the right form, and if not issues an error message. If the 3402 -- argument has the right form then the Mechanism field of Ent is 3403 -- set appropriately. 3404 3405 procedure Set_Rational_Profile; 3406 -- Activate the set of configuration pragmas and permissions that make 3407 -- up the Rational profile. 3408 3409 procedure Set_Ravenscar_Profile (N : Node_Id); 3410 -- Activate the set of configuration pragmas and restrictions that make 3411 -- up the Ravenscar Profile. N is the corresponding pragma node, which 3412 -- is used for error messages on any constructs that violate the 3413 -- profile. 3414 3415 --------------------- 3416 -- Ada_2005_Pragma -- 3417 --------------------- 3418 3419 procedure Ada_2005_Pragma is 3420 begin 3421 if Ada_Version <= Ada_95 then 3422 Check_Restriction (No_Implementation_Pragmas, N); 3423 end if; 3424 end Ada_2005_Pragma; 3425 3426 --------------------- 3427 -- Ada_2012_Pragma -- 3428 --------------------- 3429 3430 procedure Ada_2012_Pragma is 3431 begin 3432 if Ada_Version <= Ada_2005 then 3433 Check_Restriction (No_Implementation_Pragmas, N); 3434 end if; 3435 end Ada_2012_Pragma; 3436 3437 --------------------- 3438 -- Analyze_Part_Of -- 3439 --------------------- 3440 3441 procedure Analyze_Part_Of 3442 (Item_Id : Entity_Id; 3443 State : Node_Id; 3444 Indic : Node_Id; 3445 Legal : out Boolean) 3446 is 3447 Pack_Id : Entity_Id; 3448 Placement : State_Space_Kind; 3449 State_Id : Entity_Id; 3450 3451 begin 3452 -- Assume that the pragma/option is illegal 3453 3454 Legal := False; 3455 3456 -- Verify the syntax of the encapsulating state when SPARK check are 3457 -- suppressed. Semantic analysis is disabled in this mode. 3458 3459 if SPARK_Mode = Off then 3460 Check_Item_Syntax (State); 3461 return; 3462 end if; 3463 3464 Analyze (State); 3465 Resolve_State (State); 3466 3467 if Is_Entity_Name (State) 3468 and then Ekind (Entity (State)) = E_Abstract_State 3469 then 3470 State_Id := Entity (State); 3471 3472 else 3473 Error_Msg_N 3474 ("indicator Part_Of must denote an abstract state", State); 3475 return; 3476 end if; 3477 3478 -- Determine where the state, variable or the package instantiation 3479 -- lives with respect to the enclosing packages or package bodies (if 3480 -- any). This placement dictates the legality of the encapsulating 3481 -- state. 3482 3483 Find_Placement_In_State_Space 3484 (Item_Id => Item_Id, 3485 Placement => Placement, 3486 Pack_Id => Pack_Id); 3487 3488 -- The item appears in a non-package construct with a declarative 3489 -- part (subprogram, block, etc). As such, the item is not allowed 3490 -- to be a part of an encapsulating state because the item is not 3491 -- visible. 3492 3493 if Placement = Not_In_Package then 3494 Error_Msg_N 3495 ("indicator Part_Of cannot appear in this context " 3496 & "(SPARK RM 7.2.6(5))", Indic); 3497 Error_Msg_Name_1 := Chars (Scope (State_Id)); 3498 Error_Msg_NE 3499 ("\& is not part of the hidden state of package %", 3500 Indic, Item_Id); 3501 3502 -- The item appears in the visible state space of some package. In 3503 -- general this scenario does not warrant Part_Of except when the 3504 -- package is a private child unit and the encapsulating state is 3505 -- declared in a parent unit or a public descendant of that parent 3506 -- unit. 3507 3508 elsif Placement = Visible_State_Space then 3509 if Is_Child_Unit (Pack_Id) 3510 and then Is_Private_Descendant (Pack_Id) 3511 then 3512 if not Is_Child_Or_Sibling (Pack_Id, Scope (State_Id)) then 3513 Error_Msg_N 3514 ("indicator Part_Of must denote an abstract state of " 3515 & "parent unit or descendant (SPARK RM 7.2.6(3))", Indic); 3516 3517 -- If the unit is a public child of a private unit it cannot 3518 -- refine the state of a private parent, only that of a 3519 -- public ancestor or descendant thereof. 3520 3521 elsif not Private_Present 3522 (Parent (Unit_Declaration_Node (Pack_Id))) 3523 and then Is_Private_Descendant (Scope (State_Id)) 3524 then 3525 Error_Msg_N 3526 ("indicator Part_Of must denote the abstract state of " 3527 & "a public ancestor", State); 3528 end if; 3529 3530 -- Indicator Part_Of is not needed when the related package is not 3531 -- a private child unit or a public descendant thereof. 3532 3533 else 3534 Error_Msg_N 3535 ("indicator Part_Of cannot appear in this context (SPARK " 3536 & "RM 7.2.6(5))", Indic); 3537 Error_Msg_Name_1 := Chars (Pack_Id); 3538 Error_Msg_NE 3539 ("\& is declared in the visible part of package %", 3540 Indic, Item_Id); 3541 end if; 3542 3543 -- When the item appears in the private state space of a package, the 3544 -- encapsulating state must be declared in the same package. 3545 3546 elsif Placement = Private_State_Space then 3547 if Scope (State_Id) /= Pack_Id then 3548 Error_Msg_NE 3549 ("indicator Part_Of must designate an abstract state of " 3550 & "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id); 3551 Error_Msg_Name_1 := Chars (Pack_Id); 3552 Error_Msg_NE 3553 ("\& is declared in the private part of package %", 3554 Indic, Item_Id); 3555 end if; 3556 3557 -- Items declared in the body state space of a package do not need 3558 -- Part_Of indicators as the refinement has already been seen. 3559 3560 else 3561 Error_Msg_N 3562 ("indicator Part_Of cannot appear in this context " 3563 & "(SPARK RM 7.2.6(5))", Indic); 3564 3565 if Scope (State_Id) = Pack_Id then 3566 Error_Msg_Name_1 := Chars (Pack_Id); 3567 Error_Msg_NE 3568 ("\& is declared in the body of package %", Indic, Item_Id); 3569 end if; 3570 end if; 3571 3572 Legal := True; 3573 end Analyze_Part_Of; 3574 3575 ---------------------------- 3576 -- Analyze_Refined_Pragma -- 3577 ---------------------------- 3578 3579 procedure Analyze_Refined_Pragma 3580 (Spec_Id : out Entity_Id; 3581 Body_Id : out Entity_Id; 3582 Legal : out Boolean) 3583 is 3584 Body_Decl : Node_Id; 3585 Spec_Decl : Node_Id; 3586 3587 begin 3588 -- Assume that the pragma is illegal 3589 3590 Spec_Id := Empty; 3591 Body_Id := Empty; 3592 Legal := False; 3593 3594 GNAT_Pragma; 3595 Check_Arg_Count (1); 3596 Check_No_Identifiers; 3597 3598 if Nam_In (Pname, Name_Refined_Depends, 3599 Name_Refined_Global, 3600 Name_Refined_State) 3601 then 3602 Ensure_Aggregate_Form (Arg1); 3603 end if; 3604 3605 -- Verify the placement of the pragma and check for duplicates. The 3606 -- pragma must apply to a subprogram body [stub]. 3607 3608 Body_Decl := Find_Related_Subprogram_Or_Body (N, Do_Checks => True); 3609 3610 -- Extract the entities of the spec and body 3611 3612 if Nkind (Body_Decl) = N_Subprogram_Body then 3613 Body_Id := Defining_Entity (Body_Decl); 3614 Spec_Id := Corresponding_Spec (Body_Decl); 3615 3616 elsif Nkind (Body_Decl) = N_Subprogram_Body_Stub then 3617 Body_Id := Defining_Entity (Body_Decl); 3618 Spec_Id := Corresponding_Spec_Of_Stub (Body_Decl); 3619 3620 else 3621 Pragma_Misplaced; 3622 return; 3623 end if; 3624 3625 -- The pragma must apply to the second declaration of a subprogram. 3626 -- In other words, the body [stub] cannot acts as a spec. 3627 3628 if No (Spec_Id) then 3629 Error_Pragma ("pragma % cannot apply to a stand alone body"); 3630 return; 3631 3632 -- Catch the case where the subprogram body is a subunit and acts as 3633 -- the third declaration of the subprogram. 3634 3635 elsif Nkind (Parent (Body_Decl)) = N_Subunit then 3636 Error_Pragma ("pragma % cannot apply to a subunit"); 3637 return; 3638 end if; 3639 3640 -- The pragma can only apply to the body [stub] of a subprogram 3641 -- declared in the visible part of a package. Retrieve the context of 3642 -- the subprogram declaration. 3643 3644 Spec_Decl := Parent (Parent (Spec_Id)); 3645 3646 if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then 3647 Error_Pragma 3648 ("pragma % must apply to the body of a subprogram declared in a " 3649 & "package specification"); 3650 return; 3651 end if; 3652 3653 -- If we get here, then the pragma is legal 3654 3655 Legal := True; 3656 end Analyze_Refined_Pragma; 3657 3658 -------------------------- 3659 -- Check_Ada_83_Warning -- 3660 -------------------------- 3661 3662 procedure Check_Ada_83_Warning is 3663 begin 3664 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3665 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N); 3666 end if; 3667 end Check_Ada_83_Warning; 3668 3669 --------------------- 3670 -- Check_Arg_Count -- 3671 --------------------- 3672 3673 procedure Check_Arg_Count (Required : Nat) is 3674 begin 3675 if Arg_Count /= Required then 3676 Error_Pragma ("wrong number of arguments for pragma%"); 3677 end if; 3678 end Check_Arg_Count; 3679 3680 -------------------------------- 3681 -- Check_Arg_Is_External_Name -- 3682 -------------------------------- 3683 3684 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is 3685 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3686 3687 begin 3688 if Nkind (Argx) = N_Identifier then 3689 return; 3690 3691 else 3692 Analyze_And_Resolve (Argx, Standard_String); 3693 3694 if Is_OK_Static_Expression (Argx) then 3695 return; 3696 3697 elsif Etype (Argx) = Any_Type then 3698 raise Pragma_Exit; 3699 3700 -- An interesting special case, if we have a string literal and 3701 -- we are in Ada 83 mode, then we allow it even though it will 3702 -- not be flagged as static. This allows expected Ada 83 mode 3703 -- use of external names which are string literals, even though 3704 -- technically these are not static in Ada 83. 3705 3706 elsif Ada_Version = Ada_83 3707 and then Nkind (Argx) = N_String_Literal 3708 then 3709 return; 3710 3711 -- Static expression that raises Constraint_Error. This has 3712 -- already been flagged, so just exit from pragma processing. 3713 3714 elsif Is_Static_Expression (Argx) then 3715 raise Pragma_Exit; 3716 3717 -- Here we have a real error (non-static expression) 3718 3719 else 3720 Error_Msg_Name_1 := Pname; 3721 3722 declare 3723 Msg : String := 3724 "argument for pragma% must be a identifier or " 3725 & "static string expression!"; 3726 begin 3727 Fix_Error (Msg); 3728 Flag_Non_Static_Expr (Msg, Argx); 3729 raise Pragma_Exit; 3730 end; 3731 end if; 3732 end if; 3733 end Check_Arg_Is_External_Name; 3734 3735 ----------------------------- 3736 -- Check_Arg_Is_Identifier -- 3737 ----------------------------- 3738 3739 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is 3740 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3741 begin 3742 if Nkind (Argx) /= N_Identifier then 3743 Error_Pragma_Arg 3744 ("argument for pragma% must be identifier", Argx); 3745 end if; 3746 end Check_Arg_Is_Identifier; 3747 3748 ---------------------------------- 3749 -- Check_Arg_Is_Integer_Literal -- 3750 ---------------------------------- 3751 3752 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is 3753 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3754 begin 3755 if Nkind (Argx) /= N_Integer_Literal then 3756 Error_Pragma_Arg 3757 ("argument for pragma% must be integer literal", Argx); 3758 end if; 3759 end Check_Arg_Is_Integer_Literal; 3760 3761 ------------------------------------------- 3762 -- Check_Arg_Is_Library_Level_Local_Name -- 3763 ------------------------------------------- 3764 3765 -- LOCAL_NAME ::= 3766 -- DIRECT_NAME 3767 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 3768 -- | library_unit_NAME 3769 3770 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is 3771 begin 3772 Check_Arg_Is_Local_Name (Arg); 3773 3774 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) 3775 and then Comes_From_Source (N) 3776 then 3777 Error_Pragma_Arg 3778 ("argument for pragma% must be library level entity", Arg); 3779 end if; 3780 end Check_Arg_Is_Library_Level_Local_Name; 3781 3782 ----------------------------- 3783 -- Check_Arg_Is_Local_Name -- 3784 ----------------------------- 3785 3786 -- LOCAL_NAME ::= 3787 -- DIRECT_NAME 3788 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 3789 -- | library_unit_NAME 3790 3791 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is 3792 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3793 3794 begin 3795 Analyze (Argx); 3796 3797 if Nkind (Argx) not in N_Direct_Name 3798 and then (Nkind (Argx) /= N_Attribute_Reference 3799 or else Present (Expressions (Argx)) 3800 or else Nkind (Prefix (Argx)) /= N_Identifier) 3801 and then (not Is_Entity_Name (Argx) 3802 or else not Is_Compilation_Unit (Entity (Argx))) 3803 then 3804 Error_Pragma_Arg ("argument for pragma% must be local name", Argx); 3805 end if; 3806 3807 -- No further check required if not an entity name 3808 3809 if not Is_Entity_Name (Argx) then 3810 null; 3811 3812 else 3813 declare 3814 OK : Boolean; 3815 Ent : constant Entity_Id := Entity (Argx); 3816 Scop : constant Entity_Id := Scope (Ent); 3817 3818 begin 3819 -- Case of a pragma applied to a compilation unit: pragma must 3820 -- occur immediately after the program unit in the compilation. 3821 3822 if Is_Compilation_Unit (Ent) then 3823 declare 3824 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 3825 3826 begin 3827 -- Case of pragma placed immediately after spec 3828 3829 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then 3830 OK := True; 3831 3832 -- Case of pragma placed immediately after body 3833 3834 elsif Nkind (Decl) = N_Subprogram_Declaration 3835 and then Present (Corresponding_Body (Decl)) 3836 then 3837 OK := Parent (N) = 3838 Aux_Decls_Node 3839 (Parent (Unit_Declaration_Node 3840 (Corresponding_Body (Decl)))); 3841 3842 -- All other cases are illegal 3843 3844 else 3845 OK := False; 3846 end if; 3847 end; 3848 3849 -- Special restricted placement rule from 10.2.1(11.8/2) 3850 3851 elsif Is_Generic_Formal (Ent) 3852 and then Prag_Id = Pragma_Preelaborable_Initialization 3853 then 3854 OK := List_Containing (N) = 3855 Generic_Formal_Declarations 3856 (Unit_Declaration_Node (Scop)); 3857 3858 -- If this is an aspect applied to a subprogram body, the 3859 -- pragma is inserted in its declarative part. 3860 3861 elsif From_Aspect_Specification (N) 3862 and then 3863 Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body 3864 and then Ent = Current_Scope 3865 then 3866 OK := True; 3867 3868 -- If the aspect is a predicate (possibly others ???) and the 3869 -- context is a record type, this is a discriminant expression 3870 -- within a type declaration, that freezes the predicated 3871 -- subtype. 3872 3873 elsif From_Aspect_Specification (N) 3874 and then Prag_Id = Pragma_Predicate 3875 and then Ekind (Current_Scope) = E_Record_Type 3876 and then Scop = Scope (Current_Scope) 3877 then 3878 OK := True; 3879 3880 -- Default case, just check that the pragma occurs in the scope 3881 -- of the entity denoted by the name. 3882 3883 else 3884 OK := Current_Scope = Scop; 3885 end if; 3886 3887 if not OK then 3888 Error_Pragma_Arg 3889 ("pragma% argument must be in same declarative part", Arg); 3890 end if; 3891 end; 3892 end if; 3893 end Check_Arg_Is_Local_Name; 3894 3895 --------------------------------- 3896 -- Check_Arg_Is_Locking_Policy -- 3897 --------------------------------- 3898 3899 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is 3900 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3901 3902 begin 3903 Check_Arg_Is_Identifier (Argx); 3904 3905 if not Is_Locking_Policy_Name (Chars (Argx)) then 3906 Error_Pragma_Arg ("& is not a valid locking policy name", Argx); 3907 end if; 3908 end Check_Arg_Is_Locking_Policy; 3909 3910 ----------------------------------------------- 3911 -- Check_Arg_Is_Partition_Elaboration_Policy -- 3912 ----------------------------------------------- 3913 3914 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is 3915 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3916 3917 begin 3918 Check_Arg_Is_Identifier (Argx); 3919 3920 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then 3921 Error_Pragma_Arg 3922 ("& is not a valid partition elaboration policy name", Argx); 3923 end if; 3924 end Check_Arg_Is_Partition_Elaboration_Policy; 3925 3926 ------------------------- 3927 -- Check_Arg_Is_One_Of -- 3928 ------------------------- 3929 3930 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 3931 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3932 3933 begin 3934 Check_Arg_Is_Identifier (Argx); 3935 3936 if not Nam_In (Chars (Argx), N1, N2) then 3937 Error_Msg_Name_2 := N1; 3938 Error_Msg_Name_3 := N2; 3939 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); 3940 end if; 3941 end Check_Arg_Is_One_Of; 3942 3943 procedure Check_Arg_Is_One_Of 3944 (Arg : Node_Id; 3945 N1, N2, N3 : Name_Id) 3946 is 3947 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3948 3949 begin 3950 Check_Arg_Is_Identifier (Argx); 3951 3952 if not Nam_In (Chars (Argx), N1, N2, N3) then 3953 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 3954 end if; 3955 end Check_Arg_Is_One_Of; 3956 3957 procedure Check_Arg_Is_One_Of 3958 (Arg : Node_Id; 3959 N1, N2, N3, N4 : Name_Id) 3960 is 3961 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3962 3963 begin 3964 Check_Arg_Is_Identifier (Argx); 3965 3966 if not Nam_In (Chars (Argx), N1, N2, N3, N4) then 3967 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 3968 end if; 3969 end Check_Arg_Is_One_Of; 3970 3971 procedure Check_Arg_Is_One_Of 3972 (Arg : Node_Id; 3973 N1, N2, N3, N4, N5 : Name_Id) 3974 is 3975 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3976 3977 begin 3978 Check_Arg_Is_Identifier (Argx); 3979 3980 if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then 3981 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 3982 end if; 3983 end Check_Arg_Is_One_Of; 3984 3985 --------------------------------- 3986 -- Check_Arg_Is_Queuing_Policy -- 3987 --------------------------------- 3988 3989 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is 3990 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3991 3992 begin 3993 Check_Arg_Is_Identifier (Argx); 3994 3995 if not Is_Queuing_Policy_Name (Chars (Argx)) then 3996 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); 3997 end if; 3998 end Check_Arg_Is_Queuing_Policy; 3999 4000 ------------------------------------ 4001 -- Check_Arg_Is_Static_Expression -- 4002 ------------------------------------ 4003 4004 procedure Check_Arg_Is_Static_Expression 4005 (Arg : Node_Id; 4006 Typ : Entity_Id := Empty) 4007 is 4008 begin 4009 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ); 4010 end Check_Arg_Is_Static_Expression; 4011 4012 ------------------------------------------ 4013 -- Check_Arg_Is_Task_Dispatching_Policy -- 4014 ------------------------------------------ 4015 4016 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is 4017 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4018 4019 begin 4020 Check_Arg_Is_Identifier (Argx); 4021 4022 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then 4023 Error_Pragma_Arg 4024 ("& is not a valid task dispatching policy name", Argx); 4025 end if; 4026 end Check_Arg_Is_Task_Dispatching_Policy; 4027 4028 --------------------- 4029 -- Check_Arg_Order -- 4030 --------------------- 4031 4032 procedure Check_Arg_Order (Names : Name_List) is 4033 Arg : Node_Id; 4034 4035 Highest_So_Far : Natural := 0; 4036 -- Highest index in Names seen do far 4037 4038 begin 4039 Arg := Arg1; 4040 for J in 1 .. Arg_Count loop 4041 if Chars (Arg) /= No_Name then 4042 for K in Names'Range loop 4043 if Chars (Arg) = Names (K) then 4044 if K < Highest_So_Far then 4045 Error_Msg_Name_1 := Pname; 4046 Error_Msg_N 4047 ("parameters out of order for pragma%", Arg); 4048 Error_Msg_Name_1 := Names (K); 4049 Error_Msg_Name_2 := Names (Highest_So_Far); 4050 Error_Msg_N ("\% must appear before %", Arg); 4051 raise Pragma_Exit; 4052 4053 else 4054 Highest_So_Far := K; 4055 end if; 4056 end if; 4057 end loop; 4058 end if; 4059 4060 Arg := Next (Arg); 4061 end loop; 4062 end Check_Arg_Order; 4063 4064 -------------------------------- 4065 -- Check_At_Least_N_Arguments -- 4066 -------------------------------- 4067 4068 procedure Check_At_Least_N_Arguments (N : Nat) is 4069 begin 4070 if Arg_Count < N then 4071 Error_Pragma ("too few arguments for pragma%"); 4072 end if; 4073 end Check_At_Least_N_Arguments; 4074 4075 ------------------------------- 4076 -- Check_At_Most_N_Arguments -- 4077 ------------------------------- 4078 4079 procedure Check_At_Most_N_Arguments (N : Nat) is 4080 Arg : Node_Id; 4081 begin 4082 if Arg_Count > N then 4083 Arg := Arg1; 4084 for J in 1 .. N loop 4085 Next (Arg); 4086 Error_Pragma_Arg ("too many arguments for pragma%", Arg); 4087 end loop; 4088 end if; 4089 end Check_At_Most_N_Arguments; 4090 4091 --------------------- 4092 -- Check_Component -- 4093 --------------------- 4094 4095 procedure Check_Component 4096 (Comp : Node_Id; 4097 UU_Typ : Entity_Id; 4098 In_Variant_Part : Boolean := False) 4099 is 4100 Comp_Id : constant Entity_Id := Defining_Identifier (Comp); 4101 Sindic : constant Node_Id := 4102 Subtype_Indication (Component_Definition (Comp)); 4103 Typ : constant Entity_Id := Etype (Comp_Id); 4104 4105 begin 4106 -- Ada 2005 (AI-216): If a component subtype is subject to a per- 4107 -- object constraint, then the component type shall be an Unchecked_ 4108 -- Union. 4109 4110 if Nkind (Sindic) = N_Subtype_Indication 4111 and then Has_Per_Object_Constraint (Comp_Id) 4112 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) 4113 then 4114 Error_Msg_N 4115 ("component subtype subject to per-object constraint " 4116 & "must be an Unchecked_Union", Comp); 4117 4118 -- Ada 2012 (AI05-0026): For an unchecked union type declared within 4119 -- the body of a generic unit, or within the body of any of its 4120 -- descendant library units, no part of the type of a component 4121 -- declared in a variant_part of the unchecked union type shall be of 4122 -- a formal private type or formal private extension declared within 4123 -- the formal part of the generic unit. 4124 4125 elsif Ada_Version >= Ada_2012 4126 and then In_Generic_Body (UU_Typ) 4127 and then In_Variant_Part 4128 and then Is_Private_Type (Typ) 4129 and then Is_Generic_Type (Typ) 4130 then 4131 Error_Msg_N 4132 ("component of unchecked union cannot be of generic type", Comp); 4133 4134 elsif Needs_Finalization (Typ) then 4135 Error_Msg_N 4136 ("component of unchecked union cannot be controlled", Comp); 4137 4138 elsif Has_Task (Typ) then 4139 Error_Msg_N 4140 ("component of unchecked union cannot have tasks", Comp); 4141 end if; 4142 end Check_Component; 4143 4144 ----------------------------- 4145 -- Check_Declaration_Order -- 4146 ----------------------------- 4147 4148 procedure Check_Declaration_Order (First : Node_Id; Second : Node_Id) is 4149 procedure Check_Aspect_Specification_Order; 4150 -- Inspect the aspect specifications of the context to determine the 4151 -- proper order. 4152 4153 -------------------------------------- 4154 -- Check_Aspect_Specification_Order -- 4155 -------------------------------------- 4156 4157 procedure Check_Aspect_Specification_Order is 4158 Asp_First : constant Node_Id := Corresponding_Aspect (First); 4159 Asp_Second : constant Node_Id := Corresponding_Aspect (Second); 4160 Asp : Node_Id; 4161 4162 begin 4163 -- Both aspects must be part of the same aspect specification list 4164 4165 pragma Assert 4166 (List_Containing (Asp_First) = List_Containing (Asp_Second)); 4167 4168 -- Try to reach Second starting from First in a left to right 4169 -- traversal of the aspect specifications. 4170 4171 Asp := Next (Asp_First); 4172 while Present (Asp) loop 4173 4174 -- The order is ok, First is followed by Second 4175 4176 if Asp = Asp_Second then 4177 return; 4178 end if; 4179 4180 Next (Asp); 4181 end loop; 4182 4183 -- If we get here, then the aspects are out of order 4184 4185 Error_Msg_N ("aspect % cannot come after aspect %", First); 4186 end Check_Aspect_Specification_Order; 4187 4188 -- Local variables 4189 4190 Stmt : Node_Id; 4191 4192 -- Start of processing for Check_Declaration_Order 4193 4194 begin 4195 -- Cannot check the order if one of the pragmas is missing 4196 4197 if No (First) or else No (Second) then 4198 return; 4199 end if; 4200 4201 -- Set up the error names in case the order is incorrect 4202 4203 Error_Msg_Name_1 := Pragma_Name (First); 4204 Error_Msg_Name_2 := Pragma_Name (Second); 4205 4206 if From_Aspect_Specification (First) then 4207 4208 -- Both pragmas are actually aspects, check their declaration 4209 -- order in the associated aspect specification list. Otherwise 4210 -- First is an aspect and Second a source pragma. 4211 4212 if From_Aspect_Specification (Second) then 4213 Check_Aspect_Specification_Order; 4214 end if; 4215 4216 -- Abstract_States is a source pragma 4217 4218 else 4219 if From_Aspect_Specification (Second) then 4220 Error_Msg_N ("pragma % cannot come after aspect %", First); 4221 4222 -- Both pragmas are source constructs. Try to reach First from 4223 -- Second by traversing the declarations backwards. 4224 4225 else 4226 Stmt := Prev (Second); 4227 while Present (Stmt) loop 4228 4229 -- The order is ok, First is followed by Second 4230 4231 if Stmt = First then 4232 return; 4233 end if; 4234 4235 Prev (Stmt); 4236 end loop; 4237 4238 -- If we get here, then the pragmas are out of order 4239 4240 Error_Msg_N ("pragma % cannot come after pragma %", First); 4241 end if; 4242 end if; 4243 end Check_Declaration_Order; 4244 4245 ---------------------------- 4246 -- Check_Duplicate_Pragma -- 4247 ---------------------------- 4248 4249 procedure Check_Duplicate_Pragma (E : Entity_Id) is 4250 Id : Entity_Id := E; 4251 P : Node_Id; 4252 4253 begin 4254 -- Nothing to do if this pragma comes from an aspect specification, 4255 -- since we could not be duplicating a pragma, and we dealt with the 4256 -- case of duplicated aspects in Analyze_Aspect_Specifications. 4257 4258 if From_Aspect_Specification (N) then 4259 return; 4260 end if; 4261 4262 -- Otherwise current pragma may duplicate previous pragma or a 4263 -- previously given aspect specification or attribute definition 4264 -- clause for the same pragma. 4265 4266 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False); 4267 4268 if Present (P) then 4269 4270 -- If the entity is a type, then we have to make sure that the 4271 -- ostensible duplicate is not for a parent type from which this 4272 -- type is derived. 4273 4274 if Is_Type (E) then 4275 if Nkind (P) = N_Pragma then 4276 declare 4277 Args : constant List_Id := 4278 Pragma_Argument_Associations (P); 4279 begin 4280 if Present (Args) 4281 and then Is_Entity_Name (Expression (First (Args))) 4282 and then Is_Type (Entity (Expression (First (Args)))) 4283 and then Entity (Expression (First (Args))) /= E 4284 then 4285 return; 4286 end if; 4287 end; 4288 4289 elsif Nkind (P) = N_Aspect_Specification 4290 and then Is_Type (Entity (P)) 4291 and then Entity (P) /= E 4292 then 4293 return; 4294 end if; 4295 end if; 4296 4297 -- Here we have a definite duplicate 4298 4299 Error_Msg_Name_1 := Pragma_Name (N); 4300 Error_Msg_Sloc := Sloc (P); 4301 4302 -- For a single protected or a single task object, the error is 4303 -- issued on the original entity. 4304 4305 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then 4306 Id := Defining_Identifier (Original_Node (Parent (Id))); 4307 end if; 4308 4309 if Nkind (P) = N_Aspect_Specification 4310 or else From_Aspect_Specification (P) 4311 then 4312 Error_Msg_NE ("aspect% for & previously given#", N, Id); 4313 else 4314 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); 4315 end if; 4316 4317 raise Pragma_Exit; 4318 end if; 4319 end Check_Duplicate_Pragma; 4320 4321 ---------------------------------- 4322 -- Check_Duplicated_Export_Name -- 4323 ---------------------------------- 4324 4325 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is 4326 String_Val : constant String_Id := Strval (Nam); 4327 4328 begin 4329 -- We are only interested in the export case, and in the case of 4330 -- generics, it is the instance, not the template, that is the 4331 -- problem (the template will generate a warning in any case). 4332 4333 if not Inside_A_Generic 4334 and then (Prag_Id = Pragma_Export 4335 or else 4336 Prag_Id = Pragma_Export_Procedure 4337 or else 4338 Prag_Id = Pragma_Export_Valued_Procedure 4339 or else 4340 Prag_Id = Pragma_Export_Function) 4341 then 4342 for J in Externals.First .. Externals.Last loop 4343 if String_Equal (String_Val, Strval (Externals.Table (J))) then 4344 Error_Msg_Sloc := Sloc (Externals.Table (J)); 4345 Error_Msg_N ("external name duplicates name given#", Nam); 4346 exit; 4347 end if; 4348 end loop; 4349 4350 Externals.Append (Nam); 4351 end if; 4352 end Check_Duplicated_Export_Name; 4353 4354 ------------------------------------- 4355 -- Check_Expr_Is_Static_Expression -- 4356 ------------------------------------- 4357 4358 procedure Check_Expr_Is_Static_Expression 4359 (Expr : Node_Id; 4360 Typ : Entity_Id := Empty) 4361 is 4362 begin 4363 if Present (Typ) then 4364 Analyze_And_Resolve (Expr, Typ); 4365 else 4366 Analyze_And_Resolve (Expr); 4367 end if; 4368 4369 if Is_OK_Static_Expression (Expr) then 4370 return; 4371 4372 elsif Etype (Expr) = Any_Type then 4373 raise Pragma_Exit; 4374 4375 -- An interesting special case, if we have a string literal and we 4376 -- are in Ada 83 mode, then we allow it even though it will not be 4377 -- flagged as static. This allows the use of Ada 95 pragmas like 4378 -- Import in Ada 83 mode. They will of course be flagged with 4379 -- warnings as usual, but will not cause errors. 4380 4381 elsif Ada_Version = Ada_83 4382 and then Nkind (Expr) = N_String_Literal 4383 then 4384 return; 4385 4386 -- Static expression that raises Constraint_Error. This has already 4387 -- been flagged, so just exit from pragma processing. 4388 4389 elsif Is_Static_Expression (Expr) then 4390 raise Pragma_Exit; 4391 4392 -- Finally, we have a real error 4393 4394 else 4395 Error_Msg_Name_1 := Pname; 4396 4397 declare 4398 Msg : String := 4399 "argument for pragma% must be a static expression!"; 4400 begin 4401 Fix_Error (Msg); 4402 Flag_Non_Static_Expr (Msg, Expr); 4403 end; 4404 4405 raise Pragma_Exit; 4406 end if; 4407 end Check_Expr_Is_Static_Expression; 4408 4409 ------------------------- 4410 -- Check_First_Subtype -- 4411 ------------------------- 4412 4413 procedure Check_First_Subtype (Arg : Node_Id) is 4414 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 4415 Ent : constant Entity_Id := Entity (Argx); 4416 4417 begin 4418 if Is_First_Subtype (Ent) then 4419 null; 4420 4421 elsif Is_Type (Ent) then 4422 Error_Pragma_Arg 4423 ("pragma% cannot apply to subtype", Argx); 4424 4425 elsif Is_Object (Ent) then 4426 Error_Pragma_Arg 4427 ("pragma% cannot apply to object, requires a type", Argx); 4428 4429 else 4430 Error_Pragma_Arg 4431 ("pragma% cannot apply to&, requires a type", Argx); 4432 end if; 4433 end Check_First_Subtype; 4434 4435 ---------------------- 4436 -- Check_Identifier -- 4437 ---------------------- 4438 4439 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is 4440 begin 4441 if Present (Arg) 4442 and then Nkind (Arg) = N_Pragma_Argument_Association 4443 then 4444 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then 4445 Error_Msg_Name_1 := Pname; 4446 Error_Msg_Name_2 := Id; 4447 Error_Msg_N ("pragma% argument expects identifier%", Arg); 4448 raise Pragma_Exit; 4449 end if; 4450 end if; 4451 end Check_Identifier; 4452 4453 -------------------------------- 4454 -- Check_Identifier_Is_One_Of -- 4455 -------------------------------- 4456 4457 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 4458 begin 4459 if Present (Arg) 4460 and then Nkind (Arg) = N_Pragma_Argument_Association 4461 then 4462 if Chars (Arg) = No_Name then 4463 Error_Msg_Name_1 := Pname; 4464 Error_Msg_N ("pragma% argument expects an identifier", Arg); 4465 raise Pragma_Exit; 4466 4467 elsif Chars (Arg) /= N1 4468 and then Chars (Arg) /= N2 4469 then 4470 Error_Msg_Name_1 := Pname; 4471 Error_Msg_N ("invalid identifier for pragma% argument", Arg); 4472 raise Pragma_Exit; 4473 end if; 4474 end if; 4475 end Check_Identifier_Is_One_Of; 4476 4477 --------------------------- 4478 -- Check_In_Main_Program -- 4479 --------------------------- 4480 4481 procedure Check_In_Main_Program is 4482 P : constant Node_Id := Parent (N); 4483 4484 begin 4485 -- Must be at in subprogram body 4486 4487 if Nkind (P) /= N_Subprogram_Body then 4488 Error_Pragma ("% pragma allowed only in subprogram"); 4489 4490 -- Otherwise warn if obviously not main program 4491 4492 elsif Present (Parameter_Specifications (Specification (P))) 4493 or else not Is_Compilation_Unit (Defining_Entity (P)) 4494 then 4495 Error_Msg_Name_1 := Pname; 4496 Error_Msg_N 4497 ("??pragma% is only effective in main program", N); 4498 end if; 4499 end Check_In_Main_Program; 4500 4501 --------------------------------------- 4502 -- Check_Interrupt_Or_Attach_Handler -- 4503 --------------------------------------- 4504 4505 procedure Check_Interrupt_Or_Attach_Handler is 4506 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); 4507 Handler_Proc, Proc_Scope : Entity_Id; 4508 4509 begin 4510 Analyze (Arg1_X); 4511 4512 if Prag_Id = Pragma_Interrupt_Handler then 4513 Check_Restriction (No_Dynamic_Attachment, N); 4514 end if; 4515 4516 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 4517 Proc_Scope := Scope (Handler_Proc); 4518 4519 -- On AAMP only, a pragma Interrupt_Handler is supported for 4520 -- nonprotected parameterless procedures. 4521 4522 if not AAMP_On_Target 4523 or else Prag_Id = Pragma_Attach_Handler 4524 then 4525 if Ekind (Proc_Scope) /= E_Protected_Type then 4526 Error_Pragma_Arg 4527 ("argument of pragma% must be protected procedure", Arg1); 4528 end if; 4529 4530 -- For pragma case (as opposed to access case), check placement. 4531 -- We don't need to do that for aspects, because we have the 4532 -- check that they are apply an appropriate procedure. 4533 4534 if not From_Aspect_Specification (N) 4535 and then Parent (N) /= Protected_Definition (Parent (Proc_Scope)) 4536 then 4537 Error_Pragma ("pragma% must be in protected definition"); 4538 end if; 4539 end if; 4540 4541 if not Is_Library_Level_Entity (Proc_Scope) 4542 or else (AAMP_On_Target 4543 and then not Is_Library_Level_Entity (Handler_Proc)) 4544 then 4545 Error_Pragma_Arg 4546 ("argument for pragma% must be library level entity", Arg1); 4547 end if; 4548 4549 -- AI05-0033: A pragma cannot appear within a generic body, because 4550 -- instance can be in a nested scope. The check that protected type 4551 -- is itself a library-level declaration is done elsewhere. 4552 4553 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly 4554 -- handle code prior to AI-0033. Analysis tools typically are not 4555 -- interested in this pragma in any case, so no need to worry too 4556 -- much about its placement. 4557 4558 if Inside_A_Generic then 4559 if Ekind (Scope (Current_Scope)) = E_Generic_Package 4560 and then In_Package_Body (Scope (Current_Scope)) 4561 and then not Relaxed_RM_Semantics 4562 then 4563 Error_Pragma ("pragma% cannot be used inside a generic"); 4564 end if; 4565 end if; 4566 end Check_Interrupt_Or_Attach_Handler; 4567 4568 --------------------------------- 4569 -- Check_Loop_Pragma_Placement -- 4570 --------------------------------- 4571 4572 procedure Check_Loop_Pragma_Placement is 4573 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id); 4574 -- Verify whether the current pragma is properly grouped with other 4575 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the 4576 -- related loop where the pragma appears. 4577 4578 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean; 4579 -- Determine whether an arbitrary statement Stmt denotes pragma 4580 -- Loop_Invariant or Loop_Variant. 4581 4582 procedure Placement_Error (Constr : Node_Id); 4583 pragma No_Return (Placement_Error); 4584 -- Node Constr denotes the last loop restricted construct before we 4585 -- encountered an illegal relation between enclosing constructs. Emit 4586 -- an error depending on what Constr was. 4587 4588 -------------------------------- 4589 -- Check_Loop_Pragma_Grouping -- 4590 -------------------------------- 4591 4592 procedure Check_Loop_Pragma_Grouping (Loop_Stmt : Node_Id) is 4593 Stop_Search : exception; 4594 -- This exception is used to terminate the recursive descent of 4595 -- routine Check_Grouping. 4596 4597 procedure Check_Grouping (L : List_Id); 4598 -- Find the first group of pragmas in list L and if successful, 4599 -- ensure that the current pragma is part of that group. The 4600 -- routine raises Stop_Search once such a check is performed to 4601 -- halt the recursive descent. 4602 4603 procedure Grouping_Error (Prag : Node_Id); 4604 pragma No_Return (Grouping_Error); 4605 -- Emit an error concerning the current pragma indicating that it 4606 -- should be placed after pragma Prag. 4607 4608 -------------------- 4609 -- Check_Grouping -- 4610 -------------------- 4611 4612 procedure Check_Grouping (L : List_Id) is 4613 HSS : Node_Id; 4614 Prag : Node_Id; 4615 Stmt : Node_Id; 4616 4617 begin 4618 -- Inspect the list of declarations or statements looking for 4619 -- the first grouping of pragmas: 4620 4621 -- loop 4622 -- pragma Loop_Invariant ...; 4623 -- pragma Loop_Variant ...; 4624 -- . . . -- (1) 4625 -- pragma Loop_Variant ...; -- current pragma 4626 4627 -- If the current pragma is not in the grouping, then it must 4628 -- either appear in a different declarative or statement list 4629 -- or the construct at (1) is separating the pragma from the 4630 -- grouping. 4631 4632 Stmt := First (L); 4633 while Present (Stmt) loop 4634 4635 -- Pragmas Loop_Invariant and Loop_Variant may only appear 4636 -- inside a loop or a block housed inside a loop. Inspect 4637 -- the declarations and statements of the block as they may 4638 -- contain the first grouping. 4639 4640 if Nkind (Stmt) = N_Block_Statement then 4641 HSS := Handled_Statement_Sequence (Stmt); 4642 4643 Check_Grouping (Declarations (Stmt)); 4644 4645 if Present (HSS) then 4646 Check_Grouping (Statements (HSS)); 4647 end if; 4648 4649 -- First pragma of the first topmost grouping has been found 4650 4651 elsif Is_Loop_Pragma (Stmt) then 4652 4653 -- The group and the current pragma are not in the same 4654 -- declarative or statement list. 4655 4656 if List_Containing (Stmt) /= List_Containing (N) then 4657 Grouping_Error (Stmt); 4658 4659 -- Try to reach the current pragma from the first pragma 4660 -- of the grouping while skipping other members: 4661 4662 -- pragma Loop_Invariant ...; -- first pragma 4663 -- pragma Loop_Variant ...; -- member 4664 -- . . . 4665 -- pragma Loop_Variant ...; -- current pragma 4666 4667 else 4668 while Present (Stmt) loop 4669 4670 -- The current pragma is either the first pragma 4671 -- of the group or is a member of the group. Stop 4672 -- the search as the placement is legal. 4673 4674 if Stmt = N then 4675 raise Stop_Search; 4676 4677 -- Skip group members, but keep track of the last 4678 -- pragma in the group. 4679 4680 elsif Is_Loop_Pragma (Stmt) then 4681 Prag := Stmt; 4682 4683 -- A non-pragma is separating the group from the 4684 -- current pragma, the placement is erroneous. 4685 4686 else 4687 Grouping_Error (Prag); 4688 end if; 4689 4690 Next (Stmt); 4691 end loop; 4692 4693 -- If the traversal did not reach the current pragma, 4694 -- then the list must be malformed. 4695 4696 raise Program_Error; 4697 end if; 4698 end if; 4699 4700 Next (Stmt); 4701 end loop; 4702 end Check_Grouping; 4703 4704 -------------------- 4705 -- Grouping_Error -- 4706 -------------------- 4707 4708 procedure Grouping_Error (Prag : Node_Id) is 4709 begin 4710 Error_Msg_Sloc := Sloc (Prag); 4711 Error_Pragma ("pragma% must appear next to pragma#"); 4712 end Grouping_Error; 4713 4714 -- Start of processing for Check_Loop_Pragma_Grouping 4715 4716 begin 4717 -- Inspect the statements of the loop or nested blocks housed 4718 -- within to determine whether the current pragma is part of the 4719 -- first topmost grouping of Loop_Invariant and Loop_Variant. 4720 4721 Check_Grouping (Statements (Loop_Stmt)); 4722 4723 exception 4724 when Stop_Search => null; 4725 end Check_Loop_Pragma_Grouping; 4726 4727 -------------------- 4728 -- Is_Loop_Pragma -- 4729 -------------------- 4730 4731 function Is_Loop_Pragma (Stmt : Node_Id) return Boolean is 4732 begin 4733 -- Inspect the original node as Loop_Invariant and Loop_Variant 4734 -- pragmas are rewritten to null when assertions are disabled. 4735 4736 if Nkind (Original_Node (Stmt)) = N_Pragma then 4737 return 4738 Nam_In (Pragma_Name (Original_Node (Stmt)), 4739 Name_Loop_Invariant, 4740 Name_Loop_Variant); 4741 else 4742 return False; 4743 end if; 4744 end Is_Loop_Pragma; 4745 4746 --------------------- 4747 -- Placement_Error -- 4748 --------------------- 4749 4750 procedure Placement_Error (Constr : Node_Id) is 4751 LA : constant String := " with Loop_Entry"; 4752 4753 begin 4754 if Prag_Id = Pragma_Assert then 4755 Error_Msg_String (1 .. LA'Length) := LA; 4756 Error_Msg_Strlen := LA'Length; 4757 else 4758 Error_Msg_Strlen := 0; 4759 end if; 4760 4761 if Nkind (Constr) = N_Pragma then 4762 Error_Pragma 4763 ("pragma %~ must appear immediately within the statements " 4764 & "of a loop"); 4765 else 4766 Error_Pragma_Arg 4767 ("block containing pragma %~ must appear immediately within " 4768 & "the statements of a loop", Constr); 4769 end if; 4770 end Placement_Error; 4771 4772 -- Local declarations 4773 4774 Prev : Node_Id; 4775 Stmt : Node_Id; 4776 4777 -- Start of processing for Check_Loop_Pragma_Placement 4778 4779 begin 4780 -- Check that pragma appears immediately within a loop statement, 4781 -- ignoring intervening block statements. 4782 4783 Prev := N; 4784 Stmt := Parent (N); 4785 while Present (Stmt) loop 4786 4787 -- The pragma or previous block must appear immediately within the 4788 -- current block's declarative or statement part. 4789 4790 if Nkind (Stmt) = N_Block_Statement then 4791 if (No (Declarations (Stmt)) 4792 or else List_Containing (Prev) /= Declarations (Stmt)) 4793 and then 4794 List_Containing (Prev) /= 4795 Statements (Handled_Statement_Sequence (Stmt)) 4796 then 4797 Placement_Error (Prev); 4798 return; 4799 4800 -- Keep inspecting the parents because we are now within a 4801 -- chain of nested blocks. 4802 4803 else 4804 Prev := Stmt; 4805 Stmt := Parent (Stmt); 4806 end if; 4807 4808 -- The pragma or previous block must appear immediately within the 4809 -- statements of the loop. 4810 4811 elsif Nkind (Stmt) = N_Loop_Statement then 4812 if List_Containing (Prev) /= Statements (Stmt) then 4813 Placement_Error (Prev); 4814 end if; 4815 4816 -- Stop the traversal because we reached the innermost loop 4817 -- regardless of whether we encountered an error or not. 4818 4819 exit; 4820 4821 -- Ignore a handled statement sequence. Note that this node may 4822 -- be related to a subprogram body in which case we will emit an 4823 -- error on the next iteration of the search. 4824 4825 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then 4826 Stmt := Parent (Stmt); 4827 4828 -- Any other statement breaks the chain from the pragma to the 4829 -- loop. 4830 4831 else 4832 Placement_Error (Prev); 4833 return; 4834 end if; 4835 end loop; 4836 4837 -- Check that the current pragma Loop_Invariant or Loop_Variant is 4838 -- grouped together with other such pragmas. 4839 4840 if Is_Loop_Pragma (N) then 4841 4842 -- The previous check should have located the related loop 4843 4844 pragma Assert (Nkind (Stmt) = N_Loop_Statement); 4845 Check_Loop_Pragma_Grouping (Stmt); 4846 end if; 4847 end Check_Loop_Pragma_Placement; 4848 4849 ------------------------------------------- 4850 -- Check_Is_In_Decl_Part_Or_Package_Spec -- 4851 ------------------------------------------- 4852 4853 procedure Check_Is_In_Decl_Part_Or_Package_Spec is 4854 P : Node_Id; 4855 4856 begin 4857 P := Parent (N); 4858 loop 4859 if No (P) then 4860 exit; 4861 4862 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then 4863 exit; 4864 4865 elsif Nkind_In (P, N_Package_Specification, 4866 N_Block_Statement) 4867 then 4868 return; 4869 4870 -- Note: the following tests seem a little peculiar, because 4871 -- they test for bodies, but if we were in the statement part 4872 -- of the body, we would already have hit the handled statement 4873 -- sequence, so the only way we get here is by being in the 4874 -- declarative part of the body. 4875 4876 elsif Nkind_In (P, N_Subprogram_Body, 4877 N_Package_Body, 4878 N_Task_Body, 4879 N_Entry_Body) 4880 then 4881 return; 4882 end if; 4883 4884 P := Parent (P); 4885 end loop; 4886 4887 Error_Pragma ("pragma% is not in declarative part or package spec"); 4888 end Check_Is_In_Decl_Part_Or_Package_Spec; 4889 4890 ------------------------- 4891 -- Check_No_Identifier -- 4892 ------------------------- 4893 4894 procedure Check_No_Identifier (Arg : Node_Id) is 4895 begin 4896 if Nkind (Arg) = N_Pragma_Argument_Association 4897 and then Chars (Arg) /= No_Name 4898 then 4899 Error_Pragma_Arg_Ident 4900 ("pragma% does not permit identifier& here", Arg); 4901 end if; 4902 end Check_No_Identifier; 4903 4904 -------------------------- 4905 -- Check_No_Identifiers -- 4906 -------------------------- 4907 4908 procedure Check_No_Identifiers is 4909 Arg_Node : Node_Id; 4910 begin 4911 Arg_Node := Arg1; 4912 for J in 1 .. Arg_Count loop 4913 Check_No_Identifier (Arg_Node); 4914 Next (Arg_Node); 4915 end loop; 4916 end Check_No_Identifiers; 4917 4918 ------------------------ 4919 -- Check_No_Link_Name -- 4920 ------------------------ 4921 4922 procedure Check_No_Link_Name is 4923 begin 4924 if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then 4925 Arg4 := Arg3; 4926 end if; 4927 4928 if Present (Arg4) then 4929 Error_Pragma_Arg 4930 ("Link_Name argument not allowed for Import Intrinsic", Arg4); 4931 end if; 4932 end Check_No_Link_Name; 4933 4934 ------------------------------- 4935 -- Check_Optional_Identifier -- 4936 ------------------------------- 4937 4938 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 4939 begin 4940 if Present (Arg) 4941 and then Nkind (Arg) = N_Pragma_Argument_Association 4942 and then Chars (Arg) /= No_Name 4943 then 4944 if Chars (Arg) /= Id then 4945 Error_Msg_Name_1 := Pname; 4946 Error_Msg_Name_2 := Id; 4947 Error_Msg_N ("pragma% argument expects identifier%", Arg); 4948 raise Pragma_Exit; 4949 end if; 4950 end if; 4951 end Check_Optional_Identifier; 4952 4953 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is 4954 begin 4955 Name_Buffer (1 .. Id'Length) := Id; 4956 Name_Len := Id'Length; 4957 Check_Optional_Identifier (Arg, Name_Find); 4958 end Check_Optional_Identifier; 4959 4960 -------------------- 4961 -- Check_Pre_Post -- 4962 -------------------- 4963 4964 procedure Check_Pre_Post is 4965 P : Node_Id; 4966 PO : Node_Id; 4967 4968 begin 4969 if not Is_List_Member (N) then 4970 Pragma_Misplaced; 4971 end if; 4972 4973 -- If we are within an inlined body, the legality of the pragma 4974 -- has been checked already. 4975 4976 if In_Inlined_Body then 4977 return; 4978 end if; 4979 4980 -- Search prior declarations 4981 4982 P := N; 4983 while Present (Prev (P)) loop 4984 P := Prev (P); 4985 4986 -- If the previous node is a generic subprogram, do not go to to 4987 -- the original node, which is the unanalyzed tree: we need to 4988 -- attach the pre/postconditions to the analyzed version at this 4989 -- point. They get propagated to the original tree when analyzing 4990 -- the corresponding body. 4991 4992 if Nkind (P) not in N_Generic_Declaration then 4993 PO := Original_Node (P); 4994 else 4995 PO := P; 4996 end if; 4997 4998 -- Skip past prior pragma 4999 5000 if Nkind (PO) = N_Pragma then 5001 null; 5002 5003 -- Skip stuff not coming from source 5004 5005 elsif not Comes_From_Source (PO) then 5006 5007 -- The condition may apply to a subprogram instantiation 5008 5009 if Nkind (PO) = N_Subprogram_Declaration 5010 and then Present (Generic_Parent (Specification (PO))) 5011 then 5012 return; 5013 5014 elsif Nkind (PO) = N_Subprogram_Declaration 5015 and then In_Instance 5016 then 5017 return; 5018 5019 -- For all other cases of non source code, do nothing 5020 5021 else 5022 null; 5023 end if; 5024 5025 -- Only remaining possibility is subprogram declaration 5026 5027 else 5028 return; 5029 end if; 5030 end loop; 5031 5032 -- If we fall through loop, pragma is at start of list, so see if it 5033 -- is at the start of declarations of a subprogram body. 5034 5035 PO := Parent (N); 5036 5037 if Nkind (PO) = N_Subprogram_Body 5038 and then List_Containing (N) = Declarations (PO) 5039 then 5040 -- This is only allowed if there is no separate specification 5041 5042 if Present (Corresponding_Spec (PO)) then 5043 Error_Pragma 5044 ("pragma% must apply to subprogram specification"); 5045 end if; 5046 5047 return; 5048 end if; 5049 end Check_Pre_Post; 5050 5051 -------------------------------------- 5052 -- Check_Precondition_Postcondition -- 5053 -------------------------------------- 5054 5055 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is 5056 P : Node_Id; 5057 PO : Node_Id; 5058 5059 procedure Chain_PPC (PO : Node_Id); 5060 -- If PO is an entry or a [generic] subprogram declaration node, then 5061 -- the precondition/postcondition applies to this subprogram and the 5062 -- processing for the pragma is completed. Otherwise the pragma is 5063 -- misplaced. 5064 5065 --------------- 5066 -- Chain_PPC -- 5067 --------------- 5068 5069 procedure Chain_PPC (PO : Node_Id) is 5070 S : Entity_Id; 5071 5072 begin 5073 if Nkind (PO) = N_Abstract_Subprogram_Declaration then 5074 if not From_Aspect_Specification (N) then 5075 Error_Pragma 5076 ("pragma% cannot be applied to abstract subprogram"); 5077 5078 elsif Class_Present (N) then 5079 null; 5080 5081 else 5082 Error_Pragma 5083 ("aspect % requires ''Class for abstract subprogram"); 5084 end if; 5085 5086 -- AI05-0230: The same restriction applies to null procedures. For 5087 -- compatibility with earlier uses of the Ada pragma, apply this 5088 -- rule only to aspect specifications. 5089 5090 -- The above discrepency needs documentation. Robert is dubious 5091 -- about whether it is a good idea ??? 5092 5093 elsif Nkind (PO) = N_Subprogram_Declaration 5094 and then Nkind (Specification (PO)) = N_Procedure_Specification 5095 and then Null_Present (Specification (PO)) 5096 and then From_Aspect_Specification (N) 5097 and then not Class_Present (N) 5098 then 5099 Error_Pragma 5100 ("aspect % requires ''Class for null procedure"); 5101 5102 -- Pre/postconditions are legal on a subprogram body if it is not 5103 -- a completion of a declaration. They are also legal on a stub 5104 -- with no previous declarations (this is checked when processing 5105 -- the corresponding aspects). 5106 5107 elsif Nkind (PO) = N_Subprogram_Body 5108 and then Acts_As_Spec (PO) 5109 then 5110 null; 5111 5112 elsif Nkind (PO) = N_Subprogram_Body_Stub then 5113 null; 5114 5115 elsif not Nkind_In (PO, N_Subprogram_Declaration, 5116 N_Expression_Function, 5117 N_Generic_Subprogram_Declaration, 5118 N_Entry_Declaration) 5119 then 5120 Pragma_Misplaced; 5121 end if; 5122 5123 -- Here if we have [generic] subprogram or entry declaration 5124 5125 if Nkind (PO) = N_Entry_Declaration then 5126 S := Defining_Entity (PO); 5127 else 5128 S := Defining_Unit_Name (Specification (PO)); 5129 5130 if Nkind (S) = N_Defining_Program_Unit_Name then 5131 S := Defining_Identifier (S); 5132 end if; 5133 end if; 5134 5135 -- Note: we do not analyze the pragma at this point. Instead we 5136 -- delay this analysis until the end of the declarative part in 5137 -- which the pragma appears. This implements the required delay 5138 -- in this analysis, allowing forward references. The analysis 5139 -- happens at the end of Analyze_Declarations. 5140 5141 -- Chain spec PPC pragma to list for subprogram 5142 5143 Add_Contract_Item (N, S); 5144 5145 -- Return indicating spec case 5146 5147 In_Body := False; 5148 return; 5149 end Chain_PPC; 5150 5151 -- Start of processing for Check_Precondition_Postcondition 5152 5153 begin 5154 if not Is_List_Member (N) then 5155 Pragma_Misplaced; 5156 end if; 5157 5158 -- Preanalyze message argument if present. Visibility in this 5159 -- argument is established at the point of pragma occurrence. 5160 5161 if Arg_Count = 2 then 5162 Check_Optional_Identifier (Arg2, Name_Message); 5163 Preanalyze_Spec_Expression 5164 (Get_Pragma_Arg (Arg2), Standard_String); 5165 end if; 5166 5167 -- For a pragma PPC in the extended main source unit, record enabled 5168 -- status in SCO. 5169 5170 if Is_Checked (N) and then not Split_PPC (N) then 5171 Set_SCO_Pragma_Enabled (Loc); 5172 end if; 5173 5174 -- If we are within an inlined body, the legality of the pragma 5175 -- has been checked already. 5176 5177 if In_Inlined_Body then 5178 In_Body := True; 5179 return; 5180 end if; 5181 5182 -- Search prior declarations 5183 5184 P := N; 5185 while Present (Prev (P)) loop 5186 P := Prev (P); 5187 5188 -- If the previous node is a generic subprogram, do not go to to 5189 -- the original node, which is the unanalyzed tree: we need to 5190 -- attach the pre/postconditions to the analyzed version at this 5191 -- point. They get propagated to the original tree when analyzing 5192 -- the corresponding body. 5193 5194 if Nkind (P) not in N_Generic_Declaration then 5195 PO := Original_Node (P); 5196 else 5197 PO := P; 5198 end if; 5199 5200 -- Skip past prior pragma 5201 5202 if Nkind (PO) = N_Pragma then 5203 null; 5204 5205 -- Skip stuff not coming from source 5206 5207 elsif not Comes_From_Source (PO) then 5208 5209 -- The condition may apply to a subprogram instantiation 5210 5211 if Nkind (PO) = N_Subprogram_Declaration 5212 and then Present (Generic_Parent (Specification (PO))) 5213 then 5214 Chain_PPC (PO); 5215 return; 5216 5217 elsif Nkind (PO) = N_Subprogram_Declaration 5218 and then In_Instance 5219 then 5220 Chain_PPC (PO); 5221 return; 5222 5223 -- For all other cases of non source code, do nothing 5224 5225 else 5226 null; 5227 end if; 5228 5229 -- Only remaining possibility is subprogram declaration 5230 5231 else 5232 Chain_PPC (PO); 5233 return; 5234 end if; 5235 end loop; 5236 5237 -- If we fall through loop, pragma is at start of list, so see if it 5238 -- is at the start of declarations of a subprogram body. 5239 5240 PO := Parent (N); 5241 5242 if Nkind (PO) = N_Subprogram_Body 5243 and then List_Containing (N) = Declarations (PO) 5244 then 5245 if Operating_Mode /= Generate_Code or else Inside_A_Generic then 5246 5247 -- Analyze pragma expression for correctness and for ASIS use 5248 5249 Preanalyze_Assert_Expression 5250 (Get_Pragma_Arg (Arg1), Standard_Boolean); 5251 5252 -- In ASIS mode, for a pragma generated from a source aspect, 5253 -- also analyze the original aspect expression. 5254 5255 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then 5256 Preanalyze_Assert_Expression 5257 (Expression (Corresponding_Aspect (N)), Standard_Boolean); 5258 end if; 5259 end if; 5260 5261 -- Retain copy of the pre/postcondition pragma in GNATprove mode. 5262 -- The copy is needed because the pragma is expanded into other 5263 -- constructs which are not acceptable in the N_Contract node. 5264 5265 if Acts_As_Spec (PO) 5266 and then GNATprove_Mode 5267 then 5268 declare 5269 Prag : constant Node_Id := New_Copy_Tree (N); 5270 5271 begin 5272 -- Preanalyze the pragma 5273 5274 Preanalyze_Assert_Expression 5275 (Get_Pragma_Arg 5276 (First (Pragma_Argument_Associations (Prag))), 5277 Standard_Boolean); 5278 5279 -- Preanalyze the corresponding aspect (if any) 5280 5281 if Present (Corresponding_Aspect (Prag)) then 5282 Preanalyze_Assert_Expression 5283 (Expression (Corresponding_Aspect (Prag)), 5284 Standard_Boolean); 5285 end if; 5286 5287 -- Chain the copy on the contract of the body 5288 5289 Add_Contract_Item 5290 (Prag, Defining_Unit_Name (Specification (PO))); 5291 end; 5292 end if; 5293 5294 In_Body := True; 5295 return; 5296 5297 -- See if it is in the pragmas after a library level subprogram 5298 5299 elsif Nkind (PO) = N_Compilation_Unit_Aux then 5300 5301 -- In GNATprove mode, analyze pragma expression for correctness, 5302 -- as it is not expanded later. Ditto in ASIS_Mode where there is 5303 -- no later point at which the aspect will be analyzed. 5304 5305 if GNATprove_Mode or ASIS_Mode then 5306 Analyze_Pre_Post_Condition_In_Decl_Part 5307 (N, Defining_Entity (Unit (Parent (PO)))); 5308 end if; 5309 5310 Chain_PPC (Unit (Parent (PO))); 5311 return; 5312 end if; 5313 5314 -- If we fall through, pragma was misplaced 5315 5316 Pragma_Misplaced; 5317 end Check_Precondition_Postcondition; 5318 5319 ----------------------------- 5320 -- Check_Static_Constraint -- 5321 ----------------------------- 5322 5323 -- Note: for convenience in writing this procedure, in addition to 5324 -- the officially (i.e. by spec) allowed argument which is always a 5325 -- constraint, it also allows ranges and discriminant associations. 5326 -- Above is not clear ??? 5327 5328 procedure Check_Static_Constraint (Constr : Node_Id) is 5329 5330 procedure Require_Static (E : Node_Id); 5331 -- Require given expression to be static expression 5332 5333 -------------------- 5334 -- Require_Static -- 5335 -------------------- 5336 5337 procedure Require_Static (E : Node_Id) is 5338 begin 5339 if not Is_OK_Static_Expression (E) then 5340 Flag_Non_Static_Expr 5341 ("non-static constraint not allowed in Unchecked_Union!", E); 5342 raise Pragma_Exit; 5343 end if; 5344 end Require_Static; 5345 5346 -- Start of processing for Check_Static_Constraint 5347 5348 begin 5349 case Nkind (Constr) is 5350 when N_Discriminant_Association => 5351 Require_Static (Expression (Constr)); 5352 5353 when N_Range => 5354 Require_Static (Low_Bound (Constr)); 5355 Require_Static (High_Bound (Constr)); 5356 5357 when N_Attribute_Reference => 5358 Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); 5359 Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); 5360 5361 when N_Range_Constraint => 5362 Check_Static_Constraint (Range_Expression (Constr)); 5363 5364 when N_Index_Or_Discriminant_Constraint => 5365 declare 5366 IDC : Entity_Id; 5367 begin 5368 IDC := First (Constraints (Constr)); 5369 while Present (IDC) loop 5370 Check_Static_Constraint (IDC); 5371 Next (IDC); 5372 end loop; 5373 end; 5374 5375 when others => 5376 null; 5377 end case; 5378 end Check_Static_Constraint; 5379 5380 --------------------- 5381 -- Check_Test_Case -- 5382 --------------------- 5383 5384 procedure Check_Test_Case is 5385 P : Node_Id; 5386 PO : Node_Id; 5387 5388 procedure Chain_CTC (PO : Node_Id); 5389 -- If PO is a [generic] subprogram declaration node, then the 5390 -- test-case applies to this subprogram and the processing for 5391 -- the pragma is completed. Otherwise the pragma is misplaced. 5392 5393 --------------- 5394 -- Chain_CTC -- 5395 --------------- 5396 5397 procedure Chain_CTC (PO : Node_Id) is 5398 S : Entity_Id; 5399 5400 begin 5401 if Nkind (PO) = N_Abstract_Subprogram_Declaration then 5402 Error_Pragma 5403 ("pragma% cannot be applied to abstract subprogram"); 5404 5405 elsif Nkind (PO) = N_Entry_Declaration then 5406 Error_Pragma ("pragma% cannot be applied to entry"); 5407 5408 elsif not Nkind_In (PO, N_Subprogram_Declaration, 5409 N_Generic_Subprogram_Declaration) 5410 then 5411 Pragma_Misplaced; 5412 end if; 5413 5414 -- Here if we have [generic] subprogram declaration 5415 5416 S := Defining_Unit_Name (Specification (PO)); 5417 5418 -- Note: we do not analyze the pragma at this point. Instead we 5419 -- delay this analysis until the end of the declarative part in 5420 -- which the pragma appears. This implements the required delay 5421 -- in this analysis, allowing forward references. The analysis 5422 -- happens at the end of Analyze_Declarations. 5423 5424 -- There should not be another test-case with the same name 5425 -- associated to this subprogram. 5426 5427 declare 5428 Name : constant String_Id := Get_Name_From_CTC_Pragma (N); 5429 CTC : Node_Id; 5430 5431 begin 5432 CTC := Contract_Test_Cases (Contract (S)); 5433 while Present (CTC) loop 5434 5435 -- Omit pragma Contract_Cases because it does not introduce 5436 -- a unique case name and it does not follow the syntax of 5437 -- Test_Case. 5438 5439 if Pragma_Name (CTC) = Name_Contract_Cases then 5440 null; 5441 5442 elsif String_Equal 5443 (Name, Get_Name_From_CTC_Pragma (CTC)) 5444 then 5445 Error_Msg_Sloc := Sloc (CTC); 5446 Error_Pragma ("name for pragma% is already used#"); 5447 end if; 5448 5449 CTC := Next_Pragma (CTC); 5450 end loop; 5451 end; 5452 5453 -- Chain spec CTC pragma to list for subprogram 5454 5455 Add_Contract_Item (N, S); 5456 end Chain_CTC; 5457 5458 -- Start of processing for Check_Test_Case 5459 5460 begin 5461 -- First check pragma arguments 5462 5463 Check_At_Least_N_Arguments (2); 5464 Check_At_Most_N_Arguments (4); 5465 Check_Arg_Order 5466 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); 5467 5468 Check_Optional_Identifier (Arg1, Name_Name); 5469 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 5470 5471 -- In ASIS mode, for a pragma generated from a source aspect, also 5472 -- analyze the original aspect expression. 5473 5474 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then 5475 Check_Expr_Is_Static_Expression 5476 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); 5477 end if; 5478 5479 Check_Optional_Identifier (Arg2, Name_Mode); 5480 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); 5481 5482 if Arg_Count = 4 then 5483 Check_Identifier (Arg3, Name_Requires); 5484 Check_Identifier (Arg4, Name_Ensures); 5485 5486 elsif Arg_Count = 3 then 5487 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); 5488 end if; 5489 5490 -- Check pragma placement 5491 5492 if not Is_List_Member (N) then 5493 Pragma_Misplaced; 5494 end if; 5495 5496 -- Test-case should only appear in package spec unit 5497 5498 if Get_Source_Unit (N) = No_Unit 5499 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))), 5500 N_Package_Declaration, 5501 N_Generic_Package_Declaration) 5502 then 5503 Pragma_Misplaced; 5504 end if; 5505 5506 -- Search prior declarations 5507 5508 P := N; 5509 while Present (Prev (P)) loop 5510 P := Prev (P); 5511 5512 -- If the previous node is a generic subprogram, do not go to to 5513 -- the original node, which is the unanalyzed tree: we need to 5514 -- attach the test-case to the analyzed version at this point. 5515 -- They get propagated to the original tree when analyzing the 5516 -- corresponding body. 5517 5518 if Nkind (P) not in N_Generic_Declaration then 5519 PO := Original_Node (P); 5520 else 5521 PO := P; 5522 end if; 5523 5524 -- Skip past prior pragma 5525 5526 if Nkind (PO) = N_Pragma then 5527 null; 5528 5529 -- Skip stuff not coming from source 5530 5531 elsif not Comes_From_Source (PO) then 5532 null; 5533 5534 -- Only remaining possibility is subprogram declaration. First 5535 -- check that it is declared directly in a package declaration. 5536 -- This may be either the package declaration for the current unit 5537 -- being defined or a local package declaration. 5538 5539 elsif not Present (Parent (Parent (PO))) 5540 or else not Present (Parent (Parent (Parent (PO)))) 5541 or else not Nkind_In (Parent (Parent (PO)), 5542 N_Package_Declaration, 5543 N_Generic_Package_Declaration) 5544 then 5545 Pragma_Misplaced; 5546 5547 else 5548 Chain_CTC (PO); 5549 return; 5550 end if; 5551 end loop; 5552 5553 -- If we fall through, pragma was misplaced 5554 5555 Pragma_Misplaced; 5556 end Check_Test_Case; 5557 5558 -------------------------------------- 5559 -- Check_Valid_Configuration_Pragma -- 5560 -------------------------------------- 5561 5562 -- A configuration pragma must appear in the context clause of a 5563 -- compilation unit, and only other pragmas may precede it. Note that 5564 -- the test also allows use in a configuration pragma file. 5565 5566 procedure Check_Valid_Configuration_Pragma is 5567 begin 5568 if not Is_Configuration_Pragma then 5569 Error_Pragma ("incorrect placement for configuration pragma%"); 5570 end if; 5571 end Check_Valid_Configuration_Pragma; 5572 5573 ------------------------------------- 5574 -- Check_Valid_Library_Unit_Pragma -- 5575 ------------------------------------- 5576 5577 procedure Check_Valid_Library_Unit_Pragma is 5578 Plist : List_Id; 5579 Parent_Node : Node_Id; 5580 Unit_Name : Entity_Id; 5581 Unit_Kind : Node_Kind; 5582 Unit_Node : Node_Id; 5583 Sindex : Source_File_Index; 5584 5585 begin 5586 if not Is_List_Member (N) then 5587 Pragma_Misplaced; 5588 5589 else 5590 Plist := List_Containing (N); 5591 Parent_Node := Parent (Plist); 5592 5593 if Parent_Node = Empty then 5594 Pragma_Misplaced; 5595 5596 -- Case of pragma appearing after a compilation unit. In this case 5597 -- it must have an argument with the corresponding name and must 5598 -- be part of the following pragmas of its parent. 5599 5600 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then 5601 if Plist /= Pragmas_After (Parent_Node) then 5602 Pragma_Misplaced; 5603 5604 elsif Arg_Count = 0 then 5605 Error_Pragma 5606 ("argument required if outside compilation unit"); 5607 5608 else 5609 Check_No_Identifiers; 5610 Check_Arg_Count (1); 5611 Unit_Node := Unit (Parent (Parent_Node)); 5612 Unit_Kind := Nkind (Unit_Node); 5613 5614 Analyze (Get_Pragma_Arg (Arg1)); 5615 5616 if Unit_Kind = N_Generic_Subprogram_Declaration 5617 or else Unit_Kind = N_Subprogram_Declaration 5618 then 5619 Unit_Name := Defining_Entity (Unit_Node); 5620 5621 elsif Unit_Kind in N_Generic_Instantiation then 5622 Unit_Name := Defining_Entity (Unit_Node); 5623 5624 else 5625 Unit_Name := Cunit_Entity (Current_Sem_Unit); 5626 end if; 5627 5628 if Chars (Unit_Name) /= 5629 Chars (Entity (Get_Pragma_Arg (Arg1))) 5630 then 5631 Error_Pragma_Arg 5632 ("pragma% argument is not current unit name", Arg1); 5633 end if; 5634 5635 if Ekind (Unit_Name) = E_Package 5636 and then Present (Renamed_Entity (Unit_Name)) 5637 then 5638 Error_Pragma ("pragma% not allowed for renamed package"); 5639 end if; 5640 end if; 5641 5642 -- Pragma appears other than after a compilation unit 5643 5644 else 5645 -- Here we check for the generic instantiation case and also 5646 -- for the case of processing a generic formal package. We 5647 -- detect these cases by noting that the Sloc on the node 5648 -- does not belong to the current compilation unit. 5649 5650 Sindex := Source_Index (Current_Sem_Unit); 5651 5652 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then 5653 Rewrite (N, Make_Null_Statement (Loc)); 5654 return; 5655 5656 -- If before first declaration, the pragma applies to the 5657 -- enclosing unit, and the name if present must be this name. 5658 5659 elsif Is_Before_First_Decl (N, Plist) then 5660 Unit_Node := Unit_Declaration_Node (Current_Scope); 5661 Unit_Kind := Nkind (Unit_Node); 5662 5663 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then 5664 Pragma_Misplaced; 5665 5666 elsif Unit_Kind = N_Subprogram_Body 5667 and then not Acts_As_Spec (Unit_Node) 5668 then 5669 Pragma_Misplaced; 5670 5671 elsif Nkind (Parent_Node) = N_Package_Body then 5672 Pragma_Misplaced; 5673 5674 elsif Nkind (Parent_Node) = N_Package_Specification 5675 and then Plist = Private_Declarations (Parent_Node) 5676 then 5677 Pragma_Misplaced; 5678 5679 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration 5680 or else Nkind (Parent_Node) = 5681 N_Generic_Subprogram_Declaration) 5682 and then Plist = Generic_Formal_Declarations (Parent_Node) 5683 then 5684 Pragma_Misplaced; 5685 5686 elsif Arg_Count > 0 then 5687 Analyze (Get_Pragma_Arg (Arg1)); 5688 5689 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then 5690 Error_Pragma_Arg 5691 ("name in pragma% must be enclosing unit", Arg1); 5692 end if; 5693 5694 -- It is legal to have no argument in this context 5695 5696 else 5697 return; 5698 end if; 5699 5700 -- Error if not before first declaration. This is because a 5701 -- library unit pragma argument must be the name of a library 5702 -- unit (RM 10.1.5(7)), but the only names permitted in this 5703 -- context are (RM 10.1.5(6)) names of subprogram declarations, 5704 -- generic subprogram declarations or generic instantiations. 5705 5706 else 5707 Error_Pragma 5708 ("pragma% misplaced, must be before first declaration"); 5709 end if; 5710 end if; 5711 end if; 5712 end Check_Valid_Library_Unit_Pragma; 5713 5714 ------------------- 5715 -- Check_Variant -- 5716 ------------------- 5717 5718 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is 5719 Clist : constant Node_Id := Component_List (Variant); 5720 Comp : Node_Id; 5721 5722 begin 5723 Comp := First (Component_Items (Clist)); 5724 while Present (Comp) loop 5725 Check_Component (Comp, UU_Typ, In_Variant_Part => True); 5726 Next (Comp); 5727 end loop; 5728 end Check_Variant; 5729 5730 --------------------------- 5731 -- Ensure_Aggregate_Form -- 5732 --------------------------- 5733 5734 procedure Ensure_Aggregate_Form (Arg : Node_Id) is 5735 Expr : constant Node_Id := Get_Pragma_Arg (Arg); 5736 Loc : constant Source_Ptr := Sloc (Arg); 5737 Nam : constant Name_Id := Chars (Arg); 5738 Comps : List_Id := No_List; 5739 Exprs : List_Id := No_List; 5740 5741 begin 5742 -- The argument is already in aggregate form, but the presence of a 5743 -- name causes this to be interpreted as a named association which in 5744 -- turn must be converted into an aggregate. 5745 5746 -- pragma Global (In_Out => (A, B, C)) 5747 -- ^ ^ 5748 -- name aggregate 5749 5750 -- pragma Global ((In_Out => (A, B, C))) 5751 -- ^ ^ 5752 -- aggregate aggregate 5753 5754 if Nkind (Expr) = N_Aggregate then 5755 if Nam = No_Name then 5756 return; 5757 end if; 5758 5759 -- Do not transform a null argument into an aggregate as N_Null has 5760 -- special meaning in formal verification pragmas. 5761 5762 elsif Nkind (Expr) = N_Null then 5763 return; 5764 end if; 5765 5766 -- Positional argument is transformed into an aggregate with an 5767 -- Expressions list. 5768 5769 if Nam = No_Name then 5770 Exprs := New_List (Relocate_Node (Expr)); 5771 5772 -- An associative argument is transformed into an aggregate with 5773 -- Component_Associations. 5774 5775 else 5776 Comps := New_List ( 5777 Make_Component_Association (Loc, 5778 Choices => New_List (Make_Identifier (Loc, Chars (Arg))), 5779 Expression => Relocate_Node (Expr))); 5780 5781 end if; 5782 5783 -- Remove the pragma argument name as this information has been 5784 -- captured in the aggregate. 5785 5786 Set_Chars (Arg, No_Name); 5787 5788 Set_Expression (Arg, 5789 Make_Aggregate (Loc, 5790 Component_Associations => Comps, 5791 Expressions => Exprs)); 5792 end Ensure_Aggregate_Form; 5793 5794 ------------------ 5795 -- Error_Pragma -- 5796 ------------------ 5797 5798 procedure Error_Pragma (Msg : String) is 5799 MsgF : String := Msg; 5800 begin 5801 Error_Msg_Name_1 := Pname; 5802 Fix_Error (MsgF); 5803 Error_Msg_N (MsgF, N); 5804 raise Pragma_Exit; 5805 end Error_Pragma; 5806 5807 ---------------------- 5808 -- Error_Pragma_Arg -- 5809 ---------------------- 5810 5811 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is 5812 MsgF : String := Msg; 5813 begin 5814 Error_Msg_Name_1 := Pname; 5815 Fix_Error (MsgF); 5816 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); 5817 raise Pragma_Exit; 5818 end Error_Pragma_Arg; 5819 5820 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is 5821 MsgF : String := Msg1; 5822 begin 5823 Error_Msg_Name_1 := Pname; 5824 Fix_Error (MsgF); 5825 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); 5826 Error_Pragma_Arg (Msg2, Arg); 5827 end Error_Pragma_Arg; 5828 5829 ---------------------------- 5830 -- Error_Pragma_Arg_Ident -- 5831 ---------------------------- 5832 5833 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is 5834 MsgF : String := Msg; 5835 begin 5836 Error_Msg_Name_1 := Pname; 5837 Fix_Error (MsgF); 5838 Error_Msg_N (MsgF, Arg); 5839 raise Pragma_Exit; 5840 end Error_Pragma_Arg_Ident; 5841 5842 ---------------------- 5843 -- Error_Pragma_Ref -- 5844 ---------------------- 5845 5846 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is 5847 MsgF : String := Msg; 5848 begin 5849 Error_Msg_Name_1 := Pname; 5850 Fix_Error (MsgF); 5851 Error_Msg_Sloc := Sloc (Ref); 5852 Error_Msg_NE (MsgF, N, Ref); 5853 raise Pragma_Exit; 5854 end Error_Pragma_Ref; 5855 5856 ------------------------ 5857 -- Find_Lib_Unit_Name -- 5858 ------------------------ 5859 5860 function Find_Lib_Unit_Name return Entity_Id is 5861 begin 5862 -- Return inner compilation unit entity, for case of nested 5863 -- categorization pragmas. This happens in generic unit. 5864 5865 if Nkind (Parent (N)) = N_Package_Specification 5866 and then Defining_Entity (Parent (N)) /= Current_Scope 5867 then 5868 return Defining_Entity (Parent (N)); 5869 else 5870 return Current_Scope; 5871 end if; 5872 end Find_Lib_Unit_Name; 5873 5874 ---------------------------- 5875 -- Find_Program_Unit_Name -- 5876 ---------------------------- 5877 5878 procedure Find_Program_Unit_Name (Id : Node_Id) is 5879 Unit_Name : Entity_Id; 5880 Unit_Kind : Node_Kind; 5881 P : constant Node_Id := Parent (N); 5882 5883 begin 5884 if Nkind (P) = N_Compilation_Unit then 5885 Unit_Kind := Nkind (Unit (P)); 5886 5887 if Unit_Kind = N_Subprogram_Declaration 5888 or else Unit_Kind = N_Package_Declaration 5889 or else Unit_Kind in N_Generic_Declaration 5890 then 5891 Unit_Name := Defining_Entity (Unit (P)); 5892 5893 if Chars (Id) = Chars (Unit_Name) then 5894 Set_Entity (Id, Unit_Name); 5895 Set_Etype (Id, Etype (Unit_Name)); 5896 else 5897 Set_Etype (Id, Any_Type); 5898 Error_Pragma 5899 ("cannot find program unit referenced by pragma%"); 5900 end if; 5901 5902 else 5903 Set_Etype (Id, Any_Type); 5904 Error_Pragma ("pragma% inapplicable to this unit"); 5905 end if; 5906 5907 else 5908 Analyze (Id); 5909 end if; 5910 end Find_Program_Unit_Name; 5911 5912 ----------------------------------------- 5913 -- Find_Unique_Parameterless_Procedure -- 5914 ----------------------------------------- 5915 5916 function Find_Unique_Parameterless_Procedure 5917 (Name : Entity_Id; 5918 Arg : Node_Id) return Entity_Id 5919 is 5920 Proc : Entity_Id := Empty; 5921 5922 begin 5923 -- The body of this procedure needs some comments ??? 5924 5925 if not Is_Entity_Name (Name) then 5926 Error_Pragma_Arg 5927 ("argument of pragma% must be entity name", Arg); 5928 5929 elsif not Is_Overloaded (Name) then 5930 Proc := Entity (Name); 5931 5932 if Ekind (Proc) /= E_Procedure 5933 or else Present (First_Formal (Proc)) 5934 then 5935 Error_Pragma_Arg 5936 ("argument of pragma% must be parameterless procedure", Arg); 5937 end if; 5938 5939 else 5940 declare 5941 Found : Boolean := False; 5942 It : Interp; 5943 Index : Interp_Index; 5944 5945 begin 5946 Get_First_Interp (Name, Index, It); 5947 while Present (It.Nam) loop 5948 Proc := It.Nam; 5949 5950 if Ekind (Proc) = E_Procedure 5951 and then No (First_Formal (Proc)) 5952 then 5953 if not Found then 5954 Found := True; 5955 Set_Entity (Name, Proc); 5956 Set_Is_Overloaded (Name, False); 5957 else 5958 Error_Pragma_Arg 5959 ("ambiguous handler name for pragma% ", Arg); 5960 end if; 5961 end if; 5962 5963 Get_Next_Interp (Index, It); 5964 end loop; 5965 5966 if not Found then 5967 Error_Pragma_Arg 5968 ("argument of pragma% must be parameterless procedure", 5969 Arg); 5970 else 5971 Proc := Entity (Name); 5972 end if; 5973 end; 5974 end if; 5975 5976 return Proc; 5977 end Find_Unique_Parameterless_Procedure; 5978 5979 --------------- 5980 -- Fix_Error -- 5981 --------------- 5982 5983 procedure Fix_Error (Msg : in out String) is 5984 begin 5985 -- If we have a rewriting of another pragma, go to that pragma 5986 5987 if Is_Rewrite_Substitution (N) 5988 and then Nkind (Original_Node (N)) = N_Pragma 5989 then 5990 Error_Msg_Name_1 := Pragma_Name (Original_Node (N)); 5991 end if; 5992 5993 -- Case where pragma comes from an aspect specification 5994 5995 if From_Aspect_Specification (N) then 5996 5997 -- Change appearence of "pragma" in message to "aspect" 5998 5999 for J in Msg'First .. Msg'Last - 5 loop 6000 if Msg (J .. J + 5) = "pragma" then 6001 Msg (J .. J + 5) := "aspect"; 6002 end if; 6003 end loop; 6004 6005 -- Get name from corresponding aspect 6006 6007 Error_Msg_Name_1 := Original_Aspect_Name (N); 6008 end if; 6009 end Fix_Error; 6010 6011 ------------------------- 6012 -- Gather_Associations -- 6013 ------------------------- 6014 6015 procedure Gather_Associations 6016 (Names : Name_List; 6017 Args : out Args_List) 6018 is 6019 Arg : Node_Id; 6020 6021 begin 6022 -- Initialize all parameters to Empty 6023 6024 for J in Args'Range loop 6025 Args (J) := Empty; 6026 end loop; 6027 6028 -- That's all we have to do if there are no argument associations 6029 6030 if No (Pragma_Argument_Associations (N)) then 6031 return; 6032 end if; 6033 6034 -- Otherwise first deal with any positional parameters present 6035 6036 Arg := First (Pragma_Argument_Associations (N)); 6037 for Index in Args'Range loop 6038 exit when No (Arg) or else Chars (Arg) /= No_Name; 6039 Args (Index) := Get_Pragma_Arg (Arg); 6040 Next (Arg); 6041 end loop; 6042 6043 -- Positional parameters all processed, if any left, then we 6044 -- have too many positional parameters. 6045 6046 if Present (Arg) and then Chars (Arg) = No_Name then 6047 Error_Pragma_Arg 6048 ("too many positional associations for pragma%", Arg); 6049 end if; 6050 6051 -- Process named parameters if any are present 6052 6053 while Present (Arg) loop 6054 if Chars (Arg) = No_Name then 6055 Error_Pragma_Arg 6056 ("positional association cannot follow named association", 6057 Arg); 6058 6059 else 6060 for Index in Names'Range loop 6061 if Names (Index) = Chars (Arg) then 6062 if Present (Args (Index)) then 6063 Error_Pragma_Arg 6064 ("duplicate argument association for pragma%", Arg); 6065 else 6066 Args (Index) := Get_Pragma_Arg (Arg); 6067 exit; 6068 end if; 6069 end if; 6070 6071 if Index = Names'Last then 6072 Error_Msg_Name_1 := Pname; 6073 Error_Msg_N ("pragma% does not allow & argument", Arg); 6074 6075 -- Check for possible misspelling 6076 6077 for Index1 in Names'Range loop 6078 if Is_Bad_Spelling_Of 6079 (Chars (Arg), Names (Index1)) 6080 then 6081 Error_Msg_Name_1 := Names (Index1); 6082 Error_Msg_N -- CODEFIX 6083 ("\possible misspelling of%", Arg); 6084 exit; 6085 end if; 6086 end loop; 6087 6088 raise Pragma_Exit; 6089 end if; 6090 end loop; 6091 end if; 6092 6093 Next (Arg); 6094 end loop; 6095 end Gather_Associations; 6096 6097 ----------------- 6098 -- GNAT_Pragma -- 6099 ----------------- 6100 6101 procedure GNAT_Pragma is 6102 begin 6103 -- We need to check the No_Implementation_Pragmas restriction for 6104 -- the case of a pragma from source. Note that the case of aspects 6105 -- generating corresponding pragmas marks these pragmas as not being 6106 -- from source, so this test also catches that case. 6107 6108 if Comes_From_Source (N) then 6109 Check_Restriction (No_Implementation_Pragmas, N); 6110 end if; 6111 end GNAT_Pragma; 6112 6113 -------------------------- 6114 -- Is_Before_First_Decl -- 6115 -------------------------- 6116 6117 function Is_Before_First_Decl 6118 (Pragma_Node : Node_Id; 6119 Decls : List_Id) return Boolean 6120 is 6121 Item : Node_Id := First (Decls); 6122 6123 begin 6124 -- Only other pragmas can come before this pragma 6125 6126 loop 6127 if No (Item) or else Nkind (Item) /= N_Pragma then 6128 return False; 6129 6130 elsif Item = Pragma_Node then 6131 return True; 6132 end if; 6133 6134 Next (Item); 6135 end loop; 6136 end Is_Before_First_Decl; 6137 6138 ----------------------------- 6139 -- Is_Configuration_Pragma -- 6140 ----------------------------- 6141 6142 -- A configuration pragma must appear in the context clause of a 6143 -- compilation unit, and only other pragmas may precede it. Note that 6144 -- the test below also permits use in a configuration pragma file. 6145 6146 function Is_Configuration_Pragma return Boolean is 6147 Lis : constant List_Id := List_Containing (N); 6148 Par : constant Node_Id := Parent (N); 6149 Prg : Node_Id; 6150 6151 begin 6152 -- If no parent, then we are in the configuration pragma file, 6153 -- so the placement is definitely appropriate. 6154 6155 if No (Par) then 6156 return True; 6157 6158 -- Otherwise we must be in the context clause of a compilation unit 6159 -- and the only thing allowed before us in the context list is more 6160 -- configuration pragmas. 6161 6162 elsif Nkind (Par) = N_Compilation_Unit 6163 and then Context_Items (Par) = Lis 6164 then 6165 Prg := First (Lis); 6166 6167 loop 6168 if Prg = N then 6169 return True; 6170 elsif Nkind (Prg) /= N_Pragma then 6171 return False; 6172 end if; 6173 6174 Next (Prg); 6175 end loop; 6176 6177 else 6178 return False; 6179 end if; 6180 end Is_Configuration_Pragma; 6181 6182 -------------------------- 6183 -- Is_In_Context_Clause -- 6184 -------------------------- 6185 6186 function Is_In_Context_Clause return Boolean is 6187 Plist : List_Id; 6188 Parent_Node : Node_Id; 6189 6190 begin 6191 if not Is_List_Member (N) then 6192 return False; 6193 6194 else 6195 Plist := List_Containing (N); 6196 Parent_Node := Parent (Plist); 6197 6198 if Parent_Node = Empty 6199 or else Nkind (Parent_Node) /= N_Compilation_Unit 6200 or else Context_Items (Parent_Node) /= Plist 6201 then 6202 return False; 6203 end if; 6204 end if; 6205 6206 return True; 6207 end Is_In_Context_Clause; 6208 6209 --------------------------------- 6210 -- Is_Static_String_Expression -- 6211 --------------------------------- 6212 6213 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is 6214 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 6215 6216 begin 6217 Analyze_And_Resolve (Argx); 6218 return Is_OK_Static_Expression (Argx) 6219 and then Nkind (Argx) = N_String_Literal; 6220 end Is_Static_String_Expression; 6221 6222 ---------------------- 6223 -- Pragma_Misplaced -- 6224 ---------------------- 6225 6226 procedure Pragma_Misplaced is 6227 begin 6228 Error_Pragma ("incorrect placement of pragma%"); 6229 end Pragma_Misplaced; 6230 6231 ------------------------------------ 6232 -- Process_Atomic_Shared_Volatile -- 6233 ------------------------------------ 6234 6235 procedure Process_Atomic_Shared_Volatile is 6236 E_Id : Node_Id; 6237 E : Entity_Id; 6238 D : Node_Id; 6239 K : Node_Kind; 6240 Utyp : Entity_Id; 6241 6242 procedure Set_Atomic (E : Entity_Id); 6243 -- Set given type as atomic, and if no explicit alignment was given, 6244 -- set alignment to unknown, since back end knows what the alignment 6245 -- requirements are for atomic arrays. Note: this step is necessary 6246 -- for derived types. 6247 6248 ---------------- 6249 -- Set_Atomic -- 6250 ---------------- 6251 6252 procedure Set_Atomic (E : Entity_Id) is 6253 begin 6254 Set_Is_Atomic (E); 6255 6256 if not Has_Alignment_Clause (E) then 6257 Set_Alignment (E, Uint_0); 6258 end if; 6259 end Set_Atomic; 6260 6261 -- Start of processing for Process_Atomic_Shared_Volatile 6262 6263 begin 6264 Check_Ada_83_Warning; 6265 Check_No_Identifiers; 6266 Check_Arg_Count (1); 6267 Check_Arg_Is_Local_Name (Arg1); 6268 E_Id := Get_Pragma_Arg (Arg1); 6269 6270 if Etype (E_Id) = Any_Type then 6271 return; 6272 end if; 6273 6274 E := Entity (E_Id); 6275 D := Declaration_Node (E); 6276 K := Nkind (D); 6277 6278 -- Check duplicate before we chain ourselves 6279 6280 Check_Duplicate_Pragma (E); 6281 6282 -- Now check appropriateness of the entity 6283 6284 if Is_Type (E) then 6285 if Rep_Item_Too_Early (E, N) 6286 or else 6287 Rep_Item_Too_Late (E, N) 6288 then 6289 return; 6290 else 6291 Check_First_Subtype (Arg1); 6292 end if; 6293 6294 if Prag_Id /= Pragma_Volatile then 6295 Set_Atomic (E); 6296 Set_Atomic (Underlying_Type (E)); 6297 Set_Atomic (Base_Type (E)); 6298 end if; 6299 6300 -- Attribute belongs on the base type. If the view of the type is 6301 -- currently private, it also belongs on the underlying type. 6302 6303 Set_Is_Volatile (Base_Type (E)); 6304 Set_Is_Volatile (Underlying_Type (E)); 6305 6306 Set_Treat_As_Volatile (E); 6307 Set_Treat_As_Volatile (Underlying_Type (E)); 6308 6309 elsif K = N_Object_Declaration 6310 or else (K = N_Component_Declaration 6311 and then Original_Record_Component (E) = E) 6312 then 6313 if Rep_Item_Too_Late (E, N) then 6314 return; 6315 end if; 6316 6317 if Prag_Id /= Pragma_Volatile then 6318 Set_Is_Atomic (E); 6319 6320 -- If the object declaration has an explicit initialization, a 6321 -- temporary may have to be created to hold the expression, to 6322 -- ensure that access to the object remain atomic. 6323 6324 if Nkind (Parent (E)) = N_Object_Declaration 6325 and then Present (Expression (Parent (E))) 6326 then 6327 Set_Has_Delayed_Freeze (E); 6328 end if; 6329 6330 -- An interesting improvement here. If an object of composite 6331 -- type X is declared atomic, and the type X isn't, that's a 6332 -- pity, since it may not have appropriate alignment etc. We 6333 -- can rescue this in the special case where the object and 6334 -- type are in the same unit by just setting the type as 6335 -- atomic, so that the back end will process it as atomic. 6336 6337 -- Note: we used to do this for elementary types as well, 6338 -- but that turns out to be a bad idea and can have unwanted 6339 -- effects, most notably if the type is elementary, the object 6340 -- a simple component within a record, and both are in a spec: 6341 -- every object of this type in the entire program will be 6342 -- treated as atomic, thus incurring a potentially costly 6343 -- synchronization operation for every access. 6344 6345 -- Of course it would be best if the back end could just adjust 6346 -- the alignment etc for the specific object, but that's not 6347 -- something we are capable of doing at this point. 6348 6349 Utyp := Underlying_Type (Etype (E)); 6350 6351 if Present (Utyp) 6352 and then Is_Composite_Type (Utyp) 6353 and then Sloc (E) > No_Location 6354 and then Sloc (Utyp) > No_Location 6355 and then 6356 Get_Source_File_Index (Sloc (E)) = 6357 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) 6358 then 6359 Set_Is_Atomic (Underlying_Type (Etype (E))); 6360 end if; 6361 end if; 6362 6363 Set_Is_Volatile (E); 6364 Set_Treat_As_Volatile (E); 6365 6366 else 6367 Error_Pragma_Arg 6368 ("inappropriate entity for pragma%", Arg1); 6369 end if; 6370 end Process_Atomic_Shared_Volatile; 6371 6372 ------------------------------------------- 6373 -- Process_Compile_Time_Warning_Or_Error -- 6374 ------------------------------------------- 6375 6376 procedure Process_Compile_Time_Warning_Or_Error is 6377 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 6378 6379 begin 6380 Check_Arg_Count (2); 6381 Check_No_Identifiers; 6382 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 6383 Analyze_And_Resolve (Arg1x, Standard_Boolean); 6384 6385 if Compile_Time_Known_Value (Arg1x) then 6386 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then 6387 declare 6388 Str : constant String_Id := 6389 Strval (Get_Pragma_Arg (Arg2)); 6390 Len : constant Int := String_Length (Str); 6391 Cont : Boolean; 6392 Ptr : Nat; 6393 CC : Char_Code; 6394 C : Character; 6395 Cent : constant Entity_Id := 6396 Cunit_Entity (Current_Sem_Unit); 6397 6398 Force : constant Boolean := 6399 Prag_Id = Pragma_Compile_Time_Warning 6400 and then 6401 Is_Spec_Name (Unit_Name (Current_Sem_Unit)) 6402 and then (Ekind (Cent) /= E_Package 6403 or else not In_Private_Part (Cent)); 6404 -- Set True if this is the warning case, and we are in the 6405 -- visible part of a package spec, or in a subprogram spec, 6406 -- in which case we want to force the client to see the 6407 -- warning, even though it is not in the main unit. 6408 6409 begin 6410 -- Loop through segments of message separated by line feeds. 6411 -- We output these segments as separate messages with 6412 -- continuation marks for all but the first. 6413 6414 Cont := False; 6415 Ptr := 1; 6416 loop 6417 Error_Msg_Strlen := 0; 6418 6419 -- Loop to copy characters from argument to error message 6420 -- string buffer. 6421 6422 loop 6423 exit when Ptr > Len; 6424 CC := Get_String_Char (Str, Ptr); 6425 Ptr := Ptr + 1; 6426 6427 -- Ignore wide chars ??? else store character 6428 6429 if In_Character_Range (CC) then 6430 C := Get_Character (CC); 6431 exit when C = ASCII.LF; 6432 Error_Msg_Strlen := Error_Msg_Strlen + 1; 6433 Error_Msg_String (Error_Msg_Strlen) := C; 6434 end if; 6435 end loop; 6436 6437 -- Here with one line ready to go 6438 6439 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; 6440 6441 -- If this is a warning in a spec, then we want clients 6442 -- to see the warning, so mark the message with the 6443 -- special sequence !! to force the warning. In the case 6444 -- of a package spec, we do not force this if we are in 6445 -- the private part of the spec. 6446 6447 if Force then 6448 if Cont = False then 6449 Error_Msg_N ("<~!!", Arg1); 6450 Cont := True; 6451 else 6452 Error_Msg_N ("\<~!!", Arg1); 6453 end if; 6454 6455 -- Error, rather than warning, or in a body, so we do not 6456 -- need to force visibility for client (error will be 6457 -- output in any case, and this is the situation in which 6458 -- we do not want a client to get a warning, since the 6459 -- warning is in the body or the spec private part). 6460 6461 else 6462 if Cont = False then 6463 Error_Msg_N ("<~", Arg1); 6464 Cont := True; 6465 else 6466 Error_Msg_N ("\<~", Arg1); 6467 end if; 6468 end if; 6469 6470 exit when Ptr > Len; 6471 end loop; 6472 end; 6473 end if; 6474 end if; 6475 end Process_Compile_Time_Warning_Or_Error; 6476 6477 ------------------------ 6478 -- Process_Convention -- 6479 ------------------------ 6480 6481 procedure Process_Convention 6482 (C : out Convention_Id; 6483 Ent : out Entity_Id) 6484 is 6485 Id : Node_Id; 6486 E : Entity_Id; 6487 E1 : Entity_Id; 6488 Cname : Name_Id; 6489 Comp_Unit : Unit_Number_Type; 6490 6491 procedure Diagnose_Multiple_Pragmas (S : Entity_Id); 6492 -- Called if we have more than one Export/Import/Convention pragma. 6493 -- This is generally illegal, but we have a special case of allowing 6494 -- Import and Interface to coexist if they specify the convention in 6495 -- a consistent manner. We are allowed to do this, since Interface is 6496 -- an implementation defined pragma, and we choose to do it since we 6497 -- know Rational allows this combination. S is the entity id of the 6498 -- subprogram in question. This procedure also sets the special flag 6499 -- Import_Interface_Present in both pragmas in the case where we do 6500 -- have matching Import and Interface pragmas. 6501 6502 procedure Set_Convention_From_Pragma (E : Entity_Id); 6503 -- Set convention in entity E, and also flag that the entity has a 6504 -- convention pragma. If entity is for a private or incomplete type, 6505 -- also set convention and flag on underlying type. This procedure 6506 -- also deals with the special case of C_Pass_By_Copy convention, 6507 -- and error checks for inappropriate convention specification. 6508 6509 ------------------------------- 6510 -- Diagnose_Multiple_Pragmas -- 6511 ------------------------------- 6512 6513 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is 6514 Pdec : constant Node_Id := Declaration_Node (S); 6515 Decl : Node_Id; 6516 Err : Boolean; 6517 6518 function Same_Convention (Decl : Node_Id) return Boolean; 6519 -- Decl is a pragma node. This function returns True if this 6520 -- pragma has a first argument that is an identifier with a 6521 -- Chars field corresponding to the Convention_Id C. 6522 6523 function Same_Name (Decl : Node_Id) return Boolean; 6524 -- Decl is a pragma node. This function returns True if this 6525 -- pragma has a second argument that is an identifier with a 6526 -- Chars field that matches the Chars of the current subprogram. 6527 6528 --------------------- 6529 -- Same_Convention -- 6530 --------------------- 6531 6532 function Same_Convention (Decl : Node_Id) return Boolean is 6533 Arg1 : constant Node_Id := 6534 First (Pragma_Argument_Associations (Decl)); 6535 6536 begin 6537 if Present (Arg1) then 6538 declare 6539 Arg : constant Node_Id := Get_Pragma_Arg (Arg1); 6540 begin 6541 if Nkind (Arg) = N_Identifier 6542 and then Is_Convention_Name (Chars (Arg)) 6543 and then Get_Convention_Id (Chars (Arg)) = C 6544 then 6545 return True; 6546 end if; 6547 end; 6548 end if; 6549 6550 return False; 6551 end Same_Convention; 6552 6553 --------------- 6554 -- Same_Name -- 6555 --------------- 6556 6557 function Same_Name (Decl : Node_Id) return Boolean is 6558 Arg1 : constant Node_Id := 6559 First (Pragma_Argument_Associations (Decl)); 6560 Arg2 : Node_Id; 6561 6562 begin 6563 if No (Arg1) then 6564 return False; 6565 end if; 6566 6567 Arg2 := Next (Arg1); 6568 6569 if No (Arg2) then 6570 return False; 6571 end if; 6572 6573 declare 6574 Arg : constant Node_Id := Get_Pragma_Arg (Arg2); 6575 begin 6576 if Nkind (Arg) = N_Identifier 6577 and then Chars (Arg) = Chars (S) 6578 then 6579 return True; 6580 end if; 6581 end; 6582 6583 return False; 6584 end Same_Name; 6585 6586 -- Start of processing for Diagnose_Multiple_Pragmas 6587 6588 begin 6589 Err := True; 6590 6591 -- Definitely give message if we have Convention/Export here 6592 6593 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then 6594 null; 6595 6596 -- If we have an Import or Export, scan back from pragma to 6597 -- find any previous pragma applying to the same procedure. 6598 -- The scan will be terminated by the start of the list, or 6599 -- hitting the subprogram declaration. This won't allow one 6600 -- pragma to appear in the public part and one in the private 6601 -- part, but that seems very unlikely in practice. 6602 6603 else 6604 Decl := Prev (N); 6605 while Present (Decl) and then Decl /= Pdec loop 6606 6607 -- Look for pragma with same name as us 6608 6609 if Nkind (Decl) = N_Pragma 6610 and then Same_Name (Decl) 6611 then 6612 -- Give error if same as our pragma or Export/Convention 6613 6614 if Nam_In (Pragma_Name (Decl), Name_Export, 6615 Name_Convention, 6616 Pragma_Name (N)) 6617 then 6618 exit; 6619 6620 -- Case of Import/Interface or the other way round 6621 6622 elsif Nam_In (Pragma_Name (Decl), Name_Interface, 6623 Name_Import) 6624 then 6625 -- Here we know that we have Import and Interface. It 6626 -- doesn't matter which way round they are. See if 6627 -- they specify the same convention. If so, all OK, 6628 -- and set special flags to stop other messages 6629 6630 if Same_Convention (Decl) then 6631 Set_Import_Interface_Present (N); 6632 Set_Import_Interface_Present (Decl); 6633 Err := False; 6634 6635 -- If different conventions, special message 6636 6637 else 6638 Error_Msg_Sloc := Sloc (Decl); 6639 Error_Pragma_Arg 6640 ("convention differs from that given#", Arg1); 6641 return; 6642 end if; 6643 end if; 6644 end if; 6645 6646 Next (Decl); 6647 end loop; 6648 end if; 6649 6650 -- Give message if needed if we fall through those tests 6651 -- except on Relaxed_RM_Semantics where we let go: either this 6652 -- is a case accepted/ignored by other Ada compilers (e.g. 6653 -- a mix of Convention and Import), or another error will be 6654 -- generated later (e.g. using both Import and Export). 6655 6656 if Err and not Relaxed_RM_Semantics then 6657 Error_Pragma_Arg 6658 ("at most one Convention/Export/Import pragma is allowed", 6659 Arg2); 6660 end if; 6661 end Diagnose_Multiple_Pragmas; 6662 6663 -------------------------------- 6664 -- Set_Convention_From_Pragma -- 6665 -------------------------------- 6666 6667 procedure Set_Convention_From_Pragma (E : Entity_Id) is 6668 begin 6669 -- Ghost convention is allowed only for functions 6670 6671 if Ekind (E) /= E_Function and then C = Convention_Ghost then 6672 Error_Msg_N 6673 ("& may not have Ghost convention", E); 6674 Error_Msg_N 6675 ("\only functions are permitted to have Ghost convention", 6676 E); 6677 return; 6678 end if; 6679 6680 -- Ada 2005 (AI-430): Check invalid attempt to change convention 6681 -- for an overridden dispatching operation. Technically this is 6682 -- an amendment and should only be done in Ada 2005 mode. However, 6683 -- this is clearly a mistake, since the problem that is addressed 6684 -- by this AI is that there is a clear gap in the RM. 6685 6686 if Is_Dispatching_Operation (E) 6687 and then Present (Overridden_Operation (E)) 6688 and then C /= Convention (Overridden_Operation (E)) 6689 then 6690 -- An attempt to override a function with a ghost function 6691 -- appears as a mismatch in conventions. 6692 6693 if C = Convention_Ghost then 6694 Error_Msg_N ("ghost function & cannot be overriding", E); 6695 else 6696 Error_Pragma_Arg 6697 ("cannot change convention for overridden dispatching " 6698 & "operation", Arg1); 6699 end if; 6700 end if; 6701 6702 -- Special checks for Convention_Stdcall 6703 6704 if C = Convention_Stdcall then 6705 6706 -- A dispatching call is not allowed. A dispatching subprogram 6707 -- cannot be used to interface to the Win32 API, so in fact 6708 -- this check does not impose any effective restriction. 6709 6710 if Is_Dispatching_Operation (E) then 6711 Error_Msg_Sloc := Sloc (E); 6712 6713 -- Note: make this unconditional so that if there is more 6714 -- than one call to which the pragma applies, we get a 6715 -- message for each call. Also don't use Error_Pragma, 6716 -- so that we get multiple messages. 6717 6718 Error_Msg_N 6719 ("dispatching subprogram# cannot use Stdcall convention!", 6720 Arg1); 6721 6722 -- Subprogram is allowed, but not a generic subprogram 6723 6724 elsif not Is_Subprogram (E) 6725 and then not Is_Generic_Subprogram (E) 6726 6727 -- A variable is OK 6728 6729 and then Ekind (E) /= E_Variable 6730 6731 -- An access to subprogram is also allowed 6732 6733 and then not 6734 (Is_Access_Type (E) 6735 and then Ekind (Designated_Type (E)) = E_Subprogram_Type) 6736 6737 -- Allow internal call to set convention of subprogram type 6738 6739 and then not (Ekind (E) = E_Subprogram_Type) 6740 then 6741 Error_Pragma_Arg 6742 ("second argument of pragma% must be subprogram (type)", 6743 Arg2); 6744 end if; 6745 end if; 6746 6747 -- Set the convention 6748 6749 Set_Convention (E, C); 6750 Set_Has_Convention_Pragma (E); 6751 6752 -- For the case of a record base type, also set the convention of 6753 -- any anonymous access types declared in the record which do not 6754 -- currently have a specified convention. 6755 6756 if Is_Record_Type (E) and then Is_Base_Type (E) then 6757 declare 6758 Comp : Node_Id; 6759 6760 begin 6761 Comp := First_Component (E); 6762 while Present (Comp) loop 6763 if Present (Etype (Comp)) 6764 and then Ekind_In (Etype (Comp), 6765 E_Anonymous_Access_Type, 6766 E_Anonymous_Access_Subprogram_Type) 6767 and then not Has_Convention_Pragma (Comp) 6768 then 6769 Set_Convention (Comp, C); 6770 end if; 6771 6772 Next_Component (Comp); 6773 end loop; 6774 end; 6775 end if; 6776 6777 -- Deal with incomplete/private type case, where underlying type 6778 -- is available, so set convention of that underlying type. 6779 6780 if Is_Incomplete_Or_Private_Type (E) 6781 and then Present (Underlying_Type (E)) 6782 then 6783 Set_Convention (Underlying_Type (E), C); 6784 Set_Has_Convention_Pragma (Underlying_Type (E), True); 6785 end if; 6786 6787 -- A class-wide type should inherit the convention of the specific 6788 -- root type (although this isn't specified clearly by the RM). 6789 6790 if Is_Type (E) and then Present (Class_Wide_Type (E)) then 6791 Set_Convention (Class_Wide_Type (E), C); 6792 end if; 6793 6794 -- If the entity is a record type, then check for special case of 6795 -- C_Pass_By_Copy, which is treated the same as C except that the 6796 -- special record flag is set. This convention is only permitted 6797 -- on record types (see AI95-00131). 6798 6799 if Cname = Name_C_Pass_By_Copy then 6800 if Is_Record_Type (E) then 6801 Set_C_Pass_By_Copy (Base_Type (E)); 6802 elsif Is_Incomplete_Or_Private_Type (E) 6803 and then Is_Record_Type (Underlying_Type (E)) 6804 then 6805 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); 6806 else 6807 Error_Pragma_Arg 6808 ("C_Pass_By_Copy convention allowed only for record type", 6809 Arg2); 6810 end if; 6811 end if; 6812 6813 -- If the entity is a derived boolean type, check for the special 6814 -- case of convention C, C++, or Fortran, where we consider any 6815 -- nonzero value to represent true. 6816 6817 if Is_Discrete_Type (E) 6818 and then Root_Type (Etype (E)) = Standard_Boolean 6819 and then 6820 (C = Convention_C 6821 or else 6822 C = Convention_CPP 6823 or else 6824 C = Convention_Fortran) 6825 then 6826 Set_Nonzero_Is_True (Base_Type (E)); 6827 end if; 6828 end Set_Convention_From_Pragma; 6829 6830 -- Start of processing for Process_Convention 6831 6832 begin 6833 Check_At_Least_N_Arguments (2); 6834 Check_Optional_Identifier (Arg1, Name_Convention); 6835 Check_Arg_Is_Identifier (Arg1); 6836 Cname := Chars (Get_Pragma_Arg (Arg1)); 6837 6838 -- C_Pass_By_Copy is treated as a synonym for convention C (this is 6839 -- tested again below to set the critical flag). 6840 6841 if Cname = Name_C_Pass_By_Copy then 6842 C := Convention_C; 6843 6844 -- Otherwise we must have something in the standard convention list 6845 6846 elsif Is_Convention_Name (Cname) then 6847 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); 6848 6849 -- In DEC VMS, it seems that there is an undocumented feature that 6850 -- any unrecognized convention is treated as the default, which for 6851 -- us is convention C. It does not seem so terrible to do this 6852 -- unconditionally, silently in the VMS case, and with a warning 6853 -- in the non-VMS case. 6854 6855 else 6856 if Warn_On_Export_Import and not OpenVMS_On_Target then 6857 Error_Msg_N 6858 ("??unrecognized convention name, C assumed", 6859 Get_Pragma_Arg (Arg1)); 6860 end if; 6861 6862 C := Convention_C; 6863 end if; 6864 6865 Check_Optional_Identifier (Arg2, Name_Entity); 6866 Check_Arg_Is_Local_Name (Arg2); 6867 6868 Id := Get_Pragma_Arg (Arg2); 6869 Analyze (Id); 6870 6871 if not Is_Entity_Name (Id) then 6872 Error_Pragma_Arg ("entity name required", Arg2); 6873 end if; 6874 6875 E := Entity (Id); 6876 6877 -- Set entity to return 6878 6879 Ent := E; 6880 6881 -- Ada_Pass_By_Copy special checking 6882 6883 if C = Convention_Ada_Pass_By_Copy then 6884 if not Is_First_Subtype (E) then 6885 Error_Pragma_Arg 6886 ("convention `Ada_Pass_By_Copy` only allowed for types", 6887 Arg2); 6888 end if; 6889 6890 if Is_By_Reference_Type (E) then 6891 Error_Pragma_Arg 6892 ("convention `Ada_Pass_By_Copy` not allowed for by-reference " 6893 & "type", Arg1); 6894 end if; 6895 end if; 6896 6897 -- Ada_Pass_By_Reference special checking 6898 6899 if C = Convention_Ada_Pass_By_Reference then 6900 if not Is_First_Subtype (E) then 6901 Error_Pragma_Arg 6902 ("convention `Ada_Pass_By_Reference` only allowed for types", 6903 Arg2); 6904 end if; 6905 6906 if Is_By_Copy_Type (E) then 6907 Error_Pragma_Arg 6908 ("convention `Ada_Pass_By_Reference` not allowed for by-copy " 6909 & "type", Arg1); 6910 end if; 6911 end if; 6912 6913 -- Ghost special checking 6914 6915 if Is_Ghost_Subprogram (E) 6916 and then Present (Overridden_Operation (E)) 6917 then 6918 Error_Msg_N ("ghost function & cannot be overriding", E); 6919 end if; 6920 6921 -- Go to renamed subprogram if present, since convention applies to 6922 -- the actual renamed entity, not to the renaming entity. If the 6923 -- subprogram is inherited, go to parent subprogram. 6924 6925 if Is_Subprogram (E) 6926 and then Present (Alias (E)) 6927 then 6928 if Nkind (Parent (Declaration_Node (E))) = 6929 N_Subprogram_Renaming_Declaration 6930 then 6931 if Scope (E) /= Scope (Alias (E)) then 6932 Error_Pragma_Ref 6933 ("cannot apply pragma% to non-local entity&#", E); 6934 end if; 6935 6936 E := Alias (E); 6937 6938 elsif Nkind_In (Parent (E), N_Full_Type_Declaration, 6939 N_Private_Extension_Declaration) 6940 and then Scope (E) = Scope (Alias (E)) 6941 then 6942 E := Alias (E); 6943 6944 -- Return the parent subprogram the entity was inherited from 6945 6946 Ent := E; 6947 end if; 6948 end if; 6949 6950 -- Check that we are not applying this to a specless body 6951 -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada 6952 -- compilers. 6953 6954 if Is_Subprogram (E) 6955 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body 6956 and then not Relaxed_RM_Semantics 6957 then 6958 Error_Pragma 6959 ("pragma% requires separate spec and must come before body"); 6960 end if; 6961 6962 -- Check that we are not applying this to a named constant 6963 6964 if Ekind_In (E, E_Named_Integer, E_Named_Real) then 6965 Error_Msg_Name_1 := Pname; 6966 Error_Msg_N 6967 ("cannot apply pragma% to named constant!", 6968 Get_Pragma_Arg (Arg2)); 6969 Error_Pragma_Arg 6970 ("\supply appropriate type for&!", Arg2); 6971 end if; 6972 6973 if Ekind (E) = E_Enumeration_Literal then 6974 Error_Pragma ("enumeration literal not allowed for pragma%"); 6975 end if; 6976 6977 -- Check for rep item appearing too early or too late 6978 6979 if Etype (E) = Any_Type 6980 or else Rep_Item_Too_Early (E, N) 6981 then 6982 raise Pragma_Exit; 6983 6984 elsif Present (Underlying_Type (E)) then 6985 E := Underlying_Type (E); 6986 end if; 6987 6988 if Rep_Item_Too_Late (E, N) then 6989 raise Pragma_Exit; 6990 end if; 6991 6992 if Has_Convention_Pragma (E) then 6993 Diagnose_Multiple_Pragmas (E); 6994 6995 elsif Convention (E) = Convention_Protected 6996 or else Ekind (Scope (E)) = E_Protected_Type 6997 then 6998 Error_Pragma_Arg 6999 ("a protected operation cannot be given a different convention", 7000 Arg2); 7001 end if; 7002 7003 -- For Intrinsic, a subprogram is required 7004 7005 if C = Convention_Intrinsic 7006 and then not Is_Subprogram (E) 7007 and then not Is_Generic_Subprogram (E) 7008 then 7009 Error_Pragma_Arg 7010 ("second argument of pragma% must be a subprogram", Arg2); 7011 end if; 7012 7013 -- Deal with non-subprogram cases 7014 7015 if not Is_Subprogram (E) 7016 and then not Is_Generic_Subprogram (E) 7017 then 7018 Set_Convention_From_Pragma (E); 7019 7020 if Is_Type (E) then 7021 Check_First_Subtype (Arg2); 7022 Set_Convention_From_Pragma (Base_Type (E)); 7023 7024 -- For access subprograms, we must set the convention on the 7025 -- internally generated directly designated type as well. 7026 7027 if Ekind (E) = E_Access_Subprogram_Type then 7028 Set_Convention_From_Pragma (Directly_Designated_Type (E)); 7029 end if; 7030 end if; 7031 7032 -- For the subprogram case, set proper convention for all homonyms 7033 -- in same scope and the same declarative part, i.e. the same 7034 -- compilation unit. 7035 7036 else 7037 Comp_Unit := Get_Source_Unit (E); 7038 Set_Convention_From_Pragma (E); 7039 7040 -- Treat a pragma Import as an implicit body, and pragma import 7041 -- as implicit reference (for navigation in GPS). 7042 7043 if Prag_Id = Pragma_Import then 7044 Generate_Reference (E, Id, 'b'); 7045 7046 -- For exported entities we restrict the generation of references 7047 -- to entities exported to foreign languages since entities 7048 -- exported to Ada do not provide further information to GPS and 7049 -- add undesired references to the output of the gnatxref tool. 7050 7051 elsif Prag_Id = Pragma_Export 7052 and then Convention (E) /= Convention_Ada 7053 then 7054 Generate_Reference (E, Id, 'i'); 7055 end if; 7056 7057 -- If the pragma comes from from an aspect, it only applies to the 7058 -- given entity, not its homonyms. 7059 7060 if From_Aspect_Specification (N) then 7061 return; 7062 end if; 7063 7064 -- Otherwise Loop through the homonyms of the pragma argument's 7065 -- entity, an apply convention to those in the current scope. 7066 7067 E1 := Ent; 7068 7069 loop 7070 E1 := Homonym (E1); 7071 exit when No (E1) or else Scope (E1) /= Current_Scope; 7072 7073 -- Ignore entry for which convention is already set 7074 7075 if Has_Convention_Pragma (E1) then 7076 goto Continue; 7077 end if; 7078 7079 -- Do not set the pragma on inherited operations or on formal 7080 -- subprograms. 7081 7082 if Comes_From_Source (E1) 7083 and then Comp_Unit = Get_Source_Unit (E1) 7084 and then not Is_Formal_Subprogram (E1) 7085 and then Nkind (Original_Node (Parent (E1))) /= 7086 N_Full_Type_Declaration 7087 then 7088 if Present (Alias (E1)) 7089 and then Scope (E1) /= Scope (Alias (E1)) 7090 then 7091 Error_Pragma_Ref 7092 ("cannot apply pragma% to non-local entity& declared#", 7093 E1); 7094 end if; 7095 7096 Set_Convention_From_Pragma (E1); 7097 7098 if Prag_Id = Pragma_Import then 7099 Generate_Reference (E1, Id, 'b'); 7100 end if; 7101 end if; 7102 7103 <<Continue>> 7104 null; 7105 end loop; 7106 end if; 7107 end Process_Convention; 7108 7109 ---------------------------------------- 7110 -- Process_Disable_Enable_Atomic_Sync -- 7111 ---------------------------------------- 7112 7113 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is 7114 begin 7115 Check_No_Identifiers; 7116 Check_At_Most_N_Arguments (1); 7117 7118 -- Modeled internally as 7119 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity]) 7120 7121 Rewrite (N, 7122 Make_Pragma (Loc, 7123 Pragma_Identifier => 7124 Make_Identifier (Loc, Nam), 7125 Pragma_Argument_Associations => New_List ( 7126 Make_Pragma_Argument_Association (Loc, 7127 Expression => 7128 Make_Identifier (Loc, Name_Atomic_Synchronization))))); 7129 7130 if Present (Arg1) then 7131 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); 7132 end if; 7133 7134 Analyze (N); 7135 end Process_Disable_Enable_Atomic_Sync; 7136 7137 ----------------------------------------------------- 7138 -- Process_Extended_Import_Export_Exception_Pragma -- 7139 ----------------------------------------------------- 7140 7141 procedure Process_Extended_Import_Export_Exception_Pragma 7142 (Arg_Internal : Node_Id; 7143 Arg_External : Node_Id; 7144 Arg_Form : Node_Id; 7145 Arg_Code : Node_Id) 7146 is 7147 Def_Id : Entity_Id; 7148 Code_Val : Uint; 7149 7150 begin 7151 if not OpenVMS_On_Target then 7152 Error_Pragma 7153 ("??pragma% ignored (applies only to Open'V'M'S)"); 7154 end if; 7155 7156 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 7157 Def_Id := Entity (Arg_Internal); 7158 7159 if Ekind (Def_Id) /= E_Exception then 7160 Error_Pragma_Arg 7161 ("pragma% must refer to declared exception", Arg_Internal); 7162 end if; 7163 7164 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 7165 7166 if Present (Arg_Form) then 7167 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); 7168 end if; 7169 7170 if Present (Arg_Form) 7171 and then Chars (Arg_Form) = Name_Ada 7172 then 7173 null; 7174 else 7175 Set_Is_VMS_Exception (Def_Id); 7176 Set_Exception_Code (Def_Id, No_Uint); 7177 end if; 7178 7179 if Present (Arg_Code) then 7180 if not Is_VMS_Exception (Def_Id) then 7181 Error_Pragma_Arg 7182 ("Code option for pragma% not allowed for Ada case", 7183 Arg_Code); 7184 end if; 7185 7186 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer); 7187 Code_Val := Expr_Value (Arg_Code); 7188 7189 if not UI_Is_In_Int_Range (Code_Val) then 7190 Error_Pragma_Arg 7191 ("Code option for pragma% must be in 32-bit range", 7192 Arg_Code); 7193 7194 else 7195 Set_Exception_Code (Def_Id, Code_Val); 7196 end if; 7197 end if; 7198 end Process_Extended_Import_Export_Exception_Pragma; 7199 7200 ------------------------------------------------- 7201 -- Process_Extended_Import_Export_Internal_Arg -- 7202 ------------------------------------------------- 7203 7204 procedure Process_Extended_Import_Export_Internal_Arg 7205 (Arg_Internal : Node_Id := Empty) 7206 is 7207 begin 7208 if No (Arg_Internal) then 7209 Error_Pragma ("Internal parameter required for pragma%"); 7210 end if; 7211 7212 if Nkind (Arg_Internal) = N_Identifier then 7213 null; 7214 7215 elsif Nkind (Arg_Internal) = N_Operator_Symbol 7216 and then (Prag_Id = Pragma_Import_Function 7217 or else 7218 Prag_Id = Pragma_Export_Function) 7219 then 7220 null; 7221 7222 else 7223 Error_Pragma_Arg 7224 ("wrong form for Internal parameter for pragma%", Arg_Internal); 7225 end if; 7226 7227 Check_Arg_Is_Local_Name (Arg_Internal); 7228 end Process_Extended_Import_Export_Internal_Arg; 7229 7230 -------------------------------------------------- 7231 -- Process_Extended_Import_Export_Object_Pragma -- 7232 -------------------------------------------------- 7233 7234 procedure Process_Extended_Import_Export_Object_Pragma 7235 (Arg_Internal : Node_Id; 7236 Arg_External : Node_Id; 7237 Arg_Size : Node_Id) 7238 is 7239 Def_Id : Entity_Id; 7240 7241 begin 7242 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 7243 Def_Id := Entity (Arg_Internal); 7244 7245 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 7246 Error_Pragma_Arg 7247 ("pragma% must designate an object", Arg_Internal); 7248 end if; 7249 7250 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 7251 or else 7252 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 7253 then 7254 Error_Pragma_Arg 7255 ("previous Common/Psect_Object applies, pragma % not permitted", 7256 Arg_Internal); 7257 end if; 7258 7259 if Rep_Item_Too_Late (Def_Id, N) then 7260 raise Pragma_Exit; 7261 end if; 7262 7263 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 7264 7265 if Present (Arg_Size) then 7266 Check_Arg_Is_External_Name (Arg_Size); 7267 end if; 7268 7269 -- Export_Object case 7270 7271 if Prag_Id = Pragma_Export_Object then 7272 if not Is_Library_Level_Entity (Def_Id) then 7273 Error_Pragma_Arg 7274 ("argument for pragma% must be library level entity", 7275 Arg_Internal); 7276 end if; 7277 7278 if Ekind (Current_Scope) = E_Generic_Package then 7279 Error_Pragma ("pragma& cannot appear in a generic unit"); 7280 end if; 7281 7282 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then 7283 Error_Pragma_Arg 7284 ("exported object must have compile time known size", 7285 Arg_Internal); 7286 end if; 7287 7288 if Warn_On_Export_Import and then Is_Exported (Def_Id) then 7289 Error_Msg_N ("??duplicate Export_Object pragma", N); 7290 else 7291 Set_Exported (Def_Id, Arg_Internal); 7292 end if; 7293 7294 -- Import_Object case 7295 7296 else 7297 if Is_Concurrent_Type (Etype (Def_Id)) then 7298 Error_Pragma_Arg 7299 ("cannot use pragma% for task/protected object", 7300 Arg_Internal); 7301 end if; 7302 7303 if Ekind (Def_Id) = E_Constant then 7304 Error_Pragma_Arg 7305 ("cannot import a constant", Arg_Internal); 7306 end if; 7307 7308 if Warn_On_Export_Import 7309 and then Has_Discriminants (Etype (Def_Id)) 7310 then 7311 Error_Msg_N 7312 ("imported value must be initialized??", Arg_Internal); 7313 end if; 7314 7315 if Warn_On_Export_Import 7316 and then Is_Access_Type (Etype (Def_Id)) 7317 then 7318 Error_Pragma_Arg 7319 ("cannot import object of an access type??", Arg_Internal); 7320 end if; 7321 7322 if Warn_On_Export_Import 7323 and then Is_Imported (Def_Id) 7324 then 7325 Error_Msg_N ("??duplicate Import_Object pragma", N); 7326 7327 -- Check for explicit initialization present. Note that an 7328 -- initialization generated by the code generator, e.g. for an 7329 -- access type, does not count here. 7330 7331 elsif Present (Expression (Parent (Def_Id))) 7332 and then 7333 Comes_From_Source 7334 (Original_Node (Expression (Parent (Def_Id)))) 7335 then 7336 Error_Msg_Sloc := Sloc (Def_Id); 7337 Error_Pragma_Arg 7338 ("imported entities cannot be initialized (RM B.1(24))", 7339 "\no initialization allowed for & declared#", Arg1); 7340 else 7341 Set_Imported (Def_Id); 7342 Note_Possible_Modification (Arg_Internal, Sure => False); 7343 end if; 7344 end if; 7345 end Process_Extended_Import_Export_Object_Pragma; 7346 7347 ------------------------------------------------------ 7348 -- Process_Extended_Import_Export_Subprogram_Pragma -- 7349 ------------------------------------------------------ 7350 7351 procedure Process_Extended_Import_Export_Subprogram_Pragma 7352 (Arg_Internal : Node_Id; 7353 Arg_External : Node_Id; 7354 Arg_Parameter_Types : Node_Id; 7355 Arg_Result_Type : Node_Id := Empty; 7356 Arg_Mechanism : Node_Id; 7357 Arg_Result_Mechanism : Node_Id := Empty; 7358 Arg_First_Optional_Parameter : Node_Id := Empty) 7359 is 7360 Ent : Entity_Id; 7361 Def_Id : Entity_Id; 7362 Hom_Id : Entity_Id; 7363 Formal : Entity_Id; 7364 Ambiguous : Boolean; 7365 Match : Boolean; 7366 Dval : Node_Id; 7367 7368 function Same_Base_Type 7369 (Ptype : Node_Id; 7370 Formal : Entity_Id) return Boolean; 7371 -- Determines if Ptype references the type of Formal. Note that only 7372 -- the base types need to match according to the spec. Ptype here is 7373 -- the argument from the pragma, which is either a type name, or an 7374 -- access attribute. 7375 7376 -------------------- 7377 -- Same_Base_Type -- 7378 -------------------- 7379 7380 function Same_Base_Type 7381 (Ptype : Node_Id; 7382 Formal : Entity_Id) return Boolean 7383 is 7384 Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); 7385 Pref : Node_Id; 7386 7387 begin 7388 -- Case where pragma argument is typ'Access 7389 7390 if Nkind (Ptype) = N_Attribute_Reference 7391 and then Attribute_Name (Ptype) = Name_Access 7392 then 7393 Pref := Prefix (Ptype); 7394 Find_Type (Pref); 7395 7396 if not Is_Entity_Name (Pref) 7397 or else Entity (Pref) = Any_Type 7398 then 7399 raise Pragma_Exit; 7400 end if; 7401 7402 -- We have a match if the corresponding argument is of an 7403 -- anonymous access type, and its designated type matches the 7404 -- type of the prefix of the access attribute 7405 7406 return Ekind (Ftyp) = E_Anonymous_Access_Type 7407 and then Base_Type (Entity (Pref)) = 7408 Base_Type (Etype (Designated_Type (Ftyp))); 7409 7410 -- Case where pragma argument is a type name 7411 7412 else 7413 Find_Type (Ptype); 7414 7415 if not Is_Entity_Name (Ptype) 7416 or else Entity (Ptype) = Any_Type 7417 then 7418 raise Pragma_Exit; 7419 end if; 7420 7421 -- We have a match if the corresponding argument is of the type 7422 -- given in the pragma (comparing base types) 7423 7424 return Base_Type (Entity (Ptype)) = Ftyp; 7425 end if; 7426 end Same_Base_Type; 7427 7428 -- Start of processing for 7429 -- Process_Extended_Import_Export_Subprogram_Pragma 7430 7431 begin 7432 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 7433 Ent := Empty; 7434 Ambiguous := False; 7435 7436 -- Loop through homonyms (overloadings) of the entity 7437 7438 Hom_Id := Entity (Arg_Internal); 7439 while Present (Hom_Id) loop 7440 Def_Id := Get_Base_Subprogram (Hom_Id); 7441 7442 -- We need a subprogram in the current scope 7443 7444 if not Is_Subprogram (Def_Id) 7445 or else Scope (Def_Id) /= Current_Scope 7446 then 7447 null; 7448 7449 else 7450 Match := True; 7451 7452 -- Pragma cannot apply to subprogram body 7453 7454 if Is_Subprogram (Def_Id) 7455 and then Nkind (Parent (Declaration_Node (Def_Id))) = 7456 N_Subprogram_Body 7457 then 7458 Error_Pragma 7459 ("pragma% requires separate spec" 7460 & " and must come before body"); 7461 end if; 7462 7463 -- Test result type if given, note that the result type 7464 -- parameter can only be present for the function cases. 7465 7466 if Present (Arg_Result_Type) 7467 and then not Same_Base_Type (Arg_Result_Type, Def_Id) 7468 then 7469 Match := False; 7470 7471 elsif Etype (Def_Id) /= Standard_Void_Type 7472 and then 7473 Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure) 7474 then 7475 Match := False; 7476 7477 -- Test parameter types if given. Note that this parameter 7478 -- has not been analyzed (and must not be, since it is 7479 -- semantic nonsense), so we get it as the parser left it. 7480 7481 elsif Present (Arg_Parameter_Types) then 7482 Check_Matching_Types : declare 7483 Formal : Entity_Id; 7484 Ptype : Node_Id; 7485 7486 begin 7487 Formal := First_Formal (Def_Id); 7488 7489 if Nkind (Arg_Parameter_Types) = N_Null then 7490 if Present (Formal) then 7491 Match := False; 7492 end if; 7493 7494 -- A list of one type, e.g. (List) is parsed as 7495 -- a parenthesized expression. 7496 7497 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate 7498 and then Paren_Count (Arg_Parameter_Types) = 1 7499 then 7500 if No (Formal) 7501 or else Present (Next_Formal (Formal)) 7502 then 7503 Match := False; 7504 else 7505 Match := 7506 Same_Base_Type (Arg_Parameter_Types, Formal); 7507 end if; 7508 7509 -- A list of more than one type is parsed as a aggregate 7510 7511 elsif Nkind (Arg_Parameter_Types) = N_Aggregate 7512 and then Paren_Count (Arg_Parameter_Types) = 0 7513 then 7514 Ptype := First (Expressions (Arg_Parameter_Types)); 7515 while Present (Ptype) or else Present (Formal) loop 7516 if No (Ptype) 7517 or else No (Formal) 7518 or else not Same_Base_Type (Ptype, Formal) 7519 then 7520 Match := False; 7521 exit; 7522 else 7523 Next_Formal (Formal); 7524 Next (Ptype); 7525 end if; 7526 end loop; 7527 7528 -- Anything else is of the wrong form 7529 7530 else 7531 Error_Pragma_Arg 7532 ("wrong form for Parameter_Types parameter", 7533 Arg_Parameter_Types); 7534 end if; 7535 end Check_Matching_Types; 7536 end if; 7537 7538 -- Match is now False if the entry we found did not match 7539 -- either a supplied Parameter_Types or Result_Types argument 7540 7541 if Match then 7542 if No (Ent) then 7543 Ent := Def_Id; 7544 7545 -- Ambiguous case, the flag Ambiguous shows if we already 7546 -- detected this and output the initial messages. 7547 7548 else 7549 if not Ambiguous then 7550 Ambiguous := True; 7551 Error_Msg_Name_1 := Pname; 7552 Error_Msg_N 7553 ("pragma% does not uniquely identify subprogram!", 7554 N); 7555 Error_Msg_Sloc := Sloc (Ent); 7556 Error_Msg_N ("matching subprogram #!", N); 7557 Ent := Empty; 7558 end if; 7559 7560 Error_Msg_Sloc := Sloc (Def_Id); 7561 Error_Msg_N ("matching subprogram #!", N); 7562 end if; 7563 end if; 7564 end if; 7565 7566 Hom_Id := Homonym (Hom_Id); 7567 end loop; 7568 7569 -- See if we found an entry 7570 7571 if No (Ent) then 7572 if not Ambiguous then 7573 if Is_Generic_Subprogram (Entity (Arg_Internal)) then 7574 Error_Pragma 7575 ("pragma% cannot be given for generic subprogram"); 7576 else 7577 Error_Pragma 7578 ("pragma% does not identify local subprogram"); 7579 end if; 7580 end if; 7581 7582 return; 7583 end if; 7584 7585 -- Import pragmas must be for imported entities 7586 7587 if Prag_Id = Pragma_Import_Function 7588 or else 7589 Prag_Id = Pragma_Import_Procedure 7590 or else 7591 Prag_Id = Pragma_Import_Valued_Procedure 7592 then 7593 if not Is_Imported (Ent) then 7594 Error_Pragma 7595 ("pragma Import or Interface must precede pragma%"); 7596 end if; 7597 7598 -- Here we have the Export case which can set the entity as exported 7599 7600 -- But does not do so if the specified external name is null, since 7601 -- that is taken as a signal in DEC Ada 83 (with which we want to be 7602 -- compatible) to request no external name. 7603 7604 elsif Nkind (Arg_External) = N_String_Literal 7605 and then String_Length (Strval (Arg_External)) = 0 7606 then 7607 null; 7608 7609 -- In all other cases, set entity as exported 7610 7611 else 7612 Set_Exported (Ent, Arg_Internal); 7613 end if; 7614 7615 -- Special processing for Valued_Procedure cases 7616 7617 if Prag_Id = Pragma_Import_Valued_Procedure 7618 or else 7619 Prag_Id = Pragma_Export_Valued_Procedure 7620 then 7621 Formal := First_Formal (Ent); 7622 7623 if No (Formal) then 7624 Error_Pragma ("at least one parameter required for pragma%"); 7625 7626 elsif Ekind (Formal) /= E_Out_Parameter then 7627 Error_Pragma ("first parameter must have mode out for pragma%"); 7628 7629 else 7630 Set_Is_Valued_Procedure (Ent); 7631 end if; 7632 end if; 7633 7634 Set_Extended_Import_Export_External_Name (Ent, Arg_External); 7635 7636 -- Process Result_Mechanism argument if present. We have already 7637 -- checked that this is only allowed for the function case. 7638 7639 if Present (Arg_Result_Mechanism) then 7640 Set_Mechanism_Value (Ent, Arg_Result_Mechanism); 7641 end if; 7642 7643 -- Process Mechanism parameter if present. Note that this parameter 7644 -- is not analyzed, and must not be analyzed since it is semantic 7645 -- nonsense, so we get it in exactly as the parser left it. 7646 7647 if Present (Arg_Mechanism) then 7648 declare 7649 Formal : Entity_Id; 7650 Massoc : Node_Id; 7651 Mname : Node_Id; 7652 Choice : Node_Id; 7653 7654 begin 7655 -- A single mechanism association without a formal parameter 7656 -- name is parsed as a parenthesized expression. All other 7657 -- cases are parsed as aggregates, so we rewrite the single 7658 -- parameter case as an aggregate for consistency. 7659 7660 if Nkind (Arg_Mechanism) /= N_Aggregate 7661 and then Paren_Count (Arg_Mechanism) = 1 7662 then 7663 Rewrite (Arg_Mechanism, 7664 Make_Aggregate (Sloc (Arg_Mechanism), 7665 Expressions => New_List ( 7666 Relocate_Node (Arg_Mechanism)))); 7667 end if; 7668 7669 -- Case of only mechanism name given, applies to all formals 7670 7671 if Nkind (Arg_Mechanism) /= N_Aggregate then 7672 Formal := First_Formal (Ent); 7673 while Present (Formal) loop 7674 Set_Mechanism_Value (Formal, Arg_Mechanism); 7675 Next_Formal (Formal); 7676 end loop; 7677 7678 -- Case of list of mechanism associations given 7679 7680 else 7681 if Null_Record_Present (Arg_Mechanism) then 7682 Error_Pragma_Arg 7683 ("inappropriate form for Mechanism parameter", 7684 Arg_Mechanism); 7685 end if; 7686 7687 -- Deal with positional ones first 7688 7689 Formal := First_Formal (Ent); 7690 7691 if Present (Expressions (Arg_Mechanism)) then 7692 Mname := First (Expressions (Arg_Mechanism)); 7693 while Present (Mname) loop 7694 if No (Formal) then 7695 Error_Pragma_Arg 7696 ("too many mechanism associations", Mname); 7697 end if; 7698 7699 Set_Mechanism_Value (Formal, Mname); 7700 Next_Formal (Formal); 7701 Next (Mname); 7702 end loop; 7703 end if; 7704 7705 -- Deal with named entries 7706 7707 if Present (Component_Associations (Arg_Mechanism)) then 7708 Massoc := First (Component_Associations (Arg_Mechanism)); 7709 while Present (Massoc) loop 7710 Choice := First (Choices (Massoc)); 7711 7712 if Nkind (Choice) /= N_Identifier 7713 or else Present (Next (Choice)) 7714 then 7715 Error_Pragma_Arg 7716 ("incorrect form for mechanism association", 7717 Massoc); 7718 end if; 7719 7720 Formal := First_Formal (Ent); 7721 loop 7722 if No (Formal) then 7723 Error_Pragma_Arg 7724 ("parameter name & not present", Choice); 7725 end if; 7726 7727 if Chars (Choice) = Chars (Formal) then 7728 Set_Mechanism_Value 7729 (Formal, Expression (Massoc)); 7730 7731 -- Set entity on identifier (needed by ASIS) 7732 7733 Set_Entity (Choice, Formal); 7734 7735 exit; 7736 end if; 7737 7738 Next_Formal (Formal); 7739 end loop; 7740 7741 Next (Massoc); 7742 end loop; 7743 end if; 7744 end if; 7745 end; 7746 end if; 7747 7748 -- Process First_Optional_Parameter argument if present. We have 7749 -- already checked that this is only allowed for the Import case. 7750 7751 if Present (Arg_First_Optional_Parameter) then 7752 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then 7753 Error_Pragma_Arg 7754 ("first optional parameter must be formal parameter name", 7755 Arg_First_Optional_Parameter); 7756 end if; 7757 7758 Formal := First_Formal (Ent); 7759 loop 7760 if No (Formal) then 7761 Error_Pragma_Arg 7762 ("specified formal parameter& not found", 7763 Arg_First_Optional_Parameter); 7764 end if; 7765 7766 exit when Chars (Formal) = 7767 Chars (Arg_First_Optional_Parameter); 7768 7769 Next_Formal (Formal); 7770 end loop; 7771 7772 Set_First_Optional_Parameter (Ent, Formal); 7773 7774 -- Check specified and all remaining formals have right form 7775 7776 while Present (Formal) loop 7777 if Ekind (Formal) /= E_In_Parameter then 7778 Error_Msg_NE 7779 ("optional formal& is not of mode in!", 7780 Arg_First_Optional_Parameter, Formal); 7781 7782 else 7783 Dval := Default_Value (Formal); 7784 7785 if No (Dval) then 7786 Error_Msg_NE 7787 ("optional formal& does not have default value!", 7788 Arg_First_Optional_Parameter, Formal); 7789 7790 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then 7791 null; 7792 7793 else 7794 Error_Msg_FE 7795 ("default value for optional formal& is non-static!", 7796 Arg_First_Optional_Parameter, Formal); 7797 end if; 7798 end if; 7799 7800 Set_Is_Optional_Parameter (Formal); 7801 Next_Formal (Formal); 7802 end loop; 7803 end if; 7804 end Process_Extended_Import_Export_Subprogram_Pragma; 7805 7806 -------------------------- 7807 -- Process_Generic_List -- 7808 -------------------------- 7809 7810 procedure Process_Generic_List is 7811 Arg : Node_Id; 7812 Exp : Node_Id; 7813 7814 begin 7815 Check_No_Identifiers; 7816 Check_At_Least_N_Arguments (1); 7817 7818 -- Check all arguments are names of generic units or instances 7819 7820 Arg := Arg1; 7821 while Present (Arg) loop 7822 Exp := Get_Pragma_Arg (Arg); 7823 Analyze (Exp); 7824 7825 if not Is_Entity_Name (Exp) 7826 or else 7827 (not Is_Generic_Instance (Entity (Exp)) 7828 and then 7829 not Is_Generic_Unit (Entity (Exp))) 7830 then 7831 Error_Pragma_Arg 7832 ("pragma% argument must be name of generic unit/instance", 7833 Arg); 7834 end if; 7835 7836 Next (Arg); 7837 end loop; 7838 end Process_Generic_List; 7839 7840 ------------------------------------ 7841 -- Process_Import_Predefined_Type -- 7842 ------------------------------------ 7843 7844 procedure Process_Import_Predefined_Type is 7845 Loc : constant Source_Ptr := Sloc (N); 7846 Elmt : Elmt_Id; 7847 Ftyp : Node_Id := Empty; 7848 Decl : Node_Id; 7849 Def : Node_Id; 7850 Nam : Name_Id; 7851 7852 begin 7853 String_To_Name_Buffer (Strval (Expression (Arg3))); 7854 Nam := Name_Find; 7855 7856 Elmt := First_Elmt (Predefined_Float_Types); 7857 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop 7858 Next_Elmt (Elmt); 7859 end loop; 7860 7861 Ftyp := Node (Elmt); 7862 7863 if Present (Ftyp) then 7864 7865 -- Don't build a derived type declaration, because predefined C 7866 -- types have no declaration anywhere, so cannot really be named. 7867 -- Instead build a full type declaration, starting with an 7868 -- appropriate type definition is built 7869 7870 if Is_Floating_Point_Type (Ftyp) then 7871 Def := Make_Floating_Point_Definition (Loc, 7872 Make_Integer_Literal (Loc, Digits_Value (Ftyp)), 7873 Make_Real_Range_Specification (Loc, 7874 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))), 7875 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp))))); 7876 7877 -- Should never have a predefined type we cannot handle 7878 7879 else 7880 raise Program_Error; 7881 end if; 7882 7883 -- Build and insert a Full_Type_Declaration, which will be 7884 -- analyzed as soon as this list entry has been analyzed. 7885 7886 Decl := Make_Full_Type_Declaration (Loc, 7887 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))), 7888 Type_Definition => Def); 7889 7890 Insert_After (N, Decl); 7891 Mark_Rewrite_Insertion (Decl); 7892 7893 else 7894 Error_Pragma_Arg ("no matching type found for pragma%", 7895 Arg2); 7896 end if; 7897 end Process_Import_Predefined_Type; 7898 7899 --------------------------------- 7900 -- Process_Import_Or_Interface -- 7901 --------------------------------- 7902 7903 procedure Process_Import_Or_Interface is 7904 C : Convention_Id; 7905 Def_Id : Entity_Id; 7906 Hom_Id : Entity_Id; 7907 7908 begin 7909 -- In Relaxed_RM_Semantics, support old Ada 83 style: 7910 -- pragma Import (Entity, "external name"); 7911 7912 if Relaxed_RM_Semantics 7913 and then Arg_Count = 2 7914 and then Prag_Id = Pragma_Import 7915 and then Nkind (Expression (Arg2)) = N_String_Literal 7916 then 7917 C := Convention_C; 7918 Def_Id := Get_Pragma_Arg (Arg1); 7919 Analyze (Def_Id); 7920 7921 if not Is_Entity_Name (Def_Id) then 7922 Error_Pragma_Arg ("entity name required", Arg1); 7923 end if; 7924 7925 Def_Id := Entity (Def_Id); 7926 Kill_Size_Check_Code (Def_Id); 7927 Note_Possible_Modification (Get_Pragma_Arg (Arg1), Sure => False); 7928 7929 else 7930 Process_Convention (C, Def_Id); 7931 Kill_Size_Check_Code (Def_Id); 7932 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); 7933 end if; 7934 7935 if Ekind_In (Def_Id, E_Variable, E_Constant) then 7936 7937 -- We do not permit Import to apply to a renaming declaration 7938 7939 if Present (Renamed_Object (Def_Id)) then 7940 Error_Pragma_Arg 7941 ("pragma% not allowed for object renaming", Arg2); 7942 7943 -- User initialization is not allowed for imported object, but 7944 -- the object declaration may contain a default initialization, 7945 -- that will be discarded. Note that an explicit initialization 7946 -- only counts if it comes from source, otherwise it is simply 7947 -- the code generator making an implicit initialization explicit. 7948 7949 elsif Present (Expression (Parent (Def_Id))) 7950 and then Comes_From_Source (Expression (Parent (Def_Id))) 7951 then 7952 Error_Msg_Sloc := Sloc (Def_Id); 7953 Error_Pragma_Arg 7954 ("no initialization allowed for declaration of& #", 7955 "\imported entities cannot be initialized (RM B.1(24))", 7956 Arg2); 7957 7958 else 7959 Set_Imported (Def_Id); 7960 Process_Interface_Name (Def_Id, Arg3, Arg4); 7961 7962 -- Note that we do not set Is_Public here. That's because we 7963 -- only want to set it if there is no address clause, and we 7964 -- don't know that yet, so we delay that processing till 7965 -- freeze time. 7966 7967 -- pragma Import completes deferred constants 7968 7969 if Ekind (Def_Id) = E_Constant then 7970 Set_Has_Completion (Def_Id); 7971 end if; 7972 7973 -- It is not possible to import a constant of an unconstrained 7974 -- array type (e.g. string) because there is no simple way to 7975 -- write a meaningful subtype for it. 7976 7977 if Is_Array_Type (Etype (Def_Id)) 7978 and then not Is_Constrained (Etype (Def_Id)) 7979 then 7980 Error_Msg_NE 7981 ("imported constant& must have a constrained subtype", 7982 N, Def_Id); 7983 end if; 7984 end if; 7985 7986 elsif Is_Subprogram (Def_Id) 7987 or else Is_Generic_Subprogram (Def_Id) 7988 then 7989 -- If the name is overloaded, pragma applies to all of the denoted 7990 -- entities in the same declarative part, unless the pragma comes 7991 -- from an aspect specification. 7992 7993 Hom_Id := Def_Id; 7994 while Present (Hom_Id) loop 7995 7996 Def_Id := Get_Base_Subprogram (Hom_Id); 7997 7998 -- Ignore inherited subprograms because the pragma will apply 7999 -- to the parent operation, which is the one called. 8000 8001 if Is_Overloadable (Def_Id) 8002 and then Present (Alias (Def_Id)) 8003 then 8004 null; 8005 8006 -- If it is not a subprogram, it must be in an outer scope and 8007 -- pragma does not apply. 8008 8009 elsif not Is_Subprogram (Def_Id) 8010 and then not Is_Generic_Subprogram (Def_Id) 8011 then 8012 null; 8013 8014 -- The pragma does not apply to primitives of interfaces 8015 8016 elsif Is_Dispatching_Operation (Def_Id) 8017 and then Present (Find_Dispatching_Type (Def_Id)) 8018 and then Is_Interface (Find_Dispatching_Type (Def_Id)) 8019 then 8020 null; 8021 8022 -- Verify that the homonym is in the same declarative part (not 8023 -- just the same scope). If the pragma comes from an aspect 8024 -- specification we know that it is part of the declaration. 8025 8026 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) 8027 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux 8028 and then not From_Aspect_Specification (N) 8029 then 8030 exit; 8031 8032 else 8033 Set_Imported (Def_Id); 8034 8035 -- Reject an Import applied to an abstract subprogram 8036 8037 if Is_Subprogram (Def_Id) 8038 and then Is_Abstract_Subprogram (Def_Id) 8039 then 8040 Error_Msg_Sloc := Sloc (Def_Id); 8041 Error_Msg_NE 8042 ("cannot import abstract subprogram& declared#", 8043 Arg2, Def_Id); 8044 end if; 8045 8046 -- Special processing for Convention_Intrinsic 8047 8048 if C = Convention_Intrinsic then 8049 8050 -- Link_Name argument not allowed for intrinsic 8051 8052 Check_No_Link_Name; 8053 8054 Set_Is_Intrinsic_Subprogram (Def_Id); 8055 8056 -- If no external name is present, then check that this 8057 -- is a valid intrinsic subprogram. If an external name 8058 -- is present, then this is handled by the back end. 8059 8060 if No (Arg3) then 8061 Check_Intrinsic_Subprogram 8062 (Def_Id, Get_Pragma_Arg (Arg2)); 8063 end if; 8064 end if; 8065 8066 -- Verify that the subprogram does not have a completion 8067 -- through a renaming declaration. For other completions the 8068 -- pragma appears as a too late representation. 8069 8070 declare 8071 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); 8072 8073 begin 8074 if Present (Decl) 8075 and then Nkind (Decl) = N_Subprogram_Declaration 8076 and then Present (Corresponding_Body (Decl)) 8077 and then Nkind (Unit_Declaration_Node 8078 (Corresponding_Body (Decl))) = 8079 N_Subprogram_Renaming_Declaration 8080 then 8081 Error_Msg_Sloc := Sloc (Def_Id); 8082 Error_Msg_NE 8083 ("cannot import&, renaming already provided for " 8084 & "declaration #", N, Def_Id); 8085 end if; 8086 end; 8087 8088 Set_Has_Completion (Def_Id); 8089 Process_Interface_Name (Def_Id, Arg3, Arg4); 8090 end if; 8091 8092 if Is_Compilation_Unit (Hom_Id) then 8093 8094 -- Its possible homonyms are not affected by the pragma. 8095 -- Such homonyms might be present in the context of other 8096 -- units being compiled. 8097 8098 exit; 8099 8100 elsif From_Aspect_Specification (N) then 8101 exit; 8102 8103 else 8104 Hom_Id := Homonym (Hom_Id); 8105 end if; 8106 end loop; 8107 8108 -- When the convention is Java or CIL, we also allow Import to 8109 -- be given for packages, generic packages, exceptions, record 8110 -- components, and access to subprograms. 8111 8112 elsif (C = Convention_Java or else C = Convention_CIL) 8113 and then 8114 (Is_Package_Or_Generic_Package (Def_Id) 8115 or else Ekind (Def_Id) = E_Exception 8116 or else Ekind (Def_Id) = E_Access_Subprogram_Type 8117 or else Nkind (Parent (Def_Id)) = N_Component_Declaration) 8118 then 8119 Set_Imported (Def_Id); 8120 Set_Is_Public (Def_Id); 8121 Process_Interface_Name (Def_Id, Arg3, Arg4); 8122 8123 -- Import a CPP class 8124 8125 elsif C = Convention_CPP 8126 and then (Is_Record_Type (Def_Id) 8127 or else Ekind (Def_Id) = E_Incomplete_Type) 8128 then 8129 if Ekind (Def_Id) = E_Incomplete_Type then 8130 if Present (Full_View (Def_Id)) then 8131 Def_Id := Full_View (Def_Id); 8132 8133 else 8134 Error_Msg_N 8135 ("cannot import 'C'P'P type before full declaration seen", 8136 Get_Pragma_Arg (Arg2)); 8137 8138 -- Although we have reported the error we decorate it as 8139 -- CPP_Class to avoid reporting spurious errors 8140 8141 Set_Is_CPP_Class (Def_Id); 8142 return; 8143 end if; 8144 end if; 8145 8146 -- Types treated as CPP classes must be declared limited (note: 8147 -- this used to be a warning but there is no real benefit to it 8148 -- since we did effectively intend to treat the type as limited 8149 -- anyway). 8150 8151 if not Is_Limited_Type (Def_Id) then 8152 Error_Msg_N 8153 ("imported 'C'P'P type must be limited", 8154 Get_Pragma_Arg (Arg2)); 8155 end if; 8156 8157 if Etype (Def_Id) /= Def_Id 8158 and then not Is_CPP_Class (Root_Type (Def_Id)) 8159 then 8160 Error_Msg_N ("root type must be a 'C'P'P type", Arg1); 8161 end if; 8162 8163 Set_Is_CPP_Class (Def_Id); 8164 8165 -- Imported CPP types must not have discriminants (because C++ 8166 -- classes do not have discriminants). 8167 8168 if Has_Discriminants (Def_Id) then 8169 Error_Msg_N 8170 ("imported 'C'P'P type cannot have discriminants", 8171 First (Discriminant_Specifications 8172 (Declaration_Node (Def_Id)))); 8173 end if; 8174 8175 -- Check that components of imported CPP types do not have default 8176 -- expressions. For private types this check is performed when the 8177 -- full view is analyzed (see Process_Full_View). 8178 8179 if not Is_Private_Type (Def_Id) then 8180 Check_CPP_Type_Has_No_Defaults (Def_Id); 8181 end if; 8182 8183 -- Import a CPP exception 8184 8185 elsif C = Convention_CPP 8186 and then Ekind (Def_Id) = E_Exception 8187 then 8188 if No (Arg3) then 8189 Error_Pragma_Arg 8190 ("'External_'Name arguments is required for 'Cpp exception", 8191 Arg3); 8192 else 8193 -- As only a string is allowed, Check_Arg_Is_External_Name 8194 -- isn't called. 8195 Check_Arg_Is_Static_Expression (Arg3, Standard_String); 8196 end if; 8197 8198 if Present (Arg4) then 8199 Error_Pragma_Arg 8200 ("Link_Name argument not allowed for imported Cpp exception", 8201 Arg4); 8202 end if; 8203 8204 -- Do not call Set_Interface_Name as the name of the exception 8205 -- shouldn't be modified (and in particular it shouldn't be 8206 -- the External_Name). For exceptions, the External_Name is the 8207 -- name of the RTTI structure. 8208 8209 -- ??? Emit an error if pragma Import/Export_Exception is present 8210 8211 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then 8212 Check_No_Link_Name; 8213 Check_Arg_Count (3); 8214 Check_Arg_Is_Static_Expression (Arg3, Standard_String); 8215 8216 Process_Import_Predefined_Type; 8217 8218 else 8219 Error_Pragma_Arg 8220 ("second argument of pragma% must be object, subprogram " 8221 & "or incomplete type", 8222 Arg2); 8223 end if; 8224 8225 -- If this pragma applies to a compilation unit, then the unit, which 8226 -- is a subprogram, does not require (or allow) a body. We also do 8227 -- not need to elaborate imported procedures. 8228 8229 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 8230 declare 8231 Cunit : constant Node_Id := Parent (Parent (N)); 8232 begin 8233 Set_Body_Required (Cunit, False); 8234 end; 8235 end if; 8236 end Process_Import_Or_Interface; 8237 8238 -------------------- 8239 -- Process_Inline -- 8240 -------------------- 8241 8242 procedure Process_Inline (Status : Inline_Status) is 8243 Assoc : Node_Id; 8244 Decl : Node_Id; 8245 Subp_Id : Node_Id; 8246 Subp : Entity_Id; 8247 Applies : Boolean; 8248 8249 Effective : Boolean := False; 8250 -- Set True if inline has some effect, i.e. if there is at least one 8251 -- subprogram set as inlined as a result of the use of the pragma. 8252 8253 procedure Make_Inline (Subp : Entity_Id); 8254 -- Subp is the defining unit name of the subprogram declaration. Set 8255 -- the flag, as well as the flag in the corresponding body, if there 8256 -- is one present. 8257 8258 procedure Set_Inline_Flags (Subp : Entity_Id); 8259 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also 8260 -- Has_Pragma_Inline_Always for the Inline_Always case. 8261 8262 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; 8263 -- Returns True if it can be determined at this stage that inlining 8264 -- is not possible, for example if the body is available and contains 8265 -- exception handlers, we prevent inlining, since otherwise we can 8266 -- get undefined symbols at link time. This function also emits a 8267 -- warning if front-end inlining is enabled and the pragma appears 8268 -- too late. 8269 -- 8270 -- ??? is business with link symbols still valid, or does it relate 8271 -- to front end ZCX which is being phased out ??? 8272 8273 --------------------------- 8274 -- Inlining_Not_Possible -- 8275 --------------------------- 8276 8277 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is 8278 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 8279 Stats : Node_Id; 8280 8281 begin 8282 if Nkind (Decl) = N_Subprogram_Body then 8283 Stats := Handled_Statement_Sequence (Decl); 8284 return Present (Exception_Handlers (Stats)) 8285 or else Present (At_End_Proc (Stats)); 8286 8287 elsif Nkind (Decl) = N_Subprogram_Declaration 8288 and then Present (Corresponding_Body (Decl)) 8289 then 8290 if Front_End_Inlining 8291 and then Analyzed (Corresponding_Body (Decl)) 8292 then 8293 Error_Msg_N ("pragma appears too late, ignored??", N); 8294 return True; 8295 8296 -- If the subprogram is a renaming as body, the body is just a 8297 -- call to the renamed subprogram, and inlining is trivially 8298 -- possible. 8299 8300 elsif 8301 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = 8302 N_Subprogram_Renaming_Declaration 8303 then 8304 return False; 8305 8306 else 8307 Stats := 8308 Handled_Statement_Sequence 8309 (Unit_Declaration_Node (Corresponding_Body (Decl))); 8310 8311 return 8312 Present (Exception_Handlers (Stats)) 8313 or else Present (At_End_Proc (Stats)); 8314 end if; 8315 8316 else 8317 -- If body is not available, assume the best, the check is 8318 -- performed again when compiling enclosing package bodies. 8319 8320 return False; 8321 end if; 8322 end Inlining_Not_Possible; 8323 8324 ----------------- 8325 -- Make_Inline -- 8326 ----------------- 8327 8328 procedure Make_Inline (Subp : Entity_Id) is 8329 Kind : constant Entity_Kind := Ekind (Subp); 8330 Inner_Subp : Entity_Id := Subp; 8331 8332 begin 8333 -- Ignore if bad type, avoid cascaded error 8334 8335 if Etype (Subp) = Any_Type then 8336 Applies := True; 8337 return; 8338 8339 -- Ignore if all inlining is suppressed 8340 8341 elsif Suppress_All_Inlining then 8342 Applies := True; 8343 return; 8344 8345 -- If inlining is not possible, for now do not treat as an error 8346 8347 elsif Status /= Suppressed 8348 and then Inlining_Not_Possible (Subp) 8349 then 8350 Applies := True; 8351 return; 8352 8353 -- Here we have a candidate for inlining, but we must exclude 8354 -- derived operations. Otherwise we would end up trying to inline 8355 -- a phantom declaration, and the result would be to drag in a 8356 -- body which has no direct inlining associated with it. That 8357 -- would not only be inefficient but would also result in the 8358 -- backend doing cross-unit inlining in cases where it was 8359 -- definitely inappropriate to do so. 8360 8361 -- However, a simple Comes_From_Source test is insufficient, since 8362 -- we do want to allow inlining of generic instances which also do 8363 -- not come from source. We also need to recognize specs generated 8364 -- by the front-end for bodies that carry the pragma. Finally, 8365 -- predefined operators do not come from source but are not 8366 -- inlineable either. 8367 8368 elsif Is_Generic_Instance (Subp) 8369 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration 8370 then 8371 null; 8372 8373 elsif not Comes_From_Source (Subp) 8374 and then Scope (Subp) /= Standard_Standard 8375 then 8376 Applies := True; 8377 return; 8378 end if; 8379 8380 -- The referenced entity must either be the enclosing entity, or 8381 -- an entity declared within the current open scope. 8382 8383 if Present (Scope (Subp)) 8384 and then Scope (Subp) /= Current_Scope 8385 and then Subp /= Current_Scope 8386 then 8387 Error_Pragma_Arg 8388 ("argument of% must be entity in current scope", Assoc); 8389 return; 8390 end if; 8391 8392 -- Processing for procedure, operator or function. If subprogram 8393 -- is aliased (as for an instance) indicate that the renamed 8394 -- entity (if declared in the same unit) is inlined. 8395 8396 if Is_Subprogram (Subp) then 8397 Inner_Subp := Ultimate_Alias (Inner_Subp); 8398 8399 if In_Same_Source_Unit (Subp, Inner_Subp) then 8400 Set_Inline_Flags (Inner_Subp); 8401 8402 Decl := Parent (Parent (Inner_Subp)); 8403 8404 if Nkind (Decl) = N_Subprogram_Declaration 8405 and then Present (Corresponding_Body (Decl)) 8406 then 8407 Set_Inline_Flags (Corresponding_Body (Decl)); 8408 8409 elsif Is_Generic_Instance (Subp) then 8410 8411 -- Indicate that the body needs to be created for 8412 -- inlining subsequent calls. The instantiation node 8413 -- follows the declaration of the wrapper package 8414 -- created for it. 8415 8416 if Scope (Subp) /= Standard_Standard 8417 and then 8418 Need_Subprogram_Instance_Body 8419 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), 8420 Subp) 8421 then 8422 null; 8423 end if; 8424 8425 -- Inline is a program unit pragma (RM 10.1.5) and cannot 8426 -- appear in a formal part to apply to a formal subprogram. 8427 -- Do not apply check within an instance or a formal package 8428 -- the test will have been applied to the original generic. 8429 8430 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration 8431 and then List_Containing (Decl) = List_Containing (N) 8432 and then not In_Instance 8433 then 8434 Error_Msg_N 8435 ("Inline cannot apply to a formal subprogram", N); 8436 8437 -- If Subp is a renaming, it is the renamed entity that 8438 -- will appear in any call, and be inlined. However, for 8439 -- ASIS uses it is convenient to indicate that the renaming 8440 -- itself is an inlined subprogram, so that some gnatcheck 8441 -- rules can be applied in the absence of expansion. 8442 8443 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then 8444 Set_Inline_Flags (Subp); 8445 end if; 8446 end if; 8447 8448 Applies := True; 8449 8450 -- For a generic subprogram set flag as well, for use at the point 8451 -- of instantiation, to determine whether the body should be 8452 -- generated. 8453 8454 elsif Is_Generic_Subprogram (Subp) then 8455 Set_Inline_Flags (Subp); 8456 Applies := True; 8457 8458 -- Literals are by definition inlined 8459 8460 elsif Kind = E_Enumeration_Literal then 8461 null; 8462 8463 -- Anything else is an error 8464 8465 else 8466 Error_Pragma_Arg 8467 ("expect subprogram name for pragma%", Assoc); 8468 end if; 8469 end Make_Inline; 8470 8471 ---------------------- 8472 -- Set_Inline_Flags -- 8473 ---------------------- 8474 8475 procedure Set_Inline_Flags (Subp : Entity_Id) is 8476 begin 8477 -- First set the Has_Pragma_XXX flags and issue the appropriate 8478 -- errors and warnings for suspicious combinations. 8479 8480 if Prag_Id = Pragma_No_Inline then 8481 if Has_Pragma_Inline_Always (Subp) then 8482 Error_Msg_N 8483 ("Inline_Always and No_Inline are mutually exclusive", N); 8484 elsif Has_Pragma_Inline (Subp) then 8485 Error_Msg_NE 8486 ("Inline and No_Inline both specified for& ??", 8487 N, Entity (Subp_Id)); 8488 end if; 8489 8490 Set_Has_Pragma_No_Inline (Subp); 8491 else 8492 if Prag_Id = Pragma_Inline_Always then 8493 if Has_Pragma_No_Inline (Subp) then 8494 Error_Msg_N 8495 ("Inline_Always and No_Inline are mutually exclusive", 8496 N); 8497 end if; 8498 8499 Set_Has_Pragma_Inline_Always (Subp); 8500 else 8501 if Has_Pragma_No_Inline (Subp) then 8502 Error_Msg_NE 8503 ("Inline and No_Inline both specified for& ??", 8504 N, Entity (Subp_Id)); 8505 end if; 8506 end if; 8507 8508 if not Has_Pragma_Inline (Subp) then 8509 Set_Has_Pragma_Inline (Subp); 8510 Effective := True; 8511 end if; 8512 end if; 8513 8514 -- Then adjust the Is_Inlined flag. It can never be set if the 8515 -- subprogram is subject to pragma No_Inline. 8516 8517 case Status is 8518 when Suppressed => 8519 Set_Is_Inlined (Subp, False); 8520 when Disabled => 8521 null; 8522 when Enabled => 8523 if not Has_Pragma_No_Inline (Subp) then 8524 Set_Is_Inlined (Subp, True); 8525 end if; 8526 end case; 8527 end Set_Inline_Flags; 8528 8529 -- Start of processing for Process_Inline 8530 8531 begin 8532 Check_No_Identifiers; 8533 Check_At_Least_N_Arguments (1); 8534 8535 if Status = Enabled then 8536 Inline_Processing_Required := True; 8537 end if; 8538 8539 Assoc := Arg1; 8540 while Present (Assoc) loop 8541 Subp_Id := Get_Pragma_Arg (Assoc); 8542 Analyze (Subp_Id); 8543 Applies := False; 8544 8545 if Is_Entity_Name (Subp_Id) then 8546 Subp := Entity (Subp_Id); 8547 8548 if Subp = Any_Id then 8549 8550 -- If previous error, avoid cascaded errors 8551 8552 Check_Error_Detected; 8553 Applies := True; 8554 Effective := True; 8555 8556 else 8557 Make_Inline (Subp); 8558 8559 -- For the pragma case, climb homonym chain. This is 8560 -- what implements allowing the pragma in the renaming 8561 -- case, with the result applying to the ancestors, and 8562 -- also allows Inline to apply to all previous homonyms. 8563 8564 if not From_Aspect_Specification (N) then 8565 while Present (Homonym (Subp)) 8566 and then Scope (Homonym (Subp)) = Current_Scope 8567 loop 8568 Make_Inline (Homonym (Subp)); 8569 Subp := Homonym (Subp); 8570 end loop; 8571 end if; 8572 end if; 8573 end if; 8574 8575 if not Applies then 8576 Error_Pragma_Arg 8577 ("inappropriate argument for pragma%", Assoc); 8578 8579 elsif not Effective 8580 and then Warn_On_Redundant_Constructs 8581 and then not (Status = Suppressed or else Suppress_All_Inlining) 8582 then 8583 if Inlining_Not_Possible (Subp) then 8584 Error_Msg_NE 8585 ("pragma Inline for& is ignored?r?", 8586 N, Entity (Subp_Id)); 8587 else 8588 Error_Msg_NE 8589 ("pragma Inline for& is redundant?r?", 8590 N, Entity (Subp_Id)); 8591 end if; 8592 end if; 8593 8594 Next (Assoc); 8595 end loop; 8596 end Process_Inline; 8597 8598 ---------------------------- 8599 -- Process_Interface_Name -- 8600 ---------------------------- 8601 8602 procedure Process_Interface_Name 8603 (Subprogram_Def : Entity_Id; 8604 Ext_Arg : Node_Id; 8605 Link_Arg : Node_Id) 8606 is 8607 Ext_Nam : Node_Id; 8608 Link_Nam : Node_Id; 8609 String_Val : String_Id; 8610 8611 procedure Check_Form_Of_Interface_Name 8612 (SN : Node_Id; 8613 Ext_Name_Case : Boolean); 8614 -- SN is a string literal node for an interface name. This routine 8615 -- performs some minimal checks that the name is reasonable. In 8616 -- particular that no spaces or other obviously incorrect characters 8617 -- appear. This is only a warning, since any characters are allowed. 8618 -- Ext_Name_Case is True for an External_Name, False for a Link_Name. 8619 8620 ---------------------------------- 8621 -- Check_Form_Of_Interface_Name -- 8622 ---------------------------------- 8623 8624 procedure Check_Form_Of_Interface_Name 8625 (SN : Node_Id; 8626 Ext_Name_Case : Boolean) 8627 is 8628 S : constant String_Id := Strval (Expr_Value_S (SN)); 8629 SL : constant Nat := String_Length (S); 8630 C : Char_Code; 8631 8632 begin 8633 if SL = 0 then 8634 Error_Msg_N ("interface name cannot be null string", SN); 8635 end if; 8636 8637 for J in 1 .. SL loop 8638 C := Get_String_Char (S, J); 8639 8640 -- Look for dubious character and issue unconditional warning. 8641 -- Definitely dubious if not in character range. 8642 8643 if not In_Character_Range (C) 8644 8645 -- For all cases except CLI target, 8646 -- commas, spaces and slashes are dubious (in CLI, we use 8647 -- commas and backslashes in external names to specify 8648 -- assembly version and public key, while slashes and spaces 8649 -- can be used in names to mark nested classes and 8650 -- valuetypes). 8651 8652 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) 8653 and then (Get_Character (C) = ',' 8654 or else 8655 Get_Character (C) = '\')) 8656 or else (VM_Target /= CLI_Target 8657 and then (Get_Character (C) = ' ' 8658 or else 8659 Get_Character (C) = '/')) 8660 then 8661 Error_Msg 8662 ("??interface name contains illegal character", 8663 Sloc (SN) + Source_Ptr (J)); 8664 end if; 8665 end loop; 8666 end Check_Form_Of_Interface_Name; 8667 8668 -- Start of processing for Process_Interface_Name 8669 8670 begin 8671 if No (Link_Arg) then 8672 if No (Ext_Arg) then 8673 if VM_Target = CLI_Target 8674 and then Ekind (Subprogram_Def) = E_Package 8675 and then Nkind (Parent (Subprogram_Def)) = 8676 N_Package_Specification 8677 and then Present (Generic_Parent (Parent (Subprogram_Def))) 8678 then 8679 Set_Interface_Name 8680 (Subprogram_Def, 8681 Interface_Name 8682 (Generic_Parent (Parent (Subprogram_Def)))); 8683 end if; 8684 8685 return; 8686 8687 elsif Chars (Ext_Arg) = Name_Link_Name then 8688 Ext_Nam := Empty; 8689 Link_Nam := Expression (Ext_Arg); 8690 8691 else 8692 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 8693 Ext_Nam := Expression (Ext_Arg); 8694 Link_Nam := Empty; 8695 end if; 8696 8697 else 8698 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 8699 Check_Optional_Identifier (Link_Arg, Name_Link_Name); 8700 Ext_Nam := Expression (Ext_Arg); 8701 Link_Nam := Expression (Link_Arg); 8702 end if; 8703 8704 -- Check expressions for external name and link name are static 8705 8706 if Present (Ext_Nam) then 8707 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); 8708 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); 8709 8710 -- Verify that external name is not the name of a local entity, 8711 -- which would hide the imported one and could lead to run-time 8712 -- surprises. The problem can only arise for entities declared in 8713 -- a package body (otherwise the external name is fully qualified 8714 -- and will not conflict). 8715 8716 declare 8717 Nam : Name_Id; 8718 E : Entity_Id; 8719 Par : Node_Id; 8720 8721 begin 8722 if Prag_Id = Pragma_Import then 8723 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); 8724 Nam := Name_Find; 8725 E := Entity_Id (Get_Name_Table_Info (Nam)); 8726 8727 if Nam /= Chars (Subprogram_Def) 8728 and then Present (E) 8729 and then not Is_Overloadable (E) 8730 and then Is_Immediately_Visible (E) 8731 and then not Is_Imported (E) 8732 and then Ekind (Scope (E)) = E_Package 8733 then 8734 Par := Parent (E); 8735 while Present (Par) loop 8736 if Nkind (Par) = N_Package_Body then 8737 Error_Msg_Sloc := Sloc (E); 8738 Error_Msg_NE 8739 ("imported entity is hidden by & declared#", 8740 Ext_Arg, E); 8741 exit; 8742 end if; 8743 8744 Par := Parent (Par); 8745 end loop; 8746 end if; 8747 end if; 8748 end; 8749 end if; 8750 8751 if Present (Link_Nam) then 8752 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); 8753 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); 8754 end if; 8755 8756 -- If there is no link name, just set the external name 8757 8758 if No (Link_Nam) then 8759 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); 8760 8761 -- For the Link_Name case, the given literal is preceded by an 8762 -- asterisk, which indicates to GCC that the given name should be 8763 -- taken literally, and in particular that no prepending of 8764 -- underlines should occur, even in systems where this is the 8765 -- normal default. 8766 8767 else 8768 Start_String; 8769 8770 if VM_Target = No_VM then 8771 Store_String_Char (Get_Char_Code ('*')); 8772 end if; 8773 8774 String_Val := Strval (Expr_Value_S (Link_Nam)); 8775 Store_String_Chars (String_Val); 8776 Link_Nam := 8777 Make_String_Literal (Sloc (Link_Nam), 8778 Strval => End_String); 8779 end if; 8780 8781 -- Set the interface name. If the entity is a generic instance, use 8782 -- its alias, which is the callable entity. 8783 8784 if Is_Generic_Instance (Subprogram_Def) then 8785 Set_Encoded_Interface_Name 8786 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); 8787 else 8788 Set_Encoded_Interface_Name 8789 (Get_Base_Subprogram (Subprogram_Def), Link_Nam); 8790 end if; 8791 8792 -- We allow duplicated export names in CIL/Java, as they are always 8793 -- enclosed in a namespace that differentiates them, and overloaded 8794 -- entities are supported by the VM. 8795 8796 if Convention (Subprogram_Def) /= Convention_CIL 8797 and then 8798 Convention (Subprogram_Def) /= Convention_Java 8799 then 8800 Check_Duplicated_Export_Name (Link_Nam); 8801 end if; 8802 end Process_Interface_Name; 8803 8804 ----------------------------------------- 8805 -- Process_Interrupt_Or_Attach_Handler -- 8806 ----------------------------------------- 8807 8808 procedure Process_Interrupt_Or_Attach_Handler is 8809 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); 8810 Handler_Proc : constant Entity_Id := Entity (Arg1_X); 8811 Proc_Scope : constant Entity_Id := Scope (Handler_Proc); 8812 8813 begin 8814 Set_Is_Interrupt_Handler (Handler_Proc); 8815 8816 -- If the pragma is not associated with a handler procedure within a 8817 -- protected type, then it must be for a nonprotected procedure for 8818 -- the AAMP target, in which case we don't associate a representation 8819 -- item with the procedure's scope. 8820 8821 if Ekind (Proc_Scope) = E_Protected_Type then 8822 if Prag_Id = Pragma_Interrupt_Handler 8823 or else 8824 Prag_Id = Pragma_Attach_Handler 8825 then 8826 Record_Rep_Item (Proc_Scope, N); 8827 end if; 8828 end if; 8829 end Process_Interrupt_Or_Attach_Handler; 8830 8831 -------------------------------------------------- 8832 -- Process_Restrictions_Or_Restriction_Warnings -- 8833 -------------------------------------------------- 8834 8835 -- Note: some of the simple identifier cases were handled in par-prag, 8836 -- but it is harmless (and more straightforward) to simply handle all 8837 -- cases here, even if it means we repeat a bit of work in some cases. 8838 8839 procedure Process_Restrictions_Or_Restriction_Warnings 8840 (Warn : Boolean) 8841 is 8842 Arg : Node_Id; 8843 R_Id : Restriction_Id; 8844 Id : Name_Id; 8845 Expr : Node_Id; 8846 Val : Uint; 8847 8848 begin 8849 -- Ignore all Restrictions pragmas in CodePeer mode 8850 8851 if CodePeer_Mode then 8852 return; 8853 end if; 8854 8855 Check_Ada_83_Warning; 8856 Check_At_Least_N_Arguments (1); 8857 Check_Valid_Configuration_Pragma; 8858 8859 Arg := Arg1; 8860 while Present (Arg) loop 8861 Id := Chars (Arg); 8862 Expr := Get_Pragma_Arg (Arg); 8863 8864 -- Case of no restriction identifier present 8865 8866 if Id = No_Name then 8867 if Nkind (Expr) /= N_Identifier then 8868 Error_Pragma_Arg 8869 ("invalid form for restriction", Arg); 8870 end if; 8871 8872 R_Id := 8873 Get_Restriction_Id 8874 (Process_Restriction_Synonyms (Expr)); 8875 8876 if R_Id not in All_Boolean_Restrictions then 8877 Error_Msg_Name_1 := Pname; 8878 Error_Msg_N 8879 ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); 8880 8881 -- Check for possible misspelling 8882 8883 for J in Restriction_Id loop 8884 declare 8885 Rnm : constant String := Restriction_Id'Image (J); 8886 8887 begin 8888 Name_Buffer (1 .. Rnm'Length) := Rnm; 8889 Name_Len := Rnm'Length; 8890 Set_Casing (All_Lower_Case); 8891 8892 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then 8893 Set_Casing 8894 (Identifier_Casing (Current_Source_File)); 8895 Error_Msg_String (1 .. Rnm'Length) := 8896 Name_Buffer (1 .. Name_Len); 8897 Error_Msg_Strlen := Rnm'Length; 8898 Error_Msg_N -- CODEFIX 8899 ("\possible misspelling of ""~""", 8900 Get_Pragma_Arg (Arg)); 8901 exit; 8902 end if; 8903 end; 8904 end loop; 8905 8906 raise Pragma_Exit; 8907 end if; 8908 8909 if Implementation_Restriction (R_Id) then 8910 Check_Restriction (No_Implementation_Restrictions, Arg); 8911 end if; 8912 8913 -- Special processing for No_Elaboration_Code restriction 8914 8915 if R_Id = No_Elaboration_Code then 8916 8917 -- Restriction is only recognized within a configuration 8918 -- pragma file, or within a unit of the main extended 8919 -- program. Note: the test for Main_Unit is needed to 8920 -- properly include the case of configuration pragma files. 8921 8922 if not (Current_Sem_Unit = Main_Unit 8923 or else In_Extended_Main_Source_Unit (N)) 8924 then 8925 return; 8926 8927 -- Don't allow in a subunit unless already specified in 8928 -- body or spec. 8929 8930 elsif Nkind (Parent (N)) = N_Compilation_Unit 8931 and then Nkind (Unit (Parent (N))) = N_Subunit 8932 and then not Restriction_Active (No_Elaboration_Code) 8933 then 8934 Error_Msg_N 8935 ("invalid specification of ""No_Elaboration_Code""", 8936 N); 8937 Error_Msg_N 8938 ("\restriction cannot be specified in a subunit", N); 8939 Error_Msg_N 8940 ("\unless also specified in body or spec", N); 8941 return; 8942 8943 -- If we have a No_Elaboration_Code pragma that we 8944 -- accept, then it needs to be added to the configuration 8945 -- restrcition set so that we get proper application to 8946 -- other units in the main extended source as required. 8947 8948 else 8949 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 8950 end if; 8951 end if; 8952 8953 -- If this is a warning, then set the warning unless we already 8954 -- have a real restriction active (we never want a warning to 8955 -- override a real restriction). 8956 8957 if Warn then 8958 if not Restriction_Active (R_Id) then 8959 Set_Restriction (R_Id, N); 8960 Restriction_Warnings (R_Id) := True; 8961 end if; 8962 8963 -- If real restriction case, then set it and make sure that the 8964 -- restriction warning flag is off, since a real restriction 8965 -- always overrides a warning. 8966 8967 else 8968 Set_Restriction (R_Id, N); 8969 Restriction_Warnings (R_Id) := False; 8970 end if; 8971 8972 -- Check for obsolescent restrictions in Ada 2005 mode 8973 8974 if not Warn 8975 and then Ada_Version >= Ada_2005 8976 and then (R_Id = No_Asynchronous_Control 8977 or else 8978 R_Id = No_Unchecked_Deallocation 8979 or else 8980 R_Id = No_Unchecked_Conversion) 8981 then 8982 Check_Restriction (No_Obsolescent_Features, N); 8983 end if; 8984 8985 -- A very special case that must be processed here: pragma 8986 -- Restrictions (No_Exceptions) turns off all run-time 8987 -- checking. This is a bit dubious in terms of the formal 8988 -- language definition, but it is what is intended by RM 8989 -- H.4(12). Restriction_Warnings never affects generated code 8990 -- so this is done only in the real restriction case. 8991 8992 -- Atomic_Synchronization is not a real check, so it is not 8993 -- affected by this processing). 8994 8995 if R_Id = No_Exceptions and then not Warn then 8996 for J in Scope_Suppress.Suppress'Range loop 8997 if J /= Atomic_Synchronization then 8998 Scope_Suppress.Suppress (J) := True; 8999 end if; 9000 end loop; 9001 end if; 9002 9003 -- Case of No_Dependence => unit-name. Note that the parser 9004 -- already made the necessary entry in the No_Dependence table. 9005 9006 elsif Id = Name_No_Dependence then 9007 if not OK_No_Dependence_Unit_Name (Expr) then 9008 raise Pragma_Exit; 9009 end if; 9010 9011 -- Case of No_Specification_Of_Aspect => Identifier. 9012 9013 elsif Id = Name_No_Specification_Of_Aspect then 9014 declare 9015 A_Id : Aspect_Id; 9016 9017 begin 9018 if Nkind (Expr) /= N_Identifier then 9019 A_Id := No_Aspect; 9020 else 9021 A_Id := Get_Aspect_Id (Chars (Expr)); 9022 end if; 9023 9024 if A_Id = No_Aspect then 9025 Error_Pragma_Arg ("invalid restriction name", Arg); 9026 else 9027 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); 9028 end if; 9029 end; 9030 9031 elsif Id = Name_No_Use_Of_Attribute then 9032 if Nkind (Expr) /= N_Identifier 9033 or else not Is_Attribute_Name (Chars (Expr)) 9034 then 9035 Error_Msg_N ("unknown attribute name?", Expr); 9036 9037 else 9038 Set_Restriction_No_Use_Of_Attribute (Expr, Warn); 9039 end if; 9040 9041 elsif Id = Name_No_Use_Of_Pragma then 9042 if Nkind (Expr) /= N_Identifier 9043 or else not Is_Pragma_Name (Chars (Expr)) 9044 then 9045 Error_Msg_N ("unknown pragma name?", Expr); 9046 9047 else 9048 Set_Restriction_No_Use_Of_Pragma (Expr, Warn); 9049 end if; 9050 9051 -- All other cases of restriction identifier present 9052 9053 else 9054 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); 9055 Analyze_And_Resolve (Expr, Any_Integer); 9056 9057 if R_Id not in All_Parameter_Restrictions then 9058 Error_Pragma_Arg 9059 ("invalid restriction parameter identifier", Arg); 9060 9061 elsif not Is_OK_Static_Expression (Expr) then 9062 Flag_Non_Static_Expr 9063 ("value must be static expression!", Expr); 9064 raise Pragma_Exit; 9065 9066 elsif not Is_Integer_Type (Etype (Expr)) 9067 or else Expr_Value (Expr) < 0 9068 then 9069 Error_Pragma_Arg 9070 ("value must be non-negative integer", Arg); 9071 end if; 9072 9073 -- Restriction pragma is active 9074 9075 Val := Expr_Value (Expr); 9076 9077 if not UI_Is_In_Int_Range (Val) then 9078 Error_Pragma_Arg 9079 ("pragma ignored, value too large??", Arg); 9080 end if; 9081 9082 -- Warning case. If the real restriction is active, then we 9083 -- ignore the request, since warning never overrides a real 9084 -- restriction. Otherwise we set the proper warning. Note that 9085 -- this circuit sets the warning again if it is already set, 9086 -- which is what we want, since the constant may have changed. 9087 9088 if Warn then 9089 if not Restriction_Active (R_Id) then 9090 Set_Restriction 9091 (R_Id, N, Integer (UI_To_Int (Val))); 9092 Restriction_Warnings (R_Id) := True; 9093 end if; 9094 9095 -- Real restriction case, set restriction and make sure warning 9096 -- flag is off since real restriction always overrides warning. 9097 9098 else 9099 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); 9100 Restriction_Warnings (R_Id) := False; 9101 end if; 9102 end if; 9103 9104 Next (Arg); 9105 end loop; 9106 end Process_Restrictions_Or_Restriction_Warnings; 9107 9108 --------------------------------- 9109 -- Process_Suppress_Unsuppress -- 9110 --------------------------------- 9111 9112 -- Note: this procedure makes entries in the check suppress data 9113 -- structures managed by Sem. See spec of package Sem for full 9114 -- details on how we handle recording of check suppression. 9115 9116 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is 9117 C : Check_Id; 9118 E_Id : Node_Id; 9119 E : Entity_Id; 9120 9121 In_Package_Spec : constant Boolean := 9122 Is_Package_Or_Generic_Package (Current_Scope) 9123 and then not In_Package_Body (Current_Scope); 9124 9125 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); 9126 -- Used to suppress a single check on the given entity 9127 9128 -------------------------------- 9129 -- Suppress_Unsuppress_Echeck -- 9130 -------------------------------- 9131 9132 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is 9133 begin 9134 -- Check for error of trying to set atomic synchronization for 9135 -- a non-atomic variable. 9136 9137 if C = Atomic_Synchronization 9138 and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) 9139 then 9140 Error_Msg_N 9141 ("pragma & requires atomic type or variable", 9142 Pragma_Identifier (Original_Node (N))); 9143 end if; 9144 9145 Set_Checks_May_Be_Suppressed (E); 9146 9147 if In_Package_Spec then 9148 Push_Global_Suppress_Stack_Entry 9149 (Entity => E, 9150 Check => C, 9151 Suppress => Suppress_Case); 9152 else 9153 Push_Local_Suppress_Stack_Entry 9154 (Entity => E, 9155 Check => C, 9156 Suppress => Suppress_Case); 9157 end if; 9158 9159 -- If this is a first subtype, and the base type is distinct, 9160 -- then also set the suppress flags on the base type. 9161 9162 if Is_First_Subtype (E) and then Etype (E) /= E then 9163 Suppress_Unsuppress_Echeck (Etype (E), C); 9164 end if; 9165 end Suppress_Unsuppress_Echeck; 9166 9167 -- Start of processing for Process_Suppress_Unsuppress 9168 9169 begin 9170 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes 9171 -- on user code: we want to generate checks for analysis purposes, as 9172 -- set respectively by -gnatC and -gnatd.F 9173 9174 if (CodePeer_Mode or GNATprove_Mode) 9175 and then Comes_From_Source (N) 9176 then 9177 return; 9178 end if; 9179 9180 -- Suppress/Unsuppress can appear as a configuration pragma, or in a 9181 -- declarative part or a package spec (RM 11.5(5)). 9182 9183 if not Is_Configuration_Pragma then 9184 Check_Is_In_Decl_Part_Or_Package_Spec; 9185 end if; 9186 9187 Check_At_Least_N_Arguments (1); 9188 Check_At_Most_N_Arguments (2); 9189 Check_No_Identifier (Arg1); 9190 Check_Arg_Is_Identifier (Arg1); 9191 9192 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); 9193 9194 if C = No_Check_Id then 9195 Error_Pragma_Arg 9196 ("argument of pragma% is not valid check name", Arg1); 9197 end if; 9198 9199 if Arg_Count = 1 then 9200 9201 -- Make an entry in the local scope suppress table. This is the 9202 -- table that directly shows the current value of the scope 9203 -- suppress check for any check id value. 9204 9205 if C = All_Checks then 9206 9207 -- For All_Checks, we set all specific predefined checks with 9208 -- the exception of Elaboration_Check, which is handled 9209 -- specially because of not wanting All_Checks to have the 9210 -- effect of deactivating static elaboration order processing. 9211 -- Atomic_Synchronization is also not affected, since this is 9212 -- not a real check. 9213 9214 for J in Scope_Suppress.Suppress'Range loop 9215 if J /= Elaboration_Check 9216 and then 9217 J /= Atomic_Synchronization 9218 then 9219 Scope_Suppress.Suppress (J) := Suppress_Case; 9220 end if; 9221 end loop; 9222 9223 -- If not All_Checks, and predefined check, then set appropriate 9224 -- scope entry. Note that we will set Elaboration_Check if this 9225 -- is explicitly specified. Atomic_Synchronization is allowed 9226 -- only if internally generated and entity is atomic. 9227 9228 elsif C in Predefined_Check_Id 9229 and then (not Comes_From_Source (N) 9230 or else C /= Atomic_Synchronization) 9231 then 9232 Scope_Suppress.Suppress (C) := Suppress_Case; 9233 end if; 9234 9235 -- Also make an entry in the Local_Entity_Suppress table 9236 9237 Push_Local_Suppress_Stack_Entry 9238 (Entity => Empty, 9239 Check => C, 9240 Suppress => Suppress_Case); 9241 9242 -- Case of two arguments present, where the check is suppressed for 9243 -- a specified entity (given as the second argument of the pragma) 9244 9245 else 9246 -- This is obsolescent in Ada 2005 mode 9247 9248 if Ada_Version >= Ada_2005 then 9249 Check_Restriction (No_Obsolescent_Features, Arg2); 9250 end if; 9251 9252 Check_Optional_Identifier (Arg2, Name_On); 9253 E_Id := Get_Pragma_Arg (Arg2); 9254 Analyze (E_Id); 9255 9256 if not Is_Entity_Name (E_Id) then 9257 Error_Pragma_Arg 9258 ("second argument of pragma% must be entity name", Arg2); 9259 end if; 9260 9261 E := Entity (E_Id); 9262 9263 if E = Any_Id then 9264 return; 9265 end if; 9266 9267 -- Enforce RM 11.5(7) which requires that for a pragma that 9268 -- appears within a package spec, the named entity must be 9269 -- within the package spec. We allow the package name itself 9270 -- to be mentioned since that makes sense, although it is not 9271 -- strictly allowed by 11.5(7). 9272 9273 if In_Package_Spec 9274 and then E /= Current_Scope 9275 and then Scope (E) /= Current_Scope 9276 then 9277 Error_Pragma_Arg 9278 ("entity in pragma% is not in package spec (RM 11.5(7))", 9279 Arg2); 9280 end if; 9281 9282 -- Loop through homonyms. As noted below, in the case of a package 9283 -- spec, only homonyms within the package spec are considered. 9284 9285 loop 9286 Suppress_Unsuppress_Echeck (E, C); 9287 9288 if Is_Generic_Instance (E) 9289 and then Is_Subprogram (E) 9290 and then Present (Alias (E)) 9291 then 9292 Suppress_Unsuppress_Echeck (Alias (E), C); 9293 end if; 9294 9295 -- Move to next homonym if not aspect spec case 9296 9297 exit when From_Aspect_Specification (N); 9298 E := Homonym (E); 9299 exit when No (E); 9300 9301 -- If we are within a package specification, the pragma only 9302 -- applies to homonyms in the same scope. 9303 9304 exit when In_Package_Spec 9305 and then Scope (E) /= Current_Scope; 9306 end loop; 9307 end if; 9308 end Process_Suppress_Unsuppress; 9309 9310 ------------------ 9311 -- Set_Exported -- 9312 ------------------ 9313 9314 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is 9315 begin 9316 if Is_Imported (E) then 9317 Error_Pragma_Arg 9318 ("cannot export entity& that was previously imported", Arg); 9319 9320 elsif Present (Address_Clause (E)) 9321 and then not Relaxed_RM_Semantics 9322 then 9323 Error_Pragma_Arg 9324 ("cannot export entity& that has an address clause", Arg); 9325 end if; 9326 9327 Set_Is_Exported (E); 9328 9329 -- Generate a reference for entity explicitly, because the 9330 -- identifier may be overloaded and name resolution will not 9331 -- generate one. 9332 9333 Generate_Reference (E, Arg); 9334 9335 -- Deal with exporting non-library level entity 9336 9337 if not Is_Library_Level_Entity (E) then 9338 9339 -- Not allowed at all for subprograms 9340 9341 if Is_Subprogram (E) then 9342 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); 9343 9344 -- Otherwise set public and statically allocated 9345 9346 else 9347 Set_Is_Public (E); 9348 Set_Is_Statically_Allocated (E); 9349 9350 -- Warn if the corresponding W flag is set and the pragma comes 9351 -- from source. The latter may not be true e.g. on VMS where we 9352 -- expand export pragmas for exception codes associated with 9353 -- imported or exported exceptions. We do not want to generate 9354 -- a warning for something that the user did not write. 9355 9356 if Warn_On_Export_Import 9357 and then Comes_From_Source (Arg) 9358 then 9359 Error_Msg_NE 9360 ("?x?& has been made static as a result of Export", 9361 Arg, E); 9362 Error_Msg_N 9363 ("\?x?this usage is non-standard and non-portable", 9364 Arg); 9365 end if; 9366 end if; 9367 end if; 9368 9369 if Warn_On_Export_Import and then Is_Type (E) then 9370 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); 9371 end if; 9372 9373 if Warn_On_Export_Import and Inside_A_Generic then 9374 Error_Msg_NE 9375 ("all instances of& will have the same external name?x?", 9376 Arg, E); 9377 end if; 9378 end Set_Exported; 9379 9380 ---------------------------------------------- 9381 -- Set_Extended_Import_Export_External_Name -- 9382 ---------------------------------------------- 9383 9384 procedure Set_Extended_Import_Export_External_Name 9385 (Internal_Ent : Entity_Id; 9386 Arg_External : Node_Id) 9387 is 9388 Old_Name : constant Node_Id := Interface_Name (Internal_Ent); 9389 New_Name : Node_Id; 9390 9391 begin 9392 if No (Arg_External) then 9393 return; 9394 end if; 9395 9396 Check_Arg_Is_External_Name (Arg_External); 9397 9398 if Nkind (Arg_External) = N_String_Literal then 9399 if String_Length (Strval (Arg_External)) = 0 then 9400 return; 9401 else 9402 New_Name := Adjust_External_Name_Case (Arg_External); 9403 end if; 9404 9405 elsif Nkind (Arg_External) = N_Identifier then 9406 New_Name := Get_Default_External_Name (Arg_External); 9407 9408 -- Check_Arg_Is_External_Name should let through only identifiers and 9409 -- string literals or static string expressions (which are folded to 9410 -- string literals). 9411 9412 else 9413 raise Program_Error; 9414 end if; 9415 9416 -- If we already have an external name set (by a prior normal Import 9417 -- or Export pragma), then the external names must match 9418 9419 if Present (Interface_Name (Internal_Ent)) then 9420 9421 -- Ignore mismatching names in CodePeer mode, to support some 9422 -- old compilers which would export the same procedure under 9423 -- different names, e.g: 9424 -- procedure P; 9425 -- pragma Export_Procedure (P, "a"); 9426 -- pragma Export_Procedure (P, "b"); 9427 9428 if CodePeer_Mode then 9429 return; 9430 end if; 9431 9432 Check_Matching_Internal_Names : declare 9433 S1 : constant String_Id := Strval (Old_Name); 9434 S2 : constant String_Id := Strval (New_Name); 9435 9436 procedure Mismatch; 9437 pragma No_Return (Mismatch); 9438 -- Called if names do not match 9439 9440 -------------- 9441 -- Mismatch -- 9442 -------------- 9443 9444 procedure Mismatch is 9445 begin 9446 Error_Msg_Sloc := Sloc (Old_Name); 9447 Error_Pragma_Arg 9448 ("external name does not match that given #", 9449 Arg_External); 9450 end Mismatch; 9451 9452 -- Start of processing for Check_Matching_Internal_Names 9453 9454 begin 9455 if String_Length (S1) /= String_Length (S2) then 9456 Mismatch; 9457 9458 else 9459 for J in 1 .. String_Length (S1) loop 9460 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then 9461 Mismatch; 9462 end if; 9463 end loop; 9464 end if; 9465 end Check_Matching_Internal_Names; 9466 9467 -- Otherwise set the given name 9468 9469 else 9470 Set_Encoded_Interface_Name (Internal_Ent, New_Name); 9471 Check_Duplicated_Export_Name (New_Name); 9472 end if; 9473 end Set_Extended_Import_Export_External_Name; 9474 9475 ------------------ 9476 -- Set_Imported -- 9477 ------------------ 9478 9479 procedure Set_Imported (E : Entity_Id) is 9480 begin 9481 -- Error message if already imported or exported 9482 9483 if Is_Exported (E) or else Is_Imported (E) then 9484 9485 -- Error if being set Exported twice 9486 9487 if Is_Exported (E) then 9488 Error_Msg_NE ("entity& was previously exported", N, E); 9489 9490 -- Ignore error in CodePeer mode where we treat all imported 9491 -- subprograms as unknown. 9492 9493 elsif CodePeer_Mode then 9494 goto OK; 9495 9496 -- OK if Import/Interface case 9497 9498 elsif Import_Interface_Present (N) then 9499 goto OK; 9500 9501 -- Error if being set Imported twice 9502 9503 else 9504 Error_Msg_NE ("entity& was previously imported", N, E); 9505 end if; 9506 9507 Error_Msg_Name_1 := Pname; 9508 Error_Msg_N 9509 ("\(pragma% applies to all previous entities)", N); 9510 9511 Error_Msg_Sloc := Sloc (E); 9512 Error_Msg_NE ("\import not allowed for& declared#", N, E); 9513 9514 -- Here if not previously imported or exported, OK to import 9515 9516 else 9517 Set_Is_Imported (E); 9518 9519 -- For subprogram, set Import_Pragma field 9520 9521 if Is_Subprogram (E) then 9522 Set_Import_Pragma (E, N); 9523 end if; 9524 9525 -- If the entity is an object that is not at the library level, 9526 -- then it is statically allocated. We do not worry about objects 9527 -- with address clauses in this context since they are not really 9528 -- imported in the linker sense. 9529 9530 if Is_Object (E) 9531 and then not Is_Library_Level_Entity (E) 9532 and then No (Address_Clause (E)) 9533 then 9534 Set_Is_Statically_Allocated (E); 9535 end if; 9536 end if; 9537 9538 <<OK>> null; 9539 end Set_Imported; 9540 9541 ------------------------- 9542 -- Set_Mechanism_Value -- 9543 ------------------------- 9544 9545 -- Note: the mechanism name has not been analyzed (and cannot indeed be 9546 -- analyzed, since it is semantic nonsense), so we get it in the exact 9547 -- form created by the parser. 9548 9549 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is 9550 Class : Node_Id; 9551 Param : Node_Id; 9552 Mech_Name_Id : Name_Id; 9553 9554 procedure Bad_Class; 9555 pragma No_Return (Bad_Class); 9556 -- Signal bad descriptor class name 9557 9558 procedure Bad_Mechanism; 9559 pragma No_Return (Bad_Mechanism); 9560 -- Signal bad mechanism name 9561 9562 --------------- 9563 -- Bad_Class -- 9564 --------------- 9565 9566 procedure Bad_Class is 9567 begin 9568 Error_Pragma_Arg ("unrecognized descriptor class name", Class); 9569 end Bad_Class; 9570 9571 ------------------------- 9572 -- Bad_Mechanism_Value -- 9573 ------------------------- 9574 9575 procedure Bad_Mechanism is 9576 begin 9577 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); 9578 end Bad_Mechanism; 9579 9580 -- Start of processing for Set_Mechanism_Value 9581 9582 begin 9583 if Mechanism (Ent) /= Default_Mechanism then 9584 Error_Msg_NE 9585 ("mechanism for & has already been set", Mech_Name, Ent); 9586 end if; 9587 9588 -- MECHANISM_NAME ::= value | reference | descriptor | 9589 -- short_descriptor 9590 9591 if Nkind (Mech_Name) = N_Identifier then 9592 if Chars (Mech_Name) = Name_Value then 9593 Set_Mechanism (Ent, By_Copy); 9594 return; 9595 9596 elsif Chars (Mech_Name) = Name_Reference then 9597 Set_Mechanism (Ent, By_Reference); 9598 return; 9599 9600 elsif Chars (Mech_Name) = Name_Descriptor then 9601 Check_VMS (Mech_Name); 9602 9603 -- Descriptor => Short_Descriptor if pragma was given 9604 9605 if Short_Descriptors then 9606 Set_Mechanism (Ent, By_Short_Descriptor); 9607 else 9608 Set_Mechanism (Ent, By_Descriptor); 9609 end if; 9610 9611 return; 9612 9613 elsif Chars (Mech_Name) = Name_Short_Descriptor then 9614 Check_VMS (Mech_Name); 9615 Set_Mechanism (Ent, By_Short_Descriptor); 9616 return; 9617 9618 elsif Chars (Mech_Name) = Name_Copy then 9619 Error_Pragma_Arg 9620 ("bad mechanism name, Value assumed", Mech_Name); 9621 9622 else 9623 Bad_Mechanism; 9624 end if; 9625 9626 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | 9627 -- short_descriptor (CLASS_NAME) 9628 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 9629 9630 -- Note: this form is parsed as an indexed component 9631 9632 elsif Nkind (Mech_Name) = N_Indexed_Component then 9633 Class := First (Expressions (Mech_Name)); 9634 9635 if Nkind (Prefix (Mech_Name)) /= N_Identifier 9636 or else 9637 not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, 9638 Name_Short_Descriptor) 9639 or else Present (Next (Class)) 9640 then 9641 Bad_Mechanism; 9642 else 9643 Mech_Name_Id := Chars (Prefix (Mech_Name)); 9644 9645 -- Change Descriptor => Short_Descriptor if pragma was given 9646 9647 if Mech_Name_Id = Name_Descriptor 9648 and then Short_Descriptors 9649 then 9650 Mech_Name_Id := Name_Short_Descriptor; 9651 end if; 9652 end if; 9653 9654 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | 9655 -- short_descriptor (Class => CLASS_NAME) 9656 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 9657 9658 -- Note: this form is parsed as a function call 9659 9660 elsif Nkind (Mech_Name) = N_Function_Call then 9661 Param := First (Parameter_Associations (Mech_Name)); 9662 9663 if Nkind (Name (Mech_Name)) /= N_Identifier 9664 or else 9665 not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, 9666 Name_Short_Descriptor) 9667 or else Present (Next (Param)) 9668 or else No (Selector_Name (Param)) 9669 or else Chars (Selector_Name (Param)) /= Name_Class 9670 then 9671 Bad_Mechanism; 9672 else 9673 Class := Explicit_Actual_Parameter (Param); 9674 Mech_Name_Id := Chars (Name (Mech_Name)); 9675 end if; 9676 9677 else 9678 Bad_Mechanism; 9679 end if; 9680 9681 -- Fall through here with Class set to descriptor class name 9682 9683 Check_VMS (Mech_Name); 9684 9685 if Nkind (Class) /= N_Identifier then 9686 Bad_Class; 9687 9688 elsif Mech_Name_Id = Name_Descriptor 9689 and then Chars (Class) = Name_UBS 9690 then 9691 Set_Mechanism (Ent, By_Descriptor_UBS); 9692 9693 elsif Mech_Name_Id = Name_Descriptor 9694 and then Chars (Class) = Name_UBSB 9695 then 9696 Set_Mechanism (Ent, By_Descriptor_UBSB); 9697 9698 elsif Mech_Name_Id = Name_Descriptor 9699 and then Chars (Class) = Name_UBA 9700 then 9701 Set_Mechanism (Ent, By_Descriptor_UBA); 9702 9703 elsif Mech_Name_Id = Name_Descriptor 9704 and then Chars (Class) = Name_S 9705 then 9706 Set_Mechanism (Ent, By_Descriptor_S); 9707 9708 elsif Mech_Name_Id = Name_Descriptor 9709 and then Chars (Class) = Name_SB 9710 then 9711 Set_Mechanism (Ent, By_Descriptor_SB); 9712 9713 elsif Mech_Name_Id = Name_Descriptor 9714 and then Chars (Class) = Name_A 9715 then 9716 Set_Mechanism (Ent, By_Descriptor_A); 9717 9718 elsif Mech_Name_Id = Name_Descriptor 9719 and then Chars (Class) = Name_NCA 9720 then 9721 Set_Mechanism (Ent, By_Descriptor_NCA); 9722 9723 elsif Mech_Name_Id = Name_Short_Descriptor 9724 and then Chars (Class) = Name_UBS 9725 then 9726 Set_Mechanism (Ent, By_Short_Descriptor_UBS); 9727 9728 elsif Mech_Name_Id = Name_Short_Descriptor 9729 and then Chars (Class) = Name_UBSB 9730 then 9731 Set_Mechanism (Ent, By_Short_Descriptor_UBSB); 9732 9733 elsif Mech_Name_Id = Name_Short_Descriptor 9734 and then Chars (Class) = Name_UBA 9735 then 9736 Set_Mechanism (Ent, By_Short_Descriptor_UBA); 9737 9738 elsif Mech_Name_Id = Name_Short_Descriptor 9739 and then Chars (Class) = Name_S 9740 then 9741 Set_Mechanism (Ent, By_Short_Descriptor_S); 9742 9743 elsif Mech_Name_Id = Name_Short_Descriptor 9744 and then Chars (Class) = Name_SB 9745 then 9746 Set_Mechanism (Ent, By_Short_Descriptor_SB); 9747 9748 elsif Mech_Name_Id = Name_Short_Descriptor 9749 and then Chars (Class) = Name_A 9750 then 9751 Set_Mechanism (Ent, By_Short_Descriptor_A); 9752 9753 elsif Mech_Name_Id = Name_Short_Descriptor 9754 and then Chars (Class) = Name_NCA 9755 then 9756 Set_Mechanism (Ent, By_Short_Descriptor_NCA); 9757 9758 else 9759 Bad_Class; 9760 end if; 9761 end Set_Mechanism_Value; 9762 9763 -------------------------- 9764 -- Set_Rational_Profile -- 9765 -------------------------- 9766 9767 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and 9768 -- and extension to the semantics of renaming declarations. 9769 9770 procedure Set_Rational_Profile is 9771 begin 9772 Implicit_Packing := True; 9773 Overriding_Renamings := True; 9774 Use_VADS_Size := True; 9775 end Set_Rational_Profile; 9776 9777 --------------------------- 9778 -- Set_Ravenscar_Profile -- 9779 --------------------------- 9780 9781 -- The tasks to be done here are 9782 9783 -- Set required policies 9784 9785 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 9786 -- pragma Locking_Policy (Ceiling_Locking) 9787 9788 -- Set Detect_Blocking mode 9789 9790 -- Set required restrictions (see System.Rident for detailed list) 9791 9792 -- Set the No_Dependence rules 9793 -- No_Dependence => Ada.Asynchronous_Task_Control 9794 -- No_Dependence => Ada.Calendar 9795 -- No_Dependence => Ada.Execution_Time.Group_Budget 9796 -- No_Dependence => Ada.Execution_Time.Timers 9797 -- No_Dependence => Ada.Task_Attributes 9798 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 9799 9800 procedure Set_Ravenscar_Profile (N : Node_Id) is 9801 Prefix_Entity : Entity_Id; 9802 Selector_Entity : Entity_Id; 9803 Prefix_Node : Node_Id; 9804 Node : Node_Id; 9805 9806 begin 9807 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 9808 9809 if Task_Dispatching_Policy /= ' ' 9810 and then Task_Dispatching_Policy /= 'F' 9811 then 9812 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 9813 Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); 9814 9815 -- Set the FIFO_Within_Priorities policy, but always preserve 9816 -- System_Location since we like the error message with the run time 9817 -- name. 9818 9819 else 9820 Task_Dispatching_Policy := 'F'; 9821 9822 if Task_Dispatching_Policy_Sloc /= System_Location then 9823 Task_Dispatching_Policy_Sloc := Loc; 9824 end if; 9825 end if; 9826 9827 -- pragma Locking_Policy (Ceiling_Locking) 9828 9829 if Locking_Policy /= ' ' 9830 and then Locking_Policy /= 'C' 9831 then 9832 Error_Msg_Sloc := Locking_Policy_Sloc; 9833 Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); 9834 9835 -- Set the Ceiling_Locking policy, but preserve System_Location since 9836 -- we like the error message with the run time name. 9837 9838 else 9839 Locking_Policy := 'C'; 9840 9841 if Locking_Policy_Sloc /= System_Location then 9842 Locking_Policy_Sloc := Loc; 9843 end if; 9844 end if; 9845 9846 -- pragma Detect_Blocking 9847 9848 Detect_Blocking := True; 9849 9850 -- Set the corresponding restrictions 9851 9852 Set_Profile_Restrictions 9853 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); 9854 9855 -- Set the No_Dependence restrictions 9856 9857 -- The following No_Dependence restrictions: 9858 -- No_Dependence => Ada.Asynchronous_Task_Control 9859 -- No_Dependence => Ada.Calendar 9860 -- No_Dependence => Ada.Task_Attributes 9861 -- are already set by previous call to Set_Profile_Restrictions. 9862 9863 -- Set the following restrictions which were added to Ada 2005: 9864 -- No_Dependence => Ada.Execution_Time.Group_Budget 9865 -- No_Dependence => Ada.Execution_Time.Timers 9866 9867 if Ada_Version >= Ada_2005 then 9868 Name_Buffer (1 .. 3) := "ada"; 9869 Name_Len := 3; 9870 9871 Prefix_Entity := Make_Identifier (Loc, Name_Find); 9872 9873 Name_Buffer (1 .. 14) := "execution_time"; 9874 Name_Len := 14; 9875 9876 Selector_Entity := Make_Identifier (Loc, Name_Find); 9877 9878 Prefix_Node := 9879 Make_Selected_Component 9880 (Sloc => Loc, 9881 Prefix => Prefix_Entity, 9882 Selector_Name => Selector_Entity); 9883 9884 Name_Buffer (1 .. 13) := "group_budgets"; 9885 Name_Len := 13; 9886 9887 Selector_Entity := Make_Identifier (Loc, Name_Find); 9888 9889 Node := 9890 Make_Selected_Component 9891 (Sloc => Loc, 9892 Prefix => Prefix_Node, 9893 Selector_Name => Selector_Entity); 9894 9895 Set_Restriction_No_Dependence 9896 (Unit => Node, 9897 Warn => Treat_Restrictions_As_Warnings, 9898 Profile => Ravenscar); 9899 9900 Name_Buffer (1 .. 6) := "timers"; 9901 Name_Len := 6; 9902 9903 Selector_Entity := Make_Identifier (Loc, Name_Find); 9904 9905 Node := 9906 Make_Selected_Component 9907 (Sloc => Loc, 9908 Prefix => Prefix_Node, 9909 Selector_Name => Selector_Entity); 9910 9911 Set_Restriction_No_Dependence 9912 (Unit => Node, 9913 Warn => Treat_Restrictions_As_Warnings, 9914 Profile => Ravenscar); 9915 end if; 9916 9917 -- Set the following restrictions which was added to Ada 2012 (see 9918 -- AI-0171): 9919 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 9920 9921 if Ada_Version >= Ada_2012 then 9922 Name_Buffer (1 .. 6) := "system"; 9923 Name_Len := 6; 9924 9925 Prefix_Entity := Make_Identifier (Loc, Name_Find); 9926 9927 Name_Buffer (1 .. 15) := "multiprocessors"; 9928 Name_Len := 15; 9929 9930 Selector_Entity := Make_Identifier (Loc, Name_Find); 9931 9932 Prefix_Node := 9933 Make_Selected_Component 9934 (Sloc => Loc, 9935 Prefix => Prefix_Entity, 9936 Selector_Name => Selector_Entity); 9937 9938 Name_Buffer (1 .. 19) := "dispatching_domains"; 9939 Name_Len := 19; 9940 9941 Selector_Entity := Make_Identifier (Loc, Name_Find); 9942 9943 Node := 9944 Make_Selected_Component 9945 (Sloc => Loc, 9946 Prefix => Prefix_Node, 9947 Selector_Name => Selector_Entity); 9948 9949 Set_Restriction_No_Dependence 9950 (Unit => Node, 9951 Warn => Treat_Restrictions_As_Warnings, 9952 Profile => Ravenscar); 9953 end if; 9954 end Set_Ravenscar_Profile; 9955 9956 -- Start of processing for Analyze_Pragma 9957 9958 begin 9959 -- The following code is a defense against recursion. Not clear that 9960 -- this can happen legitimately, but perhaps some error situations 9961 -- can cause it, and we did see this recursion during testing. 9962 9963 if Analyzed (N) then 9964 return; 9965 else 9966 Set_Analyzed (N, True); 9967 end if; 9968 9969 -- Deal with unrecognized pragma 9970 9971 Pname := Pragma_Name (N); 9972 9973 if not Is_Pragma_Name (Pname) then 9974 if Warn_On_Unrecognized_Pragma then 9975 Error_Msg_Name_1 := Pname; 9976 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N)); 9977 9978 for PN in First_Pragma_Name .. Last_Pragma_Name loop 9979 if Is_Bad_Spelling_Of (Pname, PN) then 9980 Error_Msg_Name_1 := PN; 9981 Error_Msg_N -- CODEFIX 9982 ("\?g?possible misspelling of %!", Pragma_Identifier (N)); 9983 exit; 9984 end if; 9985 end loop; 9986 end if; 9987 9988 return; 9989 end if; 9990 9991 -- Here to start processing for recognized pragma 9992 9993 Prag_Id := Get_Pragma_Id (Pname); 9994 Pname := Original_Aspect_Name (N); 9995 9996 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored 9997 -- is already set, indicating that we have already checked the policy 9998 -- at the right point. This happens for example in the case of a pragma 9999 -- that is derived from an Aspect. 10000 10001 if Is_Ignored (N) or else Is_Checked (N) then 10002 null; 10003 10004 -- For a pragma that is a rewriting of another pragma, copy the 10005 -- Is_Checked/Is_Ignored status from the rewritten pragma. 10006 10007 elsif Is_Rewrite_Substitution (N) 10008 and then Nkind (Original_Node (N)) = N_Pragma 10009 and then Original_Node (N) /= N 10010 then 10011 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 10012 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 10013 10014 -- Otherwise query the applicable policy at this point 10015 10016 else 10017 Check_Applicable_Policy (N); 10018 10019 -- If pragma is disabled, rewrite as NULL and skip analysis 10020 10021 if Is_Disabled (N) then 10022 Rewrite (N, Make_Null_Statement (Loc)); 10023 Analyze (N); 10024 raise Pragma_Exit; 10025 end if; 10026 end if; 10027 10028 -- Preset arguments 10029 10030 Arg_Count := 0; 10031 Arg1 := Empty; 10032 Arg2 := Empty; 10033 Arg3 := Empty; 10034 Arg4 := Empty; 10035 10036 if Present (Pragma_Argument_Associations (N)) then 10037 Arg_Count := List_Length (Pragma_Argument_Associations (N)); 10038 Arg1 := First (Pragma_Argument_Associations (N)); 10039 10040 if Present (Arg1) then 10041 Arg2 := Next (Arg1); 10042 10043 if Present (Arg2) then 10044 Arg3 := Next (Arg2); 10045 10046 if Present (Arg3) then 10047 Arg4 := Next (Arg3); 10048 end if; 10049 end if; 10050 end if; 10051 end if; 10052 10053 Check_Restriction_No_Use_Of_Pragma (N); 10054 10055 -- An enumeration type defines the pragmas that are supported by the 10056 -- implementation. Get_Pragma_Id (in package Prag) transforms a name 10057 -- into the corresponding enumeration value for the following case. 10058 10059 case Prag_Id is 10060 10061 ----------------- 10062 -- Abort_Defer -- 10063 ----------------- 10064 10065 -- pragma Abort_Defer; 10066 10067 when Pragma_Abort_Defer => 10068 GNAT_Pragma; 10069 Check_Arg_Count (0); 10070 10071 -- The only required semantic processing is to check the 10072 -- placement. This pragma must appear at the start of the 10073 -- statement sequence of a handled sequence of statements. 10074 10075 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 10076 or else N /= First (Statements (Parent (N))) 10077 then 10078 Pragma_Misplaced; 10079 end if; 10080 10081 -------------------- 10082 -- Abstract_State -- 10083 -------------------- 10084 10085 -- pragma Abstract_State (ABSTRACT_STATE_LIST); 10086 10087 -- ABSTRACT_STATE_LIST ::= 10088 -- null 10089 -- | STATE_NAME_WITH_OPTIONS 10090 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS} ) 10091 10092 -- STATE_NAME_WITH_OPTIONS ::= 10093 -- STATE_NAME 10094 -- | (STATE_NAME with OPTION_LIST) 10095 10096 -- OPTION_LIST ::= OPTION {, OPTION} 10097 10098 -- OPTION ::= 10099 -- SIMPLE_OPTION 10100 -- | NAME_VALUE_OPTION 10101 10102 -- SIMPLE_OPTION ::= identifier 10103 10104 -- NAME_VALUE_OPTION ::= 10105 -- Part_Of => ABSTRACT_STATE 10106 -- | External [=> EXTERNAL_PROPERTY_LIST] 10107 10108 -- EXTERNAL_PROPERTY_LIST ::= 10109 -- EXTERNAL_PROPERTY 10110 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY} ) 10111 10112 -- EXTERNAL_PROPERTY ::= 10113 -- Async_Readers [=> boolean_EXPRESSION] 10114 -- | Async_Writers [=> boolean_EXPRESSION] 10115 -- | Effective_Reads [=> boolean_EXPRESSION] 10116 -- | Effective_Writes [=> boolean_EXPRESSION] 10117 -- others => boolean_EXPRESSION 10118 10119 -- STATE_NAME ::= defining_identifier 10120 10121 -- ABSTRACT_STATE ::= name 10122 10123 when Pragma_Abstract_State => Abstract_State : declare 10124 10125 -- Flags used to verify the consistency of states 10126 10127 Non_Null_Seen : Boolean := False; 10128 Null_Seen : Boolean := False; 10129 10130 Pack_Id : Entity_Id; 10131 -- Entity of related package when pragma Abstract_State appears 10132 10133 procedure Analyze_Abstract_State (State : Node_Id); 10134 -- Verify the legality of a single state declaration. Create and 10135 -- decorate a state abstraction entity and introduce it into the 10136 -- visibility chain. 10137 10138 procedure Check_State_Declaration_Syntax (State : Node_Id); 10139 -- Verify the syntex of state declaration State 10140 10141 ---------------------------- 10142 -- Analyze_Abstract_State -- 10143 ---------------------------- 10144 10145 procedure Analyze_Abstract_State (State : Node_Id) is 10146 10147 -- Flags used to verify the consistency of options 10148 10149 AR_Seen : Boolean := False; 10150 AW_Seen : Boolean := False; 10151 ER_Seen : Boolean := False; 10152 EW_Seen : Boolean := False; 10153 External_Seen : Boolean := False; 10154 Others_Seen : Boolean := False; 10155 Part_Of_Seen : Boolean := False; 10156 10157 -- Flags used to store the static value of all external states' 10158 -- expressions. 10159 10160 AR_Val : Boolean := False; 10161 AW_Val : Boolean := False; 10162 ER_Val : Boolean := False; 10163 EW_Val : Boolean := False; 10164 10165 State_Id : Entity_Id := Empty; 10166 -- The entity to be generated for the current state declaration 10167 10168 procedure Analyze_External_Option (Opt : Node_Id); 10169 -- Verify the legality of option External 10170 10171 procedure Analyze_External_Property 10172 (Prop : Node_Id; 10173 Expr : Node_Id := Empty); 10174 -- Verify the legailty of a single external property. Prop 10175 -- denotes the external property. Expr is the expression used 10176 -- to set the property. 10177 10178 procedure Analyze_Part_Of_Option (Opt : Node_Id); 10179 -- Verify the legality of option Part_Of 10180 10181 procedure Check_Duplicate_Option 10182 (Opt : Node_Id; 10183 Status : in out Boolean); 10184 -- Flag Status denotes whether a particular option has been 10185 -- seen while processing a state. This routine verifies that 10186 -- Opt is not a duplicate option and sets the flag Status 10187 -- (SPARK RM 7.1.4(1)). 10188 10189 procedure Check_Duplicate_Property 10190 (Prop : Node_Id; 10191 Status : in out Boolean); 10192 -- Flag Status denotes whether a particular property has been 10193 -- seen while processing option External. This routine verifies 10194 -- that Prop is not a duplicate property and sets flag Status. 10195 -- Opt is not a duplicate property and sets the flag Status. 10196 -- (SPARK RM 7.1.4(2)) 10197 10198 procedure Create_Abstract_State 10199 (Nam : Name_Id; 10200 Decl : Node_Id; 10201 Loc : Source_Ptr; 10202 Is_Null : Boolean); 10203 -- Generate an abstract state entity with name Nam and enter it 10204 -- into visibility. Decl is the "declaration" of the state as 10205 -- it appears in pragma Abstract_State. Loc is the location of 10206 -- the related state "declaration". Flag Is_Null should be set 10207 -- when the associated Abstract_State pragma defines a null 10208 -- state. 10209 10210 ----------------------------- 10211 -- Analyze_External_Option -- 10212 ----------------------------- 10213 10214 procedure Analyze_External_Option (Opt : Node_Id) is 10215 Errors : constant Nat := Serious_Errors_Detected; 10216 Prop : Node_Id; 10217 Props : Node_Id := Empty; 10218 10219 begin 10220 Check_Duplicate_Option (Opt, External_Seen); 10221 10222 if Nkind (Opt) = N_Component_Association then 10223 Props := Expression (Opt); 10224 end if; 10225 10226 -- External state with properties 10227 10228 if Present (Props) then 10229 10230 -- Multiple properties appear as an aggregate 10231 10232 if Nkind (Props) = N_Aggregate then 10233 10234 -- Simple property form 10235 10236 Prop := First (Expressions (Props)); 10237 while Present (Prop) loop 10238 Analyze_External_Property (Prop); 10239 Next (Prop); 10240 end loop; 10241 10242 -- Property with expression form 10243 10244 Prop := First (Component_Associations (Props)); 10245 while Present (Prop) loop 10246 Analyze_External_Property 10247 (Prop => First (Choices (Prop)), 10248 Expr => Expression (Prop)); 10249 10250 Next (Prop); 10251 end loop; 10252 10253 -- Single property 10254 10255 else 10256 Analyze_External_Property (Props); 10257 end if; 10258 10259 -- An external state defined without any properties defaults 10260 -- all properties to True. 10261 10262 else 10263 AR_Val := True; 10264 AW_Val := True; 10265 ER_Val := True; 10266 EW_Val := True; 10267 end if; 10268 10269 -- Once all external properties have been processed, verify 10270 -- their mutual interaction. Do not perform the check when 10271 -- at least one of the properties is illegal as this will 10272 -- produce a bogus error. 10273 10274 if Errors = Serious_Errors_Detected then 10275 Check_External_Properties 10276 (State, AR_Val, AW_Val, ER_Val, EW_Val); 10277 end if; 10278 end Analyze_External_Option; 10279 10280 ------------------------------- 10281 -- Analyze_External_Property -- 10282 ------------------------------- 10283 10284 procedure Analyze_External_Property 10285 (Prop : Node_Id; 10286 Expr : Node_Id := Empty) 10287 is 10288 Expr_Val : Boolean; 10289 10290 begin 10291 -- Check the placement of "others" (if available) 10292 10293 if Nkind (Prop) = N_Others_Choice then 10294 if Others_Seen then 10295 Error_Msg_N 10296 ("only one others choice allowed in option External", 10297 Prop); 10298 else 10299 Others_Seen := True; 10300 end if; 10301 10302 elsif Others_Seen then 10303 Error_Msg_N 10304 ("others must be the last property in option External", 10305 Prop); 10306 10307 -- The only remaining legal options are the four predefined 10308 -- external properties. 10309 10310 elsif Nkind (Prop) = N_Identifier 10311 and then Nam_In (Chars (Prop), Name_Async_Readers, 10312 Name_Async_Writers, 10313 Name_Effective_Reads, 10314 Name_Effective_Writes) 10315 then 10316 null; 10317 10318 -- Otherwise the construct is not a valid property 10319 10320 else 10321 Error_Msg_N ("invalid external state property", Prop); 10322 return; 10323 end if; 10324 10325 -- Ensure that the expression of the external state property 10326 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)). 10327 10328 if Present (Expr) then 10329 Analyze_And_Resolve (Expr, Standard_Boolean); 10330 10331 if Is_Static_Expression (Expr) then 10332 Expr_Val := Is_True (Expr_Value (Expr)); 10333 else 10334 Error_Msg_N 10335 ("expression of external state property must be " 10336 & "static", Expr); 10337 end if; 10338 10339 -- The lack of expression defaults the property to True 10340 10341 else 10342 Expr_Val := True; 10343 end if; 10344 10345 -- Named properties 10346 10347 if Nkind (Prop) = N_Identifier then 10348 if Chars (Prop) = Name_Async_Readers then 10349 Check_Duplicate_Property (Prop, AR_Seen); 10350 AR_Val := Expr_Val; 10351 10352 elsif Chars (Prop) = Name_Async_Writers then 10353 Check_Duplicate_Property (Prop, AW_Seen); 10354 AW_Val := Expr_Val; 10355 10356 elsif Chars (Prop) = Name_Effective_Reads then 10357 Check_Duplicate_Property (Prop, ER_Seen); 10358 ER_Val := Expr_Val; 10359 10360 else 10361 Check_Duplicate_Property (Prop, EW_Seen); 10362 EW_Val := Expr_Val; 10363 end if; 10364 10365 -- The handling of property "others" must take into account 10366 -- all other named properties that have been encountered so 10367 -- far. Only those that have not been seen are affected by 10368 -- "others". 10369 10370 else 10371 if not AR_Seen then 10372 AR_Val := Expr_Val; 10373 end if; 10374 10375 if not AW_Seen then 10376 AW_Val := Expr_Val; 10377 end if; 10378 10379 if not ER_Seen then 10380 ER_Val := Expr_Val; 10381 end if; 10382 10383 if not EW_Seen then 10384 EW_Val := Expr_Val; 10385 end if; 10386 end if; 10387 end Analyze_External_Property; 10388 10389 ---------------------------- 10390 -- Analyze_Part_Of_Option -- 10391 ---------------------------- 10392 10393 procedure Analyze_Part_Of_Option (Opt : Node_Id) is 10394 Encaps : constant Node_Id := Expression (Opt); 10395 Encaps_Id : Entity_Id; 10396 Legal : Boolean; 10397 10398 begin 10399 Check_Duplicate_Option (Opt, Part_Of_Seen); 10400 10401 Analyze_Part_Of 10402 (Item_Id => State_Id, 10403 State => Encaps, 10404 Indic => First (Choices (Opt)), 10405 Legal => Legal); 10406 10407 -- The Part_Of indicator turns an abstract state into a 10408 -- constituent of the encapsulating state. 10409 10410 if Legal then 10411 Encaps_Id := Entity (Encaps); 10412 10413 Append_Elmt (State_Id, Part_Of_Constituents (Encaps_Id)); 10414 Set_Encapsulating_State (State_Id, Encaps_Id); 10415 end if; 10416 end Analyze_Part_Of_Option; 10417 10418 ---------------------------- 10419 -- Check_Duplicate_Option -- 10420 ---------------------------- 10421 10422 procedure Check_Duplicate_Option 10423 (Opt : Node_Id; 10424 Status : in out Boolean) 10425 is 10426 begin 10427 if Status then 10428 Error_Msg_N ("duplicate state option", Opt); 10429 end if; 10430 10431 Status := True; 10432 end Check_Duplicate_Option; 10433 10434 ------------------------------ 10435 -- Check_Duplicate_Property -- 10436 ------------------------------ 10437 10438 procedure Check_Duplicate_Property 10439 (Prop : Node_Id; 10440 Status : in out Boolean) 10441 is 10442 begin 10443 if Status then 10444 Error_Msg_N ("duplicate external property", Prop); 10445 end if; 10446 10447 Status := True; 10448 end Check_Duplicate_Property; 10449 10450 --------------------------- 10451 -- Create_Abstract_State -- 10452 --------------------------- 10453 10454 procedure Create_Abstract_State 10455 (Nam : Name_Id; 10456 Decl : Node_Id; 10457 Loc : Source_Ptr; 10458 Is_Null : Boolean) 10459 is 10460 begin 10461 -- The generated state abstraction reuses the same chars 10462 -- from the original state declaration. Decorate the entity. 10463 10464 State_Id := Make_Defining_Identifier (Loc, Nam); 10465 10466 -- Null states never come from source 10467 10468 Set_Comes_From_Source (State_Id, not Is_Null); 10469 Set_Parent (State_Id, State); 10470 Set_Ekind (State_Id, E_Abstract_State); 10471 Set_Etype (State_Id, Standard_Void_Type); 10472 Set_Encapsulating_State (State_Id, Empty); 10473 Set_Refinement_Constituents (State_Id, New_Elmt_List); 10474 Set_Part_Of_Constituents (State_Id, New_Elmt_List); 10475 10476 -- Establish a link between the state declaration and the 10477 -- abstract state entity. Note that a null state remains as 10478 -- N_Null and does not carry any linkages. 10479 10480 if not Is_Null then 10481 if Present (Decl) then 10482 Set_Entity (Decl, State_Id); 10483 Set_Etype (Decl, Standard_Void_Type); 10484 end if; 10485 10486 -- Every non-null state must be defined, nameable and 10487 -- resolvable. 10488 10489 Push_Scope (Pack_Id); 10490 Generate_Definition (State_Id); 10491 Enter_Name (State_Id); 10492 Pop_Scope; 10493 end if; 10494 end Create_Abstract_State; 10495 10496 -- Local variables 10497 10498 Opt : Node_Id; 10499 Opt_Nam : Node_Id; 10500 10501 -- Start of processing for Analyze_Abstract_State 10502 10503 begin 10504 -- A package with a null abstract state is not allowed to 10505 -- declare additional states. 10506 10507 if Null_Seen then 10508 Error_Msg_NE 10509 ("package & has null abstract state", State, Pack_Id); 10510 10511 -- Null states appear as internally generated entities 10512 10513 elsif Nkind (State) = N_Null then 10514 Create_Abstract_State 10515 (Nam => New_Internal_Name ('S'), 10516 Decl => Empty, 10517 Loc => Sloc (State), 10518 Is_Null => True); 10519 Null_Seen := True; 10520 10521 -- Catch a case where a null state appears in a list of 10522 -- non-null states. 10523 10524 if Non_Null_Seen then 10525 Error_Msg_NE 10526 ("package & has non-null abstract state", 10527 State, Pack_Id); 10528 end if; 10529 10530 -- Simple state declaration 10531 10532 elsif Nkind (State) = N_Identifier then 10533 Create_Abstract_State 10534 (Nam => Chars (State), 10535 Decl => State, 10536 Loc => Sloc (State), 10537 Is_Null => False); 10538 Non_Null_Seen := True; 10539 10540 -- State declaration with various options. This construct 10541 -- appears as an extension aggregate in the tree. 10542 10543 elsif Nkind (State) = N_Extension_Aggregate then 10544 if Nkind (Ancestor_Part (State)) = N_Identifier then 10545 Create_Abstract_State 10546 (Nam => Chars (Ancestor_Part (State)), 10547 Decl => Ancestor_Part (State), 10548 Loc => Sloc (Ancestor_Part (State)), 10549 Is_Null => False); 10550 Non_Null_Seen := True; 10551 else 10552 Error_Msg_N 10553 ("state name must be an identifier", 10554 Ancestor_Part (State)); 10555 end if; 10556 10557 -- Catch an attempt to introduce a simple option which is 10558 -- currently not allowed. An exception to this is External 10559 -- defined without any properties. 10560 10561 Opt := First (Expressions (State)); 10562 while Present (Opt) loop 10563 if Nkind (Opt) = N_Identifier 10564 and then Chars (Opt) = Name_External 10565 then 10566 Analyze_External_Option (Opt); 10567 10568 -- When an erroneous option Part_Of is without a parent 10569 -- state, it appears in the list of expression of the 10570 -- aggregate rather than the component associations 10571 -- (SPARK RM 7.1.4(9)). 10572 10573 elsif Chars (Opt) = Name_Part_Of then 10574 Error_Msg_N 10575 ("indicator Part_Of must denote an abstract state", 10576 Opt); 10577 10578 else 10579 Error_Msg_N 10580 ("simple option not allowed in state declaration", 10581 Opt); 10582 end if; 10583 10584 Next (Opt); 10585 end loop; 10586 10587 -- Options External and Part_Of appear as component 10588 -- associations. 10589 10590 Opt := First (Component_Associations (State)); 10591 while Present (Opt) loop 10592 Opt_Nam := First (Choices (Opt)); 10593 10594 if Nkind (Opt_Nam) = N_Identifier then 10595 if Chars (Opt_Nam) = Name_External then 10596 Analyze_External_Option (Opt); 10597 10598 elsif Chars (Opt_Nam) = Name_Part_Of then 10599 Analyze_Part_Of_Option (Opt); 10600 10601 else 10602 Error_Msg_N ("invalid state option", Opt); 10603 end if; 10604 else 10605 Error_Msg_N ("invalid state option", Opt); 10606 end if; 10607 10608 Next (Opt); 10609 end loop; 10610 10611 -- Any other attempt to declare a state is erroneous 10612 10613 else 10614 Error_Msg_N ("malformed abstract state declaration", State); 10615 end if; 10616 10617 -- Guard against a junk state. In such cases no entity is 10618 -- generated and the subsequent checks cannot be applied. 10619 10620 if Present (State_Id) then 10621 10622 -- Verify whether the state does not introduce an illegal 10623 -- hidden state within a package subject to a null abstract 10624 -- state. 10625 10626 Check_No_Hidden_State (State_Id); 10627 10628 -- Check whether the lack of option Part_Of agrees with the 10629 -- placement of the abstract state with respect to the state 10630 -- space. 10631 10632 if not Part_Of_Seen then 10633 Check_Missing_Part_Of (State_Id); 10634 end if; 10635 10636 -- Associate the state with its related package 10637 10638 if No (Abstract_States (Pack_Id)) then 10639 Set_Abstract_States (Pack_Id, New_Elmt_List); 10640 end if; 10641 10642 Append_Elmt (State_Id, Abstract_States (Pack_Id)); 10643 end if; 10644 end Analyze_Abstract_State; 10645 10646 ------------------------------------ 10647 -- Check_State_Declaration_Syntax -- 10648 ------------------------------------ 10649 10650 procedure Check_State_Declaration_Syntax (State : Node_Id) is 10651 Decl : Node_Id; 10652 10653 begin 10654 -- Null abstract state 10655 10656 if Nkind (State) = N_Null then 10657 null; 10658 10659 -- Single state 10660 10661 elsif Nkind (State) = N_Identifier then 10662 null; 10663 10664 -- State with various options 10665 10666 elsif Nkind (State) = N_Extension_Aggregate then 10667 if Nkind (Ancestor_Part (State)) /= N_Identifier then 10668 Error_Msg_N 10669 ("state name must be an identifier", 10670 Ancestor_Part (State)); 10671 end if; 10672 10673 -- Multiple states 10674 10675 elsif Nkind (State) = N_Aggregate 10676 and then Present (Expressions (State)) 10677 then 10678 Decl := First (Expressions (State)); 10679 while Present (Decl) loop 10680 Check_State_Declaration_Syntax (Decl); 10681 Next (Decl); 10682 end loop; 10683 10684 else 10685 Error_Msg_N ("malformed abstract state", State); 10686 end if; 10687 end Check_State_Declaration_Syntax; 10688 10689 -- Local variables 10690 10691 Context : constant Node_Id := Parent (Parent (N)); 10692 State : Node_Id; 10693 10694 -- Start of processing for Abstract_State 10695 10696 begin 10697 GNAT_Pragma; 10698 Check_Arg_Count (1); 10699 Ensure_Aggregate_Form (Arg1); 10700 10701 -- Ensure the proper placement of the pragma. Abstract states must 10702 -- be associated with a package declaration. 10703 10704 if not Nkind_In (Context, N_Generic_Package_Declaration, 10705 N_Package_Declaration) 10706 then 10707 Pragma_Misplaced; 10708 return; 10709 end if; 10710 10711 State := Expression (Arg1); 10712 10713 -- Verify the syntax of pragma Abstract_State when SPARK checks 10714 -- are suppressed. Semantic analysis is disabled in this mode. 10715 10716 if SPARK_Mode = Off then 10717 Check_State_Declaration_Syntax (State); 10718 return; 10719 end if; 10720 10721 Pack_Id := Defining_Entity (Context); 10722 10723 -- Multiple non-null abstract states appear as an aggregate 10724 10725 if Nkind (State) = N_Aggregate then 10726 State := First (Expressions (State)); 10727 while Present (State) loop 10728 Analyze_Abstract_State (State); 10729 Next (State); 10730 end loop; 10731 10732 -- Various forms of a single abstract state. Note that these may 10733 -- include malformed state declarations. 10734 10735 else 10736 Analyze_Abstract_State (State); 10737 end if; 10738 10739 -- Save the pragma for retrieval by other tools 10740 10741 Add_Contract_Item (N, Pack_Id); 10742 10743 -- Verify the declaration order of pragmas Abstract_State and 10744 -- Initializes. 10745 10746 Check_Declaration_Order 10747 (First => N, 10748 Second => Get_Pragma (Pack_Id, Pragma_Initializes)); 10749 end Abstract_State; 10750 10751 ------------ 10752 -- Ada_83 -- 10753 ------------ 10754 10755 -- pragma Ada_83; 10756 10757 -- Note: this pragma also has some specific processing in Par.Prag 10758 -- because we want to set the Ada version mode during parsing. 10759 10760 when Pragma_Ada_83 => 10761 GNAT_Pragma; 10762 Check_Arg_Count (0); 10763 10764 -- We really should check unconditionally for proper configuration 10765 -- pragma placement, since we really don't want mixed Ada modes 10766 -- within a single unit, and the GNAT reference manual has always 10767 -- said this was a configuration pragma, but we did not check and 10768 -- are hesitant to add the check now. 10769 10770 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 10771 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 10772 -- or Ada 2012 mode. 10773 10774 if Ada_Version >= Ada_2005 then 10775 Check_Valid_Configuration_Pragma; 10776 end if; 10777 10778 -- Now set Ada 83 mode 10779 10780 Ada_Version := Ada_83; 10781 Ada_Version_Explicit := Ada_83; 10782 Ada_Version_Pragma := N; 10783 10784 ------------ 10785 -- Ada_95 -- 10786 ------------ 10787 10788 -- pragma Ada_95; 10789 10790 -- Note: this pragma also has some specific processing in Par.Prag 10791 -- because we want to set the Ada 83 version mode during parsing. 10792 10793 when Pragma_Ada_95 => 10794 GNAT_Pragma; 10795 Check_Arg_Count (0); 10796 10797 -- We really should check unconditionally for proper configuration 10798 -- pragma placement, since we really don't want mixed Ada modes 10799 -- within a single unit, and the GNAT reference manual has always 10800 -- said this was a configuration pragma, but we did not check and 10801 -- are hesitant to add the check now. 10802 10803 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 10804 -- or Ada 95, so we must check if we are in Ada 2005 mode. 10805 10806 if Ada_Version >= Ada_2005 then 10807 Check_Valid_Configuration_Pragma; 10808 end if; 10809 10810 -- Now set Ada 95 mode 10811 10812 Ada_Version := Ada_95; 10813 Ada_Version_Explicit := Ada_95; 10814 Ada_Version_Pragma := N; 10815 10816 --------------------- 10817 -- Ada_05/Ada_2005 -- 10818 --------------------- 10819 10820 -- pragma Ada_05; 10821 -- pragma Ada_05 (LOCAL_NAME); 10822 10823 -- pragma Ada_2005; 10824 -- pragma Ada_2005 (LOCAL_NAME): 10825 10826 -- Note: these pragmas also have some specific processing in Par.Prag 10827 -- because we want to set the Ada 2005 version mode during parsing. 10828 10829 -- The one argument form is used for managing the transition from 10830 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked 10831 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95 10832 -- mode will generate a warning. In addition, in Ada_83 or Ada_95 10833 -- mode, a preference rule is established which does not choose 10834 -- such an entity unless it is unambiguously specified. This avoids 10835 -- extra subprograms marked this way from generating ambiguities in 10836 -- otherwise legal pre-Ada_2005 programs. The one argument form is 10837 -- intended for exclusive use in the GNAT run-time library. 10838 10839 when Pragma_Ada_05 | Pragma_Ada_2005 => declare 10840 E_Id : Node_Id; 10841 10842 begin 10843 GNAT_Pragma; 10844 10845 if Arg_Count = 1 then 10846 Check_Arg_Is_Local_Name (Arg1); 10847 E_Id := Get_Pragma_Arg (Arg1); 10848 10849 if Etype (E_Id) = Any_Type then 10850 return; 10851 end if; 10852 10853 Set_Is_Ada_2005_Only (Entity (E_Id)); 10854 Record_Rep_Item (Entity (E_Id), N); 10855 10856 else 10857 Check_Arg_Count (0); 10858 10859 -- For Ada_2005 we unconditionally enforce the documented 10860 -- configuration pragma placement, since we do not want to 10861 -- tolerate mixed modes in a unit involving Ada 2005. That 10862 -- would cause real difficulties for those cases where there 10863 -- are incompatibilities between Ada 95 and Ada 2005. 10864 10865 Check_Valid_Configuration_Pragma; 10866 10867 -- Now set appropriate Ada mode 10868 10869 Ada_Version := Ada_2005; 10870 Ada_Version_Explicit := Ada_2005; 10871 Ada_Version_Pragma := N; 10872 end if; 10873 end; 10874 10875 --------------------- 10876 -- Ada_12/Ada_2012 -- 10877 --------------------- 10878 10879 -- pragma Ada_12; 10880 -- pragma Ada_12 (LOCAL_NAME); 10881 10882 -- pragma Ada_2012; 10883 -- pragma Ada_2012 (LOCAL_NAME): 10884 10885 -- Note: these pragmas also have some specific processing in Par.Prag 10886 -- because we want to set the Ada 2012 version mode during parsing. 10887 10888 -- The one argument form is used for managing the transition from Ada 10889 -- 2005 to Ada 2012 in the run-time library. If an entity is marked 10890 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012 10891 -- mode will generate a warning. In addition, in any pre-Ada_2012 10892 -- mode, a preference rule is established which does not choose 10893 -- such an entity unless it is unambiguously specified. This avoids 10894 -- extra subprograms marked this way from generating ambiguities in 10895 -- otherwise legal pre-Ada_2012 programs. The one argument form is 10896 -- intended for exclusive use in the GNAT run-time library. 10897 10898 when Pragma_Ada_12 | Pragma_Ada_2012 => declare 10899 E_Id : Node_Id; 10900 10901 begin 10902 GNAT_Pragma; 10903 10904 if Arg_Count = 1 then 10905 Check_Arg_Is_Local_Name (Arg1); 10906 E_Id := Get_Pragma_Arg (Arg1); 10907 10908 if Etype (E_Id) = Any_Type then 10909 return; 10910 end if; 10911 10912 Set_Is_Ada_2012_Only (Entity (E_Id)); 10913 Record_Rep_Item (Entity (E_Id), N); 10914 10915 else 10916 Check_Arg_Count (0); 10917 10918 -- For Ada_2012 we unconditionally enforce the documented 10919 -- configuration pragma placement, since we do not want to 10920 -- tolerate mixed modes in a unit involving Ada 2012. That 10921 -- would cause real difficulties for those cases where there 10922 -- are incompatibilities between Ada 95 and Ada 2012. We could 10923 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. 10924 10925 Check_Valid_Configuration_Pragma; 10926 10927 -- Now set appropriate Ada mode 10928 10929 Ada_Version := Ada_2012; 10930 Ada_Version_Explicit := Ada_2012; 10931 Ada_Version_Pragma := N; 10932 end if; 10933 end; 10934 10935 ---------------------- 10936 -- All_Calls_Remote -- 10937 ---------------------- 10938 10939 -- pragma All_Calls_Remote [(library_package_NAME)]; 10940 10941 when Pragma_All_Calls_Remote => All_Calls_Remote : declare 10942 Lib_Entity : Entity_Id; 10943 10944 begin 10945 Check_Ada_83_Warning; 10946 Check_Valid_Library_Unit_Pragma; 10947 10948 if Nkind (N) = N_Null_Statement then 10949 return; 10950 end if; 10951 10952 Lib_Entity := Find_Lib_Unit_Name; 10953 10954 -- This pragma should only apply to a RCI unit (RM E.2.3(23)) 10955 10956 if Present (Lib_Entity) 10957 and then not Debug_Flag_U 10958 then 10959 if not Is_Remote_Call_Interface (Lib_Entity) then 10960 Error_Pragma ("pragma% only apply to rci unit"); 10961 10962 -- Set flag for entity of the library unit 10963 10964 else 10965 Set_Has_All_Calls_Remote (Lib_Entity); 10966 end if; 10967 10968 end if; 10969 end All_Calls_Remote; 10970 10971 --------------------------- 10972 -- Allow_Integer_Address -- 10973 --------------------------- 10974 10975 -- pragma Allow_Integer_Address; 10976 10977 when Pragma_Allow_Integer_Address => 10978 GNAT_Pragma; 10979 Check_Valid_Configuration_Pragma; 10980 Check_Arg_Count (0); 10981 10982 -- If Address is a private type, then set the flag to allow 10983 -- integer address values. If Address is not private (e.g. on 10984 -- VMS, where it is an integer type), then this pragma has no 10985 -- purpose, so it is simply ignored. 10986 10987 if Is_Private_Type (RTE (RE_Address)) then 10988 Opt.Allow_Integer_Address := True; 10989 end if; 10990 10991 -------------- 10992 -- Annotate -- 10993 -------------- 10994 10995 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); 10996 -- ARG ::= NAME | EXPRESSION 10997 10998 -- The first two arguments are by convention intended to refer to an 10999 -- external tool and a tool-specific function. These arguments are 11000 -- not analyzed. 11001 11002 when Pragma_Annotate => Annotate : declare 11003 Arg : Node_Id; 11004 Exp : Node_Id; 11005 11006 begin 11007 GNAT_Pragma; 11008 Check_At_Least_N_Arguments (1); 11009 Check_Arg_Is_Identifier (Arg1); 11010 Check_No_Identifiers; 11011 Store_Note (N); 11012 11013 -- Second parameter is optional, it is never analyzed 11014 11015 if No (Arg2) then 11016 null; 11017 11018 -- Here if we have a second parameter 11019 11020 else 11021 -- Second parameter must be identifier 11022 11023 Check_Arg_Is_Identifier (Arg2); 11024 11025 -- Process remaining parameters if any 11026 11027 Arg := Next (Arg2); 11028 while Present (Arg) loop 11029 Exp := Get_Pragma_Arg (Arg); 11030 Analyze (Exp); 11031 11032 if Is_Entity_Name (Exp) then 11033 null; 11034 11035 -- For string literals, we assume Standard_String as the 11036 -- type, unless the string contains wide or wide_wide 11037 -- characters. 11038 11039 elsif Nkind (Exp) = N_String_Literal then 11040 if Has_Wide_Wide_Character (Exp) then 11041 Resolve (Exp, Standard_Wide_Wide_String); 11042 elsif Has_Wide_Character (Exp) then 11043 Resolve (Exp, Standard_Wide_String); 11044 else 11045 Resolve (Exp, Standard_String); 11046 end if; 11047 11048 elsif Is_Overloaded (Exp) then 11049 Error_Pragma_Arg 11050 ("ambiguous argument for pragma%", Exp); 11051 11052 else 11053 Resolve (Exp); 11054 end if; 11055 11056 Next (Arg); 11057 end loop; 11058 end if; 11059 end Annotate; 11060 11061 ------------------------------------------------- 11062 -- Assert/Assert_And_Cut/Assume/Loop_Invariant -- 11063 ------------------------------------------------- 11064 11065 -- pragma Assert 11066 -- ( [Check => ] Boolean_EXPRESSION 11067 -- [, [Message =>] Static_String_EXPRESSION]); 11068 11069 -- pragma Assert_And_Cut 11070 -- ( [Check => ] Boolean_EXPRESSION 11071 -- [, [Message =>] Static_String_EXPRESSION]); 11072 11073 -- pragma Assume 11074 -- ( [Check => ] Boolean_EXPRESSION 11075 -- [, [Message =>] Static_String_EXPRESSION]); 11076 11077 -- pragma Loop_Invariant 11078 -- ( [Check => ] Boolean_EXPRESSION 11079 -- [, [Message =>] Static_String_EXPRESSION]); 11080 11081 when Pragma_Assert | 11082 Pragma_Assert_And_Cut | 11083 Pragma_Assume | 11084 Pragma_Loop_Invariant => 11085 Assert : declare 11086 Expr : Node_Id; 11087 Newa : List_Id; 11088 11089 Has_Loop_Entry : Boolean; 11090 -- Set True by 11091 11092 function Contains_Loop_Entry return Boolean; 11093 -- Tests if Expr contains a Loop_Entry attribute reference 11094 11095 ------------------------- 11096 -- Contains_Loop_Entry -- 11097 ------------------------- 11098 11099 function Contains_Loop_Entry return Boolean is 11100 function Process (N : Node_Id) return Traverse_Result; 11101 -- Process function for traversal to look for Loop_Entry 11102 11103 ------------- 11104 -- Process -- 11105 ------------- 11106 11107 function Process (N : Node_Id) return Traverse_Result is 11108 begin 11109 if Nkind (N) = N_Attribute_Reference 11110 and then Attribute_Name (N) = Name_Loop_Entry 11111 then 11112 Has_Loop_Entry := True; 11113 return Abandon; 11114 else 11115 return OK; 11116 end if; 11117 end Process; 11118 11119 procedure Traverse is new Traverse_Proc (Process); 11120 11121 -- Start of processing for Contains_Loop_Entry 11122 11123 begin 11124 Has_Loop_Entry := False; 11125 Traverse (Expr); 11126 return Has_Loop_Entry; 11127 end Contains_Loop_Entry; 11128 11129 -- Start of processing for Assert 11130 11131 begin 11132 -- Assert is an Ada 2005 RM-defined pragma 11133 11134 if Prag_Id = Pragma_Assert then 11135 Ada_2005_Pragma; 11136 11137 -- The remaining ones are GNAT pragmas 11138 11139 else 11140 GNAT_Pragma; 11141 end if; 11142 11143 Check_At_Least_N_Arguments (1); 11144 Check_At_Most_N_Arguments (2); 11145 Check_Arg_Order ((Name_Check, Name_Message)); 11146 Check_Optional_Identifier (Arg1, Name_Check); 11147 Expr := Get_Pragma_Arg (Arg1); 11148 11149 -- Special processing for Loop_Invariant or for other cases if 11150 -- a Loop_Entry attribute is present. 11151 11152 if Prag_Id = Pragma_Loop_Invariant 11153 or else Contains_Loop_Entry 11154 then 11155 -- Check restricted placement, must be within a loop 11156 11157 Check_Loop_Pragma_Placement; 11158 11159 -- Do preanalyze to deal with embedded Loop_Entry attribute 11160 11161 Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean); 11162 end if; 11163 11164 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating 11165 -- a corresponding Check pragma: 11166 11167 -- pragma Check (name, condition [, msg]); 11168 11169 -- Where name is the identifier matching the pragma name. So 11170 -- rewrite pragma in this manner, transfer the message argument 11171 -- if present, and analyze the result 11172 11173 -- Note: When dealing with a semantically analyzed tree, the 11174 -- information that a Check node N corresponds to a source Assert, 11175 -- Assume, or Assert_And_Cut pragma can be retrieved from the 11176 -- pragma kind of Original_Node(N). 11177 11178 Newa := New_List ( 11179 Make_Pragma_Argument_Association (Loc, 11180 Expression => Make_Identifier (Loc, Pname)), 11181 Make_Pragma_Argument_Association (Sloc (Expr), 11182 Expression => Expr)); 11183 11184 if Arg_Count > 1 then 11185 Check_Optional_Identifier (Arg2, Name_Message); 11186 Append_To (Newa, New_Copy_Tree (Arg2)); 11187 end if; 11188 11189 -- Rewrite as Check pragma 11190 11191 Rewrite (N, 11192 Make_Pragma (Loc, 11193 Chars => Name_Check, 11194 Pragma_Argument_Associations => Newa)); 11195 Analyze (N); 11196 end Assert; 11197 11198 ---------------------- 11199 -- Assertion_Policy -- 11200 ---------------------- 11201 11202 -- pragma Assertion_Policy (POLICY_IDENTIFIER); 11203 11204 -- The following form is Ada 2012 only, but we allow it in all modes 11205 11206 -- Pragma Assertion_Policy ( 11207 -- ASSERTION_KIND => POLICY_IDENTIFIER 11208 -- {, ASSERTION_KIND => POLICY_IDENTIFIER}); 11209 11210 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND 11211 11212 -- RM_ASSERTION_KIND ::= Assert | 11213 -- Static_Predicate | 11214 -- Dynamic_Predicate | 11215 -- Pre | 11216 -- Pre'Class | 11217 -- Post | 11218 -- Post'Class | 11219 -- Type_Invariant | 11220 -- Type_Invariant'Class 11221 11222 -- ID_ASSERTION_KIND ::= Assert_And_Cut | 11223 -- Assume | 11224 -- Contract_Cases | 11225 -- Debug | 11226 -- Initial_Condition | 11227 -- Loop_Invariant | 11228 -- Loop_Variant | 11229 -- Postcondition | 11230 -- Precondition | 11231 -- Predicate | 11232 -- Refined_Post | 11233 -- Statement_Assertions 11234 11235 -- Note: The RM_ASSERTION_KIND list is language-defined, and the 11236 -- ID_ASSERTION_KIND list contains implementation-defined additions 11237 -- recognized by GNAT. The effect is to control the behavior of 11238 -- identically named aspects and pragmas, depending on the specified 11239 -- policy identifier: 11240 11241 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore 11242 11243 -- Note: Check and Ignore are language-defined. Disable is a GNAT 11244 -- implementation defined addition that results in totally ignoring 11245 -- the corresponding assertion. If Disable is specified, then the 11246 -- argument of the assertion is not even analyzed. This is useful 11247 -- when the aspect/pragma argument references entities in a with'ed 11248 -- package that is replaced by a dummy package in the final build. 11249 11250 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class, 11251 -- and Type_Invariant'Class were recognized by the parser and 11252 -- transformed into references to the special internal identifiers 11253 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special 11254 -- processing is required here. 11255 11256 when Pragma_Assertion_Policy => Assertion_Policy : declare 11257 LocP : Source_Ptr; 11258 Policy : Node_Id; 11259 Arg : Node_Id; 11260 Kind : Name_Id; 11261 11262 begin 11263 Ada_2005_Pragma; 11264 11265 -- This can always appear as a configuration pragma 11266 11267 if Is_Configuration_Pragma then 11268 null; 11269 11270 -- It can also appear in a declarative part or package spec in Ada 11271 -- 2012 mode. We allow this in other modes, but in that case we 11272 -- consider that we have an Ada 2012 pragma on our hands. 11273 11274 else 11275 Check_Is_In_Decl_Part_Or_Package_Spec; 11276 Ada_2012_Pragma; 11277 end if; 11278 11279 -- One argument case with no identifier (first form above) 11280 11281 if Arg_Count = 1 11282 and then (Nkind (Arg1) /= N_Pragma_Argument_Association 11283 or else Chars (Arg1) = No_Name) 11284 then 11285 Check_Arg_Is_One_Of 11286 (Arg1, Name_Check, Name_Disable, Name_Ignore); 11287 11288 -- Treat one argument Assertion_Policy as equivalent to: 11289 11290 -- pragma Check_Policy (Assertion, policy) 11291 11292 -- So rewrite pragma in that manner and link on to the chain 11293 -- of Check_Policy pragmas, marking the pragma as analyzed. 11294 11295 Policy := Get_Pragma_Arg (Arg1); 11296 11297 Rewrite (N, 11298 Make_Pragma (Loc, 11299 Chars => Name_Check_Policy, 11300 Pragma_Argument_Associations => New_List ( 11301 Make_Pragma_Argument_Association (Loc, 11302 Expression => Make_Identifier (Loc, Name_Assertion)), 11303 11304 Make_Pragma_Argument_Association (Loc, 11305 Expression => 11306 Make_Identifier (Sloc (Policy), Chars (Policy)))))); 11307 Analyze (N); 11308 11309 -- Here if we have two or more arguments 11310 11311 else 11312 Check_At_Least_N_Arguments (1); 11313 Ada_2012_Pragma; 11314 11315 -- Loop through arguments 11316 11317 Arg := Arg1; 11318 while Present (Arg) loop 11319 LocP := Sloc (Arg); 11320 11321 -- Kind must be specified 11322 11323 if Nkind (Arg) /= N_Pragma_Argument_Association 11324 or else Chars (Arg) = No_Name 11325 then 11326 Error_Pragma_Arg 11327 ("missing assertion kind for pragma%", Arg); 11328 end if; 11329 11330 -- Check Kind and Policy have allowed forms 11331 11332 Kind := Chars (Arg); 11333 11334 if not Is_Valid_Assertion_Kind (Kind) then 11335 Error_Pragma_Arg 11336 ("invalid assertion kind for pragma%", Arg); 11337 end if; 11338 11339 Check_Arg_Is_One_Of 11340 (Arg, Name_Check, Name_Disable, Name_Ignore); 11341 11342 -- We rewrite the Assertion_Policy pragma as a series of 11343 -- Check_Policy pragmas: 11344 11345 -- Check_Policy (Kind, Policy); 11346 11347 Insert_Action (N, 11348 Make_Pragma (LocP, 11349 Chars => Name_Check_Policy, 11350 Pragma_Argument_Associations => New_List ( 11351 Make_Pragma_Argument_Association (LocP, 11352 Expression => Make_Identifier (LocP, Kind)), 11353 Make_Pragma_Argument_Association (LocP, 11354 Expression => Get_Pragma_Arg (Arg))))); 11355 11356 Arg := Next (Arg); 11357 end loop; 11358 11359 -- Rewrite the Assertion_Policy pragma as null since we have 11360 -- now inserted all the equivalent Check pragmas. 11361 11362 Rewrite (N, Make_Null_Statement (Loc)); 11363 Analyze (N); 11364 end if; 11365 end Assertion_Policy; 11366 11367 ------------------------------ 11368 -- Assume_No_Invalid_Values -- 11369 ------------------------------ 11370 11371 -- pragma Assume_No_Invalid_Values (On | Off); 11372 11373 when Pragma_Assume_No_Invalid_Values => 11374 GNAT_Pragma; 11375 Check_Valid_Configuration_Pragma; 11376 Check_Arg_Count (1); 11377 Check_No_Identifiers; 11378 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 11379 11380 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 11381 Assume_No_Invalid_Values := True; 11382 else 11383 Assume_No_Invalid_Values := False; 11384 end if; 11385 11386 -------------------------- 11387 -- Attribute_Definition -- 11388 -------------------------- 11389 11390 -- pragma Attribute_Definition 11391 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, 11392 -- [Entity =>] LOCAL_NAME, 11393 -- [Expression =>] EXPRESSION | NAME); 11394 11395 when Pragma_Attribute_Definition => Attribute_Definition : declare 11396 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); 11397 Aname : Name_Id; 11398 11399 begin 11400 GNAT_Pragma; 11401 Check_Arg_Count (3); 11402 Check_Optional_Identifier (Arg1, "attribute"); 11403 Check_Optional_Identifier (Arg2, "entity"); 11404 Check_Optional_Identifier (Arg3, "expression"); 11405 11406 if Nkind (Attribute_Designator) /= N_Identifier then 11407 Error_Msg_N ("attribute name expected", Attribute_Designator); 11408 return; 11409 end if; 11410 11411 Check_Arg_Is_Local_Name (Arg2); 11412 11413 -- If the attribute is not recognized, then issue a warning (not 11414 -- an error), and ignore the pragma. 11415 11416 Aname := Chars (Attribute_Designator); 11417 11418 if not Is_Attribute_Name (Aname) then 11419 Bad_Attribute (Attribute_Designator, Aname, Warn => True); 11420 return; 11421 end if; 11422 11423 -- Otherwise, rewrite the pragma as an attribute definition clause 11424 11425 Rewrite (N, 11426 Make_Attribute_Definition_Clause (Loc, 11427 Name => Get_Pragma_Arg (Arg2), 11428 Chars => Aname, 11429 Expression => Get_Pragma_Arg (Arg3))); 11430 Analyze (N); 11431 end Attribute_Definition; 11432 11433 --------------- 11434 -- AST_Entry -- 11435 --------------- 11436 11437 -- pragma AST_Entry (entry_IDENTIFIER); 11438 11439 when Pragma_AST_Entry => AST_Entry : declare 11440 Ent : Node_Id; 11441 11442 begin 11443 GNAT_Pragma; 11444 Check_VMS (N); 11445 Check_Arg_Count (1); 11446 Check_No_Identifiers; 11447 Check_Arg_Is_Local_Name (Arg1); 11448 Ent := Entity (Get_Pragma_Arg (Arg1)); 11449 11450 -- Note: the implementation of the AST_Entry pragma could handle 11451 -- the entry family case fine, but for now we are consistent with 11452 -- the DEC rules, and do not allow the pragma, which of course 11453 -- has the effect of also forbidding the attribute. 11454 11455 if Ekind (Ent) /= E_Entry then 11456 Error_Pragma_Arg 11457 ("pragma% argument must be simple entry name", Arg1); 11458 11459 elsif Is_AST_Entry (Ent) then 11460 Error_Pragma_Arg 11461 ("duplicate % pragma for entry", Arg1); 11462 11463 elsif Has_Homonym (Ent) then 11464 Error_Pragma_Arg 11465 ("pragma% argument cannot specify overloaded entry", Arg1); 11466 11467 else 11468 declare 11469 FF : constant Entity_Id := First_Formal (Ent); 11470 11471 begin 11472 if Present (FF) then 11473 if Present (Next_Formal (FF)) then 11474 Error_Pragma_Arg 11475 ("entry for pragma% can have only one argument", 11476 Arg1); 11477 11478 elsif Parameter_Mode (FF) /= E_In_Parameter then 11479 Error_Pragma_Arg 11480 ("entry parameter for pragma% must have mode IN", 11481 Arg1); 11482 end if; 11483 end if; 11484 end; 11485 11486 Set_Is_AST_Entry (Ent); 11487 end if; 11488 end AST_Entry; 11489 11490 ------------------------------------------------------------------ 11491 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- 11492 ------------------------------------------------------------------ 11493 11494 -- pragma Asynch_Readers ( identifier [, boolean_EXPRESSION] ); 11495 -- pragma Asynch_Writers ( identifier [, boolean_EXPRESSION] ); 11496 -- pragma Effective_Reads ( identifier [, boolean_EXPRESSION] ); 11497 -- pragma Effective_Writes ( identifier [, boolean_EXPRESSION] ); 11498 11499 when Pragma_Async_Readers | 11500 Pragma_Async_Writers | 11501 Pragma_Effective_Reads | 11502 Pragma_Effective_Writes => 11503 Async_Effective : declare 11504 Duplic : Node_Id; 11505 Obj_Id : Entity_Id; 11506 11507 begin 11508 GNAT_Pragma; 11509 Check_No_Identifiers; 11510 Check_At_Least_N_Arguments (1); 11511 Check_At_Most_N_Arguments (2); 11512 Check_Arg_Is_Local_Name (Arg1); 11513 11514 Arg1 := Get_Pragma_Arg (Arg1); 11515 11516 -- Perform minimal verification to ensure that the argument is at 11517 -- least a variable. Subsequent finer grained checks will be done 11518 -- at the end of the declarative region the contains the pragma. 11519 11520 if Is_Entity_Name (Arg1) and then Present (Entity (Arg1)) then 11521 Obj_Id := Entity (Get_Pragma_Arg (Arg1)); 11522 11523 -- It is not efficient to examine preceding statements in order 11524 -- to detect duplicate pragmas as Boolean aspects may appear 11525 -- anywhere between the related object declaration and its 11526 -- freeze point. As an alternative, inspect the contents of the 11527 -- variable contract. 11528 11529 if Ekind (Obj_Id) = E_Variable then 11530 Duplic := Get_Pragma (Obj_Id, Prag_Id); 11531 11532 if Present (Duplic) then 11533 Error_Msg_Name_1 := Pname; 11534 Error_Msg_Sloc := Sloc (Duplic); 11535 Error_Msg_N ("pragma % duplicates pragma declared #", N); 11536 11537 -- Chain the pragma on the contract for further processing. 11538 -- This also aids in detecting duplicates. 11539 11540 else 11541 Add_Contract_Item (N, Obj_Id); 11542 end if; 11543 11544 -- The minimum legality requirements have been met, do not 11545 -- fall through to the error message. 11546 11547 return; 11548 end if; 11549 end if; 11550 11551 -- If we get here, then the pragma applies to a non-object 11552 -- construct, issue a generic error (SPARK RM 7.1.3(2)). 11553 11554 Error_Pragma ("pragma % must apply to a volatile object"); 11555 end Async_Effective; 11556 11557 ------------------ 11558 -- Asynchronous -- 11559 ------------------ 11560 11561 -- pragma Asynchronous (LOCAL_NAME); 11562 11563 when Pragma_Asynchronous => Asynchronous : declare 11564 Nm : Entity_Id; 11565 C_Ent : Entity_Id; 11566 L : List_Id; 11567 S : Node_Id; 11568 N : Node_Id; 11569 Formal : Entity_Id; 11570 11571 procedure Process_Async_Pragma; 11572 -- Common processing for procedure and access-to-procedure case 11573 11574 -------------------------- 11575 -- Process_Async_Pragma -- 11576 -------------------------- 11577 11578 procedure Process_Async_Pragma is 11579 begin 11580 if No (L) then 11581 Set_Is_Asynchronous (Nm); 11582 return; 11583 end if; 11584 11585 -- The formals should be of mode IN (RM E.4.1(6)) 11586 11587 S := First (L); 11588 while Present (S) loop 11589 Formal := Defining_Identifier (S); 11590 11591 if Nkind (Formal) = N_Defining_Identifier 11592 and then Ekind (Formal) /= E_In_Parameter 11593 then 11594 Error_Pragma_Arg 11595 ("pragma% procedure can only have IN parameter", 11596 Arg1); 11597 end if; 11598 11599 Next (S); 11600 end loop; 11601 11602 Set_Is_Asynchronous (Nm); 11603 end Process_Async_Pragma; 11604 11605 -- Start of processing for pragma Asynchronous 11606 11607 begin 11608 Check_Ada_83_Warning; 11609 Check_No_Identifiers; 11610 Check_Arg_Count (1); 11611 Check_Arg_Is_Local_Name (Arg1); 11612 11613 if Debug_Flag_U then 11614 return; 11615 end if; 11616 11617 C_Ent := Cunit_Entity (Current_Sem_Unit); 11618 Analyze (Get_Pragma_Arg (Arg1)); 11619 Nm := Entity (Get_Pragma_Arg (Arg1)); 11620 11621 if not Is_Remote_Call_Interface (C_Ent) 11622 and then not Is_Remote_Types (C_Ent) 11623 then 11624 -- This pragma should only appear in an RCI or Remote Types 11625 -- unit (RM E.4.1(4)). 11626 11627 Error_Pragma 11628 ("pragma% not in Remote_Call_Interface or Remote_Types unit"); 11629 end if; 11630 11631 if Ekind (Nm) = E_Procedure 11632 and then Nkind (Parent (Nm)) = N_Procedure_Specification 11633 then 11634 if not Is_Remote_Call_Interface (Nm) then 11635 Error_Pragma_Arg 11636 ("pragma% cannot be applied on non-remote procedure", 11637 Arg1); 11638 end if; 11639 11640 L := Parameter_Specifications (Parent (Nm)); 11641 Process_Async_Pragma; 11642 return; 11643 11644 elsif Ekind (Nm) = E_Function then 11645 Error_Pragma_Arg 11646 ("pragma% cannot be applied to function", Arg1); 11647 11648 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then 11649 if Is_Record_Type (Nm) then 11650 11651 -- A record type that is the Equivalent_Type for a remote 11652 -- access-to-subprogram type. 11653 11654 N := Declaration_Node (Corresponding_Remote_Type (Nm)); 11655 11656 else 11657 -- A non-expanded RAS type (distribution is not enabled) 11658 11659 N := Declaration_Node (Nm); 11660 end if; 11661 11662 if Nkind (N) = N_Full_Type_Declaration 11663 and then Nkind (Type_Definition (N)) = 11664 N_Access_Procedure_Definition 11665 then 11666 L := Parameter_Specifications (Type_Definition (N)); 11667 Process_Async_Pragma; 11668 11669 if Is_Asynchronous (Nm) 11670 and then Expander_Active 11671 and then Get_PCS_Name /= Name_No_DSA 11672 then 11673 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); 11674 end if; 11675 11676 else 11677 Error_Pragma_Arg 11678 ("pragma% cannot reference access-to-function type", 11679 Arg1); 11680 end if; 11681 11682 -- Only other possibility is Access-to-class-wide type 11683 11684 elsif Is_Access_Type (Nm) 11685 and then Is_Class_Wide_Type (Designated_Type (Nm)) 11686 then 11687 Check_First_Subtype (Arg1); 11688 Set_Is_Asynchronous (Nm); 11689 if Expander_Active then 11690 RACW_Type_Is_Asynchronous (Nm); 11691 end if; 11692 11693 else 11694 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); 11695 end if; 11696 end Asynchronous; 11697 11698 ------------ 11699 -- Atomic -- 11700 ------------ 11701 11702 -- pragma Atomic (LOCAL_NAME); 11703 11704 when Pragma_Atomic => 11705 Process_Atomic_Shared_Volatile; 11706 11707 ----------------------- 11708 -- Atomic_Components -- 11709 ----------------------- 11710 11711 -- pragma Atomic_Components (array_LOCAL_NAME); 11712 11713 -- This processing is shared by Volatile_Components 11714 11715 when Pragma_Atomic_Components | 11716 Pragma_Volatile_Components => 11717 11718 Atomic_Components : declare 11719 E_Id : Node_Id; 11720 E : Entity_Id; 11721 D : Node_Id; 11722 K : Node_Kind; 11723 11724 begin 11725 Check_Ada_83_Warning; 11726 Check_No_Identifiers; 11727 Check_Arg_Count (1); 11728 Check_Arg_Is_Local_Name (Arg1); 11729 E_Id := Get_Pragma_Arg (Arg1); 11730 11731 if Etype (E_Id) = Any_Type then 11732 return; 11733 end if; 11734 11735 E := Entity (E_Id); 11736 11737 Check_Duplicate_Pragma (E); 11738 11739 if Rep_Item_Too_Early (E, N) 11740 or else 11741 Rep_Item_Too_Late (E, N) 11742 then 11743 return; 11744 end if; 11745 11746 D := Declaration_Node (E); 11747 K := Nkind (D); 11748 11749 if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) 11750 or else 11751 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 11752 and then Nkind (D) = N_Object_Declaration 11753 and then Nkind (Object_Definition (D)) = 11754 N_Constrained_Array_Definition) 11755 then 11756 -- The flag is set on the object, or on the base type 11757 11758 if Nkind (D) /= N_Object_Declaration then 11759 E := Base_Type (E); 11760 end if; 11761 11762 Set_Has_Volatile_Components (E); 11763 11764 if Prag_Id = Pragma_Atomic_Components then 11765 Set_Has_Atomic_Components (E); 11766 end if; 11767 11768 else 11769 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 11770 end if; 11771 end Atomic_Components; 11772 11773 -------------------- 11774 -- Attach_Handler -- 11775 -------------------- 11776 11777 -- pragma Attach_Handler (handler_NAME, EXPRESSION); 11778 11779 when Pragma_Attach_Handler => 11780 Check_Ada_83_Warning; 11781 Check_No_Identifiers; 11782 Check_Arg_Count (2); 11783 11784 if No_Run_Time_Mode then 11785 Error_Msg_CRT ("Attach_Handler pragma", N); 11786 else 11787 Check_Interrupt_Or_Attach_Handler; 11788 11789 -- The expression that designates the attribute may depend on a 11790 -- discriminant, and is therefore a per-object expression, to 11791 -- be expanded in the init proc. If expansion is enabled, then 11792 -- perform semantic checks on a copy only. 11793 11794 declare 11795 Temp : Node_Id; 11796 Typ : Node_Id; 11797 Parg2 : constant Node_Id := Get_Pragma_Arg (Arg2); 11798 11799 begin 11800 -- In Relaxed_RM_Semantics mode, we allow any static 11801 -- integer value, for compatibility with other compilers. 11802 11803 if Relaxed_RM_Semantics 11804 and then Nkind (Parg2) = N_Integer_Literal 11805 then 11806 Typ := Standard_Integer; 11807 else 11808 Typ := RTE (RE_Interrupt_ID); 11809 end if; 11810 11811 if Expander_Active then 11812 Temp := New_Copy_Tree (Parg2); 11813 Set_Parent (Temp, N); 11814 Preanalyze_And_Resolve (Temp, Typ); 11815 else 11816 Analyze (Parg2); 11817 Resolve (Parg2, Typ); 11818 end if; 11819 end; 11820 11821 Process_Interrupt_Or_Attach_Handler; 11822 end if; 11823 11824 -------------------- 11825 -- C_Pass_By_Copy -- 11826 -------------------- 11827 11828 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); 11829 11830 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare 11831 Arg : Node_Id; 11832 Val : Uint; 11833 11834 begin 11835 GNAT_Pragma; 11836 Check_Valid_Configuration_Pragma; 11837 Check_Arg_Count (1); 11838 Check_Optional_Identifier (Arg1, "max_size"); 11839 11840 Arg := Get_Pragma_Arg (Arg1); 11841 Check_Arg_Is_Static_Expression (Arg, Any_Integer); 11842 11843 Val := Expr_Value (Arg); 11844 11845 if Val <= 0 then 11846 Error_Pragma_Arg 11847 ("maximum size for pragma% must be positive", Arg1); 11848 11849 elsif UI_Is_In_Int_Range (Val) then 11850 Default_C_Record_Mechanism := UI_To_Int (Val); 11851 11852 -- If a giant value is given, Int'Last will do well enough. 11853 -- If sometime someone complains that a record larger than 11854 -- two gigabytes is not copied, we will worry about it then. 11855 11856 else 11857 Default_C_Record_Mechanism := Mechanism_Type'Last; 11858 end if; 11859 end C_Pass_By_Copy; 11860 11861 ----------- 11862 -- Check -- 11863 ----------- 11864 11865 -- pragma Check ([Name =>] CHECK_KIND, 11866 -- [Check =>] Boolean_EXPRESSION 11867 -- [,[Message =>] String_EXPRESSION]); 11868 11869 -- CHECK_KIND ::= IDENTIFIER | 11870 -- Pre'Class | 11871 -- Post'Class | 11872 -- Invariant'Class | 11873 -- Type_Invariant'Class 11874 11875 -- The identifiers Assertions and Statement_Assertions are not 11876 -- allowed, since they have special meaning for Check_Policy. 11877 11878 when Pragma_Check => Check : declare 11879 Expr : Node_Id; 11880 Eloc : Source_Ptr; 11881 Cname : Name_Id; 11882 Str : Node_Id; 11883 11884 begin 11885 GNAT_Pragma; 11886 Check_At_Least_N_Arguments (2); 11887 Check_At_Most_N_Arguments (3); 11888 Check_Optional_Identifier (Arg1, Name_Name); 11889 Check_Optional_Identifier (Arg2, Name_Check); 11890 11891 if Arg_Count = 3 then 11892 Check_Optional_Identifier (Arg3, Name_Message); 11893 Str := Get_Pragma_Arg (Arg3); 11894 end if; 11895 11896 Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1)); 11897 Check_Arg_Is_Identifier (Arg1); 11898 Cname := Chars (Get_Pragma_Arg (Arg1)); 11899 11900 -- Check forbidden name Assertions or Statement_Assertions 11901 11902 case Cname is 11903 when Name_Assertions => 11904 Error_Pragma_Arg 11905 ("""Assertions"" is not allowed as a check kind " 11906 & "for pragma%", Arg1); 11907 11908 when Name_Statement_Assertions => 11909 Error_Pragma_Arg 11910 ("""Statement_Assertions"" is not allowed as a check kind " 11911 & "for pragma%", Arg1); 11912 11913 when others => 11914 null; 11915 end case; 11916 11917 -- Check applicable policy. We skip this if Checked/Ignored status 11918 -- is already set (e.g. in the casse of a pragma from an aspect). 11919 11920 if Is_Checked (N) or else Is_Ignored (N) then 11921 null; 11922 11923 -- For a non-source pragma that is a rewriting of another pragma, 11924 -- copy the Is_Checked/Ignored status from the rewritten pragma. 11925 11926 elsif Is_Rewrite_Substitution (N) 11927 and then Nkind (Original_Node (N)) = N_Pragma 11928 and then Original_Node (N) /= N 11929 then 11930 Set_Is_Ignored (N, Is_Ignored (Original_Node (N))); 11931 Set_Is_Checked (N, Is_Checked (Original_Node (N))); 11932 11933 -- Otherwise query the applicable policy at this point 11934 11935 else 11936 case Check_Kind (Cname) is 11937 when Name_Ignore => 11938 Set_Is_Ignored (N, True); 11939 Set_Is_Checked (N, False); 11940 11941 when Name_Check => 11942 Set_Is_Ignored (N, False); 11943 Set_Is_Checked (N, True); 11944 11945 -- For disable, rewrite pragma as null statement and skip 11946 -- rest of the analysis of the pragma. 11947 11948 when Name_Disable => 11949 Rewrite (N, Make_Null_Statement (Loc)); 11950 Analyze (N); 11951 raise Pragma_Exit; 11952 11953 -- No other possibilities 11954 11955 when others => 11956 raise Program_Error; 11957 end case; 11958 end if; 11959 11960 -- If check kind was not Disable, then continue pragma analysis 11961 11962 Expr := Get_Pragma_Arg (Arg2); 11963 11964 -- Deal with SCO generation 11965 11966 case Cname is 11967 when Name_Predicate | 11968 Name_Invariant => 11969 11970 -- Nothing to do: since checks occur in client units, 11971 -- the SCO for the aspect in the declaration unit is 11972 -- conservatively always enabled. 11973 11974 null; 11975 11976 when others => 11977 11978 if Is_Checked (N) and then not Split_PPC (N) then 11979 11980 -- Mark aspect/pragma SCO as enabled 11981 11982 Set_SCO_Pragma_Enabled (Loc); 11983 end if; 11984 end case; 11985 11986 -- Deal with analyzing the string argument. 11987 11988 if Arg_Count = 3 then 11989 11990 -- If checks are not on we don't want any expansion (since 11991 -- such expansion would not get properly deleted) but 11992 -- we do want to analyze (to get proper references). 11993 -- The Preanalyze_And_Resolve routine does just what we want 11994 11995 if Is_Ignored (N) then 11996 Preanalyze_And_Resolve (Str, Standard_String); 11997 11998 -- Otherwise we need a proper analysis and expansion 11999 12000 else 12001 Analyze_And_Resolve (Str, Standard_String); 12002 end if; 12003 end if; 12004 12005 -- Now you might think we could just do the same with the Boolean 12006 -- expression if checks are off (and expansion is on) and then 12007 -- rewrite the check as a null statement. This would work but we 12008 -- would lose the useful warnings about an assertion being bound 12009 -- to fail even if assertions are turned off. 12010 12011 -- So instead we wrap the boolean expression in an if statement 12012 -- that looks like: 12013 12014 -- if False and then condition then 12015 -- null; 12016 -- end if; 12017 12018 -- The reason we do this rewriting during semantic analysis rather 12019 -- than as part of normal expansion is that we cannot analyze and 12020 -- expand the code for the boolean expression directly, or it may 12021 -- cause insertion of actions that would escape the attempt to 12022 -- suppress the check code. 12023 12024 -- Note that the Sloc for the if statement corresponds to the 12025 -- argument condition, not the pragma itself. The reason for 12026 -- this is that we may generate a warning if the condition is 12027 -- False at compile time, and we do not want to delete this 12028 -- warning when we delete the if statement. 12029 12030 if Expander_Active and Is_Ignored (N) then 12031 Eloc := Sloc (Expr); 12032 12033 Rewrite (N, 12034 Make_If_Statement (Eloc, 12035 Condition => 12036 Make_And_Then (Eloc, 12037 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), 12038 Right_Opnd => Expr), 12039 Then_Statements => New_List ( 12040 Make_Null_Statement (Eloc)))); 12041 12042 In_Assertion_Expr := In_Assertion_Expr + 1; 12043 Analyze (N); 12044 In_Assertion_Expr := In_Assertion_Expr - 1; 12045 12046 -- Check is active or expansion not active. In these cases we can 12047 -- just go ahead and analyze the boolean with no worries. 12048 12049 else 12050 In_Assertion_Expr := In_Assertion_Expr + 1; 12051 Analyze_And_Resolve (Expr, Any_Boolean); 12052 In_Assertion_Expr := In_Assertion_Expr - 1; 12053 end if; 12054 end Check; 12055 12056 -------------------------- 12057 -- Check_Float_Overflow -- 12058 -------------------------- 12059 12060 -- pragma Check_Float_Overflow; 12061 12062 when Pragma_Check_Float_Overflow => 12063 GNAT_Pragma; 12064 Check_Valid_Configuration_Pragma; 12065 Check_Arg_Count (0); 12066 Check_Float_Overflow := True; 12067 12068 ---------------- 12069 -- Check_Name -- 12070 ---------------- 12071 12072 -- pragma Check_Name (check_IDENTIFIER); 12073 12074 when Pragma_Check_Name => 12075 GNAT_Pragma; 12076 Check_No_Identifiers; 12077 Check_Valid_Configuration_Pragma; 12078 Check_Arg_Count (1); 12079 Check_Arg_Is_Identifier (Arg1); 12080 12081 declare 12082 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 12083 12084 begin 12085 for J in Check_Names.First .. Check_Names.Last loop 12086 if Check_Names.Table (J) = Nam then 12087 return; 12088 end if; 12089 end loop; 12090 12091 Check_Names.Append (Nam); 12092 end; 12093 12094 ------------------ 12095 -- Check_Policy -- 12096 ------------------ 12097 12098 -- This is the old style syntax, which is still allowed in all modes: 12099 12100 -- pragma Check_Policy ([Name =>] CHECK_KIND 12101 -- [Policy =>] POLICY_IDENTIFIER); 12102 12103 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore 12104 12105 -- CHECK_KIND ::= IDENTIFIER | 12106 -- Pre'Class | 12107 -- Post'Class | 12108 -- Type_Invariant'Class | 12109 -- Invariant'Class 12110 12111 -- This is the new style syntax, compatible with Assertion_Policy 12112 -- and also allowed in all modes. 12113 12114 -- Pragma Check_Policy ( 12115 -- CHECK_KIND => POLICY_IDENTIFIER 12116 -- {, CHECK_KIND => POLICY_IDENTIFIER}); 12117 12118 -- Note: the identifiers Name and Policy are not allowed as 12119 -- Check_Kind values. This avoids ambiguities between the old and 12120 -- new form syntax. 12121 12122 when Pragma_Check_Policy => Check_Policy : declare 12123 Kind : Node_Id; 12124 12125 begin 12126 GNAT_Pragma; 12127 Check_At_Least_N_Arguments (1); 12128 12129 -- A Check_Policy pragma can appear either as a configuration 12130 -- pragma, or in a declarative part or a package spec (see RM 12131 -- 11.5(5) for rules for Suppress/Unsuppress which are also 12132 -- followed for Check_Policy). 12133 12134 if not Is_Configuration_Pragma then 12135 Check_Is_In_Decl_Part_Or_Package_Spec; 12136 end if; 12137 12138 -- Figure out if we have the old or new syntax. We have the 12139 -- old syntax if the first argument has no identifier, or the 12140 -- identifier is Name. 12141 12142 if Nkind (Arg1) /= N_Pragma_Argument_Association 12143 or else Nam_In (Chars (Arg1), No_Name, Name_Name) 12144 then 12145 -- Old syntax 12146 12147 Check_Arg_Count (2); 12148 Check_Optional_Identifier (Arg1, Name_Name); 12149 Kind := Get_Pragma_Arg (Arg1); 12150 Rewrite_Assertion_Kind (Kind); 12151 Check_Arg_Is_Identifier (Arg1); 12152 12153 -- Check forbidden check kind 12154 12155 if Nam_In (Chars (Kind), Name_Name, Name_Policy) then 12156 Error_Msg_Name_2 := Chars (Kind); 12157 Error_Pragma_Arg 12158 ("pragma% does not allow% as check name", Arg1); 12159 end if; 12160 12161 -- Check policy 12162 12163 Check_Optional_Identifier (Arg2, Name_Policy); 12164 Check_Arg_Is_One_Of 12165 (Arg2, 12166 Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); 12167 12168 -- And chain pragma on the Check_Policy_List for search 12169 12170 Set_Next_Pragma (N, Opt.Check_Policy_List); 12171 Opt.Check_Policy_List := N; 12172 12173 -- For the new syntax, what we do is to convert each argument to 12174 -- an old syntax equivalent. We do that because we want to chain 12175 -- old style Check_Policy pragmas for the search (we don't want 12176 -- to have to deal with multiple arguments in the search). 12177 12178 else 12179 declare 12180 Arg : Node_Id; 12181 Argx : Node_Id; 12182 LocP : Source_Ptr; 12183 12184 begin 12185 Arg := Arg1; 12186 while Present (Arg) loop 12187 LocP := Sloc (Arg); 12188 Argx := Get_Pragma_Arg (Arg); 12189 12190 -- Kind must be specified 12191 12192 if Nkind (Arg) /= N_Pragma_Argument_Association 12193 or else Chars (Arg) = No_Name 12194 then 12195 Error_Pragma_Arg 12196 ("missing assertion kind for pragma%", Arg); 12197 end if; 12198 12199 -- Construct equivalent old form syntax Check_Policy 12200 -- pragma and insert it to get remaining checks. 12201 12202 Insert_Action (N, 12203 Make_Pragma (LocP, 12204 Chars => Name_Check_Policy, 12205 Pragma_Argument_Associations => New_List ( 12206 Make_Pragma_Argument_Association (LocP, 12207 Expression => 12208 Make_Identifier (LocP, Chars (Arg))), 12209 Make_Pragma_Argument_Association (Sloc (Argx), 12210 Expression => Argx)))); 12211 12212 Arg := Next (Arg); 12213 end loop; 12214 12215 -- Rewrite original Check_Policy pragma to null, since we 12216 -- have converted it into a series of old syntax pragmas. 12217 12218 Rewrite (N, Make_Null_Statement (Loc)); 12219 Analyze (N); 12220 end; 12221 end if; 12222 end Check_Policy; 12223 12224 --------------------- 12225 -- CIL_Constructor -- 12226 --------------------- 12227 12228 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME); 12229 12230 -- Processing for this pragma is shared with Java_Constructor 12231 12232 ------------- 12233 -- Comment -- 12234 ------------- 12235 12236 -- pragma Comment (static_string_EXPRESSION) 12237 12238 -- Processing for pragma Comment shares the circuitry for pragma 12239 -- Ident. The only differences are that Ident enforces a limit of 31 12240 -- characters on its argument, and also enforces limitations on 12241 -- placement for DEC compatibility. Pragma Comment shares neither of 12242 -- these restrictions. 12243 12244 ------------------- 12245 -- Common_Object -- 12246 ------------------- 12247 12248 -- pragma Common_Object ( 12249 -- [Internal =>] LOCAL_NAME 12250 -- [, [External =>] EXTERNAL_SYMBOL] 12251 -- [, [Size =>] EXTERNAL_SYMBOL]); 12252 12253 -- Processing for this pragma is shared with Psect_Object 12254 12255 ------------------------ 12256 -- Compile_Time_Error -- 12257 ------------------------ 12258 12259 -- pragma Compile_Time_Error 12260 -- (boolean_EXPRESSION, static_string_EXPRESSION); 12261 12262 when Pragma_Compile_Time_Error => 12263 GNAT_Pragma; 12264 Process_Compile_Time_Warning_Or_Error; 12265 12266 -------------------------- 12267 -- Compile_Time_Warning -- 12268 -------------------------- 12269 12270 -- pragma Compile_Time_Warning 12271 -- (boolean_EXPRESSION, static_string_EXPRESSION); 12272 12273 when Pragma_Compile_Time_Warning => 12274 GNAT_Pragma; 12275 Process_Compile_Time_Warning_Or_Error; 12276 12277 --------------------------- 12278 -- Compiler_Unit_Warning -- 12279 --------------------------- 12280 12281 -- pragma Compiler_Unit_Warning; 12282 12283 -- Historical note 12284 12285 -- Originally, we had only pragma Compiler_Unit, and it resulted in 12286 -- errors not warnings. This means that we had introduced a big extra 12287 -- inertia to compiler changes, since even if we implemented a new 12288 -- feature, and even if all versions to be used for bootstrapping 12289 -- implemented this new feature, we could not use it, since old 12290 -- compilers would give errors for using this feature in units 12291 -- having Compiler_Unit pragmas. 12292 12293 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the 12294 -- problem. We no longer have any units mentioning Compiler_Unit, 12295 -- so old compilers see Compiler_Unit_Warning which is unrecognized, 12296 -- and thus generates a warning which can be ignored. So that deals 12297 -- with the problem of old compilers not implementing the newer form 12298 -- of the pragma. 12299 12300 -- Newer compilers recognize the new pragma, but generate warning 12301 -- messages instead of errors, which again can be ignored in the 12302 -- case of an old compiler which implements a wanted new feature 12303 -- but at the time felt like warning about it for older compilers. 12304 12305 -- We retain Compiler_Unit so that new compilers can be used to build 12306 -- older run-times that use this pragma. That's an unusual case, but 12307 -- it's easy enough to handle, so why not? 12308 12309 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning => 12310 GNAT_Pragma; 12311 Check_Arg_Count (0); 12312 Set_Is_Compiler_Unit (Get_Source_Unit (N)); 12313 12314 ----------------------------- 12315 -- Complete_Representation -- 12316 ----------------------------- 12317 12318 -- pragma Complete_Representation; 12319 12320 when Pragma_Complete_Representation => 12321 GNAT_Pragma; 12322 Check_Arg_Count (0); 12323 12324 if Nkind (Parent (N)) /= N_Record_Representation_Clause then 12325 Error_Pragma 12326 ("pragma & must appear within record representation clause"); 12327 end if; 12328 12329 ---------------------------- 12330 -- Complex_Representation -- 12331 ---------------------------- 12332 12333 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); 12334 12335 when Pragma_Complex_Representation => Complex_Representation : declare 12336 E_Id : Entity_Id; 12337 E : Entity_Id; 12338 Ent : Entity_Id; 12339 12340 begin 12341 GNAT_Pragma; 12342 Check_Arg_Count (1); 12343 Check_Optional_Identifier (Arg1, Name_Entity); 12344 Check_Arg_Is_Local_Name (Arg1); 12345 E_Id := Get_Pragma_Arg (Arg1); 12346 12347 if Etype (E_Id) = Any_Type then 12348 return; 12349 end if; 12350 12351 E := Entity (E_Id); 12352 12353 if not Is_Record_Type (E) then 12354 Error_Pragma_Arg 12355 ("argument for pragma% must be record type", Arg1); 12356 end if; 12357 12358 Ent := First_Entity (E); 12359 12360 if No (Ent) 12361 or else No (Next_Entity (Ent)) 12362 or else Present (Next_Entity (Next_Entity (Ent))) 12363 or else not Is_Floating_Point_Type (Etype (Ent)) 12364 or else Etype (Ent) /= Etype (Next_Entity (Ent)) 12365 then 12366 Error_Pragma_Arg 12367 ("record for pragma% must have two fields of the same " 12368 & "floating-point type", Arg1); 12369 12370 else 12371 Set_Has_Complex_Representation (Base_Type (E)); 12372 12373 -- We need to treat the type has having a non-standard 12374 -- representation, for back-end purposes, even though in 12375 -- general a complex will have the default representation 12376 -- of a record with two real components. 12377 12378 Set_Has_Non_Standard_Rep (Base_Type (E)); 12379 end if; 12380 end Complex_Representation; 12381 12382 ------------------------- 12383 -- Component_Alignment -- 12384 ------------------------- 12385 12386 -- pragma Component_Alignment ( 12387 -- [Form =>] ALIGNMENT_CHOICE 12388 -- [, [Name =>] type_LOCAL_NAME]); 12389 -- 12390 -- ALIGNMENT_CHOICE ::= 12391 -- Component_Size 12392 -- | Component_Size_4 12393 -- | Storage_Unit 12394 -- | Default 12395 12396 when Pragma_Component_Alignment => Component_AlignmentP : declare 12397 Args : Args_List (1 .. 2); 12398 Names : constant Name_List (1 .. 2) := ( 12399 Name_Form, 12400 Name_Name); 12401 12402 Form : Node_Id renames Args (1); 12403 Name : Node_Id renames Args (2); 12404 12405 Atype : Component_Alignment_Kind; 12406 Typ : Entity_Id; 12407 12408 begin 12409 GNAT_Pragma; 12410 Gather_Associations (Names, Args); 12411 12412 if No (Form) then 12413 Error_Pragma ("missing Form argument for pragma%"); 12414 end if; 12415 12416 Check_Arg_Is_Identifier (Form); 12417 12418 -- Get proper alignment, note that Default = Component_Size on all 12419 -- machines we have so far, and we want to set this value rather 12420 -- than the default value to indicate that it has been explicitly 12421 -- set (and thus will not get overridden by the default component 12422 -- alignment for the current scope) 12423 12424 if Chars (Form) = Name_Component_Size then 12425 Atype := Calign_Component_Size; 12426 12427 elsif Chars (Form) = Name_Component_Size_4 then 12428 Atype := Calign_Component_Size_4; 12429 12430 elsif Chars (Form) = Name_Default then 12431 Atype := Calign_Component_Size; 12432 12433 elsif Chars (Form) = Name_Storage_Unit then 12434 Atype := Calign_Storage_Unit; 12435 12436 else 12437 Error_Pragma_Arg 12438 ("invalid Form parameter for pragma%", Form); 12439 end if; 12440 12441 -- Case with no name, supplied, affects scope table entry 12442 12443 if No (Name) then 12444 Scope_Stack.Table 12445 (Scope_Stack.Last).Component_Alignment_Default := Atype; 12446 12447 -- Case of name supplied 12448 12449 else 12450 Check_Arg_Is_Local_Name (Name); 12451 Find_Type (Name); 12452 Typ := Entity (Name); 12453 12454 if Typ = Any_Type 12455 or else Rep_Item_Too_Early (Typ, N) 12456 then 12457 return; 12458 else 12459 Typ := Underlying_Type (Typ); 12460 end if; 12461 12462 if not Is_Record_Type (Typ) 12463 and then not Is_Array_Type (Typ) 12464 then 12465 Error_Pragma_Arg 12466 ("Name parameter of pragma% must identify record or " 12467 & "array type", Name); 12468 end if; 12469 12470 -- An explicit Component_Alignment pragma overrides an 12471 -- implicit pragma Pack, but not an explicit one. 12472 12473 if not Has_Pragma_Pack (Base_Type (Typ)) then 12474 Set_Is_Packed (Base_Type (Typ), False); 12475 Set_Component_Alignment (Base_Type (Typ), Atype); 12476 end if; 12477 end if; 12478 end Component_AlignmentP; 12479 12480 -------------------- 12481 -- Contract_Cases -- 12482 -------------------- 12483 12484 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE)); 12485 12486 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE 12487 12488 -- CASE_GUARD ::= boolean_EXPRESSION | others 12489 12490 -- CONSEQUENCE ::= boolean_EXPRESSION 12491 12492 when Pragma_Contract_Cases => Contract_Cases : declare 12493 Subp_Decl : Node_Id; 12494 12495 begin 12496 GNAT_Pragma; 12497 Check_Arg_Count (1); 12498 Ensure_Aggregate_Form (Arg1); 12499 12500 -- The pragma is analyzed at the end of the declarative part which 12501 -- contains the related subprogram. Reset the analyzed flag. 12502 12503 Set_Analyzed (N, False); 12504 12505 -- Ensure the proper placement of the pragma. Contract_Cases must 12506 -- be associated with a subprogram declaration or a body that acts 12507 -- as a spec. 12508 12509 Subp_Decl := 12510 Find_Related_Subprogram_Or_Body (N, Do_Checks => True); 12511 12512 if Nkind (Subp_Decl) = N_Subprogram_Declaration then 12513 null; 12514 12515 -- Body acts as spec 12516 12517 elsif Nkind (Subp_Decl) = N_Subprogram_Body 12518 and then No (Corresponding_Spec (Subp_Decl)) 12519 then 12520 null; 12521 12522 -- Body stub acts as spec 12523 12524 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 12525 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 12526 then 12527 null; 12528 12529 else 12530 Pragma_Misplaced; 12531 return; 12532 end if; 12533 12534 -- When the pragma appears on a subprogram body, perform the full 12535 -- analysis now. 12536 12537 if Nkind (Subp_Decl) = N_Subprogram_Body then 12538 Analyze_Contract_Cases_In_Decl_Part (N); 12539 12540 -- When Contract_Cases applies to a subprogram compilation unit, 12541 -- the corresponding pragma is placed after the unit's declaration 12542 -- node and needs to be analyzed immediately. 12543 12544 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration 12545 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit 12546 then 12547 Analyze_Contract_Cases_In_Decl_Part (N); 12548 end if; 12549 12550 -- Chain the pragma on the contract for further processing 12551 12552 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 12553 end Contract_Cases; 12554 12555 ---------------- 12556 -- Controlled -- 12557 ---------------- 12558 12559 -- pragma Controlled (first_subtype_LOCAL_NAME); 12560 12561 when Pragma_Controlled => Controlled : declare 12562 Arg : Node_Id; 12563 12564 begin 12565 Check_No_Identifiers; 12566 Check_Arg_Count (1); 12567 Check_Arg_Is_Local_Name (Arg1); 12568 Arg := Get_Pragma_Arg (Arg1); 12569 12570 if not Is_Entity_Name (Arg) 12571 or else not Is_Access_Type (Entity (Arg)) 12572 then 12573 Error_Pragma_Arg ("pragma% requires access type", Arg1); 12574 else 12575 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); 12576 end if; 12577 end Controlled; 12578 12579 ---------------- 12580 -- Convention -- 12581 ---------------- 12582 12583 -- pragma Convention ([Convention =>] convention_IDENTIFIER, 12584 -- [Entity =>] LOCAL_NAME); 12585 12586 when Pragma_Convention => Convention : declare 12587 C : Convention_Id; 12588 E : Entity_Id; 12589 pragma Warnings (Off, C); 12590 pragma Warnings (Off, E); 12591 begin 12592 Check_Arg_Order ((Name_Convention, Name_Entity)); 12593 Check_Ada_83_Warning; 12594 Check_Arg_Count (2); 12595 Process_Convention (C, E); 12596 end Convention; 12597 12598 --------------------------- 12599 -- Convention_Identifier -- 12600 --------------------------- 12601 12602 -- pragma Convention_Identifier ([Name =>] IDENTIFIER, 12603 -- [Convention =>] convention_IDENTIFIER); 12604 12605 when Pragma_Convention_Identifier => Convention_Identifier : declare 12606 Idnam : Name_Id; 12607 Cname : Name_Id; 12608 12609 begin 12610 GNAT_Pragma; 12611 Check_Arg_Order ((Name_Name, Name_Convention)); 12612 Check_Arg_Count (2); 12613 Check_Optional_Identifier (Arg1, Name_Name); 12614 Check_Optional_Identifier (Arg2, Name_Convention); 12615 Check_Arg_Is_Identifier (Arg1); 12616 Check_Arg_Is_Identifier (Arg2); 12617 Idnam := Chars (Get_Pragma_Arg (Arg1)); 12618 Cname := Chars (Get_Pragma_Arg (Arg2)); 12619 12620 if Is_Convention_Name (Cname) then 12621 Record_Convention_Identifier 12622 (Idnam, Get_Convention_Id (Cname)); 12623 else 12624 Error_Pragma_Arg 12625 ("second arg for % pragma must be convention", Arg2); 12626 end if; 12627 end Convention_Identifier; 12628 12629 --------------- 12630 -- CPP_Class -- 12631 --------------- 12632 12633 -- pragma CPP_Class ([Entity =>] local_NAME) 12634 12635 when Pragma_CPP_Class => CPP_Class : declare 12636 begin 12637 GNAT_Pragma; 12638 12639 if Warn_On_Obsolescent_Feature then 12640 Error_Msg_N 12641 ("'G'N'A'T pragma cpp'_class is now obsolete and has no " 12642 & "effect; replace it by pragma import?j?", N); 12643 end if; 12644 12645 Check_Arg_Count (1); 12646 12647 Rewrite (N, 12648 Make_Pragma (Loc, 12649 Chars => Name_Import, 12650 Pragma_Argument_Associations => New_List ( 12651 Make_Pragma_Argument_Association (Loc, 12652 Expression => Make_Identifier (Loc, Name_CPP)), 12653 New_Copy (First (Pragma_Argument_Associations (N)))))); 12654 Analyze (N); 12655 end CPP_Class; 12656 12657 --------------------- 12658 -- CPP_Constructor -- 12659 --------------------- 12660 12661 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME 12662 -- [, [External_Name =>] static_string_EXPRESSION ] 12663 -- [, [Link_Name =>] static_string_EXPRESSION ]); 12664 12665 when Pragma_CPP_Constructor => CPP_Constructor : declare 12666 Elmt : Elmt_Id; 12667 Id : Entity_Id; 12668 Def_Id : Entity_Id; 12669 Tag_Typ : Entity_Id; 12670 12671 begin 12672 GNAT_Pragma; 12673 Check_At_Least_N_Arguments (1); 12674 Check_At_Most_N_Arguments (3); 12675 Check_Optional_Identifier (Arg1, Name_Entity); 12676 Check_Arg_Is_Local_Name (Arg1); 12677 12678 Id := Get_Pragma_Arg (Arg1); 12679 Find_Program_Unit_Name (Id); 12680 12681 -- If we did not find the name, we are done 12682 12683 if Etype (Id) = Any_Type then 12684 return; 12685 end if; 12686 12687 Def_Id := Entity (Id); 12688 12689 -- Check if already defined as constructor 12690 12691 if Is_Constructor (Def_Id) then 12692 Error_Msg_N 12693 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1); 12694 return; 12695 end if; 12696 12697 if Ekind (Def_Id) = E_Function 12698 and then (Is_CPP_Class (Etype (Def_Id)) 12699 or else (Is_Class_Wide_Type (Etype (Def_Id)) 12700 and then 12701 Is_CPP_Class (Root_Type (Etype (Def_Id))))) 12702 then 12703 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then 12704 Error_Msg_N 12705 ("'C'P'P constructor must be defined in the scope of " 12706 & "its returned type", Arg1); 12707 end if; 12708 12709 if Arg_Count >= 2 then 12710 Set_Imported (Def_Id); 12711 Set_Is_Public (Def_Id); 12712 Process_Interface_Name (Def_Id, Arg2, Arg3); 12713 end if; 12714 12715 Set_Has_Completion (Def_Id); 12716 Set_Is_Constructor (Def_Id); 12717 Set_Convention (Def_Id, Convention_CPP); 12718 12719 -- Imported C++ constructors are not dispatching primitives 12720 -- because in C++ they don't have a dispatch table slot. 12721 -- However, in Ada the constructor has the profile of a 12722 -- function that returns a tagged type and therefore it has 12723 -- been treated as a primitive operation during semantic 12724 -- analysis. We now remove it from the list of primitive 12725 -- operations of the type. 12726 12727 if Is_Tagged_Type (Etype (Def_Id)) 12728 and then not Is_Class_Wide_Type (Etype (Def_Id)) 12729 and then Is_Dispatching_Operation (Def_Id) 12730 then 12731 Tag_Typ := Etype (Def_Id); 12732 12733 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 12734 while Present (Elmt) and then Node (Elmt) /= Def_Id loop 12735 Next_Elmt (Elmt); 12736 end loop; 12737 12738 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); 12739 Set_Is_Dispatching_Operation (Def_Id, False); 12740 end if; 12741 12742 -- For backward compatibility, if the constructor returns a 12743 -- class wide type, and we internally change the return type to 12744 -- the corresponding root type. 12745 12746 if Is_Class_Wide_Type (Etype (Def_Id)) then 12747 Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); 12748 end if; 12749 else 12750 Error_Pragma_Arg 12751 ("pragma% requires function returning a 'C'P'P_Class type", 12752 Arg1); 12753 end if; 12754 end CPP_Constructor; 12755 12756 ----------------- 12757 -- CPP_Virtual -- 12758 ----------------- 12759 12760 when Pragma_CPP_Virtual => CPP_Virtual : declare 12761 begin 12762 GNAT_Pragma; 12763 12764 if Warn_On_Obsolescent_Feature then 12765 Error_Msg_N 12766 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no " 12767 & "effect?j?", N); 12768 end if; 12769 end CPP_Virtual; 12770 12771 ---------------- 12772 -- CPP_Vtable -- 12773 ---------------- 12774 12775 when Pragma_CPP_Vtable => CPP_Vtable : declare 12776 begin 12777 GNAT_Pragma; 12778 12779 if Warn_On_Obsolescent_Feature then 12780 Error_Msg_N 12781 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no " 12782 & "effect?j?", N); 12783 end if; 12784 end CPP_Vtable; 12785 12786 --------- 12787 -- CPU -- 12788 --------- 12789 12790 -- pragma CPU (EXPRESSION); 12791 12792 when Pragma_CPU => CPU : declare 12793 P : constant Node_Id := Parent (N); 12794 Arg : Node_Id; 12795 Ent : Entity_Id; 12796 12797 begin 12798 Ada_2012_Pragma; 12799 Check_No_Identifiers; 12800 Check_Arg_Count (1); 12801 12802 -- Subprogram case 12803 12804 if Nkind (P) = N_Subprogram_Body then 12805 Check_In_Main_Program; 12806 12807 Arg := Get_Pragma_Arg (Arg1); 12808 Analyze_And_Resolve (Arg, Any_Integer); 12809 12810 Ent := Defining_Unit_Name (Specification (P)); 12811 12812 if Nkind (Ent) = N_Defining_Program_Unit_Name then 12813 Ent := Defining_Identifier (Ent); 12814 end if; 12815 12816 -- Must be static 12817 12818 if not Is_Static_Expression (Arg) then 12819 Flag_Non_Static_Expr 12820 ("main subprogram affinity is not static!", Arg); 12821 raise Pragma_Exit; 12822 12823 -- If constraint error, then we already signalled an error 12824 12825 elsif Raises_Constraint_Error (Arg) then 12826 null; 12827 12828 -- Otherwise check in range 12829 12830 else 12831 declare 12832 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); 12833 -- This is the entity System.Multiprocessors.CPU_Range; 12834 12835 Val : constant Uint := Expr_Value (Arg); 12836 12837 begin 12838 if Val < Expr_Value (Type_Low_Bound (CPU_Id)) 12839 or else 12840 Val > Expr_Value (Type_High_Bound (CPU_Id)) 12841 then 12842 Error_Pragma_Arg 12843 ("main subprogram CPU is out of range", Arg1); 12844 end if; 12845 end; 12846 end if; 12847 12848 Set_Main_CPU 12849 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 12850 12851 -- Task case 12852 12853 elsif Nkind (P) = N_Task_Definition then 12854 Arg := Get_Pragma_Arg (Arg1); 12855 Ent := Defining_Identifier (Parent (P)); 12856 12857 -- The expression must be analyzed in the special manner 12858 -- described in "Handling of Default and Per-Object 12859 -- Expressions" in sem.ads. 12860 12861 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); 12862 12863 -- Anything else is incorrect 12864 12865 else 12866 Pragma_Misplaced; 12867 end if; 12868 12869 -- Check duplicate pragma before we chain the pragma in the Rep 12870 -- Item chain of Ent. 12871 12872 Check_Duplicate_Pragma (Ent); 12873 Record_Rep_Item (Ent, N); 12874 end CPU; 12875 12876 ----------- 12877 -- Debug -- 12878 ----------- 12879 12880 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); 12881 12882 when Pragma_Debug => Debug : declare 12883 Cond : Node_Id; 12884 Call : Node_Id; 12885 12886 begin 12887 GNAT_Pragma; 12888 12889 -- The condition for executing the call is that the expander 12890 -- is active and that we are not ignoring this debug pragma. 12891 12892 Cond := 12893 New_Occurrence_Of 12894 (Boolean_Literals 12895 (Expander_Active and then not Is_Ignored (N)), 12896 Loc); 12897 12898 if not Is_Ignored (N) then 12899 Set_SCO_Pragma_Enabled (Loc); 12900 end if; 12901 12902 if Arg_Count = 2 then 12903 Cond := 12904 Make_And_Then (Loc, 12905 Left_Opnd => Relocate_Node (Cond), 12906 Right_Opnd => Get_Pragma_Arg (Arg1)); 12907 Call := Get_Pragma_Arg (Arg2); 12908 else 12909 Call := Get_Pragma_Arg (Arg1); 12910 end if; 12911 12912 if Nkind_In (Call, 12913 N_Indexed_Component, 12914 N_Function_Call, 12915 N_Identifier, 12916 N_Expanded_Name, 12917 N_Selected_Component) 12918 then 12919 -- If this pragma Debug comes from source, its argument was 12920 -- parsed as a name form (which is syntactically identical). 12921 -- In a generic context a parameterless call will be left as 12922 -- an expanded name (if global) or selected_component if local. 12923 -- Change it to a procedure call statement now. 12924 12925 Change_Name_To_Procedure_Call_Statement (Call); 12926 12927 elsif Nkind (Call) = N_Procedure_Call_Statement then 12928 12929 -- Already in the form of a procedure call statement: nothing 12930 -- to do (could happen in case of an internally generated 12931 -- pragma Debug). 12932 12933 null; 12934 12935 else 12936 -- All other cases: diagnose error 12937 12938 Error_Msg 12939 ("argument of pragma ""Debug"" is not procedure call", 12940 Sloc (Call)); 12941 return; 12942 end if; 12943 12944 -- Rewrite into a conditional with an appropriate condition. We 12945 -- wrap the procedure call in a block so that overhead from e.g. 12946 -- use of the secondary stack does not generate execution overhead 12947 -- for suppressed conditions. 12948 12949 -- Normally the analysis that follows will freeze the subprogram 12950 -- being called. However, if the call is to a null procedure, 12951 -- we want to freeze it before creating the block, because the 12952 -- analysis that follows may be done with expansion disabled, in 12953 -- which case the body will not be generated, leading to spurious 12954 -- errors. 12955 12956 if Nkind (Call) = N_Procedure_Call_Statement 12957 and then Is_Entity_Name (Name (Call)) 12958 then 12959 Analyze (Name (Call)); 12960 Freeze_Before (N, Entity (Name (Call))); 12961 end if; 12962 12963 Rewrite (N, 12964 Make_Implicit_If_Statement (N, 12965 Condition => Cond, 12966 Then_Statements => New_List ( 12967 Make_Block_Statement (Loc, 12968 Handled_Statement_Sequence => 12969 Make_Handled_Sequence_Of_Statements (Loc, 12970 Statements => New_List (Relocate_Node (Call))))))); 12971 Analyze (N); 12972 12973 -- Ignore pragma Debug in GNATprove mode. Do this rewriting 12974 -- after analysis of the normally rewritten node, to capture all 12975 -- references to entities, which avoids issuing wrong warnings 12976 -- about unused entities. 12977 12978 if GNATprove_Mode then 12979 Rewrite (N, Make_Null_Statement (Loc)); 12980 end if; 12981 end Debug; 12982 12983 ------------------ 12984 -- Debug_Policy -- 12985 ------------------ 12986 12987 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore) 12988 12989 when Pragma_Debug_Policy => 12990 GNAT_Pragma; 12991 Check_Arg_Count (1); 12992 Check_No_Identifiers; 12993 Check_Arg_Is_Identifier (Arg1); 12994 12995 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so 12996 -- rewrite it that way, and let the rest of the checking come 12997 -- from analyzing the rewritten pragma. 12998 12999 Rewrite (N, 13000 Make_Pragma (Loc, 13001 Chars => Name_Check_Policy, 13002 Pragma_Argument_Associations => New_List ( 13003 Make_Pragma_Argument_Association (Loc, 13004 Expression => Make_Identifier (Loc, Name_Debug)), 13005 13006 Make_Pragma_Argument_Association (Loc, 13007 Expression => Get_Pragma_Arg (Arg1))))); 13008 Analyze (N); 13009 13010 ------------- 13011 -- Depends -- 13012 ------------- 13013 13014 -- pragma Depends (DEPENDENCY_RELATION); 13015 13016 -- DEPENDENCY_RELATION ::= 13017 -- null 13018 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE} 13019 13020 -- DEPENDENCY_CLAUSE ::= 13021 -- OUTPUT_LIST =>[+] INPUT_LIST 13022 -- | NULL_DEPENDENCY_CLAUSE 13023 13024 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 13025 13026 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 13027 13028 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 13029 13030 -- OUTPUT ::= NAME | FUNCTION_RESULT 13031 -- INPUT ::= NAME 13032 13033 -- where FUNCTION_RESULT is a function Result attribute_reference 13034 13035 when Pragma_Depends => Depends : declare 13036 Subp_Decl : Node_Id; 13037 13038 begin 13039 GNAT_Pragma; 13040 Check_Arg_Count (1); 13041 Ensure_Aggregate_Form (Arg1); 13042 13043 -- Ensure the proper placement of the pragma. Depends must be 13044 -- associated with a subprogram declaration or a body that acts 13045 -- as a spec. 13046 13047 Subp_Decl := 13048 Find_Related_Subprogram_Or_Body (N, Do_Checks => True); 13049 13050 if Nkind (Subp_Decl) = N_Subprogram_Declaration then 13051 null; 13052 13053 -- Body acts as spec 13054 13055 elsif Nkind (Subp_Decl) = N_Subprogram_Body 13056 and then No (Corresponding_Spec (Subp_Decl)) 13057 then 13058 null; 13059 13060 -- Body stub acts as spec 13061 13062 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 13063 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 13064 then 13065 null; 13066 13067 else 13068 Pragma_Misplaced; 13069 return; 13070 end if; 13071 13072 -- When the pragma appears on a subprogram body, perform the full 13073 -- analysis now. 13074 13075 if Nkind (Subp_Decl) = N_Subprogram_Body then 13076 Analyze_Depends_In_Decl_Part (N); 13077 13078 -- When Depends applies to a subprogram compilation unit, the 13079 -- corresponding pragma is placed after the unit's declaration 13080 -- node and needs to be analyzed immediately. 13081 13082 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration 13083 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit 13084 then 13085 Analyze_Depends_In_Decl_Part (N); 13086 end if; 13087 13088 -- Chain the pragma on the contract for further processing 13089 13090 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 13091 end Depends; 13092 13093 --------------------- 13094 -- Detect_Blocking -- 13095 --------------------- 13096 13097 -- pragma Detect_Blocking; 13098 13099 when Pragma_Detect_Blocking => 13100 Ada_2005_Pragma; 13101 Check_Arg_Count (0); 13102 Check_Valid_Configuration_Pragma; 13103 Detect_Blocking := True; 13104 13105 -------------------------- 13106 -- Default_Storage_Pool -- 13107 -------------------------- 13108 13109 -- pragma Default_Storage_Pool (storage_pool_NAME | null); 13110 13111 when Pragma_Default_Storage_Pool => 13112 Ada_2012_Pragma; 13113 Check_Arg_Count (1); 13114 13115 -- Default_Storage_Pool can appear as a configuration pragma, or 13116 -- in a declarative part or a package spec. 13117 13118 if not Is_Configuration_Pragma then 13119 Check_Is_In_Decl_Part_Or_Package_Spec; 13120 end if; 13121 13122 -- Case of Default_Storage_Pool (null); 13123 13124 if Nkind (Expression (Arg1)) = N_Null then 13125 Analyze (Expression (Arg1)); 13126 13127 -- This is an odd case, this is not really an expression, so 13128 -- we don't have a type for it. So just set the type to Empty. 13129 13130 Set_Etype (Expression (Arg1), Empty); 13131 13132 -- Case of Default_Storage_Pool (storage_pool_NAME); 13133 13134 else 13135 -- If it's a configuration pragma, then the only allowed 13136 -- argument is "null". 13137 13138 if Is_Configuration_Pragma then 13139 Error_Pragma_Arg ("NULL expected", Arg1); 13140 end if; 13141 13142 -- The expected type for a non-"null" argument is 13143 -- Root_Storage_Pool'Class. 13144 13145 Analyze_And_Resolve 13146 (Get_Pragma_Arg (Arg1), 13147 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 13148 end if; 13149 13150 -- Finally, record the pool name (or null). Freeze.Freeze_Entity 13151 -- for an access type will use this information to set the 13152 -- appropriate attributes of the access type. 13153 13154 Default_Pool := Expression (Arg1); 13155 13156 ------------------------------------ 13157 -- Disable_Atomic_Synchronization -- 13158 ------------------------------------ 13159 13160 -- pragma Disable_Atomic_Synchronization [(Entity)]; 13161 13162 when Pragma_Disable_Atomic_Synchronization => 13163 GNAT_Pragma; 13164 Process_Disable_Enable_Atomic_Sync (Name_Suppress); 13165 13166 ------------------- 13167 -- Discard_Names -- 13168 ------------------- 13169 13170 -- pragma Discard_Names [([On =>] LOCAL_NAME)]; 13171 13172 when Pragma_Discard_Names => Discard_Names : declare 13173 E : Entity_Id; 13174 E_Id : Entity_Id; 13175 13176 begin 13177 Check_Ada_83_Warning; 13178 13179 -- Deal with configuration pragma case 13180 13181 if Arg_Count = 0 and then Is_Configuration_Pragma then 13182 Global_Discard_Names := True; 13183 return; 13184 13185 -- Otherwise, check correct appropriate context 13186 13187 else 13188 Check_Is_In_Decl_Part_Or_Package_Spec; 13189 13190 if Arg_Count = 0 then 13191 13192 -- If there is no parameter, then from now on this pragma 13193 -- applies to any enumeration, exception or tagged type 13194 -- defined in the current declarative part, and recursively 13195 -- to any nested scope. 13196 13197 Set_Discard_Names (Current_Scope); 13198 return; 13199 13200 else 13201 Check_Arg_Count (1); 13202 Check_Optional_Identifier (Arg1, Name_On); 13203 Check_Arg_Is_Local_Name (Arg1); 13204 13205 E_Id := Get_Pragma_Arg (Arg1); 13206 13207 if Etype (E_Id) = Any_Type then 13208 return; 13209 else 13210 E := Entity (E_Id); 13211 end if; 13212 13213 if (Is_First_Subtype (E) 13214 and then 13215 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) 13216 or else Ekind (E) = E_Exception 13217 then 13218 Set_Discard_Names (E); 13219 Record_Rep_Item (E, N); 13220 13221 else 13222 Error_Pragma_Arg 13223 ("inappropriate entity for pragma%", Arg1); 13224 end if; 13225 13226 end if; 13227 end if; 13228 end Discard_Names; 13229 13230 ------------------------ 13231 -- Dispatching_Domain -- 13232 ------------------------ 13233 13234 -- pragma Dispatching_Domain (EXPRESSION); 13235 13236 when Pragma_Dispatching_Domain => Dispatching_Domain : declare 13237 P : constant Node_Id := Parent (N); 13238 Arg : Node_Id; 13239 Ent : Entity_Id; 13240 13241 begin 13242 Ada_2012_Pragma; 13243 Check_No_Identifiers; 13244 Check_Arg_Count (1); 13245 13246 -- This pragma is born obsolete, but not the aspect 13247 13248 if not From_Aspect_Specification (N) then 13249 Check_Restriction 13250 (No_Obsolescent_Features, Pragma_Identifier (N)); 13251 end if; 13252 13253 if Nkind (P) = N_Task_Definition then 13254 Arg := Get_Pragma_Arg (Arg1); 13255 Ent := Defining_Identifier (Parent (P)); 13256 13257 -- The expression must be analyzed in the special manner 13258 -- described in "Handling of Default and Per-Object 13259 -- Expressions" in sem.ads. 13260 13261 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); 13262 13263 -- Check duplicate pragma before we chain the pragma in the Rep 13264 -- Item chain of Ent. 13265 13266 Check_Duplicate_Pragma (Ent); 13267 Record_Rep_Item (Ent, N); 13268 13269 -- Anything else is incorrect 13270 13271 else 13272 Pragma_Misplaced; 13273 end if; 13274 end Dispatching_Domain; 13275 13276 --------------- 13277 -- Elaborate -- 13278 --------------- 13279 13280 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); 13281 13282 when Pragma_Elaborate => Elaborate : declare 13283 Arg : Node_Id; 13284 Citem : Node_Id; 13285 13286 begin 13287 -- Pragma must be in context items list of a compilation unit 13288 13289 if not Is_In_Context_Clause then 13290 Pragma_Misplaced; 13291 end if; 13292 13293 -- Must be at least one argument 13294 13295 if Arg_Count = 0 then 13296 Error_Pragma ("pragma% requires at least one argument"); 13297 end if; 13298 13299 -- In Ada 83 mode, there can be no items following it in the 13300 -- context list except other pragmas and implicit with clauses 13301 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this 13302 -- placement rule does not apply. 13303 13304 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 13305 Citem := Next (N); 13306 while Present (Citem) loop 13307 if Nkind (Citem) = N_Pragma 13308 or else (Nkind (Citem) = N_With_Clause 13309 and then Implicit_With (Citem)) 13310 then 13311 null; 13312 else 13313 Error_Pragma 13314 ("(Ada 83) pragma% must be at end of context clause"); 13315 end if; 13316 13317 Next (Citem); 13318 end loop; 13319 end if; 13320 13321 -- Finally, the arguments must all be units mentioned in a with 13322 -- clause in the same context clause. Note we already checked (in 13323 -- Par.Prag) that the arguments are all identifiers or selected 13324 -- components. 13325 13326 Arg := Arg1; 13327 Outer : while Present (Arg) loop 13328 Citem := First (List_Containing (N)); 13329 Inner : while Citem /= N loop 13330 if Nkind (Citem) = N_With_Clause 13331 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 13332 then 13333 Set_Elaborate_Present (Citem, True); 13334 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 13335 Generate_Reference (Entity (Name (Citem)), Citem); 13336 13337 -- With the pragma present, elaboration calls on 13338 -- subprograms from the named unit need no further 13339 -- checks, as long as the pragma appears in the current 13340 -- compilation unit. If the pragma appears in some unit 13341 -- in the context, there might still be a need for an 13342 -- Elaborate_All_Desirable from the current compilation 13343 -- to the named unit, so we keep the check enabled. 13344 13345 if In_Extended_Main_Source_Unit (N) then 13346 Set_Suppress_Elaboration_Warnings 13347 (Entity (Name (Citem))); 13348 end if; 13349 13350 exit Inner; 13351 end if; 13352 13353 Next (Citem); 13354 end loop Inner; 13355 13356 if Citem = N then 13357 Error_Pragma_Arg 13358 ("argument of pragma% is not withed unit", Arg); 13359 end if; 13360 13361 Next (Arg); 13362 end loop Outer; 13363 13364 -- Give a warning if operating in static mode with one of the 13365 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set. 13366 13367 if Elab_Warnings and not Dynamic_Elaboration_Checks then 13368 Error_Msg_N 13369 ("?l?use of pragma Elaborate may not be safe", N); 13370 Error_Msg_N 13371 ("?l?use pragma Elaborate_All instead if possible", N); 13372 end if; 13373 end Elaborate; 13374 13375 ------------------- 13376 -- Elaborate_All -- 13377 ------------------- 13378 13379 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); 13380 13381 when Pragma_Elaborate_All => Elaborate_All : declare 13382 Arg : Node_Id; 13383 Citem : Node_Id; 13384 13385 begin 13386 Check_Ada_83_Warning; 13387 13388 -- Pragma must be in context items list of a compilation unit 13389 13390 if not Is_In_Context_Clause then 13391 Pragma_Misplaced; 13392 end if; 13393 13394 -- Must be at least one argument 13395 13396 if Arg_Count = 0 then 13397 Error_Pragma ("pragma% requires at least one argument"); 13398 end if; 13399 13400 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not 13401 -- have to appear at the end of the context clause, but may 13402 -- appear mixed in with other items, even in Ada 83 mode. 13403 13404 -- Final check: the arguments must all be units mentioned in 13405 -- a with clause in the same context clause. Note that we 13406 -- already checked (in Par.Prag) that all the arguments are 13407 -- either identifiers or selected components. 13408 13409 Arg := Arg1; 13410 Outr : while Present (Arg) loop 13411 Citem := First (List_Containing (N)); 13412 Innr : while Citem /= N loop 13413 if Nkind (Citem) = N_With_Clause 13414 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 13415 then 13416 Set_Elaborate_All_Present (Citem, True); 13417 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 13418 13419 -- Suppress warnings and elaboration checks on the named 13420 -- unit if the pragma is in the current compilation, as 13421 -- for pragma Elaborate. 13422 13423 if In_Extended_Main_Source_Unit (N) then 13424 Set_Suppress_Elaboration_Warnings 13425 (Entity (Name (Citem))); 13426 end if; 13427 exit Innr; 13428 end if; 13429 13430 Next (Citem); 13431 end loop Innr; 13432 13433 if Citem = N then 13434 Set_Error_Posted (N); 13435 Error_Pragma_Arg 13436 ("argument of pragma% is not withed unit", Arg); 13437 end if; 13438 13439 Next (Arg); 13440 end loop Outr; 13441 end Elaborate_All; 13442 13443 -------------------- 13444 -- Elaborate_Body -- 13445 -------------------- 13446 13447 -- pragma Elaborate_Body [( library_unit_NAME )]; 13448 13449 when Pragma_Elaborate_Body => Elaborate_Body : declare 13450 Cunit_Node : Node_Id; 13451 Cunit_Ent : Entity_Id; 13452 13453 begin 13454 Check_Ada_83_Warning; 13455 Check_Valid_Library_Unit_Pragma; 13456 13457 if Nkind (N) = N_Null_Statement then 13458 return; 13459 end if; 13460 13461 Cunit_Node := Cunit (Current_Sem_Unit); 13462 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 13463 13464 if Nkind_In (Unit (Cunit_Node), N_Package_Body, 13465 N_Subprogram_Body) 13466 then 13467 Error_Pragma ("pragma% must refer to a spec, not a body"); 13468 else 13469 Set_Body_Required (Cunit_Node, True); 13470 Set_Has_Pragma_Elaborate_Body (Cunit_Ent); 13471 13472 -- If we are in dynamic elaboration mode, then we suppress 13473 -- elaboration warnings for the unit, since it is definitely 13474 -- fine NOT to do dynamic checks at the first level (and such 13475 -- checks will be suppressed because no elaboration boolean 13476 -- is created for Elaborate_Body packages). 13477 13478 -- But in the static model of elaboration, Elaborate_Body is 13479 -- definitely NOT good enough to ensure elaboration safety on 13480 -- its own, since the body may WITH other units that are not 13481 -- safe from an elaboration point of view, so a client must 13482 -- still do an Elaborate_All on such units. 13483 13484 -- Debug flag -gnatdD restores the old behavior of 3.13, where 13485 -- Elaborate_Body always suppressed elab warnings. 13486 13487 if Dynamic_Elaboration_Checks or Debug_Flag_DD then 13488 Set_Suppress_Elaboration_Warnings (Cunit_Ent); 13489 end if; 13490 end if; 13491 end Elaborate_Body; 13492 13493 ------------------------ 13494 -- Elaboration_Checks -- 13495 ------------------------ 13496 13497 -- pragma Elaboration_Checks (Static | Dynamic); 13498 13499 when Pragma_Elaboration_Checks => 13500 GNAT_Pragma; 13501 Check_Arg_Count (1); 13502 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); 13503 Dynamic_Elaboration_Checks := 13504 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic); 13505 13506 --------------- 13507 -- Eliminate -- 13508 --------------- 13509 13510 -- pragma Eliminate ( 13511 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, 13512 -- [,[Entity =>] IDENTIFIER | 13513 -- SELECTED_COMPONENT | 13514 -- STRING_LITERAL] 13515 -- [, OVERLOADING_RESOLUTION]); 13516 13517 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE | 13518 -- SOURCE_LOCATION 13519 13520 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE | 13521 -- FUNCTION_PROFILE 13522 13523 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES 13524 13525 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,] 13526 -- Result_Type => result_SUBTYPE_NAME] 13527 13528 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) 13529 -- SUBTYPE_NAME ::= STRING_LITERAL 13530 13531 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE 13532 -- SOURCE_TRACE ::= STRING_LITERAL 13533 13534 when Pragma_Eliminate => Eliminate : declare 13535 Args : Args_List (1 .. 5); 13536 Names : constant Name_List (1 .. 5) := ( 13537 Name_Unit_Name, 13538 Name_Entity, 13539 Name_Parameter_Types, 13540 Name_Result_Type, 13541 Name_Source_Location); 13542 13543 Unit_Name : Node_Id renames Args (1); 13544 Entity : Node_Id renames Args (2); 13545 Parameter_Types : Node_Id renames Args (3); 13546 Result_Type : Node_Id renames Args (4); 13547 Source_Location : Node_Id renames Args (5); 13548 13549 begin 13550 GNAT_Pragma; 13551 Check_Valid_Configuration_Pragma; 13552 Gather_Associations (Names, Args); 13553 13554 if No (Unit_Name) then 13555 Error_Pragma ("missing Unit_Name argument for pragma%"); 13556 end if; 13557 13558 if No (Entity) 13559 and then (Present (Parameter_Types) 13560 or else 13561 Present (Result_Type) 13562 or else 13563 Present (Source_Location)) 13564 then 13565 Error_Pragma ("missing Entity argument for pragma%"); 13566 end if; 13567 13568 if (Present (Parameter_Types) 13569 or else 13570 Present (Result_Type)) 13571 and then 13572 Present (Source_Location) 13573 then 13574 Error_Pragma 13575 ("parameter profile and source location cannot be used " 13576 & "together in pragma%"); 13577 end if; 13578 13579 Process_Eliminate_Pragma 13580 (N, 13581 Unit_Name, 13582 Entity, 13583 Parameter_Types, 13584 Result_Type, 13585 Source_Location); 13586 end Eliminate; 13587 13588 ----------------------------------- 13589 -- Enable_Atomic_Synchronization -- 13590 ----------------------------------- 13591 13592 -- pragma Enable_Atomic_Synchronization [(Entity)]; 13593 13594 when Pragma_Enable_Atomic_Synchronization => 13595 GNAT_Pragma; 13596 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress); 13597 13598 ------------ 13599 -- Export -- 13600 ------------ 13601 13602 -- pragma Export ( 13603 -- [ Convention =>] convention_IDENTIFIER, 13604 -- [ Entity =>] local_NAME 13605 -- [, [External_Name =>] static_string_EXPRESSION ] 13606 -- [, [Link_Name =>] static_string_EXPRESSION ]); 13607 13608 when Pragma_Export => Export : declare 13609 C : Convention_Id; 13610 Def_Id : Entity_Id; 13611 13612 pragma Warnings (Off, C); 13613 13614 begin 13615 Check_Ada_83_Warning; 13616 Check_Arg_Order 13617 ((Name_Convention, 13618 Name_Entity, 13619 Name_External_Name, 13620 Name_Link_Name)); 13621 13622 Check_At_Least_N_Arguments (2); 13623 Check_At_Most_N_Arguments (4); 13624 13625 -- In Relaxed_RM_Semantics, support old Ada 83 style: 13626 -- pragma Export (Entity, "external name"); 13627 13628 if Relaxed_RM_Semantics 13629 and then Arg_Count = 2 13630 and then Nkind (Expression (Arg2)) = N_String_Literal 13631 then 13632 C := Convention_C; 13633 Def_Id := Get_Pragma_Arg (Arg1); 13634 Analyze (Def_Id); 13635 13636 if not Is_Entity_Name (Def_Id) then 13637 Error_Pragma_Arg ("entity name required", Arg1); 13638 end if; 13639 13640 Def_Id := Entity (Def_Id); 13641 Set_Exported (Def_Id, Arg1); 13642 13643 else 13644 Process_Convention (C, Def_Id); 13645 13646 if Ekind (Def_Id) /= E_Constant then 13647 Note_Possible_Modification 13648 (Get_Pragma_Arg (Arg2), Sure => False); 13649 end if; 13650 13651 Process_Interface_Name (Def_Id, Arg3, Arg4); 13652 Set_Exported (Def_Id, Arg2); 13653 end if; 13654 13655 -- If the entity is a deferred constant, propagate the information 13656 -- to the full view, because gigi elaborates the full view only. 13657 13658 if Ekind (Def_Id) = E_Constant 13659 and then Present (Full_View (Def_Id)) 13660 then 13661 declare 13662 Id2 : constant Entity_Id := Full_View (Def_Id); 13663 begin 13664 Set_Is_Exported (Id2, Is_Exported (Def_Id)); 13665 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); 13666 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); 13667 end; 13668 end if; 13669 end Export; 13670 13671 ---------------------- 13672 -- Export_Exception -- 13673 ---------------------- 13674 13675 -- pragma Export_Exception ( 13676 -- [Internal =>] LOCAL_NAME 13677 -- [, [External =>] EXTERNAL_SYMBOL] 13678 -- [, [Form =>] Ada | VMS] 13679 -- [, [Code =>] static_integer_EXPRESSION]); 13680 13681 when Pragma_Export_Exception => Export_Exception : declare 13682 Args : Args_List (1 .. 4); 13683 Names : constant Name_List (1 .. 4) := ( 13684 Name_Internal, 13685 Name_External, 13686 Name_Form, 13687 Name_Code); 13688 13689 Internal : Node_Id renames Args (1); 13690 External : Node_Id renames Args (2); 13691 Form : Node_Id renames Args (3); 13692 Code : Node_Id renames Args (4); 13693 13694 begin 13695 GNAT_Pragma; 13696 13697 if Inside_A_Generic then 13698 Error_Pragma ("pragma% cannot be used for generic entities"); 13699 end if; 13700 13701 Gather_Associations (Names, Args); 13702 Process_Extended_Import_Export_Exception_Pragma ( 13703 Arg_Internal => Internal, 13704 Arg_External => External, 13705 Arg_Form => Form, 13706 Arg_Code => Code); 13707 13708 if not Is_VMS_Exception (Entity (Internal)) then 13709 Set_Exported (Entity (Internal), Internal); 13710 end if; 13711 end Export_Exception; 13712 13713 --------------------- 13714 -- Export_Function -- 13715 --------------------- 13716 13717 -- pragma Export_Function ( 13718 -- [Internal =>] LOCAL_NAME 13719 -- [, [External =>] EXTERNAL_SYMBOL] 13720 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 13721 -- [, [Result_Type =>] TYPE_DESIGNATOR] 13722 -- [, [Mechanism =>] MECHANISM] 13723 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 13724 13725 -- EXTERNAL_SYMBOL ::= 13726 -- IDENTIFIER 13727 -- | static_string_EXPRESSION 13728 13729 -- PARAMETER_TYPES ::= 13730 -- null 13731 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 13732 13733 -- TYPE_DESIGNATOR ::= 13734 -- subtype_NAME 13735 -- | subtype_Name ' Access 13736 13737 -- MECHANISM ::= 13738 -- MECHANISM_NAME 13739 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 13740 13741 -- MECHANISM_ASSOCIATION ::= 13742 -- [formal_parameter_NAME =>] MECHANISM_NAME 13743 13744 -- MECHANISM_NAME ::= 13745 -- Value 13746 -- | Reference 13747 -- | Descriptor [([Class =>] CLASS_NAME)] 13748 13749 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 13750 13751 when Pragma_Export_Function => Export_Function : declare 13752 Args : Args_List (1 .. 6); 13753 Names : constant Name_List (1 .. 6) := ( 13754 Name_Internal, 13755 Name_External, 13756 Name_Parameter_Types, 13757 Name_Result_Type, 13758 Name_Mechanism, 13759 Name_Result_Mechanism); 13760 13761 Internal : Node_Id renames Args (1); 13762 External : Node_Id renames Args (2); 13763 Parameter_Types : Node_Id renames Args (3); 13764 Result_Type : Node_Id renames Args (4); 13765 Mechanism : Node_Id renames Args (5); 13766 Result_Mechanism : Node_Id renames Args (6); 13767 13768 begin 13769 GNAT_Pragma; 13770 Gather_Associations (Names, Args); 13771 Process_Extended_Import_Export_Subprogram_Pragma ( 13772 Arg_Internal => Internal, 13773 Arg_External => External, 13774 Arg_Parameter_Types => Parameter_Types, 13775 Arg_Result_Type => Result_Type, 13776 Arg_Mechanism => Mechanism, 13777 Arg_Result_Mechanism => Result_Mechanism); 13778 end Export_Function; 13779 13780 ------------------- 13781 -- Export_Object -- 13782 ------------------- 13783 13784 -- pragma Export_Object ( 13785 -- [Internal =>] LOCAL_NAME 13786 -- [, [External =>] EXTERNAL_SYMBOL] 13787 -- [, [Size =>] EXTERNAL_SYMBOL]); 13788 13789 -- EXTERNAL_SYMBOL ::= 13790 -- IDENTIFIER 13791 -- | static_string_EXPRESSION 13792 13793 -- PARAMETER_TYPES ::= 13794 -- null 13795 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 13796 13797 -- TYPE_DESIGNATOR ::= 13798 -- subtype_NAME 13799 -- | subtype_Name ' Access 13800 13801 -- MECHANISM ::= 13802 -- MECHANISM_NAME 13803 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 13804 13805 -- MECHANISM_ASSOCIATION ::= 13806 -- [formal_parameter_NAME =>] MECHANISM_NAME 13807 13808 -- MECHANISM_NAME ::= 13809 -- Value 13810 -- | Reference 13811 -- | Descriptor [([Class =>] CLASS_NAME)] 13812 13813 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 13814 13815 when Pragma_Export_Object => Export_Object : declare 13816 Args : Args_List (1 .. 3); 13817 Names : constant Name_List (1 .. 3) := ( 13818 Name_Internal, 13819 Name_External, 13820 Name_Size); 13821 13822 Internal : Node_Id renames Args (1); 13823 External : Node_Id renames Args (2); 13824 Size : Node_Id renames Args (3); 13825 13826 begin 13827 GNAT_Pragma; 13828 Gather_Associations (Names, Args); 13829 Process_Extended_Import_Export_Object_Pragma ( 13830 Arg_Internal => Internal, 13831 Arg_External => External, 13832 Arg_Size => Size); 13833 end Export_Object; 13834 13835 ---------------------- 13836 -- Export_Procedure -- 13837 ---------------------- 13838 13839 -- pragma Export_Procedure ( 13840 -- [Internal =>] LOCAL_NAME 13841 -- [, [External =>] EXTERNAL_SYMBOL] 13842 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 13843 -- [, [Mechanism =>] MECHANISM]); 13844 13845 -- EXTERNAL_SYMBOL ::= 13846 -- IDENTIFIER 13847 -- | static_string_EXPRESSION 13848 13849 -- PARAMETER_TYPES ::= 13850 -- null 13851 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 13852 13853 -- TYPE_DESIGNATOR ::= 13854 -- subtype_NAME 13855 -- | subtype_Name ' Access 13856 13857 -- MECHANISM ::= 13858 -- MECHANISM_NAME 13859 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 13860 13861 -- MECHANISM_ASSOCIATION ::= 13862 -- [formal_parameter_NAME =>] MECHANISM_NAME 13863 13864 -- MECHANISM_NAME ::= 13865 -- Value 13866 -- | Reference 13867 -- | Descriptor [([Class =>] CLASS_NAME)] 13868 13869 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 13870 13871 when Pragma_Export_Procedure => Export_Procedure : declare 13872 Args : Args_List (1 .. 4); 13873 Names : constant Name_List (1 .. 4) := ( 13874 Name_Internal, 13875 Name_External, 13876 Name_Parameter_Types, 13877 Name_Mechanism); 13878 13879 Internal : Node_Id renames Args (1); 13880 External : Node_Id renames Args (2); 13881 Parameter_Types : Node_Id renames Args (3); 13882 Mechanism : Node_Id renames Args (4); 13883 13884 begin 13885 GNAT_Pragma; 13886 Gather_Associations (Names, Args); 13887 Process_Extended_Import_Export_Subprogram_Pragma ( 13888 Arg_Internal => Internal, 13889 Arg_External => External, 13890 Arg_Parameter_Types => Parameter_Types, 13891 Arg_Mechanism => Mechanism); 13892 end Export_Procedure; 13893 13894 ------------------ 13895 -- Export_Value -- 13896 ------------------ 13897 13898 -- pragma Export_Value ( 13899 -- [Value =>] static_integer_EXPRESSION, 13900 -- [Link_Name =>] static_string_EXPRESSION); 13901 13902 when Pragma_Export_Value => 13903 GNAT_Pragma; 13904 Check_Arg_Order ((Name_Value, Name_Link_Name)); 13905 Check_Arg_Count (2); 13906 13907 Check_Optional_Identifier (Arg1, Name_Value); 13908 Check_Arg_Is_Static_Expression (Arg1, Any_Integer); 13909 13910 Check_Optional_Identifier (Arg2, Name_Link_Name); 13911 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 13912 13913 ----------------------------- 13914 -- Export_Valued_Procedure -- 13915 ----------------------------- 13916 13917 -- pragma Export_Valued_Procedure ( 13918 -- [Internal =>] LOCAL_NAME 13919 -- [, [External =>] EXTERNAL_SYMBOL,] 13920 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 13921 -- [, [Mechanism =>] MECHANISM]); 13922 13923 -- EXTERNAL_SYMBOL ::= 13924 -- IDENTIFIER 13925 -- | static_string_EXPRESSION 13926 13927 -- PARAMETER_TYPES ::= 13928 -- null 13929 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 13930 13931 -- TYPE_DESIGNATOR ::= 13932 -- subtype_NAME 13933 -- | subtype_Name ' Access 13934 13935 -- MECHANISM ::= 13936 -- MECHANISM_NAME 13937 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 13938 13939 -- MECHANISM_ASSOCIATION ::= 13940 -- [formal_parameter_NAME =>] MECHANISM_NAME 13941 13942 -- MECHANISM_NAME ::= 13943 -- Value 13944 -- | Reference 13945 -- | Descriptor [([Class =>] CLASS_NAME)] 13946 13947 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 13948 13949 when Pragma_Export_Valued_Procedure => 13950 Export_Valued_Procedure : declare 13951 Args : Args_List (1 .. 4); 13952 Names : constant Name_List (1 .. 4) := ( 13953 Name_Internal, 13954 Name_External, 13955 Name_Parameter_Types, 13956 Name_Mechanism); 13957 13958 Internal : Node_Id renames Args (1); 13959 External : Node_Id renames Args (2); 13960 Parameter_Types : Node_Id renames Args (3); 13961 Mechanism : Node_Id renames Args (4); 13962 13963 begin 13964 GNAT_Pragma; 13965 Gather_Associations (Names, Args); 13966 Process_Extended_Import_Export_Subprogram_Pragma ( 13967 Arg_Internal => Internal, 13968 Arg_External => External, 13969 Arg_Parameter_Types => Parameter_Types, 13970 Arg_Mechanism => Mechanism); 13971 end Export_Valued_Procedure; 13972 13973 ------------------- 13974 -- Extend_System -- 13975 ------------------- 13976 13977 -- pragma Extend_System ([Name =>] Identifier); 13978 13979 when Pragma_Extend_System => Extend_System : declare 13980 begin 13981 GNAT_Pragma; 13982 Check_Valid_Configuration_Pragma; 13983 Check_Arg_Count (1); 13984 Check_Optional_Identifier (Arg1, Name_Name); 13985 Check_Arg_Is_Identifier (Arg1); 13986 13987 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 13988 13989 if Name_Len > 4 13990 and then Name_Buffer (1 .. 4) = "aux_" 13991 then 13992 if Present (System_Extend_Pragma_Arg) then 13993 if Chars (Get_Pragma_Arg (Arg1)) = 13994 Chars (Expression (System_Extend_Pragma_Arg)) 13995 then 13996 null; 13997 else 13998 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg); 13999 Error_Pragma ("pragma% conflicts with that #"); 14000 end if; 14001 14002 else 14003 System_Extend_Pragma_Arg := Arg1; 14004 14005 if not GNAT_Mode then 14006 System_Extend_Unit := Arg1; 14007 end if; 14008 end if; 14009 else 14010 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); 14011 end if; 14012 end Extend_System; 14013 14014 ------------------------ 14015 -- Extensions_Allowed -- 14016 ------------------------ 14017 14018 -- pragma Extensions_Allowed (ON | OFF); 14019 14020 when Pragma_Extensions_Allowed => 14021 GNAT_Pragma; 14022 Check_Arg_Count (1); 14023 Check_No_Identifiers; 14024 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 14025 14026 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 14027 Extensions_Allowed := True; 14028 Ada_Version := Ada_Version_Type'Last; 14029 14030 else 14031 Extensions_Allowed := False; 14032 Ada_Version := Ada_Version_Explicit; 14033 Ada_Version_Pragma := Empty; 14034 end if; 14035 14036 -------------- 14037 -- External -- 14038 -------------- 14039 14040 -- pragma External ( 14041 -- [ Convention =>] convention_IDENTIFIER, 14042 -- [ Entity =>] local_NAME 14043 -- [, [External_Name =>] static_string_EXPRESSION ] 14044 -- [, [Link_Name =>] static_string_EXPRESSION ]); 14045 14046 when Pragma_External => External : declare 14047 Def_Id : Entity_Id; 14048 14049 C : Convention_Id; 14050 pragma Warnings (Off, C); 14051 14052 begin 14053 GNAT_Pragma; 14054 Check_Arg_Order 14055 ((Name_Convention, 14056 Name_Entity, 14057 Name_External_Name, 14058 Name_Link_Name)); 14059 Check_At_Least_N_Arguments (2); 14060 Check_At_Most_N_Arguments (4); 14061 Process_Convention (C, Def_Id); 14062 Note_Possible_Modification 14063 (Get_Pragma_Arg (Arg2), Sure => False); 14064 Process_Interface_Name (Def_Id, Arg3, Arg4); 14065 Set_Exported (Def_Id, Arg2); 14066 end External; 14067 14068 -------------------------- 14069 -- External_Name_Casing -- 14070 -------------------------- 14071 14072 -- pragma External_Name_Casing ( 14073 -- UPPERCASE | LOWERCASE 14074 -- [, AS_IS | UPPERCASE | LOWERCASE]); 14075 14076 when Pragma_External_Name_Casing => External_Name_Casing : declare 14077 begin 14078 GNAT_Pragma; 14079 Check_No_Identifiers; 14080 14081 if Arg_Count = 2 then 14082 Check_Arg_Is_One_Of 14083 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase); 14084 14085 case Chars (Get_Pragma_Arg (Arg2)) is 14086 when Name_As_Is => 14087 Opt.External_Name_Exp_Casing := As_Is; 14088 14089 when Name_Uppercase => 14090 Opt.External_Name_Exp_Casing := Uppercase; 14091 14092 when Name_Lowercase => 14093 Opt.External_Name_Exp_Casing := Lowercase; 14094 14095 when others => 14096 null; 14097 end case; 14098 14099 else 14100 Check_Arg_Count (1); 14101 end if; 14102 14103 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase); 14104 14105 case Chars (Get_Pragma_Arg (Arg1)) is 14106 when Name_Uppercase => 14107 Opt.External_Name_Imp_Casing := Uppercase; 14108 14109 when Name_Lowercase => 14110 Opt.External_Name_Imp_Casing := Lowercase; 14111 14112 when others => 14113 null; 14114 end case; 14115 end External_Name_Casing; 14116 14117 --------------- 14118 -- Fast_Math -- 14119 --------------- 14120 14121 -- pragma Fast_Math; 14122 14123 when Pragma_Fast_Math => 14124 GNAT_Pragma; 14125 Check_No_Identifiers; 14126 Check_Valid_Configuration_Pragma; 14127 Fast_Math := True; 14128 14129 -------------------------- 14130 -- Favor_Top_Level -- 14131 -------------------------- 14132 14133 -- pragma Favor_Top_Level (type_NAME); 14134 14135 when Pragma_Favor_Top_Level => Favor_Top_Level : declare 14136 Named_Entity : Entity_Id; 14137 14138 begin 14139 GNAT_Pragma; 14140 Check_No_Identifiers; 14141 Check_Arg_Count (1); 14142 Check_Arg_Is_Local_Name (Arg1); 14143 Named_Entity := Entity (Get_Pragma_Arg (Arg1)); 14144 14145 -- If it's an access-to-subprogram type (in particular, not a 14146 -- subtype), set the flag on that type. 14147 14148 if Is_Access_Subprogram_Type (Named_Entity) then 14149 Set_Can_Use_Internal_Rep (Named_Entity, False); 14150 14151 -- Otherwise it's an error (name denotes the wrong sort of entity) 14152 14153 else 14154 Error_Pragma_Arg 14155 ("access-to-subprogram type expected", 14156 Get_Pragma_Arg (Arg1)); 14157 end if; 14158 end Favor_Top_Level; 14159 14160 --------------------------- 14161 -- Finalize_Storage_Only -- 14162 --------------------------- 14163 14164 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); 14165 14166 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare 14167 Assoc : constant Node_Id := Arg1; 14168 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 14169 Typ : Entity_Id; 14170 14171 begin 14172 GNAT_Pragma; 14173 Check_No_Identifiers; 14174 Check_Arg_Count (1); 14175 Check_Arg_Is_Local_Name (Arg1); 14176 14177 Find_Type (Type_Id); 14178 Typ := Entity (Type_Id); 14179 14180 if Typ = Any_Type 14181 or else Rep_Item_Too_Early (Typ, N) 14182 then 14183 return; 14184 else 14185 Typ := Underlying_Type (Typ); 14186 end if; 14187 14188 if not Is_Controlled (Typ) then 14189 Error_Pragma ("pragma% must specify controlled type"); 14190 end if; 14191 14192 Check_First_Subtype (Arg1); 14193 14194 if Finalize_Storage_Only (Typ) then 14195 Error_Pragma ("duplicate pragma%, only one allowed"); 14196 14197 elsif not Rep_Item_Too_Late (Typ, N) then 14198 Set_Finalize_Storage_Only (Base_Type (Typ), True); 14199 end if; 14200 end Finalize_Storage; 14201 14202 -------------------------- 14203 -- Float_Representation -- 14204 -------------------------- 14205 14206 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]); 14207 14208 -- FLOAT_REP ::= VAX_Float | IEEE_Float 14209 14210 when Pragma_Float_Representation => Float_Representation : declare 14211 Argx : Node_Id; 14212 Digs : Nat; 14213 Ent : Entity_Id; 14214 14215 begin 14216 GNAT_Pragma; 14217 14218 if Arg_Count = 1 then 14219 Check_Valid_Configuration_Pragma; 14220 else 14221 Check_Arg_Count (2); 14222 Check_Optional_Identifier (Arg2, Name_Entity); 14223 Check_Arg_Is_Local_Name (Arg2); 14224 end if; 14225 14226 Check_No_Identifier (Arg1); 14227 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); 14228 14229 if not OpenVMS_On_Target then 14230 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then 14231 Error_Pragma 14232 ("??pragma% ignored (applies only to Open'V'M'S)"); 14233 end if; 14234 14235 return; 14236 end if; 14237 14238 -- One argument case 14239 14240 if Arg_Count = 1 then 14241 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then 14242 if Opt.Float_Format = 'I' then 14243 Error_Pragma ("'I'E'E'E format previously specified"); 14244 end if; 14245 14246 Opt.Float_Format := 'V'; 14247 14248 else 14249 if Opt.Float_Format = 'V' then 14250 Error_Pragma ("'V'A'X format previously specified"); 14251 end if; 14252 14253 Opt.Float_Format := 'I'; 14254 end if; 14255 14256 Set_Standard_Fpt_Formats; 14257 14258 -- Two argument case 14259 14260 else 14261 Argx := Get_Pragma_Arg (Arg2); 14262 14263 if not Is_Entity_Name (Argx) 14264 or else not Is_Floating_Point_Type (Entity (Argx)) 14265 then 14266 Error_Pragma_Arg 14267 ("second argument of% pragma must be floating-point type", 14268 Arg2); 14269 end if; 14270 14271 Ent := Entity (Argx); 14272 Digs := UI_To_Int (Digits_Value (Ent)); 14273 14274 -- Two arguments, VAX_Float case 14275 14276 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then 14277 case Digs is 14278 when 6 => Set_F_Float (Ent); 14279 when 9 => Set_D_Float (Ent); 14280 when 15 => Set_G_Float (Ent); 14281 14282 when others => 14283 Error_Pragma_Arg 14284 ("wrong digits value, must be 6,9 or 15", Arg2); 14285 end case; 14286 14287 -- Two arguments, IEEE_Float case 14288 14289 else 14290 case Digs is 14291 when 6 => Set_IEEE_Short (Ent); 14292 when 15 => Set_IEEE_Long (Ent); 14293 14294 when others => 14295 Error_Pragma_Arg 14296 ("wrong digits value, must be 6 or 15", Arg2); 14297 end case; 14298 end if; 14299 end if; 14300 end Float_Representation; 14301 14302 ------------ 14303 -- Global -- 14304 ------------ 14305 14306 -- pragma Global (GLOBAL_SPECIFICATION); 14307 14308 -- GLOBAL_SPECIFICATION ::= 14309 -- null 14310 -- | GLOBAL_LIST 14311 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST} 14312 14313 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 14314 14315 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 14316 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 14317 -- GLOBAL_ITEM ::= NAME 14318 14319 when Pragma_Global => Global : declare 14320 Subp_Decl : Node_Id; 14321 14322 begin 14323 GNAT_Pragma; 14324 Check_Arg_Count (1); 14325 Ensure_Aggregate_Form (Arg1); 14326 14327 -- Ensure the proper placement of the pragma. Global must be 14328 -- associated with a subprogram declaration or a body that acts 14329 -- as a spec. 14330 14331 Subp_Decl := 14332 Find_Related_Subprogram_Or_Body (N, Do_Checks => True); 14333 14334 if Nkind (Subp_Decl) = N_Subprogram_Declaration then 14335 null; 14336 14337 -- Body acts as spec 14338 14339 elsif Nkind (Subp_Decl) = N_Subprogram_Body 14340 and then No (Corresponding_Spec (Subp_Decl)) 14341 then 14342 null; 14343 14344 -- Body stub acts as spec 14345 14346 elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub 14347 and then No (Corresponding_Spec_Of_Stub (Subp_Decl)) 14348 then 14349 null; 14350 14351 else 14352 Pragma_Misplaced; 14353 return; 14354 end if; 14355 14356 -- When the pragma appears on a subprogram body, perform the full 14357 -- analysis now. 14358 14359 if Nkind (Subp_Decl) = N_Subprogram_Body then 14360 Analyze_Global_In_Decl_Part (N); 14361 14362 -- When Global applies to a subprogram compilation unit, the 14363 -- corresponding pragma is placed after the unit's declaration 14364 -- node and needs to be analyzed immediately. 14365 14366 elsif Nkind (Subp_Decl) = N_Subprogram_Declaration 14367 and then Nkind (Parent (Subp_Decl)) = N_Compilation_Unit 14368 then 14369 Analyze_Global_In_Decl_Part (N); 14370 end if; 14371 14372 -- Chain the pragma on the contract for further processing 14373 14374 Add_Contract_Item (N, Defining_Entity (Subp_Decl)); 14375 end Global; 14376 14377 ----------- 14378 -- Ident -- 14379 ----------- 14380 14381 -- pragma Ident (static_string_EXPRESSION) 14382 14383 -- Note: pragma Comment shares this processing. Pragma Comment is 14384 -- identical to Ident, except that the restriction of the argument to 14385 -- 31 characters and the placement restrictions are not enforced for 14386 -- pragma Comment. 14387 14388 when Pragma_Ident | Pragma_Comment => Ident : declare 14389 Str : Node_Id; 14390 14391 begin 14392 GNAT_Pragma; 14393 Check_Arg_Count (1); 14394 Check_No_Identifiers; 14395 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 14396 Store_Note (N); 14397 14398 -- For pragma Ident, preserve DEC compatibility by requiring the 14399 -- pragma to appear in a declarative part or package spec. 14400 14401 if Prag_Id = Pragma_Ident then 14402 Check_Is_In_Decl_Part_Or_Package_Spec; 14403 end if; 14404 14405 Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); 14406 14407 declare 14408 CS : Node_Id; 14409 GP : Node_Id; 14410 14411 begin 14412 GP := Parent (Parent (N)); 14413 14414 if Nkind_In (GP, N_Package_Declaration, 14415 N_Generic_Package_Declaration) 14416 then 14417 GP := Parent (GP); 14418 end if; 14419 14420 -- If we have a compilation unit, then record the ident value, 14421 -- checking for improper duplication. 14422 14423 if Nkind (GP) = N_Compilation_Unit then 14424 CS := Ident_String (Current_Sem_Unit); 14425 14426 if Present (CS) then 14427 14428 -- For Ident, we do not permit multiple instances 14429 14430 if Prag_Id = Pragma_Ident then 14431 Error_Pragma ("duplicate% pragma not permitted"); 14432 14433 -- For Comment, we concatenate the string, unless we want 14434 -- to preserve the tree structure for ASIS. 14435 14436 elsif not ASIS_Mode then 14437 Start_String (Strval (CS)); 14438 Store_String_Char (' '); 14439 Store_String_Chars (Strval (Str)); 14440 Set_Strval (CS, End_String); 14441 end if; 14442 14443 else 14444 -- In VMS, the effect of IDENT is achieved by passing 14445 -- --identification=name as a --for-linker switch. 14446 14447 if OpenVMS_On_Target then 14448 Start_String; 14449 Store_String_Chars 14450 ("--for-linker=--identification="); 14451 String_To_Name_Buffer (Strval (Str)); 14452 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 14453 14454 -- Only the last processed IDENT is saved. The main 14455 -- purpose is so an IDENT associated with a main 14456 -- procedure will be used in preference to an IDENT 14457 -- associated with a with'd package. 14458 14459 Replace_Linker_Option_String 14460 (End_String, "--for-linker=--identification="); 14461 end if; 14462 14463 Set_Ident_String (Current_Sem_Unit, Str); 14464 end if; 14465 14466 -- For subunits, we just ignore the Ident, since in GNAT these 14467 -- are not separate object files, and hence not separate units 14468 -- in the unit table. 14469 14470 elsif Nkind (GP) = N_Subunit then 14471 null; 14472 14473 -- Otherwise we have a misplaced pragma Ident, but we ignore 14474 -- this if we are in an instantiation, since it comes from 14475 -- a generic, and has no relevance to the instantiation. 14476 14477 elsif Prag_Id = Pragma_Ident then 14478 if Instantiation_Location (Loc) = No_Location then 14479 Error_Pragma ("pragma% only allowed at outer level"); 14480 end if; 14481 end if; 14482 end; 14483 end Ident; 14484 14485 ---------------------------- 14486 -- Implementation_Defined -- 14487 ---------------------------- 14488 14489 -- pragma Implementation_Defined (local_NAME); 14490 14491 -- Marks previously declared entity as implementation defined. For 14492 -- an overloaded entity, applies to the most recent homonym. 14493 14494 -- pragma Implementation_Defined; 14495 14496 -- The form with no arguments appears anywhere within a scope, most 14497 -- typically a package spec, and indicates that all entities that are 14498 -- defined within the package spec are Implementation_Defined. 14499 14500 when Pragma_Implementation_Defined => Implementation_Defined : declare 14501 Ent : Entity_Id; 14502 14503 begin 14504 GNAT_Pragma; 14505 Check_No_Identifiers; 14506 14507 -- Form with no arguments 14508 14509 if Arg_Count = 0 then 14510 Set_Is_Implementation_Defined (Current_Scope); 14511 14512 -- Form with one argument 14513 14514 else 14515 Check_Arg_Count (1); 14516 Check_Arg_Is_Local_Name (Arg1); 14517 Ent := Entity (Get_Pragma_Arg (Arg1)); 14518 Set_Is_Implementation_Defined (Ent); 14519 end if; 14520 end Implementation_Defined; 14521 14522 ----------------- 14523 -- Implemented -- 14524 ----------------- 14525 14526 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND); 14527 14528 -- IMPLEMENTATION_KIND ::= 14529 -- By_Entry | By_Protected_Procedure | By_Any | Optional 14530 14531 -- "By_Any" and "Optional" are treated as synonyms in order to 14532 -- support Ada 2012 aspect Synchronization. 14533 14534 when Pragma_Implemented => Implemented : declare 14535 Proc_Id : Entity_Id; 14536 Typ : Entity_Id; 14537 14538 begin 14539 Ada_2012_Pragma; 14540 Check_Arg_Count (2); 14541 Check_No_Identifiers; 14542 Check_Arg_Is_Identifier (Arg1); 14543 Check_Arg_Is_Local_Name (Arg1); 14544 Check_Arg_Is_One_Of (Arg2, 14545 Name_By_Any, 14546 Name_By_Entry, 14547 Name_By_Protected_Procedure, 14548 Name_Optional); 14549 14550 -- Extract the name of the local procedure 14551 14552 Proc_Id := Entity (Get_Pragma_Arg (Arg1)); 14553 14554 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a 14555 -- primitive procedure of a synchronized tagged type. 14556 14557 if Ekind (Proc_Id) = E_Procedure 14558 and then Is_Primitive (Proc_Id) 14559 and then Present (First_Formal (Proc_Id)) 14560 then 14561 Typ := Etype (First_Formal (Proc_Id)); 14562 14563 if Is_Tagged_Type (Typ) 14564 and then 14565 14566 -- Check for a protected, a synchronized or a task interface 14567 14568 ((Is_Interface (Typ) 14569 and then Is_Synchronized_Interface (Typ)) 14570 14571 -- Check for a protected type or a task type that implements 14572 -- an interface. 14573 14574 or else 14575 (Is_Concurrent_Record_Type (Typ) 14576 and then Present (Interfaces (Typ))) 14577 14578 -- Check for a private record extension with keyword 14579 -- "synchronized". 14580 14581 or else 14582 (Ekind_In (Typ, E_Record_Type_With_Private, 14583 E_Record_Subtype_With_Private) 14584 and then Synchronized_Present (Parent (Typ)))) 14585 then 14586 null; 14587 else 14588 Error_Pragma_Arg 14589 ("controlling formal must be of synchronized tagged type", 14590 Arg1); 14591 return; 14592 end if; 14593 14594 -- Procedures declared inside a protected type must be accepted 14595 14596 elsif Ekind (Proc_Id) = E_Procedure 14597 and then Is_Protected_Type (Scope (Proc_Id)) 14598 then 14599 null; 14600 14601 -- The first argument is not a primitive procedure 14602 14603 else 14604 Error_Pragma_Arg 14605 ("pragma % must be applied to a primitive procedure", Arg1); 14606 return; 14607 end if; 14608 14609 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind 14610 -- By_Protected_Procedure to the primitive procedure of a task 14611 -- interface. 14612 14613 if Chars (Arg2) = Name_By_Protected_Procedure 14614 and then Is_Interface (Typ) 14615 and then Is_Task_Interface (Typ) 14616 then 14617 Error_Pragma_Arg 14618 ("implementation kind By_Protected_Procedure cannot be " 14619 & "applied to a task interface primitive", Arg2); 14620 return; 14621 end if; 14622 14623 Record_Rep_Item (Proc_Id, N); 14624 end Implemented; 14625 14626 ---------------------- 14627 -- Implicit_Packing -- 14628 ---------------------- 14629 14630 -- pragma Implicit_Packing; 14631 14632 when Pragma_Implicit_Packing => 14633 GNAT_Pragma; 14634 Check_Arg_Count (0); 14635 Implicit_Packing := True; 14636 14637 ------------ 14638 -- Import -- 14639 ------------ 14640 14641 -- pragma Import ( 14642 -- [Convention =>] convention_IDENTIFIER, 14643 -- [Entity =>] local_NAME 14644 -- [, [External_Name =>] static_string_EXPRESSION ] 14645 -- [, [Link_Name =>] static_string_EXPRESSION ]); 14646 14647 when Pragma_Import => 14648 Check_Ada_83_Warning; 14649 Check_Arg_Order 14650 ((Name_Convention, 14651 Name_Entity, 14652 Name_External_Name, 14653 Name_Link_Name)); 14654 14655 Check_At_Least_N_Arguments (2); 14656 Check_At_Most_N_Arguments (4); 14657 Process_Import_Or_Interface; 14658 14659 ---------------------- 14660 -- Import_Exception -- 14661 ---------------------- 14662 14663 -- pragma Import_Exception ( 14664 -- [Internal =>] LOCAL_NAME 14665 -- [, [External =>] EXTERNAL_SYMBOL] 14666 -- [, [Form =>] Ada | VMS] 14667 -- [, [Code =>] static_integer_EXPRESSION]); 14668 14669 when Pragma_Import_Exception => Import_Exception : declare 14670 Args : Args_List (1 .. 4); 14671 Names : constant Name_List (1 .. 4) := ( 14672 Name_Internal, 14673 Name_External, 14674 Name_Form, 14675 Name_Code); 14676 14677 Internal : Node_Id renames Args (1); 14678 External : Node_Id renames Args (2); 14679 Form : Node_Id renames Args (3); 14680 Code : Node_Id renames Args (4); 14681 14682 begin 14683 GNAT_Pragma; 14684 Gather_Associations (Names, Args); 14685 14686 if Present (External) and then Present (Code) then 14687 Error_Pragma 14688 ("cannot give both External and Code options for pragma%"); 14689 end if; 14690 14691 Process_Extended_Import_Export_Exception_Pragma ( 14692 Arg_Internal => Internal, 14693 Arg_External => External, 14694 Arg_Form => Form, 14695 Arg_Code => Code); 14696 14697 if not Is_VMS_Exception (Entity (Internal)) then 14698 Set_Imported (Entity (Internal)); 14699 end if; 14700 end Import_Exception; 14701 14702 --------------------- 14703 -- Import_Function -- 14704 --------------------- 14705 14706 -- pragma Import_Function ( 14707 -- [Internal =>] LOCAL_NAME, 14708 -- [, [External =>] EXTERNAL_SYMBOL] 14709 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 14710 -- [, [Result_Type =>] SUBTYPE_MARK] 14711 -- [, [Mechanism =>] MECHANISM] 14712 -- [, [Result_Mechanism =>] MECHANISM_NAME] 14713 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 14714 14715 -- EXTERNAL_SYMBOL ::= 14716 -- IDENTIFIER 14717 -- | static_string_EXPRESSION 14718 14719 -- PARAMETER_TYPES ::= 14720 -- null 14721 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 14722 14723 -- TYPE_DESIGNATOR ::= 14724 -- subtype_NAME 14725 -- | subtype_Name ' Access 14726 14727 -- MECHANISM ::= 14728 -- MECHANISM_NAME 14729 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 14730 14731 -- MECHANISM_ASSOCIATION ::= 14732 -- [formal_parameter_NAME =>] MECHANISM_NAME 14733 14734 -- MECHANISM_NAME ::= 14735 -- Value 14736 -- | Reference 14737 -- | Descriptor [([Class =>] CLASS_NAME)] 14738 14739 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 14740 14741 when Pragma_Import_Function => Import_Function : declare 14742 Args : Args_List (1 .. 7); 14743 Names : constant Name_List (1 .. 7) := ( 14744 Name_Internal, 14745 Name_External, 14746 Name_Parameter_Types, 14747 Name_Result_Type, 14748 Name_Mechanism, 14749 Name_Result_Mechanism, 14750 Name_First_Optional_Parameter); 14751 14752 Internal : Node_Id renames Args (1); 14753 External : Node_Id renames Args (2); 14754 Parameter_Types : Node_Id renames Args (3); 14755 Result_Type : Node_Id renames Args (4); 14756 Mechanism : Node_Id renames Args (5); 14757 Result_Mechanism : Node_Id renames Args (6); 14758 First_Optional_Parameter : Node_Id renames Args (7); 14759 14760 begin 14761 GNAT_Pragma; 14762 Gather_Associations (Names, Args); 14763 Process_Extended_Import_Export_Subprogram_Pragma ( 14764 Arg_Internal => Internal, 14765 Arg_External => External, 14766 Arg_Parameter_Types => Parameter_Types, 14767 Arg_Result_Type => Result_Type, 14768 Arg_Mechanism => Mechanism, 14769 Arg_Result_Mechanism => Result_Mechanism, 14770 Arg_First_Optional_Parameter => First_Optional_Parameter); 14771 end Import_Function; 14772 14773 ------------------- 14774 -- Import_Object -- 14775 ------------------- 14776 14777 -- pragma Import_Object ( 14778 -- [Internal =>] LOCAL_NAME 14779 -- [, [External =>] EXTERNAL_SYMBOL] 14780 -- [, [Size =>] EXTERNAL_SYMBOL]); 14781 14782 -- EXTERNAL_SYMBOL ::= 14783 -- IDENTIFIER 14784 -- | static_string_EXPRESSION 14785 14786 when Pragma_Import_Object => Import_Object : declare 14787 Args : Args_List (1 .. 3); 14788 Names : constant Name_List (1 .. 3) := ( 14789 Name_Internal, 14790 Name_External, 14791 Name_Size); 14792 14793 Internal : Node_Id renames Args (1); 14794 External : Node_Id renames Args (2); 14795 Size : Node_Id renames Args (3); 14796 14797 begin 14798 GNAT_Pragma; 14799 Gather_Associations (Names, Args); 14800 Process_Extended_Import_Export_Object_Pragma ( 14801 Arg_Internal => Internal, 14802 Arg_External => External, 14803 Arg_Size => Size); 14804 end Import_Object; 14805 14806 ---------------------- 14807 -- Import_Procedure -- 14808 ---------------------- 14809 14810 -- pragma Import_Procedure ( 14811 -- [Internal =>] LOCAL_NAME 14812 -- [, [External =>] EXTERNAL_SYMBOL] 14813 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 14814 -- [, [Mechanism =>] MECHANISM] 14815 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 14816 14817 -- EXTERNAL_SYMBOL ::= 14818 -- IDENTIFIER 14819 -- | static_string_EXPRESSION 14820 14821 -- PARAMETER_TYPES ::= 14822 -- null 14823 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 14824 14825 -- TYPE_DESIGNATOR ::= 14826 -- subtype_NAME 14827 -- | subtype_Name ' Access 14828 14829 -- MECHANISM ::= 14830 -- MECHANISM_NAME 14831 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 14832 14833 -- MECHANISM_ASSOCIATION ::= 14834 -- [formal_parameter_NAME =>] MECHANISM_NAME 14835 14836 -- MECHANISM_NAME ::= 14837 -- Value 14838 -- | Reference 14839 -- | Descriptor [([Class =>] CLASS_NAME)] 14840 14841 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 14842 14843 when Pragma_Import_Procedure => Import_Procedure : declare 14844 Args : Args_List (1 .. 5); 14845 Names : constant Name_List (1 .. 5) := ( 14846 Name_Internal, 14847 Name_External, 14848 Name_Parameter_Types, 14849 Name_Mechanism, 14850 Name_First_Optional_Parameter); 14851 14852 Internal : Node_Id renames Args (1); 14853 External : Node_Id renames Args (2); 14854 Parameter_Types : Node_Id renames Args (3); 14855 Mechanism : Node_Id renames Args (4); 14856 First_Optional_Parameter : Node_Id renames Args (5); 14857 14858 begin 14859 GNAT_Pragma; 14860 Gather_Associations (Names, Args); 14861 Process_Extended_Import_Export_Subprogram_Pragma ( 14862 Arg_Internal => Internal, 14863 Arg_External => External, 14864 Arg_Parameter_Types => Parameter_Types, 14865 Arg_Mechanism => Mechanism, 14866 Arg_First_Optional_Parameter => First_Optional_Parameter); 14867 end Import_Procedure; 14868 14869 ----------------------------- 14870 -- Import_Valued_Procedure -- 14871 ----------------------------- 14872 14873 -- pragma Import_Valued_Procedure ( 14874 -- [Internal =>] LOCAL_NAME 14875 -- [, [External =>] EXTERNAL_SYMBOL] 14876 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 14877 -- [, [Mechanism =>] MECHANISM] 14878 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 14879 14880 -- EXTERNAL_SYMBOL ::= 14881 -- IDENTIFIER 14882 -- | static_string_EXPRESSION 14883 14884 -- PARAMETER_TYPES ::= 14885 -- null 14886 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 14887 14888 -- TYPE_DESIGNATOR ::= 14889 -- subtype_NAME 14890 -- | subtype_Name ' Access 14891 14892 -- MECHANISM ::= 14893 -- MECHANISM_NAME 14894 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 14895 14896 -- MECHANISM_ASSOCIATION ::= 14897 -- [formal_parameter_NAME =>] MECHANISM_NAME 14898 14899 -- MECHANISM_NAME ::= 14900 -- Value 14901 -- | Reference 14902 -- | Descriptor [([Class =>] CLASS_NAME)] 14903 14904 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 14905 14906 when Pragma_Import_Valued_Procedure => 14907 Import_Valued_Procedure : declare 14908 Args : Args_List (1 .. 5); 14909 Names : constant Name_List (1 .. 5) := ( 14910 Name_Internal, 14911 Name_External, 14912 Name_Parameter_Types, 14913 Name_Mechanism, 14914 Name_First_Optional_Parameter); 14915 14916 Internal : Node_Id renames Args (1); 14917 External : Node_Id renames Args (2); 14918 Parameter_Types : Node_Id renames Args (3); 14919 Mechanism : Node_Id renames Args (4); 14920 First_Optional_Parameter : Node_Id renames Args (5); 14921 14922 begin 14923 GNAT_Pragma; 14924 Gather_Associations (Names, Args); 14925 Process_Extended_Import_Export_Subprogram_Pragma ( 14926 Arg_Internal => Internal, 14927 Arg_External => External, 14928 Arg_Parameter_Types => Parameter_Types, 14929 Arg_Mechanism => Mechanism, 14930 Arg_First_Optional_Parameter => First_Optional_Parameter); 14931 end Import_Valued_Procedure; 14932 14933 ----------------- 14934 -- Independent -- 14935 ----------------- 14936 14937 -- pragma Independent (LOCAL_NAME); 14938 14939 when Pragma_Independent => Independent : declare 14940 E_Id : Node_Id; 14941 E : Entity_Id; 14942 D : Node_Id; 14943 K : Node_Kind; 14944 14945 begin 14946 Check_Ada_83_Warning; 14947 Ada_2012_Pragma; 14948 Check_No_Identifiers; 14949 Check_Arg_Count (1); 14950 Check_Arg_Is_Local_Name (Arg1); 14951 E_Id := Get_Pragma_Arg (Arg1); 14952 14953 if Etype (E_Id) = Any_Type then 14954 return; 14955 end if; 14956 14957 E := Entity (E_Id); 14958 D := Declaration_Node (E); 14959 K := Nkind (D); 14960 14961 -- Check duplicate before we chain ourselves 14962 14963 Check_Duplicate_Pragma (E); 14964 14965 -- Check appropriate entity 14966 14967 if Is_Type (E) then 14968 if Rep_Item_Too_Early (E, N) 14969 or else 14970 Rep_Item_Too_Late (E, N) 14971 then 14972 return; 14973 else 14974 Check_First_Subtype (Arg1); 14975 end if; 14976 14977 elsif K = N_Object_Declaration 14978 or else (K = N_Component_Declaration 14979 and then Original_Record_Component (E) = E) 14980 then 14981 if Rep_Item_Too_Late (E, N) then 14982 return; 14983 end if; 14984 14985 else 14986 Error_Pragma_Arg 14987 ("inappropriate entity for pragma%", Arg1); 14988 end if; 14989 14990 Independence_Checks.Append ((N, E)); 14991 end Independent; 14992 14993 ---------------------------- 14994 -- Independent_Components -- 14995 ---------------------------- 14996 14997 -- pragma Atomic_Components (array_LOCAL_NAME); 14998 14999 -- This processing is shared by Volatile_Components 15000 15001 when Pragma_Independent_Components => Independent_Components : declare 15002 E_Id : Node_Id; 15003 E : Entity_Id; 15004 D : Node_Id; 15005 K : Node_Kind; 15006 15007 begin 15008 Check_Ada_83_Warning; 15009 Ada_2012_Pragma; 15010 Check_No_Identifiers; 15011 Check_Arg_Count (1); 15012 Check_Arg_Is_Local_Name (Arg1); 15013 E_Id := Get_Pragma_Arg (Arg1); 15014 15015 if Etype (E_Id) = Any_Type then 15016 return; 15017 end if; 15018 15019 E := Entity (E_Id); 15020 15021 -- Check duplicate before we chain ourselves 15022 15023 Check_Duplicate_Pragma (E); 15024 15025 -- Check appropriate entity 15026 15027 if Rep_Item_Too_Early (E, N) 15028 or else 15029 Rep_Item_Too_Late (E, N) 15030 then 15031 return; 15032 end if; 15033 15034 D := Declaration_Node (E); 15035 K := Nkind (D); 15036 15037 if K = N_Full_Type_Declaration 15038 and then (Is_Array_Type (E) or else Is_Record_Type (E)) 15039 then 15040 Independence_Checks.Append ((N, E)); 15041 Set_Has_Independent_Components (Base_Type (E)); 15042 15043 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 15044 and then Nkind (D) = N_Object_Declaration 15045 and then Nkind (Object_Definition (D)) = 15046 N_Constrained_Array_Definition 15047 then 15048 Independence_Checks.Append ((N, E)); 15049 Set_Has_Independent_Components (E); 15050 15051 else 15052 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 15053 end if; 15054 end Independent_Components; 15055 15056 ----------------------- 15057 -- Initial_Condition -- 15058 ----------------------- 15059 15060 -- pragma Initial_Condition (boolean_EXPRESSION); 15061 15062 when Pragma_Initial_Condition => Initial_Condition : declare 15063 Context : constant Node_Id := Parent (Parent (N)); 15064 Pack_Id : Entity_Id; 15065 Stmt : Node_Id; 15066 15067 begin 15068 GNAT_Pragma; 15069 Check_Arg_Count (1); 15070 15071 -- Ensure the proper placement of the pragma. Initial_Condition 15072 -- must be associated with a package declaration. 15073 15074 if not Nkind_In (Context, N_Generic_Package_Declaration, 15075 N_Package_Declaration) 15076 then 15077 Pragma_Misplaced; 15078 return; 15079 end if; 15080 15081 Stmt := Prev (N); 15082 while Present (Stmt) loop 15083 15084 -- Skip prior pragmas, but check for duplicates 15085 15086 if Nkind (Stmt) = N_Pragma then 15087 if Pragma_Name (Stmt) = Pname then 15088 Error_Msg_Name_1 := Pname; 15089 Error_Msg_Sloc := Sloc (Stmt); 15090 Error_Msg_N ("pragma % duplicates pragma declared #", N); 15091 end if; 15092 15093 -- Skip internally generated code 15094 15095 elsif not Comes_From_Source (Stmt) then 15096 null; 15097 15098 -- The pragma does not apply to a legal construct, issue an 15099 -- error and stop the analysis. 15100 15101 else 15102 Pragma_Misplaced; 15103 return; 15104 end if; 15105 15106 Stmt := Prev (Stmt); 15107 end loop; 15108 15109 -- The pragma must be analyzed at the end of the visible 15110 -- declarations of the related package. Save the pragma for later 15111 -- (see Analyze_Initial_Condition_In_Decl_Part) by adding it to 15112 -- the contract of the package. 15113 15114 Pack_Id := Defining_Entity (Context); 15115 Add_Contract_Item (N, Pack_Id); 15116 15117 -- Verify the declaration order of pragma Initial_Condition with 15118 -- respect to pragmas Abstract_State and Initializes when SPARK 15119 -- checks are enabled. 15120 15121 if SPARK_Mode /= Off then 15122 Check_Declaration_Order 15123 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State), 15124 Second => N); 15125 15126 Check_Declaration_Order 15127 (First => Get_Pragma (Pack_Id, Pragma_Initializes), 15128 Second => N); 15129 end if; 15130 end Initial_Condition; 15131 15132 ------------------------ 15133 -- Initialize_Scalars -- 15134 ------------------------ 15135 15136 -- pragma Initialize_Scalars; 15137 15138 when Pragma_Initialize_Scalars => 15139 GNAT_Pragma; 15140 Check_Arg_Count (0); 15141 Check_Valid_Configuration_Pragma; 15142 Check_Restriction (No_Initialize_Scalars, N); 15143 15144 -- Initialize_Scalars creates false positives in CodePeer, and 15145 -- incorrect negative results in GNATprove mode, so ignore this 15146 -- pragma in these modes. 15147 15148 if not Restriction_Active (No_Initialize_Scalars) 15149 and then not (CodePeer_Mode or GNATprove_Mode) 15150 then 15151 Init_Or_Norm_Scalars := True; 15152 Initialize_Scalars := True; 15153 end if; 15154 15155 ----------------- 15156 -- Initializes -- 15157 ----------------- 15158 15159 -- pragma Initializes (INITIALIZATION_SPEC); 15160 15161 -- INITIALIZATION_SPEC ::= null | INITIALIZATION_LIST 15162 15163 -- INITIALIZATION_LIST ::= 15164 -- INITIALIZATION_ITEM 15165 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM}) 15166 15167 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST] 15168 15169 -- INPUT_LIST ::= 15170 -- null 15171 -- | INPUT 15172 -- | (INPUT {, INPUT}) 15173 15174 -- INPUT ::= name 15175 15176 when Pragma_Initializes => Initializes : declare 15177 Context : constant Node_Id := Parent (Parent (N)); 15178 Pack_Id : Entity_Id; 15179 Stmt : Node_Id; 15180 15181 begin 15182 GNAT_Pragma; 15183 Check_Arg_Count (1); 15184 Ensure_Aggregate_Form (Arg1); 15185 15186 -- Ensure the proper placement of the pragma. Initializes must be 15187 -- associated with a package declaration. 15188 15189 if not Nkind_In (Context, N_Generic_Package_Declaration, 15190 N_Package_Declaration) 15191 then 15192 Pragma_Misplaced; 15193 return; 15194 end if; 15195 15196 Stmt := Prev (N); 15197 while Present (Stmt) loop 15198 15199 -- Skip prior pragmas, but check for duplicates 15200 15201 if Nkind (Stmt) = N_Pragma then 15202 if Pragma_Name (Stmt) = Pname then 15203 Error_Msg_Name_1 := Pname; 15204 Error_Msg_Sloc := Sloc (Stmt); 15205 Error_Msg_N ("pragma % duplicates pragma declared #", N); 15206 end if; 15207 15208 -- Skip internally generated code 15209 15210 elsif not Comes_From_Source (Stmt) then 15211 null; 15212 15213 -- The pragma does not apply to a legal construct, issue an 15214 -- error and stop the analysis. 15215 15216 else 15217 Pragma_Misplaced; 15218 return; 15219 end if; 15220 15221 Stmt := Prev (Stmt); 15222 end loop; 15223 15224 -- The pragma must be analyzed at the end of the visible 15225 -- declarations of the related package. Save the pragma for later 15226 -- (see Analyze_Initializes_In_Decl_Part) by adding it to the 15227 -- contract of the package. 15228 15229 Pack_Id := Defining_Entity (Context); 15230 Add_Contract_Item (N, Pack_Id); 15231 15232 -- Verify the declaration order of pragmas Abstract_State and 15233 -- Initializes when SPARK checks are enabled. 15234 15235 if SPARK_Mode /= Off then 15236 Check_Declaration_Order 15237 (First => Get_Pragma (Pack_Id, Pragma_Abstract_State), 15238 Second => N); 15239 end if; 15240 end Initializes; 15241 15242 ------------ 15243 -- Inline -- 15244 ------------ 15245 15246 -- pragma Inline ( NAME {, NAME} ); 15247 15248 when Pragma_Inline => 15249 15250 -- Inline status is Enabled if inlining option is active 15251 15252 if Inline_Active then 15253 Process_Inline (Enabled); 15254 else 15255 Process_Inline (Disabled); 15256 end if; 15257 15258 ------------------- 15259 -- Inline_Always -- 15260 ------------------- 15261 15262 -- pragma Inline_Always ( NAME {, NAME} ); 15263 15264 when Pragma_Inline_Always => 15265 GNAT_Pragma; 15266 15267 -- Pragma always active unless in CodePeer or GNATprove mode, 15268 -- since this causes walk order issues. 15269 15270 if not (CodePeer_Mode or GNATprove_Mode) then 15271 Process_Inline (Enabled); 15272 end if; 15273 15274 -------------------- 15275 -- Inline_Generic -- 15276 -------------------- 15277 15278 -- pragma Inline_Generic (NAME {, NAME}); 15279 15280 when Pragma_Inline_Generic => 15281 GNAT_Pragma; 15282 Process_Generic_List; 15283 15284 ---------------------- 15285 -- Inspection_Point -- 15286 ---------------------- 15287 15288 -- pragma Inspection_Point [(object_NAME {, object_NAME})]; 15289 15290 when Pragma_Inspection_Point => Inspection_Point : declare 15291 Arg : Node_Id; 15292 Exp : Node_Id; 15293 15294 begin 15295 if Arg_Count > 0 then 15296 Arg := Arg1; 15297 loop 15298 Exp := Get_Pragma_Arg (Arg); 15299 Analyze (Exp); 15300 15301 if not Is_Entity_Name (Exp) 15302 or else not Is_Object (Entity (Exp)) 15303 then 15304 Error_Pragma_Arg ("object name required", Arg); 15305 end if; 15306 15307 Next (Arg); 15308 exit when No (Arg); 15309 end loop; 15310 end if; 15311 end Inspection_Point; 15312 15313 --------------- 15314 -- Interface -- 15315 --------------- 15316 15317 -- pragma Interface ( 15318 -- [ Convention =>] convention_IDENTIFIER, 15319 -- [ Entity =>] local_NAME 15320 -- [, [External_Name =>] static_string_EXPRESSION ] 15321 -- [, [Link_Name =>] static_string_EXPRESSION ]); 15322 15323 when Pragma_Interface => 15324 GNAT_Pragma; 15325 Check_Arg_Order 15326 ((Name_Convention, 15327 Name_Entity, 15328 Name_External_Name, 15329 Name_Link_Name)); 15330 Check_At_Least_N_Arguments (2); 15331 Check_At_Most_N_Arguments (4); 15332 Process_Import_Or_Interface; 15333 15334 -- In Ada 2005, the permission to use Interface (a reserved word) 15335 -- as a pragma name is considered an obsolescent feature, and this 15336 -- pragma was already obsolescent in Ada 95. 15337 15338 if Ada_Version >= Ada_95 then 15339 Check_Restriction 15340 (No_Obsolescent_Features, Pragma_Identifier (N)); 15341 15342 if Warn_On_Obsolescent_Feature then 15343 Error_Msg_N 15344 ("pragma Interface is an obsolescent feature?j?", N); 15345 Error_Msg_N 15346 ("|use pragma Import instead?j?", N); 15347 end if; 15348 end if; 15349 15350 -------------------- 15351 -- Interface_Name -- 15352 -------------------- 15353 15354 -- pragma Interface_Name ( 15355 -- [ Entity =>] local_NAME 15356 -- [,[External_Name =>] static_string_EXPRESSION ] 15357 -- [,[Link_Name =>] static_string_EXPRESSION ]); 15358 15359 when Pragma_Interface_Name => Interface_Name : declare 15360 Id : Node_Id; 15361 Def_Id : Entity_Id; 15362 Hom_Id : Entity_Id; 15363 Found : Boolean; 15364 15365 begin 15366 GNAT_Pragma; 15367 Check_Arg_Order 15368 ((Name_Entity, Name_External_Name, Name_Link_Name)); 15369 Check_At_Least_N_Arguments (2); 15370 Check_At_Most_N_Arguments (3); 15371 Id := Get_Pragma_Arg (Arg1); 15372 Analyze (Id); 15373 15374 -- This is obsolete from Ada 95 on, but it is an implementation 15375 -- defined pragma, so we do not consider that it violates the 15376 -- restriction (No_Obsolescent_Features). 15377 15378 if Ada_Version >= Ada_95 then 15379 if Warn_On_Obsolescent_Feature then 15380 Error_Msg_N 15381 ("pragma Interface_Name is an obsolescent feature?j?", N); 15382 Error_Msg_N 15383 ("|use pragma Import instead?j?", N); 15384 end if; 15385 end if; 15386 15387 if not Is_Entity_Name (Id) then 15388 Error_Pragma_Arg 15389 ("first argument for pragma% must be entity name", Arg1); 15390 elsif Etype (Id) = Any_Type then 15391 return; 15392 else 15393 Def_Id := Entity (Id); 15394 end if; 15395 15396 -- Special DEC-compatible processing for the object case, forces 15397 -- object to be imported. 15398 15399 if Ekind (Def_Id) = E_Variable then 15400 Kill_Size_Check_Code (Def_Id); 15401 Note_Possible_Modification (Id, Sure => False); 15402 15403 -- Initialization is not allowed for imported variable 15404 15405 if Present (Expression (Parent (Def_Id))) 15406 and then Comes_From_Source (Expression (Parent (Def_Id))) 15407 then 15408 Error_Msg_Sloc := Sloc (Def_Id); 15409 Error_Pragma_Arg 15410 ("no initialization allowed for declaration of& #", 15411 Arg2); 15412 15413 else 15414 -- For compatibility, support VADS usage of providing both 15415 -- pragmas Interface and Interface_Name to obtain the effect 15416 -- of a single Import pragma. 15417 15418 if Is_Imported (Def_Id) 15419 and then Present (First_Rep_Item (Def_Id)) 15420 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma 15421 and then 15422 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface 15423 then 15424 null; 15425 else 15426 Set_Imported (Def_Id); 15427 end if; 15428 15429 Set_Is_Public (Def_Id); 15430 Process_Interface_Name (Def_Id, Arg2, Arg3); 15431 end if; 15432 15433 -- Otherwise must be subprogram 15434 15435 elsif not Is_Subprogram (Def_Id) then 15436 Error_Pragma_Arg 15437 ("argument of pragma% is not subprogram", Arg1); 15438 15439 else 15440 Check_At_Most_N_Arguments (3); 15441 Hom_Id := Def_Id; 15442 Found := False; 15443 15444 -- Loop through homonyms 15445 15446 loop 15447 Def_Id := Get_Base_Subprogram (Hom_Id); 15448 15449 if Is_Imported (Def_Id) then 15450 Process_Interface_Name (Def_Id, Arg2, Arg3); 15451 Found := True; 15452 end if; 15453 15454 exit when From_Aspect_Specification (N); 15455 Hom_Id := Homonym (Hom_Id); 15456 15457 exit when No (Hom_Id) 15458 or else Scope (Hom_Id) /= Current_Scope; 15459 end loop; 15460 15461 if not Found then 15462 Error_Pragma_Arg 15463 ("argument of pragma% is not imported subprogram", 15464 Arg1); 15465 end if; 15466 end if; 15467 end Interface_Name; 15468 15469 ----------------------- 15470 -- Interrupt_Handler -- 15471 ----------------------- 15472 15473 -- pragma Interrupt_Handler (handler_NAME); 15474 15475 when Pragma_Interrupt_Handler => 15476 Check_Ada_83_Warning; 15477 Check_Arg_Count (1); 15478 Check_No_Identifiers; 15479 15480 if No_Run_Time_Mode then 15481 Error_Msg_CRT ("Interrupt_Handler pragma", N); 15482 else 15483 Check_Interrupt_Or_Attach_Handler; 15484 Process_Interrupt_Or_Attach_Handler; 15485 end if; 15486 15487 ------------------------ 15488 -- Interrupt_Priority -- 15489 ------------------------ 15490 15491 -- pragma Interrupt_Priority [(EXPRESSION)]; 15492 15493 when Pragma_Interrupt_Priority => Interrupt_Priority : declare 15494 P : constant Node_Id := Parent (N); 15495 Arg : Node_Id; 15496 Ent : Entity_Id; 15497 15498 begin 15499 Check_Ada_83_Warning; 15500 15501 if Arg_Count /= 0 then 15502 Arg := Get_Pragma_Arg (Arg1); 15503 Check_Arg_Count (1); 15504 Check_No_Identifiers; 15505 15506 -- The expression must be analyzed in the special manner 15507 -- described in "Handling of Default and Per-Object 15508 -- Expressions" in sem.ads. 15509 15510 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); 15511 end if; 15512 15513 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then 15514 Pragma_Misplaced; 15515 return; 15516 15517 else 15518 Ent := Defining_Identifier (Parent (P)); 15519 15520 -- Check duplicate pragma before we chain the pragma in the Rep 15521 -- Item chain of Ent. 15522 15523 Check_Duplicate_Pragma (Ent); 15524 Record_Rep_Item (Ent, N); 15525 end if; 15526 end Interrupt_Priority; 15527 15528 --------------------- 15529 -- Interrupt_State -- 15530 --------------------- 15531 15532 -- pragma Interrupt_State ( 15533 -- [Name =>] INTERRUPT_ID, 15534 -- [State =>] INTERRUPT_STATE); 15535 15536 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION 15537 -- INTERRUPT_STATE => System | Runtime | User 15538 15539 -- Note: if the interrupt id is given as an identifier, then it must 15540 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is 15541 -- given as a static integer expression which must be in the range of 15542 -- Ada.Interrupts.Interrupt_ID. 15543 15544 when Pragma_Interrupt_State => Interrupt_State : declare 15545 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); 15546 -- This is the entity Ada.Interrupts.Interrupt_ID; 15547 15548 State_Type : Character; 15549 -- Set to 's'/'r'/'u' for System/Runtime/User 15550 15551 IST_Num : Pos; 15552 -- Index to entry in Interrupt_States table 15553 15554 Int_Val : Uint; 15555 -- Value of interrupt 15556 15557 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); 15558 -- The first argument to the pragma 15559 15560 Int_Ent : Entity_Id; 15561 -- Interrupt entity in Ada.Interrupts.Names 15562 15563 begin 15564 GNAT_Pragma; 15565 Check_Arg_Order ((Name_Name, Name_State)); 15566 Check_Arg_Count (2); 15567 15568 Check_Optional_Identifier (Arg1, Name_Name); 15569 Check_Optional_Identifier (Arg2, Name_State); 15570 Check_Arg_Is_Identifier (Arg2); 15571 15572 -- First argument is identifier 15573 15574 if Nkind (Arg1X) = N_Identifier then 15575 15576 -- Search list of names in Ada.Interrupts.Names 15577 15578 Int_Ent := First_Entity (RTE (RE_Names)); 15579 loop 15580 if No (Int_Ent) then 15581 Error_Pragma_Arg ("invalid interrupt name", Arg1); 15582 15583 elsif Chars (Int_Ent) = Chars (Arg1X) then 15584 Int_Val := Expr_Value (Constant_Value (Int_Ent)); 15585 exit; 15586 end if; 15587 15588 Next_Entity (Int_Ent); 15589 end loop; 15590 15591 -- First argument is not an identifier, so it must be a static 15592 -- expression of type Ada.Interrupts.Interrupt_ID. 15593 15594 else 15595 Check_Arg_Is_Static_Expression (Arg1, Any_Integer); 15596 Int_Val := Expr_Value (Arg1X); 15597 15598 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) 15599 or else 15600 Int_Val > Expr_Value (Type_High_Bound (Int_Id)) 15601 then 15602 Error_Pragma_Arg 15603 ("value not in range of type " 15604 & """Ada.Interrupts.Interrupt_'I'D""", Arg1); 15605 end if; 15606 end if; 15607 15608 -- Check OK state 15609 15610 case Chars (Get_Pragma_Arg (Arg2)) is 15611 when Name_Runtime => State_Type := 'r'; 15612 when Name_System => State_Type := 's'; 15613 when Name_User => State_Type := 'u'; 15614 15615 when others => 15616 Error_Pragma_Arg ("invalid interrupt state", Arg2); 15617 end case; 15618 15619 -- Check if entry is already stored 15620 15621 IST_Num := Interrupt_States.First; 15622 loop 15623 -- If entry not found, add it 15624 15625 if IST_Num > Interrupt_States.Last then 15626 Interrupt_States.Append 15627 ((Interrupt_Number => UI_To_Int (Int_Val), 15628 Interrupt_State => State_Type, 15629 Pragma_Loc => Loc)); 15630 exit; 15631 15632 -- Case of entry for the same entry 15633 15634 elsif Int_Val = Interrupt_States.Table (IST_Num). 15635 Interrupt_Number 15636 then 15637 -- If state matches, done, no need to make redundant entry 15638 15639 exit when 15640 State_Type = Interrupt_States.Table (IST_Num). 15641 Interrupt_State; 15642 15643 -- Otherwise if state does not match, error 15644 15645 Error_Msg_Sloc := 15646 Interrupt_States.Table (IST_Num).Pragma_Loc; 15647 Error_Pragma_Arg 15648 ("state conflicts with that given #", Arg2); 15649 exit; 15650 end if; 15651 15652 IST_Num := IST_Num + 1; 15653 end loop; 15654 end Interrupt_State; 15655 15656 --------------- 15657 -- Invariant -- 15658 --------------- 15659 15660 -- pragma Invariant 15661 -- ([Entity =>] type_LOCAL_NAME, 15662 -- [Check =>] EXPRESSION 15663 -- [,[Message =>] String_Expression]); 15664 15665 when Pragma_Invariant => Invariant : declare 15666 Type_Id : Node_Id; 15667 Typ : Entity_Id; 15668 PDecl : Node_Id; 15669 15670 Discard : Boolean; 15671 pragma Unreferenced (Discard); 15672 15673 begin 15674 GNAT_Pragma; 15675 Check_At_Least_N_Arguments (2); 15676 Check_At_Most_N_Arguments (3); 15677 Check_Optional_Identifier (Arg1, Name_Entity); 15678 Check_Optional_Identifier (Arg2, Name_Check); 15679 15680 if Arg_Count = 3 then 15681 Check_Optional_Identifier (Arg3, Name_Message); 15682 Check_Arg_Is_Static_Expression (Arg3, Standard_String); 15683 end if; 15684 15685 Check_Arg_Is_Local_Name (Arg1); 15686 15687 Type_Id := Get_Pragma_Arg (Arg1); 15688 Find_Type (Type_Id); 15689 Typ := Entity (Type_Id); 15690 15691 if Typ = Any_Type then 15692 return; 15693 15694 -- An invariant must apply to a private type, or appear in the 15695 -- private part of a package spec and apply to a completion. 15696 -- a class-wide invariant can only appear on a private declaration 15697 -- or private extension, not a completion. 15698 15699 elsif Ekind_In (Typ, E_Private_Type, 15700 E_Record_Type_With_Private, 15701 E_Limited_Private_Type) 15702 then 15703 null; 15704 15705 elsif In_Private_Part (Current_Scope) 15706 and then Has_Private_Declaration (Typ) 15707 and then not Class_Present (N) 15708 then 15709 null; 15710 15711 elsif In_Private_Part (Current_Scope) then 15712 Error_Pragma_Arg 15713 ("pragma% only allowed for private type declared in " 15714 & "visible part", Arg1); 15715 15716 else 15717 Error_Pragma_Arg 15718 ("pragma% only allowed for private type", Arg1); 15719 end if; 15720 15721 -- Note that the type has at least one invariant, and also that 15722 -- it has inheritable invariants if we have Invariant'Class 15723 -- or Type_Invariant'Class. Build the corresponding invariant 15724 -- procedure declaration, so that calls to it can be generated 15725 -- before the body is built (e.g. within an expression function). 15726 15727 PDecl := Build_Invariant_Procedure_Declaration (Typ); 15728 15729 Insert_After (N, PDecl); 15730 Analyze (PDecl); 15731 15732 if Class_Present (N) then 15733 Set_Has_Inheritable_Invariants (Typ); 15734 end if; 15735 15736 -- The remaining processing is simply to link the pragma on to 15737 -- the rep item chain, for processing when the type is frozen. 15738 -- This is accomplished by a call to Rep_Item_Too_Late. 15739 15740 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 15741 end Invariant; 15742 15743 ---------------------- 15744 -- Java_Constructor -- 15745 ---------------------- 15746 15747 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME); 15748 15749 -- Also handles pragma CIL_Constructor 15750 15751 when Pragma_CIL_Constructor | Pragma_Java_Constructor => 15752 Java_Constructor : declare 15753 Convention : Convention_Id; 15754 Def_Id : Entity_Id; 15755 Hom_Id : Entity_Id; 15756 Id : Entity_Id; 15757 This_Formal : Entity_Id; 15758 15759 begin 15760 GNAT_Pragma; 15761 Check_Arg_Count (1); 15762 Check_Optional_Identifier (Arg1, Name_Entity); 15763 Check_Arg_Is_Local_Name (Arg1); 15764 15765 Id := Get_Pragma_Arg (Arg1); 15766 Find_Program_Unit_Name (Id); 15767 15768 -- If we did not find the name, we are done 15769 15770 if Etype (Id) = Any_Type then 15771 return; 15772 end if; 15773 15774 -- Check wrong use of pragma in wrong VM target 15775 15776 if VM_Target = No_VM then 15777 return; 15778 15779 elsif VM_Target = CLI_Target 15780 and then Prag_Id = Pragma_Java_Constructor 15781 then 15782 Error_Pragma ("must use pragma 'C'I'L_'Constructor"); 15783 15784 elsif VM_Target = JVM_Target 15785 and then Prag_Id = Pragma_CIL_Constructor 15786 then 15787 Error_Pragma ("must use pragma 'Java_'Constructor"); 15788 end if; 15789 15790 case Prag_Id is 15791 when Pragma_CIL_Constructor => Convention := Convention_CIL; 15792 when Pragma_Java_Constructor => Convention := Convention_Java; 15793 when others => null; 15794 end case; 15795 15796 Hom_Id := Entity (Id); 15797 15798 -- Loop through homonyms 15799 15800 loop 15801 Def_Id := Get_Base_Subprogram (Hom_Id); 15802 15803 -- The constructor is required to be a function 15804 15805 if Ekind (Def_Id) /= E_Function then 15806 if VM_Target = JVM_Target then 15807 Error_Pragma_Arg 15808 ("pragma% requires function returning a 'Java access " 15809 & "type", Def_Id); 15810 else 15811 Error_Pragma_Arg 15812 ("pragma% requires function returning a 'C'I'L access " 15813 & "type", Def_Id); 15814 end if; 15815 end if; 15816 15817 -- Check arguments: For tagged type the first formal must be 15818 -- named "this" and its type must be a named access type 15819 -- designating a class-wide tagged type that has convention 15820 -- CIL/Java. The first formal must also have a null default 15821 -- value. For example: 15822 15823 -- type Typ is tagged ... 15824 -- type Ref is access all Typ; 15825 -- pragma Convention (CIL, Typ); 15826 15827 -- function New_Typ (This : Ref) return Ref; 15828 -- function New_Typ (This : Ref; I : Integer) return Ref; 15829 -- pragma Cil_Constructor (New_Typ); 15830 15831 -- Reason: The first formal must NOT be a primitive of the 15832 -- tagged type. 15833 15834 -- This rule also applies to constructors of delegates used 15835 -- to interface with standard target libraries. For example: 15836 15837 -- type Delegate is access procedure ... 15838 -- pragma Import (CIL, Delegate, ...); 15839 15840 -- function new_Delegate 15841 -- (This : Delegate := null; ... ) return Delegate; 15842 15843 -- For value-types this rule does not apply. 15844 15845 if not Is_Value_Type (Etype (Def_Id)) then 15846 if No (First_Formal (Def_Id)) then 15847 Error_Msg_Name_1 := Pname; 15848 Error_Msg_N ("% function must have parameters", Def_Id); 15849 return; 15850 end if; 15851 15852 -- In the JRE library we have several occurrences in which 15853 -- the "this" parameter is not the first formal. 15854 15855 This_Formal := First_Formal (Def_Id); 15856 15857 -- In the JRE library we have several occurrences in which 15858 -- the "this" parameter is not the first formal. Search for 15859 -- it. 15860 15861 if VM_Target = JVM_Target then 15862 while Present (This_Formal) 15863 and then Get_Name_String (Chars (This_Formal)) /= "this" 15864 loop 15865 Next_Formal (This_Formal); 15866 end loop; 15867 15868 if No (This_Formal) then 15869 This_Formal := First_Formal (Def_Id); 15870 end if; 15871 end if; 15872 15873 -- Warning: The first parameter should be named "this". 15874 -- We temporarily allow it because we have the following 15875 -- case in the Java runtime (file s-osinte.ads) ??? 15876 15877 -- function new_Thread 15878 -- (Self_Id : System.Address) return Thread_Id; 15879 -- pragma Java_Constructor (new_Thread); 15880 15881 if VM_Target = JVM_Target 15882 and then Get_Name_String (Chars (First_Formal (Def_Id))) 15883 = "self_id" 15884 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address) 15885 then 15886 null; 15887 15888 elsif Get_Name_String (Chars (This_Formal)) /= "this" then 15889 Error_Msg_Name_1 := Pname; 15890 Error_Msg_N 15891 ("first formal of % function must be named `this`", 15892 Parent (This_Formal)); 15893 15894 elsif not Is_Access_Type (Etype (This_Formal)) then 15895 Error_Msg_Name_1 := Pname; 15896 Error_Msg_N 15897 ("first formal of % function must be an access type", 15898 Parameter_Type (Parent (This_Formal))); 15899 15900 -- For delegates the type of the first formal must be a 15901 -- named access-to-subprogram type (see previous example) 15902 15903 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type 15904 and then Ekind (Etype (This_Formal)) 15905 /= E_Access_Subprogram_Type 15906 then 15907 Error_Msg_Name_1 := Pname; 15908 Error_Msg_N 15909 ("first formal of % function must be a named access " 15910 & "to subprogram type", 15911 Parameter_Type (Parent (This_Formal))); 15912 15913 -- Warning: We should reject anonymous access types because 15914 -- the constructor must not be handled as a primitive of the 15915 -- tagged type. We temporarily allow it because this profile 15916 -- is currently generated by cil2ada??? 15917 15918 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type 15919 and then not Ekind_In (Etype (This_Formal), 15920 E_Access_Type, 15921 E_General_Access_Type, 15922 E_Anonymous_Access_Type) 15923 then 15924 Error_Msg_Name_1 := Pname; 15925 Error_Msg_N 15926 ("first formal of % function must be a named access " 15927 & "type", Parameter_Type (Parent (This_Formal))); 15928 15929 elsif Atree.Convention 15930 (Designated_Type (Etype (This_Formal))) /= Convention 15931 then 15932 Error_Msg_Name_1 := Pname; 15933 15934 if Convention = Convention_Java then 15935 Error_Msg_N 15936 ("pragma% requires convention 'Cil in designated " 15937 & "type", Parameter_Type (Parent (This_Formal))); 15938 else 15939 Error_Msg_N 15940 ("pragma% requires convention 'Java in designated " 15941 & "type", Parameter_Type (Parent (This_Formal))); 15942 end if; 15943 15944 elsif No (Expression (Parent (This_Formal))) 15945 or else Nkind (Expression (Parent (This_Formal))) /= N_Null 15946 then 15947 Error_Msg_Name_1 := Pname; 15948 Error_Msg_N 15949 ("pragma% requires first formal with default `null`", 15950 Parameter_Type (Parent (This_Formal))); 15951 end if; 15952 end if; 15953 15954 -- Check result type: the constructor must be a function 15955 -- returning: 15956 -- * a value type (only allowed in the CIL compiler) 15957 -- * an access-to-subprogram type with convention Java/CIL 15958 -- * an access-type designating a type that has convention 15959 -- Java/CIL. 15960 15961 if Is_Value_Type (Etype (Def_Id)) then 15962 null; 15963 15964 -- Access-to-subprogram type with convention Java/CIL 15965 15966 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then 15967 if Atree.Convention (Etype (Def_Id)) /= Convention then 15968 if Convention = Convention_Java then 15969 Error_Pragma_Arg 15970 ("pragma% requires function returning a 'Java " 15971 & "access type", Arg1); 15972 else 15973 pragma Assert (Convention = Convention_CIL); 15974 Error_Pragma_Arg 15975 ("pragma% requires function returning a 'C'I'L " 15976 & "access type", Arg1); 15977 end if; 15978 end if; 15979 15980 elsif Ekind (Etype (Def_Id)) in Access_Kind then 15981 if not Ekind_In (Etype (Def_Id), E_Access_Type, 15982 E_General_Access_Type) 15983 or else 15984 Atree.Convention 15985 (Designated_Type (Etype (Def_Id))) /= Convention 15986 then 15987 Error_Msg_Name_1 := Pname; 15988 15989 if Convention = Convention_Java then 15990 Error_Pragma_Arg 15991 ("pragma% requires function returning a named " 15992 & "'Java access type", Arg1); 15993 else 15994 Error_Pragma_Arg 15995 ("pragma% requires function returning a named " 15996 & "'C'I'L access type", Arg1); 15997 end if; 15998 end if; 15999 end if; 16000 16001 Set_Is_Constructor (Def_Id); 16002 Set_Convention (Def_Id, Convention); 16003 Set_Is_Imported (Def_Id); 16004 16005 exit when From_Aspect_Specification (N); 16006 Hom_Id := Homonym (Hom_Id); 16007 16008 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; 16009 end loop; 16010 end Java_Constructor; 16011 16012 ---------------------- 16013 -- Java_Interface -- 16014 ---------------------- 16015 16016 -- pragma Java_Interface ([Entity =>] LOCAL_NAME); 16017 16018 when Pragma_Java_Interface => Java_Interface : declare 16019 Arg : Node_Id; 16020 Typ : Entity_Id; 16021 16022 begin 16023 GNAT_Pragma; 16024 Check_Arg_Count (1); 16025 Check_Optional_Identifier (Arg1, Name_Entity); 16026 Check_Arg_Is_Local_Name (Arg1); 16027 16028 Arg := Get_Pragma_Arg (Arg1); 16029 Analyze (Arg); 16030 16031 if Etype (Arg) = Any_Type then 16032 return; 16033 end if; 16034 16035 if not Is_Entity_Name (Arg) 16036 or else not Is_Type (Entity (Arg)) 16037 then 16038 Error_Pragma_Arg ("pragma% requires a type mark", Arg1); 16039 end if; 16040 16041 Typ := Underlying_Type (Entity (Arg)); 16042 16043 -- For now simply check some of the semantic constraints on the 16044 -- type. This currently leaves out some restrictions on interface 16045 -- types, namely that the parent type must be java.lang.Object.Typ 16046 -- and that all primitives of the type should be declared 16047 -- abstract. ??? 16048 16049 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then 16050 Error_Pragma_Arg 16051 ("pragma% requires an abstract tagged type", Arg1); 16052 16053 elsif not Has_Discriminants (Typ) 16054 or else Ekind (Etype (First_Discriminant (Typ))) 16055 /= E_Anonymous_Access_Type 16056 or else 16057 not Is_Class_Wide_Type 16058 (Designated_Type (Etype (First_Discriminant (Typ)))) 16059 then 16060 Error_Pragma_Arg 16061 ("type must have a class-wide access discriminant", Arg1); 16062 end if; 16063 end Java_Interface; 16064 16065 ---------------- 16066 -- Keep_Names -- 16067 ---------------- 16068 16069 -- pragma Keep_Names ([On => ] local_NAME); 16070 16071 when Pragma_Keep_Names => Keep_Names : declare 16072 Arg : Node_Id; 16073 16074 begin 16075 GNAT_Pragma; 16076 Check_Arg_Count (1); 16077 Check_Optional_Identifier (Arg1, Name_On); 16078 Check_Arg_Is_Local_Name (Arg1); 16079 16080 Arg := Get_Pragma_Arg (Arg1); 16081 Analyze (Arg); 16082 16083 if Etype (Arg) = Any_Type then 16084 return; 16085 end if; 16086 16087 if not Is_Entity_Name (Arg) 16088 or else Ekind (Entity (Arg)) /= E_Enumeration_Type 16089 then 16090 Error_Pragma_Arg 16091 ("pragma% requires a local enumeration type", Arg1); 16092 end if; 16093 16094 Set_Discard_Names (Entity (Arg), False); 16095 end Keep_Names; 16096 16097 ------------- 16098 -- License -- 16099 ------------- 16100 16101 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL); 16102 16103 when Pragma_License => 16104 GNAT_Pragma; 16105 Check_Arg_Count (1); 16106 Check_No_Identifiers; 16107 Check_Valid_Configuration_Pragma; 16108 Check_Arg_Is_Identifier (Arg1); 16109 16110 declare 16111 Sind : constant Source_File_Index := 16112 Source_Index (Current_Sem_Unit); 16113 16114 begin 16115 case Chars (Get_Pragma_Arg (Arg1)) is 16116 when Name_GPL => 16117 Set_License (Sind, GPL); 16118 16119 when Name_Modified_GPL => 16120 Set_License (Sind, Modified_GPL); 16121 16122 when Name_Restricted => 16123 Set_License (Sind, Restricted); 16124 16125 when Name_Unrestricted => 16126 Set_License (Sind, Unrestricted); 16127 16128 when others => 16129 Error_Pragma_Arg ("invalid license name", Arg1); 16130 end case; 16131 end; 16132 16133 --------------- 16134 -- Link_With -- 16135 --------------- 16136 16137 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION}); 16138 16139 when Pragma_Link_With => Link_With : declare 16140 Arg : Node_Id; 16141 16142 begin 16143 GNAT_Pragma; 16144 16145 if Operating_Mode = Generate_Code 16146 and then In_Extended_Main_Source_Unit (N) 16147 then 16148 Check_At_Least_N_Arguments (1); 16149 Check_No_Identifiers; 16150 Check_Is_In_Decl_Part_Or_Package_Spec; 16151 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 16152 Start_String; 16153 16154 Arg := Arg1; 16155 while Present (Arg) loop 16156 Check_Arg_Is_Static_Expression (Arg, Standard_String); 16157 16158 -- Store argument, converting sequences of spaces to a 16159 -- single null character (this is one of the differences 16160 -- in processing between Link_With and Linker_Options). 16161 16162 Arg_Store : declare 16163 C : constant Char_Code := Get_Char_Code (' '); 16164 S : constant String_Id := 16165 Strval (Expr_Value_S (Get_Pragma_Arg (Arg))); 16166 L : constant Nat := String_Length (S); 16167 F : Nat := 1; 16168 16169 procedure Skip_Spaces; 16170 -- Advance F past any spaces 16171 16172 ----------------- 16173 -- Skip_Spaces -- 16174 ----------------- 16175 16176 procedure Skip_Spaces is 16177 begin 16178 while F <= L and then Get_String_Char (S, F) = C loop 16179 F := F + 1; 16180 end loop; 16181 end Skip_Spaces; 16182 16183 -- Start of processing for Arg_Store 16184 16185 begin 16186 Skip_Spaces; -- skip leading spaces 16187 16188 -- Loop through characters, changing any embedded 16189 -- sequence of spaces to a single null character (this 16190 -- is how Link_With/Linker_Options differ) 16191 16192 while F <= L loop 16193 if Get_String_Char (S, F) = C then 16194 Skip_Spaces; 16195 exit when F > L; 16196 Store_String_Char (ASCII.NUL); 16197 16198 else 16199 Store_String_Char (Get_String_Char (S, F)); 16200 F := F + 1; 16201 end if; 16202 end loop; 16203 end Arg_Store; 16204 16205 Arg := Next (Arg); 16206 16207 if Present (Arg) then 16208 Store_String_Char (ASCII.NUL); 16209 end if; 16210 end loop; 16211 16212 Store_Linker_Option_String (End_String); 16213 end if; 16214 end Link_With; 16215 16216 ------------------ 16217 -- Linker_Alias -- 16218 ------------------ 16219 16220 -- pragma Linker_Alias ( 16221 -- [Entity =>] LOCAL_NAME 16222 -- [Target =>] static_string_EXPRESSION); 16223 16224 when Pragma_Linker_Alias => 16225 GNAT_Pragma; 16226 Check_Arg_Order ((Name_Entity, Name_Target)); 16227 Check_Arg_Count (2); 16228 Check_Optional_Identifier (Arg1, Name_Entity); 16229 Check_Optional_Identifier (Arg2, Name_Target); 16230 Check_Arg_Is_Library_Level_Local_Name (Arg1); 16231 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 16232 16233 -- The only processing required is to link this item on to the 16234 -- list of rep items for the given entity. This is accomplished 16235 -- by the call to Rep_Item_Too_Late (when no error is detected 16236 -- and False is returned). 16237 16238 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then 16239 return; 16240 else 16241 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 16242 end if; 16243 16244 ------------------------ 16245 -- Linker_Constructor -- 16246 ------------------------ 16247 16248 -- pragma Linker_Constructor (procedure_LOCAL_NAME); 16249 16250 -- Code is shared with Linker_Destructor 16251 16252 ----------------------- 16253 -- Linker_Destructor -- 16254 ----------------------- 16255 16256 -- pragma Linker_Destructor (procedure_LOCAL_NAME); 16257 16258 when Pragma_Linker_Constructor | 16259 Pragma_Linker_Destructor => 16260 Linker_Constructor : declare 16261 Arg1_X : Node_Id; 16262 Proc : Entity_Id; 16263 16264 begin 16265 GNAT_Pragma; 16266 Check_Arg_Count (1); 16267 Check_No_Identifiers; 16268 Check_Arg_Is_Local_Name (Arg1); 16269 Arg1_X := Get_Pragma_Arg (Arg1); 16270 Analyze (Arg1_X); 16271 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 16272 16273 if not Is_Library_Level_Entity (Proc) then 16274 Error_Pragma_Arg 16275 ("argument for pragma% must be library level entity", Arg1); 16276 end if; 16277 16278 -- The only processing required is to link this item on to the 16279 -- list of rep items for the given entity. This is accomplished 16280 -- by the call to Rep_Item_Too_Late (when no error is detected 16281 -- and False is returned). 16282 16283 if Rep_Item_Too_Late (Proc, N) then 16284 return; 16285 else 16286 Set_Has_Gigi_Rep_Item (Proc); 16287 end if; 16288 end Linker_Constructor; 16289 16290 -------------------- 16291 -- Linker_Options -- 16292 -------------------- 16293 16294 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); 16295 16296 when Pragma_Linker_Options => Linker_Options : declare 16297 Arg : Node_Id; 16298 16299 begin 16300 Check_Ada_83_Warning; 16301 Check_No_Identifiers; 16302 Check_Arg_Count (1); 16303 Check_Is_In_Decl_Part_Or_Package_Spec; 16304 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 16305 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); 16306 16307 Arg := Arg2; 16308 while Present (Arg) loop 16309 Check_Arg_Is_Static_Expression (Arg, Standard_String); 16310 Store_String_Char (ASCII.NUL); 16311 Store_String_Chars 16312 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); 16313 Arg := Next (Arg); 16314 end loop; 16315 16316 if Operating_Mode = Generate_Code 16317 and then In_Extended_Main_Source_Unit (N) 16318 then 16319 Store_Linker_Option_String (End_String); 16320 end if; 16321 end Linker_Options; 16322 16323 -------------------- 16324 -- Linker_Section -- 16325 -------------------- 16326 16327 -- pragma Linker_Section ( 16328 -- [Entity =>] LOCAL_NAME 16329 -- [Section =>] static_string_EXPRESSION); 16330 16331 when Pragma_Linker_Section => Linker_Section : declare 16332 Arg : Node_Id; 16333 Ent : Entity_Id; 16334 16335 begin 16336 GNAT_Pragma; 16337 Check_Arg_Order ((Name_Entity, Name_Section)); 16338 Check_Arg_Count (2); 16339 Check_Optional_Identifier (Arg1, Name_Entity); 16340 Check_Optional_Identifier (Arg2, Name_Section); 16341 Check_Arg_Is_Library_Level_Local_Name (Arg1); 16342 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 16343 16344 -- Check kind of entity 16345 16346 Arg := Get_Pragma_Arg (Arg1); 16347 Ent := Entity (Arg); 16348 16349 case Ekind (Ent) is 16350 16351 -- Objects (constants and variables) and types. For these cases 16352 -- all we need to do is to set the Linker_Section_pragma field. 16353 16354 when E_Constant | E_Variable | Type_Kind => 16355 Set_Linker_Section_Pragma (Ent, N); 16356 16357 -- Subprograms 16358 16359 when Subprogram_Kind => 16360 16361 -- Aspect case, entity already set 16362 16363 if From_Aspect_Specification (N) then 16364 Set_Linker_Section_Pragma 16365 (Entity (Corresponding_Aspect (N)), N); 16366 16367 -- Pragma case, we must climb the homonym chain, but skip 16368 -- any for which the linker section is already set. 16369 16370 else 16371 loop 16372 if No (Linker_Section_Pragma (Ent)) then 16373 Set_Linker_Section_Pragma (Ent, N); 16374 end if; 16375 16376 Ent := Homonym (Ent); 16377 exit when No (Ent) 16378 or else Scope (Ent) /= Current_Scope; 16379 end loop; 16380 end if; 16381 16382 -- All other cases are illegal 16383 16384 when others => 16385 Error_Pragma_Arg 16386 ("pragma% applies only to objects, subprograms, and types", 16387 Arg1); 16388 end case; 16389 end Linker_Section; 16390 16391 ---------- 16392 -- List -- 16393 ---------- 16394 16395 -- pragma List (On | Off) 16396 16397 -- There is nothing to do here, since we did all the processing for 16398 -- this pragma in Par.Prag (so that it works properly even in syntax 16399 -- only mode). 16400 16401 when Pragma_List => 16402 null; 16403 16404 --------------- 16405 -- Lock_Free -- 16406 --------------- 16407 16408 -- pragma Lock_Free [(Boolean_EXPRESSION)]; 16409 16410 when Pragma_Lock_Free => Lock_Free : declare 16411 P : constant Node_Id := Parent (N); 16412 Arg : Node_Id; 16413 Ent : Entity_Id; 16414 Val : Boolean; 16415 16416 begin 16417 Check_No_Identifiers; 16418 Check_At_Most_N_Arguments (1); 16419 16420 -- Protected definition case 16421 16422 if Nkind (P) = N_Protected_Definition then 16423 Ent := Defining_Identifier (Parent (P)); 16424 16425 -- One argument 16426 16427 if Arg_Count = 1 then 16428 Arg := Get_Pragma_Arg (Arg1); 16429 Val := Is_True (Static_Boolean (Arg)); 16430 16431 -- No arguments (expression is considered to be True) 16432 16433 else 16434 Val := True; 16435 end if; 16436 16437 -- Check duplicate pragma before we chain the pragma in the Rep 16438 -- Item chain of Ent. 16439 16440 Check_Duplicate_Pragma (Ent); 16441 Record_Rep_Item (Ent, N); 16442 Set_Uses_Lock_Free (Ent, Val); 16443 16444 -- Anything else is incorrect placement 16445 16446 else 16447 Pragma_Misplaced; 16448 end if; 16449 end Lock_Free; 16450 16451 -------------------- 16452 -- Locking_Policy -- 16453 -------------------- 16454 16455 -- pragma Locking_Policy (policy_IDENTIFIER); 16456 16457 when Pragma_Locking_Policy => declare 16458 subtype LP_Range is Name_Id 16459 range First_Locking_Policy_Name .. Last_Locking_Policy_Name; 16460 LP_Val : LP_Range; 16461 LP : Character; 16462 16463 begin 16464 Check_Ada_83_Warning; 16465 Check_Arg_Count (1); 16466 Check_No_Identifiers; 16467 Check_Arg_Is_Locking_Policy (Arg1); 16468 Check_Valid_Configuration_Pragma; 16469 LP_Val := Chars (Get_Pragma_Arg (Arg1)); 16470 16471 case LP_Val is 16472 when Name_Ceiling_Locking => 16473 LP := 'C'; 16474 when Name_Inheritance_Locking => 16475 LP := 'I'; 16476 when Name_Concurrent_Readers_Locking => 16477 LP := 'R'; 16478 end case; 16479 16480 if Locking_Policy /= ' ' 16481 and then Locking_Policy /= LP 16482 then 16483 Error_Msg_Sloc := Locking_Policy_Sloc; 16484 Error_Pragma ("locking policy incompatible with policy#"); 16485 16486 -- Set new policy, but always preserve System_Location since we 16487 -- like the error message with the run time name. 16488 16489 else 16490 Locking_Policy := LP; 16491 16492 if Locking_Policy_Sloc /= System_Location then 16493 Locking_Policy_Sloc := Loc; 16494 end if; 16495 end if; 16496 end; 16497 16498 ---------------- 16499 -- Long_Float -- 16500 ---------------- 16501 16502 -- pragma Long_Float (D_Float | G_Float); 16503 16504 when Pragma_Long_Float => Long_Float : declare 16505 begin 16506 GNAT_Pragma; 16507 Check_Valid_Configuration_Pragma; 16508 Check_Arg_Count (1); 16509 Check_No_Identifier (Arg1); 16510 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float); 16511 16512 if not OpenVMS_On_Target then 16513 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)"); 16514 end if; 16515 16516 -- D_Float case 16517 16518 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then 16519 if Opt.Float_Format_Long = 'G' then 16520 Error_Pragma_Arg 16521 ("G_Float previously specified", Arg1); 16522 16523 elsif Current_Sem_Unit /= Main_Unit 16524 and then Opt.Float_Format_Long /= 'D' 16525 then 16526 Error_Pragma_Arg 16527 ("main unit not compiled with pragma Long_Float (D_Float)", 16528 "\pragma% must be used consistently for whole partition", 16529 Arg1); 16530 16531 else 16532 Opt.Float_Format_Long := 'D'; 16533 end if; 16534 16535 -- G_Float case (this is the default, does not need overriding) 16536 16537 else 16538 if Opt.Float_Format_Long = 'D' then 16539 Error_Pragma ("D_Float previously specified"); 16540 16541 elsif Current_Sem_Unit /= Main_Unit 16542 and then Opt.Float_Format_Long /= 'G' 16543 then 16544 Error_Pragma_Arg 16545 ("main unit not compiled with pragma Long_Float (G_Float)", 16546 "\pragma% must be used consistently for whole partition", 16547 Arg1); 16548 16549 else 16550 Opt.Float_Format_Long := 'G'; 16551 end if; 16552 end if; 16553 16554 Set_Standard_Fpt_Formats; 16555 end Long_Float; 16556 16557 ------------------- 16558 -- Loop_Optimize -- 16559 ------------------- 16560 16561 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } ); 16562 16563 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector 16564 16565 when Pragma_Loop_Optimize => Loop_Optimize : declare 16566 Hint : Node_Id; 16567 16568 begin 16569 GNAT_Pragma; 16570 Check_At_Least_N_Arguments (1); 16571 Check_No_Identifiers; 16572 16573 Hint := First (Pragma_Argument_Associations (N)); 16574 while Present (Hint) loop 16575 Check_Arg_Is_One_Of (Hint, 16576 Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector); 16577 Next (Hint); 16578 end loop; 16579 16580 Check_Loop_Pragma_Placement; 16581 end Loop_Optimize; 16582 16583 ------------------ 16584 -- Loop_Variant -- 16585 ------------------ 16586 16587 -- pragma Loop_Variant 16588 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } ); 16589 16590 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION 16591 16592 -- CHANGE_DIRECTION ::= Increases | Decreases 16593 16594 when Pragma_Loop_Variant => Loop_Variant : declare 16595 Variant : Node_Id; 16596 16597 begin 16598 GNAT_Pragma; 16599 Check_At_Least_N_Arguments (1); 16600 Check_Loop_Pragma_Placement; 16601 16602 -- Process all increasing / decreasing expressions 16603 16604 Variant := First (Pragma_Argument_Associations (N)); 16605 while Present (Variant) loop 16606 if not Nam_In (Chars (Variant), Name_Decreases, 16607 Name_Increases) 16608 then 16609 Error_Pragma_Arg ("wrong change modifier", Variant); 16610 end if; 16611 16612 Preanalyze_Assert_Expression 16613 (Expression (Variant), Any_Discrete); 16614 16615 Next (Variant); 16616 end loop; 16617 end Loop_Variant; 16618 16619 ----------------------- 16620 -- Machine_Attribute -- 16621 ----------------------- 16622 16623 -- pragma Machine_Attribute ( 16624 -- [Entity =>] LOCAL_NAME, 16625 -- [Attribute_Name =>] static_string_EXPRESSION 16626 -- [, [Info =>] static_EXPRESSION] ); 16627 16628 when Pragma_Machine_Attribute => Machine_Attribute : declare 16629 Def_Id : Entity_Id; 16630 16631 begin 16632 GNAT_Pragma; 16633 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info)); 16634 16635 if Arg_Count = 3 then 16636 Check_Optional_Identifier (Arg3, Name_Info); 16637 Check_Arg_Is_Static_Expression (Arg3); 16638 else 16639 Check_Arg_Count (2); 16640 end if; 16641 16642 Check_Optional_Identifier (Arg1, Name_Entity); 16643 Check_Optional_Identifier (Arg2, Name_Attribute_Name); 16644 Check_Arg_Is_Local_Name (Arg1); 16645 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 16646 Def_Id := Entity (Get_Pragma_Arg (Arg1)); 16647 16648 if Is_Access_Type (Def_Id) then 16649 Def_Id := Designated_Type (Def_Id); 16650 end if; 16651 16652 if Rep_Item_Too_Early (Def_Id, N) then 16653 return; 16654 end if; 16655 16656 Def_Id := Underlying_Type (Def_Id); 16657 16658 -- The only processing required is to link this item on to the 16659 -- list of rep items for the given entity. This is accomplished 16660 -- by the call to Rep_Item_Too_Late (when no error is detected 16661 -- and False is returned). 16662 16663 if Rep_Item_Too_Late (Def_Id, N) then 16664 return; 16665 else 16666 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 16667 end if; 16668 end Machine_Attribute; 16669 16670 ---------- 16671 -- Main -- 16672 ---------- 16673 16674 -- pragma Main 16675 -- (MAIN_OPTION [, MAIN_OPTION]); 16676 16677 -- MAIN_OPTION ::= 16678 -- [STACK_SIZE =>] static_integer_EXPRESSION 16679 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION 16680 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION 16681 16682 when Pragma_Main => Main : declare 16683 Args : Args_List (1 .. 3); 16684 Names : constant Name_List (1 .. 3) := ( 16685 Name_Stack_Size, 16686 Name_Task_Stack_Size_Default, 16687 Name_Time_Slicing_Enabled); 16688 16689 Nod : Node_Id; 16690 16691 begin 16692 GNAT_Pragma; 16693 Gather_Associations (Names, Args); 16694 16695 for J in 1 .. 2 loop 16696 if Present (Args (J)) then 16697 Check_Arg_Is_Static_Expression (Args (J), Any_Integer); 16698 end if; 16699 end loop; 16700 16701 if Present (Args (3)) then 16702 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean); 16703 end if; 16704 16705 Nod := Next (N); 16706 while Present (Nod) loop 16707 if Nkind (Nod) = N_Pragma 16708 and then Pragma_Name (Nod) = Name_Main 16709 then 16710 Error_Msg_Name_1 := Pname; 16711 Error_Msg_N ("duplicate pragma% not permitted", Nod); 16712 end if; 16713 16714 Next (Nod); 16715 end loop; 16716 end Main; 16717 16718 ------------------ 16719 -- Main_Storage -- 16720 ------------------ 16721 16722 -- pragma Main_Storage 16723 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); 16724 16725 -- MAIN_STORAGE_OPTION ::= 16726 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION 16727 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION 16728 16729 when Pragma_Main_Storage => Main_Storage : declare 16730 Args : Args_List (1 .. 2); 16731 Names : constant Name_List (1 .. 2) := ( 16732 Name_Working_Storage, 16733 Name_Top_Guard); 16734 16735 Nod : Node_Id; 16736 16737 begin 16738 GNAT_Pragma; 16739 Gather_Associations (Names, Args); 16740 16741 for J in 1 .. 2 loop 16742 if Present (Args (J)) then 16743 Check_Arg_Is_Static_Expression (Args (J), Any_Integer); 16744 end if; 16745 end loop; 16746 16747 Check_In_Main_Program; 16748 16749 Nod := Next (N); 16750 while Present (Nod) loop 16751 if Nkind (Nod) = N_Pragma 16752 and then Pragma_Name (Nod) = Name_Main_Storage 16753 then 16754 Error_Msg_Name_1 := Pname; 16755 Error_Msg_N ("duplicate pragma% not permitted", Nod); 16756 end if; 16757 16758 Next (Nod); 16759 end loop; 16760 end Main_Storage; 16761 16762 ----------------- 16763 -- Memory_Size -- 16764 ----------------- 16765 16766 -- pragma Memory_Size (NUMERIC_LITERAL) 16767 16768 when Pragma_Memory_Size => 16769 GNAT_Pragma; 16770 16771 -- Memory size is simply ignored 16772 16773 Check_No_Identifiers; 16774 Check_Arg_Count (1); 16775 Check_Arg_Is_Integer_Literal (Arg1); 16776 16777 ------------- 16778 -- No_Body -- 16779 ------------- 16780 16781 -- pragma No_Body; 16782 16783 -- The only correct use of this pragma is on its own in a file, in 16784 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body 16785 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to 16786 -- check for a file containing nothing but a No_Body pragma). If we 16787 -- attempt to process it during normal semantics processing, it means 16788 -- it was misplaced. 16789 16790 when Pragma_No_Body => 16791 GNAT_Pragma; 16792 Pragma_Misplaced; 16793 16794 --------------- 16795 -- No_Inline -- 16796 --------------- 16797 16798 -- pragma No_Inline ( NAME {, NAME} ); 16799 16800 when Pragma_No_Inline => 16801 GNAT_Pragma; 16802 Process_Inline (Suppressed); 16803 16804 --------------- 16805 -- No_Return -- 16806 --------------- 16807 16808 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name}); 16809 16810 when Pragma_No_Return => No_Return : declare 16811 Id : Node_Id; 16812 E : Entity_Id; 16813 Found : Boolean; 16814 Arg : Node_Id; 16815 16816 begin 16817 Ada_2005_Pragma; 16818 Check_At_Least_N_Arguments (1); 16819 16820 -- Loop through arguments of pragma 16821 16822 Arg := Arg1; 16823 while Present (Arg) loop 16824 Check_Arg_Is_Local_Name (Arg); 16825 Id := Get_Pragma_Arg (Arg); 16826 Analyze (Id); 16827 16828 if not Is_Entity_Name (Id) then 16829 Error_Pragma_Arg ("entity name required", Arg); 16830 end if; 16831 16832 if Etype (Id) = Any_Type then 16833 raise Pragma_Exit; 16834 end if; 16835 16836 -- Loop to find matching procedures 16837 16838 E := Entity (Id); 16839 Found := False; 16840 while Present (E) 16841 and then Scope (E) = Current_Scope 16842 loop 16843 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then 16844 Set_No_Return (E); 16845 16846 -- Set flag on any alias as well 16847 16848 if Is_Overloadable (E) and then Present (Alias (E)) then 16849 Set_No_Return (Alias (E)); 16850 end if; 16851 16852 Found := True; 16853 end if; 16854 16855 exit when From_Aspect_Specification (N); 16856 E := Homonym (E); 16857 end loop; 16858 16859 -- If entity in not in current scope it may be the enclosing 16860 -- suprogram body to which the aspect applies. 16861 16862 if not Found then 16863 if Entity (Id) = Current_Scope 16864 and then From_Aspect_Specification (N) 16865 then 16866 Set_No_Return (Entity (Id)); 16867 else 16868 Error_Pragma_Arg ("no procedure& found for pragma%", Arg); 16869 end if; 16870 end if; 16871 16872 Next (Arg); 16873 end loop; 16874 end No_Return; 16875 16876 ----------------- 16877 -- No_Run_Time -- 16878 ----------------- 16879 16880 -- pragma No_Run_Time; 16881 16882 -- Note: this pragma is retained for backwards compatibility. See 16883 -- body of Rtsfind for full details on its handling. 16884 16885 when Pragma_No_Run_Time => 16886 GNAT_Pragma; 16887 Check_Valid_Configuration_Pragma; 16888 Check_Arg_Count (0); 16889 16890 No_Run_Time_Mode := True; 16891 Configurable_Run_Time_Mode := True; 16892 16893 -- Set Duration to 32 bits if word size is 32 16894 16895 if Ttypes.System_Word_Size = 32 then 16896 Duration_32_Bits_On_Target := True; 16897 end if; 16898 16899 -- Set appropriate restrictions 16900 16901 Set_Restriction (No_Finalization, N); 16902 Set_Restriction (No_Exception_Handlers, N); 16903 Set_Restriction (Max_Tasks, N, 0); 16904 Set_Restriction (No_Tasking, N); 16905 16906 ------------------------ 16907 -- No_Strict_Aliasing -- 16908 ------------------------ 16909 16910 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; 16911 16912 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare 16913 E_Id : Entity_Id; 16914 16915 begin 16916 GNAT_Pragma; 16917 Check_At_Most_N_Arguments (1); 16918 16919 if Arg_Count = 0 then 16920 Check_Valid_Configuration_Pragma; 16921 Opt.No_Strict_Aliasing := True; 16922 16923 else 16924 Check_Optional_Identifier (Arg2, Name_Entity); 16925 Check_Arg_Is_Local_Name (Arg1); 16926 E_Id := Entity (Get_Pragma_Arg (Arg1)); 16927 16928 if E_Id = Any_Type then 16929 return; 16930 elsif No (E_Id) or else not Is_Access_Type (E_Id) then 16931 Error_Pragma_Arg ("pragma% requires access type", Arg1); 16932 end if; 16933 16934 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); 16935 end if; 16936 end No_Strict_Aliasing; 16937 16938 ----------------------- 16939 -- Normalize_Scalars -- 16940 ----------------------- 16941 16942 -- pragma Normalize_Scalars; 16943 16944 when Pragma_Normalize_Scalars => 16945 Check_Ada_83_Warning; 16946 Check_Arg_Count (0); 16947 Check_Valid_Configuration_Pragma; 16948 16949 -- Normalize_Scalars creates false positives in CodePeer, and 16950 -- incorrect negative results in GNATprove mode, so ignore this 16951 -- pragma in these modes. 16952 16953 if not (CodePeer_Mode or GNATprove_Mode) then 16954 Normalize_Scalars := True; 16955 Init_Or_Norm_Scalars := True; 16956 end if; 16957 16958 ----------------- 16959 -- Obsolescent -- 16960 ----------------- 16961 16962 -- pragma Obsolescent; 16963 16964 -- pragma Obsolescent ( 16965 -- [Message =>] static_string_EXPRESSION 16966 -- [,[Version =>] Ada_05]]); 16967 16968 -- pragma Obsolescent ( 16969 -- [Entity =>] NAME 16970 -- [,[Message =>] static_string_EXPRESSION 16971 -- [,[Version =>] Ada_05]] ); 16972 16973 when Pragma_Obsolescent => Obsolescent : declare 16974 Ename : Node_Id; 16975 Decl : Node_Id; 16976 16977 procedure Set_Obsolescent (E : Entity_Id); 16978 -- Given an entity Ent, mark it as obsolescent if appropriate 16979 16980 --------------------- 16981 -- Set_Obsolescent -- 16982 --------------------- 16983 16984 procedure Set_Obsolescent (E : Entity_Id) is 16985 Active : Boolean; 16986 Ent : Entity_Id; 16987 S : String_Id; 16988 16989 begin 16990 Active := True; 16991 Ent := E; 16992 16993 -- Entity name was given 16994 16995 if Present (Ename) then 16996 16997 -- If entity name matches, we are fine. Save entity in 16998 -- pragma argument, for ASIS use. 16999 17000 if Chars (Ename) = Chars (Ent) then 17001 Set_Entity (Ename, Ent); 17002 Generate_Reference (Ent, Ename); 17003 17004 -- If entity name does not match, only possibility is an 17005 -- enumeration literal from an enumeration type declaration. 17006 17007 elsif Ekind (Ent) /= E_Enumeration_Type then 17008 Error_Pragma 17009 ("pragma % entity name does not match declaration"); 17010 17011 else 17012 Ent := First_Literal (E); 17013 loop 17014 if No (Ent) then 17015 Error_Pragma 17016 ("pragma % entity name does not match any " 17017 & "enumeration literal"); 17018 17019 elsif Chars (Ent) = Chars (Ename) then 17020 Set_Entity (Ename, Ent); 17021 Generate_Reference (Ent, Ename); 17022 exit; 17023 17024 else 17025 Ent := Next_Literal (Ent); 17026 end if; 17027 end loop; 17028 end if; 17029 end if; 17030 17031 -- Ent points to entity to be marked 17032 17033 if Arg_Count >= 1 then 17034 17035 -- Deal with static string argument 17036 17037 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 17038 S := Strval (Get_Pragma_Arg (Arg1)); 17039 17040 for J in 1 .. String_Length (S) loop 17041 if not In_Character_Range (Get_String_Char (S, J)) then 17042 Error_Pragma_Arg 17043 ("pragma% argument does not allow wide characters", 17044 Arg1); 17045 end if; 17046 end loop; 17047 17048 Obsolescent_Warnings.Append 17049 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1)))); 17050 17051 -- Check for Ada_05 parameter 17052 17053 if Arg_Count /= 1 then 17054 Check_Arg_Count (2); 17055 17056 declare 17057 Argx : constant Node_Id := Get_Pragma_Arg (Arg2); 17058 17059 begin 17060 Check_Arg_Is_Identifier (Argx); 17061 17062 if Chars (Argx) /= Name_Ada_05 then 17063 Error_Msg_Name_2 := Name_Ada_05; 17064 Error_Pragma_Arg 17065 ("only allowed argument for pragma% is %", Argx); 17066 end if; 17067 17068 if Ada_Version_Explicit < Ada_2005 17069 or else not Warn_On_Ada_2005_Compatibility 17070 then 17071 Active := False; 17072 end if; 17073 end; 17074 end if; 17075 end if; 17076 17077 -- Set flag if pragma active 17078 17079 if Active then 17080 Set_Is_Obsolescent (Ent); 17081 end if; 17082 17083 return; 17084 end Set_Obsolescent; 17085 17086 -- Start of processing for pragma Obsolescent 17087 17088 begin 17089 GNAT_Pragma; 17090 17091 Check_At_Most_N_Arguments (3); 17092 17093 -- See if first argument specifies an entity name 17094 17095 if Arg_Count >= 1 17096 and then 17097 (Chars (Arg1) = Name_Entity 17098 or else 17099 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, 17100 N_Identifier, 17101 N_Operator_Symbol)) 17102 then 17103 Ename := Get_Pragma_Arg (Arg1); 17104 17105 -- Eliminate first argument, so we can share processing 17106 17107 Arg1 := Arg2; 17108 Arg2 := Arg3; 17109 Arg_Count := Arg_Count - 1; 17110 17111 -- No Entity name argument given 17112 17113 else 17114 Ename := Empty; 17115 end if; 17116 17117 if Arg_Count >= 1 then 17118 Check_Optional_Identifier (Arg1, Name_Message); 17119 17120 if Arg_Count = 2 then 17121 Check_Optional_Identifier (Arg2, Name_Version); 17122 end if; 17123 end if; 17124 17125 -- Get immediately preceding declaration 17126 17127 Decl := Prev (N); 17128 while Present (Decl) and then Nkind (Decl) = N_Pragma loop 17129 Prev (Decl); 17130 end loop; 17131 17132 -- Cases where we do not follow anything other than another pragma 17133 17134 if No (Decl) then 17135 17136 -- First case: library level compilation unit declaration with 17137 -- the pragma immediately following the declaration. 17138 17139 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 17140 Set_Obsolescent 17141 (Defining_Entity (Unit (Parent (Parent (N))))); 17142 return; 17143 17144 -- Case 2: library unit placement for package 17145 17146 else 17147 declare 17148 Ent : constant Entity_Id := Find_Lib_Unit_Name; 17149 begin 17150 if Is_Package_Or_Generic_Package (Ent) then 17151 Set_Obsolescent (Ent); 17152 return; 17153 end if; 17154 end; 17155 end if; 17156 17157 -- Cases where we must follow a declaration 17158 17159 else 17160 if Nkind (Decl) not in N_Declaration 17161 and then Nkind (Decl) not in N_Later_Decl_Item 17162 and then Nkind (Decl) not in N_Generic_Declaration 17163 and then Nkind (Decl) not in N_Renaming_Declaration 17164 then 17165 Error_Pragma 17166 ("pragma% misplaced, " 17167 & "must immediately follow a declaration"); 17168 17169 else 17170 Set_Obsolescent (Defining_Entity (Decl)); 17171 return; 17172 end if; 17173 end if; 17174 end Obsolescent; 17175 17176 -------------- 17177 -- Optimize -- 17178 -------------- 17179 17180 -- pragma Optimize (Time | Space | Off); 17181 17182 -- The actual check for optimize is done in Gigi. Note that this 17183 -- pragma does not actually change the optimization setting, it 17184 -- simply checks that it is consistent with the pragma. 17185 17186 when Pragma_Optimize => 17187 Check_No_Identifiers; 17188 Check_Arg_Count (1); 17189 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); 17190 17191 ------------------------ 17192 -- Optimize_Alignment -- 17193 ------------------------ 17194 17195 -- pragma Optimize_Alignment (Time | Space | Off); 17196 17197 when Pragma_Optimize_Alignment => Optimize_Alignment : begin 17198 GNAT_Pragma; 17199 Check_No_Identifiers; 17200 Check_Arg_Count (1); 17201 Check_Valid_Configuration_Pragma; 17202 17203 declare 17204 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 17205 begin 17206 case Nam is 17207 when Name_Time => 17208 Opt.Optimize_Alignment := 'T'; 17209 when Name_Space => 17210 Opt.Optimize_Alignment := 'S'; 17211 when Name_Off => 17212 Opt.Optimize_Alignment := 'O'; 17213 when others => 17214 Error_Pragma_Arg ("invalid argument for pragma%", Arg1); 17215 end case; 17216 end; 17217 17218 -- Set indication that mode is set locally. If we are in fact in a 17219 -- configuration pragma file, this setting is harmless since the 17220 -- switch will get reset anyway at the start of each unit. 17221 17222 Optimize_Alignment_Local := True; 17223 end Optimize_Alignment; 17224 17225 ------------- 17226 -- Ordered -- 17227 ------------- 17228 17229 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); 17230 17231 when Pragma_Ordered => Ordered : declare 17232 Assoc : constant Node_Id := Arg1; 17233 Type_Id : Node_Id; 17234 Typ : Entity_Id; 17235 17236 begin 17237 GNAT_Pragma; 17238 Check_No_Identifiers; 17239 Check_Arg_Count (1); 17240 Check_Arg_Is_Local_Name (Arg1); 17241 17242 Type_Id := Get_Pragma_Arg (Assoc); 17243 Find_Type (Type_Id); 17244 Typ := Entity (Type_Id); 17245 17246 if Typ = Any_Type then 17247 return; 17248 else 17249 Typ := Underlying_Type (Typ); 17250 end if; 17251 17252 if not Is_Enumeration_Type (Typ) then 17253 Error_Pragma ("pragma% must specify enumeration type"); 17254 end if; 17255 17256 Check_First_Subtype (Arg1); 17257 Set_Has_Pragma_Ordered (Base_Type (Typ)); 17258 end Ordered; 17259 17260 ------------------- 17261 -- Overflow_Mode -- 17262 ------------------- 17263 17264 -- pragma Overflow_Mode 17265 -- ([General => ] MODE [, [Assertions => ] MODE]); 17266 17267 -- MODE := STRICT | MINIMIZED | ELIMINATED 17268 17269 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64 17270 -- since System.Bignums makes this assumption. This is true of nearly 17271 -- all (all?) targets. 17272 17273 when Pragma_Overflow_Mode => Overflow_Mode : declare 17274 function Get_Overflow_Mode 17275 (Name : Name_Id; 17276 Arg : Node_Id) return Overflow_Mode_Type; 17277 -- Function to process one pragma argument, Arg. If an identifier 17278 -- is present, it must be Name. Mode type is returned if a valid 17279 -- argument exists, otherwise an error is signalled. 17280 17281 ----------------------- 17282 -- Get_Overflow_Mode -- 17283 ----------------------- 17284 17285 function Get_Overflow_Mode 17286 (Name : Name_Id; 17287 Arg : Node_Id) return Overflow_Mode_Type 17288 is 17289 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 17290 17291 begin 17292 Check_Optional_Identifier (Arg, Name); 17293 Check_Arg_Is_Identifier (Argx); 17294 17295 if Chars (Argx) = Name_Strict then 17296 return Strict; 17297 17298 elsif Chars (Argx) = Name_Minimized then 17299 return Minimized; 17300 17301 elsif Chars (Argx) = Name_Eliminated then 17302 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then 17303 Error_Pragma_Arg 17304 ("Eliminated not implemented on this target", Argx); 17305 else 17306 return Eliminated; 17307 end if; 17308 17309 else 17310 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 17311 end if; 17312 end Get_Overflow_Mode; 17313 17314 -- Start of processing for Overflow_Mode 17315 17316 begin 17317 GNAT_Pragma; 17318 Check_At_Least_N_Arguments (1); 17319 Check_At_Most_N_Arguments (2); 17320 17321 -- Process first argument 17322 17323 Scope_Suppress.Overflow_Mode_General := 17324 Get_Overflow_Mode (Name_General, Arg1); 17325 17326 -- Case of only one argument 17327 17328 if Arg_Count = 1 then 17329 Scope_Suppress.Overflow_Mode_Assertions := 17330 Scope_Suppress.Overflow_Mode_General; 17331 17332 -- Case of two arguments present 17333 17334 else 17335 Scope_Suppress.Overflow_Mode_Assertions := 17336 Get_Overflow_Mode (Name_Assertions, Arg2); 17337 end if; 17338 end Overflow_Mode; 17339 17340 -------------------------- 17341 -- Overriding Renamings -- 17342 -------------------------- 17343 17344 -- pragma Overriding_Renamings; 17345 17346 when Pragma_Overriding_Renamings => 17347 GNAT_Pragma; 17348 Check_Arg_Count (0); 17349 Check_Valid_Configuration_Pragma; 17350 Overriding_Renamings := True; 17351 17352 ---------- 17353 -- Pack -- 17354 ---------- 17355 17356 -- pragma Pack (first_subtype_LOCAL_NAME); 17357 17358 when Pragma_Pack => Pack : declare 17359 Assoc : constant Node_Id := Arg1; 17360 Type_Id : Node_Id; 17361 Typ : Entity_Id; 17362 Ctyp : Entity_Id; 17363 Ignore : Boolean := False; 17364 17365 begin 17366 Check_No_Identifiers; 17367 Check_Arg_Count (1); 17368 Check_Arg_Is_Local_Name (Arg1); 17369 17370 Type_Id := Get_Pragma_Arg (Assoc); 17371 Find_Type (Type_Id); 17372 Typ := Entity (Type_Id); 17373 17374 if Typ = Any_Type 17375 or else Rep_Item_Too_Early (Typ, N) 17376 then 17377 return; 17378 else 17379 Typ := Underlying_Type (Typ); 17380 end if; 17381 17382 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then 17383 Error_Pragma ("pragma% must specify array or record type"); 17384 end if; 17385 17386 Check_First_Subtype (Arg1); 17387 Check_Duplicate_Pragma (Typ); 17388 17389 -- Array type 17390 17391 if Is_Array_Type (Typ) then 17392 Ctyp := Component_Type (Typ); 17393 17394 -- Ignore pack that does nothing 17395 17396 if Known_Static_Esize (Ctyp) 17397 and then Known_Static_RM_Size (Ctyp) 17398 and then Esize (Ctyp) = RM_Size (Ctyp) 17399 and then Addressable (Esize (Ctyp)) 17400 then 17401 Ignore := True; 17402 end if; 17403 17404 -- Process OK pragma Pack. Note that if there is a separate 17405 -- component clause present, the Pack will be cancelled. This 17406 -- processing is in Freeze. 17407 17408 if not Rep_Item_Too_Late (Typ, N) then 17409 17410 -- In CodePeer mode, we do not need complex front-end 17411 -- expansions related to pragma Pack, so disable handling 17412 -- of pragma Pack. 17413 17414 if CodePeer_Mode then 17415 null; 17416 17417 -- Don't attempt any packing for VM targets. We possibly 17418 -- could deal with some cases of array bit-packing, but we 17419 -- don't bother, since this is not a typical kind of 17420 -- representation in the VM context anyway (and would not 17421 -- for example work nicely with the debugger). 17422 17423 elsif VM_Target /= No_VM then 17424 if not GNAT_Mode then 17425 Error_Pragma 17426 ("??pragma% ignored in this configuration"); 17427 end if; 17428 17429 -- Normal case where we do the pack action 17430 17431 else 17432 if not Ignore then 17433 Set_Is_Packed (Base_Type (Typ)); 17434 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 17435 end if; 17436 17437 Set_Has_Pragma_Pack (Base_Type (Typ)); 17438 end if; 17439 end if; 17440 17441 -- For record types, the pack is always effective 17442 17443 else pragma Assert (Is_Record_Type (Typ)); 17444 if not Rep_Item_Too_Late (Typ, N) then 17445 17446 -- Ignore pack request with warning in VM mode (skip warning 17447 -- if we are compiling GNAT run time library). 17448 17449 if VM_Target /= No_VM then 17450 if not GNAT_Mode then 17451 Error_Pragma 17452 ("??pragma% ignored in this configuration"); 17453 end if; 17454 17455 -- Normal case of pack request active 17456 17457 else 17458 Set_Is_Packed (Base_Type (Typ)); 17459 Set_Has_Pragma_Pack (Base_Type (Typ)); 17460 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 17461 end if; 17462 end if; 17463 end if; 17464 end Pack; 17465 17466 ---------- 17467 -- Page -- 17468 ---------- 17469 17470 -- pragma Page; 17471 17472 -- There is nothing to do here, since we did all the processing for 17473 -- this pragma in Par.Prag (so that it works properly even in syntax 17474 -- only mode). 17475 17476 when Pragma_Page => 17477 null; 17478 17479 ------------- 17480 -- Part_Of -- 17481 ------------- 17482 17483 -- pragma Part_Of (ABSTRACT_STATE); 17484 17485 -- ABSTRACT_STATE ::= name 17486 17487 when Pragma_Part_Of => Part_Of : declare 17488 procedure Propagate_Part_Of 17489 (Pack_Id : Entity_Id; 17490 State_Id : Entity_Id; 17491 Instance : Node_Id); 17492 -- Propagate the Part_Of indicator to all abstract states and 17493 -- variables declared in the visible state space of a package 17494 -- denoted by Pack_Id. State_Id is the encapsulating state. 17495 -- Instance is the package instantiation node. 17496 17497 ----------------------- 17498 -- Propagate_Part_Of -- 17499 ----------------------- 17500 17501 procedure Propagate_Part_Of 17502 (Pack_Id : Entity_Id; 17503 State_Id : Entity_Id; 17504 Instance : Node_Id) 17505 is 17506 Has_Item : Boolean := False; 17507 -- Flag set when the visible state space contains at least one 17508 -- abstract state or variable. 17509 17510 procedure Propagate_Part_Of (Pack_Id : Entity_Id); 17511 -- Propagate the Part_Of indicator to all abstract states and 17512 -- variables declared in the visible state space of a package 17513 -- denoted by Pack_Id. 17514 17515 ----------------------- 17516 -- Propagate_Part_Of -- 17517 ----------------------- 17518 17519 procedure Propagate_Part_Of (Pack_Id : Entity_Id) is 17520 Item_Id : Entity_Id; 17521 17522 begin 17523 -- Traverse the entity chain of the package and set relevant 17524 -- attributes of abstract states and variables declared in 17525 -- the visible state space of the package. 17526 17527 Item_Id := First_Entity (Pack_Id); 17528 while Present (Item_Id) 17529 and then not In_Private_Part (Item_Id) 17530 loop 17531 -- Do not consider internally generated items 17532 17533 if not Comes_From_Source (Item_Id) then 17534 null; 17535 17536 -- The Part_Of indicator turns an abstract state or 17537 -- variable into a constituent of the encapsulating 17538 -- state. 17539 17540 elsif Ekind_In (Item_Id, E_Abstract_State, 17541 E_Variable) 17542 then 17543 Has_Item := True; 17544 17545 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id)); 17546 Set_Encapsulating_State (Item_Id, State_Id); 17547 17548 -- Recursively handle nested packages and instantiations 17549 17550 elsif Ekind (Item_Id) = E_Package then 17551 Propagate_Part_Of (Item_Id); 17552 end if; 17553 17554 Next_Entity (Item_Id); 17555 end loop; 17556 end Propagate_Part_Of; 17557 17558 -- Start of processing for Propagate_Part_Of 17559 17560 begin 17561 Propagate_Part_Of (Pack_Id); 17562 17563 -- Detect a package instantiation that is subject to a Part_Of 17564 -- indicator, but has no visible state. 17565 17566 if not Has_Item then 17567 Error_Msg_NE 17568 ("package instantiation & has Part_Of indicator but " 17569 & "lacks visible state", Instance, Pack_Id); 17570 end if; 17571 end Propagate_Part_Of; 17572 17573 -- Local variables 17574 17575 Item_Id : Entity_Id; 17576 Legal : Boolean; 17577 State : Node_Id; 17578 State_Id : Entity_Id; 17579 Stmt : Node_Id; 17580 17581 -- Start of processing for Part_Of 17582 17583 begin 17584 GNAT_Pragma; 17585 Check_Arg_Count (1); 17586 17587 -- Ensure the proper placement of the pragma. Part_Of must appear 17588 -- on a variable declaration or a package instantiation. 17589 17590 Stmt := Prev (N); 17591 while Present (Stmt) loop 17592 17593 -- Skip prior pragmas, but check for duplicates 17594 17595 if Nkind (Stmt) = N_Pragma then 17596 if Pragma_Name (Stmt) = Pname then 17597 Error_Msg_Name_1 := Pname; 17598 Error_Msg_Sloc := Sloc (Stmt); 17599 Error_Msg_N ("pragma% duplicates pragma declared#", N); 17600 end if; 17601 17602 -- Skip internally generated code 17603 17604 elsif not Comes_From_Source (Stmt) then 17605 null; 17606 17607 -- The pragma applies to an object declaration (possibly a 17608 -- variable) or a package instantiation. Stop the traversal 17609 -- and continue the analysis. 17610 17611 elsif Nkind_In (Stmt, N_Object_Declaration, 17612 N_Package_Instantiation) 17613 then 17614 exit; 17615 17616 -- The pragma does not apply to a legal construct, issue an 17617 -- error and stop the analysis. 17618 17619 else 17620 Pragma_Misplaced; 17621 return; 17622 end if; 17623 17624 Stmt := Prev (Stmt); 17625 end loop; 17626 17627 -- When the context is an object declaration, ensure that we are 17628 -- dealing with a variable. 17629 17630 if Nkind (Stmt) = N_Object_Declaration 17631 and then Ekind (Defining_Entity (Stmt)) /= E_Variable 17632 then 17633 Error_Msg_N ("indicator Part_Of must apply to a variable", N); 17634 return; 17635 end if; 17636 17637 -- Extract the entity of the related object declaration or package 17638 -- instantiation. In the case of the instantiation, use the entity 17639 -- of the instance spec. 17640 17641 if Nkind (Stmt) = N_Package_Instantiation then 17642 Stmt := Instance_Spec (Stmt); 17643 end if; 17644 17645 Item_Id := Defining_Entity (Stmt); 17646 State := Get_Pragma_Arg (Arg1); 17647 17648 -- Detect any discrepancies between the placement of the object 17649 -- or package instantiation with respect to state space and the 17650 -- encapsulating state. 17651 17652 Analyze_Part_Of 17653 (Item_Id => Item_Id, 17654 State => State, 17655 Indic => N, 17656 Legal => Legal); 17657 17658 if Legal then 17659 State_Id := Entity (State); 17660 17661 -- Add the pragma to the contract of the item. This aids with 17662 -- the detection of a missing but required Part_Of indicator. 17663 17664 Add_Contract_Item (N, Item_Id); 17665 17666 -- The Part_Of indicator turns a variable into a constituent 17667 -- of the encapsulating state. 17668 17669 if Ekind (Item_Id) = E_Variable then 17670 Append_Elmt (Item_Id, Part_Of_Constituents (State_Id)); 17671 Set_Encapsulating_State (Item_Id, State_Id); 17672 17673 -- Propagate the Part_Of indicator to the visible state space 17674 -- of the package instantiation. 17675 17676 else 17677 Propagate_Part_Of 17678 (Pack_Id => Item_Id, 17679 State_Id => State_Id, 17680 Instance => Stmt); 17681 end if; 17682 end if; 17683 end Part_Of; 17684 17685 ---------------------------------- 17686 -- Partition_Elaboration_Policy -- 17687 ---------------------------------- 17688 17689 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER); 17690 17691 when Pragma_Partition_Elaboration_Policy => declare 17692 subtype PEP_Range is Name_Id 17693 range First_Partition_Elaboration_Policy_Name 17694 .. Last_Partition_Elaboration_Policy_Name; 17695 PEP_Val : PEP_Range; 17696 PEP : Character; 17697 17698 begin 17699 Ada_2005_Pragma; 17700 Check_Arg_Count (1); 17701 Check_No_Identifiers; 17702 Check_Arg_Is_Partition_Elaboration_Policy (Arg1); 17703 Check_Valid_Configuration_Pragma; 17704 PEP_Val := Chars (Get_Pragma_Arg (Arg1)); 17705 17706 case PEP_Val is 17707 when Name_Concurrent => 17708 PEP := 'C'; 17709 when Name_Sequential => 17710 PEP := 'S'; 17711 end case; 17712 17713 if Partition_Elaboration_Policy /= ' ' 17714 and then Partition_Elaboration_Policy /= PEP 17715 then 17716 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc; 17717 Error_Pragma 17718 ("partition elaboration policy incompatible with policy#"); 17719 17720 -- Set new policy, but always preserve System_Location since we 17721 -- like the error message with the run time name. 17722 17723 else 17724 Partition_Elaboration_Policy := PEP; 17725 17726 if Partition_Elaboration_Policy_Sloc /= System_Location then 17727 Partition_Elaboration_Policy_Sloc := Loc; 17728 end if; 17729 end if; 17730 end; 17731 17732 ------------- 17733 -- Passive -- 17734 ------------- 17735 17736 -- pragma Passive [(PASSIVE_FORM)]; 17737 17738 -- PASSIVE_FORM ::= Semaphore | No 17739 17740 when Pragma_Passive => 17741 GNAT_Pragma; 17742 17743 if Nkind (Parent (N)) /= N_Task_Definition then 17744 Error_Pragma ("pragma% must be within task definition"); 17745 end if; 17746 17747 if Arg_Count /= 0 then 17748 Check_Arg_Count (1); 17749 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); 17750 end if; 17751 17752 ---------------------------------- 17753 -- Preelaborable_Initialization -- 17754 ---------------------------------- 17755 17756 -- pragma Preelaborable_Initialization (DIRECT_NAME); 17757 17758 when Pragma_Preelaborable_Initialization => Preelab_Init : declare 17759 Ent : Entity_Id; 17760 17761 begin 17762 Ada_2005_Pragma; 17763 Check_Arg_Count (1); 17764 Check_No_Identifiers; 17765 Check_Arg_Is_Identifier (Arg1); 17766 Check_Arg_Is_Local_Name (Arg1); 17767 Check_First_Subtype (Arg1); 17768 Ent := Entity (Get_Pragma_Arg (Arg1)); 17769 17770 -- The pragma may come from an aspect on a private declaration, 17771 -- even if the freeze point at which this is analyzed in the 17772 -- private part after the full view. 17773 17774 if Has_Private_Declaration (Ent) 17775 and then From_Aspect_Specification (N) 17776 then 17777 null; 17778 17779 elsif Is_Private_Type (Ent) 17780 or else Is_Protected_Type (Ent) 17781 or else (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)) 17782 then 17783 null; 17784 17785 else 17786 Error_Pragma_Arg 17787 ("pragma % can only be applied to private, formal derived or " 17788 & "protected type", 17789 Arg1); 17790 end if; 17791 17792 -- Give an error if the pragma is applied to a protected type that 17793 -- does not qualify (due to having entries, or due to components 17794 -- that do not qualify). 17795 17796 if Is_Protected_Type (Ent) 17797 and then not Has_Preelaborable_Initialization (Ent) 17798 then 17799 Error_Msg_N 17800 ("protected type & does not have preelaborable " 17801 & "initialization", Ent); 17802 17803 -- Otherwise mark the type as definitely having preelaborable 17804 -- initialization. 17805 17806 else 17807 Set_Known_To_Have_Preelab_Init (Ent); 17808 end if; 17809 17810 if Has_Pragma_Preelab_Init (Ent) 17811 and then Warn_On_Redundant_Constructs 17812 then 17813 Error_Pragma ("?r?duplicate pragma%!"); 17814 else 17815 Set_Has_Pragma_Preelab_Init (Ent); 17816 end if; 17817 end Preelab_Init; 17818 17819 -------------------- 17820 -- Persistent_BSS -- 17821 -------------------- 17822 17823 -- pragma Persistent_BSS [(object_NAME)]; 17824 17825 when Pragma_Persistent_BSS => Persistent_BSS : declare 17826 Decl : Node_Id; 17827 Ent : Entity_Id; 17828 Prag : Node_Id; 17829 17830 begin 17831 GNAT_Pragma; 17832 Check_At_Most_N_Arguments (1); 17833 17834 -- Case of application to specific object (one argument) 17835 17836 if Arg_Count = 1 then 17837 Check_Arg_Is_Library_Level_Local_Name (Arg1); 17838 17839 if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) 17840 or else not 17841 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, 17842 E_Constant) 17843 then 17844 Error_Pragma_Arg ("pragma% only applies to objects", Arg1); 17845 end if; 17846 17847 Ent := Entity (Get_Pragma_Arg (Arg1)); 17848 Decl := Parent (Ent); 17849 17850 -- Check for duplication before inserting in list of 17851 -- representation items. 17852 17853 Check_Duplicate_Pragma (Ent); 17854 17855 if Rep_Item_Too_Late (Ent, N) then 17856 return; 17857 end if; 17858 17859 if Present (Expression (Decl)) then 17860 Error_Pragma_Arg 17861 ("object for pragma% cannot have initialization", Arg1); 17862 end if; 17863 17864 if not Is_Potentially_Persistent_Type (Etype (Ent)) then 17865 Error_Pragma_Arg 17866 ("object type for pragma% is not potentially persistent", 17867 Arg1); 17868 end if; 17869 17870 Prag := 17871 Make_Linker_Section_Pragma 17872 (Ent, Sloc (N), ".persistent.bss"); 17873 Insert_After (N, Prag); 17874 Analyze (Prag); 17875 17876 -- Case of use as configuration pragma with no arguments 17877 17878 else 17879 Check_Valid_Configuration_Pragma; 17880 Persistent_BSS_Mode := True; 17881 end if; 17882 end Persistent_BSS; 17883 17884 ------------- 17885 -- Polling -- 17886 ------------- 17887 17888 -- pragma Polling (ON | OFF); 17889 17890 when Pragma_Polling => 17891 GNAT_Pragma; 17892 Check_Arg_Count (1); 17893 Check_No_Identifiers; 17894 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 17895 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); 17896 17897 ------------------ 17898 -- Post[_Class] -- 17899 ------------------ 17900 17901 -- pragma Post (Boolean_EXPRESSION); 17902 -- pragma Post_Class (Boolean_EXPRESSION); 17903 17904 when Pragma_Post | Pragma_Post_Class => Post : declare 17905 PC_Pragma : Node_Id; 17906 17907 begin 17908 GNAT_Pragma; 17909 Check_Arg_Count (1); 17910 Check_No_Identifiers; 17911 Check_Pre_Post; 17912 17913 -- Rewrite Post[_Class] pragma as Precondition pragma setting the 17914 -- flag Class_Present to True for the Post_Class case. 17915 17916 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class); 17917 PC_Pragma := New_Copy (N); 17918 Set_Pragma_Identifier 17919 (PC_Pragma, Make_Identifier (Loc, Name_Postcondition)); 17920 Rewrite (N, PC_Pragma); 17921 Set_Analyzed (N, False); 17922 Analyze (N); 17923 end Post; 17924 17925 ------------------- 17926 -- Postcondition -- 17927 ------------------- 17928 17929 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION 17930 -- [,[Message =>] String_EXPRESSION]); 17931 17932 when Pragma_Postcondition => Postcondition : declare 17933 In_Body : Boolean; 17934 17935 begin 17936 GNAT_Pragma; 17937 Check_At_Least_N_Arguments (1); 17938 Check_At_Most_N_Arguments (2); 17939 Check_Optional_Identifier (Arg1, Name_Check); 17940 17941 -- Verify the proper placement of the pragma. The remainder of the 17942 -- processing is found in Sem_Ch6/Sem_Ch7. 17943 17944 Check_Precondition_Postcondition (In_Body); 17945 17946 -- When the pragma is a source construct appearing inside a body, 17947 -- preanalyze the boolean_expression to detect illegal forward 17948 -- references: 17949 17950 -- procedure P is 17951 -- pragma Postcondition (X'Old ...); 17952 -- X : ... 17953 17954 if Comes_From_Source (N) and then In_Body then 17955 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean); 17956 end if; 17957 end Postcondition; 17958 17959 ----------------- 17960 -- Pre[_Class] -- 17961 ----------------- 17962 17963 -- pragma Pre (Boolean_EXPRESSION); 17964 -- pragma Pre_Class (Boolean_EXPRESSION); 17965 17966 when Pragma_Pre | Pragma_Pre_Class => Pre : declare 17967 PC_Pragma : Node_Id; 17968 17969 begin 17970 GNAT_Pragma; 17971 Check_Arg_Count (1); 17972 Check_No_Identifiers; 17973 Check_Pre_Post; 17974 17975 -- Rewrite Pre[_Class] pragma as Precondition pragma setting the 17976 -- flag Class_Present to True for the Pre_Class case. 17977 17978 Set_Class_Present (N, Prag_Id = Pragma_Pre_Class); 17979 PC_Pragma := New_Copy (N); 17980 Set_Pragma_Identifier 17981 (PC_Pragma, Make_Identifier (Loc, Name_Precondition)); 17982 Rewrite (N, PC_Pragma); 17983 Set_Analyzed (N, False); 17984 Analyze (N); 17985 end Pre; 17986 17987 ------------------ 17988 -- Precondition -- 17989 ------------------ 17990 17991 -- pragma Precondition ([Check =>] Boolean_EXPRESSION 17992 -- [,[Message =>] String_EXPRESSION]); 17993 17994 when Pragma_Precondition => Precondition : declare 17995 In_Body : Boolean; 17996 17997 begin 17998 GNAT_Pragma; 17999 Check_At_Least_N_Arguments (1); 18000 Check_At_Most_N_Arguments (2); 18001 Check_Optional_Identifier (Arg1, Name_Check); 18002 Check_Precondition_Postcondition (In_Body); 18003 18004 -- If in spec, nothing more to do. If in body, then we convert 18005 -- the pragma to an equivalent pragma Check. That works fine since 18006 -- pragma Check will analyze the condition in the proper context. 18007 18008 -- The form of the pragma Check is either: 18009 18010 -- pragma Check (Precondition, cond [, msg]) 18011 -- or 18012 -- pragma Check (Pre, cond [, msg]) 18013 18014 -- We use the Pre form if this pragma derived from a Pre aspect. 18015 -- This is needed to make sure that the right set of Policy 18016 -- pragmas are checked. 18017 18018 if In_Body then 18019 18020 -- Rewrite as Check pragma 18021 18022 Rewrite (N, 18023 Make_Pragma (Loc, 18024 Chars => Name_Check, 18025 Pragma_Argument_Associations => New_List ( 18026 Make_Pragma_Argument_Association (Loc, 18027 Expression => Make_Identifier (Loc, Pname)), 18028 18029 Make_Pragma_Argument_Association (Sloc (Arg1), 18030 Expression => 18031 Relocate_Node (Get_Pragma_Arg (Arg1)))))); 18032 18033 if Arg_Count = 2 then 18034 Append_To (Pragma_Argument_Associations (N), 18035 Make_Pragma_Argument_Association (Sloc (Arg2), 18036 Expression => 18037 Relocate_Node (Get_Pragma_Arg (Arg2)))); 18038 end if; 18039 18040 Analyze (N); 18041 end if; 18042 end Precondition; 18043 18044 --------------- 18045 -- Predicate -- 18046 --------------- 18047 18048 -- pragma Predicate 18049 -- ([Entity =>] type_LOCAL_NAME, 18050 -- [Check =>] boolean_EXPRESSION); 18051 18052 when Pragma_Predicate => Predicate : declare 18053 Type_Id : Node_Id; 18054 Typ : Entity_Id; 18055 18056 Discard : Boolean; 18057 pragma Unreferenced (Discard); 18058 18059 begin 18060 GNAT_Pragma; 18061 Check_Arg_Count (2); 18062 Check_Optional_Identifier (Arg1, Name_Entity); 18063 Check_Optional_Identifier (Arg2, Name_Check); 18064 18065 Check_Arg_Is_Local_Name (Arg1); 18066 18067 Type_Id := Get_Pragma_Arg (Arg1); 18068 Find_Type (Type_Id); 18069 Typ := Entity (Type_Id); 18070 18071 if Typ = Any_Type then 18072 return; 18073 end if; 18074 18075 -- The remaining processing is simply to link the pragma on to 18076 -- the rep item chain, for processing when the type is frozen. 18077 -- This is accomplished by a call to Rep_Item_Too_Late. We also 18078 -- mark the type as having predicates. 18079 18080 Set_Has_Predicates (Typ); 18081 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 18082 end Predicate; 18083 18084 ------------------ 18085 -- Preelaborate -- 18086 ------------------ 18087 18088 -- pragma Preelaborate [(library_unit_NAME)]; 18089 18090 -- Set the flag Is_Preelaborated of program unit name entity 18091 18092 when Pragma_Preelaborate => Preelaborate : declare 18093 Pa : constant Node_Id := Parent (N); 18094 Pk : constant Node_Kind := Nkind (Pa); 18095 Ent : Entity_Id; 18096 18097 begin 18098 Check_Ada_83_Warning; 18099 Check_Valid_Library_Unit_Pragma; 18100 18101 if Nkind (N) = N_Null_Statement then 18102 return; 18103 end if; 18104 18105 Ent := Find_Lib_Unit_Name; 18106 Check_Duplicate_Pragma (Ent); 18107 18108 -- This filters out pragmas inside generic parents that show up 18109 -- inside instantiations. Pragmas that come from aspects in the 18110 -- unit are not ignored. 18111 18112 if Present (Ent) then 18113 if Pk = N_Package_Specification 18114 and then Present (Generic_Parent (Pa)) 18115 and then not From_Aspect_Specification (N) 18116 then 18117 null; 18118 18119 else 18120 if not Debug_Flag_U then 18121 Set_Is_Preelaborated (Ent); 18122 Set_Suppress_Elaboration_Warnings (Ent); 18123 end if; 18124 end if; 18125 end if; 18126 end Preelaborate; 18127 18128 --------------------- 18129 -- Preelaborate_05 -- 18130 --------------------- 18131 18132 -- pragma Preelaborate_05 [(library_unit_NAME)]; 18133 18134 -- This pragma is useable only in GNAT_Mode, where it is used like 18135 -- pragma Preelaborate but it is only effective in Ada 2005 mode 18136 -- (otherwise it is ignored). This is used to implement AI-362 which 18137 -- recategorizes some run-time packages in Ada 2005 mode. 18138 18139 when Pragma_Preelaborate_05 => Preelaborate_05 : declare 18140 Ent : Entity_Id; 18141 18142 begin 18143 GNAT_Pragma; 18144 Check_Valid_Library_Unit_Pragma; 18145 18146 if not GNAT_Mode then 18147 Error_Pragma ("pragma% only available in GNAT mode"); 18148 end if; 18149 18150 if Nkind (N) = N_Null_Statement then 18151 return; 18152 end if; 18153 18154 -- This is one of the few cases where we need to test the value of 18155 -- Ada_Version_Explicit rather than Ada_Version (which is always 18156 -- set to Ada_2012 in a predefined unit), we need to know the 18157 -- explicit version set to know if this pragma is active. 18158 18159 if Ada_Version_Explicit >= Ada_2005 then 18160 Ent := Find_Lib_Unit_Name; 18161 Set_Is_Preelaborated (Ent); 18162 Set_Suppress_Elaboration_Warnings (Ent); 18163 end if; 18164 end Preelaborate_05; 18165 18166 -------------- 18167 -- Priority -- 18168 -------------- 18169 18170 -- pragma Priority (EXPRESSION); 18171 18172 when Pragma_Priority => Priority : declare 18173 P : constant Node_Id := Parent (N); 18174 Arg : Node_Id; 18175 Ent : Entity_Id; 18176 18177 begin 18178 Check_No_Identifiers; 18179 Check_Arg_Count (1); 18180 18181 -- Subprogram case 18182 18183 if Nkind (P) = N_Subprogram_Body then 18184 Check_In_Main_Program; 18185 18186 Ent := Defining_Unit_Name (Specification (P)); 18187 18188 if Nkind (Ent) = N_Defining_Program_Unit_Name then 18189 Ent := Defining_Identifier (Ent); 18190 end if; 18191 18192 Arg := Get_Pragma_Arg (Arg1); 18193 Analyze_And_Resolve (Arg, Standard_Integer); 18194 18195 -- Must be static 18196 18197 if not Is_Static_Expression (Arg) then 18198 Flag_Non_Static_Expr 18199 ("main subprogram priority is not static!", Arg); 18200 raise Pragma_Exit; 18201 18202 -- If constraint error, then we already signalled an error 18203 18204 elsif Raises_Constraint_Error (Arg) then 18205 null; 18206 18207 -- Otherwise check in range except if Relaxed_RM_Semantics 18208 -- where we ignore the value if out of range. 18209 18210 else 18211 declare 18212 Val : constant Uint := Expr_Value (Arg); 18213 begin 18214 if not Relaxed_RM_Semantics 18215 and then 18216 (Val < 0 18217 or else Val > Expr_Value (Expression 18218 (Parent (RTE (RE_Max_Priority))))) 18219 then 18220 Error_Pragma_Arg 18221 ("main subprogram priority is out of range", Arg1); 18222 else 18223 Set_Main_Priority 18224 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 18225 end if; 18226 end; 18227 end if; 18228 18229 -- Load an arbitrary entity from System.Tasking.Stages or 18230 -- System.Tasking.Restricted.Stages (depending on the 18231 -- supported profile) to make sure that one of these packages 18232 -- is implicitly with'ed, since we need to have the tasking 18233 -- run time active for the pragma Priority to have any effect. 18234 -- Previously with with'ed the package System.Tasking, but 18235 -- this package does not trigger the required initialization 18236 -- of the run-time library. 18237 18238 declare 18239 Discard : Entity_Id; 18240 pragma Warnings (Off, Discard); 18241 begin 18242 if Restricted_Profile then 18243 Discard := RTE (RE_Activate_Restricted_Tasks); 18244 else 18245 Discard := RTE (RE_Activate_Tasks); 18246 end if; 18247 end; 18248 18249 -- Task or Protected, must be of type Integer 18250 18251 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then 18252 Arg := Get_Pragma_Arg (Arg1); 18253 Ent := Defining_Identifier (Parent (P)); 18254 18255 -- The expression must be analyzed in the special manner 18256 -- described in "Handling of Default and Per-Object 18257 -- Expressions" in sem.ads. 18258 18259 Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); 18260 18261 if not Is_Static_Expression (Arg) then 18262 Check_Restriction (Static_Priorities, Arg); 18263 end if; 18264 18265 -- Anything else is incorrect 18266 18267 else 18268 Pragma_Misplaced; 18269 end if; 18270 18271 -- Check duplicate pragma before we chain the pragma in the Rep 18272 -- Item chain of Ent. 18273 18274 Check_Duplicate_Pragma (Ent); 18275 Record_Rep_Item (Ent, N); 18276 end Priority; 18277 18278 ----------------------------------- 18279 -- Priority_Specific_Dispatching -- 18280 ----------------------------------- 18281 18282 -- pragma Priority_Specific_Dispatching ( 18283 -- policy_IDENTIFIER, 18284 -- first_priority_EXPRESSION, 18285 -- last_priority_EXPRESSION); 18286 18287 when Pragma_Priority_Specific_Dispatching => 18288 Priority_Specific_Dispatching : declare 18289 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority); 18290 -- This is the entity System.Any_Priority; 18291 18292 DP : Character; 18293 Lower_Bound : Node_Id; 18294 Upper_Bound : Node_Id; 18295 Lower_Val : Uint; 18296 Upper_Val : Uint; 18297 18298 begin 18299 Ada_2005_Pragma; 18300 Check_Arg_Count (3); 18301 Check_No_Identifiers; 18302 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 18303 Check_Valid_Configuration_Pragma; 18304 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 18305 DP := Fold_Upper (Name_Buffer (1)); 18306 18307 Lower_Bound := Get_Pragma_Arg (Arg2); 18308 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer); 18309 Lower_Val := Expr_Value (Lower_Bound); 18310 18311 Upper_Bound := Get_Pragma_Arg (Arg3); 18312 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer); 18313 Upper_Val := Expr_Value (Upper_Bound); 18314 18315 -- It is not allowed to use Task_Dispatching_Policy and 18316 -- Priority_Specific_Dispatching in the same partition. 18317 18318 if Task_Dispatching_Policy /= ' ' then 18319 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 18320 Error_Pragma 18321 ("pragma% incompatible with Task_Dispatching_Policy#"); 18322 18323 -- Check lower bound in range 18324 18325 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 18326 or else 18327 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id)) 18328 then 18329 Error_Pragma_Arg 18330 ("first_priority is out of range", Arg2); 18331 18332 -- Check upper bound in range 18333 18334 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 18335 or else 18336 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id)) 18337 then 18338 Error_Pragma_Arg 18339 ("last_priority is out of range", Arg3); 18340 18341 -- Check that the priority range is valid 18342 18343 elsif Lower_Val > Upper_Val then 18344 Error_Pragma 18345 ("last_priority_expression must be greater than or equal to " 18346 & "first_priority_expression"); 18347 18348 -- Store the new policy, but always preserve System_Location since 18349 -- we like the error message with the run-time name. 18350 18351 else 18352 -- Check overlapping in the priority ranges specified in other 18353 -- Priority_Specific_Dispatching pragmas within the same 18354 -- partition. We can only check those we know about. 18355 18356 for J in 18357 Specific_Dispatching.First .. Specific_Dispatching.Last 18358 loop 18359 if Specific_Dispatching.Table (J).First_Priority in 18360 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 18361 or else Specific_Dispatching.Table (J).Last_Priority in 18362 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 18363 then 18364 Error_Msg_Sloc := 18365 Specific_Dispatching.Table (J).Pragma_Loc; 18366 Error_Pragma 18367 ("priority range overlaps with " 18368 & "Priority_Specific_Dispatching#"); 18369 end if; 18370 end loop; 18371 18372 -- The use of Priority_Specific_Dispatching is incompatible 18373 -- with Task_Dispatching_Policy. 18374 18375 if Task_Dispatching_Policy /= ' ' then 18376 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 18377 Error_Pragma 18378 ("Priority_Specific_Dispatching incompatible " 18379 & "with Task_Dispatching_Policy#"); 18380 end if; 18381 18382 -- The use of Priority_Specific_Dispatching forces ceiling 18383 -- locking policy. 18384 18385 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then 18386 Error_Msg_Sloc := Locking_Policy_Sloc; 18387 Error_Pragma 18388 ("Priority_Specific_Dispatching incompatible " 18389 & "with Locking_Policy#"); 18390 18391 -- Set the Ceiling_Locking policy, but preserve System_Location 18392 -- since we like the error message with the run time name. 18393 18394 else 18395 Locking_Policy := 'C'; 18396 18397 if Locking_Policy_Sloc /= System_Location then 18398 Locking_Policy_Sloc := Loc; 18399 end if; 18400 end if; 18401 18402 -- Add entry in the table 18403 18404 Specific_Dispatching.Append 18405 ((Dispatching_Policy => DP, 18406 First_Priority => UI_To_Int (Lower_Val), 18407 Last_Priority => UI_To_Int (Upper_Val), 18408 Pragma_Loc => Loc)); 18409 end if; 18410 end Priority_Specific_Dispatching; 18411 18412 ------------- 18413 -- Profile -- 18414 ------------- 18415 18416 -- pragma Profile (profile_IDENTIFIER); 18417 18418 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational 18419 18420 when Pragma_Profile => 18421 Ada_2005_Pragma; 18422 Check_Arg_Count (1); 18423 Check_Valid_Configuration_Pragma; 18424 Check_No_Identifiers; 18425 18426 declare 18427 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 18428 18429 begin 18430 if Chars (Argx) = Name_Ravenscar then 18431 Set_Ravenscar_Profile (N); 18432 18433 elsif Chars (Argx) = Name_Restricted then 18434 Set_Profile_Restrictions 18435 (Restricted, 18436 N, Warn => Treat_Restrictions_As_Warnings); 18437 18438 elsif Chars (Argx) = Name_Rational then 18439 Set_Rational_Profile; 18440 18441 elsif Chars (Argx) = Name_No_Implementation_Extensions then 18442 Set_Profile_Restrictions 18443 (No_Implementation_Extensions, 18444 N, Warn => Treat_Restrictions_As_Warnings); 18445 18446 else 18447 Error_Pragma_Arg ("& is not a valid profile", Argx); 18448 end if; 18449 end; 18450 18451 ---------------------- 18452 -- Profile_Warnings -- 18453 ---------------------- 18454 18455 -- pragma Profile_Warnings (profile_IDENTIFIER); 18456 18457 -- profile_IDENTIFIER => Restricted | Ravenscar 18458 18459 when Pragma_Profile_Warnings => 18460 GNAT_Pragma; 18461 Check_Arg_Count (1); 18462 Check_Valid_Configuration_Pragma; 18463 Check_No_Identifiers; 18464 18465 declare 18466 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 18467 18468 begin 18469 if Chars (Argx) = Name_Ravenscar then 18470 Set_Profile_Restrictions (Ravenscar, N, Warn => True); 18471 18472 elsif Chars (Argx) = Name_Restricted then 18473 Set_Profile_Restrictions (Restricted, N, Warn => True); 18474 18475 elsif Chars (Argx) = Name_No_Implementation_Extensions then 18476 Set_Profile_Restrictions 18477 (No_Implementation_Extensions, N, Warn => True); 18478 18479 else 18480 Error_Pragma_Arg ("& is not a valid profile", Argx); 18481 end if; 18482 end; 18483 18484 -------------------------- 18485 -- Propagate_Exceptions -- 18486 -------------------------- 18487 18488 -- pragma Propagate_Exceptions; 18489 18490 -- Note: this pragma is obsolete and has no effect 18491 18492 when Pragma_Propagate_Exceptions => 18493 GNAT_Pragma; 18494 Check_Arg_Count (0); 18495 18496 if Warn_On_Obsolescent_Feature then 18497 Error_Msg_N 18498 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " & 18499 "and has no effect?j?", N); 18500 end if; 18501 18502 ----------------------------- 18503 -- Provide_Shift_Operators -- 18504 ----------------------------- 18505 18506 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME); 18507 18508 when Pragma_Provide_Shift_Operators => 18509 Provide_Shift_Operators : declare 18510 Ent : Entity_Id; 18511 18512 procedure Declare_Shift_Operator (Nam : Name_Id); 18513 -- Insert declaration and pragma Instrinsic for named shift op 18514 18515 ---------------------------- 18516 -- Declare_Shift_Operator -- 18517 ---------------------------- 18518 18519 procedure Declare_Shift_Operator (Nam : Name_Id) is 18520 Func : Node_Id; 18521 Import : Node_Id; 18522 18523 begin 18524 Func := 18525 Make_Subprogram_Declaration (Loc, 18526 Make_Function_Specification (Loc, 18527 Defining_Unit_Name => 18528 Make_Defining_Identifier (Loc, Chars => Nam), 18529 18530 Result_Definition => 18531 Make_Identifier (Loc, Chars => Chars (Ent)), 18532 18533 Parameter_Specifications => New_List ( 18534 Make_Parameter_Specification (Loc, 18535 Defining_Identifier => 18536 Make_Defining_Identifier (Loc, Name_Value), 18537 Parameter_Type => 18538 Make_Identifier (Loc, Chars => Chars (Ent))), 18539 18540 Make_Parameter_Specification (Loc, 18541 Defining_Identifier => 18542 Make_Defining_Identifier (Loc, Name_Amount), 18543 Parameter_Type => 18544 New_Occurrence_Of (Standard_Natural, Loc))))); 18545 18546 Import := 18547 Make_Pragma (Loc, 18548 Pragma_Identifier => Make_Identifier (Loc, Name_Import), 18549 Pragma_Argument_Associations => New_List ( 18550 Make_Pragma_Argument_Association (Loc, 18551 Expression => Make_Identifier (Loc, Name_Intrinsic)), 18552 Make_Pragma_Argument_Association (Loc, 18553 Expression => Make_Identifier (Loc, Nam)))); 18554 18555 Insert_After (N, Import); 18556 Insert_After (N, Func); 18557 end Declare_Shift_Operator; 18558 18559 -- Start of processing for Provide_Shift_Operators 18560 18561 begin 18562 GNAT_Pragma; 18563 Check_Arg_Count (1); 18564 Check_Arg_Is_Local_Name (Arg1); 18565 18566 Arg1 := Get_Pragma_Arg (Arg1); 18567 18568 -- We must have an entity name 18569 18570 if not Is_Entity_Name (Arg1) then 18571 Error_Pragma_Arg 18572 ("pragma % must apply to integer first subtype", Arg1); 18573 end if; 18574 18575 -- If no Entity, means there was a prior error so ignore 18576 18577 if Present (Entity (Arg1)) then 18578 Ent := Entity (Arg1); 18579 18580 -- Apply error checks 18581 18582 if not Is_First_Subtype (Ent) then 18583 Error_Pragma_Arg 18584 ("cannot apply pragma %", 18585 "\& is not a first subtype", 18586 Arg1); 18587 18588 elsif not Is_Integer_Type (Ent) then 18589 Error_Pragma_Arg 18590 ("cannot apply pragma %", 18591 "\& is not an integer type", 18592 Arg1); 18593 18594 elsif Has_Shift_Operator (Ent) then 18595 Error_Pragma_Arg 18596 ("cannot apply pragma %", 18597 "\& already has declared shift operators", 18598 Arg1); 18599 18600 elsif Is_Frozen (Ent) then 18601 Error_Pragma_Arg 18602 ("pragma % appears too late", 18603 "\& is already frozen", 18604 Arg1); 18605 end if; 18606 18607 -- Now declare the operators. We do this during analysis rather 18608 -- than expansion, since we want the operators available if we 18609 -- are operating in -gnatc or ASIS mode. 18610 18611 Declare_Shift_Operator (Name_Rotate_Left); 18612 Declare_Shift_Operator (Name_Rotate_Right); 18613 Declare_Shift_Operator (Name_Shift_Left); 18614 Declare_Shift_Operator (Name_Shift_Right); 18615 Declare_Shift_Operator (Name_Shift_Right_Arithmetic); 18616 end if; 18617 end Provide_Shift_Operators; 18618 18619 ------------------ 18620 -- Psect_Object -- 18621 ------------------ 18622 18623 -- pragma Psect_Object ( 18624 -- [Internal =>] LOCAL_NAME, 18625 -- [, [External =>] EXTERNAL_SYMBOL] 18626 -- [, [Size =>] EXTERNAL_SYMBOL]); 18627 18628 when Pragma_Psect_Object | Pragma_Common_Object => 18629 Psect_Object : declare 18630 Args : Args_List (1 .. 3); 18631 Names : constant Name_List (1 .. 3) := ( 18632 Name_Internal, 18633 Name_External, 18634 Name_Size); 18635 18636 Internal : Node_Id renames Args (1); 18637 External : Node_Id renames Args (2); 18638 Size : Node_Id renames Args (3); 18639 18640 Def_Id : Entity_Id; 18641 18642 procedure Check_Too_Long (Arg : Node_Id); 18643 -- Posts message if the argument is an identifier with more 18644 -- than 31 characters, or a string literal with more than 18645 -- 31 characters, and we are operating under VMS 18646 18647 -------------------- 18648 -- Check_Too_Long -- 18649 -------------------- 18650 18651 procedure Check_Too_Long (Arg : Node_Id) is 18652 X : constant Node_Id := Original_Node (Arg); 18653 18654 begin 18655 if not Nkind_In (X, N_String_Literal, N_Identifier) then 18656 Error_Pragma_Arg 18657 ("inappropriate argument for pragma %", Arg); 18658 end if; 18659 18660 if OpenVMS_On_Target then 18661 if (Nkind (X) = N_String_Literal 18662 and then String_Length (Strval (X)) > 31) 18663 or else 18664 (Nkind (X) = N_Identifier 18665 and then Length_Of_Name (Chars (X)) > 31) 18666 then 18667 Error_Pragma_Arg 18668 ("argument for pragma % is longer than 31 characters", 18669 Arg); 18670 end if; 18671 end if; 18672 end Check_Too_Long; 18673 18674 -- Start of processing for Common_Object/Psect_Object 18675 18676 begin 18677 GNAT_Pragma; 18678 Gather_Associations (Names, Args); 18679 Process_Extended_Import_Export_Internal_Arg (Internal); 18680 18681 Def_Id := Entity (Internal); 18682 18683 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 18684 Error_Pragma_Arg 18685 ("pragma% must designate an object", Internal); 18686 end if; 18687 18688 Check_Too_Long (Internal); 18689 18690 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then 18691 Error_Pragma_Arg 18692 ("cannot use pragma% for imported/exported object", 18693 Internal); 18694 end if; 18695 18696 if Is_Concurrent_Type (Etype (Internal)) then 18697 Error_Pragma_Arg 18698 ("cannot specify pragma % for task/protected object", 18699 Internal); 18700 end if; 18701 18702 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 18703 or else 18704 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 18705 then 18706 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N); 18707 end if; 18708 18709 if Ekind (Def_Id) = E_Constant then 18710 Error_Pragma_Arg 18711 ("cannot specify pragma % for a constant", Internal); 18712 end if; 18713 18714 if Is_Record_Type (Etype (Internal)) then 18715 declare 18716 Ent : Entity_Id; 18717 Decl : Entity_Id; 18718 18719 begin 18720 Ent := First_Entity (Etype (Internal)); 18721 while Present (Ent) loop 18722 Decl := Declaration_Node (Ent); 18723 18724 if Ekind (Ent) = E_Component 18725 and then Nkind (Decl) = N_Component_Declaration 18726 and then Present (Expression (Decl)) 18727 and then Warn_On_Export_Import 18728 then 18729 Error_Msg_N 18730 ("?x?object for pragma % has defaults", Internal); 18731 exit; 18732 18733 else 18734 Next_Entity (Ent); 18735 end if; 18736 end loop; 18737 end; 18738 end if; 18739 18740 if Present (Size) then 18741 Check_Too_Long (Size); 18742 end if; 18743 18744 if Present (External) then 18745 Check_Arg_Is_External_Name (External); 18746 Check_Too_Long (External); 18747 end if; 18748 18749 -- If all error tests pass, link pragma on to the rep item chain 18750 18751 Record_Rep_Item (Def_Id, N); 18752 end Psect_Object; 18753 18754 ---------- 18755 -- Pure -- 18756 ---------- 18757 18758 -- pragma Pure [(library_unit_NAME)]; 18759 18760 when Pragma_Pure => Pure : declare 18761 Ent : Entity_Id; 18762 18763 begin 18764 Check_Ada_83_Warning; 18765 Check_Valid_Library_Unit_Pragma; 18766 18767 if Nkind (N) = N_Null_Statement then 18768 return; 18769 end if; 18770 18771 Ent := Find_Lib_Unit_Name; 18772 Set_Is_Pure (Ent); 18773 Set_Has_Pragma_Pure (Ent); 18774 Set_Suppress_Elaboration_Warnings (Ent); 18775 end Pure; 18776 18777 ------------- 18778 -- Pure_05 -- 18779 ------------- 18780 18781 -- pragma Pure_05 [(library_unit_NAME)]; 18782 18783 -- This pragma is useable only in GNAT_Mode, where it is used like 18784 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise 18785 -- it is ignored). It may be used after a pragma Preelaborate, in 18786 -- which case it overrides the effect of the pragma Preelaborate. 18787 -- This is used to implement AI-362 which recategorizes some run-time 18788 -- packages in Ada 2005 mode. 18789 18790 when Pragma_Pure_05 => Pure_05 : declare 18791 Ent : Entity_Id; 18792 18793 begin 18794 GNAT_Pragma; 18795 Check_Valid_Library_Unit_Pragma; 18796 18797 if not GNAT_Mode then 18798 Error_Pragma ("pragma% only available in GNAT mode"); 18799 end if; 18800 18801 if Nkind (N) = N_Null_Statement then 18802 return; 18803 end if; 18804 18805 -- This is one of the few cases where we need to test the value of 18806 -- Ada_Version_Explicit rather than Ada_Version (which is always 18807 -- set to Ada_2012 in a predefined unit), we need to know the 18808 -- explicit version set to know if this pragma is active. 18809 18810 if Ada_Version_Explicit >= Ada_2005 then 18811 Ent := Find_Lib_Unit_Name; 18812 Set_Is_Preelaborated (Ent, False); 18813 Set_Is_Pure (Ent); 18814 Set_Suppress_Elaboration_Warnings (Ent); 18815 end if; 18816 end Pure_05; 18817 18818 ------------- 18819 -- Pure_12 -- 18820 ------------- 18821 18822 -- pragma Pure_12 [(library_unit_NAME)]; 18823 18824 -- This pragma is useable only in GNAT_Mode, where it is used like 18825 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise 18826 -- it is ignored). It may be used after a pragma Preelaborate, in 18827 -- which case it overrides the effect of the pragma Preelaborate. 18828 -- This is used to implement AI05-0212 which recategorizes some 18829 -- run-time packages in Ada 2012 mode. 18830 18831 when Pragma_Pure_12 => Pure_12 : declare 18832 Ent : Entity_Id; 18833 18834 begin 18835 GNAT_Pragma; 18836 Check_Valid_Library_Unit_Pragma; 18837 18838 if not GNAT_Mode then 18839 Error_Pragma ("pragma% only available in GNAT mode"); 18840 end if; 18841 18842 if Nkind (N) = N_Null_Statement then 18843 return; 18844 end if; 18845 18846 -- This is one of the few cases where we need to test the value of 18847 -- Ada_Version_Explicit rather than Ada_Version (which is always 18848 -- set to Ada_2012 in a predefined unit), we need to know the 18849 -- explicit version set to know if this pragma is active. 18850 18851 if Ada_Version_Explicit >= Ada_2012 then 18852 Ent := Find_Lib_Unit_Name; 18853 Set_Is_Preelaborated (Ent, False); 18854 Set_Is_Pure (Ent); 18855 Set_Suppress_Elaboration_Warnings (Ent); 18856 end if; 18857 end Pure_12; 18858 18859 ------------------- 18860 -- Pure_Function -- 18861 ------------------- 18862 18863 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME); 18864 18865 when Pragma_Pure_Function => Pure_Function : declare 18866 E_Id : Node_Id; 18867 E : Entity_Id; 18868 Def_Id : Entity_Id; 18869 Effective : Boolean := False; 18870 18871 begin 18872 GNAT_Pragma; 18873 Check_Arg_Count (1); 18874 Check_Optional_Identifier (Arg1, Name_Entity); 18875 Check_Arg_Is_Local_Name (Arg1); 18876 E_Id := Get_Pragma_Arg (Arg1); 18877 18878 if Error_Posted (E_Id) then 18879 return; 18880 end if; 18881 18882 -- Loop through homonyms (overloadings) of referenced entity 18883 18884 E := Entity (E_Id); 18885 18886 if Present (E) then 18887 loop 18888 Def_Id := Get_Base_Subprogram (E); 18889 18890 if not Ekind_In (Def_Id, E_Function, 18891 E_Generic_Function, 18892 E_Operator) 18893 then 18894 Error_Pragma_Arg 18895 ("pragma% requires a function name", Arg1); 18896 end if; 18897 18898 Set_Is_Pure (Def_Id); 18899 18900 if not Has_Pragma_Pure_Function (Def_Id) then 18901 Set_Has_Pragma_Pure_Function (Def_Id); 18902 Effective := True; 18903 end if; 18904 18905 exit when From_Aspect_Specification (N); 18906 E := Homonym (E); 18907 exit when No (E) or else Scope (E) /= Current_Scope; 18908 end loop; 18909 18910 if not Effective 18911 and then Warn_On_Redundant_Constructs 18912 then 18913 Error_Msg_NE 18914 ("pragma Pure_Function on& is redundant?r?", 18915 N, Entity (E_Id)); 18916 end if; 18917 end if; 18918 end Pure_Function; 18919 18920 -------------------- 18921 -- Queuing_Policy -- 18922 -------------------- 18923 18924 -- pragma Queuing_Policy (policy_IDENTIFIER); 18925 18926 when Pragma_Queuing_Policy => declare 18927 QP : Character; 18928 18929 begin 18930 Check_Ada_83_Warning; 18931 Check_Arg_Count (1); 18932 Check_No_Identifiers; 18933 Check_Arg_Is_Queuing_Policy (Arg1); 18934 Check_Valid_Configuration_Pragma; 18935 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 18936 QP := Fold_Upper (Name_Buffer (1)); 18937 18938 if Queuing_Policy /= ' ' 18939 and then Queuing_Policy /= QP 18940 then 18941 Error_Msg_Sloc := Queuing_Policy_Sloc; 18942 Error_Pragma ("queuing policy incompatible with policy#"); 18943 18944 -- Set new policy, but always preserve System_Location since we 18945 -- like the error message with the run time name. 18946 18947 else 18948 Queuing_Policy := QP; 18949 18950 if Queuing_Policy_Sloc /= System_Location then 18951 Queuing_Policy_Sloc := Loc; 18952 end if; 18953 end if; 18954 end; 18955 18956 -------------- 18957 -- Rational -- 18958 -------------- 18959 18960 -- pragma Rational, for compatibility with foreign compiler 18961 18962 when Pragma_Rational => 18963 Set_Rational_Profile; 18964 18965 ------------------------------------ 18966 -- Refined_Depends/Refined_Global -- 18967 ------------------------------------ 18968 18969 -- pragma Refined_Depends (DEPENDENCY_RELATION); 18970 18971 -- DEPENDENCY_RELATION ::= 18972 -- null 18973 -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE} 18974 18975 -- DEPENDENCY_CLAUSE ::= 18976 -- OUTPUT_LIST =>[+] INPUT_LIST 18977 -- | NULL_DEPENDENCY_CLAUSE 18978 18979 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST 18980 18981 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) 18982 18983 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) 18984 18985 -- OUTPUT ::= NAME | FUNCTION_RESULT 18986 -- INPUT ::= NAME 18987 18988 -- where FUNCTION_RESULT is a function Result attribute_reference 18989 18990 -- pragma Refined_Global (GLOBAL_SPECIFICATION); 18991 18992 -- GLOBAL_SPECIFICATION ::= 18993 -- null 18994 -- | GLOBAL_LIST 18995 -- | MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST} 18996 18997 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 18998 18999 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In 19000 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM}) 19001 -- GLOBAL_ITEM ::= NAME 19002 19003 when Pragma_Refined_Depends | 19004 Pragma_Refined_Global => Refined_Depends_Global : 19005 declare 19006 Body_Id : Entity_Id; 19007 Legal : Boolean; 19008 Spec_Id : Entity_Id; 19009 19010 begin 19011 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal); 19012 19013 -- Save the pragma in the contract of the subprogram body. The 19014 -- remaining analysis is performed at the end of the enclosing 19015 -- declarations. 19016 19017 if Legal then 19018 Add_Contract_Item (N, Body_Id); 19019 end if; 19020 end Refined_Depends_Global; 19021 19022 ------------------ 19023 -- Refined_Post -- 19024 ------------------ 19025 19026 -- pragma Refined_Post (boolean_EXPRESSION); 19027 19028 when Pragma_Refined_Post => Refined_Post : declare 19029 Body_Id : Entity_Id; 19030 Legal : Boolean; 19031 Result_Seen : Boolean := False; 19032 Spec_Id : Entity_Id; 19033 19034 begin 19035 Analyze_Refined_Pragma (Spec_Id, Body_Id, Legal); 19036 19037 -- Analyze the boolean expression as a "spec expression" 19038 19039 if Legal then 19040 Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id); 19041 19042 -- Verify that the refined postcondition mentions attribute 19043 -- 'Result and its expression introduces a post-state. 19044 19045 if Warn_On_Suspicious_Contract 19046 and then Ekind_In (Spec_Id, E_Function, E_Generic_Function) 19047 then 19048 Check_Result_And_Post_State (N, Result_Seen); 19049 19050 if not Result_Seen then 19051 Error_Pragma 19052 ("pragma % does not mention function result?T?"); 19053 end if; 19054 end if; 19055 19056 -- Chain the pragma on the contract for easy retrieval 19057 19058 Add_Contract_Item (N, Body_Id); 19059 end if; 19060 end Refined_Post; 19061 19062 ------------------- 19063 -- Refined_State -- 19064 ------------------- 19065 19066 -- pragma Refined_State (REFINEMENT_LIST); 19067 19068 -- REFINEMENT_LIST ::= 19069 -- REFINEMENT_CLAUSE 19070 -- | (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE}) 19071 19072 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST 19073 19074 -- CONSTITUENT_LIST ::= 19075 -- null 19076 -- | CONSTITUENT 19077 -- | (CONSTITUENT {, CONSTITUENT}) 19078 19079 -- CONSTITUENT ::= object_NAME | state_NAME 19080 19081 when Pragma_Refined_State => Refined_State : declare 19082 Context : constant Node_Id := Parent (N); 19083 Spec_Id : Entity_Id; 19084 Stmt : Node_Id; 19085 19086 begin 19087 GNAT_Pragma; 19088 Check_Arg_Count (1); 19089 19090 -- Ensure the proper placement of the pragma. Refined states must 19091 -- be associated with a package body. 19092 19093 if Nkind (Context) /= N_Package_Body then 19094 Pragma_Misplaced; 19095 return; 19096 end if; 19097 19098 Stmt := Prev (N); 19099 while Present (Stmt) loop 19100 19101 -- Skip prior pragmas, but check for duplicates 19102 19103 if Nkind (Stmt) = N_Pragma then 19104 if Pragma_Name (Stmt) = Pname then 19105 Error_Msg_Name_1 := Pname; 19106 Error_Msg_Sloc := Sloc (Stmt); 19107 Error_Msg_N ("pragma % duplicates pragma declared #", N); 19108 end if; 19109 19110 -- Skip internally generated code 19111 19112 elsif not Comes_From_Source (Stmt) then 19113 null; 19114 19115 -- The pragma does not apply to a legal construct, issue an 19116 -- error and stop the analysis. 19117 19118 else 19119 Pragma_Misplaced; 19120 return; 19121 end if; 19122 19123 Stmt := Prev (Stmt); 19124 end loop; 19125 19126 Spec_Id := Corresponding_Spec (Context); 19127 19128 -- State refinement is allowed only when the corresponding package 19129 -- declaration has non-null pragma Abstract_State. Refinement not 19130 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)). 19131 19132 if SPARK_Mode /= Off 19133 and then 19134 (No (Abstract_States (Spec_Id)) 19135 or else Has_Null_Abstract_State (Spec_Id)) 19136 then 19137 Error_Msg_NE 19138 ("useless refinement, package & does not define abstract " 19139 & "states", N, Spec_Id); 19140 return; 19141 end if; 19142 19143 -- The pragma must be analyzed at the end of the declarations as 19144 -- it has visibility over the whole declarative region. Save the 19145 -- pragma for later (see Analyze_Refined_Depends_In_Decl_Part) by 19146 -- adding it to the contract of the package body. 19147 19148 Add_Contract_Item (N, Defining_Entity (Context)); 19149 end Refined_State; 19150 19151 ----------------------- 19152 -- Relative_Deadline -- 19153 ----------------------- 19154 19155 -- pragma Relative_Deadline (time_span_EXPRESSION); 19156 19157 when Pragma_Relative_Deadline => Relative_Deadline : declare 19158 P : constant Node_Id := Parent (N); 19159 Arg : Node_Id; 19160 19161 begin 19162 Ada_2005_Pragma; 19163 Check_No_Identifiers; 19164 Check_Arg_Count (1); 19165 19166 Arg := Get_Pragma_Arg (Arg1); 19167 19168 -- The expression must be analyzed in the special manner described 19169 -- in "Handling of Default and Per-Object Expressions" in sem.ads. 19170 19171 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); 19172 19173 -- Subprogram case 19174 19175 if Nkind (P) = N_Subprogram_Body then 19176 Check_In_Main_Program; 19177 19178 -- Only Task and subprogram cases allowed 19179 19180 elsif Nkind (P) /= N_Task_Definition then 19181 Pragma_Misplaced; 19182 end if; 19183 19184 -- Check duplicate pragma before we set the corresponding flag 19185 19186 if Has_Relative_Deadline_Pragma (P) then 19187 Error_Pragma ("duplicate pragma% not allowed"); 19188 end if; 19189 19190 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that 19191 -- Relative_Deadline pragma node cannot be inserted in the Rep 19192 -- Item chain of Ent since it is rewritten by the expander as a 19193 -- procedure call statement that will break the chain. 19194 19195 Set_Has_Relative_Deadline_Pragma (P, True); 19196 end Relative_Deadline; 19197 19198 ------------------------ 19199 -- Remote_Access_Type -- 19200 ------------------------ 19201 19202 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME); 19203 19204 when Pragma_Remote_Access_Type => Remote_Access_Type : declare 19205 E : Entity_Id; 19206 19207 begin 19208 GNAT_Pragma; 19209 Check_Arg_Count (1); 19210 Check_Optional_Identifier (Arg1, Name_Entity); 19211 Check_Arg_Is_Local_Name (Arg1); 19212 19213 E := Entity (Get_Pragma_Arg (Arg1)); 19214 19215 if Nkind (Parent (E)) = N_Formal_Type_Declaration 19216 and then Ekind (E) = E_General_Access_Type 19217 and then Is_Class_Wide_Type (Directly_Designated_Type (E)) 19218 and then Scope (Root_Type (Directly_Designated_Type (E))) 19219 = Scope (E) 19220 and then Is_Valid_Remote_Object_Type 19221 (Root_Type (Directly_Designated_Type (E))) 19222 then 19223 Set_Is_Remote_Types (E); 19224 19225 else 19226 Error_Pragma_Arg 19227 ("pragma% applies only to formal access to classwide types", 19228 Arg1); 19229 end if; 19230 end Remote_Access_Type; 19231 19232 --------------------------- 19233 -- Remote_Call_Interface -- 19234 --------------------------- 19235 19236 -- pragma Remote_Call_Interface [(library_unit_NAME)]; 19237 19238 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare 19239 Cunit_Node : Node_Id; 19240 Cunit_Ent : Entity_Id; 19241 K : Node_Kind; 19242 19243 begin 19244 Check_Ada_83_Warning; 19245 Check_Valid_Library_Unit_Pragma; 19246 19247 if Nkind (N) = N_Null_Statement then 19248 return; 19249 end if; 19250 19251 Cunit_Node := Cunit (Current_Sem_Unit); 19252 K := Nkind (Unit (Cunit_Node)); 19253 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 19254 19255 if K = N_Package_Declaration 19256 or else K = N_Generic_Package_Declaration 19257 or else K = N_Subprogram_Declaration 19258 or else K = N_Generic_Subprogram_Declaration 19259 or else (K = N_Subprogram_Body 19260 and then Acts_As_Spec (Unit (Cunit_Node))) 19261 then 19262 null; 19263 else 19264 Error_Pragma ( 19265 "pragma% must apply to package or subprogram declaration"); 19266 end if; 19267 19268 Set_Is_Remote_Call_Interface (Cunit_Ent); 19269 end Remote_Call_Interface; 19270 19271 ------------------ 19272 -- Remote_Types -- 19273 ------------------ 19274 19275 -- pragma Remote_Types [(library_unit_NAME)]; 19276 19277 when Pragma_Remote_Types => Remote_Types : declare 19278 Cunit_Node : Node_Id; 19279 Cunit_Ent : Entity_Id; 19280 19281 begin 19282 Check_Ada_83_Warning; 19283 Check_Valid_Library_Unit_Pragma; 19284 19285 if Nkind (N) = N_Null_Statement then 19286 return; 19287 end if; 19288 19289 Cunit_Node := Cunit (Current_Sem_Unit); 19290 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 19291 19292 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 19293 N_Generic_Package_Declaration) 19294 then 19295 Error_Pragma 19296 ("pragma% can only apply to a package declaration"); 19297 end if; 19298 19299 Set_Is_Remote_Types (Cunit_Ent); 19300 end Remote_Types; 19301 19302 --------------- 19303 -- Ravenscar -- 19304 --------------- 19305 19306 -- pragma Ravenscar; 19307 19308 when Pragma_Ravenscar => 19309 GNAT_Pragma; 19310 Check_Arg_Count (0); 19311 Check_Valid_Configuration_Pragma; 19312 Set_Ravenscar_Profile (N); 19313 19314 if Warn_On_Obsolescent_Feature then 19315 Error_Msg_N 19316 ("pragma Ravenscar is an obsolescent feature?j?", N); 19317 Error_Msg_N 19318 ("|use pragma Profile (Ravenscar) instead?j?", N); 19319 end if; 19320 19321 ------------------------- 19322 -- Restricted_Run_Time -- 19323 ------------------------- 19324 19325 -- pragma Restricted_Run_Time; 19326 19327 when Pragma_Restricted_Run_Time => 19328 GNAT_Pragma; 19329 Check_Arg_Count (0); 19330 Check_Valid_Configuration_Pragma; 19331 Set_Profile_Restrictions 19332 (Restricted, N, Warn => Treat_Restrictions_As_Warnings); 19333 19334 if Warn_On_Obsolescent_Feature then 19335 Error_Msg_N 19336 ("pragma Restricted_Run_Time is an obsolescent feature?j?", 19337 N); 19338 Error_Msg_N 19339 ("|use pragma Profile (Restricted) instead?j?", N); 19340 end if; 19341 19342 ------------------ 19343 -- Restrictions -- 19344 ------------------ 19345 19346 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 19347 19348 -- RESTRICTION ::= 19349 -- restriction_IDENTIFIER 19350 -- | restriction_parameter_IDENTIFIER => EXPRESSION 19351 19352 when Pragma_Restrictions => 19353 Process_Restrictions_Or_Restriction_Warnings 19354 (Warn => Treat_Restrictions_As_Warnings); 19355 19356 -------------------------- 19357 -- Restriction_Warnings -- 19358 -------------------------- 19359 19360 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 19361 19362 -- RESTRICTION ::= 19363 -- restriction_IDENTIFIER 19364 -- | restriction_parameter_IDENTIFIER => EXPRESSION 19365 19366 when Pragma_Restriction_Warnings => 19367 GNAT_Pragma; 19368 Process_Restrictions_Or_Restriction_Warnings (Warn => True); 19369 19370 ---------------- 19371 -- Reviewable -- 19372 ---------------- 19373 19374 -- pragma Reviewable; 19375 19376 when Pragma_Reviewable => 19377 Check_Ada_83_Warning; 19378 Check_Arg_Count (0); 19379 19380 -- Call dummy debugging function rv. This is done to assist front 19381 -- end debugging. By placing a Reviewable pragma in the source 19382 -- program, a breakpoint on rv catches this place in the source, 19383 -- allowing convenient stepping to the point of interest. 19384 19385 rv; 19386 19387 -------------------------- 19388 -- Short_Circuit_And_Or -- 19389 -------------------------- 19390 19391 -- pragma Short_Circuit_And_Or; 19392 19393 when Pragma_Short_Circuit_And_Or => 19394 GNAT_Pragma; 19395 Check_Arg_Count (0); 19396 Check_Valid_Configuration_Pragma; 19397 Short_Circuit_And_Or := True; 19398 19399 ------------------- 19400 -- Share_Generic -- 19401 ------------------- 19402 19403 -- pragma Share_Generic (GNAME {, GNAME}); 19404 19405 -- GNAME ::= generic_unit_NAME | generic_instance_NAME 19406 19407 when Pragma_Share_Generic => 19408 GNAT_Pragma; 19409 Process_Generic_List; 19410 19411 ------------ 19412 -- Shared -- 19413 ------------ 19414 19415 -- pragma Shared (LOCAL_NAME); 19416 19417 when Pragma_Shared => 19418 GNAT_Pragma; 19419 Process_Atomic_Shared_Volatile; 19420 19421 -------------------- 19422 -- Shared_Passive -- 19423 -------------------- 19424 19425 -- pragma Shared_Passive [(library_unit_NAME)]; 19426 19427 -- Set the flag Is_Shared_Passive of program unit name entity 19428 19429 when Pragma_Shared_Passive => Shared_Passive : declare 19430 Cunit_Node : Node_Id; 19431 Cunit_Ent : Entity_Id; 19432 19433 begin 19434 Check_Ada_83_Warning; 19435 Check_Valid_Library_Unit_Pragma; 19436 19437 if Nkind (N) = N_Null_Statement then 19438 return; 19439 end if; 19440 19441 Cunit_Node := Cunit (Current_Sem_Unit); 19442 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 19443 19444 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 19445 N_Generic_Package_Declaration) 19446 then 19447 Error_Pragma 19448 ("pragma% can only apply to a package declaration"); 19449 end if; 19450 19451 Set_Is_Shared_Passive (Cunit_Ent); 19452 end Shared_Passive; 19453 19454 ----------------------- 19455 -- Short_Descriptors -- 19456 ----------------------- 19457 19458 -- pragma Short_Descriptors; 19459 19460 when Pragma_Short_Descriptors => 19461 GNAT_Pragma; 19462 Check_Arg_Count (0); 19463 Check_Valid_Configuration_Pragma; 19464 Short_Descriptors := True; 19465 19466 ------------------------------ 19467 -- Simple_Storage_Pool_Type -- 19468 ------------------------------ 19469 19470 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME); 19471 19472 when Pragma_Simple_Storage_Pool_Type => 19473 Simple_Storage_Pool_Type : declare 19474 Type_Id : Node_Id; 19475 Typ : Entity_Id; 19476 19477 begin 19478 GNAT_Pragma; 19479 Check_Arg_Count (1); 19480 Check_Arg_Is_Library_Level_Local_Name (Arg1); 19481 19482 Type_Id := Get_Pragma_Arg (Arg1); 19483 Find_Type (Type_Id); 19484 Typ := Entity (Type_Id); 19485 19486 if Typ = Any_Type then 19487 return; 19488 end if; 19489 19490 -- We require the pragma to apply to a type declared in a package 19491 -- declaration, but not (immediately) within a package body. 19492 19493 if Ekind (Current_Scope) /= E_Package 19494 or else In_Package_Body (Current_Scope) 19495 then 19496 Error_Pragma 19497 ("pragma% can only apply to type declared immediately " 19498 & "within a package declaration"); 19499 end if; 19500 19501 -- A simple storage pool type must be an immutably limited record 19502 -- or private type. If the pragma is given for a private type, 19503 -- the full type is similarly restricted (which is checked later 19504 -- in Freeze_Entity). 19505 19506 if Is_Record_Type (Typ) 19507 and then not Is_Limited_View (Typ) 19508 then 19509 Error_Pragma 19510 ("pragma% can only apply to explicitly limited record type"); 19511 19512 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then 19513 Error_Pragma 19514 ("pragma% can only apply to a private type that is limited"); 19515 19516 elsif not Is_Record_Type (Typ) 19517 and then not Is_Private_Type (Typ) 19518 then 19519 Error_Pragma 19520 ("pragma% can only apply to limited record or private type"); 19521 end if; 19522 19523 Record_Rep_Item (Typ, N); 19524 end Simple_Storage_Pool_Type; 19525 19526 ---------------------- 19527 -- Source_File_Name -- 19528 ---------------------- 19529 19530 -- There are five forms for this pragma: 19531 19532 -- pragma Source_File_Name ( 19533 -- [UNIT_NAME =>] unit_NAME, 19534 -- BODY_FILE_NAME => STRING_LITERAL 19535 -- [, [INDEX =>] INTEGER_LITERAL]); 19536 19537 -- pragma Source_File_Name ( 19538 -- [UNIT_NAME =>] unit_NAME, 19539 -- SPEC_FILE_NAME => STRING_LITERAL 19540 -- [, [INDEX =>] INTEGER_LITERAL]); 19541 19542 -- pragma Source_File_Name ( 19543 -- BODY_FILE_NAME => STRING_LITERAL 19544 -- [, DOT_REPLACEMENT => STRING_LITERAL] 19545 -- [, CASING => CASING_SPEC]); 19546 19547 -- pragma Source_File_Name ( 19548 -- SPEC_FILE_NAME => STRING_LITERAL 19549 -- [, DOT_REPLACEMENT => STRING_LITERAL] 19550 -- [, CASING => CASING_SPEC]); 19551 19552 -- pragma Source_File_Name ( 19553 -- SUBUNIT_FILE_NAME => STRING_LITERAL 19554 -- [, DOT_REPLACEMENT => STRING_LITERAL] 19555 -- [, CASING => CASING_SPEC]); 19556 19557 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 19558 19559 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 19560 -- Source_File_Name (SFN), however their usage is exclusive: SFN can 19561 -- only be used when no project file is used, while SFNP can only be 19562 -- used when a project file is used. 19563 19564 -- No processing here. Processing was completed during parsing, since 19565 -- we need to have file names set as early as possible. Units are 19566 -- loaded well before semantic processing starts. 19567 19568 -- The only processing we defer to this point is the check for 19569 -- correct placement. 19570 19571 when Pragma_Source_File_Name => 19572 GNAT_Pragma; 19573 Check_Valid_Configuration_Pragma; 19574 19575 ------------------------------ 19576 -- Source_File_Name_Project -- 19577 ------------------------------ 19578 19579 -- See Source_File_Name for syntax 19580 19581 -- No processing here. Processing was completed during parsing, since 19582 -- we need to have file names set as early as possible. Units are 19583 -- loaded well before semantic processing starts. 19584 19585 -- The only processing we defer to this point is the check for 19586 -- correct placement. 19587 19588 when Pragma_Source_File_Name_Project => 19589 GNAT_Pragma; 19590 Check_Valid_Configuration_Pragma; 19591 19592 -- Check that a pragma Source_File_Name_Project is used only in a 19593 -- configuration pragmas file. 19594 19595 -- Pragmas Source_File_Name_Project should only be generated by 19596 -- the Project Manager in configuration pragmas files. 19597 19598 -- This is really an ugly test. It seems to depend on some 19599 -- accidental and undocumented property. At the very least it 19600 -- needs to be documented, but it would be better to have a 19601 -- clean way of testing if we are in a configuration file??? 19602 19603 if Present (Parent (N)) then 19604 Error_Pragma 19605 ("pragma% can only appear in a configuration pragmas file"); 19606 end if; 19607 19608 ---------------------- 19609 -- Source_Reference -- 19610 ---------------------- 19611 19612 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); 19613 19614 -- Nothing to do, all processing completed in Par.Prag, since we need 19615 -- the information for possible parser messages that are output. 19616 19617 when Pragma_Source_Reference => 19618 GNAT_Pragma; 19619 19620 ---------------- 19621 -- SPARK_Mode -- 19622 ---------------- 19623 19624 -- pragma SPARK_Mode [(On | Off)]; 19625 19626 when Pragma_SPARK_Mode => Do_SPARK_Mode : declare 19627 Body_Id : Entity_Id; 19628 Context : Node_Id; 19629 Mode : Name_Id; 19630 Mode_Id : SPARK_Mode_Type; 19631 Spec_Id : Entity_Id; 19632 Stmt : Node_Id; 19633 19634 procedure Check_Pragma_Conformance 19635 (Context_Pragma : Node_Id; 19636 Entity_Pragma : Node_Id; 19637 Entity : Entity_Id); 19638 -- If Context_Pragma is not Empty, verify that the new pragma N 19639 -- is compatible with the pragma Context_Pragma that was inherited 19640 -- from the context: 19641 -- . if Context_Pragma is ON, then the new mode can be anything 19642 -- . if Context_Pragma is OFF, then the only allowed new mode is 19643 -- also OFF. 19644 -- 19645 -- If Entity is not Empty, verify that the new pragma N is 19646 -- compatible with Entity_Pragma, the SPARK_Mode previously set 19647 -- for Entity (which may be Empty): 19648 -- . if Entity_Pragma is ON, then the new mode can be anything 19649 -- . if Entity_Pragma is OFF, then the only allowed new mode is 19650 -- also OFF. 19651 -- . if Entity_Pragma is Empty, we always issue an error, as this 19652 -- corresponds to a case where a previous section of Entity 19653 -- had no SPARK_Mode set. 19654 19655 procedure Check_Library_Level_Entity (E : Entity_Id); 19656 -- Verify that pragma is applied to library-level entity E 19657 19658 ------------------------------ 19659 -- Check_Pragma_Conformance -- 19660 ------------------------------ 19661 19662 procedure Check_Pragma_Conformance 19663 (Context_Pragma : Node_Id; 19664 Entity_Pragma : Node_Id; 19665 Entity : Entity_Id) 19666 is 19667 begin 19668 if Present (Context_Pragma) then 19669 pragma Assert (Nkind (Context_Pragma) = N_Pragma); 19670 19671 -- New mode less restrictive than the established mode 19672 19673 if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off 19674 and then Mode_Id = On 19675 then 19676 Error_Msg_N 19677 ("cannot change SPARK_Mode from Off to On", Arg1); 19678 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); 19679 Error_Msg_N ("\SPARK_Mode was set to Off#", Arg1); 19680 raise Pragma_Exit; 19681 end if; 19682 end if; 19683 19684 if Present (Entity) then 19685 if Present (Entity_Pragma) then 19686 if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off 19687 and then Mode_Id = On 19688 then 19689 Error_Msg_N ("incorrect use of SPARK_Mode", Arg1); 19690 Error_Msg_Sloc := Sloc (Entity_Pragma); 19691 Error_Msg_NE 19692 ("\value Off was set for SPARK_Mode on&#", 19693 Arg1, Entity); 19694 raise Pragma_Exit; 19695 end if; 19696 19697 else 19698 Error_Msg_N ("incorrect use of SPARK_Mode", Arg1); 19699 Error_Msg_Sloc := Sloc (Entity); 19700 Error_Msg_NE 19701 ("\no value was set for SPARK_Mode on&#", 19702 Arg1, Entity); 19703 raise Pragma_Exit; 19704 end if; 19705 end if; 19706 end Check_Pragma_Conformance; 19707 19708 -------------------------------- 19709 -- Check_Library_Level_Entity -- 19710 -------------------------------- 19711 19712 procedure Check_Library_Level_Entity (E : Entity_Id) is 19713 MsgF : String := "incorrect placement of pragma%"; 19714 19715 begin 19716 if not Is_Library_Level_Entity (E) then 19717 Error_Msg_Name_1 := Pname; 19718 Fix_Error (MsgF); 19719 Error_Msg_N (MsgF, N); 19720 19721 if Ekind_In (E, E_Generic_Package, 19722 E_Package, 19723 E_Package_Body) 19724 then 19725 Error_Msg_NE 19726 ("\& is not a library-level package", N, E); 19727 else 19728 Error_Msg_NE 19729 ("\& is not a library-level subprogram", N, E); 19730 end if; 19731 19732 raise Pragma_Exit; 19733 end if; 19734 end Check_Library_Level_Entity; 19735 19736 -- Start of processing for Do_SPARK_Mode 19737 19738 begin 19739 GNAT_Pragma; 19740 Check_No_Identifiers; 19741 Check_At_Most_N_Arguments (1); 19742 19743 -- Check the legality of the mode (no argument = ON) 19744 19745 if Arg_Count = 1 then 19746 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 19747 Mode := Chars (Get_Pragma_Arg (Arg1)); 19748 else 19749 Mode := Name_On; 19750 end if; 19751 19752 Mode_Id := Get_SPARK_Mode_Type (Mode); 19753 Context := Parent (N); 19754 19755 -- Packages and subprograms declared in a generic unit cannot be 19756 -- subject to the pragma. 19757 19758 if Inside_A_Generic then 19759 Error_Pragma ("incorrect placement of pragma% in a generic"); 19760 19761 -- The pragma appears in a configuration pragmas file 19762 19763 elsif No (Context) then 19764 Check_Valid_Configuration_Pragma; 19765 19766 if Present (SPARK_Mode_Pragma) then 19767 Error_Msg_Sloc := Sloc (SPARK_Mode_Pragma); 19768 Error_Msg_N ("pragma% duplicates pragma declared#", N); 19769 raise Pragma_Exit; 19770 end if; 19771 19772 SPARK_Mode_Pragma := N; 19773 SPARK_Mode := Mode_Id; 19774 19775 -- When the pragma is placed before the declaration of a unit, it 19776 -- configures the whole unit. 19777 19778 elsif Nkind (Context) = N_Compilation_Unit then 19779 Check_Valid_Configuration_Pragma; 19780 19781 if Nkind (Unit (Context)) in N_Generic_Declaration 19782 or else (Present (Library_Unit (Context)) 19783 and then Nkind (Unit (Library_Unit (Context))) in 19784 N_Generic_Declaration) 19785 then 19786 Error_Pragma ("incorrect placement of pragma% in a generic"); 19787 end if; 19788 19789 SPARK_Mode_Pragma := N; 19790 SPARK_Mode := Mode_Id; 19791 19792 -- The pragma applies to a [library unit] subprogram or package 19793 19794 else 19795 -- Verify the placement of the pragma with respect to package 19796 -- or subprogram declarations and detect duplicates. 19797 19798 Stmt := Prev (N); 19799 while Present (Stmt) loop 19800 19801 -- Skip prior pragmas, but check for duplicates 19802 19803 if Nkind (Stmt) = N_Pragma then 19804 if Pragma_Name (Stmt) = Pname then 19805 Error_Msg_Name_1 := Pname; 19806 Error_Msg_Sloc := Sloc (Stmt); 19807 Error_Msg_N ("pragma% duplicates pragma declared#", N); 19808 raise Pragma_Exit; 19809 end if; 19810 19811 -- Skip internally generated code 19812 19813 elsif not Comes_From_Source (Stmt) then 19814 null; 19815 19816 elsif Nkind (Stmt) in N_Generic_Declaration then 19817 Error_Pragma 19818 ("incorrect placement of pragma% on a generic"); 19819 19820 -- The pragma applies to a package declaration 19821 19822 elsif Nkind (Stmt) = N_Package_Declaration then 19823 Spec_Id := Defining_Entity (Stmt); 19824 Check_Library_Level_Entity (Spec_Id); 19825 Check_Pragma_Conformance 19826 (Context_Pragma => SPARK_Pragma (Spec_Id), 19827 Entity_Pragma => Empty, 19828 Entity => Empty); 19829 19830 Set_SPARK_Pragma (Spec_Id, N); 19831 Set_SPARK_Pragma_Inherited (Spec_Id, False); 19832 Set_SPARK_Aux_Pragma (Spec_Id, N); 19833 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); 19834 return; 19835 19836 -- The pragma applies to a subprogram declaration 19837 19838 elsif Nkind (Stmt) = N_Subprogram_Declaration then 19839 Spec_Id := Defining_Entity (Stmt); 19840 Check_Library_Level_Entity (Spec_Id); 19841 Check_Pragma_Conformance 19842 (Context_Pragma => SPARK_Pragma (Spec_Id), 19843 Entity_Pragma => Empty, 19844 Entity => Empty); 19845 19846 Set_SPARK_Pragma (Spec_Id, N); 19847 Set_SPARK_Pragma_Inherited (Spec_Id, False); 19848 return; 19849 19850 -- The pragma does not apply to a legal construct, issue an 19851 -- error and stop the analysis. 19852 19853 else 19854 Pragma_Misplaced; 19855 exit; 19856 end if; 19857 19858 Stmt := Prev (Stmt); 19859 end loop; 19860 19861 -- Handle all cases where the pragma is actually an aspect and 19862 -- applies to a library-level package spec, body or subprogram. 19863 19864 -- function F ... with SPARK_Mode => ...; 19865 -- package P with SPARK_Mode => ...; 19866 -- package body P with SPARK_Mode => ... is 19867 19868 -- The following circuitry simply prepares the proper context 19869 -- for the general pragma processing mechanism below. 19870 19871 if Nkind (Context) = N_Compilation_Unit_Aux then 19872 Context := Unit (Parent (Context)); 19873 19874 if Nkind_In (Context, N_Package_Declaration, 19875 N_Subprogram_Declaration) 19876 then 19877 Context := Specification (Context); 19878 end if; 19879 end if; 19880 19881 -- The pragma is at the top level of a package spec 19882 19883 -- package P is 19884 -- pragma SPARK_Mode; 19885 19886 -- or 19887 19888 -- package P is 19889 -- ... 19890 -- private 19891 -- pragma SPARK_Mode; 19892 19893 if Nkind (Context) = N_Package_Specification then 19894 Spec_Id := Defining_Entity (Context); 19895 19896 -- Pragma applies to private part 19897 19898 if List_Containing (N) = Private_Declarations (Context) then 19899 Check_Library_Level_Entity (Spec_Id); 19900 Check_Pragma_Conformance 19901 (Context_Pragma => Empty, 19902 Entity_Pragma => SPARK_Pragma (Spec_Id), 19903 Entity => Spec_Id); 19904 SPARK_Mode_Pragma := N; 19905 SPARK_Mode := Mode_Id; 19906 19907 Set_SPARK_Aux_Pragma (Spec_Id, N); 19908 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); 19909 19910 -- Pragma applies to public part 19911 19912 else 19913 Check_Library_Level_Entity (Spec_Id); 19914 Check_Pragma_Conformance 19915 (Context_Pragma => SPARK_Pragma (Spec_Id), 19916 Entity_Pragma => Empty, 19917 Entity => Empty); 19918 SPARK_Mode_Pragma := N; 19919 SPARK_Mode := Mode_Id; 19920 19921 Set_SPARK_Pragma (Spec_Id, N); 19922 Set_SPARK_Pragma_Inherited (Spec_Id, False); 19923 Set_SPARK_Aux_Pragma (Spec_Id, N); 19924 Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); 19925 end if; 19926 19927 -- The pragma appears as an aspect on a subprogram. 19928 19929 -- function F ... with SPARK_Mode => ...; 19930 19931 elsif Nkind_In (Context, N_Function_Specification, 19932 N_Procedure_Specification) 19933 then 19934 Spec_Id := Defining_Entity (Context); 19935 Check_Library_Level_Entity (Spec_Id); 19936 Check_Pragma_Conformance 19937 (Context_Pragma => SPARK_Pragma (Spec_Id), 19938 Entity_Pragma => Empty, 19939 Entity => Empty); 19940 Set_SPARK_Pragma (Spec_Id, N); 19941 Set_SPARK_Pragma_Inherited (Spec_Id, False); 19942 19943 -- Pragma is immediately within a package body 19944 19945 -- package body P is 19946 -- pragma SPARK_Mode; 19947 19948 elsif Nkind (Context) = N_Package_Body then 19949 Spec_Id := Corresponding_Spec (Context); 19950 Body_Id := Defining_Entity (Context); 19951 Check_Library_Level_Entity (Body_Id); 19952 Check_Pragma_Conformance 19953 (Context_Pragma => SPARK_Pragma (Body_Id), 19954 Entity_Pragma => SPARK_Aux_Pragma (Spec_Id), 19955 Entity => Spec_Id); 19956 SPARK_Mode_Pragma := N; 19957 SPARK_Mode := Mode_Id; 19958 19959 Set_SPARK_Pragma (Body_Id, N); 19960 Set_SPARK_Pragma_Inherited (Body_Id, False); 19961 Set_SPARK_Aux_Pragma (Body_Id, N); 19962 Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); 19963 19964 -- Pragma is immediately within a subprogram body 19965 19966 -- function F ... is 19967 -- pragma SPARK_Mode; 19968 19969 elsif Nkind (Context) = N_Subprogram_Body then 19970 Spec_Id := Corresponding_Spec (Context); 19971 Context := Specification (Context); 19972 Body_Id := Defining_Entity (Context); 19973 Check_Library_Level_Entity (Body_Id); 19974 19975 if Present (Spec_Id) then 19976 Check_Pragma_Conformance 19977 (Context_Pragma => SPARK_Pragma (Body_Id), 19978 Entity_Pragma => SPARK_Pragma (Spec_Id), 19979 Entity => Spec_Id); 19980 else 19981 Check_Pragma_Conformance 19982 (Context_Pragma => SPARK_Pragma (Body_Id), 19983 Entity_Pragma => Empty, 19984 Entity => Empty); 19985 end if; 19986 19987 SPARK_Mode_Pragma := N; 19988 SPARK_Mode := Mode_Id; 19989 19990 Set_SPARK_Pragma (Body_Id, N); 19991 Set_SPARK_Pragma_Inherited (Body_Id, False); 19992 19993 -- The pragma applies to the statements of a package body 19994 19995 -- package body P is 19996 -- begin 19997 -- pragma SPARK_Mode; 19998 19999 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements 20000 and then Nkind (Parent (Context)) = N_Package_Body 20001 then 20002 Context := Parent (Context); 20003 Spec_Id := Corresponding_Spec (Context); 20004 Body_Id := Defining_Entity (Context); 20005 Check_Library_Level_Entity (Body_Id); 20006 Check_Pragma_Conformance 20007 (Context_Pragma => Empty, 20008 Entity_Pragma => SPARK_Pragma (Body_Id), 20009 Entity => Body_Id); 20010 SPARK_Mode_Pragma := N; 20011 SPARK_Mode := Mode_Id; 20012 20013 Set_SPARK_Aux_Pragma (Body_Id, N); 20014 Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); 20015 20016 -- The pragma does not apply to a legal construct, issue error 20017 20018 else 20019 Pragma_Misplaced; 20020 end if; 20021 end if; 20022 end Do_SPARK_Mode; 20023 20024 -------------------------------- 20025 -- Static_Elaboration_Desired -- 20026 -------------------------------- 20027 20028 -- pragma Static_Elaboration_Desired (DIRECT_NAME); 20029 20030 when Pragma_Static_Elaboration_Desired => 20031 GNAT_Pragma; 20032 Check_At_Most_N_Arguments (1); 20033 20034 if Is_Compilation_Unit (Current_Scope) 20035 and then Ekind (Current_Scope) = E_Package 20036 then 20037 Set_Static_Elaboration_Desired (Current_Scope, True); 20038 else 20039 Error_Pragma ("pragma% must apply to a library-level package"); 20040 end if; 20041 20042 ------------------ 20043 -- Storage_Size -- 20044 ------------------ 20045 20046 -- pragma Storage_Size (EXPRESSION); 20047 20048 when Pragma_Storage_Size => Storage_Size : declare 20049 P : constant Node_Id := Parent (N); 20050 Arg : Node_Id; 20051 20052 begin 20053 Check_No_Identifiers; 20054 Check_Arg_Count (1); 20055 20056 -- The expression must be analyzed in the special manner described 20057 -- in "Handling of Default Expressions" in sem.ads. 20058 20059 Arg := Get_Pragma_Arg (Arg1); 20060 Preanalyze_Spec_Expression (Arg, Any_Integer); 20061 20062 if not Is_Static_Expression (Arg) then 20063 Check_Restriction (Static_Storage_Size, Arg); 20064 end if; 20065 20066 if Nkind (P) /= N_Task_Definition then 20067 Pragma_Misplaced; 20068 return; 20069 20070 else 20071 if Has_Storage_Size_Pragma (P) then 20072 Error_Pragma ("duplicate pragma% not allowed"); 20073 else 20074 Set_Has_Storage_Size_Pragma (P, True); 20075 end if; 20076 20077 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 20078 end if; 20079 end Storage_Size; 20080 20081 ------------------ 20082 -- Storage_Unit -- 20083 ------------------ 20084 20085 -- pragma Storage_Unit (NUMERIC_LITERAL); 20086 20087 -- Only permitted argument is System'Storage_Unit value 20088 20089 when Pragma_Storage_Unit => 20090 Check_No_Identifiers; 20091 Check_Arg_Count (1); 20092 Check_Arg_Is_Integer_Literal (Arg1); 20093 20094 if Intval (Get_Pragma_Arg (Arg1)) /= 20095 UI_From_Int (Ttypes.System_Storage_Unit) 20096 then 20097 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); 20098 Error_Pragma_Arg 20099 ("the only allowed argument for pragma% is ^", Arg1); 20100 end if; 20101 20102 -------------------- 20103 -- Stream_Convert -- 20104 -------------------- 20105 20106 -- pragma Stream_Convert ( 20107 -- [Entity =>] type_LOCAL_NAME, 20108 -- [Read =>] function_NAME, 20109 -- [Write =>] function NAME); 20110 20111 when Pragma_Stream_Convert => Stream_Convert : declare 20112 20113 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); 20114 -- Check that the given argument is the name of a local function 20115 -- of one argument that is not overloaded earlier in the current 20116 -- local scope. A check is also made that the argument is a 20117 -- function with one parameter. 20118 20119 -------------------------------------- 20120 -- Check_OK_Stream_Convert_Function -- 20121 -------------------------------------- 20122 20123 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is 20124 Ent : Entity_Id; 20125 20126 begin 20127 Check_Arg_Is_Local_Name (Arg); 20128 Ent := Entity (Get_Pragma_Arg (Arg)); 20129 20130 if Has_Homonym (Ent) then 20131 Error_Pragma_Arg 20132 ("argument for pragma% may not be overloaded", Arg); 20133 end if; 20134 20135 if Ekind (Ent) /= E_Function 20136 or else No (First_Formal (Ent)) 20137 or else Present (Next_Formal (First_Formal (Ent))) 20138 then 20139 Error_Pragma_Arg 20140 ("argument for pragma% must be function of one argument", 20141 Arg); 20142 end if; 20143 end Check_OK_Stream_Convert_Function; 20144 20145 -- Start of processing for Stream_Convert 20146 20147 begin 20148 GNAT_Pragma; 20149 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write)); 20150 Check_Arg_Count (3); 20151 Check_Optional_Identifier (Arg1, Name_Entity); 20152 Check_Optional_Identifier (Arg2, Name_Read); 20153 Check_Optional_Identifier (Arg3, Name_Write); 20154 Check_Arg_Is_Local_Name (Arg1); 20155 Check_OK_Stream_Convert_Function (Arg2); 20156 Check_OK_Stream_Convert_Function (Arg3); 20157 20158 declare 20159 Typ : constant Entity_Id := 20160 Underlying_Type (Entity (Get_Pragma_Arg (Arg1))); 20161 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2)); 20162 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3)); 20163 20164 begin 20165 Check_First_Subtype (Arg1); 20166 20167 -- Check for too early or too late. Note that we don't enforce 20168 -- the rule about primitive operations in this case, since, as 20169 -- is the case for explicit stream attributes themselves, these 20170 -- restrictions are not appropriate. Note that the chaining of 20171 -- the pragma by Rep_Item_Too_Late is actually the critical 20172 -- processing done for this pragma. 20173 20174 if Rep_Item_Too_Early (Typ, N) 20175 or else 20176 Rep_Item_Too_Late (Typ, N, FOnly => True) 20177 then 20178 return; 20179 end if; 20180 20181 -- Return if previous error 20182 20183 if Etype (Typ) = Any_Type 20184 or else 20185 Etype (Read) = Any_Type 20186 or else 20187 Etype (Write) = Any_Type 20188 then 20189 return; 20190 end if; 20191 20192 -- Error checks 20193 20194 if Underlying_Type (Etype (Read)) /= Typ then 20195 Error_Pragma_Arg 20196 ("incorrect return type for function&", Arg2); 20197 end if; 20198 20199 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then 20200 Error_Pragma_Arg 20201 ("incorrect parameter type for function&", Arg3); 20202 end if; 20203 20204 if Underlying_Type (Etype (First_Formal (Read))) /= 20205 Underlying_Type (Etype (Write)) 20206 then 20207 Error_Pragma_Arg 20208 ("result type of & does not match Read parameter type", 20209 Arg3); 20210 end if; 20211 end; 20212 end Stream_Convert; 20213 20214 ------------------ 20215 -- Style_Checks -- 20216 ------------------ 20217 20218 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 20219 20220 -- This is processed by the parser since some of the style checks 20221 -- take place during source scanning and parsing. This means that 20222 -- we don't need to issue error messages here. 20223 20224 when Pragma_Style_Checks => Style_Checks : declare 20225 A : constant Node_Id := Get_Pragma_Arg (Arg1); 20226 S : String_Id; 20227 C : Char_Code; 20228 20229 begin 20230 GNAT_Pragma; 20231 Check_No_Identifiers; 20232 20233 -- Two argument form 20234 20235 if Arg_Count = 2 then 20236 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 20237 20238 declare 20239 E_Id : Node_Id; 20240 E : Entity_Id; 20241 20242 begin 20243 E_Id := Get_Pragma_Arg (Arg2); 20244 Analyze (E_Id); 20245 20246 if not Is_Entity_Name (E_Id) then 20247 Error_Pragma_Arg 20248 ("second argument of pragma% must be entity name", 20249 Arg2); 20250 end if; 20251 20252 E := Entity (E_Id); 20253 20254 if not Ignore_Style_Checks_Pragmas then 20255 if E = Any_Id then 20256 return; 20257 else 20258 loop 20259 Set_Suppress_Style_Checks 20260 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off); 20261 exit when No (Homonym (E)); 20262 E := Homonym (E); 20263 end loop; 20264 end if; 20265 end if; 20266 end; 20267 20268 -- One argument form 20269 20270 else 20271 Check_Arg_Count (1); 20272 20273 if Nkind (A) = N_String_Literal then 20274 S := Strval (A); 20275 20276 declare 20277 Slen : constant Natural := Natural (String_Length (S)); 20278 Options : String (1 .. Slen); 20279 J : Natural; 20280 20281 begin 20282 J := 1; 20283 loop 20284 C := Get_String_Char (S, Int (J)); 20285 exit when not In_Character_Range (C); 20286 Options (J) := Get_Character (C); 20287 20288 -- If at end of string, set options. As per discussion 20289 -- above, no need to check for errors, since we issued 20290 -- them in the parser. 20291 20292 if J = Slen then 20293 if not Ignore_Style_Checks_Pragmas then 20294 Set_Style_Check_Options (Options); 20295 end if; 20296 20297 exit; 20298 end if; 20299 20300 J := J + 1; 20301 end loop; 20302 end; 20303 20304 elsif Nkind (A) = N_Identifier then 20305 if Chars (A) = Name_All_Checks then 20306 if not Ignore_Style_Checks_Pragmas then 20307 if GNAT_Mode then 20308 Set_GNAT_Style_Check_Options; 20309 else 20310 Set_Default_Style_Check_Options; 20311 end if; 20312 end if; 20313 20314 elsif Chars (A) = Name_On then 20315 if not Ignore_Style_Checks_Pragmas then 20316 Style_Check := True; 20317 end if; 20318 20319 elsif Chars (A) = Name_Off then 20320 if not Ignore_Style_Checks_Pragmas then 20321 Style_Check := False; 20322 end if; 20323 end if; 20324 end if; 20325 end if; 20326 end Style_Checks; 20327 20328 -------------- 20329 -- Subtitle -- 20330 -------------- 20331 20332 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL); 20333 20334 when Pragma_Subtitle => 20335 GNAT_Pragma; 20336 Check_Arg_Count (1); 20337 Check_Optional_Identifier (Arg1, Name_Subtitle); 20338 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 20339 Store_Note (N); 20340 20341 -------------- 20342 -- Suppress -- 20343 -------------- 20344 20345 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); 20346 20347 when Pragma_Suppress => 20348 Process_Suppress_Unsuppress (True); 20349 20350 ------------------ 20351 -- Suppress_All -- 20352 ------------------ 20353 20354 -- pragma Suppress_All; 20355 20356 -- The only check made here is that the pragma has no arguments. 20357 -- There are no placement rules, and the processing required (setting 20358 -- the Has_Pragma_Suppress_All flag in the compilation unit node was 20359 -- taken care of by the parser). Process_Compilation_Unit_Pragmas 20360 -- then creates and inserts a pragma Suppress (All_Checks). 20361 20362 when Pragma_Suppress_All => 20363 GNAT_Pragma; 20364 Check_Arg_Count (0); 20365 20366 ------------------------- 20367 -- Suppress_Debug_Info -- 20368 ------------------------- 20369 20370 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME); 20371 20372 when Pragma_Suppress_Debug_Info => 20373 GNAT_Pragma; 20374 Check_Arg_Count (1); 20375 Check_Optional_Identifier (Arg1, Name_Entity); 20376 Check_Arg_Is_Local_Name (Arg1); 20377 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1))); 20378 20379 ---------------------------------- 20380 -- Suppress_Exception_Locations -- 20381 ---------------------------------- 20382 20383 -- pragma Suppress_Exception_Locations; 20384 20385 when Pragma_Suppress_Exception_Locations => 20386 GNAT_Pragma; 20387 Check_Arg_Count (0); 20388 Check_Valid_Configuration_Pragma; 20389 Exception_Locations_Suppressed := True; 20390 20391 ----------------------------- 20392 -- Suppress_Initialization -- 20393 ----------------------------- 20394 20395 -- pragma Suppress_Initialization ([Entity =>] type_Name); 20396 20397 when Pragma_Suppress_Initialization => Suppress_Init : declare 20398 E_Id : Node_Id; 20399 E : Entity_Id; 20400 20401 begin 20402 GNAT_Pragma; 20403 Check_Arg_Count (1); 20404 Check_Optional_Identifier (Arg1, Name_Entity); 20405 Check_Arg_Is_Local_Name (Arg1); 20406 20407 E_Id := Get_Pragma_Arg (Arg1); 20408 20409 if Etype (E_Id) = Any_Type then 20410 return; 20411 end if; 20412 20413 E := Entity (E_Id); 20414 20415 if not Is_Type (E) then 20416 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1); 20417 end if; 20418 20419 if Rep_Item_Too_Early (E, N) 20420 or else 20421 Rep_Item_Too_Late (E, N, FOnly => True) 20422 then 20423 return; 20424 end if; 20425 20426 -- For incomplete/private type, set flag on full view 20427 20428 if Is_Incomplete_Or_Private_Type (E) then 20429 if No (Full_View (Base_Type (E))) then 20430 Error_Pragma_Arg 20431 ("argument of pragma% cannot be an incomplete type", Arg1); 20432 else 20433 Set_Suppress_Initialization (Full_View (Base_Type (E))); 20434 end if; 20435 20436 -- For first subtype, set flag on base type 20437 20438 elsif Is_First_Subtype (E) then 20439 Set_Suppress_Initialization (Base_Type (E)); 20440 20441 -- For other than first subtype, set flag on subtype itself 20442 20443 else 20444 Set_Suppress_Initialization (E); 20445 end if; 20446 end Suppress_Init; 20447 20448 ----------------- 20449 -- System_Name -- 20450 ----------------- 20451 20452 -- pragma System_Name (DIRECT_NAME); 20453 20454 -- Syntax check: one argument, which must be the identifier GNAT or 20455 -- the identifier GCC, no other identifiers are acceptable. 20456 20457 when Pragma_System_Name => 20458 GNAT_Pragma; 20459 Check_No_Identifiers; 20460 Check_Arg_Count (1); 20461 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); 20462 20463 ----------------------------- 20464 -- Task_Dispatching_Policy -- 20465 ----------------------------- 20466 20467 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER); 20468 20469 when Pragma_Task_Dispatching_Policy => declare 20470 DP : Character; 20471 20472 begin 20473 Check_Ada_83_Warning; 20474 Check_Arg_Count (1); 20475 Check_No_Identifiers; 20476 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 20477 Check_Valid_Configuration_Pragma; 20478 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 20479 DP := Fold_Upper (Name_Buffer (1)); 20480 20481 if Task_Dispatching_Policy /= ' ' 20482 and then Task_Dispatching_Policy /= DP 20483 then 20484 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 20485 Error_Pragma 20486 ("task dispatching policy incompatible with policy#"); 20487 20488 -- Set new policy, but always preserve System_Location since we 20489 -- like the error message with the run time name. 20490 20491 else 20492 Task_Dispatching_Policy := DP; 20493 20494 if Task_Dispatching_Policy_Sloc /= System_Location then 20495 Task_Dispatching_Policy_Sloc := Loc; 20496 end if; 20497 end if; 20498 end; 20499 20500 --------------- 20501 -- Task_Info -- 20502 --------------- 20503 20504 -- pragma Task_Info (EXPRESSION); 20505 20506 when Pragma_Task_Info => Task_Info : declare 20507 P : constant Node_Id := Parent (N); 20508 Ent : Entity_Id; 20509 20510 begin 20511 GNAT_Pragma; 20512 20513 if Nkind (P) /= N_Task_Definition then 20514 Error_Pragma ("pragma% must appear in task definition"); 20515 end if; 20516 20517 Check_No_Identifiers; 20518 Check_Arg_Count (1); 20519 20520 Analyze_And_Resolve 20521 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type)); 20522 20523 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then 20524 return; 20525 end if; 20526 20527 Ent := Defining_Identifier (Parent (P)); 20528 20529 -- Check duplicate pragma before we chain the pragma in the Rep 20530 -- Item chain of Ent. 20531 20532 if Has_Rep_Pragma 20533 (Ent, Name_Task_Info, Check_Parents => False) 20534 then 20535 Error_Pragma ("duplicate pragma% not allowed"); 20536 end if; 20537 20538 Record_Rep_Item (Ent, N); 20539 end Task_Info; 20540 20541 --------------- 20542 -- Task_Name -- 20543 --------------- 20544 20545 -- pragma Task_Name (string_EXPRESSION); 20546 20547 when Pragma_Task_Name => Task_Name : declare 20548 P : constant Node_Id := Parent (N); 20549 Arg : Node_Id; 20550 Ent : Entity_Id; 20551 20552 begin 20553 Check_No_Identifiers; 20554 Check_Arg_Count (1); 20555 20556 Arg := Get_Pragma_Arg (Arg1); 20557 20558 -- The expression is used in the call to Create_Task, and must be 20559 -- expanded there, not in the context of the current spec. It must 20560 -- however be analyzed to capture global references, in case it 20561 -- appears in a generic context. 20562 20563 Preanalyze_And_Resolve (Arg, Standard_String); 20564 20565 if Nkind (P) /= N_Task_Definition then 20566 Pragma_Misplaced; 20567 end if; 20568 20569 Ent := Defining_Identifier (Parent (P)); 20570 20571 -- Check duplicate pragma before we chain the pragma in the Rep 20572 -- Item chain of Ent. 20573 20574 if Has_Rep_Pragma 20575 (Ent, Name_Task_Name, Check_Parents => False) 20576 then 20577 Error_Pragma ("duplicate pragma% not allowed"); 20578 end if; 20579 20580 Record_Rep_Item (Ent, N); 20581 end Task_Name; 20582 20583 ------------------ 20584 -- Task_Storage -- 20585 ------------------ 20586 20587 -- pragma Task_Storage ( 20588 -- [Task_Type =>] LOCAL_NAME, 20589 -- [Top_Guard =>] static_integer_EXPRESSION); 20590 20591 when Pragma_Task_Storage => Task_Storage : declare 20592 Args : Args_List (1 .. 2); 20593 Names : constant Name_List (1 .. 2) := ( 20594 Name_Task_Type, 20595 Name_Top_Guard); 20596 20597 Task_Type : Node_Id renames Args (1); 20598 Top_Guard : Node_Id renames Args (2); 20599 20600 Ent : Entity_Id; 20601 20602 begin 20603 GNAT_Pragma; 20604 Gather_Associations (Names, Args); 20605 20606 if No (Task_Type) then 20607 Error_Pragma 20608 ("missing task_type argument for pragma%"); 20609 end if; 20610 20611 Check_Arg_Is_Local_Name (Task_Type); 20612 20613 Ent := Entity (Task_Type); 20614 20615 if not Is_Task_Type (Ent) then 20616 Error_Pragma_Arg 20617 ("argument for pragma% must be task type", Task_Type); 20618 end if; 20619 20620 if No (Top_Guard) then 20621 Error_Pragma_Arg 20622 ("pragma% takes two arguments", Task_Type); 20623 else 20624 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer); 20625 end if; 20626 20627 Check_First_Subtype (Task_Type); 20628 20629 if Rep_Item_Too_Late (Ent, N) then 20630 raise Pragma_Exit; 20631 end if; 20632 end Task_Storage; 20633 20634 --------------- 20635 -- Test_Case -- 20636 --------------- 20637 20638 -- pragma Test_Case 20639 -- ([Name =>] Static_String_EXPRESSION 20640 -- ,[Mode =>] MODE_TYPE 20641 -- [, Requires => Boolean_EXPRESSION] 20642 -- [, Ensures => Boolean_EXPRESSION]); 20643 20644 -- MODE_TYPE ::= Nominal | Robustness 20645 20646 when Pragma_Test_Case => 20647 GNAT_Pragma; 20648 Check_Test_Case; 20649 20650 -------------------------- 20651 -- Thread_Local_Storage -- 20652 -------------------------- 20653 20654 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); 20655 20656 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare 20657 Id : Node_Id; 20658 E : Entity_Id; 20659 20660 begin 20661 GNAT_Pragma; 20662 Check_Arg_Count (1); 20663 Check_Optional_Identifier (Arg1, Name_Entity); 20664 Check_Arg_Is_Library_Level_Local_Name (Arg1); 20665 20666 Id := Get_Pragma_Arg (Arg1); 20667 Analyze (Id); 20668 20669 if not Is_Entity_Name (Id) 20670 or else Ekind (Entity (Id)) /= E_Variable 20671 then 20672 Error_Pragma_Arg ("local variable name required", Arg1); 20673 end if; 20674 20675 E := Entity (Id); 20676 20677 if Rep_Item_Too_Early (E, N) 20678 or else Rep_Item_Too_Late (E, N) 20679 then 20680 raise Pragma_Exit; 20681 end if; 20682 20683 Set_Has_Pragma_Thread_Local_Storage (E); 20684 Set_Has_Gigi_Rep_Item (E); 20685 end Thread_Local_Storage; 20686 20687 ---------------- 20688 -- Time_Slice -- 20689 ---------------- 20690 20691 -- pragma Time_Slice (static_duration_EXPRESSION); 20692 20693 when Pragma_Time_Slice => Time_Slice : declare 20694 Val : Ureal; 20695 Nod : Node_Id; 20696 20697 begin 20698 GNAT_Pragma; 20699 Check_Arg_Count (1); 20700 Check_No_Identifiers; 20701 Check_In_Main_Program; 20702 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration); 20703 20704 if not Error_Posted (Arg1) then 20705 Nod := Next (N); 20706 while Present (Nod) loop 20707 if Nkind (Nod) = N_Pragma 20708 and then Pragma_Name (Nod) = Name_Time_Slice 20709 then 20710 Error_Msg_Name_1 := Pname; 20711 Error_Msg_N ("duplicate pragma% not permitted", Nod); 20712 end if; 20713 20714 Next (Nod); 20715 end loop; 20716 end if; 20717 20718 -- Process only if in main unit 20719 20720 if Get_Source_Unit (Loc) = Main_Unit then 20721 Opt.Time_Slice_Set := True; 20722 Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); 20723 20724 if Val <= Ureal_0 then 20725 Opt.Time_Slice_Value := 0; 20726 20727 elsif Val > UR_From_Uint (UI_From_Int (1000)) then 20728 Opt.Time_Slice_Value := 1_000_000_000; 20729 20730 else 20731 Opt.Time_Slice_Value := 20732 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000))); 20733 end if; 20734 end if; 20735 end Time_Slice; 20736 20737 ----------- 20738 -- Title -- 20739 ----------- 20740 20741 -- pragma Title (TITLING_OPTION [, TITLING OPTION]); 20742 20743 -- TITLING_OPTION ::= 20744 -- [Title =>] STRING_LITERAL 20745 -- | [Subtitle =>] STRING_LITERAL 20746 20747 when Pragma_Title => Title : declare 20748 Args : Args_List (1 .. 2); 20749 Names : constant Name_List (1 .. 2) := ( 20750 Name_Title, 20751 Name_Subtitle); 20752 20753 begin 20754 GNAT_Pragma; 20755 Gather_Associations (Names, Args); 20756 Store_Note (N); 20757 20758 for J in 1 .. 2 loop 20759 if Present (Args (J)) then 20760 Check_Arg_Is_Static_Expression (Args (J), Standard_String); 20761 end if; 20762 end loop; 20763 end Title; 20764 20765 ---------------------------- 20766 -- Type_Invariant[_Class] -- 20767 ---------------------------- 20768 20769 -- pragma Type_Invariant[_Class] 20770 -- ([Entity =>] type_LOCAL_NAME, 20771 -- [Check =>] EXPRESSION); 20772 20773 when Pragma_Type_Invariant | 20774 Pragma_Type_Invariant_Class => 20775 Type_Invariant : declare 20776 I_Pragma : Node_Id; 20777 20778 begin 20779 Check_Arg_Count (2); 20780 20781 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma, 20782 -- setting Class_Present for the Type_Invariant_Class case. 20783 20784 Set_Class_Present (N, Prag_Id = Pragma_Type_Invariant_Class); 20785 I_Pragma := New_Copy (N); 20786 Set_Pragma_Identifier 20787 (I_Pragma, Make_Identifier (Loc, Name_Invariant)); 20788 Rewrite (N, I_Pragma); 20789 Set_Analyzed (N, False); 20790 Analyze (N); 20791 end Type_Invariant; 20792 20793 --------------------- 20794 -- Unchecked_Union -- 20795 --------------------- 20796 20797 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) 20798 20799 when Pragma_Unchecked_Union => Unchecked_Union : declare 20800 Assoc : constant Node_Id := Arg1; 20801 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 20802 Typ : Entity_Id; 20803 Tdef : Node_Id; 20804 Clist : Node_Id; 20805 Vpart : Node_Id; 20806 Comp : Node_Id; 20807 Variant : Node_Id; 20808 20809 begin 20810 Ada_2005_Pragma; 20811 Check_No_Identifiers; 20812 Check_Arg_Count (1); 20813 Check_Arg_Is_Local_Name (Arg1); 20814 20815 Find_Type (Type_Id); 20816 20817 Typ := Entity (Type_Id); 20818 20819 if Typ = Any_Type 20820 or else Rep_Item_Too_Early (Typ, N) 20821 then 20822 return; 20823 else 20824 Typ := Underlying_Type (Typ); 20825 end if; 20826 20827 if Rep_Item_Too_Late (Typ, N) then 20828 return; 20829 end if; 20830 20831 Check_First_Subtype (Arg1); 20832 20833 -- Note remaining cases are references to a type in the current 20834 -- declarative part. If we find an error, we post the error on 20835 -- the relevant type declaration at an appropriate point. 20836 20837 if not Is_Record_Type (Typ) then 20838 Error_Msg_N ("unchecked union must be record type", Typ); 20839 return; 20840 20841 elsif Is_Tagged_Type (Typ) then 20842 Error_Msg_N ("unchecked union must not be tagged", Typ); 20843 return; 20844 20845 elsif not Has_Discriminants (Typ) then 20846 Error_Msg_N 20847 ("unchecked union must have one discriminant", Typ); 20848 return; 20849 20850 -- Note: in previous versions of GNAT we used to check for limited 20851 -- types and give an error, but in fact the standard does allow 20852 -- Unchecked_Union on limited types, so this check was removed. 20853 20854 -- Similarly, GNAT used to require that all discriminants have 20855 -- default values, but this is not mandated by the RM. 20856 20857 -- Proceed with basic error checks completed 20858 20859 else 20860 Tdef := Type_Definition (Declaration_Node (Typ)); 20861 Clist := Component_List (Tdef); 20862 20863 -- Check presence of component list and variant part 20864 20865 if No (Clist) or else No (Variant_Part (Clist)) then 20866 Error_Msg_N 20867 ("unchecked union must have variant part", Tdef); 20868 return; 20869 end if; 20870 20871 -- Check components 20872 20873 Comp := First (Component_Items (Clist)); 20874 while Present (Comp) loop 20875 Check_Component (Comp, Typ); 20876 Next (Comp); 20877 end loop; 20878 20879 -- Check variant part 20880 20881 Vpart := Variant_Part (Clist); 20882 20883 Variant := First (Variants (Vpart)); 20884 while Present (Variant) loop 20885 Check_Variant (Variant, Typ); 20886 Next (Variant); 20887 end loop; 20888 end if; 20889 20890 Set_Is_Unchecked_Union (Typ); 20891 Set_Convention (Typ, Convention_C); 20892 Set_Has_Unchecked_Union (Base_Type (Typ)); 20893 Set_Is_Unchecked_Union (Base_Type (Typ)); 20894 end Unchecked_Union; 20895 20896 ------------------------ 20897 -- Unimplemented_Unit -- 20898 ------------------------ 20899 20900 -- pragma Unimplemented_Unit; 20901 20902 -- Note: this only gives an error if we are generating code, or if 20903 -- we are in a generic library unit (where the pragma appears in the 20904 -- body, not in the spec). 20905 20906 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare 20907 Cunitent : constant Entity_Id := 20908 Cunit_Entity (Get_Source_Unit (Loc)); 20909 Ent_Kind : constant Entity_Kind := 20910 Ekind (Cunitent); 20911 20912 begin 20913 GNAT_Pragma; 20914 Check_Arg_Count (0); 20915 20916 if Operating_Mode = Generate_Code 20917 or else Ent_Kind = E_Generic_Function 20918 or else Ent_Kind = E_Generic_Procedure 20919 or else Ent_Kind = E_Generic_Package 20920 then 20921 Get_Name_String (Chars (Cunitent)); 20922 Set_Casing (Mixed_Case); 20923 Write_Str (Name_Buffer (1 .. Name_Len)); 20924 Write_Str (" is not supported in this configuration"); 20925 Write_Eol; 20926 raise Unrecoverable_Error; 20927 end if; 20928 end Unimplemented_Unit; 20929 20930 ------------------------ 20931 -- Universal_Aliasing -- 20932 ------------------------ 20933 20934 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)]; 20935 20936 when Pragma_Universal_Aliasing => Universal_Alias : declare 20937 E_Id : Entity_Id; 20938 20939 begin 20940 GNAT_Pragma; 20941 Check_Arg_Count (1); 20942 Check_Optional_Identifier (Arg2, Name_Entity); 20943 Check_Arg_Is_Local_Name (Arg1); 20944 E_Id := Entity (Get_Pragma_Arg (Arg1)); 20945 20946 if E_Id = Any_Type then 20947 return; 20948 elsif No (E_Id) or else not Is_Type (E_Id) then 20949 Error_Pragma_Arg ("pragma% requires type", Arg1); 20950 end if; 20951 20952 Set_Universal_Aliasing (Implementation_Base_Type (E_Id)); 20953 Record_Rep_Item (E_Id, N); 20954 end Universal_Alias; 20955 20956 -------------------- 20957 -- Universal_Data -- 20958 -------------------- 20959 20960 -- pragma Universal_Data [(library_unit_NAME)]; 20961 20962 when Pragma_Universal_Data => 20963 GNAT_Pragma; 20964 20965 -- If this is a configuration pragma, then set the universal 20966 -- addressing option, otherwise confirm that the pragma satisfies 20967 -- the requirements of library unit pragma placement and leave it 20968 -- to the GNAAMP back end to detect the pragma (avoids transitive 20969 -- setting of the option due to withed units). 20970 20971 if Is_Configuration_Pragma then 20972 Universal_Addressing_On_AAMP := True; 20973 else 20974 Check_Valid_Library_Unit_Pragma; 20975 end if; 20976 20977 if not AAMP_On_Target then 20978 Error_Pragma ("??pragma% ignored (applies only to AAMP)"); 20979 end if; 20980 20981 ---------------- 20982 -- Unmodified -- 20983 ---------------- 20984 20985 -- pragma Unmodified (local_Name {, local_Name}); 20986 20987 when Pragma_Unmodified => Unmodified : declare 20988 Arg_Node : Node_Id; 20989 Arg_Expr : Node_Id; 20990 Arg_Ent : Entity_Id; 20991 20992 begin 20993 GNAT_Pragma; 20994 Check_At_Least_N_Arguments (1); 20995 20996 -- Loop through arguments 20997 20998 Arg_Node := Arg1; 20999 while Present (Arg_Node) loop 21000 Check_No_Identifier (Arg_Node); 21001 21002 -- Note: the analyze call done by Check_Arg_Is_Local_Name will 21003 -- in fact generate reference, so that the entity will have a 21004 -- reference, which will inhibit any warnings about it not 21005 -- being referenced, and also properly show up in the ali file 21006 -- as a reference. But this reference is recorded before the 21007 -- Has_Pragma_Unreferenced flag is set, so that no warning is 21008 -- generated for this reference. 21009 21010 Check_Arg_Is_Local_Name (Arg_Node); 21011 Arg_Expr := Get_Pragma_Arg (Arg_Node); 21012 21013 if Is_Entity_Name (Arg_Expr) then 21014 Arg_Ent := Entity (Arg_Expr); 21015 21016 if not Is_Assignable (Arg_Ent) then 21017 Error_Pragma_Arg 21018 ("pragma% can only be applied to a variable", 21019 Arg_Expr); 21020 else 21021 Set_Has_Pragma_Unmodified (Arg_Ent); 21022 end if; 21023 end if; 21024 21025 Next (Arg_Node); 21026 end loop; 21027 end Unmodified; 21028 21029 ------------------ 21030 -- Unreferenced -- 21031 ------------------ 21032 21033 -- pragma Unreferenced (local_Name {, local_Name}); 21034 21035 -- or when used in a context clause: 21036 21037 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME} 21038 21039 when Pragma_Unreferenced => Unreferenced : declare 21040 Arg_Node : Node_Id; 21041 Arg_Expr : Node_Id; 21042 Arg_Ent : Entity_Id; 21043 Citem : Node_Id; 21044 21045 begin 21046 GNAT_Pragma; 21047 Check_At_Least_N_Arguments (1); 21048 21049 -- Check case of appearing within context clause 21050 21051 if Is_In_Context_Clause then 21052 21053 -- The arguments must all be units mentioned in a with clause 21054 -- in the same context clause. Note we already checked (in 21055 -- Par.Prag) that the arguments are either identifiers or 21056 -- selected components. 21057 21058 Arg_Node := Arg1; 21059 while Present (Arg_Node) loop 21060 Citem := First (List_Containing (N)); 21061 while Citem /= N loop 21062 if Nkind (Citem) = N_With_Clause 21063 and then 21064 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node)) 21065 then 21066 Set_Has_Pragma_Unreferenced 21067 (Cunit_Entity 21068 (Get_Source_Unit 21069 (Library_Unit (Citem)))); 21070 Set_Unit_Name 21071 (Get_Pragma_Arg (Arg_Node), Name (Citem)); 21072 exit; 21073 end if; 21074 21075 Next (Citem); 21076 end loop; 21077 21078 if Citem = N then 21079 Error_Pragma_Arg 21080 ("argument of pragma% is not withed unit", Arg_Node); 21081 end if; 21082 21083 Next (Arg_Node); 21084 end loop; 21085 21086 -- Case of not in list of context items 21087 21088 else 21089 Arg_Node := Arg1; 21090 while Present (Arg_Node) loop 21091 Check_No_Identifier (Arg_Node); 21092 21093 -- Note: the analyze call done by Check_Arg_Is_Local_Name 21094 -- will in fact generate reference, so that the entity will 21095 -- have a reference, which will inhibit any warnings about 21096 -- it not being referenced, and also properly show up in the 21097 -- ali file as a reference. But this reference is recorded 21098 -- before the Has_Pragma_Unreferenced flag is set, so that 21099 -- no warning is generated for this reference. 21100 21101 Check_Arg_Is_Local_Name (Arg_Node); 21102 Arg_Expr := Get_Pragma_Arg (Arg_Node); 21103 21104 if Is_Entity_Name (Arg_Expr) then 21105 Arg_Ent := Entity (Arg_Expr); 21106 21107 -- If the entity is overloaded, the pragma applies to the 21108 -- most recent overloading, as documented. In this case, 21109 -- name resolution does not generate a reference, so it 21110 -- must be done here explicitly. 21111 21112 if Is_Overloaded (Arg_Expr) then 21113 Generate_Reference (Arg_Ent, N); 21114 end if; 21115 21116 Set_Has_Pragma_Unreferenced (Arg_Ent); 21117 end if; 21118 21119 Next (Arg_Node); 21120 end loop; 21121 end if; 21122 end Unreferenced; 21123 21124 -------------------------- 21125 -- Unreferenced_Objects -- 21126 -------------------------- 21127 21128 -- pragma Unreferenced_Objects (local_Name {, local_Name}); 21129 21130 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare 21131 Arg_Node : Node_Id; 21132 Arg_Expr : Node_Id; 21133 21134 begin 21135 GNAT_Pragma; 21136 Check_At_Least_N_Arguments (1); 21137 21138 Arg_Node := Arg1; 21139 while Present (Arg_Node) loop 21140 Check_No_Identifier (Arg_Node); 21141 Check_Arg_Is_Local_Name (Arg_Node); 21142 Arg_Expr := Get_Pragma_Arg (Arg_Node); 21143 21144 if not Is_Entity_Name (Arg_Expr) 21145 or else not Is_Type (Entity (Arg_Expr)) 21146 then 21147 Error_Pragma_Arg 21148 ("argument for pragma% must be type or subtype", Arg_Node); 21149 end if; 21150 21151 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr)); 21152 Next (Arg_Node); 21153 end loop; 21154 end Unreferenced_Objects; 21155 21156 ------------------------------ 21157 -- Unreserve_All_Interrupts -- 21158 ------------------------------ 21159 21160 -- pragma Unreserve_All_Interrupts; 21161 21162 when Pragma_Unreserve_All_Interrupts => 21163 GNAT_Pragma; 21164 Check_Arg_Count (0); 21165 21166 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then 21167 Unreserve_All_Interrupts := True; 21168 end if; 21169 21170 ---------------- 21171 -- Unsuppress -- 21172 ---------------- 21173 21174 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); 21175 21176 when Pragma_Unsuppress => 21177 Ada_2005_Pragma; 21178 Process_Suppress_Unsuppress (False); 21179 21180 ------------------- 21181 -- Use_VADS_Size -- 21182 ------------------- 21183 21184 -- pragma Use_VADS_Size; 21185 21186 when Pragma_Use_VADS_Size => 21187 GNAT_Pragma; 21188 Check_Arg_Count (0); 21189 Check_Valid_Configuration_Pragma; 21190 Use_VADS_Size := True; 21191 21192 --------------------- 21193 -- Validity_Checks -- 21194 --------------------- 21195 21196 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 21197 21198 when Pragma_Validity_Checks => Validity_Checks : declare 21199 A : constant Node_Id := Get_Pragma_Arg (Arg1); 21200 S : String_Id; 21201 C : Char_Code; 21202 21203 begin 21204 GNAT_Pragma; 21205 Check_Arg_Count (1); 21206 Check_No_Identifiers; 21207 21208 -- Pragma always active unless in CodePeer or GNATprove modes, 21209 -- which use a fixed configuration of validity checks. 21210 21211 if not (CodePeer_Mode or GNATprove_Mode) then 21212 if Nkind (A) = N_String_Literal then 21213 S := Strval (A); 21214 21215 declare 21216 Slen : constant Natural := Natural (String_Length (S)); 21217 Options : String (1 .. Slen); 21218 J : Natural; 21219 21220 begin 21221 -- Couldn't we use a for loop here over Options'Range??? 21222 21223 J := 1; 21224 loop 21225 C := Get_String_Char (S, Int (J)); 21226 21227 -- This is a weird test, it skips setting validity 21228 -- checks entirely if any element of S is out of 21229 -- range of Character, what is that about ??? 21230 21231 exit when not In_Character_Range (C); 21232 Options (J) := Get_Character (C); 21233 21234 if J = Slen then 21235 Set_Validity_Check_Options (Options); 21236 exit; 21237 else 21238 J := J + 1; 21239 end if; 21240 end loop; 21241 end; 21242 21243 elsif Nkind (A) = N_Identifier then 21244 if Chars (A) = Name_All_Checks then 21245 Set_Validity_Check_Options ("a"); 21246 elsif Chars (A) = Name_On then 21247 Validity_Checks_On := True; 21248 elsif Chars (A) = Name_Off then 21249 Validity_Checks_On := False; 21250 end if; 21251 end if; 21252 end if; 21253 end Validity_Checks; 21254 21255 -------------- 21256 -- Volatile -- 21257 -------------- 21258 21259 -- pragma Volatile (LOCAL_NAME); 21260 21261 when Pragma_Volatile => 21262 Process_Atomic_Shared_Volatile; 21263 21264 ------------------------- 21265 -- Volatile_Components -- 21266 ------------------------- 21267 21268 -- pragma Volatile_Components (array_LOCAL_NAME); 21269 21270 -- Volatile is handled by the same circuit as Atomic_Components 21271 21272 ---------------------- 21273 -- Warning_As_Error -- 21274 ---------------------- 21275 21276 when Pragma_Warning_As_Error => 21277 GNAT_Pragma; 21278 Check_Arg_Count (1); 21279 Check_No_Identifiers; 21280 Check_Valid_Configuration_Pragma; 21281 21282 if not Is_Static_String_Expression (Arg1) then 21283 Error_Pragma_Arg 21284 ("argument of pragma% must be static string expression", 21285 Arg1); 21286 21287 -- OK static string expression 21288 21289 else 21290 String_To_Name_Buffer 21291 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); 21292 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1; 21293 Warnings_As_Errors (Warnings_As_Errors_Count) := 21294 new String'(Name_Buffer (1 .. Name_Len)); 21295 end if; 21296 21297 -------------- 21298 -- Warnings -- 21299 -------------- 21300 21301 -- pragma Warnings (On | Off [,REASON]); 21302 -- pragma Warnings (On | Off, LOCAL_NAME [,REASON]); 21303 -- pragma Warnings (static_string_EXPRESSION [,REASON]); 21304 -- pragma Warnings (On | Off, STRING_LITERAL [,REASON]); 21305 21306 -- REASON ::= Reason => Static_String_Expression 21307 21308 when Pragma_Warnings => Warnings : declare 21309 Reason : String_Id; 21310 21311 begin 21312 GNAT_Pragma; 21313 Check_At_Least_N_Arguments (1); 21314 21315 -- See if last argument is labeled Reason. If so, make sure we 21316 -- have a static string expression, and acquire the REASON string. 21317 -- Then remove the REASON argument by decreasing Num_Args by one; 21318 -- Remaining processing looks only at first Num_Args arguments). 21319 21320 declare 21321 Last_Arg : constant Node_Id := 21322 Last (Pragma_Argument_Associations (N)); 21323 begin 21324 if Nkind (Last_Arg) = N_Pragma_Argument_Association 21325 and then Chars (Last_Arg) = Name_Reason 21326 then 21327 Start_String; 21328 Get_Reason_String (Get_Pragma_Arg (Last_Arg)); 21329 Reason := End_String; 21330 Arg_Count := Arg_Count - 1; 21331 21332 -- Not allowed in compiler units (bootstrap issues) 21333 21334 Check_Compiler_Unit (N); 21335 21336 -- No REASON string, set null string as reason 21337 21338 else 21339 Reason := Null_String_Id; 21340 end if; 21341 end; 21342 21343 -- Now proceed with REASON taken care of and eliminated 21344 21345 Check_No_Identifiers; 21346 21347 -- If debug flag -gnatd.i is set, pragma is ignored 21348 21349 if Debug_Flag_Dot_I then 21350 return; 21351 end if; 21352 21353 -- Process various forms of the pragma 21354 21355 declare 21356 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 21357 21358 begin 21359 -- One argument case 21360 21361 if Arg_Count = 1 then 21362 21363 -- On/Off one argument case was processed by parser 21364 21365 if Nkind (Argx) = N_Identifier 21366 and then Nam_In (Chars (Argx), Name_On, Name_Off) 21367 then 21368 null; 21369 21370 -- One argument case must be ON/OFF or static string expr 21371 21372 elsif not Is_Static_String_Expression (Arg1) then 21373 Error_Pragma_Arg 21374 ("argument of pragma% must be On/Off or static string " 21375 & "expression", Arg1); 21376 21377 -- One argument string expression case 21378 21379 else 21380 declare 21381 Lit : constant Node_Id := Expr_Value_S (Argx); 21382 Str : constant String_Id := Strval (Lit); 21383 Len : constant Nat := String_Length (Str); 21384 C : Char_Code; 21385 J : Nat; 21386 OK : Boolean; 21387 Chr : Character; 21388 21389 begin 21390 J := 1; 21391 while J <= Len loop 21392 C := Get_String_Char (Str, J); 21393 OK := In_Character_Range (C); 21394 21395 if OK then 21396 Chr := Get_Character (C); 21397 21398 -- Dash case: only -Wxxx is accepted 21399 21400 if J = 1 21401 and then J < Len 21402 and then Chr = '-' 21403 then 21404 J := J + 1; 21405 C := Get_String_Char (Str, J); 21406 Chr := Get_Character (C); 21407 exit when Chr = 'W'; 21408 OK := False; 21409 21410 -- Dot case 21411 21412 elsif J < Len and then Chr = '.' then 21413 J := J + 1; 21414 C := Get_String_Char (Str, J); 21415 Chr := Get_Character (C); 21416 21417 if not Set_Dot_Warning_Switch (Chr) then 21418 Error_Pragma_Arg 21419 ("invalid warning switch character " 21420 & '.' & Chr, Arg1); 21421 end if; 21422 21423 -- Non-Dot case 21424 21425 else 21426 OK := Set_Warning_Switch (Chr); 21427 end if; 21428 end if; 21429 21430 if not OK then 21431 Error_Pragma_Arg 21432 ("invalid warning switch character " & Chr, 21433 Arg1); 21434 end if; 21435 21436 J := J + 1; 21437 end loop; 21438 end; 21439 end if; 21440 21441 -- Two or more arguments (must be two) 21442 21443 else 21444 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 21445 Check_At_Most_N_Arguments (2); 21446 21447 declare 21448 E_Id : Node_Id; 21449 E : Entity_Id; 21450 Err : Boolean; 21451 21452 begin 21453 E_Id := Get_Pragma_Arg (Arg2); 21454 Analyze (E_Id); 21455 21456 -- In the expansion of an inlined body, a reference to 21457 -- the formal may be wrapped in a conversion if the 21458 -- actual is a conversion. Retrieve the real entity name. 21459 21460 if (In_Instance_Body or In_Inlined_Body) 21461 and then Nkind (E_Id) = N_Unchecked_Type_Conversion 21462 then 21463 E_Id := Expression (E_Id); 21464 end if; 21465 21466 -- Entity name case 21467 21468 if Is_Entity_Name (E_Id) then 21469 E := Entity (E_Id); 21470 21471 if E = Any_Id then 21472 return; 21473 else 21474 loop 21475 Set_Warnings_Off 21476 (E, (Chars (Get_Pragma_Arg (Arg1)) = 21477 Name_Off)); 21478 21479 -- For OFF case, make entry in warnings off 21480 -- pragma table for later processing. But we do 21481 -- not do that within an instance, since these 21482 -- warnings are about what is needed in the 21483 -- template, not an instance of it. 21484 21485 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off 21486 and then Warn_On_Warnings_Off 21487 and then not In_Instance 21488 then 21489 Warnings_Off_Pragmas.Append ((N, E, Reason)); 21490 end if; 21491 21492 if Is_Enumeration_Type (E) then 21493 declare 21494 Lit : Entity_Id; 21495 begin 21496 Lit := First_Literal (E); 21497 while Present (Lit) loop 21498 Set_Warnings_Off (Lit); 21499 Next_Literal (Lit); 21500 end loop; 21501 end; 21502 end if; 21503 21504 exit when No (Homonym (E)); 21505 E := Homonym (E); 21506 end loop; 21507 end if; 21508 21509 -- Error if not entity or static string expression case 21510 21511 elsif not Is_Static_String_Expression (Arg2) then 21512 Error_Pragma_Arg 21513 ("second argument of pragma% must be entity name " 21514 & "or static string expression", Arg2); 21515 21516 -- Static string expression case 21517 21518 else 21519 String_To_Name_Buffer 21520 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)))); 21521 21522 -- Note on configuration pragma case: If this is a 21523 -- configuration pragma, then for an OFF pragma, we 21524 -- just set Config True in the call, which is all 21525 -- that needs to be done. For the case of ON, this 21526 -- is normally an error, unless it is canceling the 21527 -- effect of a previous OFF pragma in the same file. 21528 -- In any other case, an error will be signalled (ON 21529 -- with no matching OFF). 21530 21531 -- Note: We set Used if we are inside a generic to 21532 -- disable the test that the non-config case actually 21533 -- cancels a warning. That's because we can't be sure 21534 -- there isn't an instantiation in some other unit 21535 -- where a warning is suppressed. 21536 21537 -- We could do a little better here by checking if the 21538 -- generic unit we are inside is public, but for now 21539 -- we don't bother with that refinement. 21540 21541 if Chars (Argx) = Name_Off then 21542 Set_Specific_Warning_Off 21543 (Loc, Name_Buffer (1 .. Name_Len), Reason, 21544 Config => Is_Configuration_Pragma, 21545 Used => Inside_A_Generic or else In_Instance); 21546 21547 elsif Chars (Argx) = Name_On then 21548 Set_Specific_Warning_On 21549 (Loc, Name_Buffer (1 .. Name_Len), Err); 21550 21551 if Err then 21552 Error_Msg 21553 ("??pragma Warnings On with no matching " 21554 & "Warnings Off", Loc); 21555 end if; 21556 end if; 21557 end if; 21558 end; 21559 end if; 21560 end; 21561 end Warnings; 21562 21563 ------------------- 21564 -- Weak_External -- 21565 ------------------- 21566 21567 -- pragma Weak_External ([Entity =>] LOCAL_NAME); 21568 21569 when Pragma_Weak_External => Weak_External : declare 21570 Ent : Entity_Id; 21571 21572 begin 21573 GNAT_Pragma; 21574 Check_Arg_Count (1); 21575 Check_Optional_Identifier (Arg1, Name_Entity); 21576 Check_Arg_Is_Library_Level_Local_Name (Arg1); 21577 Ent := Entity (Get_Pragma_Arg (Arg1)); 21578 21579 if Rep_Item_Too_Early (Ent, N) then 21580 return; 21581 else 21582 Ent := Underlying_Type (Ent); 21583 end if; 21584 21585 -- The only processing required is to link this item on to the 21586 -- list of rep items for the given entity. This is accomplished 21587 -- by the call to Rep_Item_Too_Late (when no error is detected 21588 -- and False is returned). 21589 21590 if Rep_Item_Too_Late (Ent, N) then 21591 return; 21592 else 21593 Set_Has_Gigi_Rep_Item (Ent); 21594 end if; 21595 end Weak_External; 21596 21597 ----------------------------- 21598 -- Wide_Character_Encoding -- 21599 ----------------------------- 21600 21601 -- pragma Wide_Character_Encoding (IDENTIFIER); 21602 21603 when Pragma_Wide_Character_Encoding => 21604 GNAT_Pragma; 21605 21606 -- Nothing to do, handled in parser. Note that we do not enforce 21607 -- configuration pragma placement, this pragma can appear at any 21608 -- place in the source, allowing mixed encodings within a single 21609 -- source program. 21610 21611 null; 21612 21613 -------------------- 21614 -- Unknown_Pragma -- 21615 -------------------- 21616 21617 -- Should be impossible, since the case of an unknown pragma is 21618 -- separately processed before the case statement is entered. 21619 21620 when Unknown_Pragma => 21621 raise Program_Error; 21622 end case; 21623 21624 -- AI05-0144: detect dangerous order dependence. Disabled for now, 21625 -- until AI is formally approved. 21626 21627 -- Check_Order_Dependence; 21628 21629 exception 21630 when Pragma_Exit => null; 21631 end Analyze_Pragma; 21632 21633 --------------------------------------------- 21634 -- Analyze_Pre_Post_Condition_In_Decl_Part -- 21635 --------------------------------------------- 21636 21637 procedure Analyze_Pre_Post_Condition_In_Decl_Part 21638 (Prag : Node_Id; 21639 Subp_Id : Entity_Id) 21640 is 21641 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (Prag)); 21642 Nam : constant Name_Id := Original_Aspect_Name (Prag); 21643 Expr : Node_Id; 21644 21645 Restore_Scope : Boolean := False; 21646 -- Gets set True if we do a Push_Scope needing a Pop_Scope on exit 21647 21648 begin 21649 -- Ensure that the subprogram and its formals are visible when analyzing 21650 -- the expression of the pragma. 21651 21652 if not In_Open_Scopes (Subp_Id) then 21653 Restore_Scope := True; 21654 Push_Scope (Subp_Id); 21655 Install_Formals (Subp_Id); 21656 end if; 21657 21658 -- Preanalyze the boolean expression, we treat this as a spec expression 21659 -- (i.e. similar to a default expression). 21660 21661 Expr := Get_Pragma_Arg (Arg1); 21662 21663 -- In ASIS mode, for a pragma generated from a source aspect, analyze 21664 -- the original aspect expression, which is shared with the generated 21665 -- pragma. 21666 21667 if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then 21668 Expr := Expression (Corresponding_Aspect (Prag)); 21669 end if; 21670 21671 Preanalyze_Assert_Expression (Expr, Standard_Boolean); 21672 21673 -- For a class-wide condition, a reference to a controlling formal must 21674 -- be interpreted as having the class-wide type (or an access to such) 21675 -- so that the inherited condition can be properly applied to any 21676 -- overriding operation (see ARM12 6.6.1 (7)). 21677 21678 if Class_Present (Prag) then 21679 Class_Wide_Condition : declare 21680 T : constant Entity_Id := Find_Dispatching_Type (Subp_Id); 21681 21682 ACW : Entity_Id := Empty; 21683 -- Access to T'class, created if there is a controlling formal 21684 -- that is an access parameter. 21685 21686 function Get_ACW return Entity_Id; 21687 -- If the expression has a reference to an controlling access 21688 -- parameter, create an access to T'class for the necessary 21689 -- conversions if one does not exist. 21690 21691 function Process (N : Node_Id) return Traverse_Result; 21692 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class 21693 -- aspect for a primitive subprogram of a tagged type T, a name 21694 -- that denotes a formal parameter of type T is interpreted as 21695 -- having type T'Class. Similarly, a name that denotes a formal 21696 -- accessparameter of type access-to-T is interpreted as having 21697 -- type access-to-T'Class. This ensures the expression is well- 21698 -- defined for a primitive subprogram of a type descended from T. 21699 -- Note that this replacement is not done for selector names in 21700 -- parameter associations. These carry an entity for reference 21701 -- purposes, but semantically they are just identifiers. 21702 21703 ------------- 21704 -- Get_ACW -- 21705 ------------- 21706 21707 function Get_ACW return Entity_Id is 21708 Loc : constant Source_Ptr := Sloc (Prag); 21709 Decl : Node_Id; 21710 21711 begin 21712 if No (ACW) then 21713 Decl := 21714 Make_Full_Type_Declaration (Loc, 21715 Defining_Identifier => Make_Temporary (Loc, 'T'), 21716 Type_Definition => 21717 Make_Access_To_Object_Definition (Loc, 21718 Subtype_Indication => 21719 New_Occurrence_Of (Class_Wide_Type (T), Loc), 21720 All_Present => True)); 21721 21722 Insert_Before (Unit_Declaration_Node (Subp_Id), Decl); 21723 Analyze (Decl); 21724 ACW := Defining_Identifier (Decl); 21725 Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW); 21726 end if; 21727 21728 return ACW; 21729 end Get_ACW; 21730 21731 ------------- 21732 -- Process -- 21733 ------------- 21734 21735 function Process (N : Node_Id) return Traverse_Result is 21736 Loc : constant Source_Ptr := Sloc (N); 21737 Typ : Entity_Id; 21738 21739 begin 21740 if Is_Entity_Name (N) 21741 and then Present (Entity (N)) 21742 and then Is_Formal (Entity (N)) 21743 and then Nkind (Parent (N)) /= N_Type_Conversion 21744 and then 21745 (Nkind (Parent (N)) /= N_Parameter_Association 21746 or else N /= Selector_Name (Parent (N))) 21747 then 21748 if Etype (Entity (N)) = T then 21749 Typ := Class_Wide_Type (T); 21750 21751 elsif Is_Access_Type (Etype (Entity (N))) 21752 and then Designated_Type (Etype (Entity (N))) = T 21753 then 21754 Typ := Get_ACW; 21755 else 21756 Typ := Empty; 21757 end if; 21758 21759 if Present (Typ) then 21760 Rewrite (N, 21761 Make_Type_Conversion (Loc, 21762 Subtype_Mark => 21763 New_Occurrence_Of (Typ, Loc), 21764 Expression => New_Occurrence_Of (Entity (N), Loc))); 21765 Set_Etype (N, Typ); 21766 end if; 21767 end if; 21768 21769 return OK; 21770 end Process; 21771 21772 procedure Replace_Type is new Traverse_Proc (Process); 21773 21774 -- Start of processing for Class_Wide_Condition 21775 21776 begin 21777 if not Present (T) then 21778 21779 -- Pre'Class/Post'Class aspect cases 21780 21781 if From_Aspect_Specification (Prag) then 21782 if Nam = Name_uPre then 21783 Error_Msg_Name_1 := Name_Pre; 21784 else 21785 Error_Msg_Name_1 := Name_Post; 21786 end if; 21787 21788 Error_Msg_Name_2 := Name_Class; 21789 21790 Error_Msg_N 21791 ("aspect `%''%` can only be specified for a primitive " 21792 & "operation of a tagged type", 21793 Corresponding_Aspect (Prag)); 21794 21795 -- Pre_Class, Post_Class pragma cases 21796 21797 else 21798 if Nam = Name_uPre then 21799 Error_Msg_Name_1 := Name_Pre_Class; 21800 else 21801 Error_Msg_Name_1 := Name_Post_Class; 21802 end if; 21803 21804 Error_Msg_N 21805 ("pragma% can only be specified for a primitive " 21806 & "operation of a tagged type", 21807 Corresponding_Aspect (Prag)); 21808 end if; 21809 end if; 21810 21811 Replace_Type (Get_Pragma_Arg (Arg1)); 21812 end Class_Wide_Condition; 21813 end if; 21814 21815 -- Remove the subprogram from the scope stack now that the pre-analysis 21816 -- of the precondition/postcondition is done. 21817 21818 if Restore_Scope then 21819 End_Scope; 21820 end if; 21821 end Analyze_Pre_Post_Condition_In_Decl_Part; 21822 21823 ------------------------------------------ 21824 -- Analyze_Refined_Depends_In_Decl_Part -- 21825 ------------------------------------------ 21826 21827 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is 21828 Dependencies : List_Id := No_List; 21829 Depends : Node_Id; 21830 -- The corresponding Depends pragma along with its clauses 21831 21832 Refinements : List_Id := No_List; 21833 -- The clauses of pragma Refined_Depends 21834 21835 Spec_Id : Entity_Id; 21836 -- The entity of the subprogram subject to pragma Refined_Depends 21837 21838 procedure Check_Dependency_Clause (Dep_Clause : Node_Id); 21839 -- Verify the legality of a single clause 21840 21841 function Input_Match 21842 (Dep_Input : Node_Id; 21843 Ref_Inputs : List_Id; 21844 Post_Errors : Boolean) return Boolean; 21845 -- Determine whether input Dep_Input matches one of inputs found in list 21846 -- Ref_Inputs. If flag Post_Errors is set, the routine reports missed or 21847 -- extra input items. 21848 21849 function Inputs_Match 21850 (Dep_Clause : Node_Id; 21851 Ref_Clause : Node_Id; 21852 Post_Errors : Boolean) return Boolean; 21853 -- Determine whether the inputs of Depends clause Dep_Clause match those 21854 -- of refinement clause Ref_Clause. If flag Post_Errors is set, then the 21855 -- routine reports missed or extra input items. 21856 21857 function Is_Self_Referential (Item_Id : Entity_Id) return Boolean; 21858 -- Determine whether a formal parameter, variable or state denoted by 21859 -- Item_Id appears both as input and an output in a single clause of 21860 -- pragma Depends. 21861 21862 procedure Report_Extra_Clauses; 21863 -- Emit an error for each extra clause the appears in Refined_Depends 21864 21865 ----------------------------- 21866 -- Check_Dependency_Clause -- 21867 ----------------------------- 21868 21869 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is 21870 Dep_Output : constant Node_Id := First (Choices (Dep_Clause)); 21871 Dep_Id : Entity_Id; 21872 Matching_Clause : Node_Id := Empty; 21873 Next_Ref_Clause : Node_Id; 21874 Ref_Clause : Node_Id; 21875 Ref_Id : Entity_Id; 21876 Ref_Output : Node_Id; 21877 21878 Has_Constituent : Boolean := False; 21879 -- Flag set when the refinement output list contains at least one 21880 -- constituent of the state denoted by Dep_Id. 21881 21882 Has_Null_State : Boolean := False; 21883 -- Flag set when the output of clause Dep_Clause is a state with a 21884 -- null refinement. 21885 21886 Has_Refined_State : Boolean := False; 21887 -- Flag set when the output of clause Dep_Clause is a state with 21888 -- visible refinement. 21889 21890 begin 21891 -- The analysis of pragma Depends should produce normalized clauses 21892 -- with exactly one output. This is important because output items 21893 -- are unique in the whole dependence relation and can be used as 21894 -- keys. 21895 21896 pragma Assert (No (Next (Dep_Output))); 21897 21898 -- Inspect all clauses of Refined_Depends and attempt to match the 21899 -- output of Dep_Clause against an output from the refinement clauses 21900 -- set. 21901 21902 Ref_Clause := First (Refinements); 21903 while Present (Ref_Clause) loop 21904 Matching_Clause := Empty; 21905 21906 -- Store the next clause now because a match will trim the list of 21907 -- refinement clauses and this side effect should not be visible 21908 -- in pragma Refined_Depends. 21909 21910 Next_Ref_Clause := Next (Ref_Clause); 21911 21912 -- The analysis of pragma Refined_Depends should produce 21913 -- normalized clauses with exactly one output. 21914 21915 Ref_Output := First (Choices (Ref_Clause)); 21916 pragma Assert (No (Next (Ref_Output))); 21917 21918 -- Two null output lists match if their inputs match 21919 21920 if Nkind (Dep_Output) = N_Null 21921 and then Nkind (Ref_Output) = N_Null 21922 then 21923 Matching_Clause := Ref_Clause; 21924 exit; 21925 21926 -- Two function 'Result attributes match if their inputs match. 21927 -- Note that there is no need to compare the two prefixes because 21928 -- the attributes cannot denote anything but the related function. 21929 21930 elsif Is_Attribute_Result (Dep_Output) 21931 and then Is_Attribute_Result (Ref_Output) 21932 then 21933 Matching_Clause := Ref_Clause; 21934 exit; 21935 21936 -- The remaining cases are formal parameters, variables and states 21937 21938 elsif Is_Entity_Name (Dep_Output) then 21939 21940 -- Handle abstract views of states and variables generated for 21941 -- limited with clauses. 21942 21943 Dep_Id := Available_View (Entity_Of (Dep_Output)); 21944 21945 if Ekind (Dep_Id) = E_Abstract_State then 21946 21947 -- A state with a null refinement matches either a null 21948 -- output list or nothing at all (no clause): 21949 21950 -- Refined_State => (State => null) 21951 21952 -- No clause 21953 21954 -- Depends => (State => null) 21955 -- Refined_Depends => null -- OK 21956 21957 -- Null output list 21958 21959 -- Depends => (State => <input>) 21960 -- Refined_Depends => (null => <input>) -- OK 21961 21962 if Has_Null_Refinement (Dep_Id) then 21963 Has_Null_State := True; 21964 21965 -- When a state with null refinement matches a null 21966 -- output, compare their inputs. 21967 21968 if Nkind (Ref_Output) = N_Null then 21969 Matching_Clause := Ref_Clause; 21970 end if; 21971 21972 exit; 21973 21974 -- The state has a non-null refinement in which case the 21975 -- match is based on constituents and inputs. A state with 21976 -- multiple output constituents may match multiple clauses: 21977 21978 -- Refined_State => (State => (C1, C2)) 21979 -- Depends => (State => <input>) 21980 -- Refined_Depends => ((C1, C2) => <input>) 21981 21982 -- When normalized, the above becomes: 21983 21984 -- Refined_Depends => (C1 => <input>, 21985 -- C2 => <input>) 21986 21987 elsif Has_Non_Null_Refinement (Dep_Id) then 21988 Has_Refined_State := True; 21989 21990 -- Account for the case where a state with a non-null 21991 -- refinement matches a null output list: 21992 21993 -- Refined_State => (State_1 => (C1, C2), 21994 -- State_2 => (C3, C4)) 21995 -- Depends => (State_1 => State_2) 21996 -- Refined_Depends => (null => C3) 21997 21998 if Nkind (Ref_Output) = N_Null 21999 and then Inputs_Match 22000 (Dep_Clause => Dep_Clause, 22001 Ref_Clause => Ref_Clause, 22002 Post_Errors => False) 22003 then 22004 Has_Constituent := True; 22005 22006 -- Note that the search continues after the clause is 22007 -- removed from the pool of candidates because it may 22008 -- have been normalized into multiple simple clauses. 22009 22010 Remove (Ref_Clause); 22011 22012 -- Otherwise the output of the refinement clause must be 22013 -- a valid constituent of the state: 22014 22015 -- Refined_State => (State => (C1, C2)) 22016 -- Depends => (State => <input>) 22017 -- Refined_Depends => (C1 => <input>) 22018 22019 elsif Is_Entity_Name (Ref_Output) then 22020 Ref_Id := Entity_Of (Ref_Output); 22021 22022 if Ekind_In (Ref_Id, E_Abstract_State, E_Variable) 22023 and then Present (Encapsulating_State (Ref_Id)) 22024 and then Encapsulating_State (Ref_Id) = Dep_Id 22025 and then Inputs_Match 22026 (Dep_Clause => Dep_Clause, 22027 Ref_Clause => Ref_Clause, 22028 Post_Errors => False) 22029 then 22030 Has_Constituent := True; 22031 22032 -- Note that the search continues after the clause 22033 -- is removed from the pool of candidates because 22034 -- it may have been normalized into multiple simple 22035 -- clauses. 22036 22037 Remove (Ref_Clause); 22038 end if; 22039 end if; 22040 22041 -- The abstract view of a state matches is corresponding 22042 -- non-abstract view: 22043 22044 -- Depends => (Lim_Pack.State => <input>) 22045 -- Refined_Depends => (State => <input>) 22046 22047 elsif Is_Entity_Name (Ref_Output) 22048 and then Entity_Of (Ref_Output) = Dep_Id 22049 then 22050 Matching_Clause := Ref_Clause; 22051 exit; 22052 end if; 22053 22054 -- Formal parameters and variables match if their inputs match 22055 22056 elsif Is_Entity_Name (Ref_Output) 22057 and then Entity_Of (Ref_Output) = Dep_Id 22058 then 22059 Matching_Clause := Ref_Clause; 22060 exit; 22061 end if; 22062 end if; 22063 22064 Ref_Clause := Next_Ref_Clause; 22065 end loop; 22066 22067 -- Handle the case where pragma Depends contains one or more clauses 22068 -- that only mention states with null refinements. In that case the 22069 -- corresponding pragma Refined_Depends may have a null relation. 22070 22071 -- Refined_State => (State => null) 22072 -- Depends => (State => null) 22073 -- Refined_Depends => null -- OK 22074 22075 -- Another instance of the same scenario occurs when the list of 22076 -- refinements has been depleted while processing previous clauses. 22077 22078 if Is_Entity_Name (Dep_Output) 22079 and then (No (Refinements) or else Is_Empty_List (Refinements)) 22080 then 22081 Dep_Id := Entity_Of (Dep_Output); 22082 22083 if Ekind (Dep_Id) = E_Abstract_State 22084 and then Has_Null_Refinement (Dep_Id) 22085 then 22086 Has_Null_State := True; 22087 end if; 22088 end if; 22089 22090 -- The above search produced a match based on unique output. Ensure 22091 -- that the inputs match as well and if they do, remove the clause 22092 -- from the pool of candidates. 22093 22094 if Present (Matching_Clause) then 22095 if Inputs_Match 22096 (Ref_Clause => Ref_Clause, 22097 Dep_Clause => Matching_Clause, 22098 Post_Errors => True) 22099 then 22100 Remove (Matching_Clause); 22101 end if; 22102 22103 -- A state with a visible refinement was matched against one or 22104 -- more clauses containing appropriate constituents. 22105 22106 elsif Has_Constituent then 22107 null; 22108 22109 -- A state with a null refinement did not warrant a clause 22110 22111 elsif Has_Null_State then 22112 null; 22113 22114 -- The dependence relation of pragma Refined_Depends does not contain 22115 -- a matching clause, emit an error. 22116 22117 else 22118 Error_Msg_NE 22119 ("dependence clause of subprogram & has no matching refinement " 22120 & "in body", Ref_Clause, Spec_Id); 22121 22122 if Has_Refined_State then 22123 Error_Msg_N 22124 ("\check the use of constituents in dependence refinement", 22125 Ref_Clause); 22126 end if; 22127 end if; 22128 end Check_Dependency_Clause; 22129 22130 ----------------- 22131 -- Input_Match -- 22132 ----------------- 22133 22134 function Input_Match 22135 (Dep_Input : Node_Id; 22136 Ref_Inputs : List_Id; 22137 Post_Errors : Boolean) return Boolean 22138 is 22139 procedure Match_Error (Msg : String; N : Node_Id); 22140 -- Emit a matching error if flag Post_Errors is set 22141 22142 ----------------- 22143 -- Match_Error -- 22144 ----------------- 22145 22146 procedure Match_Error (Msg : String; N : Node_Id) is 22147 begin 22148 if Post_Errors then 22149 Error_Msg_N (Msg, N); 22150 end if; 22151 end Match_Error; 22152 22153 -- Local variables 22154 22155 Dep_Id : Node_Id; 22156 Next_Ref_Input : Node_Id; 22157 Ref_Id : Entity_Id; 22158 Ref_Input : Node_Id; 22159 22160 Has_Constituent : Boolean := False; 22161 -- Flag set when the refinement input list contains at least one 22162 -- constituent of the state denoted by Dep_Id. 22163 22164 Has_Null_State : Boolean := False; 22165 -- Flag set when the dependency input is a state with a visible null 22166 -- refinement. 22167 22168 Has_Refined_State : Boolean := False; 22169 -- Flag set when the dependency input is a state with visible non- 22170 -- null refinement. 22171 22172 -- Start of processing for Input_Match 22173 22174 begin 22175 -- Match a null input with another null input 22176 22177 if Nkind (Dep_Input) = N_Null then 22178 Ref_Input := First (Ref_Inputs); 22179 22180 -- Remove the matching null from the pool of candidates 22181 22182 if Nkind (Ref_Input) = N_Null then 22183 Remove (Ref_Input); 22184 return True; 22185 22186 else 22187 Match_Error 22188 ("null input cannot be matched in corresponding refinement " 22189 & "clause", Dep_Input); 22190 end if; 22191 22192 -- Remaining cases are formal parameters, variables, and states 22193 22194 else 22195 -- Handle abstract views of states and variables generated for 22196 -- limited with clauses. 22197 22198 Dep_Id := Available_View (Entity_Of (Dep_Input)); 22199 22200 -- Inspect all inputs of the refinement clause and attempt to 22201 -- match against the inputs of the dependence clause. 22202 22203 Ref_Input := First (Ref_Inputs); 22204 while Present (Ref_Input) loop 22205 22206 -- Store the next input now because a match will remove it from 22207 -- the list. 22208 22209 Next_Ref_Input := Next (Ref_Input); 22210 22211 if Ekind (Dep_Id) = E_Abstract_State then 22212 22213 -- A state with a null refinement matches either a null 22214 -- input list or nothing at all (no input): 22215 22216 -- Refined_State => (State => null) 22217 22218 -- No input 22219 22220 -- Depends => (<output> => (State, Input)) 22221 -- Refined_Depends => (<output> => Input) -- OK 22222 22223 -- Null input list 22224 22225 -- Depends => (<output> => State) 22226 -- Refined_Depends => (<output> => null) -- OK 22227 22228 if Has_Null_Refinement (Dep_Id) then 22229 Has_Null_State := True; 22230 22231 -- Remove the matching null from the pool of candidates 22232 22233 if Nkind (Ref_Input) = N_Null then 22234 Remove (Ref_Input); 22235 end if; 22236 22237 return True; 22238 22239 -- The state has a non-null refinement in which case remove 22240 -- all the matching constituents of the state: 22241 22242 -- Refined_State => (State => (C1, C2)) 22243 -- Depends => (<output> => State) 22244 -- Refined_Depends => (<output> => (C1, C2)) 22245 22246 elsif Has_Non_Null_Refinement (Dep_Id) then 22247 Has_Refined_State := True; 22248 22249 -- A state with a visible non-null refinement may have a 22250 -- null input_list only when it is self referential. 22251 22252 -- Refined_State => (State => (C1, C2)) 22253 -- Depends => (State => State) 22254 -- Refined_Depends => (C2 => null) -- OK 22255 22256 if Nkind (Ref_Input) = N_Null 22257 and then Is_Self_Referential (Dep_Id) 22258 then 22259 -- Remove the null from the pool of candidates. Note 22260 -- that the search continues because the state may be 22261 -- represented by multiple constituents. 22262 22263 Has_Constituent := True; 22264 Remove (Ref_Input); 22265 22266 -- Ref_Input is an entity name 22267 22268 elsif Is_Entity_Name (Ref_Input) then 22269 Ref_Id := Entity_Of (Ref_Input); 22270 22271 -- The input of the refinement clause is a valid 22272 -- constituent of the state. Remove the input from the 22273 -- pool of candidates. Note that the search continues 22274 -- because the state may be represented by multiple 22275 -- constituents. 22276 22277 if Ekind_In (Ref_Id, E_Abstract_State, 22278 E_Variable) 22279 and then Present (Encapsulating_State (Ref_Id)) 22280 and then Encapsulating_State (Ref_Id) = Dep_Id 22281 then 22282 Has_Constituent := True; 22283 Remove (Ref_Input); 22284 end if; 22285 end if; 22286 22287 -- The abstract view of a state matches its corresponding 22288 -- non-abstract view: 22289 22290 -- Depends => (<output> => Lim_Pack.State) 22291 -- Refined_Depends => (<output> => State) 22292 22293 elsif Is_Entity_Name (Ref_Input) 22294 and then Entity_Of (Ref_Input) = Dep_Id 22295 then 22296 Remove (Ref_Input); 22297 return True; 22298 end if; 22299 22300 -- Formal parameters and variables are matched on entities. If 22301 -- this is the case, remove the input from the candidate list. 22302 22303 elsif Is_Entity_Name (Ref_Input) 22304 and then Entity_Of (Ref_Input) = Dep_Id 22305 then 22306 Remove (Ref_Input); 22307 return True; 22308 end if; 22309 22310 Ref_Input := Next_Ref_Input; 22311 end loop; 22312 22313 -- When a state with a null refinement appears as the last input, 22314 -- it matches nothing: 22315 22316 -- Refined_State => (State => null) 22317 -- Depends => (<output> => (Input, State)) 22318 -- Refined_Depends => (<output> => Input) -- OK 22319 22320 if Ekind (Dep_Id) = E_Abstract_State 22321 and then Has_Null_Refinement (Dep_Id) 22322 and then No (Ref_Input) 22323 then 22324 Has_Null_State := True; 22325 end if; 22326 end if; 22327 22328 -- A state with visible refinement was matched against one or more of 22329 -- its constituents. 22330 22331 if Has_Constituent then 22332 return True; 22333 22334 -- A state with a null refinement matched null or nothing 22335 22336 elsif Has_Null_State then 22337 return True; 22338 22339 -- The input of a dependence clause does not have a matching input in 22340 -- the refinement clause, emit an error. 22341 22342 else 22343 Match_Error 22344 ("input cannot be matched in corresponding refinement clause", 22345 Dep_Input); 22346 22347 if Has_Refined_State then 22348 Match_Error 22349 ("\check the use of constituents in dependence refinement", 22350 Dep_Input); 22351 end if; 22352 22353 return False; 22354 end if; 22355 end Input_Match; 22356 22357 ------------------ 22358 -- Inputs_Match -- 22359 ------------------ 22360 22361 function Inputs_Match 22362 (Dep_Clause : Node_Id; 22363 Ref_Clause : Node_Id; 22364 Post_Errors : Boolean) return Boolean 22365 is 22366 Ref_Inputs : List_Id; 22367 -- The input list of the refinement clause 22368 22369 procedure Report_Extra_Inputs; 22370 -- Emit errors for all extra inputs that appear in Ref_Inputs 22371 22372 ------------------------- 22373 -- Report_Extra_Inputs -- 22374 ------------------------- 22375 22376 procedure Report_Extra_Inputs is 22377 Input : Node_Id; 22378 22379 begin 22380 if Present (Ref_Inputs) and then Post_Errors then 22381 Input := First (Ref_Inputs); 22382 while Present (Input) loop 22383 Error_Msg_N 22384 ("unmatched or extra input in refinement clause", Input); 22385 22386 Next (Input); 22387 end loop; 22388 end if; 22389 end Report_Extra_Inputs; 22390 22391 -- Local variables 22392 22393 Dep_Inputs : constant Node_Id := Expression (Dep_Clause); 22394 Inputs : constant Node_Id := Expression (Ref_Clause); 22395 Dep_Input : Node_Id; 22396 Result : Boolean; 22397 22398 -- Start of processing for Inputs_Match 22399 22400 begin 22401 -- Construct a list of all refinement inputs. Note that the input 22402 -- list is copied because the algorithm modifies its contents and 22403 -- this should not be visible in Refined_Depends. The same applies 22404 -- for a solitary input. 22405 22406 if Nkind (Inputs) = N_Aggregate then 22407 Ref_Inputs := New_Copy_List (Expressions (Inputs)); 22408 else 22409 Ref_Inputs := New_List (New_Copy (Inputs)); 22410 end if; 22411 22412 -- Depending on whether the original dependency clause mentions 22413 -- states with visible refinement, the corresponding refinement 22414 -- clause may differ greatly in structure and contents: 22415 22416 -- State with null refinement 22417 22418 -- Refined_State => (State => null) 22419 -- Depends => (<output> => State) 22420 -- Refined_Depends => (<output> => null) 22421 22422 -- Depends => (<output> => (State, Input)) 22423 -- Refined_Depends => (<output> => Input) 22424 22425 -- Depends => (<output> => (Input_1, State, Input_2)) 22426 -- Refined_Depends => (<output> => (Input_1, Input_2)) 22427 22428 -- State with non-null refinement 22429 22430 -- Refined_State => (State_1 => (C1, C2)) 22431 -- Depends => (<output> => State) 22432 -- Refined_Depends => (<output> => C1) 22433 -- or 22434 -- Refined_Depends => (<output> => (C1, C2)) 22435 22436 if Nkind (Dep_Inputs) = N_Aggregate then 22437 Dep_Input := First (Expressions (Dep_Inputs)); 22438 while Present (Dep_Input) loop 22439 if not Input_Match 22440 (Dep_Input => Dep_Input, 22441 Ref_Inputs => Ref_Inputs, 22442 Post_Errors => Post_Errors) 22443 then 22444 Result := False; 22445 end if; 22446 22447 Next (Dep_Input); 22448 end loop; 22449 22450 Result := True; 22451 22452 -- Solitary input 22453 22454 else 22455 Result := 22456 Input_Match 22457 (Dep_Input => Dep_Inputs, 22458 Ref_Inputs => Ref_Inputs, 22459 Post_Errors => Post_Errors); 22460 end if; 22461 22462 -- List all inputs that appear as extras 22463 22464 Report_Extra_Inputs; 22465 22466 return Result; 22467 end Inputs_Match; 22468 22469 ------------------------- 22470 -- Is_Self_Referential -- 22471 ------------------------- 22472 22473 function Is_Self_Referential (Item_Id : Entity_Id) return Boolean is 22474 function Denotes_Item (N : Node_Id) return Boolean; 22475 -- Determine whether an arbitrary node N denotes item Item_Id 22476 22477 ------------------ 22478 -- Denotes_Item -- 22479 ------------------ 22480 22481 function Denotes_Item (N : Node_Id) return Boolean is 22482 begin 22483 return 22484 Is_Entity_Name (N) 22485 and then Present (Entity (N)) 22486 and then Entity (N) = Item_Id; 22487 end Denotes_Item; 22488 22489 -- Local variables 22490 22491 Clauses : constant Node_Id := 22492 Get_Pragma_Arg 22493 (First (Pragma_Argument_Associations (Depends))); 22494 Clause : Node_Id; 22495 Input : Node_Id; 22496 Output : Node_Id; 22497 22498 -- Start of processing for Is_Self_Referential 22499 22500 begin 22501 Clause := First (Component_Associations (Clauses)); 22502 while Present (Clause) loop 22503 22504 -- Due to normalization, a dependence clause has exactly one 22505 -- output even if the original clause had multiple outputs. 22506 22507 Output := First (Choices (Clause)); 22508 22509 -- Detect the following scenario: 22510 -- 22511 -- Item_Id => [(...,] Item_Id [, ...)] 22512 22513 if Denotes_Item (Output) then 22514 Input := Expression (Clause); 22515 22516 -- Multiple inputs appear as an aggregate 22517 22518 if Nkind (Input) = N_Aggregate then 22519 Input := First (Expressions (Input)); 22520 22521 if Denotes_Item (Input) then 22522 return True; 22523 end if; 22524 22525 Next (Input); 22526 22527 -- Solitary input 22528 22529 elsif Denotes_Item (Input) then 22530 return True; 22531 end if; 22532 end if; 22533 22534 Next (Clause); 22535 end loop; 22536 22537 return False; 22538 end Is_Self_Referential; 22539 22540 -------------------------- 22541 -- Report_Extra_Clauses -- 22542 -------------------------- 22543 22544 procedure Report_Extra_Clauses is 22545 Clause : Node_Id; 22546 22547 begin 22548 if Present (Refinements) then 22549 Clause := First (Refinements); 22550 while Present (Clause) loop 22551 22552 -- Do not complain about a null input refinement, since a null 22553 -- input legitimately matches anything. 22554 22555 if Nkind (Clause) /= N_Component_Association 22556 or else Nkind (Expression (Clause)) /= N_Null 22557 then 22558 Error_Msg_N 22559 ("unmatched or extra clause in dependence refinement", 22560 Clause); 22561 end if; 22562 22563 Next (Clause); 22564 end loop; 22565 end if; 22566 end Report_Extra_Clauses; 22567 22568 -- Local variables 22569 22570 Body_Decl : constant Node_Id := Parent (N); 22571 Errors : constant Nat := Serious_Errors_Detected; 22572 Refs : constant Node_Id := 22573 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 22574 Clause : Node_Id; 22575 Deps : Node_Id; 22576 22577 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part 22578 22579 begin 22580 -- Verify the syntax of pragma Refined_Depends when SPARK checks are 22581 -- suppressed. Semantic analysis is disabled in this mode. 22582 22583 if SPARK_Mode = Off then 22584 Check_Dependence_List_Syntax (Refs); 22585 return; 22586 end if; 22587 22588 Spec_Id := Corresponding_Spec (Body_Decl); 22589 Depends := Get_Pragma (Spec_Id, Pragma_Depends); 22590 22591 -- Subprogram declarations lacks pragma Depends. Refined_Depends is 22592 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)). 22593 22594 if No (Depends) then 22595 Error_Msg_NE 22596 ("useless refinement, declaration of subprogram & lacks aspect or " 22597 & "pragma Depends", N, Spec_Id); 22598 return; 22599 end if; 22600 22601 Deps := Get_Pragma_Arg (First (Pragma_Argument_Associations (Depends))); 22602 22603 -- A null dependency relation renders the refinement useless because it 22604 -- cannot possibly mention abstract states with visible refinement. Note 22605 -- that the inverse is not true as states may be refined to null 22606 -- (SPARK RM 7.2.5(2)). 22607 22608 if Nkind (Deps) = N_Null then 22609 Error_Msg_NE 22610 ("useless refinement, subprogram & does not depend on abstract " 22611 & "state with visible refinement", 22612 N, Spec_Id); 22613 return; 22614 end if; 22615 22616 -- Multiple dependency clauses appear as component associations of an 22617 -- aggregate. 22618 22619 pragma Assert (Nkind (Deps) = N_Aggregate); 22620 Dependencies := Component_Associations (Deps); 22621 22622 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends. 22623 -- This ensures that the categorization of all refined dependency items 22624 -- is consistent with their role. 22625 22626 Analyze_Depends_In_Decl_Part (N); 22627 22628 if Serious_Errors_Detected = Errors then 22629 if Nkind (Refs) = N_Null then 22630 Refinements := No_List; 22631 22632 -- Multiple dependency clauses appear as component associations of an 22633 -- aggregate. Note that the clauses are copied because the algorithm 22634 -- modifies them and this should not be visible in Refined_Depends. 22635 22636 else pragma Assert (Nkind (Refs) = N_Aggregate); 22637 Refinements := New_Copy_List (Component_Associations (Refs)); 22638 end if; 22639 22640 -- Inspect all the clauses of pragma Depends looking for a matching 22641 -- clause in pragma Refined_Depends. The approach is to use the 22642 -- sole output of a clause as a key. Output items are unique in a 22643 -- dependence relation. Clause normalization also ensured that all 22644 -- clauses have exactly one output. Depending on what the key is, one 22645 -- or more refinement clauses may satisfy the dependency clause. Each 22646 -- time a dependency clause is matched, its related refinement clause 22647 -- is consumed. In the end, two things may happen: 22648 22649 -- 1) A clause of pragma Depends was not matched in which case 22650 -- Check_Dependency_Clause reports the error. 22651 22652 -- 2) Refined_Depends has an extra clause in which case the error 22653 -- is reported by Report_Extra_Clauses. 22654 22655 Clause := First (Dependencies); 22656 while Present (Clause) loop 22657 Check_Dependency_Clause (Clause); 22658 Next (Clause); 22659 end loop; 22660 end if; 22661 22662 if Serious_Errors_Detected = Errors then 22663 Report_Extra_Clauses; 22664 end if; 22665 end Analyze_Refined_Depends_In_Decl_Part; 22666 22667 ----------------------------------------- 22668 -- Analyze_Refined_Global_In_Decl_Part -- 22669 ----------------------------------------- 22670 22671 procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is 22672 Global : Node_Id; 22673 -- The corresponding Global pragma 22674 22675 Has_In_State : Boolean := False; 22676 Has_In_Out_State : Boolean := False; 22677 Has_Out_State : Boolean := False; 22678 Has_Proof_In_State : Boolean := False; 22679 -- These flags are set when the corresponding Global pragma has a state 22680 -- of mode Input, In_Out, Output or Proof_In respectively with a visible 22681 -- refinement. 22682 22683 Has_Null_State : Boolean := False; 22684 -- This flag is set when the corresponding Global pragma has at least 22685 -- one state with a null refinement. 22686 22687 In_Constits : Elist_Id := No_Elist; 22688 In_Out_Constits : Elist_Id := No_Elist; 22689 Out_Constits : Elist_Id := No_Elist; 22690 Proof_In_Constits : Elist_Id := No_Elist; 22691 -- These lists contain the entities of all Input, In_Out, Output and 22692 -- Proof_In constituents that appear in Refined_Global and participate 22693 -- in state refinement. 22694 22695 In_Items : Elist_Id := No_Elist; 22696 In_Out_Items : Elist_Id := No_Elist; 22697 Out_Items : Elist_Id := No_Elist; 22698 Proof_In_Items : Elist_Id := No_Elist; 22699 -- These list contain the entities of all Input, In_Out, Output and 22700 -- Proof_In items defined in the corresponding Global pragma. 22701 22702 procedure Check_In_Out_States; 22703 -- Determine whether the corresponding Global pragma mentions In_Out 22704 -- states with visible refinement and if so, ensure that one of the 22705 -- following completions apply to the constituents of the state: 22706 -- 1) there is at least one constituent of mode In_Out 22707 -- 2) there is at least one Input and one Output constituent 22708 -- 3) not all constituents are present and one of them is of mode 22709 -- Output. 22710 -- This routine may remove elements from In_Constits, In_Out_Constits, 22711 -- Out_Constits and Proof_In_Constits. 22712 22713 procedure Check_Input_States; 22714 -- Determine whether the corresponding Global pragma mentions Input 22715 -- states with visible refinement and if so, ensure that at least one of 22716 -- its constituents appears as an Input item in Refined_Global. 22717 -- This routine may remove elements from In_Constits, In_Out_Constits, 22718 -- Out_Constits and Proof_In_Constits. 22719 22720 procedure Check_Output_States; 22721 -- Determine whether the corresponding Global pragma mentions Output 22722 -- states with visible refinement and if so, ensure that all of its 22723 -- constituents appear as Output items in Refined_Global. 22724 -- This routine may remove elements from In_Constits, In_Out_Constits, 22725 -- Out_Constits and Proof_In_Constits. 22726 22727 procedure Check_Proof_In_States; 22728 -- Determine whether the corresponding Global pragma mentions Proof_In 22729 -- states with visible refinement and if so, ensure that at least one of 22730 -- its constituents appears as a Proof_In item in Refined_Global. 22731 -- This routine may remove elements from In_Constits, In_Out_Constits, 22732 -- Out_Constits and Proof_In_Constits. 22733 22734 procedure Check_Refined_Global_List 22735 (List : Node_Id; 22736 Global_Mode : Name_Id := Name_Input); 22737 -- Verify the legality of a single global list declaration. Global_Mode 22738 -- denotes the current mode in effect. 22739 22740 function Present_Then_Remove 22741 (List : Elist_Id; 22742 Item : Entity_Id) return Boolean; 22743 -- Search List for a particular entity Item. If Item has been found, 22744 -- remove it from List. This routine is used to strip lists In_Constits, 22745 -- In_Out_Constits and Out_Constits of valid constituents. 22746 22747 procedure Report_Extra_Constituents; 22748 -- Emit an error for each constituent found in lists In_Constits, 22749 -- In_Out_Constits and Out_Constits. 22750 22751 ------------------------- 22752 -- Check_In_Out_States -- 22753 ------------------------- 22754 22755 procedure Check_In_Out_States is 22756 procedure Check_Constituent_Usage (State_Id : Entity_Id); 22757 -- Determine whether one of the following coverage scenarios is in 22758 -- effect: 22759 -- 1) there is at least one constituent of mode In_Out 22760 -- 2) there is at least one Input and one Output constituent 22761 -- 3) not all constituents are present and one of them is of mode 22762 -- Output. 22763 -- If this is not the case, emit an error. 22764 22765 ----------------------------- 22766 -- Check_Constituent_Usage -- 22767 ----------------------------- 22768 22769 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 22770 Constit_Elmt : Elmt_Id; 22771 Constit_Id : Entity_Id; 22772 Has_Missing : Boolean := False; 22773 In_Out_Seen : Boolean := False; 22774 In_Seen : Boolean := False; 22775 Out_Seen : Boolean := False; 22776 22777 begin 22778 -- Process all the constituents of the state and note their modes 22779 -- within the global refinement. 22780 22781 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 22782 while Present (Constit_Elmt) loop 22783 Constit_Id := Node (Constit_Elmt); 22784 22785 if Present_Then_Remove (In_Constits, Constit_Id) then 22786 In_Seen := True; 22787 22788 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then 22789 In_Out_Seen := True; 22790 22791 elsif Present_Then_Remove (Out_Constits, Constit_Id) then 22792 Out_Seen := True; 22793 22794 -- A Proof_In constituent cannot participate in the completion 22795 -- of an Output state (SPARK RM 7.2.4(5)). 22796 22797 elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) then 22798 Error_Msg_Name_1 := Chars (State_Id); 22799 Error_Msg_NE 22800 ("constituent & of state % must have mode Input, In_Out " 22801 & "or Output in global refinement", 22802 N, Constit_Id); 22803 22804 else 22805 Has_Missing := True; 22806 end if; 22807 22808 Next_Elmt (Constit_Elmt); 22809 end loop; 22810 22811 -- A single In_Out constituent is a valid completion 22812 22813 if In_Out_Seen then 22814 null; 22815 22816 -- A pair of one Input and one Output constituent is a valid 22817 -- completion. 22818 22819 elsif In_Seen and then Out_Seen then 22820 null; 22821 22822 -- A single Output constituent is a valid completion only when 22823 -- some of the other constituents are missing (SPARK RM 7.2.4(5)). 22824 22825 elsif Has_Missing and then Out_Seen then 22826 null; 22827 22828 else 22829 Error_Msg_NE 22830 ("global refinement of state & redefines the mode of its " 22831 & "constituents", N, State_Id); 22832 end if; 22833 end Check_Constituent_Usage; 22834 22835 -- Local variables 22836 22837 Item_Elmt : Elmt_Id; 22838 Item_Id : Entity_Id; 22839 22840 -- Start of processing for Check_In_Out_States 22841 22842 begin 22843 -- Inspect the In_Out items of the corresponding Global pragma 22844 -- looking for a state with a visible refinement. 22845 22846 if Has_In_Out_State and then Present (In_Out_Items) then 22847 Item_Elmt := First_Elmt (In_Out_Items); 22848 while Present (Item_Elmt) loop 22849 Item_Id := Node (Item_Elmt); 22850 22851 -- Ensure that one of the three coverage variants is satisfied 22852 22853 if Ekind (Item_Id) = E_Abstract_State 22854 and then Has_Non_Null_Refinement (Item_Id) 22855 then 22856 Check_Constituent_Usage (Item_Id); 22857 end if; 22858 22859 Next_Elmt (Item_Elmt); 22860 end loop; 22861 end if; 22862 end Check_In_Out_States; 22863 22864 ------------------------ 22865 -- Check_Input_States -- 22866 ------------------------ 22867 22868 procedure Check_Input_States is 22869 procedure Check_Constituent_Usage (State_Id : Entity_Id); 22870 -- Determine whether at least one constituent of state State_Id with 22871 -- visible refinement is used and has mode Input. Ensure that the 22872 -- remaining constituents do not have In_Out, Output or Proof_In 22873 -- modes. 22874 22875 ----------------------------- 22876 -- Check_Constituent_Usage -- 22877 ----------------------------- 22878 22879 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 22880 Constit_Elmt : Elmt_Id; 22881 Constit_Id : Entity_Id; 22882 In_Seen : Boolean := False; 22883 22884 begin 22885 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 22886 while Present (Constit_Elmt) loop 22887 Constit_Id := Node (Constit_Elmt); 22888 22889 -- At least one of the constituents appears as an Input 22890 22891 if Present_Then_Remove (In_Constits, Constit_Id) then 22892 In_Seen := True; 22893 22894 -- The constituent appears in the global refinement, but has 22895 -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)). 22896 22897 elsif Present_Then_Remove (In_Out_Constits, Constit_Id) 22898 or else Present_Then_Remove (Out_Constits, Constit_Id) 22899 or else Present_Then_Remove (Proof_In_Constits, Constit_Id) 22900 then 22901 Error_Msg_Name_1 := Chars (State_Id); 22902 Error_Msg_NE 22903 ("constituent & of state % must have mode Input in global " 22904 & "refinement", N, Constit_Id); 22905 end if; 22906 22907 Next_Elmt (Constit_Elmt); 22908 end loop; 22909 22910 -- Not one of the constituents appeared as Input 22911 22912 if not In_Seen then 22913 Error_Msg_NE 22914 ("global refinement of state & must include at least one " 22915 & "constituent of mode Input", N, State_Id); 22916 end if; 22917 end Check_Constituent_Usage; 22918 22919 -- Local variables 22920 22921 Item_Elmt : Elmt_Id; 22922 Item_Id : Entity_Id; 22923 22924 -- Start of processing for Check_Input_States 22925 22926 begin 22927 -- Inspect the Input items of the corresponding Global pragma 22928 -- looking for a state with a visible refinement. 22929 22930 if Has_In_State and then Present (In_Items) then 22931 Item_Elmt := First_Elmt (In_Items); 22932 while Present (Item_Elmt) loop 22933 Item_Id := Node (Item_Elmt); 22934 22935 -- Ensure that at least one of the constituents is utilized and 22936 -- is of mode Input. 22937 22938 if Ekind (Item_Id) = E_Abstract_State 22939 and then Has_Non_Null_Refinement (Item_Id) 22940 then 22941 Check_Constituent_Usage (Item_Id); 22942 end if; 22943 22944 Next_Elmt (Item_Elmt); 22945 end loop; 22946 end if; 22947 end Check_Input_States; 22948 22949 ------------------------- 22950 -- Check_Output_States -- 22951 ------------------------- 22952 22953 procedure Check_Output_States is 22954 procedure Check_Constituent_Usage (State_Id : Entity_Id); 22955 -- Determine whether all constituents of state State_Id with visible 22956 -- refinement are used and have mode Output. Emit an error if this is 22957 -- not the case. 22958 22959 ----------------------------- 22960 -- Check_Constituent_Usage -- 22961 ----------------------------- 22962 22963 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 22964 Constit_Elmt : Elmt_Id; 22965 Constit_Id : Entity_Id; 22966 Posted : Boolean := False; 22967 22968 begin 22969 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 22970 while Present (Constit_Elmt) loop 22971 Constit_Id := Node (Constit_Elmt); 22972 22973 if Present_Then_Remove (Out_Constits, Constit_Id) then 22974 null; 22975 22976 -- The constituent appears in the global refinement, but has 22977 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)). 22978 22979 elsif Present_Then_Remove (In_Constits, Constit_Id) 22980 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 22981 or else Present_Then_Remove (Proof_In_Constits, Constit_Id) 22982 then 22983 Error_Msg_Name_1 := Chars (State_Id); 22984 Error_Msg_NE 22985 ("constituent & of state % must have mode Output in " 22986 & "global refinement", N, Constit_Id); 22987 22988 -- The constituent is altogether missing (SPARK RM 7.2.5(3)) 22989 22990 else 22991 if not Posted then 22992 Posted := True; 22993 Error_Msg_NE 22994 ("output state & must be replaced by all its " 22995 & "constituents in global refinement", N, State_Id); 22996 end if; 22997 22998 Error_Msg_NE 22999 ("\constituent & is missing in output list", 23000 N, Constit_Id); 23001 end if; 23002 23003 Next_Elmt (Constit_Elmt); 23004 end loop; 23005 end Check_Constituent_Usage; 23006 23007 -- Local variables 23008 23009 Item_Elmt : Elmt_Id; 23010 Item_Id : Entity_Id; 23011 23012 -- Start of processing for Check_Output_States 23013 23014 begin 23015 -- Inspect the Output items of the corresponding Global pragma 23016 -- looking for a state with a visible refinement. 23017 23018 if Has_Out_State and then Present (Out_Items) then 23019 Item_Elmt := First_Elmt (Out_Items); 23020 while Present (Item_Elmt) loop 23021 Item_Id := Node (Item_Elmt); 23022 23023 -- Ensure that all of the constituents are utilized and they 23024 -- have mode Output. 23025 23026 if Ekind (Item_Id) = E_Abstract_State 23027 and then Has_Non_Null_Refinement (Item_Id) 23028 then 23029 Check_Constituent_Usage (Item_Id); 23030 end if; 23031 23032 Next_Elmt (Item_Elmt); 23033 end loop; 23034 end if; 23035 end Check_Output_States; 23036 23037 --------------------------- 23038 -- Check_Proof_In_States -- 23039 --------------------------- 23040 23041 procedure Check_Proof_In_States is 23042 procedure Check_Constituent_Usage (State_Id : Entity_Id); 23043 -- Determine whether at least one constituent of state State_Id with 23044 -- visible refinement is used and has mode Proof_In. Ensure that the 23045 -- remaining constituents do not have Input, In_Out or Output modes. 23046 23047 ----------------------------- 23048 -- Check_Constituent_Usage -- 23049 ----------------------------- 23050 23051 procedure Check_Constituent_Usage (State_Id : Entity_Id) is 23052 Constit_Elmt : Elmt_Id; 23053 Constit_Id : Entity_Id; 23054 Proof_In_Seen : Boolean := False; 23055 23056 begin 23057 Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id)); 23058 while Present (Constit_Elmt) loop 23059 Constit_Id := Node (Constit_Elmt); 23060 23061 -- At least one of the constituents appears as Proof_In 23062 23063 if Present_Then_Remove (Proof_In_Constits, Constit_Id) then 23064 Proof_In_Seen := True; 23065 23066 -- The constituent appears in the global refinement, but has 23067 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)). 23068 23069 elsif Present_Then_Remove (In_Constits, Constit_Id) 23070 or else Present_Then_Remove (In_Out_Constits, Constit_Id) 23071 or else Present_Then_Remove (Out_Constits, Constit_Id) 23072 then 23073 Error_Msg_Name_1 := Chars (State_Id); 23074 Error_Msg_NE 23075 ("constituent & of state % must have mode Proof_In in " 23076 & "global refinement", N, Constit_Id); 23077 end if; 23078 23079 Next_Elmt (Constit_Elmt); 23080 end loop; 23081 23082 -- Not one of the constituents appeared as Proof_In 23083 23084 if not Proof_In_Seen then 23085 Error_Msg_NE 23086 ("global refinement of state & must include at least one " 23087 & "constituent of mode Proof_In", N, State_Id); 23088 end if; 23089 end Check_Constituent_Usage; 23090 23091 -- Local variables 23092 23093 Item_Elmt : Elmt_Id; 23094 Item_Id : Entity_Id; 23095 23096 -- Start of processing for Check_Proof_In_States 23097 23098 begin 23099 -- Inspect the Proof_In items of the corresponding Global pragma 23100 -- looking for a state with a visible refinement. 23101 23102 if Has_Proof_In_State and then Present (Proof_In_Items) then 23103 Item_Elmt := First_Elmt (Proof_In_Items); 23104 while Present (Item_Elmt) loop 23105 Item_Id := Node (Item_Elmt); 23106 23107 -- Ensure that at least one of the constituents is utilized and 23108 -- is of mode Proof_In 23109 23110 if Ekind (Item_Id) = E_Abstract_State 23111 and then Has_Non_Null_Refinement (Item_Id) 23112 then 23113 Check_Constituent_Usage (Item_Id); 23114 end if; 23115 23116 Next_Elmt (Item_Elmt); 23117 end loop; 23118 end if; 23119 end Check_Proof_In_States; 23120 23121 ------------------------------- 23122 -- Check_Refined_Global_List -- 23123 ------------------------------- 23124 23125 procedure Check_Refined_Global_List 23126 (List : Node_Id; 23127 Global_Mode : Name_Id := Name_Input) 23128 is 23129 procedure Check_Refined_Global_Item 23130 (Item : Node_Id; 23131 Global_Mode : Name_Id); 23132 -- Verify the legality of a single global item declaration. Parameter 23133 -- Global_Mode denotes the current mode in effect. 23134 23135 ------------------------------- 23136 -- Check_Refined_Global_Item -- 23137 ------------------------------- 23138 23139 procedure Check_Refined_Global_Item 23140 (Item : Node_Id; 23141 Global_Mode : Name_Id) 23142 is 23143 Item_Id : constant Entity_Id := Entity_Of (Item); 23144 23145 procedure Inconsistent_Mode_Error (Expect : Name_Id); 23146 -- Issue a common error message for all mode mismatches. Expect 23147 -- denotes the expected mode. 23148 23149 ----------------------------- 23150 -- Inconsistent_Mode_Error -- 23151 ----------------------------- 23152 23153 procedure Inconsistent_Mode_Error (Expect : Name_Id) is 23154 begin 23155 Error_Msg_NE 23156 ("global item & has inconsistent modes", Item, Item_Id); 23157 23158 Error_Msg_Name_1 := Global_Mode; 23159 Error_Msg_Name_2 := Expect; 23160 Error_Msg_N ("\expected mode %, found mode %", Item); 23161 end Inconsistent_Mode_Error; 23162 23163 -- Start of processing for Check_Refined_Global_Item 23164 23165 begin 23166 -- When the state or variable acts as a constituent of another 23167 -- state with a visible refinement, collect it for the state 23168 -- completeness checks performed later on. 23169 23170 if Present (Encapsulating_State (Item_Id)) 23171 and then Has_Visible_Refinement (Encapsulating_State (Item_Id)) 23172 then 23173 if Global_Mode = Name_Input then 23174 Add_Item (Item_Id, In_Constits); 23175 23176 elsif Global_Mode = Name_In_Out then 23177 Add_Item (Item_Id, In_Out_Constits); 23178 23179 elsif Global_Mode = Name_Output then 23180 Add_Item (Item_Id, Out_Constits); 23181 23182 elsif Global_Mode = Name_Proof_In then 23183 Add_Item (Item_Id, Proof_In_Constits); 23184 end if; 23185 23186 -- When not a constituent, ensure that both occurrences of the 23187 -- item in pragmas Global and Refined_Global match. 23188 23189 elsif Contains (In_Items, Item_Id) then 23190 if Global_Mode /= Name_Input then 23191 Inconsistent_Mode_Error (Name_Input); 23192 end if; 23193 23194 elsif Contains (In_Out_Items, Item_Id) then 23195 if Global_Mode /= Name_In_Out then 23196 Inconsistent_Mode_Error (Name_In_Out); 23197 end if; 23198 23199 elsif Contains (Out_Items, Item_Id) then 23200 if Global_Mode /= Name_Output then 23201 Inconsistent_Mode_Error (Name_Output); 23202 end if; 23203 23204 elsif Contains (Proof_In_Items, Item_Id) then 23205 null; 23206 23207 -- The item does not appear in the corresponding Global pragma, 23208 -- it must be an extra (SPARK RM 7.2.4(3)). 23209 23210 else 23211 Error_Msg_NE ("extra global item &", Item, Item_Id); 23212 end if; 23213 end Check_Refined_Global_Item; 23214 23215 -- Local variables 23216 23217 Item : Node_Id; 23218 23219 -- Start of processing for Check_Refined_Global_List 23220 23221 begin 23222 if Nkind (List) = N_Null then 23223 null; 23224 23225 -- Single global item declaration 23226 23227 elsif Nkind_In (List, N_Expanded_Name, 23228 N_Identifier, 23229 N_Selected_Component) 23230 then 23231 Check_Refined_Global_Item (List, Global_Mode); 23232 23233 -- Simple global list or moded global list declaration 23234 23235 elsif Nkind (List) = N_Aggregate then 23236 23237 -- The declaration of a simple global list appear as a collection 23238 -- of expressions. 23239 23240 if Present (Expressions (List)) then 23241 Item := First (Expressions (List)); 23242 while Present (Item) loop 23243 Check_Refined_Global_Item (Item, Global_Mode); 23244 23245 Next (Item); 23246 end loop; 23247 23248 -- The declaration of a moded global list appears as a collection 23249 -- of component associations where individual choices denote 23250 -- modes. 23251 23252 elsif Present (Component_Associations (List)) then 23253 Item := First (Component_Associations (List)); 23254 while Present (Item) loop 23255 Check_Refined_Global_List 23256 (List => Expression (Item), 23257 Global_Mode => Chars (First (Choices (Item)))); 23258 23259 Next (Item); 23260 end loop; 23261 23262 -- Invalid tree 23263 23264 else 23265 raise Program_Error; 23266 end if; 23267 23268 -- Invalid list 23269 23270 else 23271 raise Program_Error; 23272 end if; 23273 end Check_Refined_Global_List; 23274 23275 ------------------------- 23276 -- Present_Then_Remove -- 23277 ------------------------- 23278 23279 function Present_Then_Remove 23280 (List : Elist_Id; 23281 Item : Entity_Id) return Boolean 23282 is 23283 Elmt : Elmt_Id; 23284 23285 begin 23286 if Present (List) then 23287 Elmt := First_Elmt (List); 23288 while Present (Elmt) loop 23289 if Node (Elmt) = Item then 23290 Remove_Elmt (List, Elmt); 23291 return True; 23292 end if; 23293 23294 Next_Elmt (Elmt); 23295 end loop; 23296 end if; 23297 23298 return False; 23299 end Present_Then_Remove; 23300 23301 ------------------------------- 23302 -- Report_Extra_Constituents -- 23303 ------------------------------- 23304 23305 procedure Report_Extra_Constituents is 23306 procedure Report_Extra_Constituents_In_List (List : Elist_Id); 23307 -- Emit an error for every element of List 23308 23309 --------------------------------------- 23310 -- Report_Extra_Constituents_In_List -- 23311 --------------------------------------- 23312 23313 procedure Report_Extra_Constituents_In_List (List : Elist_Id) is 23314 Constit_Elmt : Elmt_Id; 23315 23316 begin 23317 if Present (List) then 23318 Constit_Elmt := First_Elmt (List); 23319 while Present (Constit_Elmt) loop 23320 Error_Msg_NE ("extra constituent &", N, Node (Constit_Elmt)); 23321 Next_Elmt (Constit_Elmt); 23322 end loop; 23323 end if; 23324 end Report_Extra_Constituents_In_List; 23325 23326 -- Start of processing for Report_Extra_Constituents 23327 23328 begin 23329 Report_Extra_Constituents_In_List (In_Constits); 23330 Report_Extra_Constituents_In_List (In_Out_Constits); 23331 Report_Extra_Constituents_In_List (Out_Constits); 23332 Report_Extra_Constituents_In_List (Proof_In_Constits); 23333 end Report_Extra_Constituents; 23334 23335 -- Local variables 23336 23337 Body_Decl : constant Node_Id := Parent (N); 23338 Errors : constant Nat := Serious_Errors_Detected; 23339 Items : constant Node_Id := 23340 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 23341 Spec_Id : constant Entity_Id := Corresponding_Spec (Body_Decl); 23342 23343 -- Start of processing for Analyze_Refined_Global_In_Decl_Part 23344 23345 begin 23346 -- Verify the syntax of pragma Refined_Global when SPARK checks are 23347 -- suppressed. Semantic analysis is disabled in this mode. 23348 23349 if SPARK_Mode = Off then 23350 Check_Global_List_Syntax (Items); 23351 return; 23352 end if; 23353 23354 Global := Get_Pragma (Spec_Id, Pragma_Global); 23355 23356 -- The subprogram declaration lacks pragma Global. This renders 23357 -- Refined_Global useless as there is nothing to refine. 23358 23359 if No (Global) then 23360 Error_Msg_NE 23361 ("useless refinement, declaration of subprogram & lacks aspect or " 23362 & "pragma Global", N, Spec_Id); 23363 return; 23364 end if; 23365 23366 -- Extract all relevant items from the corresponding Global pragma 23367 23368 Collect_Global_Items 23369 (Prag => Global, 23370 In_Items => In_Items, 23371 In_Out_Items => In_Out_Items, 23372 Out_Items => Out_Items, 23373 Proof_In_Items => Proof_In_Items, 23374 Has_In_State => Has_In_State, 23375 Has_In_Out_State => Has_In_Out_State, 23376 Has_Out_State => Has_Out_State, 23377 Has_Proof_In_State => Has_Proof_In_State, 23378 Has_Null_State => Has_Null_State); 23379 23380 -- Corresponding Global pragma must mention at least one state witha 23381 -- visible refinement at the point Refined_Global is processed. States 23382 -- with null refinements need Refined_Global pragma (SPARK RM 7.2.4(2)). 23383 23384 if not Has_In_State 23385 and then not Has_In_Out_State 23386 and then not Has_Out_State 23387 and then not Has_Proof_In_State 23388 and then not Has_Null_State 23389 then 23390 Error_Msg_NE 23391 ("useless refinement, subprogram & does not depend on abstract " 23392 & "state with visible refinement", N, Spec_Id); 23393 return; 23394 end if; 23395 23396 -- The global refinement of inputs and outputs cannot be null when the 23397 -- corresponding Global pragma contains at least one item except in the 23398 -- case where we have states with null refinements. 23399 23400 if Nkind (Items) = N_Null 23401 and then 23402 (Present (In_Items) 23403 or else Present (In_Out_Items) 23404 or else Present (Out_Items) 23405 or else Present (Proof_In_Items)) 23406 and then not Has_Null_State 23407 then 23408 Error_Msg_NE 23409 ("refinement cannot be null, subprogram & has global items", 23410 N, Spec_Id); 23411 return; 23412 end if; 23413 23414 -- Analyze Refined_Global as if it behaved as a regular pragma Global. 23415 -- This ensures that the categorization of all refined global items is 23416 -- consistent with their role. 23417 23418 Analyze_Global_In_Decl_Part (N); 23419 23420 -- Perform all refinement checks with respect to completeness and mode 23421 -- matching. 23422 23423 if Serious_Errors_Detected = Errors then 23424 Check_Refined_Global_List (Items); 23425 end if; 23426 23427 -- For Input states with visible refinement, at least one constituent 23428 -- must be used as an Input in the global refinement. 23429 23430 if Serious_Errors_Detected = Errors then 23431 Check_Input_States; 23432 end if; 23433 23434 -- Verify all possible completion variants for In_Out states with 23435 -- visible refinement. 23436 23437 if Serious_Errors_Detected = Errors then 23438 Check_In_Out_States; 23439 end if; 23440 23441 -- For Output states with visible refinement, all constituents must be 23442 -- used as Outputs in the global refinement. 23443 23444 if Serious_Errors_Detected = Errors then 23445 Check_Output_States; 23446 end if; 23447 23448 -- For Proof_In states with visible refinement, at least one constituent 23449 -- must be used as Proof_In in the global refinement. 23450 23451 if Serious_Errors_Detected = Errors then 23452 Check_Proof_In_States; 23453 end if; 23454 23455 -- Emit errors for all constituents that belong to other states with 23456 -- visible refinement that do not appear in Global. 23457 23458 if Serious_Errors_Detected = Errors then 23459 Report_Extra_Constituents; 23460 end if; 23461 end Analyze_Refined_Global_In_Decl_Part; 23462 23463 ---------------------------------------- 23464 -- Analyze_Refined_State_In_Decl_Part -- 23465 ---------------------------------------- 23466 23467 procedure Analyze_Refined_State_In_Decl_Part (N : Node_Id) is 23468 Available_States : Elist_Id := No_Elist; 23469 -- A list of all abstract states defined in the package declaration that 23470 -- are available for refinement. The list is used to report unrefined 23471 -- states. 23472 23473 Body_Id : Entity_Id; 23474 -- The body entity of the package subject to pragma Refined_State 23475 23476 Body_States : Elist_Id := No_Elist; 23477 -- A list of all hidden states that appear in the body of the related 23478 -- package. The list is used to report unused hidden states. 23479 23480 Constituents_Seen : Elist_Id := No_Elist; 23481 -- A list that contains all constituents processed so far. The list is 23482 -- used to detect multiple uses of the same constituent. 23483 23484 Refined_States_Seen : Elist_Id := No_Elist; 23485 -- A list that contains all refined states processed so far. The list is 23486 -- used to detect duplicate refinements. 23487 23488 Spec_Id : Entity_Id; 23489 -- The spec entity of the package subject to pragma Refined_State 23490 23491 procedure Analyze_Refinement_Clause (Clause : Node_Id); 23492 -- Perform full analysis of a single refinement clause 23493 23494 procedure Check_Refinement_List_Syntax (List : Node_Id); 23495 -- Verify the syntax of refinement clause list List 23496 23497 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id; 23498 -- Gather the entities of all abstract states and variables declared in 23499 -- the body state space of package Pack_Id. 23500 23501 procedure Report_Unrefined_States (States : Elist_Id); 23502 -- Emit errors for all unrefined abstract states found in list States 23503 23504 procedure Report_Unused_States (States : Elist_Id); 23505 -- Emit errors for all unused states found in list States 23506 23507 ------------------------------- 23508 -- Analyze_Refinement_Clause -- 23509 ------------------------------- 23510 23511 procedure Analyze_Refinement_Clause (Clause : Node_Id) is 23512 AR_Constit : Entity_Id := Empty; 23513 AW_Constit : Entity_Id := Empty; 23514 ER_Constit : Entity_Id := Empty; 23515 EW_Constit : Entity_Id := Empty; 23516 -- The entities of external constituents that contain one of the 23517 -- following enabled properties: Async_Readers, Async_Writers, 23518 -- Effective_Reads and Effective_Writes. 23519 23520 External_Constit_Seen : Boolean := False; 23521 -- Flag used to mark when at least one external constituent is part 23522 -- of the state refinement. 23523 23524 Non_Null_Seen : Boolean := False; 23525 Null_Seen : Boolean := False; 23526 -- Flags used to detect multiple uses of null in a single clause or a 23527 -- mixture of null and non-null constituents. 23528 23529 Part_Of_Constits : Elist_Id := No_Elist; 23530 -- A list of all candidate constituents subject to indicator Part_Of 23531 -- where the encapsulating state is the current state. 23532 23533 State : Node_Id; 23534 State_Id : Entity_Id; 23535 -- The current state being refined 23536 23537 procedure Analyze_Constituent (Constit : Node_Id); 23538 -- Perform full analysis of a single constituent 23539 23540 procedure Check_External_Property 23541 (Prop_Nam : Name_Id; 23542 Enabled : Boolean; 23543 Constit : Entity_Id); 23544 -- Determine whether a property denoted by name Prop_Nam is present 23545 -- in both the refined state and constituent Constit. Flag Enabled 23546 -- should be set when the property applies to the refined state. If 23547 -- this is not the case, emit an error message. 23548 23549 procedure Check_Matching_State; 23550 -- Determine whether the state being refined appears in list 23551 -- Available_States. Emit an error when attempting to re-refine the 23552 -- state or when the state is not defined in the package declaration, 23553 -- otherwise remove the state from Available_States. 23554 23555 procedure Report_Unused_Constituents (Constits : Elist_Id); 23556 -- Emit errors for all unused Part_Of constituents in list Constits 23557 23558 ------------------------- 23559 -- Analyze_Constituent -- 23560 ------------------------- 23561 23562 procedure Analyze_Constituent (Constit : Node_Id) is 23563 procedure Check_Matching_Constituent (Constit_Id : Entity_Id); 23564 -- Determine whether constituent Constit denoted by its entity 23565 -- Constit_Id appears in Hidden_States. Emit an error when the 23566 -- constituent is not a valid hidden state of the related package 23567 -- or when it is used more than once. Otherwise remove the 23568 -- constituent from Hidden_States. 23569 23570 -------------------------------- 23571 -- Check_Matching_Constituent -- 23572 -------------------------------- 23573 23574 procedure Check_Matching_Constituent (Constit_Id : Entity_Id) is 23575 procedure Collect_Constituent; 23576 -- Add constituent Constit_Id to the refinements of State_Id 23577 23578 ------------------------- 23579 -- Collect_Constituent -- 23580 ------------------------- 23581 23582 procedure Collect_Constituent is 23583 begin 23584 -- Add the constituent to the list of processed items to aid 23585 -- with the detection of duplicates. 23586 23587 Add_Item (Constit_Id, Constituents_Seen); 23588 23589 -- Collect the constituent in the list of refinement items 23590 -- and establish a relation between the refined state and 23591 -- the item. 23592 23593 Append_Elmt (Constit_Id, Refinement_Constituents (State_Id)); 23594 Set_Encapsulating_State (Constit_Id, State_Id); 23595 23596 -- The state has at least one legal constituent, mark the 23597 -- start of the refinement region. The region ends when the 23598 -- body declarations end (see routine Analyze_Declarations). 23599 23600 Set_Has_Visible_Refinement (State_Id); 23601 23602 -- When the constituent is external, save its relevant 23603 -- property for further checks. 23604 23605 if Async_Readers_Enabled (Constit_Id) then 23606 AR_Constit := Constit_Id; 23607 External_Constit_Seen := True; 23608 end if; 23609 23610 if Async_Writers_Enabled (Constit_Id) then 23611 AW_Constit := Constit_Id; 23612 External_Constit_Seen := True; 23613 end if; 23614 23615 if Effective_Reads_Enabled (Constit_Id) then 23616 ER_Constit := Constit_Id; 23617 External_Constit_Seen := True; 23618 end if; 23619 23620 if Effective_Writes_Enabled (Constit_Id) then 23621 EW_Constit := Constit_Id; 23622 External_Constit_Seen := True; 23623 end if; 23624 end Collect_Constituent; 23625 23626 -- Local variables 23627 23628 State_Elmt : Elmt_Id; 23629 23630 -- Start of processing for Check_Matching_Constituent 23631 23632 begin 23633 -- Detect a duplicate use of a constituent 23634 23635 if Contains (Constituents_Seen, Constit_Id) then 23636 Error_Msg_NE 23637 ("duplicate use of constituent &", Constit, Constit_Id); 23638 return; 23639 end if; 23640 23641 -- The constituent is subject to a Part_Of indicator 23642 23643 if Present (Encapsulating_State (Constit_Id)) then 23644 if Encapsulating_State (Constit_Id) = State_Id then 23645 Remove (Part_Of_Constits, Constit_Id); 23646 Collect_Constituent; 23647 23648 -- The constituent is part of another state and is used 23649 -- incorrectly in the refinement of the current state. 23650 23651 else 23652 Error_Msg_Name_1 := Chars (State_Id); 23653 Error_Msg_NE 23654 ("& cannot act as constituent of state %", 23655 Constit, Constit_Id); 23656 Error_Msg_NE 23657 ("\Part_Of indicator specifies & as encapsulating " 23658 & "state", Constit, Encapsulating_State (Constit_Id)); 23659 end if; 23660 23661 -- The only other source of legal constituents is the body 23662 -- state space of the related package. 23663 23664 else 23665 if Present (Body_States) then 23666 State_Elmt := First_Elmt (Body_States); 23667 while Present (State_Elmt) loop 23668 23669 -- Consume a valid constituent to signal that it has 23670 -- been encountered. 23671 23672 if Node (State_Elmt) = Constit_Id then 23673 Remove_Elmt (Body_States, State_Elmt); 23674 Collect_Constituent; 23675 return; 23676 end if; 23677 23678 Next_Elmt (State_Elmt); 23679 end loop; 23680 end if; 23681 23682 -- If we get here, then the constituent is not a hidden 23683 -- state of the related package and may not be used in a 23684 -- refinement (SPARK RM 7.2.2(9)). 23685 23686 Error_Msg_Name_1 := Chars (Spec_Id); 23687 Error_Msg_NE 23688 ("cannot use & in refinement, constituent is not a hidden " 23689 & "state of package %", Constit, Constit_Id); 23690 end if; 23691 end Check_Matching_Constituent; 23692 23693 -- Local variables 23694 23695 Constit_Id : Entity_Id; 23696 23697 -- Start of processing for Analyze_Constituent 23698 23699 begin 23700 -- Detect multiple uses of null in a single refinement clause or a 23701 -- mixture of null and non-null constituents. 23702 23703 if Nkind (Constit) = N_Null then 23704 if Null_Seen then 23705 Error_Msg_N 23706 ("multiple null constituents not allowed", Constit); 23707 23708 elsif Non_Null_Seen then 23709 Error_Msg_N 23710 ("cannot mix null and non-null constituents", Constit); 23711 23712 else 23713 Null_Seen := True; 23714 23715 -- Collect the constituent in the list of refinement items 23716 23717 Append_Elmt (Constit, Refinement_Constituents (State_Id)); 23718 23719 -- The state has at least one legal constituent, mark the 23720 -- start of the refinement region. The region ends when the 23721 -- body declarations end (see Analyze_Declarations). 23722 23723 Set_Has_Visible_Refinement (State_Id); 23724 end if; 23725 23726 -- Non-null constituents 23727 23728 else 23729 Non_Null_Seen := True; 23730 23731 if Null_Seen then 23732 Error_Msg_N 23733 ("cannot mix null and non-null constituents", Constit); 23734 end if; 23735 23736 Analyze (Constit); 23737 Resolve_State (Constit); 23738 23739 -- Ensure that the constituent denotes a valid state or a 23740 -- whole variable. 23741 23742 if Is_Entity_Name (Constit) then 23743 Constit_Id := Entity_Of (Constit); 23744 23745 if Ekind_In (Constit_Id, E_Abstract_State, E_Variable) then 23746 Check_Matching_Constituent (Constit_Id); 23747 23748 else 23749 Error_Msg_NE 23750 ("constituent & must denote a variable or state (SPARK " 23751 & "RM 7.2.2(5))", Constit, Constit_Id); 23752 end if; 23753 23754 -- The constituent is illegal 23755 23756 else 23757 Error_Msg_N ("malformed constituent", Constit); 23758 end if; 23759 end if; 23760 end Analyze_Constituent; 23761 23762 ----------------------------- 23763 -- Check_External_Property -- 23764 ----------------------------- 23765 23766 procedure Check_External_Property 23767 (Prop_Nam : Name_Id; 23768 Enabled : Boolean; 23769 Constit : Entity_Id) 23770 is 23771 begin 23772 Error_Msg_Name_1 := Prop_Nam; 23773 23774 -- The property is enabled in the related Abstract_State pragma 23775 -- that defines the state (SPARK RM 7.2.8(3)). 23776 23777 if Enabled then 23778 if No (Constit) then 23779 Error_Msg_NE 23780 ("external state & requires at least one constituent with " 23781 & "property %", State, State_Id); 23782 end if; 23783 23784 -- The property is missing in the declaration of the state, but 23785 -- a constituent is introducing it in the state refinement 23786 -- (SPARK RM 7.2.8(3)). 23787 23788 elsif Present (Constit) then 23789 Error_Msg_Name_2 := Chars (Constit); 23790 Error_Msg_NE 23791 ("external state & lacks property % set by constituent %", 23792 State, State_Id); 23793 end if; 23794 end Check_External_Property; 23795 23796 -------------------------- 23797 -- Check_Matching_State -- 23798 -------------------------- 23799 23800 procedure Check_Matching_State is 23801 State_Elmt : Elmt_Id; 23802 23803 begin 23804 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8)) 23805 23806 if Contains (Refined_States_Seen, State_Id) then 23807 Error_Msg_NE 23808 ("duplicate refinement of state &", State, State_Id); 23809 return; 23810 end if; 23811 23812 -- Inspect the abstract states defined in the package declaration 23813 -- looking for a match. 23814 23815 State_Elmt := First_Elmt (Available_States); 23816 while Present (State_Elmt) loop 23817 23818 -- A valid abstract state is being refined in the body. Add 23819 -- the state to the list of processed refined states to aid 23820 -- with the detection of duplicate refinements. Remove the 23821 -- state from Available_States to signal that it has already 23822 -- been refined. 23823 23824 if Node (State_Elmt) = State_Id then 23825 Add_Item (State_Id, Refined_States_Seen); 23826 Remove_Elmt (Available_States, State_Elmt); 23827 return; 23828 end if; 23829 23830 Next_Elmt (State_Elmt); 23831 end loop; 23832 23833 -- If we get here, we are refining a state that is not defined in 23834 -- the package declaration. 23835 23836 Error_Msg_Name_1 := Chars (Spec_Id); 23837 Error_Msg_NE 23838 ("cannot refine state, & is not defined in package %", 23839 State, State_Id); 23840 end Check_Matching_State; 23841 23842 -------------------------------- 23843 -- Report_Unused_Constituents -- 23844 -------------------------------- 23845 23846 procedure Report_Unused_Constituents (Constits : Elist_Id) is 23847 Constit_Elmt : Elmt_Id; 23848 Constit_Id : Entity_Id; 23849 Posted : Boolean := False; 23850 23851 begin 23852 if Present (Constits) then 23853 Constit_Elmt := First_Elmt (Constits); 23854 while Present (Constit_Elmt) loop 23855 Constit_Id := Node (Constit_Elmt); 23856 23857 -- Generate an error message of the form: 23858 23859 -- state ... has unused Part_Of constituents 23860 -- abstract state ... defined at ... 23861 -- variable ... defined at ... 23862 23863 if not Posted then 23864 Posted := True; 23865 Error_Msg_NE 23866 ("state & has unused Part_Of constituents", 23867 State, State_Id); 23868 end if; 23869 23870 Error_Msg_Sloc := Sloc (Constit_Id); 23871 23872 if Ekind (Constit_Id) = E_Abstract_State then 23873 Error_Msg_NE 23874 ("\abstract state & defined #", State, Constit_Id); 23875 else 23876 Error_Msg_NE 23877 ("\variable & defined #", State, Constit_Id); 23878 end if; 23879 23880 Next_Elmt (Constit_Elmt); 23881 end loop; 23882 end if; 23883 end Report_Unused_Constituents; 23884 23885 -- Local declarations 23886 23887 Body_Ref : Node_Id; 23888 Body_Ref_Elmt : Elmt_Id; 23889 Constit : Node_Id; 23890 Extra_State : Node_Id; 23891 23892 -- Start of processing for Analyze_Refinement_Clause 23893 23894 begin 23895 -- A refinement clause appears as a component association where the 23896 -- sole choice is the state and the expressions are the constituents. 23897 23898 if Nkind (Clause) /= N_Component_Association then 23899 Error_Msg_N ("malformed state refinement clause", Clause); 23900 return; 23901 end if; 23902 23903 -- Analyze the state name of a refinement clause 23904 23905 State := First (Choices (Clause)); 23906 23907 Analyze (State); 23908 Resolve_State (State); 23909 23910 -- Ensure that the state name denotes a valid abstract state that is 23911 -- defined in the spec of the related package. 23912 23913 if Is_Entity_Name (State) then 23914 State_Id := Entity_Of (State); 23915 23916 -- Catch any attempts to re-refine a state or refine a state that 23917 -- is not defined in the package declaration. 23918 23919 if Ekind (State_Id) = E_Abstract_State then 23920 Check_Matching_State; 23921 else 23922 Error_Msg_NE 23923 ("& must denote an abstract state", State, State_Id); 23924 return; 23925 end if; 23926 23927 -- References to a state with visible refinement are illegal. 23928 -- When nested packages are involved, detecting such references is 23929 -- tricky because pragma Refined_State is analyzed later than the 23930 -- offending pragma Depends or Global. References that occur in 23931 -- such nested context are stored in a list. Emit errors for all 23932 -- references found in Body_References (SPARK RM 6.1.4(8)). 23933 23934 if Present (Body_References (State_Id)) then 23935 Body_Ref_Elmt := First_Elmt (Body_References (State_Id)); 23936 while Present (Body_Ref_Elmt) loop 23937 Body_Ref := Node (Body_Ref_Elmt); 23938 23939 Error_Msg_N ("reference to & not allowed", Body_Ref); 23940 Error_Msg_Sloc := Sloc (State); 23941 Error_Msg_N ("\refinement of & is visible#", Body_Ref); 23942 23943 Next_Elmt (Body_Ref_Elmt); 23944 end loop; 23945 end if; 23946 23947 -- The state name is illegal 23948 23949 else 23950 Error_Msg_N ("malformed state name in refinement clause", State); 23951 return; 23952 end if; 23953 23954 -- A refinement clause may only refine one state at a time 23955 23956 Extra_State := Next (State); 23957 23958 if Present (Extra_State) then 23959 Error_Msg_N 23960 ("refinement clause cannot cover multiple states", Extra_State); 23961 end if; 23962 23963 -- Replicate the Part_Of constituents of the refined state because 23964 -- the algorithm will consume items. 23965 23966 Part_Of_Constits := New_Copy_Elist (Part_Of_Constituents (State_Id)); 23967 23968 -- Analyze all constituents of the refinement. Multiple constituents 23969 -- appear as an aggregate. 23970 23971 Constit := Expression (Clause); 23972 23973 if Nkind (Constit) = N_Aggregate then 23974 if Present (Component_Associations (Constit)) then 23975 Error_Msg_N 23976 ("constituents of refinement clause must appear in " 23977 & "positional form", Constit); 23978 23979 else pragma Assert (Present (Expressions (Constit))); 23980 Constit := First (Expressions (Constit)); 23981 while Present (Constit) loop 23982 Analyze_Constituent (Constit); 23983 23984 Next (Constit); 23985 end loop; 23986 end if; 23987 23988 -- Various forms of a single constituent. Note that these may include 23989 -- malformed constituents. 23990 23991 else 23992 Analyze_Constituent (Constit); 23993 end if; 23994 23995 -- A refined external state is subject to special rules with respect 23996 -- to its properties and constituents. 23997 23998 if Is_External_State (State_Id) then 23999 24000 -- The set of properties that all external constituents yield must 24001 -- match that of the refined state. There are two cases to detect: 24002 -- the refined state lacks a property or has an extra property. 24003 24004 if External_Constit_Seen then 24005 Check_External_Property 24006 (Prop_Nam => Name_Async_Readers, 24007 Enabled => Async_Readers_Enabled (State_Id), 24008 Constit => AR_Constit); 24009 24010 Check_External_Property 24011 (Prop_Nam => Name_Async_Writers, 24012 Enabled => Async_Writers_Enabled (State_Id), 24013 Constit => AW_Constit); 24014 24015 Check_External_Property 24016 (Prop_Nam => Name_Effective_Reads, 24017 Enabled => Effective_Reads_Enabled (State_Id), 24018 Constit => ER_Constit); 24019 24020 Check_External_Property 24021 (Prop_Nam => Name_Effective_Writes, 24022 Enabled => Effective_Writes_Enabled (State_Id), 24023 Constit => EW_Constit); 24024 24025 -- An external state may be refined to null (SPARK RM 7.2.8(2)) 24026 24027 elsif Null_Seen then 24028 null; 24029 24030 -- The external state has constituents, but none of them are 24031 -- external (SPARK RM 7.2.8(2)). 24032 24033 else 24034 Error_Msg_NE 24035 ("external state & requires at least one external " 24036 & "constituent or null refinement", State, State_Id); 24037 end if; 24038 24039 -- When a refined state is not external, it should not have external 24040 -- constituents (SPARK RM 7.2.8(1)). 24041 24042 elsif External_Constit_Seen then 24043 Error_Msg_NE 24044 ("non-external state & cannot contain external constituents in " 24045 & "refinement", State, State_Id); 24046 end if; 24047 24048 -- Ensure that all Part_Of candidate constituents have been mentioned 24049 -- in the refinement clause. 24050 24051 Report_Unused_Constituents (Part_Of_Constits); 24052 end Analyze_Refinement_Clause; 24053 24054 ---------------------------------- 24055 -- Check_Refinement_List_Syntax -- 24056 ---------------------------------- 24057 24058 procedure Check_Refinement_List_Syntax (List : Node_Id) is 24059 procedure Check_Clause_Syntax (Clause : Node_Id); 24060 -- Verify the syntax of state refinement clause Clause 24061 24062 ------------------------- 24063 -- Check_Clause_Syntax -- 24064 ------------------------- 24065 24066 procedure Check_Clause_Syntax (Clause : Node_Id) is 24067 Constits : constant Node_Id := Expression (Clause); 24068 Constit : Node_Id; 24069 24070 begin 24071 -- State to be refined 24072 24073 Check_Item_Syntax (First (Choices (Clause))); 24074 24075 -- Multiple constituents 24076 24077 if Nkind (Constits) = N_Aggregate 24078 and then Present (Expressions (Constits)) 24079 then 24080 Constit := First (Expressions (Constits)); 24081 while Present (Constit) loop 24082 Check_Item_Syntax (Constit); 24083 Next (Constit); 24084 end loop; 24085 24086 -- Single constituent 24087 24088 else 24089 Check_Item_Syntax (Constits); 24090 end if; 24091 end Check_Clause_Syntax; 24092 24093 -- Local variables 24094 24095 Clause : Node_Id; 24096 24097 -- Start of processing for Check_Refinement_List_Syntax 24098 24099 begin 24100 -- Multiple state refinement clauses 24101 24102 if Nkind (List) = N_Aggregate 24103 and then Present (Component_Associations (List)) 24104 then 24105 Clause := First (Component_Associations (List)); 24106 while Present (Clause) loop 24107 Check_Clause_Syntax (Clause); 24108 Next (Clause); 24109 end loop; 24110 24111 -- Single state refinement clause 24112 24113 else 24114 Check_Clause_Syntax (List); 24115 end if; 24116 end Check_Refinement_List_Syntax; 24117 24118 ------------------------- 24119 -- Collect_Body_States -- 24120 ------------------------- 24121 24122 function Collect_Body_States (Pack_Id : Entity_Id) return Elist_Id is 24123 Result : Elist_Id := No_Elist; 24124 -- A list containing all body states of Pack_Id 24125 24126 procedure Collect_Visible_States (Pack_Id : Entity_Id); 24127 -- Gather the entities of all abstract states and variables declared 24128 -- in the visible state space of package Pack_Id. 24129 24130 ---------------------------- 24131 -- Collect_Visible_States -- 24132 ---------------------------- 24133 24134 procedure Collect_Visible_States (Pack_Id : Entity_Id) is 24135 Item_Id : Entity_Id; 24136 24137 begin 24138 -- Traverse the entity chain of the package and inspect all 24139 -- visible items. 24140 24141 Item_Id := First_Entity (Pack_Id); 24142 while Present (Item_Id) and then not In_Private_Part (Item_Id) loop 24143 24144 -- Do not consider internally generated items as those cannot 24145 -- be named and participate in refinement. 24146 24147 if not Comes_From_Source (Item_Id) then 24148 null; 24149 24150 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 24151 Add_Item (Item_Id, Result); 24152 24153 -- Recursively gather the visible states of a nested package 24154 24155 elsif Ekind (Item_Id) = E_Package then 24156 Collect_Visible_States (Item_Id); 24157 end if; 24158 24159 Next_Entity (Item_Id); 24160 end loop; 24161 end Collect_Visible_States; 24162 24163 -- Local variables 24164 24165 Pack_Body : constant Node_Id := 24166 Declaration_Node (Body_Entity (Pack_Id)); 24167 Decl : Node_Id; 24168 Item_Id : Entity_Id; 24169 24170 -- Start of processing for Collect_Body_States 24171 24172 begin 24173 -- Inspect the declarations of the body looking for source variables, 24174 -- packages and package instantiations. 24175 24176 Decl := First (Declarations (Pack_Body)); 24177 while Present (Decl) loop 24178 if Nkind (Decl) = N_Object_Declaration then 24179 Item_Id := Defining_Entity (Decl); 24180 24181 -- Capture source variables only as internally generated 24182 -- temporaries cannot be named and participate in refinement. 24183 24184 if Ekind (Item_Id) = E_Variable 24185 and then Comes_From_Source (Item_Id) 24186 then 24187 Add_Item (Item_Id, Result); 24188 end if; 24189 24190 elsif Nkind (Decl) = N_Package_Declaration then 24191 Item_Id := Defining_Entity (Decl); 24192 24193 -- Capture the visible abstract states and variables of a 24194 -- source package [instantiation]. 24195 24196 if Comes_From_Source (Item_Id) then 24197 Collect_Visible_States (Item_Id); 24198 end if; 24199 end if; 24200 24201 Next (Decl); 24202 end loop; 24203 24204 return Result; 24205 end Collect_Body_States; 24206 24207 ----------------------------- 24208 -- Report_Unrefined_States -- 24209 ----------------------------- 24210 24211 procedure Report_Unrefined_States (States : Elist_Id) is 24212 State_Elmt : Elmt_Id; 24213 24214 begin 24215 if Present (States) then 24216 State_Elmt := First_Elmt (States); 24217 while Present (State_Elmt) loop 24218 Error_Msg_N 24219 ("abstract state & must be refined", Node (State_Elmt)); 24220 24221 Next_Elmt (State_Elmt); 24222 end loop; 24223 end if; 24224 end Report_Unrefined_States; 24225 24226 -------------------------- 24227 -- Report_Unused_States -- 24228 -------------------------- 24229 24230 procedure Report_Unused_States (States : Elist_Id) is 24231 Posted : Boolean := False; 24232 State_Elmt : Elmt_Id; 24233 State_Id : Entity_Id; 24234 24235 begin 24236 if Present (States) then 24237 State_Elmt := First_Elmt (States); 24238 while Present (State_Elmt) loop 24239 State_Id := Node (State_Elmt); 24240 24241 -- Generate an error message of the form: 24242 24243 -- body of package ... has unused hidden states 24244 -- abstract state ... defined at ... 24245 -- variable ... defined at ... 24246 24247 if not Posted then 24248 Posted := True; 24249 Error_Msg_N 24250 ("body of package & has unused hidden states", Body_Id); 24251 end if; 24252 24253 Error_Msg_Sloc := Sloc (State_Id); 24254 24255 if Ekind (State_Id) = E_Abstract_State then 24256 Error_Msg_NE 24257 ("\abstract state & defined #", Body_Id, State_Id); 24258 else 24259 Error_Msg_NE 24260 ("\variable & defined #", Body_Id, State_Id); 24261 end if; 24262 24263 Next_Elmt (State_Elmt); 24264 end loop; 24265 end if; 24266 end Report_Unused_States; 24267 24268 -- Local declarations 24269 24270 Body_Decl : constant Node_Id := Parent (N); 24271 Clauses : constant Node_Id := 24272 Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); 24273 Clause : Node_Id; 24274 24275 -- Start of processing for Analyze_Refined_State_In_Decl_Part 24276 24277 begin 24278 Set_Analyzed (N); 24279 24280 -- Verify the syntax of pragma Refined_State when SPARK checks are 24281 -- suppressed. Semantic analysis is disabled in this mode. 24282 24283 if SPARK_Mode = Off then 24284 Check_Refinement_List_Syntax (Clauses); 24285 return; 24286 end if; 24287 24288 Body_Id := Defining_Entity (Body_Decl); 24289 Spec_Id := Corresponding_Spec (Body_Decl); 24290 24291 -- Replicate the abstract states declared by the package because the 24292 -- matching algorithm will consume states. 24293 24294 Available_States := New_Copy_Elist (Abstract_States (Spec_Id)); 24295 24296 -- Gather all abstract states and variables declared in the visible 24297 -- state space of the package body. These items must be utilized as 24298 -- constituents in a state refinement. 24299 24300 Body_States := Collect_Body_States (Spec_Id); 24301 24302 -- Multiple non-null state refinements appear as an aggregate 24303 24304 if Nkind (Clauses) = N_Aggregate then 24305 if Present (Expressions (Clauses)) then 24306 Error_Msg_N 24307 ("state refinements must appear as component associations", 24308 Clauses); 24309 24310 else pragma Assert (Present (Component_Associations (Clauses))); 24311 Clause := First (Component_Associations (Clauses)); 24312 while Present (Clause) loop 24313 Analyze_Refinement_Clause (Clause); 24314 24315 Next (Clause); 24316 end loop; 24317 end if; 24318 24319 -- Various forms of a single state refinement. Note that these may 24320 -- include malformed refinements. 24321 24322 else 24323 Analyze_Refinement_Clause (Clauses); 24324 end if; 24325 24326 -- List all abstract states that were left unrefined 24327 24328 Report_Unrefined_States (Available_States); 24329 24330 -- Ensure that all abstract states and variables declared in the body 24331 -- state space of the related package are utilized as constituents. 24332 24333 Report_Unused_States (Body_States); 24334 end Analyze_Refined_State_In_Decl_Part; 24335 24336 ------------------------------------ 24337 -- Analyze_Test_Case_In_Decl_Part -- 24338 ------------------------------------ 24339 24340 procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id) is 24341 begin 24342 -- Install formals and push subprogram spec onto scope stack so that we 24343 -- can see the formals from the pragma. 24344 24345 Push_Scope (S); 24346 Install_Formals (S); 24347 24348 -- Preanalyze the boolean expressions, we treat these as spec 24349 -- expressions (i.e. similar to a default expression). 24350 24351 if Pragma_Name (N) = Name_Test_Case then 24352 Preanalyze_CTC_Args 24353 (N, 24354 Get_Requires_From_CTC_Pragma (N), 24355 Get_Ensures_From_CTC_Pragma (N)); 24356 end if; 24357 24358 -- Remove the subprogram from the scope stack now that the pre-analysis 24359 -- of the expressions in the contract case or test case is done. 24360 24361 End_Scope; 24362 end Analyze_Test_Case_In_Decl_Part; 24363 24364 ---------------- 24365 -- Appears_In -- 24366 ---------------- 24367 24368 function Appears_In (List : Elist_Id; Item_Id : Entity_Id) return Boolean is 24369 Elmt : Elmt_Id; 24370 Id : Entity_Id; 24371 24372 begin 24373 if Present (List) then 24374 Elmt := First_Elmt (List); 24375 while Present (Elmt) loop 24376 if Nkind (Node (Elmt)) = N_Defining_Identifier then 24377 Id := Node (Elmt); 24378 else 24379 Id := Entity_Of (Node (Elmt)); 24380 end if; 24381 24382 if Id = Item_Id then 24383 return True; 24384 end if; 24385 24386 Next_Elmt (Elmt); 24387 end loop; 24388 end if; 24389 24390 return False; 24391 end Appears_In; 24392 24393 ----------------------------- 24394 -- Check_Applicable_Policy -- 24395 ----------------------------- 24396 24397 procedure Check_Applicable_Policy (N : Node_Id) is 24398 PP : Node_Id; 24399 Policy : Name_Id; 24400 24401 Ename : constant Name_Id := Original_Aspect_Name (N); 24402 24403 begin 24404 -- No effect if not valid assertion kind name 24405 24406 if not Is_Valid_Assertion_Kind (Ename) then 24407 return; 24408 end if; 24409 24410 -- Loop through entries in check policy list 24411 24412 PP := Opt.Check_Policy_List; 24413 while Present (PP) loop 24414 declare 24415 PPA : constant List_Id := Pragma_Argument_Associations (PP); 24416 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 24417 24418 begin 24419 if Ename = Pnm 24420 or else Pnm = Name_Assertion 24421 or else (Pnm = Name_Statement_Assertions 24422 and then Nam_In (Ename, Name_Assert, 24423 Name_Assert_And_Cut, 24424 Name_Assume, 24425 Name_Loop_Invariant, 24426 Name_Loop_Variant)) 24427 then 24428 Policy := Chars (Get_Pragma_Arg (Last (PPA))); 24429 24430 case Policy is 24431 when Name_Off | Name_Ignore => 24432 Set_Is_Ignored (N, True); 24433 Set_Is_Checked (N, False); 24434 24435 when Name_On | Name_Check => 24436 Set_Is_Checked (N, True); 24437 Set_Is_Ignored (N, False); 24438 24439 when Name_Disable => 24440 Set_Is_Ignored (N, True); 24441 Set_Is_Checked (N, False); 24442 Set_Is_Disabled (N, True); 24443 24444 -- That should be exhaustive, the null here is a defence 24445 -- against a malformed tree from previous errors. 24446 24447 when others => 24448 null; 24449 end case; 24450 24451 return; 24452 end if; 24453 24454 PP := Next_Pragma (PP); 24455 end; 24456 end loop; 24457 24458 -- If there are no specific entries that matched, then we let the 24459 -- setting of assertions govern. Note that this provides the needed 24460 -- compatibility with the RM for the cases of assertion, invariant, 24461 -- precondition, predicate, and postcondition. 24462 24463 if Assertions_Enabled then 24464 Set_Is_Checked (N, True); 24465 Set_Is_Ignored (N, False); 24466 else 24467 Set_Is_Checked (N, False); 24468 Set_Is_Ignored (N, True); 24469 end if; 24470 end Check_Applicable_Policy; 24471 24472 ---------------------------------- 24473 -- Check_Dependence_List_Syntax -- 24474 ---------------------------------- 24475 24476 procedure Check_Dependence_List_Syntax (List : Node_Id) is 24477 procedure Check_Clause_Syntax (Clause : Node_Id); 24478 -- Verify the syntax of a dependency clause Clause 24479 24480 ------------------------- 24481 -- Check_Clause_Syntax -- 24482 ------------------------- 24483 24484 procedure Check_Clause_Syntax (Clause : Node_Id) is 24485 Input : Node_Id; 24486 Inputs : Node_Id; 24487 Output : Node_Id; 24488 24489 begin 24490 -- Output items 24491 24492 Output := First (Choices (Clause)); 24493 while Present (Output) loop 24494 Check_Item_Syntax (Output); 24495 Next (Output); 24496 end loop; 24497 24498 Inputs := Expression (Clause); 24499 24500 -- A self-dependency appears as operator "+" 24501 24502 if Nkind (Inputs) = N_Op_Plus then 24503 Inputs := Right_Opnd (Inputs); 24504 end if; 24505 24506 -- Input items 24507 24508 if Nkind (Inputs) = N_Aggregate then 24509 if Present (Expressions (Inputs)) then 24510 Input := First (Expressions (Inputs)); 24511 while Present (Input) loop 24512 Check_Item_Syntax (Input); 24513 Next (Input); 24514 end loop; 24515 24516 else 24517 Error_Msg_N ("malformed input dependency list", Inputs); 24518 end if; 24519 24520 -- Single input item 24521 24522 else 24523 Check_Item_Syntax (Inputs); 24524 end if; 24525 end Check_Clause_Syntax; 24526 24527 -- Local variables 24528 24529 Clause : Node_Id; 24530 24531 -- Start of processing for Check_Dependence_List_Syntax 24532 24533 begin 24534 -- Null dependency relation 24535 24536 if Nkind (List) = N_Null then 24537 null; 24538 24539 -- Verify the syntax of a single or multiple dependency clauses 24540 24541 elsif Nkind (List) = N_Aggregate 24542 and then Present (Component_Associations (List)) 24543 then 24544 Clause := First (Component_Associations (List)); 24545 while Present (Clause) loop 24546 if Has_Extra_Parentheses (Clause) then 24547 null; 24548 else 24549 Check_Clause_Syntax (Clause); 24550 end if; 24551 24552 Next (Clause); 24553 end loop; 24554 24555 else 24556 Error_Msg_N ("malformed dependency relation", List); 24557 end if; 24558 end Check_Dependence_List_Syntax; 24559 24560 ------------------------------- 24561 -- Check_External_Properties -- 24562 ------------------------------- 24563 24564 procedure Check_External_Properties 24565 (Item : Node_Id; 24566 AR : Boolean; 24567 AW : Boolean; 24568 ER : Boolean; 24569 EW : Boolean) 24570 is 24571 begin 24572 -- All properties enabled 24573 24574 if AR and AW and ER and EW then 24575 null; 24576 24577 -- Async_Readers + Effective_Writes 24578 -- Async_Readers + Async_Writers + Effective_Writes 24579 24580 elsif AR and EW and not ER then 24581 null; 24582 24583 -- Async_Writers + Effective_Reads 24584 -- Async_Readers + Async_Writers + Effective_Reads 24585 24586 elsif AW and ER and not EW then 24587 null; 24588 24589 -- Async_Readers + Async_Writers 24590 24591 elsif AR and AW and not ER and not EW then 24592 null; 24593 24594 -- Async_Readers 24595 24596 elsif AR and not AW and not ER and not EW then 24597 null; 24598 24599 -- Async_Writers 24600 24601 elsif AW and not AR and not ER and not EW then 24602 null; 24603 24604 else 24605 Error_Msg_N 24606 ("illegal combination of external properties (SPARK RM 7.1.2(6))", 24607 Item); 24608 end if; 24609 end Check_External_Properties; 24610 24611 ------------------------------ 24612 -- Check_Global_List_Syntax -- 24613 ------------------------------ 24614 24615 procedure Check_Global_List_Syntax (List : Node_Id) is 24616 Assoc : Node_Id; 24617 Item : Node_Id; 24618 24619 begin 24620 -- Null global list 24621 24622 if Nkind (List) = N_Null then 24623 null; 24624 24625 -- Single global item 24626 24627 elsif Nkind_In (List, N_Expanded_Name, 24628 N_Identifier, 24629 N_Selected_Component) 24630 then 24631 null; 24632 24633 elsif Nkind (List) = N_Aggregate then 24634 24635 -- Items in a simple global list 24636 24637 if Present (Expressions (List)) then 24638 Item := First (Expressions (List)); 24639 while Present (Item) loop 24640 Check_Item_Syntax (Item); 24641 Next (Item); 24642 end loop; 24643 24644 -- Items in a moded global list 24645 24646 elsif Present (Component_Associations (List)) then 24647 Assoc := First (Component_Associations (List)); 24648 while Present (Assoc) loop 24649 Check_Item_Syntax (First (Choices (Assoc))); 24650 Check_Global_List_Syntax (Expression (Assoc)); 24651 24652 Next (Assoc); 24653 end loop; 24654 end if; 24655 24656 -- Anything else is an error 24657 24658 else 24659 Error_Msg_N ("malformed global list", List); 24660 end if; 24661 end Check_Global_List_Syntax; 24662 24663 ----------------------- 24664 -- Check_Item_Syntax -- 24665 ----------------------- 24666 24667 procedure Check_Item_Syntax (Item : Node_Id) is 24668 begin 24669 -- Null can appear in various annotation lists to denote a missing or 24670 -- optional relation. 24671 24672 if Nkind (Item) = N_Null then 24673 null; 24674 24675 -- Formal parameter, state or variable nodes 24676 24677 elsif Nkind_In (Item, N_Expanded_Name, 24678 N_Identifier, 24679 N_Selected_Component) 24680 then 24681 null; 24682 24683 -- Attribute 'Result can appear in annotations to denote the outcome of 24684 -- a function call. 24685 24686 elsif Is_Attribute_Result (Item) then 24687 null; 24688 24689 -- Any other node cannot possibly denote a legal SPARK item 24690 24691 else 24692 Error_Msg_N ("malformed item", Item); 24693 end if; 24694 end Check_Item_Syntax; 24695 24696 ---------------- 24697 -- Check_Kind -- 24698 ---------------- 24699 24700 function Check_Kind (Nam : Name_Id) return Name_Id is 24701 PP : Node_Id; 24702 24703 begin 24704 -- Loop through entries in check policy list 24705 24706 PP := Opt.Check_Policy_List; 24707 while Present (PP) loop 24708 declare 24709 PPA : constant List_Id := Pragma_Argument_Associations (PP); 24710 Pnm : constant Name_Id := Chars (Get_Pragma_Arg (First (PPA))); 24711 24712 begin 24713 if Nam = Pnm 24714 or else (Pnm = Name_Assertion 24715 and then Is_Valid_Assertion_Kind (Nam)) 24716 or else (Pnm = Name_Statement_Assertions 24717 and then Nam_In (Nam, Name_Assert, 24718 Name_Assert_And_Cut, 24719 Name_Assume, 24720 Name_Loop_Invariant, 24721 Name_Loop_Variant)) 24722 then 24723 case (Chars (Get_Pragma_Arg (Last (PPA)))) is 24724 when Name_On | Name_Check => 24725 return Name_Check; 24726 when Name_Off | Name_Ignore => 24727 return Name_Ignore; 24728 when Name_Disable => 24729 return Name_Disable; 24730 when others => 24731 raise Program_Error; 24732 end case; 24733 24734 else 24735 PP := Next_Pragma (PP); 24736 end if; 24737 end; 24738 end loop; 24739 24740 -- If there are no specific entries that matched, then we let the 24741 -- setting of assertions govern. Note that this provides the needed 24742 -- compatibility with the RM for the cases of assertion, invariant, 24743 -- precondition, predicate, and postcondition. 24744 24745 if Assertions_Enabled then 24746 return Name_Check; 24747 else 24748 return Name_Ignore; 24749 end if; 24750 end Check_Kind; 24751 24752 --------------------------- 24753 -- Check_Missing_Part_Of -- 24754 --------------------------- 24755 24756 procedure Check_Missing_Part_Of (Item_Id : Entity_Id) is 24757 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean; 24758 -- Determine whether a package denoted by Pack_Id declares at least one 24759 -- visible state. 24760 24761 ----------------------- 24762 -- Has_Visible_State -- 24763 ----------------------- 24764 24765 function Has_Visible_State (Pack_Id : Entity_Id) return Boolean is 24766 Item_Id : Entity_Id; 24767 24768 begin 24769 -- Traverse the entity chain of the package trying to find at least 24770 -- one visible abstract state, variable or a package [instantiation] 24771 -- that declares a visible state. 24772 24773 Item_Id := First_Entity (Pack_Id); 24774 while Present (Item_Id) 24775 and then not In_Private_Part (Item_Id) 24776 loop 24777 -- Do not consider internally generated items 24778 24779 if not Comes_From_Source (Item_Id) then 24780 null; 24781 24782 -- A visible state has been found 24783 24784 elsif Ekind_In (Item_Id, E_Abstract_State, E_Variable) then 24785 return True; 24786 24787 -- Recursively peek into nested packages and instantiations 24788 24789 elsif Ekind (Item_Id) = E_Package 24790 and then Has_Visible_State (Item_Id) 24791 then 24792 return True; 24793 end if; 24794 24795 Next_Entity (Item_Id); 24796 end loop; 24797 24798 return False; 24799 end Has_Visible_State; 24800 24801 -- Local variables 24802 24803 Pack_Id : Entity_Id; 24804 Placement : State_Space_Kind; 24805 24806 -- Start of processing for Check_Missing_Part_Of 24807 24808 begin 24809 -- Do not consider internally generated entities as these can never 24810 -- have a Part_Of indicator. 24811 24812 if not Comes_From_Source (Item_Id) then 24813 return; 24814 24815 -- Perform these checks only when SPARK_Mode is enabled as they will 24816 -- interfere with standard Ada rules and produce false positives. 24817 24818 elsif SPARK_Mode /= On then 24819 return; 24820 end if; 24821 24822 -- Find where the abstract state, variable or package instantiation 24823 -- lives with respect to the state space. 24824 24825 Find_Placement_In_State_Space 24826 (Item_Id => Item_Id, 24827 Placement => Placement, 24828 Pack_Id => Pack_Id); 24829 24830 -- Items that appear in a non-package construct (subprogram, block, etc) 24831 -- do not require a Part_Of indicator because they can never act as a 24832 -- hidden state. 24833 24834 if Placement = Not_In_Package then 24835 null; 24836 24837 -- An item declared in the body state space of a package always act as a 24838 -- constituent and does not need explicit Part_Of indicator. 24839 24840 elsif Placement = Body_State_Space then 24841 null; 24842 24843 -- In general an item declared in the visible state space of a package 24844 -- does not require a Part_Of indicator. The only exception is when the 24845 -- related package is a private child unit in which case Part_Of must 24846 -- denote a state in the parent unit or in one of its descendants. 24847 24848 elsif Placement = Visible_State_Space then 24849 if Is_Child_Unit (Pack_Id) 24850 and then Is_Private_Descendant (Pack_Id) 24851 then 24852 -- A package instantiation does not need a Part_Of indicator when 24853 -- the related generic template has no visible state. 24854 24855 if Ekind (Item_Id) = E_Package 24856 and then Is_Generic_Instance (Item_Id) 24857 and then not Has_Visible_State (Item_Id) 24858 then 24859 null; 24860 24861 -- All other cases require Part_Of 24862 24863 else 24864 Error_Msg_N 24865 ("indicator Part_Of is required in this context " 24866 & "(SPARK RM 7.2.6(3))", Item_Id); 24867 Error_Msg_Name_1 := Chars (Pack_Id); 24868 Error_Msg_N 24869 ("\& is declared in the visible part of private child " 24870 & "unit %", Item_Id); 24871 end if; 24872 end if; 24873 24874 -- When the item appears in the private state space of a packge, it must 24875 -- be a part of some state declared by the said package. 24876 24877 else pragma Assert (Placement = Private_State_Space); 24878 24879 -- The related package does not declare a state, the item cannot act 24880 -- as a Part_Of constituent. 24881 24882 if No (Get_Pragma (Pack_Id, Pragma_Abstract_State)) then 24883 null; 24884 24885 -- A package instantiation does not need a Part_Of indicator when the 24886 -- related generic template has no visible state. 24887 24888 elsif Ekind (Pack_Id) = E_Package 24889 and then Is_Generic_Instance (Pack_Id) 24890 and then not Has_Visible_State (Pack_Id) 24891 then 24892 null; 24893 24894 -- All other cases require Part_Of 24895 24896 else 24897 Error_Msg_N 24898 ("indicator Part_Of is required in this context " 24899 & "(SPARK RM 7.2.6(2))", Item_Id); 24900 Error_Msg_Name_1 := Chars (Pack_Id); 24901 Error_Msg_N 24902 ("\& is declared in the private part of package %", Item_Id); 24903 end if; 24904 end if; 24905 end Check_Missing_Part_Of; 24906 24907 --------------------------------- 24908 -- Check_SPARK_Aspect_For_ASIS -- 24909 --------------------------------- 24910 24911 procedure Check_SPARK_Aspect_For_ASIS (N : Node_Id) is 24912 Expr : Node_Id; 24913 24914 begin 24915 if ASIS_Mode and then From_Aspect_Specification (N) then 24916 Expr := Expression (Corresponding_Aspect (N)); 24917 if Nkind (Expr) /= N_Aggregate then 24918 Preanalyze_And_Resolve (Expr); 24919 24920 else 24921 declare 24922 Comps : constant List_Id := Component_Associations (Expr); 24923 Exprs : constant List_Id := Expressions (Expr); 24924 C : Node_Id; 24925 E : Node_Id; 24926 24927 begin 24928 E := First (Exprs); 24929 while Present (E) loop 24930 Analyze (E); 24931 Next (E); 24932 end loop; 24933 24934 C := First (Comps); 24935 while Present (C) loop 24936 Analyze (Expression (C)); 24937 Next (C); 24938 end loop; 24939 end; 24940 end if; 24941 end if; 24942 end Check_SPARK_Aspect_For_ASIS; 24943 24944 ------------------------------------- 24945 -- Check_State_And_Constituent_Use -- 24946 ------------------------------------- 24947 24948 procedure Check_State_And_Constituent_Use 24949 (States : Elist_Id; 24950 Constits : Elist_Id; 24951 Context : Node_Id) 24952 is 24953 function Find_Encapsulating_State 24954 (Constit_Id : Entity_Id) return Entity_Id; 24955 -- Given the entity of a constituent, try to find a corresponding 24956 -- encapsulating state that appears in the same context. The routine 24957 -- returns Empty is no such state is found. 24958 24959 ------------------------------ 24960 -- Find_Encapsulating_State -- 24961 ------------------------------ 24962 24963 function Find_Encapsulating_State 24964 (Constit_Id : Entity_Id) return Entity_Id 24965 is 24966 State_Id : Entity_Id; 24967 24968 begin 24969 -- Since a constituent may be part of a larger constituent set, climb 24970 -- the encapsulated state chain looking for a state that appears in 24971 -- the same context. 24972 24973 State_Id := Encapsulating_State (Constit_Id); 24974 while Present (State_Id) loop 24975 if Contains (States, State_Id) then 24976 return State_Id; 24977 end if; 24978 24979 State_Id := Encapsulating_State (State_Id); 24980 end loop; 24981 24982 return Empty; 24983 end Find_Encapsulating_State; 24984 24985 -- Local variables 24986 24987 Constit_Elmt : Elmt_Id; 24988 Constit_Id : Entity_Id; 24989 State_Id : Entity_Id; 24990 24991 -- Start of processing for Check_State_And_Constituent_Use 24992 24993 begin 24994 -- Nothing to do if there are no states or constituents 24995 24996 if No (States) or else No (Constits) then 24997 return; 24998 end if; 24999 25000 -- Inspect the list of constituents and try to determine whether its 25001 -- encapsulating state is in list States. 25002 25003 Constit_Elmt := First_Elmt (Constits); 25004 while Present (Constit_Elmt) loop 25005 Constit_Id := Node (Constit_Elmt); 25006 25007 -- Determine whether the constituent is part of an encapsulating 25008 -- state that appears in the same context and if this is the case, 25009 -- emit an error (SPARK RM 7.2.6(7)). 25010 25011 State_Id := Find_Encapsulating_State (Constit_Id); 25012 25013 if Present (State_Id) then 25014 Error_Msg_Name_1 := Chars (Constit_Id); 25015 Error_Msg_NE 25016 ("cannot mention state & and its constituent % in the same " 25017 & "context", Context, State_Id); 25018 exit; 25019 end if; 25020 25021 Next_Elmt (Constit_Elmt); 25022 end loop; 25023 end Check_State_And_Constituent_Use; 25024 25025 -------------------------- 25026 -- Collect_Global_Items -- 25027 -------------------------- 25028 25029 procedure Collect_Global_Items 25030 (Prag : Node_Id; 25031 In_Items : in out Elist_Id; 25032 In_Out_Items : in out Elist_Id; 25033 Out_Items : in out Elist_Id; 25034 Proof_In_Items : in out Elist_Id; 25035 Has_In_State : out Boolean; 25036 Has_In_Out_State : out Boolean; 25037 Has_Out_State : out Boolean; 25038 Has_Proof_In_State : out Boolean; 25039 Has_Null_State : out Boolean) 25040 is 25041 procedure Process_Global_List 25042 (List : Node_Id; 25043 Mode : Name_Id := Name_Input); 25044 -- Collect all items housed in a global list. Formal Mode denotes the 25045 -- current mode in effect. 25046 25047 ------------------------- 25048 -- Process_Global_List -- 25049 ------------------------- 25050 25051 procedure Process_Global_List 25052 (List : Node_Id; 25053 Mode : Name_Id := Name_Input) 25054 is 25055 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id); 25056 -- Add a single item to the appropriate list. Formal Mode denotes the 25057 -- current mode in effect. 25058 25059 ------------------------- 25060 -- Process_Global_Item -- 25061 ------------------------- 25062 25063 procedure Process_Global_Item (Item : Node_Id; Mode : Name_Id) is 25064 Item_Id : constant Entity_Id := Available_View (Entity_Of (Item)); 25065 -- The above handles abstract views of variables and states built 25066 -- for limited with clauses. 25067 25068 begin 25069 -- Signal that the global list contains at least one abstract 25070 -- state with a visible refinement. Note that the refinement may 25071 -- be null in which case there are no constituents. 25072 25073 if Ekind (Item_Id) = E_Abstract_State then 25074 if Has_Null_Refinement (Item_Id) then 25075 Has_Null_State := True; 25076 25077 elsif Has_Non_Null_Refinement (Item_Id) then 25078 if Mode = Name_Input then 25079 Has_In_State := True; 25080 elsif Mode = Name_In_Out then 25081 Has_In_Out_State := True; 25082 elsif Mode = Name_Output then 25083 Has_Out_State := True; 25084 elsif Mode = Name_Proof_In then 25085 Has_Proof_In_State := True; 25086 end if; 25087 end if; 25088 end if; 25089 25090 -- Add the item to the proper list 25091 25092 if Mode = Name_Input then 25093 Add_Item (Item_Id, In_Items); 25094 elsif Mode = Name_In_Out then 25095 Add_Item (Item_Id, In_Out_Items); 25096 elsif Mode = Name_Output then 25097 Add_Item (Item_Id, Out_Items); 25098 elsif Mode = Name_Proof_In then 25099 Add_Item (Item_Id, Proof_In_Items); 25100 end if; 25101 end Process_Global_Item; 25102 25103 -- Local variables 25104 25105 Item : Node_Id; 25106 25107 -- Start of processing for Process_Global_List 25108 25109 begin 25110 if Nkind (List) = N_Null then 25111 null; 25112 25113 -- Single global item declaration 25114 25115 elsif Nkind_In (List, N_Expanded_Name, 25116 N_Identifier, 25117 N_Selected_Component) 25118 then 25119 Process_Global_Item (List, Mode); 25120 25121 -- Single global list or moded global list declaration 25122 25123 elsif Nkind (List) = N_Aggregate then 25124 25125 -- The declaration of a simple global list appear as a collection 25126 -- of expressions. 25127 25128 if Present (Expressions (List)) then 25129 Item := First (Expressions (List)); 25130 while Present (Item) loop 25131 Process_Global_Item (Item, Mode); 25132 25133 Next (Item); 25134 end loop; 25135 25136 -- The declaration of a moded global list appears as a collection 25137 -- of component associations where individual choices denote mode. 25138 25139 elsif Present (Component_Associations (List)) then 25140 Item := First (Component_Associations (List)); 25141 while Present (Item) loop 25142 Process_Global_List 25143 (List => Expression (Item), 25144 Mode => Chars (First (Choices (Item)))); 25145 25146 Next (Item); 25147 end loop; 25148 25149 -- Invalid tree 25150 25151 else 25152 raise Program_Error; 25153 end if; 25154 25155 -- Invalid list 25156 25157 else 25158 raise Program_Error; 25159 end if; 25160 end Process_Global_List; 25161 25162 -- Local variables 25163 25164 Items : constant Node_Id := 25165 Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); 25166 25167 -- Start of processing for Collect_Global_Items 25168 25169 begin 25170 -- Assume that no states have been encountered 25171 25172 Has_In_State := False; 25173 Has_In_Out_State := False; 25174 Has_Out_State := False; 25175 Has_Proof_In_State := False; 25176 Has_Null_State := False; 25177 25178 Process_Global_List (Items); 25179 end Collect_Global_Items; 25180 25181 --------------------------------------- 25182 -- Collect_Subprogram_Inputs_Outputs -- 25183 --------------------------------------- 25184 25185 procedure Collect_Subprogram_Inputs_Outputs 25186 (Subp_Id : Entity_Id; 25187 Subp_Inputs : in out Elist_Id; 25188 Subp_Outputs : in out Elist_Id; 25189 Global_Seen : out Boolean) 25190 is 25191 procedure Collect_Global_List 25192 (List : Node_Id; 25193 Mode : Name_Id := Name_Input); 25194 -- Collect all relevant items from a global list 25195 25196 ------------------------- 25197 -- Collect_Global_List -- 25198 ------------------------- 25199 25200 procedure Collect_Global_List 25201 (List : Node_Id; 25202 Mode : Name_Id := Name_Input) 25203 is 25204 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id); 25205 -- Add an item to the proper subprogram input or output collection 25206 25207 ------------------------- 25208 -- Collect_Global_Item -- 25209 ------------------------- 25210 25211 procedure Collect_Global_Item (Item : Node_Id; Mode : Name_Id) is 25212 begin 25213 if Nam_In (Mode, Name_In_Out, Name_Input) then 25214 Add_Item (Item, Subp_Inputs); 25215 end if; 25216 25217 if Nam_In (Mode, Name_In_Out, Name_Output) then 25218 Add_Item (Item, Subp_Outputs); 25219 end if; 25220 end Collect_Global_Item; 25221 25222 -- Local variables 25223 25224 Assoc : Node_Id; 25225 Item : Node_Id; 25226 25227 -- Start of processing for Collect_Global_List 25228 25229 begin 25230 if Nkind (List) = N_Null then 25231 null; 25232 25233 -- Single global item declaration 25234 25235 elsif Nkind_In (List, N_Expanded_Name, 25236 N_Identifier, 25237 N_Selected_Component) 25238 then 25239 Collect_Global_Item (List, Mode); 25240 25241 -- Simple global list or moded global list declaration 25242 25243 elsif Nkind (List) = N_Aggregate then 25244 if Present (Expressions (List)) then 25245 Item := First (Expressions (List)); 25246 while Present (Item) loop 25247 Collect_Global_Item (Item, Mode); 25248 Next (Item); 25249 end loop; 25250 25251 else 25252 Assoc := First (Component_Associations (List)); 25253 while Present (Assoc) loop 25254 Collect_Global_List 25255 (List => Expression (Assoc), 25256 Mode => Chars (First (Choices (Assoc)))); 25257 Next (Assoc); 25258 end loop; 25259 end if; 25260 25261 -- Invalid list 25262 25263 else 25264 raise Program_Error; 25265 end if; 25266 end Collect_Global_List; 25267 25268 -- Local variables 25269 25270 Formal : Entity_Id; 25271 Global : Node_Id; 25272 List : Node_Id; 25273 Spec_Id : Entity_Id; 25274 25275 -- Start of processing for Collect_Subprogram_Inputs_Outputs 25276 25277 begin 25278 Global_Seen := False; 25279 25280 -- Find the entity of the corresponding spec when processing a body 25281 25282 if Ekind (Subp_Id) = E_Subprogram_Body then 25283 Spec_Id := Corresponding_Spec (Parent (Parent (Subp_Id))); 25284 else 25285 Spec_Id := Subp_Id; 25286 end if; 25287 25288 -- Process all formal parameters 25289 25290 Formal := First_Formal (Spec_Id); 25291 while Present (Formal) loop 25292 if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then 25293 Add_Item (Formal, Subp_Inputs); 25294 end if; 25295 25296 if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then 25297 Add_Item (Formal, Subp_Outputs); 25298 25299 -- Out parameters can act as inputs when the related type is 25300 -- tagged, unconstrained array, unconstrained record or record 25301 -- with unconstrained components. 25302 25303 if Ekind (Formal) = E_Out_Parameter 25304 and then Is_Unconstrained_Or_Tagged_Item (Formal) 25305 then 25306 Add_Item (Formal, Subp_Inputs); 25307 end if; 25308 end if; 25309 25310 Next_Formal (Formal); 25311 end loop; 25312 25313 -- When processing a subprogram body, look for pragma Refined_Global as 25314 -- it provides finer granularity of inputs and outputs. 25315 25316 if Ekind (Subp_Id) = E_Subprogram_Body then 25317 Global := Get_Pragma (Subp_Id, Pragma_Refined_Global); 25318 25319 -- Subprogram declaration case, look for pragma Global 25320 25321 else 25322 Global := Get_Pragma (Spec_Id, Pragma_Global); 25323 end if; 25324 25325 if Present (Global) then 25326 Global_Seen := True; 25327 List := Expression (First (Pragma_Argument_Associations (Global))); 25328 25329 -- The pragma may not have been analyzed because of the arbitrary 25330 -- declaration order of aspects. Make sure that it is analyzed for 25331 -- the purposes of item extraction. 25332 25333 if not Analyzed (List) then 25334 if Pragma_Name (Global) = Name_Refined_Global then 25335 Analyze_Refined_Global_In_Decl_Part (Global); 25336 else 25337 Analyze_Global_In_Decl_Part (Global); 25338 end if; 25339 end if; 25340 25341 -- Nothing to be done for a null global list 25342 25343 if Nkind (List) /= N_Null then 25344 Collect_Global_List (List); 25345 end if; 25346 end if; 25347 end Collect_Subprogram_Inputs_Outputs; 25348 25349 --------------------------------- 25350 -- Delay_Config_Pragma_Analyze -- 25351 --------------------------------- 25352 25353 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is 25354 begin 25355 return Nam_In (Pragma_Name (N), Name_Interrupt_State, 25356 Name_Priority_Specific_Dispatching); 25357 end Delay_Config_Pragma_Analyze; 25358 25359 ------------------------------------- 25360 -- Find_Related_Subprogram_Or_Body -- 25361 ------------------------------------- 25362 25363 function Find_Related_Subprogram_Or_Body 25364 (Prag : Node_Id; 25365 Do_Checks : Boolean := False) return Node_Id 25366 is 25367 Context : constant Node_Id := Parent (Prag); 25368 Nam : constant Name_Id := Pragma_Name (Prag); 25369 Stmt : Node_Id; 25370 25371 Look_For_Body : constant Boolean := 25372 Nam_In (Nam, Name_Refined_Depends, 25373 Name_Refined_Global, 25374 Name_Refined_Post); 25375 -- Refinement pragmas must be associated with a subprogram body [stub] 25376 25377 begin 25378 pragma Assert (Nkind (Prag) = N_Pragma); 25379 25380 -- If the pragma is a byproduct of aspect expansion, return the related 25381 -- context of the original aspect. 25382 25383 if Present (Corresponding_Aspect (Prag)) then 25384 return Parent (Corresponding_Aspect (Prag)); 25385 end if; 25386 25387 -- Otherwise the pragma is a source construct, most likely part of a 25388 -- declarative list. Skip preceding declarations while looking for a 25389 -- proper subprogram declaration. 25390 25391 pragma Assert (Is_List_Member (Prag)); 25392 25393 Stmt := Prev (Prag); 25394 while Present (Stmt) loop 25395 25396 -- Skip prior pragmas, but check for duplicates 25397 25398 if Nkind (Stmt) = N_Pragma then 25399 if Do_Checks and then Pragma_Name (Stmt) = Nam then 25400 Error_Msg_Name_1 := Nam; 25401 Error_Msg_Sloc := Sloc (Stmt); 25402 Error_Msg_N ("pragma % duplicates pragma declared #", Prag); 25403 end if; 25404 25405 -- Emit an error when a refinement pragma appears on an expression 25406 -- function without a completion. 25407 25408 elsif Do_Checks 25409 and then Look_For_Body 25410 and then Nkind (Stmt) = N_Subprogram_Declaration 25411 and then Nkind (Original_Node (Stmt)) = N_Expression_Function 25412 and then not Has_Completion (Defining_Entity (Stmt)) 25413 then 25414 Error_Msg_Name_1 := Nam; 25415 Error_Msg_N 25416 ("pragma % cannot apply to a stand alone expression function", 25417 Prag); 25418 25419 return Empty; 25420 25421 -- The refinement pragma applies to a subprogram body stub 25422 25423 elsif Look_For_Body 25424 and then Nkind (Stmt) = N_Subprogram_Body_Stub 25425 then 25426 return Stmt; 25427 25428 -- Skip internally generated code 25429 25430 elsif not Comes_From_Source (Stmt) then 25431 null; 25432 25433 -- Return the current construct which is either a subprogram body, 25434 -- a subprogram declaration or is illegal. 25435 25436 else 25437 return Stmt; 25438 end if; 25439 25440 Prev (Stmt); 25441 end loop; 25442 25443 -- If we fall through, then the pragma was either the first declaration 25444 -- or it was preceded by other pragmas and no source constructs. 25445 25446 -- The pragma is associated with a library-level subprogram 25447 25448 if Nkind (Context) = N_Compilation_Unit_Aux then 25449 return Unit (Parent (Context)); 25450 25451 -- The pragma appears inside the declarative part of a subprogram body 25452 25453 elsif Nkind (Context) = N_Subprogram_Body then 25454 return Context; 25455 25456 -- No candidate subprogram [body] found 25457 25458 else 25459 return Empty; 25460 end if; 25461 end Find_Related_Subprogram_Or_Body; 25462 25463 ------------------------- 25464 -- Get_Base_Subprogram -- 25465 ------------------------- 25466 25467 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is 25468 Result : Entity_Id; 25469 25470 begin 25471 -- Follow subprogram renaming chain 25472 25473 Result := Def_Id; 25474 25475 if Is_Subprogram (Result) 25476 and then 25477 Nkind (Parent (Declaration_Node (Result))) = 25478 N_Subprogram_Renaming_Declaration 25479 and then Present (Alias (Result)) 25480 then 25481 Result := Alias (Result); 25482 end if; 25483 25484 return Result; 25485 end Get_Base_Subprogram; 25486 25487 ----------------------- 25488 -- Get_SPARK_Mode_Type -- 25489 ----------------------- 25490 25491 function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type is 25492 begin 25493 if N = Name_On then 25494 return On; 25495 elsif N = Name_Off then 25496 return Off; 25497 25498 -- Any other argument is erroneous 25499 25500 else 25501 raise Program_Error; 25502 end if; 25503 end Get_SPARK_Mode_Type; 25504 25505 -------------------------------- 25506 -- Get_SPARK_Mode_From_Pragma -- 25507 -------------------------------- 25508 25509 function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type is 25510 Args : List_Id; 25511 Mode : Node_Id; 25512 25513 begin 25514 pragma Assert (Nkind (N) = N_Pragma); 25515 Args := Pragma_Argument_Associations (N); 25516 25517 -- Extract the mode from the argument list 25518 25519 if Present (Args) then 25520 Mode := First (Pragma_Argument_Associations (N)); 25521 return Get_SPARK_Mode_Type (Chars (Get_Pragma_Arg (Mode))); 25522 25523 -- If SPARK_Mode pragma has no argument, default is ON 25524 25525 else 25526 return On; 25527 end if; 25528 end Get_SPARK_Mode_From_Pragma; 25529 25530 --------------------------- 25531 -- Has_Extra_Parentheses -- 25532 --------------------------- 25533 25534 function Has_Extra_Parentheses (Clause : Node_Id) return Boolean is 25535 Expr : Node_Id; 25536 25537 begin 25538 -- The aggregate should not have an expression list because a clause 25539 -- is always interpreted as a component association. The only way an 25540 -- expression list can sneak in is by adding extra parentheses around 25541 -- the individual clauses: 25542 25543 -- Depends (Output => Input) -- proper form 25544 -- Depends ((Output => Input)) -- extra parentheses 25545 25546 -- Since the extra parentheses are not allowed by the syntax of the 25547 -- pragma, flag them now to avoid emitting misleading errors down the 25548 -- line. 25549 25550 if Nkind (Clause) = N_Aggregate 25551 and then Present (Expressions (Clause)) 25552 then 25553 Expr := First (Expressions (Clause)); 25554 while Present (Expr) loop 25555 25556 -- A dependency clause surrounded by extra parentheses appears 25557 -- as an aggregate of component associations with an optional 25558 -- Paren_Count set. 25559 25560 if Nkind (Expr) = N_Aggregate 25561 and then Present (Component_Associations (Expr)) 25562 then 25563 Error_Msg_N 25564 ("dependency clause contains extra parentheses", Expr); 25565 25566 -- Otherwise the expression is a malformed construct 25567 25568 else 25569 Error_Msg_N ("malformed dependency clause", Expr); 25570 end if; 25571 25572 Next (Expr); 25573 end loop; 25574 25575 return True; 25576 end if; 25577 25578 return False; 25579 end Has_Extra_Parentheses; 25580 25581 ---------------- 25582 -- Initialize -- 25583 ---------------- 25584 25585 procedure Initialize is 25586 begin 25587 Externals.Init; 25588 end Initialize; 25589 25590 ----------------------------- 25591 -- Is_Config_Static_String -- 25592 ----------------------------- 25593 25594 function Is_Config_Static_String (Arg : Node_Id) return Boolean is 25595 25596 function Add_Config_Static_String (Arg : Node_Id) return Boolean; 25597 -- This is an internal recursive function that is just like the outer 25598 -- function except that it adds the string to the name buffer rather 25599 -- than placing the string in the name buffer. 25600 25601 ------------------------------ 25602 -- Add_Config_Static_String -- 25603 ------------------------------ 25604 25605 function Add_Config_Static_String (Arg : Node_Id) return Boolean is 25606 N : Node_Id; 25607 C : Char_Code; 25608 25609 begin 25610 N := Arg; 25611 25612 if Nkind (N) = N_Op_Concat then 25613 if Add_Config_Static_String (Left_Opnd (N)) then 25614 N := Right_Opnd (N); 25615 else 25616 return False; 25617 end if; 25618 end if; 25619 25620 if Nkind (N) /= N_String_Literal then 25621 Error_Msg_N ("string literal expected for pragma argument", N); 25622 return False; 25623 25624 else 25625 for J in 1 .. String_Length (Strval (N)) loop 25626 C := Get_String_Char (Strval (N), J); 25627 25628 if not In_Character_Range (C) then 25629 Error_Msg 25630 ("string literal contains invalid wide character", 25631 Sloc (N) + 1 + Source_Ptr (J)); 25632 return False; 25633 end if; 25634 25635 Add_Char_To_Name_Buffer (Get_Character (C)); 25636 end loop; 25637 end if; 25638 25639 return True; 25640 end Add_Config_Static_String; 25641 25642 -- Start of processing for Is_Config_Static_String 25643 25644 begin 25645 Name_Len := 0; 25646 25647 return Add_Config_Static_String (Arg); 25648 end Is_Config_Static_String; 25649 25650 ------------------------------- 25651 -- Is_Elaboration_SPARK_Mode -- 25652 ------------------------------- 25653 25654 function Is_Elaboration_SPARK_Mode (N : Node_Id) return Boolean is 25655 begin 25656 pragma Assert 25657 (Nkind (N) = N_Pragma 25658 and then Pragma_Name (N) = Name_SPARK_Mode 25659 and then Is_List_Member (N)); 25660 25661 -- Pragma SPARK_Mode affects the elaboration of a package body when it 25662 -- appears in the statement part of the body. 25663 25664 return 25665 Present (Parent (N)) 25666 and then Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements 25667 and then List_Containing (N) = Statements (Parent (N)) 25668 and then Present (Parent (Parent (N))) 25669 and then Nkind (Parent (Parent (N))) = N_Package_Body; 25670 end Is_Elaboration_SPARK_Mode; 25671 25672 ----------------------------------------- 25673 -- Is_Non_Significant_Pragma_Reference -- 25674 ----------------------------------------- 25675 25676 -- This function makes use of the following static table which indicates 25677 -- whether appearance of some name in a given pragma is to be considered 25678 -- as a reference for the purposes of warnings about unreferenced objects. 25679 25680 -- -1 indicates that references in any argument position are significant 25681 -- 0 indicates that appearance in any argument is not significant 25682 -- +n indicates that appearance as argument n is significant, but all 25683 -- other arguments are not significant 25684 -- 99 special processing required (e.g. for pragma Check) 25685 25686 Sig_Flags : constant array (Pragma_Id) of Int := 25687 (Pragma_AST_Entry => -1, 25688 Pragma_Abort_Defer => -1, 25689 Pragma_Abstract_State => -1, 25690 Pragma_Ada_83 => -1, 25691 Pragma_Ada_95 => -1, 25692 Pragma_Ada_05 => -1, 25693 Pragma_Ada_2005 => -1, 25694 Pragma_Ada_12 => -1, 25695 Pragma_Ada_2012 => -1, 25696 Pragma_All_Calls_Remote => -1, 25697 Pragma_Allow_Integer_Address => 0, 25698 Pragma_Annotate => -1, 25699 Pragma_Assert => -1, 25700 Pragma_Assert_And_Cut => -1, 25701 Pragma_Assertion_Policy => 0, 25702 Pragma_Assume => -1, 25703 Pragma_Assume_No_Invalid_Values => 0, 25704 Pragma_Async_Readers => 0, 25705 Pragma_Async_Writers => 0, 25706 Pragma_Asynchronous => -1, 25707 Pragma_Atomic => 0, 25708 Pragma_Atomic_Components => 0, 25709 Pragma_Attach_Handler => -1, 25710 Pragma_Attribute_Definition => +3, 25711 Pragma_Check => 99, 25712 Pragma_Check_Float_Overflow => 0, 25713 Pragma_Check_Name => 0, 25714 Pragma_Check_Policy => 0, 25715 Pragma_CIL_Constructor => -1, 25716 Pragma_CPP_Class => 0, 25717 Pragma_CPP_Constructor => 0, 25718 Pragma_CPP_Virtual => 0, 25719 Pragma_CPP_Vtable => 0, 25720 Pragma_CPU => -1, 25721 Pragma_C_Pass_By_Copy => 0, 25722 Pragma_Comment => 0, 25723 Pragma_Common_Object => -1, 25724 Pragma_Compile_Time_Error => -1, 25725 Pragma_Compile_Time_Warning => -1, 25726 Pragma_Compiler_Unit => 0, 25727 Pragma_Compiler_Unit_Warning => 0, 25728 Pragma_Complete_Representation => 0, 25729 Pragma_Complex_Representation => 0, 25730 Pragma_Component_Alignment => -1, 25731 Pragma_Contract_Cases => -1, 25732 Pragma_Controlled => 0, 25733 Pragma_Convention => 0, 25734 Pragma_Convention_Identifier => 0, 25735 Pragma_Debug => -1, 25736 Pragma_Debug_Policy => 0, 25737 Pragma_Detect_Blocking => -1, 25738 Pragma_Default_Storage_Pool => -1, 25739 Pragma_Depends => -1, 25740 Pragma_Disable_Atomic_Synchronization => -1, 25741 Pragma_Discard_Names => 0, 25742 Pragma_Dispatching_Domain => -1, 25743 Pragma_Effective_Reads => 0, 25744 Pragma_Effective_Writes => 0, 25745 Pragma_Elaborate => -1, 25746 Pragma_Elaborate_All => -1, 25747 Pragma_Elaborate_Body => -1, 25748 Pragma_Elaboration_Checks => -1, 25749 Pragma_Eliminate => -1, 25750 Pragma_Enable_Atomic_Synchronization => -1, 25751 Pragma_Export => -1, 25752 Pragma_Export_Exception => -1, 25753 Pragma_Export_Function => -1, 25754 Pragma_Export_Object => -1, 25755 Pragma_Export_Procedure => -1, 25756 Pragma_Export_Value => -1, 25757 Pragma_Export_Valued_Procedure => -1, 25758 Pragma_Extend_System => -1, 25759 Pragma_Extensions_Allowed => -1, 25760 Pragma_External => -1, 25761 Pragma_Favor_Top_Level => -1, 25762 Pragma_External_Name_Casing => -1, 25763 Pragma_Fast_Math => -1, 25764 Pragma_Finalize_Storage_Only => 0, 25765 Pragma_Float_Representation => 0, 25766 Pragma_Global => -1, 25767 Pragma_Ident => -1, 25768 Pragma_Implementation_Defined => -1, 25769 Pragma_Implemented => -1, 25770 Pragma_Implicit_Packing => 0, 25771 Pragma_Import => +2, 25772 Pragma_Import_Exception => 0, 25773 Pragma_Import_Function => 0, 25774 Pragma_Import_Object => 0, 25775 Pragma_Import_Procedure => 0, 25776 Pragma_Import_Valued_Procedure => 0, 25777 Pragma_Independent => 0, 25778 Pragma_Independent_Components => 0, 25779 Pragma_Initial_Condition => -1, 25780 Pragma_Initialize_Scalars => -1, 25781 Pragma_Initializes => -1, 25782 Pragma_Inline => 0, 25783 Pragma_Inline_Always => 0, 25784 Pragma_Inline_Generic => 0, 25785 Pragma_Inspection_Point => -1, 25786 Pragma_Interface => +2, 25787 Pragma_Interface_Name => +2, 25788 Pragma_Interrupt_Handler => -1, 25789 Pragma_Interrupt_Priority => -1, 25790 Pragma_Interrupt_State => -1, 25791 Pragma_Invariant => -1, 25792 Pragma_Java_Constructor => -1, 25793 Pragma_Java_Interface => -1, 25794 Pragma_Keep_Names => 0, 25795 Pragma_License => -1, 25796 Pragma_Link_With => -1, 25797 Pragma_Linker_Alias => -1, 25798 Pragma_Linker_Constructor => -1, 25799 Pragma_Linker_Destructor => -1, 25800 Pragma_Linker_Options => -1, 25801 Pragma_Linker_Section => -1, 25802 Pragma_List => -1, 25803 Pragma_Lock_Free => -1, 25804 Pragma_Locking_Policy => -1, 25805 Pragma_Long_Float => -1, 25806 Pragma_Loop_Invariant => -1, 25807 Pragma_Loop_Optimize => -1, 25808 Pragma_Loop_Variant => -1, 25809 Pragma_Machine_Attribute => -1, 25810 Pragma_Main => -1, 25811 Pragma_Main_Storage => -1, 25812 Pragma_Memory_Size => -1, 25813 Pragma_No_Return => 0, 25814 Pragma_No_Body => 0, 25815 Pragma_No_Inline => 0, 25816 Pragma_No_Run_Time => -1, 25817 Pragma_No_Strict_Aliasing => -1, 25818 Pragma_Normalize_Scalars => -1, 25819 Pragma_Obsolescent => 0, 25820 Pragma_Optimize => -1, 25821 Pragma_Optimize_Alignment => -1, 25822 Pragma_Overflow_Mode => 0, 25823 Pragma_Overriding_Renamings => 0, 25824 Pragma_Ordered => 0, 25825 Pragma_Pack => 0, 25826 Pragma_Page => -1, 25827 Pragma_Part_Of => -1, 25828 Pragma_Partition_Elaboration_Policy => -1, 25829 Pragma_Passive => -1, 25830 Pragma_Persistent_BSS => 0, 25831 Pragma_Polling => -1, 25832 Pragma_Post => -1, 25833 Pragma_Postcondition => -1, 25834 Pragma_Post_Class => -1, 25835 Pragma_Pre => -1, 25836 Pragma_Precondition => -1, 25837 Pragma_Predicate => -1, 25838 Pragma_Preelaborable_Initialization => -1, 25839 Pragma_Preelaborate => -1, 25840 Pragma_Preelaborate_05 => -1, 25841 Pragma_Pre_Class => -1, 25842 Pragma_Priority => -1, 25843 Pragma_Priority_Specific_Dispatching => -1, 25844 Pragma_Profile => 0, 25845 Pragma_Profile_Warnings => 0, 25846 Pragma_Propagate_Exceptions => -1, 25847 Pragma_Provide_Shift_Operators => -1, 25848 Pragma_Psect_Object => -1, 25849 Pragma_Pure => -1, 25850 Pragma_Pure_05 => -1, 25851 Pragma_Pure_12 => -1, 25852 Pragma_Pure_Function => -1, 25853 Pragma_Queuing_Policy => -1, 25854 Pragma_Rational => -1, 25855 Pragma_Ravenscar => -1, 25856 Pragma_Refined_Depends => -1, 25857 Pragma_Refined_Global => -1, 25858 Pragma_Refined_Post => -1, 25859 Pragma_Refined_State => -1, 25860 Pragma_Relative_Deadline => -1, 25861 Pragma_Remote_Access_Type => -1, 25862 Pragma_Remote_Call_Interface => -1, 25863 Pragma_Remote_Types => -1, 25864 Pragma_Restricted_Run_Time => -1, 25865 Pragma_Restriction_Warnings => -1, 25866 Pragma_Restrictions => -1, 25867 Pragma_Reviewable => -1, 25868 Pragma_Short_Circuit_And_Or => -1, 25869 Pragma_Share_Generic => -1, 25870 Pragma_Shared => -1, 25871 Pragma_Shared_Passive => -1, 25872 Pragma_Short_Descriptors => 0, 25873 Pragma_Simple_Storage_Pool_Type => 0, 25874 Pragma_Source_File_Name => -1, 25875 Pragma_Source_File_Name_Project => -1, 25876 Pragma_Source_Reference => -1, 25877 Pragma_SPARK_Mode => 0, 25878 Pragma_Storage_Size => -1, 25879 Pragma_Storage_Unit => -1, 25880 Pragma_Static_Elaboration_Desired => -1, 25881 Pragma_Stream_Convert => -1, 25882 Pragma_Style_Checks => -1, 25883 Pragma_Subtitle => -1, 25884 Pragma_Suppress => 0, 25885 Pragma_Suppress_Exception_Locations => 0, 25886 Pragma_Suppress_All => -1, 25887 Pragma_Suppress_Debug_Info => 0, 25888 Pragma_Suppress_Initialization => 0, 25889 Pragma_System_Name => -1, 25890 Pragma_Task_Dispatching_Policy => -1, 25891 Pragma_Task_Info => -1, 25892 Pragma_Task_Name => -1, 25893 Pragma_Task_Storage => 0, 25894 Pragma_Test_Case => -1, 25895 Pragma_Thread_Local_Storage => 0, 25896 Pragma_Time_Slice => -1, 25897 Pragma_Title => -1, 25898 Pragma_Type_Invariant => -1, 25899 Pragma_Type_Invariant_Class => -1, 25900 Pragma_Unchecked_Union => 0, 25901 Pragma_Unimplemented_Unit => -1, 25902 Pragma_Universal_Aliasing => -1, 25903 Pragma_Universal_Data => -1, 25904 Pragma_Unmodified => -1, 25905 Pragma_Unreferenced => -1, 25906 Pragma_Unreferenced_Objects => -1, 25907 Pragma_Unreserve_All_Interrupts => -1, 25908 Pragma_Unsuppress => 0, 25909 Pragma_Use_VADS_Size => -1, 25910 Pragma_Validity_Checks => -1, 25911 Pragma_Volatile => 0, 25912 Pragma_Volatile_Components => 0, 25913 Pragma_Warning_As_Error => -1, 25914 Pragma_Warnings => -1, 25915 Pragma_Weak_External => -1, 25916 Pragma_Wide_Character_Encoding => 0, 25917 Unknown_Pragma => 0); 25918 25919 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is 25920 Id : Pragma_Id; 25921 P : Node_Id; 25922 C : Int; 25923 A : Node_Id; 25924 25925 begin 25926 P := Parent (N); 25927 25928 if Nkind (P) /= N_Pragma_Argument_Association then 25929 return False; 25930 25931 else 25932 Id := Get_Pragma_Id (Parent (P)); 25933 C := Sig_Flags (Id); 25934 25935 case C is 25936 when -1 => 25937 return False; 25938 25939 when 0 => 25940 return True; 25941 25942 when 99 => 25943 case Id is 25944 25945 -- For pragma Check, the first argument is not significant, 25946 -- the second and the third (if present) arguments are 25947 -- significant. 25948 25949 when Pragma_Check => 25950 return 25951 P = First (Pragma_Argument_Associations (Parent (P))); 25952 25953 when others => 25954 raise Program_Error; 25955 end case; 25956 25957 when others => 25958 A := First (Pragma_Argument_Associations (Parent (P))); 25959 for J in 1 .. C - 1 loop 25960 if No (A) then 25961 return False; 25962 end if; 25963 25964 Next (A); 25965 end loop; 25966 25967 return A = P; -- is this wrong way round ??? 25968 end case; 25969 end if; 25970 end Is_Non_Significant_Pragma_Reference; 25971 25972 ------------------------------ 25973 -- Is_Pragma_String_Literal -- 25974 ------------------------------ 25975 25976 -- This function returns true if the corresponding pragma argument is a 25977 -- static string expression. These are the only cases in which string 25978 -- literals can appear as pragma arguments. We also allow a string literal 25979 -- as the first argument to pragma Assert (although it will of course 25980 -- always generate a type error). 25981 25982 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is 25983 Pragn : constant Node_Id := Parent (Par); 25984 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); 25985 Pname : constant Name_Id := Pragma_Name (Pragn); 25986 Argn : Natural; 25987 N : Node_Id; 25988 25989 begin 25990 Argn := 1; 25991 N := First (Assoc); 25992 loop 25993 exit when N = Par; 25994 Argn := Argn + 1; 25995 Next (N); 25996 end loop; 25997 25998 if Pname = Name_Assert then 25999 return True; 26000 26001 elsif Pname = Name_Export then 26002 return Argn > 2; 26003 26004 elsif Pname = Name_Ident then 26005 return Argn = 1; 26006 26007 elsif Pname = Name_Import then 26008 return Argn > 2; 26009 26010 elsif Pname = Name_Interface_Name then 26011 return Argn > 1; 26012 26013 elsif Pname = Name_Linker_Alias then 26014 return Argn = 2; 26015 26016 elsif Pname = Name_Linker_Section then 26017 return Argn = 2; 26018 26019 elsif Pname = Name_Machine_Attribute then 26020 return Argn = 2; 26021 26022 elsif Pname = Name_Source_File_Name then 26023 return True; 26024 26025 elsif Pname = Name_Source_Reference then 26026 return Argn = 2; 26027 26028 elsif Pname = Name_Title then 26029 return True; 26030 26031 elsif Pname = Name_Subtitle then 26032 return True; 26033 26034 else 26035 return False; 26036 end if; 26037 end Is_Pragma_String_Literal; 26038 26039 --------------------------- 26040 -- Is_Private_SPARK_Mode -- 26041 --------------------------- 26042 26043 function Is_Private_SPARK_Mode (N : Node_Id) return Boolean is 26044 begin 26045 pragma Assert 26046 (Nkind (N) = N_Pragma 26047 and then Pragma_Name (N) = Name_SPARK_Mode 26048 and then Is_List_Member (N)); 26049 26050 -- For pragma SPARK_Mode to be private, it has to appear in the private 26051 -- declarations of a package. 26052 26053 return 26054 Present (Parent (N)) 26055 and then Nkind (Parent (N)) = N_Package_Specification 26056 and then List_Containing (N) = Private_Declarations (Parent (N)); 26057 end Is_Private_SPARK_Mode; 26058 26059 ------------------------------------- 26060 -- Is_Unconstrained_Or_Tagged_Item -- 26061 ------------------------------------- 26062 26063 function Is_Unconstrained_Or_Tagged_Item 26064 (Item : Entity_Id) return Boolean 26065 is 26066 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean; 26067 -- Determine whether record type Typ has at least one unconstrained 26068 -- component. 26069 26070 --------------------------------- 26071 -- Has_Unconstrained_Component -- 26072 --------------------------------- 26073 26074 function Has_Unconstrained_Component (Typ : Entity_Id) return Boolean is 26075 Comp : Entity_Id; 26076 26077 begin 26078 Comp := First_Component (Typ); 26079 while Present (Comp) loop 26080 if Is_Unconstrained_Or_Tagged_Item (Comp) then 26081 return True; 26082 end if; 26083 26084 Next_Component (Comp); 26085 end loop; 26086 26087 return False; 26088 end Has_Unconstrained_Component; 26089 26090 -- Local variables 26091 26092 Typ : constant Entity_Id := Etype (Item); 26093 26094 -- Start of processing for Is_Unconstrained_Or_Tagged_Item 26095 26096 begin 26097 if Is_Tagged_Type (Typ) then 26098 return True; 26099 26100 elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) then 26101 return True; 26102 26103 elsif Is_Record_Type (Typ) then 26104 if Has_Discriminants (Typ) and then not Is_Constrained (Typ) then 26105 return True; 26106 else 26107 return Has_Unconstrained_Component (Typ); 26108 end if; 26109 26110 else 26111 return False; 26112 end if; 26113 end Is_Unconstrained_Or_Tagged_Item; 26114 26115 ----------------------------- 26116 -- Is_Valid_Assertion_Kind -- 26117 ----------------------------- 26118 26119 function Is_Valid_Assertion_Kind (Nam : Name_Id) return Boolean is 26120 begin 26121 case Nam is 26122 when 26123 -- RM defined 26124 26125 Name_Assert | 26126 Name_Static_Predicate | 26127 Name_Dynamic_Predicate | 26128 Name_Pre | 26129 Name_uPre | 26130 Name_Post | 26131 Name_uPost | 26132 Name_Type_Invariant | 26133 Name_uType_Invariant | 26134 26135 -- Impl defined 26136 26137 Name_Assert_And_Cut | 26138 Name_Assume | 26139 Name_Contract_Cases | 26140 Name_Debug | 26141 Name_Initial_Condition | 26142 Name_Invariant | 26143 Name_uInvariant | 26144 Name_Loop_Invariant | 26145 Name_Loop_Variant | 26146 Name_Postcondition | 26147 Name_Precondition | 26148 Name_Predicate | 26149 Name_Refined_Post | 26150 Name_Statement_Assertions => return True; 26151 26152 when others => return False; 26153 end case; 26154 end Is_Valid_Assertion_Kind; 26155 26156 ----------------------------------------- 26157 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl -- 26158 ----------------------------------------- 26159 26160 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is 26161 Aspects : constant List_Id := New_List; 26162 Loc : constant Source_Ptr := Sloc (Decl); 26163 Or_Decl : constant Node_Id := Original_Node (Decl); 26164 26165 Original_Aspects : List_Id; 26166 -- To capture global references, a copy of the created aspects must be 26167 -- inserted in the original tree. 26168 26169 Prag : Node_Id; 26170 Prag_Arg_Ass : Node_Id; 26171 Prag_Id : Pragma_Id; 26172 26173 begin 26174 -- Check for any PPC pragmas that appear within Decl 26175 26176 Prag := Next (Decl); 26177 while Nkind (Prag) = N_Pragma loop 26178 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag))); 26179 26180 case Prag_Id is 26181 when Pragma_Postcondition | Pragma_Precondition => 26182 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag)); 26183 26184 -- Make an aspect from any PPC pragma 26185 26186 Append_To (Aspects, 26187 Make_Aspect_Specification (Loc, 26188 Identifier => 26189 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))), 26190 Expression => 26191 Copy_Separate_Tree (Expression (Prag_Arg_Ass)))); 26192 26193 -- Generate the analysis information in the pragma expression 26194 -- and then set the pragma node analyzed to avoid any further 26195 -- analysis. 26196 26197 Analyze (Expression (Prag_Arg_Ass)); 26198 Set_Analyzed (Prag, True); 26199 26200 when others => null; 26201 end case; 26202 26203 Next (Prag); 26204 end loop; 26205 26206 -- Set all new aspects into the generic declaration node 26207 26208 if Is_Non_Empty_List (Aspects) then 26209 26210 -- Create the list of aspects to be inserted in the original tree 26211 26212 Original_Aspects := Copy_Separate_List (Aspects); 26213 26214 -- Check if Decl already has aspects 26215 26216 -- Attach the new lists of aspects to both the generic copy and the 26217 -- original tree. 26218 26219 if Has_Aspects (Decl) then 26220 Append_List (Aspects, Aspect_Specifications (Decl)); 26221 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl)); 26222 26223 else 26224 Set_Parent (Aspects, Decl); 26225 Set_Aspect_Specifications (Decl, Aspects); 26226 Set_Parent (Original_Aspects, Or_Decl); 26227 Set_Aspect_Specifications (Or_Decl, Original_Aspects); 26228 end if; 26229 end if; 26230 end Make_Aspect_For_PPC_In_Gen_Sub_Decl; 26231 26232 ------------------------- 26233 -- Preanalyze_CTC_Args -- 26234 ------------------------- 26235 26236 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is 26237 begin 26238 -- Preanalyze the boolean expressions, we treat these as spec 26239 -- expressions (i.e. similar to a default expression). 26240 26241 if Present (Arg_Req) then 26242 Preanalyze_Assert_Expression 26243 (Get_Pragma_Arg (Arg_Req), Standard_Boolean); 26244 26245 -- In ASIS mode, for a pragma generated from a source aspect, also 26246 -- analyze the original aspect expression. 26247 26248 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then 26249 Preanalyze_Assert_Expression 26250 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean); 26251 end if; 26252 end if; 26253 26254 if Present (Arg_Ens) then 26255 Preanalyze_Assert_Expression 26256 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean); 26257 26258 -- In ASIS mode, for a pragma generated from a source aspect, also 26259 -- analyze the original aspect expression. 26260 26261 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then 26262 Preanalyze_Assert_Expression 26263 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean); 26264 end if; 26265 end if; 26266 end Preanalyze_CTC_Args; 26267 26268 -------------------------------------- 26269 -- Process_Compilation_Unit_Pragmas -- 26270 -------------------------------------- 26271 26272 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is 26273 begin 26274 -- A special check for pragma Suppress_All, a very strange DEC pragma, 26275 -- strange because it comes at the end of the unit. Rational has the 26276 -- same name for a pragma, but treats it as a program unit pragma, In 26277 -- GNAT we just decide to allow it anywhere at all. If it appeared then 26278 -- the flag Has_Pragma_Suppress_All was set on the compilation unit 26279 -- node, and we insert a pragma Suppress (All_Checks) at the start of 26280 -- the context clause to ensure the correct processing. 26281 26282 if Has_Pragma_Suppress_All (N) then 26283 Prepend_To (Context_Items (N), 26284 Make_Pragma (Sloc (N), 26285 Chars => Name_Suppress, 26286 Pragma_Argument_Associations => New_List ( 26287 Make_Pragma_Argument_Association (Sloc (N), 26288 Expression => Make_Identifier (Sloc (N), Name_All_Checks))))); 26289 end if; 26290 26291 -- Nothing else to do at the current time 26292 26293 end Process_Compilation_Unit_Pragmas; 26294 26295 ------------------------------------ 26296 -- Record_Possible_Body_Reference -- 26297 ------------------------------------ 26298 26299 procedure Record_Possible_Body_Reference 26300 (State_Id : Entity_Id; 26301 Ref : Node_Id) 26302 is 26303 Context : Node_Id; 26304 Spec_Id : Entity_Id; 26305 26306 begin 26307 -- Ensure that we are dealing with a reference to a state 26308 26309 pragma Assert (Ekind (State_Id) = E_Abstract_State); 26310 26311 -- Climb the tree starting from the reference looking for a package body 26312 -- whose spec declares the referenced state. This criteria automatically 26313 -- excludes references in package specs which are legal. Note that it is 26314 -- not wise to emit an error now as the package body may lack pragma 26315 -- Refined_State or the referenced state may not be mentioned in the 26316 -- refinement. This approach avoids the generation of misleading errors. 26317 26318 Context := Ref; 26319 while Present (Context) loop 26320 if Nkind (Context) = N_Package_Body then 26321 Spec_Id := Corresponding_Spec (Context); 26322 26323 if Present (Abstract_States (Spec_Id)) 26324 and then Contains (Abstract_States (Spec_Id), State_Id) 26325 then 26326 if No (Body_References (State_Id)) then 26327 Set_Body_References (State_Id, New_Elmt_List); 26328 end if; 26329 26330 Append_Elmt (Ref, Body_References (State_Id)); 26331 exit; 26332 end if; 26333 end if; 26334 26335 Context := Parent (Context); 26336 end loop; 26337 end Record_Possible_Body_Reference; 26338 26339 ------------------------------ 26340 -- Relocate_Pragmas_To_Body -- 26341 ------------------------------ 26342 26343 procedure Relocate_Pragmas_To_Body 26344 (Subp_Body : Node_Id; 26345 Target_Body : Node_Id := Empty) 26346 is 26347 procedure Relocate_Pragma (Prag : Node_Id); 26348 -- Remove a single pragma from its current list and add it to the 26349 -- declarations of the proper body (either Subp_Body or Target_Body). 26350 26351 --------------------- 26352 -- Relocate_Pragma -- 26353 --------------------- 26354 26355 procedure Relocate_Pragma (Prag : Node_Id) is 26356 Decls : List_Id; 26357 Target : Node_Id; 26358 26359 begin 26360 -- When subprogram stubs or expression functions are involves, the 26361 -- destination declaration list belongs to the proper body. 26362 26363 if Present (Target_Body) then 26364 Target := Target_Body; 26365 else 26366 Target := Subp_Body; 26367 end if; 26368 26369 Decls := Declarations (Target); 26370 26371 if No (Decls) then 26372 Decls := New_List; 26373 Set_Declarations (Target, Decls); 26374 end if; 26375 26376 -- Unhook the pragma from its current list 26377 26378 Remove (Prag); 26379 Prepend (Prag, Decls); 26380 end Relocate_Pragma; 26381 26382 -- Local variables 26383 26384 Body_Id : constant Entity_Id := 26385 Defining_Unit_Name (Specification (Subp_Body)); 26386 Next_Stmt : Node_Id; 26387 Stmt : Node_Id; 26388 26389 -- Start of processing for Relocate_Pragmas_To_Body 26390 26391 begin 26392 -- Do not process a body that comes from a separate unit as no construct 26393 -- can possibly follow it. 26394 26395 if not Is_List_Member (Subp_Body) then 26396 return; 26397 26398 -- Do not relocate pragmas that follow a stub if the stub does not have 26399 -- a proper body. 26400 26401 elsif Nkind (Subp_Body) = N_Subprogram_Body_Stub 26402 and then No (Target_Body) 26403 then 26404 return; 26405 26406 -- Do not process internally generated routine _Postconditions 26407 26408 elsif Ekind (Body_Id) = E_Procedure 26409 and then Chars (Body_Id) = Name_uPostconditions 26410 then 26411 return; 26412 end if; 26413 26414 -- Look at what is following the body. We are interested in certain kind 26415 -- of pragmas (either from source or byproducts of expansion) that can 26416 -- apply to a body [stub]. 26417 26418 Stmt := Next (Subp_Body); 26419 while Present (Stmt) loop 26420 26421 -- Preserve the following statement for iteration purposes due to a 26422 -- possible relocation of a pragma. 26423 26424 Next_Stmt := Next (Stmt); 26425 26426 -- Move a candidate pragma following the body to the declarations of 26427 -- the body. 26428 26429 if Nkind (Stmt) = N_Pragma 26430 and then Pragma_On_Body_Or_Stub_OK (Get_Pragma_Id (Stmt)) 26431 then 26432 Relocate_Pragma (Stmt); 26433 26434 -- Skip internally generated code 26435 26436 elsif not Comes_From_Source (Stmt) then 26437 null; 26438 26439 -- No candidate pragmas are available for relocation 26440 26441 else 26442 exit; 26443 end if; 26444 26445 Stmt := Next_Stmt; 26446 end loop; 26447 end Relocate_Pragmas_To_Body; 26448 26449 ------------------- 26450 -- Resolve_State -- 26451 ------------------- 26452 26453 procedure Resolve_State (N : Node_Id) is 26454 Func : Entity_Id; 26455 State : Entity_Id; 26456 26457 begin 26458 if Is_Entity_Name (N) and then Present (Entity (N)) then 26459 Func := Entity (N); 26460 26461 -- Handle overloading of state names by functions. Traverse the 26462 -- homonym chain looking for an abstract state. 26463 26464 if Ekind (Func) = E_Function and then Has_Homonym (Func) then 26465 State := Homonym (Func); 26466 while Present (State) loop 26467 26468 -- Resolve the overloading by setting the proper entity of the 26469 -- reference to that of the state. 26470 26471 if Ekind (State) = E_Abstract_State then 26472 Set_Etype (N, Standard_Void_Type); 26473 Set_Entity (N, State); 26474 Set_Associated_Node (N, State); 26475 return; 26476 end if; 26477 26478 State := Homonym (State); 26479 end loop; 26480 26481 -- A function can never act as a state. If the homonym chain does 26482 -- not contain a corresponding state, then something went wrong in 26483 -- the overloading mechanism. 26484 26485 raise Program_Error; 26486 end if; 26487 end if; 26488 end Resolve_State; 26489 26490 ---------------------------- 26491 -- Rewrite_Assertion_Kind -- 26492 ---------------------------- 26493 26494 procedure Rewrite_Assertion_Kind (N : Node_Id) is 26495 Nam : Name_Id; 26496 26497 begin 26498 if Nkind (N) = N_Attribute_Reference 26499 and then Attribute_Name (N) = Name_Class 26500 and then Nkind (Prefix (N)) = N_Identifier 26501 then 26502 case Chars (Prefix (N)) is 26503 when Name_Pre => 26504 Nam := Name_uPre; 26505 when Name_Post => 26506 Nam := Name_uPost; 26507 when Name_Type_Invariant => 26508 Nam := Name_uType_Invariant; 26509 when Name_Invariant => 26510 Nam := Name_uInvariant; 26511 when others => 26512 return; 26513 end case; 26514 26515 Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam)); 26516 end if; 26517 end Rewrite_Assertion_Kind; 26518 26519 -------- 26520 -- rv -- 26521 -------- 26522 26523 procedure rv is 26524 begin 26525 null; 26526 end rv; 26527 26528 -------------------------------- 26529 -- Set_Encoded_Interface_Name -- 26530 -------------------------------- 26531 26532 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is 26533 Str : constant String_Id := Strval (S); 26534 Len : constant Int := String_Length (Str); 26535 CC : Char_Code; 26536 C : Character; 26537 J : Int; 26538 26539 Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; 26540 26541 procedure Encode; 26542 -- Stores encoded value of character code CC. The encoding we use an 26543 -- underscore followed by four lower case hex digits. 26544 26545 ------------ 26546 -- Encode -- 26547 ------------ 26548 26549 procedure Encode is 26550 begin 26551 Store_String_Char (Get_Char_Code ('_')); 26552 Store_String_Char 26553 (Get_Char_Code (Hex (Integer (CC / 2 ** 12)))); 26554 Store_String_Char 26555 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#)))); 26556 Store_String_Char 26557 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#)))); 26558 Store_String_Char 26559 (Get_Char_Code (Hex (Integer (CC and 16#0F#)))); 26560 end Encode; 26561 26562 -- Start of processing for Set_Encoded_Interface_Name 26563 26564 begin 26565 -- If first character is asterisk, this is a link name, and we leave it 26566 -- completely unmodified. We also ignore null strings (the latter case 26567 -- happens only in error cases) and no encoding should occur for Java or 26568 -- AAMP interface names. 26569 26570 if Len = 0 26571 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') 26572 or else VM_Target /= No_VM 26573 or else AAMP_On_Target 26574 then 26575 Set_Interface_Name (E, S); 26576 26577 else 26578 J := 1; 26579 loop 26580 CC := Get_String_Char (Str, J); 26581 26582 exit when not In_Character_Range (CC); 26583 26584 C := Get_Character (CC); 26585 26586 exit when C /= '_' and then C /= '$' 26587 and then C not in '0' .. '9' 26588 and then C not in 'a' .. 'z' 26589 and then C not in 'A' .. 'Z'; 26590 26591 if J = Len then 26592 Set_Interface_Name (E, S); 26593 return; 26594 26595 else 26596 J := J + 1; 26597 end if; 26598 end loop; 26599 26600 -- Here we need to encode. The encoding we use as follows: 26601 -- three underscores + four hex digits (lower case) 26602 26603 Start_String; 26604 26605 for J in 1 .. String_Length (Str) loop 26606 CC := Get_String_Char (Str, J); 26607 26608 if not In_Character_Range (CC) then 26609 Encode; 26610 else 26611 C := Get_Character (CC); 26612 26613 if C = '_' or else C = '$' 26614 or else C in '0' .. '9' 26615 or else C in 'a' .. 'z' 26616 or else C in 'A' .. 'Z' 26617 then 26618 Store_String_Char (CC); 26619 else 26620 Encode; 26621 end if; 26622 end if; 26623 end loop; 26624 26625 Set_Interface_Name (E, 26626 Make_String_Literal (Sloc (S), 26627 Strval => End_String)); 26628 end if; 26629 end Set_Encoded_Interface_Name; 26630 26631 ------------------- 26632 -- Set_Unit_Name -- 26633 ------------------- 26634 26635 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is 26636 Pref : Node_Id; 26637 Scop : Entity_Id; 26638 26639 begin 26640 if Nkind (N) = N_Identifier 26641 and then Nkind (With_Item) = N_Identifier 26642 then 26643 Set_Entity (N, Entity (With_Item)); 26644 26645 elsif Nkind (N) = N_Selected_Component then 26646 Change_Selected_Component_To_Expanded_Name (N); 26647 Set_Entity (N, Entity (With_Item)); 26648 Set_Entity (Selector_Name (N), Entity (N)); 26649 26650 Pref := Prefix (N); 26651 Scop := Scope (Entity (N)); 26652 while Nkind (Pref) = N_Selected_Component loop 26653 Change_Selected_Component_To_Expanded_Name (Pref); 26654 Set_Entity (Selector_Name (Pref), Scop); 26655 Set_Entity (Pref, Scop); 26656 Pref := Prefix (Pref); 26657 Scop := Scope (Scop); 26658 end loop; 26659 26660 Set_Entity (Pref, Scop); 26661 end if; 26662 end Set_Unit_Name; 26663 26664end Sem_Prag; 26665