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 Opt; use Opt; 51with Output; use Output; 52with Par_SCO; use Par_SCO; 53with Restrict; use Restrict; 54with Rident; use Rident; 55with Rtsfind; use Rtsfind; 56with Sem; use Sem; 57with Sem_Aux; use Sem_Aux; 58with Sem_Ch3; use Sem_Ch3; 59with Sem_Ch6; use Sem_Ch6; 60with Sem_Ch8; use Sem_Ch8; 61with Sem_Ch12; use Sem_Ch12; 62with Sem_Ch13; use Sem_Ch13; 63with Sem_Disp; use Sem_Disp; 64with Sem_Dist; use Sem_Dist; 65with Sem_Elim; use Sem_Elim; 66with Sem_Eval; use Sem_Eval; 67with Sem_Intr; use Sem_Intr; 68with Sem_Mech; use Sem_Mech; 69with Sem_Res; use Sem_Res; 70with Sem_Type; use Sem_Type; 71with Sem_Util; use Sem_Util; 72with Sem_VFpt; use Sem_VFpt; 73with Sem_Warn; use Sem_Warn; 74with Stand; use Stand; 75with Sinfo; use Sinfo; 76with Sinfo.CN; use Sinfo.CN; 77with Sinput; use Sinput; 78with Snames; use Snames; 79with Stringt; use Stringt; 80with Stylesw; use Stylesw; 81with Table; 82with Targparm; use Targparm; 83with Tbuild; use Tbuild; 84with Ttypes; 85with Uintp; use Uintp; 86with Uname; use Uname; 87with Urealp; use Urealp; 88with Validsw; use Validsw; 89with Warnsw; use Warnsw; 90 91package body Sem_Prag is 92 93 ---------------------------------------------- 94 -- Common Handling of Import-Export Pragmas -- 95 ---------------------------------------------- 96 97 -- In the following section, a number of Import_xxx and Export_xxx pragmas 98 -- are defined by GNAT. These are compatible with the DEC pragmas of the 99 -- same name, and all have the following common form and processing: 100 101 -- pragma Export_xxx 102 -- [Internal =>] LOCAL_NAME 103 -- [, [External =>] EXTERNAL_SYMBOL] 104 -- [, other optional parameters ]); 105 106 -- pragma Import_xxx 107 -- [Internal =>] LOCAL_NAME 108 -- [, [External =>] EXTERNAL_SYMBOL] 109 -- [, other optional parameters ]); 110 111 -- EXTERNAL_SYMBOL ::= 112 -- IDENTIFIER 113 -- | static_string_EXPRESSION 114 115 -- The internal LOCAL_NAME designates the entity that is imported or 116 -- exported, and must refer to an entity in the current declarative 117 -- part (as required by the rules for LOCAL_NAME). 118 119 -- The external linker name is designated by the External parameter if 120 -- given, or the Internal parameter if not (if there is no External 121 -- parameter, the External parameter is a copy of the Internal name). 122 123 -- If the External parameter is given as a string, then this string is 124 -- treated as an external name (exactly as though it had been given as an 125 -- External_Name parameter for a normal Import pragma). 126 127 -- If the External parameter is given as an identifier (or there is no 128 -- External parameter, so that the Internal identifier is used), then 129 -- the external name is the characters of the identifier, translated 130 -- to all upper case letters for OpenVMS versions of GNAT, and to all 131 -- lower case letters for all other versions 132 133 -- Note: the external name specified or implied by any of these special 134 -- Import_xxx or Export_xxx pragmas override an external or link name 135 -- specified in a previous Import or Export pragma. 136 137 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of 138 -- named notation, following the standard rules for subprogram calls, i.e. 139 -- parameters can be given in any order if named notation is used, and 140 -- positional and named notation can be mixed, subject to the rule that all 141 -- positional parameters must appear first. 142 143 -- Note: All these pragmas are implemented exactly following the DEC design 144 -- and implementation and are intended to be fully compatible with the use 145 -- of these pragmas in the DEC Ada compiler. 146 147 -------------------------------------------- 148 -- Checking for Duplicated External Names -- 149 -------------------------------------------- 150 151 -- It is suspicious if two separate Export pragmas use the same external 152 -- name. The following table is used to diagnose this situation so that 153 -- an appropriate warning can be issued. 154 155 -- The Node_Id stored is for the N_String_Literal node created to hold 156 -- the value of the external name. The Sloc of this node is used to 157 -- cross-reference the location of the duplication. 158 159 package Externals is new Table.Table ( 160 Table_Component_Type => Node_Id, 161 Table_Index_Type => Int, 162 Table_Low_Bound => 0, 163 Table_Initial => 100, 164 Table_Increment => 100, 165 Table_Name => "Name_Externals"); 166 167 ------------------------------------- 168 -- Local Subprograms and Variables -- 169 ------------------------------------- 170 171 function Adjust_External_Name_Case (N : Node_Id) return Node_Id; 172 -- This routine is used for possible casing adjustment of an explicit 173 -- external name supplied as a string literal (the node N), according to 174 -- the casing requirement of Opt.External_Name_Casing. If this is set to 175 -- As_Is, then the string literal is returned unchanged, but if it is set 176 -- to Uppercase or Lowercase, then a new string literal with appropriate 177 -- casing is constructed. 178 179 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; 180 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the 181 -- original one, following the renaming chain) is returned. Otherwise the 182 -- entity is returned unchanged. Should be in Einfo??? 183 184 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id); 185 -- Preanalyze the boolean expressions in the Requires and Ensures arguments 186 -- of a Contract_Case or Test_Case pragma if present (possibly Empty). We 187 -- treat these as spec expressions (i.e. similar to a default expression). 188 189 procedure rv; 190 -- This is a dummy function called by the processing for pragma Reviewable. 191 -- It is there for assisting front end debugging. By placing a Reviewable 192 -- pragma in the source program, a breakpoint on rv catches this place in 193 -- the source, allowing convenient stepping to the point of interest. 194 195 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id); 196 -- Place semantic information on the argument of an Elaborate/Elaborate_All 197 -- pragma. Entity name for unit and its parents is taken from item in 198 -- previous with_clause that mentions the unit. 199 200 ------------------------------- 201 -- Adjust_External_Name_Case -- 202 ------------------------------- 203 204 function Adjust_External_Name_Case (N : Node_Id) return Node_Id is 205 CC : Char_Code; 206 207 begin 208 -- Adjust case of literal if required 209 210 if Opt.External_Name_Exp_Casing = As_Is then 211 return N; 212 213 else 214 -- Copy existing string 215 216 Start_String; 217 218 -- Set proper casing 219 220 for J in 1 .. String_Length (Strval (N)) loop 221 CC := Get_String_Char (Strval (N), J); 222 223 if Opt.External_Name_Exp_Casing = Uppercase 224 and then CC >= Get_Char_Code ('a') 225 and then CC <= Get_Char_Code ('z') 226 then 227 Store_String_Char (CC - 32); 228 229 elsif Opt.External_Name_Exp_Casing = Lowercase 230 and then CC >= Get_Char_Code ('A') 231 and then CC <= Get_Char_Code ('Z') 232 then 233 Store_String_Char (CC + 32); 234 235 else 236 Store_String_Char (CC); 237 end if; 238 end loop; 239 240 return 241 Make_String_Literal (Sloc (N), 242 Strval => End_String); 243 end if; 244 end Adjust_External_Name_Case; 245 246 ------------------------------ 247 -- Analyze_CTC_In_Decl_Part -- 248 ------------------------------ 249 250 procedure Analyze_CTC_In_Decl_Part (N : Node_Id; S : Entity_Id) is 251 begin 252 -- Install formals and push subprogram spec onto scope stack so that we 253 -- can see the formals from the pragma. 254 255 Install_Formals (S); 256 Push_Scope (S); 257 258 -- Preanalyze the boolean expressions, we treat these as spec 259 -- expressions (i.e. similar to a default expression). 260 261 Preanalyze_CTC_Args 262 (N, 263 Get_Requires_From_CTC_Pragma (N), 264 Get_Ensures_From_CTC_Pragma (N)); 265 266 -- Remove the subprogram from the scope stack now that the pre-analysis 267 -- of the expressions in the contract case or test case is done. 268 269 End_Scope; 270 end Analyze_CTC_In_Decl_Part; 271 272 ------------------------------ 273 -- Analyze_PPC_In_Decl_Part -- 274 ------------------------------ 275 276 procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is 277 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 278 279 begin 280 -- Install formals and push subprogram spec onto scope stack so that we 281 -- can see the formals from the pragma. 282 283 Install_Formals (S); 284 Push_Scope (S); 285 286 -- Preanalyze the boolean expression, we treat this as a spec expression 287 -- (i.e. similar to a default expression). 288 289 Preanalyze_Assert_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); 290 291 -- In ASIS mode, for a pragma generated from a source aspect, also 292 -- analyze the original aspect expression. 293 294 if ASIS_Mode 295 and then Present (Corresponding_Aspect (N)) 296 then 297 Preanalyze_Assert_Expression 298 (Expression (Corresponding_Aspect (N)), Standard_Boolean); 299 end if; 300 301 -- For a class-wide condition, a reference to a controlling formal must 302 -- be interpreted as having the class-wide type (or an access to such) 303 -- so that the inherited condition can be properly applied to any 304 -- overriding operation (see ARM12 6.6.1 (7)). 305 306 if Class_Present (N) then 307 Class_Wide_Condition : declare 308 T : constant Entity_Id := Find_Dispatching_Type (S); 309 310 ACW : Entity_Id := Empty; 311 -- Access to T'class, created if there is a controlling formal 312 -- that is an access parameter. 313 314 function Get_ACW return Entity_Id; 315 -- If the expression has a reference to an controlling access 316 -- parameter, create an access to T'class for the necessary 317 -- conversions if one does not exist. 318 319 function Process (N : Node_Id) return Traverse_Result; 320 -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class 321 -- aspect for a primitive subprogram of a tagged type T, a name 322 -- that denotes a formal parameter of type T is interpreted as 323 -- having type T'Class. Similarly, a name that denotes a formal 324 -- accessparameter of type access-to-T is interpreted as having 325 -- type access-to-T'Class. This ensures the expression is well- 326 -- defined for a primitive subprogram of a type descended from T. 327 328 ------------- 329 -- Get_ACW -- 330 ------------- 331 332 function Get_ACW return Entity_Id is 333 Loc : constant Source_Ptr := Sloc (N); 334 Decl : Node_Id; 335 336 begin 337 if No (ACW) then 338 Decl := Make_Full_Type_Declaration (Loc, 339 Defining_Identifier => Make_Temporary (Loc, 'T'), 340 Type_Definition => 341 Make_Access_To_Object_Definition (Loc, 342 Subtype_Indication => 343 New_Occurrence_Of (Class_Wide_Type (T), Loc), 344 All_Present => True)); 345 346 Insert_Before (Unit_Declaration_Node (S), Decl); 347 Analyze (Decl); 348 ACW := Defining_Identifier (Decl); 349 Freeze_Before (Unit_Declaration_Node (S), ACW); 350 end if; 351 352 return ACW; 353 end Get_ACW; 354 355 ------------- 356 -- Process -- 357 ------------- 358 359 function Process (N : Node_Id) return Traverse_Result is 360 Loc : constant Source_Ptr := Sloc (N); 361 Typ : Entity_Id; 362 363 begin 364 if Is_Entity_Name (N) 365 and then Is_Formal (Entity (N)) 366 and then Nkind (Parent (N)) /= N_Type_Conversion 367 then 368 if Etype (Entity (N)) = T then 369 Typ := Class_Wide_Type (T); 370 371 elsif Is_Access_Type (Etype (Entity (N))) 372 and then Designated_Type (Etype (Entity (N))) = T 373 then 374 Typ := Get_ACW; 375 else 376 Typ := Empty; 377 end if; 378 379 if Present (Typ) then 380 Rewrite (N, 381 Make_Type_Conversion (Loc, 382 Subtype_Mark => 383 New_Occurrence_Of (Typ, Loc), 384 Expression => New_Occurrence_Of (Entity (N), Loc))); 385 Set_Etype (N, Typ); 386 end if; 387 end if; 388 389 return OK; 390 end Process; 391 392 procedure Replace_Type is new Traverse_Proc (Process); 393 394 -- Start of processing for Class_Wide_Condition 395 396 begin 397 if not Present (T) then 398 Error_Msg_Name_1 := 399 Chars (Identifier (Corresponding_Aspect (N))); 400 401 Error_Msg_Name_2 := Name_Class; 402 403 Error_Msg_N 404 ("aspect `%''%` can only be specified for a primitive " & 405 "operation of a tagged type", 406 Corresponding_Aspect (N)); 407 end if; 408 409 Replace_Type (Get_Pragma_Arg (Arg1)); 410 end Class_Wide_Condition; 411 end if; 412 413 -- Remove the subprogram from the scope stack now that the pre-analysis 414 -- of the precondition/postcondition is done. 415 416 End_Scope; 417 end Analyze_PPC_In_Decl_Part; 418 419 -------------------- 420 -- Analyze_Pragma -- 421 -------------------- 422 423 procedure Analyze_Pragma (N : Node_Id) is 424 Loc : constant Source_Ptr := Sloc (N); 425 Prag_Id : Pragma_Id; 426 427 Pname : Name_Id; 428 -- Name of the source pragma, or name of the corresponding aspect for 429 -- pragmas which originate in a source aspect. In the latter case, the 430 -- name may be different from the pragma name. 431 432 Pragma_Exit : exception; 433 -- This exception is used to exit pragma processing completely. It is 434 -- used when an error is detected, and no further processing is 435 -- required. It is also used if an earlier error has left the tree in 436 -- a state where the pragma should not be processed. 437 438 Arg_Count : Nat; 439 -- Number of pragma argument associations 440 441 Arg1 : Node_Id; 442 Arg2 : Node_Id; 443 Arg3 : Node_Id; 444 Arg4 : Node_Id; 445 -- First four pragma arguments (pragma argument association nodes, or 446 -- Empty if the corresponding argument does not exist). 447 448 type Name_List is array (Natural range <>) of Name_Id; 449 type Args_List is array (Natural range <>) of Node_Id; 450 -- Types used for arguments to Check_Arg_Order and Gather_Associations 451 452 procedure Ada_2005_Pragma; 453 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In 454 -- Ada 95 mode, these are implementation defined pragmas, so should be 455 -- caught by the No_Implementation_Pragmas restriction. 456 457 procedure Ada_2012_Pragma; 458 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. 459 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so 460 -- should be caught by the No_Implementation_Pragmas restriction. 461 462 procedure Check_Ada_83_Warning; 463 -- Issues a warning message for the current pragma if operating in Ada 464 -- 83 mode (used for language pragmas that are not a standard part of 465 -- Ada 83). This procedure does not raise Error_Pragma. Also notes use 466 -- of 95 pragma. 467 468 procedure Check_Arg_Count (Required : Nat); 469 -- Check argument count for pragma is equal to given parameter. If not, 470 -- then issue an error message and raise Pragma_Exit. 471 472 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument 473 -- Arg which can either be a pragma argument association, in which case 474 -- the check is applied to the expression of the association or an 475 -- expression directly. 476 477 procedure Check_Arg_Is_External_Name (Arg : Node_Id); 478 -- Check that an argument has the right form for an EXTERNAL_NAME 479 -- parameter of an extended import/export pragma. The rule is that the 480 -- name must be an identifier or string literal (in Ada 83 mode) or a 481 -- static string expression (in Ada 95 mode). 482 483 procedure Check_Arg_Is_Identifier (Arg : Node_Id); 484 -- Check the specified argument Arg to make sure that it is an 485 -- identifier. If not give error and raise Pragma_Exit. 486 487 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); 488 -- Check the specified argument Arg to make sure that it is an integer 489 -- literal. If not give error and raise Pragma_Exit. 490 491 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); 492 -- Check the specified argument Arg to make sure that it has the proper 493 -- syntactic form for a local name and meets the semantic requirements 494 -- for a local name. The local name is analyzed as part of the 495 -- processing for this call. In addition, the local name is required 496 -- to represent an entity at the library level. 497 498 procedure Check_Arg_Is_Local_Name (Arg : Node_Id); 499 -- Check the specified argument Arg to make sure that it has the proper 500 -- syntactic form for a local name and meets the semantic requirements 501 -- for a local name. The local name is analyzed as part of the 502 -- processing for this call. 503 504 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); 505 -- Check the specified argument Arg to make sure that it is a valid 506 -- locking policy name. If not give error and raise Pragma_Exit. 507 508 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); 509 -- Check the specified argument Arg to make sure that it is a valid 510 -- elaboration policy name. If not give error and raise Pragma_Exit. 511 512 procedure Check_Arg_Is_One_Of 513 (Arg : Node_Id; 514 N1, N2 : Name_Id); 515 procedure Check_Arg_Is_One_Of 516 (Arg : Node_Id; 517 N1, N2, N3 : Name_Id); 518 procedure Check_Arg_Is_One_Of 519 (Arg : Node_Id; 520 N1, N2, N3, N4 : Name_Id); 521 procedure Check_Arg_Is_One_Of 522 (Arg : Node_Id; 523 N1, N2, N3, N4, N5 : Name_Id); 524 -- Check the specified argument Arg to make sure that it is an 525 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if 526 -- present). If not then give error and raise Pragma_Exit. 527 528 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); 529 -- Check the specified argument Arg to make sure that it is a valid 530 -- queuing policy name. If not give error and raise Pragma_Exit. 531 532 procedure Check_Arg_Is_Static_Expression 533 (Arg : Node_Id; 534 Typ : Entity_Id := Empty); 535 -- Check the specified argument Arg to make sure that it is a static 536 -- expression of the given type (i.e. it will be analyzed and resolved 537 -- using this type, which can be any valid argument to Resolve, e.g. 538 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 539 -- Typ is left Empty, then any static expression is allowed. 540 541 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); 542 -- Check the specified argument Arg to make sure that it is a valid task 543 -- dispatching policy name. If not give error and raise Pragma_Exit. 544 545 procedure Check_Arg_Order (Names : Name_List); 546 -- Checks for an instance of two arguments with identifiers for the 547 -- current pragma which are not in the sequence indicated by Names, 548 -- and if so, generates a fatal message about bad order of arguments. 549 550 procedure Check_At_Least_N_Arguments (N : Nat); 551 -- Check there are at least N arguments present 552 553 procedure Check_At_Most_N_Arguments (N : Nat); 554 -- Check there are no more than N arguments present 555 556 procedure Check_Component 557 (Comp : Node_Id; 558 UU_Typ : Entity_Id; 559 In_Variant_Part : Boolean := False); 560 -- Examine an Unchecked_Union component for correct use of per-object 561 -- constrained subtypes, and for restrictions on finalizable components. 562 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part 563 -- should be set when Comp comes from a record variant. 564 565 procedure Check_Contract_Or_Test_Case; 566 -- Called to process a contract-case or test-case pragma. It 567 -- starts with checking pragma arguments, and the rest of the 568 -- treatment is similar to the one for pre- and postcondition in 569 -- Check_Precondition_Postcondition, except the placement rules for the 570 -- contract-case and test-case pragmas are stricter. These pragmas may 571 -- only occur after a subprogram spec declared directly in a package 572 -- spec unit. In this case, the pragma is chained to the subprogram in 573 -- question (using Spec_CTC_List and Next_Pragma) and analysis of the 574 -- pragma is delayed till the end of the spec. In all other cases, an 575 -- error message for bad placement is given. 576 577 procedure Check_Duplicate_Pragma (E : Entity_Id); 578 -- Check if a rep item of the same name as the current pragma is already 579 -- chained as a rep pragma to the given entity. If so give a message 580 -- about the duplicate, and then raise Pragma_Exit so does not return. 581 582 procedure Check_Duplicated_Export_Name (Nam : Node_Id); 583 -- Nam is an N_String_Literal node containing the external name set by 584 -- an Import or Export pragma (or extended Import or Export pragma). 585 -- This procedure checks for possible duplications if this is the export 586 -- case, and if found, issues an appropriate error message. 587 588 procedure Check_Expr_Is_Static_Expression 589 (Expr : Node_Id; 590 Typ : Entity_Id := Empty); 591 -- Check the specified expression Expr to make sure that it is a static 592 -- expression of the given type (i.e. it will be analyzed and resolved 593 -- using this type, which can be any valid argument to Resolve, e.g. 594 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If 595 -- Typ is left Empty, then any static expression is allowed. 596 597 procedure Check_First_Subtype (Arg : Node_Id); 598 -- Checks that Arg, whose expression is an entity name, references a 599 -- first subtype. 600 601 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id); 602 -- Checks that the given argument has an identifier, and if so, requires 603 -- it to match the given identifier name. If there is no identifier, or 604 -- a non-matching identifier, then an error message is given and 605 -- Pragma_Exit is raised. 606 607 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); 608 -- Checks that the given argument has an identifier, and if so, requires 609 -- it to match one of the given identifier names. If there is no 610 -- identifier, or a non-matching identifier, then an error message is 611 -- given and Pragma_Exit is raised. 612 613 procedure Check_In_Main_Program; 614 -- Common checks for pragmas that appear within a main program 615 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). 616 617 procedure Check_Interrupt_Or_Attach_Handler; 618 -- Common processing for first argument of pragma Interrupt_Handler or 619 -- pragma Attach_Handler. 620 621 procedure Check_Loop_Pragma_Placement; 622 -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant 623 -- appear immediately within a construct restricted to loops. 624 625 procedure Check_Is_In_Decl_Part_Or_Package_Spec; 626 -- Check that pragma appears in a declarative part, or in a package 627 -- specification, i.e. that it does not occur in a statement sequence 628 -- in a body. 629 630 procedure Check_No_Identifier (Arg : Node_Id); 631 -- Checks that the given argument does not have an identifier. If 632 -- an identifier is present, then an error message is issued, and 633 -- Pragma_Exit is raised. 634 635 procedure Check_No_Identifiers; 636 -- Checks that none of the arguments to the pragma has an identifier. 637 -- If any argument has an identifier, then an error message is issued, 638 -- and Pragma_Exit is raised. 639 640 procedure Check_No_Link_Name; 641 -- Checks that no link name is specified 642 643 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 644 -- Checks if the given argument has an identifier, and if so, requires 645 -- it to match the given identifier name. If there is a non-matching 646 -- identifier, then an error message is given and Pragma_Exit is raised. 647 648 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); 649 -- Checks if the given argument has an identifier, and if so, requires 650 -- it to match the given identifier name. If there is a non-matching 651 -- identifier, then an error message is given and Pragma_Exit is raised. 652 -- In this version of the procedure, the identifier name is given as 653 -- a string with lower case letters. 654 655 procedure Check_Precondition_Postcondition (In_Body : out Boolean); 656 -- Called to process a precondition or postcondition pragma. There are 657 -- three cases: 658 -- 659 -- The pragma appears after a subprogram spec 660 -- 661 -- If the corresponding check is not enabled, the pragma is analyzed 662 -- but otherwise ignored and control returns with In_Body set False. 663 -- 664 -- If the check is enabled, then the first step is to analyze the 665 -- pragma, but this is skipped if the subprogram spec appears within 666 -- a package specification (because this is the case where we delay 667 -- analysis till the end of the spec). Then (whether or not it was 668 -- analyzed), the pragma is chained to the subprogram in question 669 -- (using Spec_PPC_List and Next_Pragma) and control returns to the 670 -- caller with In_Body set False. 671 -- 672 -- The pragma appears at the start of subprogram body declarations 673 -- 674 -- In this case an immediate return to the caller is made with 675 -- In_Body set True, and the pragma is NOT analyzed. 676 -- 677 -- In all other cases, an error message for bad placement is given 678 679 procedure Check_Static_Constraint (Constr : Node_Id); 680 -- Constr is a constraint from an N_Subtype_Indication node from a 681 -- component constraint in an Unchecked_Union type. This routine checks 682 -- that the constraint is static as required by the restrictions for 683 -- Unchecked_Union. 684 685 procedure Check_Valid_Configuration_Pragma; 686 -- Legality checks for placement of a configuration pragma 687 688 procedure Check_Valid_Library_Unit_Pragma; 689 -- Legality checks for library unit pragmas. A special case arises for 690 -- pragmas in generic instances that come from copies of the original 691 -- library unit pragmas in the generic templates. In the case of other 692 -- than library level instantiations these can appear in contexts which 693 -- would normally be invalid (they only apply to the original template 694 -- and to library level instantiations), and they are simply ignored, 695 -- which is implemented by rewriting them as null statements. 696 697 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); 698 -- Check an Unchecked_Union variant for lack of nested variants and 699 -- presence of at least one component. UU_Typ is the related Unchecked_ 700 -- Union type. 701 702 procedure Error_Pragma (Msg : String); 703 pragma No_Return (Error_Pragma); 704 -- Outputs error message for current pragma. The message contains a % 705 -- that will be replaced with the pragma name, and the flag is placed 706 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine 707 -- calls Fix_Error (see spec of that function for details). 708 709 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); 710 pragma No_Return (Error_Pragma_Arg); 711 -- Outputs error message for current pragma. The message may contain 712 -- a % that will be replaced with the pragma name. The parameter Arg 713 -- may either be a pragma argument association, in which case the flag 714 -- is placed on the expression of this association, or an expression, 715 -- in which case the flag is placed directly on the expression. The 716 -- message is placed using Error_Msg_N, so the message may also contain 717 -- an & insertion character which will reference the given Arg value. 718 -- After placing the message, Pragma_Exit is raised. Note: this routine 719 -- calls Fix_Error (see spec of that function for details). 720 721 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); 722 pragma No_Return (Error_Pragma_Arg); 723 -- Similar to above form of Error_Pragma_Arg except that two messages 724 -- are provided, the second is a continuation comment starting with \. 725 726 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); 727 pragma No_Return (Error_Pragma_Arg_Ident); 728 -- Outputs error message for current pragma. The message may contain 729 -- a % that will be replaced with the pragma name. The parameter Arg 730 -- must be a pragma argument association with a non-empty identifier 731 -- (i.e. its Chars field must be set), and the error message is placed 732 -- on the identifier. The message is placed using Error_Msg_N so 733 -- the message may also contain an & insertion character which will 734 -- reference the identifier. After placing the message, Pragma_Exit 735 -- is raised. Note: this routine calls Fix_Error (see spec of that 736 -- function for details). 737 738 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); 739 pragma No_Return (Error_Pragma_Ref); 740 -- Outputs error message for current pragma. The message may contain 741 -- a % that will be replaced with the pragma name. The parameter Ref 742 -- must be an entity whose name can be referenced by & and sloc by #. 743 -- After placing the message, Pragma_Exit is raised. Note: this routine 744 -- calls Fix_Error (see spec of that function for details). 745 746 function Find_Lib_Unit_Name return Entity_Id; 747 -- Used for a library unit pragma to find the entity to which the 748 -- library unit pragma applies, returns the entity found. 749 750 procedure Find_Program_Unit_Name (Id : Node_Id); 751 -- If the pragma is a compilation unit pragma, the id must denote the 752 -- compilation unit in the same compilation, and the pragma must appear 753 -- in the list of preceding or trailing pragmas. If it is a program 754 -- unit pragma that is not a compilation unit pragma, then the 755 -- identifier must be visible. 756 757 function Find_Unique_Parameterless_Procedure 758 (Name : Entity_Id; 759 Arg : Node_Id) return Entity_Id; 760 -- Used for a procedure pragma to find the unique parameterless 761 -- procedure identified by Name, returns it if it exists, otherwise 762 -- errors out and uses Arg as the pragma argument for the message. 763 764 procedure Fix_Error (Msg : in out String); 765 -- This is called prior to issuing an error message. Msg is a string 766 -- that typically contains the substring "pragma". If the current pragma 767 -- comes from an aspect, each such "pragma" substring is replaced with 768 -- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition 769 -- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post). 770 771 procedure Gather_Associations 772 (Names : Name_List; 773 Args : out Args_List); 774 -- This procedure is used to gather the arguments for a pragma that 775 -- permits arbitrary ordering of parameters using the normal rules 776 -- for named and positional parameters. The Names argument is a list 777 -- of Name_Id values that corresponds to the allowed pragma argument 778 -- association identifiers in order. The result returned in Args is 779 -- a list of corresponding expressions that are the pragma arguments. 780 -- Note that this is a list of expressions, not of pragma argument 781 -- associations (Gather_Associations has completely checked all the 782 -- optional identifiers when it returns). An entry in Args is Empty 783 -- on return if the corresponding argument is not present. 784 785 procedure GNAT_Pragma; 786 -- Called for all GNAT defined pragmas to check the relevant restriction 787 -- (No_Implementation_Pragmas). 788 789 procedure S14_Pragma; 790 -- Called for all pragmas defined for formal verification to check that 791 -- the S14_Extensions flag is set. 792 -- This name needs fixing ??? There is no such thing as an 793 -- "S14_Extensions" flag ??? 794 795 function Is_Before_First_Decl 796 (Pragma_Node : Node_Id; 797 Decls : List_Id) return Boolean; 798 -- Return True if Pragma_Node is before the first declarative item in 799 -- Decls where Decls is the list of declarative items. 800 801 function Is_Configuration_Pragma return Boolean; 802 -- Determines if the placement of the current pragma is appropriate 803 -- for a configuration pragma. 804 805 function Is_In_Context_Clause return Boolean; 806 -- Returns True if pragma appears within the context clause of a unit, 807 -- and False for any other placement (does not generate any messages). 808 809 function Is_Static_String_Expression (Arg : Node_Id) return Boolean; 810 -- Analyzes the argument, and determines if it is a static string 811 -- expression, returns True if so, False if non-static or not String. 812 813 procedure Pragma_Misplaced; 814 pragma No_Return (Pragma_Misplaced); 815 -- Issue fatal error message for misplaced pragma 816 817 procedure Process_Atomic_Shared_Volatile; 818 -- Common processing for pragmas Atomic, Shared, Volatile. Note that 819 -- Shared is an obsolete Ada 83 pragma, treated as being identical 820 -- in effect to pragma Atomic. 821 822 procedure Process_Compile_Time_Warning_Or_Error; 823 -- Common processing for Compile_Time_Error and Compile_Time_Warning 824 825 procedure Process_Convention 826 (C : out Convention_Id; 827 Ent : out Entity_Id); 828 -- Common processing for Convention, Interface, Import and Export. 829 -- Checks first two arguments of pragma, and sets the appropriate 830 -- convention value in the specified entity or entities. On return 831 -- C is the convention, Ent is the referenced entity. 832 833 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); 834 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is 835 -- Name_Suppress for Disable and Name_Unsuppress for Enable. 836 837 procedure Process_Extended_Import_Export_Exception_Pragma 838 (Arg_Internal : Node_Id; 839 Arg_External : Node_Id; 840 Arg_Form : Node_Id; 841 Arg_Code : Node_Id); 842 -- Common processing for the pragmas Import/Export_Exception. The three 843 -- arguments correspond to the three named parameters of the pragma. An 844 -- argument is empty if the corresponding parameter is not present in 845 -- the pragma. 846 847 procedure Process_Extended_Import_Export_Object_Pragma 848 (Arg_Internal : Node_Id; 849 Arg_External : Node_Id; 850 Arg_Size : Node_Id); 851 -- Common processing for the pragmas Import/Export_Object. The three 852 -- arguments correspond to the three named parameters of the pragmas. An 853 -- argument is empty if the corresponding parameter is not present in 854 -- the pragma. 855 856 procedure Process_Extended_Import_Export_Internal_Arg 857 (Arg_Internal : Node_Id := Empty); 858 -- Common processing for all extended Import and Export pragmas. The 859 -- argument is the pragma parameter for the Internal argument. If 860 -- Arg_Internal is empty or inappropriate, an error message is posted. 861 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is 862 -- set to identify the referenced entity. 863 864 procedure Process_Extended_Import_Export_Subprogram_Pragma 865 (Arg_Internal : Node_Id; 866 Arg_External : Node_Id; 867 Arg_Parameter_Types : Node_Id; 868 Arg_Result_Type : Node_Id := Empty; 869 Arg_Mechanism : Node_Id; 870 Arg_Result_Mechanism : Node_Id := Empty; 871 Arg_First_Optional_Parameter : Node_Id := Empty); 872 -- Common processing for all extended Import and Export pragmas applying 873 -- to subprograms. The caller omits any arguments that do not apply to 874 -- the pragma in question (for example, Arg_Result_Type can be non-Empty 875 -- only in the Import_Function and Export_Function cases). The argument 876 -- names correspond to the allowed pragma association identifiers. 877 878 procedure Process_Generic_List; 879 -- Common processing for Share_Generic and Inline_Generic 880 881 procedure Process_Import_Or_Interface; 882 -- Common processing for Import of Interface 883 884 procedure Process_Import_Predefined_Type; 885 -- Processing for completing a type with pragma Import. This is used 886 -- to declare types that match predefined C types, especially for cases 887 -- without corresponding Ada predefined type. 888 889 type Inline_Status is (Suppressed, Disabled, Enabled); 890 -- Inline status of a subprogram, indicated as follows: 891 -- Suppressed: inlining is suppressed for the subprogram 892 -- Disabled: no inlining is requested for the subprogram 893 -- Enabled: inlining is requested/required for the subprogram 894 895 procedure Process_Inline (Status : Inline_Status); 896 -- Common processing for Inline, Inline_Always and No_Inline. Parameter 897 -- indicates the inline status specified by the pragma. 898 899 procedure Process_Interface_Name 900 (Subprogram_Def : Entity_Id; 901 Ext_Arg : Node_Id; 902 Link_Arg : Node_Id); 903 -- Given the last two arguments of pragma Import, pragma Export, or 904 -- pragma Interface_Name, performs validity checks and sets the 905 -- Interface_Name field of the given subprogram entity to the 906 -- appropriate external or link name, depending on the arguments given. 907 -- Ext_Arg is always present, but Link_Arg may be missing. Note that 908 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and 909 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg 910 -- nor Link_Arg is present, the interface name is set to the default 911 -- from the subprogram name. 912 913 procedure Process_Interrupt_Or_Attach_Handler; 914 -- Common processing for Interrupt and Attach_Handler pragmas 915 916 procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); 917 -- Common processing for Restrictions and Restriction_Warnings pragmas. 918 -- Warn is True for Restriction_Warnings, or for Restrictions if the 919 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag 920 -- is not set in the Restrictions case. 921 922 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); 923 -- Common processing for Suppress and Unsuppress. The boolean parameter 924 -- Suppress_Case is True for the Suppress case, and False for the 925 -- Unsuppress case. 926 927 procedure Set_Exported (E : Entity_Id; Arg : Node_Id); 928 -- This procedure sets the Is_Exported flag for the given entity, 929 -- checking that the entity was not previously imported. Arg is 930 -- the argument that specified the entity. A check is also made 931 -- for exporting inappropriate entities. 932 933 procedure Set_Extended_Import_Export_External_Name 934 (Internal_Ent : Entity_Id; 935 Arg_External : Node_Id); 936 -- Common processing for all extended import export pragmas. The first 937 -- argument, Internal_Ent, is the internal entity, which has already 938 -- been checked for validity by the caller. Arg_External is from the 939 -- Import or Export pragma, and may be null if no External parameter 940 -- was present. If Arg_External is present and is a non-null string 941 -- (a null string is treated as the default), then the Interface_Name 942 -- field of Internal_Ent is set appropriately. 943 944 procedure Set_Imported (E : Entity_Id); 945 -- This procedure sets the Is_Imported flag for the given entity, 946 -- checking that it is not previously exported or imported. 947 948 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); 949 -- Mech is a parameter passing mechanism (see Import_Function syntax 950 -- for MECHANISM_NAME). This routine checks that the mechanism argument 951 -- has the right form, and if not issues an error message. If the 952 -- argument has the right form then the Mechanism field of Ent is 953 -- set appropriately. 954 955 procedure Set_Rational_Profile; 956 -- Activate the set of configuration pragmas and permissions that make 957 -- up the Rational profile. 958 959 procedure Set_Ravenscar_Profile (N : Node_Id); 960 -- Activate the set of configuration pragmas and restrictions that make 961 -- up the Ravenscar Profile. N is the corresponding pragma node, which 962 -- is used for error messages on any constructs that violate the 963 -- profile. 964 965 --------------------- 966 -- Ada_2005_Pragma -- 967 --------------------- 968 969 procedure Ada_2005_Pragma is 970 begin 971 if Ada_Version <= Ada_95 then 972 Check_Restriction (No_Implementation_Pragmas, N); 973 end if; 974 end Ada_2005_Pragma; 975 976 --------------------- 977 -- Ada_2012_Pragma -- 978 --------------------- 979 980 procedure Ada_2012_Pragma is 981 begin 982 if Ada_Version <= Ada_2005 then 983 Check_Restriction (No_Implementation_Pragmas, N); 984 end if; 985 end Ada_2012_Pragma; 986 987 -------------------------- 988 -- Check_Ada_83_Warning -- 989 -------------------------- 990 991 procedure Check_Ada_83_Warning is 992 begin 993 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 994 Error_Msg_N ("(Ada 83) pragma& is non-standard??", N); 995 end if; 996 end Check_Ada_83_Warning; 997 998 --------------------- 999 -- Check_Arg_Count -- 1000 --------------------- 1001 1002 procedure Check_Arg_Count (Required : Nat) is 1003 begin 1004 if Arg_Count /= Required then 1005 Error_Pragma ("wrong number of arguments for pragma%"); 1006 end if; 1007 end Check_Arg_Count; 1008 1009 -------------------------------- 1010 -- Check_Arg_Is_External_Name -- 1011 -------------------------------- 1012 1013 procedure Check_Arg_Is_External_Name (Arg : Node_Id) is 1014 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1015 1016 begin 1017 if Nkind (Argx) = N_Identifier then 1018 return; 1019 1020 else 1021 Analyze_And_Resolve (Argx, Standard_String); 1022 1023 if Is_OK_Static_Expression (Argx) then 1024 return; 1025 1026 elsif Etype (Argx) = Any_Type then 1027 raise Pragma_Exit; 1028 1029 -- An interesting special case, if we have a string literal and 1030 -- we are in Ada 83 mode, then we allow it even though it will 1031 -- not be flagged as static. This allows expected Ada 83 mode 1032 -- use of external names which are string literals, even though 1033 -- technically these are not static in Ada 83. 1034 1035 elsif Ada_Version = Ada_83 1036 and then Nkind (Argx) = N_String_Literal 1037 then 1038 return; 1039 1040 -- Static expression that raises Constraint_Error. This has 1041 -- already been flagged, so just exit from pragma processing. 1042 1043 elsif Is_Static_Expression (Argx) then 1044 raise Pragma_Exit; 1045 1046 -- Here we have a real error (non-static expression) 1047 1048 else 1049 Error_Msg_Name_1 := Pname; 1050 1051 declare 1052 Msg : String := 1053 "argument for pragma% must be a identifier or " 1054 & "static string expression!"; 1055 begin 1056 Fix_Error (Msg); 1057 Flag_Non_Static_Expr (Msg, Argx); 1058 raise Pragma_Exit; 1059 end; 1060 end if; 1061 end if; 1062 end Check_Arg_Is_External_Name; 1063 1064 ----------------------------- 1065 -- Check_Arg_Is_Identifier -- 1066 ----------------------------- 1067 1068 procedure Check_Arg_Is_Identifier (Arg : Node_Id) is 1069 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1070 begin 1071 if Nkind (Argx) /= N_Identifier then 1072 Error_Pragma_Arg 1073 ("argument for pragma% must be identifier", Argx); 1074 end if; 1075 end Check_Arg_Is_Identifier; 1076 1077 ---------------------------------- 1078 -- Check_Arg_Is_Integer_Literal -- 1079 ---------------------------------- 1080 1081 procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is 1082 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1083 begin 1084 if Nkind (Argx) /= N_Integer_Literal then 1085 Error_Pragma_Arg 1086 ("argument for pragma% must be integer literal", Argx); 1087 end if; 1088 end Check_Arg_Is_Integer_Literal; 1089 1090 ------------------------------------------- 1091 -- Check_Arg_Is_Library_Level_Local_Name -- 1092 ------------------------------------------- 1093 1094 -- LOCAL_NAME ::= 1095 -- DIRECT_NAME 1096 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 1097 -- | library_unit_NAME 1098 1099 procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is 1100 begin 1101 Check_Arg_Is_Local_Name (Arg); 1102 1103 if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) 1104 and then Comes_From_Source (N) 1105 then 1106 Error_Pragma_Arg 1107 ("argument for pragma% must be library level entity", Arg); 1108 end if; 1109 end Check_Arg_Is_Library_Level_Local_Name; 1110 1111 ----------------------------- 1112 -- Check_Arg_Is_Local_Name -- 1113 ----------------------------- 1114 1115 -- LOCAL_NAME ::= 1116 -- DIRECT_NAME 1117 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR 1118 -- | library_unit_NAME 1119 1120 procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is 1121 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1122 1123 begin 1124 Analyze (Argx); 1125 1126 if Nkind (Argx) not in N_Direct_Name 1127 and then (Nkind (Argx) /= N_Attribute_Reference 1128 or else Present (Expressions (Argx)) 1129 or else Nkind (Prefix (Argx)) /= N_Identifier) 1130 and then (not Is_Entity_Name (Argx) 1131 or else not Is_Compilation_Unit (Entity (Argx))) 1132 then 1133 Error_Pragma_Arg ("argument for pragma% must be local name", Argx); 1134 end if; 1135 1136 -- No further check required if not an entity name 1137 1138 if not Is_Entity_Name (Argx) then 1139 null; 1140 1141 else 1142 declare 1143 OK : Boolean; 1144 Ent : constant Entity_Id := Entity (Argx); 1145 Scop : constant Entity_Id := Scope (Ent); 1146 begin 1147 -- Case of a pragma applied to a compilation unit: pragma must 1148 -- occur immediately after the program unit in the compilation. 1149 1150 if Is_Compilation_Unit (Ent) then 1151 declare 1152 Decl : constant Node_Id := Unit_Declaration_Node (Ent); 1153 1154 begin 1155 -- Case of pragma placed immediately after spec 1156 1157 if Parent (N) = Aux_Decls_Node (Parent (Decl)) then 1158 OK := True; 1159 1160 -- Case of pragma placed immediately after body 1161 1162 elsif Nkind (Decl) = N_Subprogram_Declaration 1163 and then Present (Corresponding_Body (Decl)) 1164 then 1165 OK := Parent (N) = 1166 Aux_Decls_Node 1167 (Parent (Unit_Declaration_Node 1168 (Corresponding_Body (Decl)))); 1169 1170 -- All other cases are illegal 1171 1172 else 1173 OK := False; 1174 end if; 1175 end; 1176 1177 -- Special restricted placement rule from 10.2.1(11.8/2) 1178 1179 elsif Is_Generic_Formal (Ent) 1180 and then Prag_Id = Pragma_Preelaborable_Initialization 1181 then 1182 OK := List_Containing (N) = 1183 Generic_Formal_Declarations 1184 (Unit_Declaration_Node (Scop)); 1185 1186 -- Default case, just check that the pragma occurs in the scope 1187 -- of the entity denoted by the name. 1188 1189 else 1190 OK := Current_Scope = Scop; 1191 end if; 1192 1193 if not OK then 1194 Error_Pragma_Arg 1195 ("pragma% argument must be in same declarative part", Arg); 1196 end if; 1197 end; 1198 end if; 1199 end Check_Arg_Is_Local_Name; 1200 1201 --------------------------------- 1202 -- Check_Arg_Is_Locking_Policy -- 1203 --------------------------------- 1204 1205 procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is 1206 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1207 1208 begin 1209 Check_Arg_Is_Identifier (Argx); 1210 1211 if not Is_Locking_Policy_Name (Chars (Argx)) then 1212 Error_Pragma_Arg ("& is not a valid locking policy name", Argx); 1213 end if; 1214 end Check_Arg_Is_Locking_Policy; 1215 1216 ----------------------------------------------- 1217 -- Check_Arg_Is_Partition_Elaboration_Policy -- 1218 ----------------------------------------------- 1219 1220 procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is 1221 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1222 1223 begin 1224 Check_Arg_Is_Identifier (Argx); 1225 1226 if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then 1227 Error_Pragma_Arg 1228 ("& is not a valid partition elaboration policy name", Argx); 1229 end if; 1230 end Check_Arg_Is_Partition_Elaboration_Policy; 1231 1232 ------------------------- 1233 -- Check_Arg_Is_One_Of -- 1234 ------------------------- 1235 1236 procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 1237 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1238 1239 begin 1240 Check_Arg_Is_Identifier (Argx); 1241 1242 if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then 1243 Error_Msg_Name_2 := N1; 1244 Error_Msg_Name_3 := N2; 1245 Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); 1246 end if; 1247 end Check_Arg_Is_One_Of; 1248 1249 procedure Check_Arg_Is_One_Of 1250 (Arg : Node_Id; 1251 N1, N2, N3 : Name_Id) 1252 is 1253 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1254 1255 begin 1256 Check_Arg_Is_Identifier (Argx); 1257 1258 if Chars (Argx) /= N1 1259 and then Chars (Argx) /= N2 1260 and then Chars (Argx) /= N3 1261 then 1262 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 1263 end if; 1264 end Check_Arg_Is_One_Of; 1265 1266 procedure Check_Arg_Is_One_Of 1267 (Arg : Node_Id; 1268 N1, N2, N3, N4 : Name_Id) 1269 is 1270 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1271 1272 begin 1273 Check_Arg_Is_Identifier (Argx); 1274 1275 if Chars (Argx) /= N1 1276 and then Chars (Argx) /= N2 1277 and then Chars (Argx) /= N3 1278 and then Chars (Argx) /= N4 1279 then 1280 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 1281 end if; 1282 end Check_Arg_Is_One_Of; 1283 1284 procedure Check_Arg_Is_One_Of 1285 (Arg : Node_Id; 1286 N1, N2, N3, N4, N5 : Name_Id) 1287 is 1288 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1289 1290 begin 1291 Check_Arg_Is_Identifier (Argx); 1292 1293 if Chars (Argx) /= N1 1294 and then Chars (Argx) /= N2 1295 and then Chars (Argx) /= N3 1296 and then Chars (Argx) /= N4 1297 and then Chars (Argx) /= N5 1298 then 1299 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 1300 end if; 1301 end Check_Arg_Is_One_Of; 1302 1303 --------------------------------- 1304 -- Check_Arg_Is_Queuing_Policy -- 1305 --------------------------------- 1306 1307 procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is 1308 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1309 1310 begin 1311 Check_Arg_Is_Identifier (Argx); 1312 1313 if not Is_Queuing_Policy_Name (Chars (Argx)) then 1314 Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); 1315 end if; 1316 end Check_Arg_Is_Queuing_Policy; 1317 1318 ------------------------------------ 1319 -- Check_Arg_Is_Static_Expression -- 1320 ------------------------------------ 1321 1322 procedure Check_Arg_Is_Static_Expression 1323 (Arg : Node_Id; 1324 Typ : Entity_Id := Empty) 1325 is 1326 begin 1327 Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ); 1328 end Check_Arg_Is_Static_Expression; 1329 1330 ------------------------------------------ 1331 -- Check_Arg_Is_Task_Dispatching_Policy -- 1332 ------------------------------------------ 1333 1334 procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is 1335 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1336 1337 begin 1338 Check_Arg_Is_Identifier (Argx); 1339 1340 if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then 1341 Error_Pragma_Arg 1342 ("& is not a valid task dispatching policy name", Argx); 1343 end if; 1344 end Check_Arg_Is_Task_Dispatching_Policy; 1345 1346 --------------------- 1347 -- Check_Arg_Order -- 1348 --------------------- 1349 1350 procedure Check_Arg_Order (Names : Name_List) is 1351 Arg : Node_Id; 1352 1353 Highest_So_Far : Natural := 0; 1354 -- Highest index in Names seen do far 1355 1356 begin 1357 Arg := Arg1; 1358 for J in 1 .. Arg_Count loop 1359 if Chars (Arg) /= No_Name then 1360 for K in Names'Range loop 1361 if Chars (Arg) = Names (K) then 1362 if K < Highest_So_Far then 1363 Error_Msg_Name_1 := Pname; 1364 Error_Msg_N 1365 ("parameters out of order for pragma%", Arg); 1366 Error_Msg_Name_1 := Names (K); 1367 Error_Msg_Name_2 := Names (Highest_So_Far); 1368 Error_Msg_N ("\% must appear before %", Arg); 1369 raise Pragma_Exit; 1370 1371 else 1372 Highest_So_Far := K; 1373 end if; 1374 end if; 1375 end loop; 1376 end if; 1377 1378 Arg := Next (Arg); 1379 end loop; 1380 end Check_Arg_Order; 1381 1382 -------------------------------- 1383 -- Check_At_Least_N_Arguments -- 1384 -------------------------------- 1385 1386 procedure Check_At_Least_N_Arguments (N : Nat) is 1387 begin 1388 if Arg_Count < N then 1389 Error_Pragma ("too few arguments for pragma%"); 1390 end if; 1391 end Check_At_Least_N_Arguments; 1392 1393 ------------------------------- 1394 -- Check_At_Most_N_Arguments -- 1395 ------------------------------- 1396 1397 procedure Check_At_Most_N_Arguments (N : Nat) is 1398 Arg : Node_Id; 1399 begin 1400 if Arg_Count > N then 1401 Arg := Arg1; 1402 for J in 1 .. N loop 1403 Next (Arg); 1404 Error_Pragma_Arg ("too many arguments for pragma%", Arg); 1405 end loop; 1406 end if; 1407 end Check_At_Most_N_Arguments; 1408 1409 --------------------- 1410 -- Check_Component -- 1411 --------------------- 1412 1413 procedure Check_Component 1414 (Comp : Node_Id; 1415 UU_Typ : Entity_Id; 1416 In_Variant_Part : Boolean := False) 1417 is 1418 Comp_Id : constant Entity_Id := Defining_Identifier (Comp); 1419 Sindic : constant Node_Id := 1420 Subtype_Indication (Component_Definition (Comp)); 1421 Typ : constant Entity_Id := Etype (Comp_Id); 1422 1423 begin 1424 -- Ada 2005 (AI-216): If a component subtype is subject to a per- 1425 -- object constraint, then the component type shall be an Unchecked_ 1426 -- Union. 1427 1428 if Nkind (Sindic) = N_Subtype_Indication 1429 and then Has_Per_Object_Constraint (Comp_Id) 1430 and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) 1431 then 1432 Error_Msg_N 1433 ("component subtype subject to per-object constraint " & 1434 "must be an Unchecked_Union", Comp); 1435 1436 -- Ada 2012 (AI05-0026): For an unchecked union type declared within 1437 -- the body of a generic unit, or within the body of any of its 1438 -- descendant library units, no part of the type of a component 1439 -- declared in a variant_part of the unchecked union type shall be of 1440 -- a formal private type or formal private extension declared within 1441 -- the formal part of the generic unit. 1442 1443 elsif Ada_Version >= Ada_2012 1444 and then In_Generic_Body (UU_Typ) 1445 and then In_Variant_Part 1446 and then Is_Private_Type (Typ) 1447 and then Is_Generic_Type (Typ) 1448 then 1449 Error_Msg_N 1450 ("component of unchecked union cannot be of generic type", Comp); 1451 1452 elsif Needs_Finalization (Typ) then 1453 Error_Msg_N 1454 ("component of unchecked union cannot be controlled", Comp); 1455 1456 elsif Has_Task (Typ) then 1457 Error_Msg_N 1458 ("component of unchecked union cannot have tasks", Comp); 1459 end if; 1460 end Check_Component; 1461 1462 --------------------------------- 1463 -- Check_Contract_Or_Test_Case -- 1464 --------------------------------- 1465 1466 procedure Check_Contract_Or_Test_Case is 1467 P : Node_Id; 1468 PO : Node_Id; 1469 1470 procedure Chain_CTC (PO : Node_Id); 1471 -- If PO is a [generic] subprogram declaration node, then the 1472 -- contract-case or test-case applies to this subprogram and the 1473 -- processing for the pragma is completed. Otherwise the pragma 1474 -- is misplaced. 1475 1476 --------------- 1477 -- Chain_CTC -- 1478 --------------- 1479 1480 procedure Chain_CTC (PO : Node_Id) is 1481 S : Entity_Id; 1482 1483 begin 1484 if Nkind (PO) = N_Abstract_Subprogram_Declaration then 1485 Error_Pragma 1486 ("pragma% cannot be applied to abstract subprogram"); 1487 1488 elsif Nkind (PO) = N_Entry_Declaration then 1489 Error_Pragma ("pragma% cannot be applied to entry"); 1490 1491 elsif not Nkind_In (PO, N_Subprogram_Declaration, 1492 N_Generic_Subprogram_Declaration) 1493 then 1494 Pragma_Misplaced; 1495 end if; 1496 1497 -- Here if we have [generic] subprogram declaration 1498 1499 S := Defining_Unit_Name (Specification (PO)); 1500 1501 -- Note: we do not analyze the pragma at this point. Instead we 1502 -- delay this analysis until the end of the declarative part in 1503 -- which the pragma appears. This implements the required delay 1504 -- in this analysis, allowing forward references. The analysis 1505 -- happens at the end of Analyze_Declarations. 1506 1507 -- There should not be another contract-case or test-case with the 1508 -- same name associated to this subprogram. 1509 1510 declare 1511 Name : constant String_Id := Get_Name_From_CTC_Pragma (N); 1512 CTC : Node_Id; 1513 1514 begin 1515 CTC := Spec_CTC_List (Contract (S)); 1516 while Present (CTC) loop 1517 1518 -- Omit pragma Contract_Cases because it does not introduce 1519 -- a unique case name and it does not follow the syntax of 1520 -- Contract_Case and Test_Case. 1521 1522 if Pragma_Name (CTC) = Name_Contract_Cases then 1523 null; 1524 1525 elsif String_Equal 1526 (Name, Get_Name_From_CTC_Pragma (CTC)) 1527 then 1528 Error_Msg_Sloc := Sloc (CTC); 1529 Error_Pragma ("name for pragma% is already used#"); 1530 end if; 1531 1532 CTC := Next_Pragma (CTC); 1533 end loop; 1534 end; 1535 1536 -- Chain spec CTC pragma to list for subprogram 1537 1538 Set_Next_Pragma (N, Spec_CTC_List (Contract (S))); 1539 Set_Spec_CTC_List (Contract (S), N); 1540 end Chain_CTC; 1541 1542 -- Start of processing for Check_Contract_Or_Test_Case 1543 1544 begin 1545 -- First check pragma arguments 1546 1547 GNAT_Pragma; 1548 Check_At_Least_N_Arguments (2); 1549 Check_At_Most_N_Arguments (4); 1550 Check_Arg_Order 1551 ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); 1552 1553 Check_Optional_Identifier (Arg1, Name_Name); 1554 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 1555 1556 -- In ASIS mode, for a pragma generated from a source aspect, also 1557 -- analyze the original aspect expression. 1558 1559 if ASIS_Mode 1560 and then Present (Corresponding_Aspect (N)) 1561 then 1562 Check_Expr_Is_Static_Expression 1563 (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); 1564 end if; 1565 1566 Check_Optional_Identifier (Arg2, Name_Mode); 1567 Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); 1568 1569 if Arg_Count = 4 then 1570 Check_Identifier (Arg3, Name_Requires); 1571 Check_Identifier (Arg4, Name_Ensures); 1572 1573 elsif Arg_Count = 3 then 1574 Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); 1575 end if; 1576 1577 -- Check pragma placement 1578 1579 if not Is_List_Member (N) then 1580 Pragma_Misplaced; 1581 end if; 1582 1583 -- Contract-case or test-case should only appear in package spec unit 1584 1585 if Get_Source_Unit (N) = No_Unit 1586 or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))), 1587 N_Package_Declaration, 1588 N_Generic_Package_Declaration) 1589 then 1590 Pragma_Misplaced; 1591 end if; 1592 1593 -- Search prior declarations 1594 1595 P := N; 1596 while Present (Prev (P)) loop 1597 P := Prev (P); 1598 1599 -- If the previous node is a generic subprogram, do not go to to 1600 -- the original node, which is the unanalyzed tree: we need to 1601 -- attach the contract-case or test-case to the analyzed version 1602 -- at this point. They get propagated to the original tree when 1603 -- analyzing the corresponding body. 1604 1605 if Nkind (P) not in N_Generic_Declaration then 1606 PO := Original_Node (P); 1607 else 1608 PO := P; 1609 end if; 1610 1611 -- Skip past prior pragma 1612 1613 if Nkind (PO) = N_Pragma then 1614 null; 1615 1616 -- Skip stuff not coming from source 1617 1618 elsif not Comes_From_Source (PO) then 1619 null; 1620 1621 -- Only remaining possibility is subprogram declaration. First 1622 -- check that it is declared directly in a package declaration. 1623 -- This may be either the package declaration for the current unit 1624 -- being defined or a local package declaration. 1625 1626 elsif not Present (Parent (Parent (PO))) 1627 or else not Present (Parent (Parent (Parent (PO)))) 1628 or else not Nkind_In (Parent (Parent (PO)), 1629 N_Package_Declaration, 1630 N_Generic_Package_Declaration) 1631 then 1632 Pragma_Misplaced; 1633 1634 else 1635 Chain_CTC (PO); 1636 return; 1637 end if; 1638 end loop; 1639 1640 -- If we fall through, pragma was misplaced 1641 1642 Pragma_Misplaced; 1643 end Check_Contract_Or_Test_Case; 1644 1645 ---------------------------- 1646 -- Check_Duplicate_Pragma -- 1647 ---------------------------- 1648 1649 procedure Check_Duplicate_Pragma (E : Entity_Id) is 1650 Id : Entity_Id := E; 1651 P : Node_Id; 1652 1653 begin 1654 -- Nothing to do if this pragma comes from an aspect specification, 1655 -- since we could not be duplicating a pragma, and we dealt with the 1656 -- case of duplicated aspects in Analyze_Aspect_Specifications. 1657 1658 if From_Aspect_Specification (N) then 1659 return; 1660 end if; 1661 1662 -- Otherwise current pragma may duplicate previous pragma or a 1663 -- previously given aspect specification or attribute definition 1664 -- clause for the same pragma. 1665 1666 P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False); 1667 1668 if Present (P) then 1669 Error_Msg_Name_1 := Pragma_Name (N); 1670 Error_Msg_Sloc := Sloc (P); 1671 1672 -- For a single protected or a single task object, the error is 1673 -- issued on the original entity. 1674 1675 if Ekind_In (Id, E_Task_Type, E_Protected_Type) then 1676 Id := Defining_Identifier (Original_Node (Parent (Id))); 1677 end if; 1678 1679 if Nkind (P) = N_Aspect_Specification 1680 or else From_Aspect_Specification (P) 1681 then 1682 Error_Msg_NE ("aspect% for & previously given#", N, Id); 1683 else 1684 Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); 1685 end if; 1686 1687 raise Pragma_Exit; 1688 end if; 1689 end Check_Duplicate_Pragma; 1690 1691 ---------------------------------- 1692 -- Check_Duplicated_Export_Name -- 1693 ---------------------------------- 1694 1695 procedure Check_Duplicated_Export_Name (Nam : Node_Id) is 1696 String_Val : constant String_Id := Strval (Nam); 1697 1698 begin 1699 -- We are only interested in the export case, and in the case of 1700 -- generics, it is the instance, not the template, that is the 1701 -- problem (the template will generate a warning in any case). 1702 1703 if not Inside_A_Generic 1704 and then (Prag_Id = Pragma_Export 1705 or else 1706 Prag_Id = Pragma_Export_Procedure 1707 or else 1708 Prag_Id = Pragma_Export_Valued_Procedure 1709 or else 1710 Prag_Id = Pragma_Export_Function) 1711 then 1712 for J in Externals.First .. Externals.Last loop 1713 if String_Equal (String_Val, Strval (Externals.Table (J))) then 1714 Error_Msg_Sloc := Sloc (Externals.Table (J)); 1715 Error_Msg_N ("external name duplicates name given#", Nam); 1716 exit; 1717 end if; 1718 end loop; 1719 1720 Externals.Append (Nam); 1721 end if; 1722 end Check_Duplicated_Export_Name; 1723 1724 ------------------------------------- 1725 -- Check_Expr_Is_Static_Expression -- 1726 ------------------------------------- 1727 1728 procedure Check_Expr_Is_Static_Expression 1729 (Expr : Node_Id; 1730 Typ : Entity_Id := Empty) 1731 is 1732 begin 1733 if Present (Typ) then 1734 Analyze_And_Resolve (Expr, Typ); 1735 else 1736 Analyze_And_Resolve (Expr); 1737 end if; 1738 1739 if Is_OK_Static_Expression (Expr) then 1740 return; 1741 1742 elsif Etype (Expr) = Any_Type then 1743 raise Pragma_Exit; 1744 1745 -- An interesting special case, if we have a string literal and we 1746 -- are in Ada 83 mode, then we allow it even though it will not be 1747 -- flagged as static. This allows the use of Ada 95 pragmas like 1748 -- Import in Ada 83 mode. They will of course be flagged with 1749 -- warnings as usual, but will not cause errors. 1750 1751 elsif Ada_Version = Ada_83 1752 and then Nkind (Expr) = N_String_Literal 1753 then 1754 return; 1755 1756 -- Static expression that raises Constraint_Error. This has already 1757 -- been flagged, so just exit from pragma processing. 1758 1759 elsif Is_Static_Expression (Expr) then 1760 raise Pragma_Exit; 1761 1762 -- Finally, we have a real error 1763 1764 else 1765 Error_Msg_Name_1 := Pname; 1766 1767 declare 1768 Msg : String := 1769 "argument for pragma% must be a static expression!"; 1770 begin 1771 Fix_Error (Msg); 1772 Flag_Non_Static_Expr (Msg, Expr); 1773 end; 1774 1775 raise Pragma_Exit; 1776 end if; 1777 end Check_Expr_Is_Static_Expression; 1778 1779 ------------------------- 1780 -- Check_First_Subtype -- 1781 ------------------------- 1782 1783 procedure Check_First_Subtype (Arg : Node_Id) is 1784 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 1785 Ent : constant Entity_Id := Entity (Argx); 1786 1787 begin 1788 if Is_First_Subtype (Ent) then 1789 null; 1790 1791 elsif Is_Type (Ent) then 1792 Error_Pragma_Arg 1793 ("pragma% cannot apply to subtype", Argx); 1794 1795 elsif Is_Object (Ent) then 1796 Error_Pragma_Arg 1797 ("pragma% cannot apply to object, requires a type", Argx); 1798 1799 else 1800 Error_Pragma_Arg 1801 ("pragma% cannot apply to&, requires a type", Argx); 1802 end if; 1803 end Check_First_Subtype; 1804 1805 ---------------------- 1806 -- Check_Identifier -- 1807 ---------------------- 1808 1809 procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is 1810 begin 1811 if Present (Arg) 1812 and then Nkind (Arg) = N_Pragma_Argument_Association 1813 then 1814 if Chars (Arg) = No_Name or else Chars (Arg) /= Id then 1815 Error_Msg_Name_1 := Pname; 1816 Error_Msg_Name_2 := Id; 1817 Error_Msg_N ("pragma% argument expects identifier%", Arg); 1818 raise Pragma_Exit; 1819 end if; 1820 end if; 1821 end Check_Identifier; 1822 1823 -------------------------------- 1824 -- Check_Identifier_Is_One_Of -- 1825 -------------------------------- 1826 1827 procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is 1828 begin 1829 if Present (Arg) 1830 and then Nkind (Arg) = N_Pragma_Argument_Association 1831 then 1832 if Chars (Arg) = No_Name then 1833 Error_Msg_Name_1 := Pname; 1834 Error_Msg_N ("pragma% argument expects an identifier", Arg); 1835 raise Pragma_Exit; 1836 1837 elsif Chars (Arg) /= N1 1838 and then Chars (Arg) /= N2 1839 then 1840 Error_Msg_Name_1 := Pname; 1841 Error_Msg_N ("invalid identifier for pragma% argument", Arg); 1842 raise Pragma_Exit; 1843 end if; 1844 end if; 1845 end Check_Identifier_Is_One_Of; 1846 1847 --------------------------- 1848 -- Check_In_Main_Program -- 1849 --------------------------- 1850 1851 procedure Check_In_Main_Program is 1852 P : constant Node_Id := Parent (N); 1853 1854 begin 1855 -- Must be at in subprogram body 1856 1857 if Nkind (P) /= N_Subprogram_Body then 1858 Error_Pragma ("% pragma allowed only in subprogram"); 1859 1860 -- Otherwise warn if obviously not main program 1861 1862 elsif Present (Parameter_Specifications (Specification (P))) 1863 or else not Is_Compilation_Unit (Defining_Entity (P)) 1864 then 1865 Error_Msg_Name_1 := Pname; 1866 Error_Msg_N 1867 ("??pragma% is only effective in main program", N); 1868 end if; 1869 end Check_In_Main_Program; 1870 1871 --------------------------------------- 1872 -- Check_Interrupt_Or_Attach_Handler -- 1873 --------------------------------------- 1874 1875 procedure Check_Interrupt_Or_Attach_Handler is 1876 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); 1877 Handler_Proc, Proc_Scope : Entity_Id; 1878 1879 begin 1880 Analyze (Arg1_X); 1881 1882 if Prag_Id = Pragma_Interrupt_Handler then 1883 Check_Restriction (No_Dynamic_Attachment, N); 1884 end if; 1885 1886 Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 1887 Proc_Scope := Scope (Handler_Proc); 1888 1889 -- On AAMP only, a pragma Interrupt_Handler is supported for 1890 -- nonprotected parameterless procedures. 1891 1892 if not AAMP_On_Target 1893 or else Prag_Id = Pragma_Attach_Handler 1894 then 1895 if Ekind (Proc_Scope) /= E_Protected_Type then 1896 Error_Pragma_Arg 1897 ("argument of pragma% must be protected procedure", Arg1); 1898 end if; 1899 1900 if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then 1901 Error_Pragma ("pragma% must be in protected definition"); 1902 end if; 1903 end if; 1904 1905 if not Is_Library_Level_Entity (Proc_Scope) 1906 or else (AAMP_On_Target 1907 and then not Is_Library_Level_Entity (Handler_Proc)) 1908 then 1909 Error_Pragma_Arg 1910 ("argument for pragma% must be library level entity", Arg1); 1911 end if; 1912 1913 -- AI05-0033: A pragma cannot appear within a generic body, because 1914 -- instance can be in a nested scope. The check that protected type 1915 -- is itself a library-level declaration is done elsewhere. 1916 1917 -- Note: we omit this check in Codepeer mode to properly handle code 1918 -- prior to AI-0033 (pragmas don't matter to codepeer in any case). 1919 1920 if Inside_A_Generic then 1921 if Ekind (Scope (Current_Scope)) = E_Generic_Package 1922 and then In_Package_Body (Scope (Current_Scope)) 1923 and then not CodePeer_Mode 1924 then 1925 Error_Pragma ("pragma% cannot be used inside a generic"); 1926 end if; 1927 end if; 1928 end Check_Interrupt_Or_Attach_Handler; 1929 1930 --------------------------------- 1931 -- Check_Loop_Pragma_Placement -- 1932 --------------------------------- 1933 1934 procedure Check_Loop_Pragma_Placement is 1935 procedure Placement_Error (Constr : Node_Id); 1936 pragma No_Return (Placement_Error); 1937 -- Node Constr denotes the last loop restricted construct before we 1938 -- encountered an illegal relation between enclosing constructs. Emit 1939 -- an error depending on what Constr was. 1940 1941 --------------------- 1942 -- Placement_Error -- 1943 --------------------- 1944 1945 procedure Placement_Error (Constr : Node_Id) is 1946 begin 1947 if Nkind (Constr) = N_Pragma then 1948 Error_Pragma 1949 ("pragma % must appear immediately within the statements " & 1950 "of a loop"); 1951 else 1952 Error_Pragma_Arg 1953 ("block containing pragma % must appear immediately within " & 1954 "the statements of a loop", Constr); 1955 end if; 1956 end Placement_Error; 1957 1958 -- Local declarations 1959 1960 Prev : Node_Id; 1961 Stmt : Node_Id; 1962 1963 -- Start of processing for Check_Loop_Pragma_Placement 1964 1965 begin 1966 Prev := N; 1967 Stmt := Parent (N); 1968 while Present (Stmt) loop 1969 1970 -- The pragma or previous block must appear immediately within the 1971 -- current block's declarative or statement part. 1972 1973 if Nkind (Stmt) = N_Block_Statement then 1974 if (No (Declarations (Stmt)) 1975 or else List_Containing (Prev) /= Declarations (Stmt)) 1976 and then 1977 List_Containing (Prev) /= 1978 Statements (Handled_Statement_Sequence (Stmt)) 1979 then 1980 Placement_Error (Prev); 1981 return; 1982 1983 -- Keep inspecting the parents because we are now within a 1984 -- chain of nested blocks. 1985 1986 else 1987 Prev := Stmt; 1988 Stmt := Parent (Stmt); 1989 end if; 1990 1991 -- The pragma or previous block must appear immediately within the 1992 -- statements of the loop. 1993 1994 elsif Nkind (Stmt) = N_Loop_Statement then 1995 if List_Containing (Prev) /= Statements (Stmt) then 1996 Placement_Error (Prev); 1997 end if; 1998 1999 -- Stop the traversal because we reached the innermost loop 2000 -- regardless of whether we encountered an error or not. 2001 2002 return; 2003 2004 -- Ignore a handled statement sequence. Note that this node may 2005 -- be related to a subprogram body in which case we will emit an 2006 -- error on the next iteration of the search. 2007 2008 elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then 2009 Stmt := Parent (Stmt); 2010 2011 -- Any other statement breaks the chain from the pragma to the 2012 -- loop. 2013 2014 else 2015 Placement_Error (Prev); 2016 return; 2017 end if; 2018 end loop; 2019 end Check_Loop_Pragma_Placement; 2020 2021 ------------------------------------------- 2022 -- Check_Is_In_Decl_Part_Or_Package_Spec -- 2023 ------------------------------------------- 2024 2025 procedure Check_Is_In_Decl_Part_Or_Package_Spec is 2026 P : Node_Id; 2027 2028 begin 2029 P := Parent (N); 2030 loop 2031 if No (P) then 2032 exit; 2033 2034 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then 2035 exit; 2036 2037 elsif Nkind_In (P, N_Package_Specification, 2038 N_Block_Statement) 2039 then 2040 return; 2041 2042 -- Note: the following tests seem a little peculiar, because 2043 -- they test for bodies, but if we were in the statement part 2044 -- of the body, we would already have hit the handled statement 2045 -- sequence, so the only way we get here is by being in the 2046 -- declarative part of the body. 2047 2048 elsif Nkind_In (P, N_Subprogram_Body, 2049 N_Package_Body, 2050 N_Task_Body, 2051 N_Entry_Body) 2052 then 2053 return; 2054 end if; 2055 2056 P := Parent (P); 2057 end loop; 2058 2059 Error_Pragma ("pragma% is not in declarative part or package spec"); 2060 end Check_Is_In_Decl_Part_Or_Package_Spec; 2061 2062 ------------------------- 2063 -- Check_No_Identifier -- 2064 ------------------------- 2065 2066 procedure Check_No_Identifier (Arg : Node_Id) is 2067 begin 2068 if Nkind (Arg) = N_Pragma_Argument_Association 2069 and then Chars (Arg) /= No_Name 2070 then 2071 Error_Pragma_Arg_Ident 2072 ("pragma% does not permit identifier& here", Arg); 2073 end if; 2074 end Check_No_Identifier; 2075 2076 -------------------------- 2077 -- Check_No_Identifiers -- 2078 -------------------------- 2079 2080 procedure Check_No_Identifiers is 2081 Arg_Node : Node_Id; 2082 begin 2083 if Arg_Count > 0 then 2084 Arg_Node := Arg1; 2085 while Present (Arg_Node) loop 2086 Check_No_Identifier (Arg_Node); 2087 Next (Arg_Node); 2088 end loop; 2089 end if; 2090 end Check_No_Identifiers; 2091 2092 ------------------------ 2093 -- Check_No_Link_Name -- 2094 ------------------------ 2095 2096 procedure Check_No_Link_Name is 2097 begin 2098 if Present (Arg3) 2099 and then Chars (Arg3) = Name_Link_Name 2100 then 2101 Arg4 := Arg3; 2102 end if; 2103 2104 if Present (Arg4) then 2105 Error_Pragma_Arg 2106 ("Link_Name argument not allowed for Import Intrinsic", Arg4); 2107 end if; 2108 end Check_No_Link_Name; 2109 2110 ------------------------------- 2111 -- Check_Optional_Identifier -- 2112 ------------------------------- 2113 2114 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 2115 begin 2116 if Present (Arg) 2117 and then Nkind (Arg) = N_Pragma_Argument_Association 2118 and then Chars (Arg) /= No_Name 2119 then 2120 if Chars (Arg) /= Id then 2121 Error_Msg_Name_1 := Pname; 2122 Error_Msg_Name_2 := Id; 2123 Error_Msg_N ("pragma% argument expects identifier%", Arg); 2124 raise Pragma_Exit; 2125 end if; 2126 end if; 2127 end Check_Optional_Identifier; 2128 2129 procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is 2130 begin 2131 Name_Buffer (1 .. Id'Length) := Id; 2132 Name_Len := Id'Length; 2133 Check_Optional_Identifier (Arg, Name_Find); 2134 end Check_Optional_Identifier; 2135 2136 -------------------------------------- 2137 -- Check_Precondition_Postcondition -- 2138 -------------------------------------- 2139 2140 procedure Check_Precondition_Postcondition (In_Body : out Boolean) is 2141 P : Node_Id; 2142 PO : Node_Id; 2143 2144 procedure Chain_PPC (PO : Node_Id); 2145 -- If PO is an entry or a [generic] subprogram declaration node, then 2146 -- the precondition/postcondition applies to this subprogram and the 2147 -- processing for the pragma is completed. Otherwise the pragma is 2148 -- misplaced. 2149 2150 --------------- 2151 -- Chain_PPC -- 2152 --------------- 2153 2154 procedure Chain_PPC (PO : Node_Id) is 2155 S : Entity_Id; 2156 2157 begin 2158 if Nkind (PO) = N_Abstract_Subprogram_Declaration then 2159 if not From_Aspect_Specification (N) then 2160 Error_Pragma 2161 ("pragma% cannot be applied to abstract subprogram"); 2162 2163 elsif Class_Present (N) then 2164 null; 2165 2166 else 2167 Error_Pragma 2168 ("aspect % requires ''Class for abstract subprogram"); 2169 end if; 2170 2171 -- AI05-0230: The same restriction applies to null procedures. For 2172 -- compatibility with earlier uses of the Ada pragma, apply this 2173 -- rule only to aspect specifications. 2174 2175 -- The above discrpency needs documentation. Robert is dubious 2176 -- about whether it is a good idea ??? 2177 2178 elsif Nkind (PO) = N_Subprogram_Declaration 2179 and then Nkind (Specification (PO)) = N_Procedure_Specification 2180 and then Null_Present (Specification (PO)) 2181 and then From_Aspect_Specification (N) 2182 and then not Class_Present (N) 2183 then 2184 Error_Pragma 2185 ("aspect % requires ''Class for null procedure"); 2186 2187 -- Pre/postconditions are legal on a subprogram body if it is not 2188 -- a completion of a declaration. 2189 2190 elsif Nkind (PO) = N_Subprogram_Body 2191 and then Acts_As_Spec (PO) 2192 then 2193 null; 2194 2195 elsif not Nkind_In (PO, N_Subprogram_Declaration, 2196 N_Expression_Function, 2197 N_Generic_Subprogram_Declaration, 2198 N_Entry_Declaration) 2199 then 2200 Pragma_Misplaced; 2201 end if; 2202 2203 -- Here if we have [generic] subprogram or entry declaration 2204 2205 if Nkind (PO) = N_Entry_Declaration then 2206 S := Defining_Entity (PO); 2207 else 2208 S := Defining_Unit_Name (Specification (PO)); 2209 2210 if Nkind (S) = N_Defining_Program_Unit_Name then 2211 S := Defining_Identifier (S); 2212 end if; 2213 end if; 2214 2215 -- Note: we do not analyze the pragma at this point. Instead we 2216 -- delay this analysis until the end of the declarative part in 2217 -- which the pragma appears. This implements the required delay 2218 -- in this analysis, allowing forward references. The analysis 2219 -- happens at the end of Analyze_Declarations. 2220 2221 -- Chain spec PPC pragma to list for subprogram 2222 2223 Set_Next_Pragma (N, Spec_PPC_List (Contract (S))); 2224 Set_Spec_PPC_List (Contract (S), N); 2225 2226 -- Return indicating spec case 2227 2228 In_Body := False; 2229 return; 2230 end Chain_PPC; 2231 2232 -- Start of processing for Check_Precondition_Postcondition 2233 2234 begin 2235 if not Is_List_Member (N) then 2236 Pragma_Misplaced; 2237 end if; 2238 2239 -- Preanalyze message argument if present. Visibility in this 2240 -- argument is established at the point of pragma occurrence. 2241 2242 if Arg_Count = 2 then 2243 Check_Optional_Identifier (Arg2, Name_Message); 2244 Preanalyze_Spec_Expression 2245 (Get_Pragma_Arg (Arg2), Standard_String); 2246 end if; 2247 2248 -- For a pragma PPC in the extended main source unit, record enabled 2249 -- status in SCO. 2250 2251 -- This may seem redundant with the call to Check_Enabled occurring 2252 -- later on when the pragma is rewritten into a pragma Check but 2253 -- is actually required in the case of a postcondition within a 2254 -- generic. 2255 2256 if Check_Enabled (Pname) and then not Split_PPC (N) then 2257 Set_SCO_Pragma_Enabled (Loc); 2258 end if; 2259 2260 -- If we are within an inlined body, the legality of the pragma 2261 -- has been checked already. 2262 2263 if In_Inlined_Body then 2264 In_Body := True; 2265 return; 2266 end if; 2267 2268 -- Search prior declarations 2269 2270 P := N; 2271 while Present (Prev (P)) loop 2272 P := Prev (P); 2273 2274 -- If the previous node is a generic subprogram, do not go to to 2275 -- the original node, which is the unanalyzed tree: we need to 2276 -- attach the pre/postconditions to the analyzed version at this 2277 -- point. They get propagated to the original tree when analyzing 2278 -- the corresponding body. 2279 2280 if Nkind (P) not in N_Generic_Declaration then 2281 PO := Original_Node (P); 2282 else 2283 PO := P; 2284 end if; 2285 2286 -- Skip past prior pragma 2287 2288 if Nkind (PO) = N_Pragma then 2289 null; 2290 2291 -- Skip stuff not coming from source 2292 2293 elsif not Comes_From_Source (PO) then 2294 2295 -- The condition may apply to a subprogram instantiation 2296 2297 if Nkind (PO) = N_Subprogram_Declaration 2298 and then Present (Generic_Parent (Specification (PO))) 2299 then 2300 Chain_PPC (PO); 2301 return; 2302 2303 elsif Nkind (PO) = N_Subprogram_Declaration 2304 and then In_Instance 2305 then 2306 Chain_PPC (PO); 2307 return; 2308 2309 -- For all other cases of non source code, do nothing 2310 2311 else 2312 null; 2313 end if; 2314 2315 -- Only remaining possibility is subprogram declaration 2316 2317 else 2318 Chain_PPC (PO); 2319 return; 2320 end if; 2321 end loop; 2322 2323 -- If we fall through loop, pragma is at start of list, so see if it 2324 -- is at the start of declarations of a subprogram body. 2325 2326 if Nkind (Parent (N)) = N_Subprogram_Body 2327 and then List_Containing (N) = Declarations (Parent (N)) 2328 then 2329 if Operating_Mode /= Generate_Code 2330 or else Inside_A_Generic 2331 then 2332 -- Analyze pragma expression for correctness and for ASIS use 2333 2334 Preanalyze_Assert_Expression 2335 (Get_Pragma_Arg (Arg1), Standard_Boolean); 2336 2337 -- In ASIS mode, for a pragma generated from a source aspect, 2338 -- also analyze the original aspect expression. 2339 2340 if ASIS_Mode 2341 and then Present (Corresponding_Aspect (N)) 2342 then 2343 Preanalyze_Assert_Expression 2344 (Expression (Corresponding_Aspect (N)), Standard_Boolean); 2345 end if; 2346 end if; 2347 2348 In_Body := True; 2349 return; 2350 2351 -- See if it is in the pragmas after a library level subprogram 2352 2353 elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then 2354 2355 -- In formal verification mode, analyze pragma expression for 2356 -- correctness, as it is not expanded later. 2357 2358 if Alfa_Mode then 2359 Analyze_PPC_In_Decl_Part 2360 (N, Defining_Entity (Unit (Parent (Parent (N))))); 2361 end if; 2362 2363 Chain_PPC (Unit (Parent (Parent (N)))); 2364 return; 2365 end if; 2366 2367 -- If we fall through, pragma was misplaced 2368 2369 Pragma_Misplaced; 2370 end Check_Precondition_Postcondition; 2371 2372 ----------------------------- 2373 -- Check_Static_Constraint -- 2374 ----------------------------- 2375 2376 -- Note: for convenience in writing this procedure, in addition to 2377 -- the officially (i.e. by spec) allowed argument which is always a 2378 -- constraint, it also allows ranges and discriminant associations. 2379 -- Above is not clear ??? 2380 2381 procedure Check_Static_Constraint (Constr : Node_Id) is 2382 2383 procedure Require_Static (E : Node_Id); 2384 -- Require given expression to be static expression 2385 2386 -------------------- 2387 -- Require_Static -- 2388 -------------------- 2389 2390 procedure Require_Static (E : Node_Id) is 2391 begin 2392 if not Is_OK_Static_Expression (E) then 2393 Flag_Non_Static_Expr 2394 ("non-static constraint not allowed in Unchecked_Union!", E); 2395 raise Pragma_Exit; 2396 end if; 2397 end Require_Static; 2398 2399 -- Start of processing for Check_Static_Constraint 2400 2401 begin 2402 case Nkind (Constr) is 2403 when N_Discriminant_Association => 2404 Require_Static (Expression (Constr)); 2405 2406 when N_Range => 2407 Require_Static (Low_Bound (Constr)); 2408 Require_Static (High_Bound (Constr)); 2409 2410 when N_Attribute_Reference => 2411 Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); 2412 Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); 2413 2414 when N_Range_Constraint => 2415 Check_Static_Constraint (Range_Expression (Constr)); 2416 2417 when N_Index_Or_Discriminant_Constraint => 2418 declare 2419 IDC : Entity_Id; 2420 begin 2421 IDC := First (Constraints (Constr)); 2422 while Present (IDC) loop 2423 Check_Static_Constraint (IDC); 2424 Next (IDC); 2425 end loop; 2426 end; 2427 2428 when others => 2429 null; 2430 end case; 2431 end Check_Static_Constraint; 2432 2433 -------------------------------------- 2434 -- Check_Valid_Configuration_Pragma -- 2435 -------------------------------------- 2436 2437 -- A configuration pragma must appear in the context clause of a 2438 -- compilation unit, and only other pragmas may precede it. Note that 2439 -- the test also allows use in a configuration pragma file. 2440 2441 procedure Check_Valid_Configuration_Pragma is 2442 begin 2443 if not Is_Configuration_Pragma then 2444 Error_Pragma ("incorrect placement for configuration pragma%"); 2445 end if; 2446 end Check_Valid_Configuration_Pragma; 2447 2448 ------------------------------------- 2449 -- Check_Valid_Library_Unit_Pragma -- 2450 ------------------------------------- 2451 2452 procedure Check_Valid_Library_Unit_Pragma is 2453 Plist : List_Id; 2454 Parent_Node : Node_Id; 2455 Unit_Name : Entity_Id; 2456 Unit_Kind : Node_Kind; 2457 Unit_Node : Node_Id; 2458 Sindex : Source_File_Index; 2459 2460 begin 2461 if not Is_List_Member (N) then 2462 Pragma_Misplaced; 2463 2464 else 2465 Plist := List_Containing (N); 2466 Parent_Node := Parent (Plist); 2467 2468 if Parent_Node = Empty then 2469 Pragma_Misplaced; 2470 2471 -- Case of pragma appearing after a compilation unit. In this case 2472 -- it must have an argument with the corresponding name and must 2473 -- be part of the following pragmas of its parent. 2474 2475 elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then 2476 if Plist /= Pragmas_After (Parent_Node) then 2477 Pragma_Misplaced; 2478 2479 elsif Arg_Count = 0 then 2480 Error_Pragma 2481 ("argument required if outside compilation unit"); 2482 2483 else 2484 Check_No_Identifiers; 2485 Check_Arg_Count (1); 2486 Unit_Node := Unit (Parent (Parent_Node)); 2487 Unit_Kind := Nkind (Unit_Node); 2488 2489 Analyze (Get_Pragma_Arg (Arg1)); 2490 2491 if Unit_Kind = N_Generic_Subprogram_Declaration 2492 or else Unit_Kind = N_Subprogram_Declaration 2493 then 2494 Unit_Name := Defining_Entity (Unit_Node); 2495 2496 elsif Unit_Kind in N_Generic_Instantiation then 2497 Unit_Name := Defining_Entity (Unit_Node); 2498 2499 else 2500 Unit_Name := Cunit_Entity (Current_Sem_Unit); 2501 end if; 2502 2503 if Chars (Unit_Name) /= 2504 Chars (Entity (Get_Pragma_Arg (Arg1))) 2505 then 2506 Error_Pragma_Arg 2507 ("pragma% argument is not current unit name", Arg1); 2508 end if; 2509 2510 if Ekind (Unit_Name) = E_Package 2511 and then Present (Renamed_Entity (Unit_Name)) 2512 then 2513 Error_Pragma ("pragma% not allowed for renamed package"); 2514 end if; 2515 end if; 2516 2517 -- Pragma appears other than after a compilation unit 2518 2519 else 2520 -- Here we check for the generic instantiation case and also 2521 -- for the case of processing a generic formal package. We 2522 -- detect these cases by noting that the Sloc on the node 2523 -- does not belong to the current compilation unit. 2524 2525 Sindex := Source_Index (Current_Sem_Unit); 2526 2527 if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then 2528 Rewrite (N, Make_Null_Statement (Loc)); 2529 return; 2530 2531 -- If before first declaration, the pragma applies to the 2532 -- enclosing unit, and the name if present must be this name. 2533 2534 elsif Is_Before_First_Decl (N, Plist) then 2535 Unit_Node := Unit_Declaration_Node (Current_Scope); 2536 Unit_Kind := Nkind (Unit_Node); 2537 2538 if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then 2539 Pragma_Misplaced; 2540 2541 elsif Unit_Kind = N_Subprogram_Body 2542 and then not Acts_As_Spec (Unit_Node) 2543 then 2544 Pragma_Misplaced; 2545 2546 elsif Nkind (Parent_Node) = N_Package_Body then 2547 Pragma_Misplaced; 2548 2549 elsif Nkind (Parent_Node) = N_Package_Specification 2550 and then Plist = Private_Declarations (Parent_Node) 2551 then 2552 Pragma_Misplaced; 2553 2554 elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration 2555 or else Nkind (Parent_Node) = 2556 N_Generic_Subprogram_Declaration) 2557 and then Plist = Generic_Formal_Declarations (Parent_Node) 2558 then 2559 Pragma_Misplaced; 2560 2561 elsif Arg_Count > 0 then 2562 Analyze (Get_Pragma_Arg (Arg1)); 2563 2564 if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then 2565 Error_Pragma_Arg 2566 ("name in pragma% must be enclosing unit", Arg1); 2567 end if; 2568 2569 -- It is legal to have no argument in this context 2570 2571 else 2572 return; 2573 end if; 2574 2575 -- Error if not before first declaration. This is because a 2576 -- library unit pragma argument must be the name of a library 2577 -- unit (RM 10.1.5(7)), but the only names permitted in this 2578 -- context are (RM 10.1.5(6)) names of subprogram declarations, 2579 -- generic subprogram declarations or generic instantiations. 2580 2581 else 2582 Error_Pragma 2583 ("pragma% misplaced, must be before first declaration"); 2584 end if; 2585 end if; 2586 end if; 2587 end Check_Valid_Library_Unit_Pragma; 2588 2589 ------------------- 2590 -- Check_Variant -- 2591 ------------------- 2592 2593 procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is 2594 Clist : constant Node_Id := Component_List (Variant); 2595 Comp : Node_Id; 2596 2597 begin 2598 Comp := First (Component_Items (Clist)); 2599 while Present (Comp) loop 2600 Check_Component (Comp, UU_Typ, In_Variant_Part => True); 2601 Next (Comp); 2602 end loop; 2603 end Check_Variant; 2604 2605 ------------------ 2606 -- Error_Pragma -- 2607 ------------------ 2608 2609 procedure Error_Pragma (Msg : String) is 2610 MsgF : String := Msg; 2611 begin 2612 Error_Msg_Name_1 := Pname; 2613 Fix_Error (MsgF); 2614 Error_Msg_N (MsgF, N); 2615 raise Pragma_Exit; 2616 end Error_Pragma; 2617 2618 ---------------------- 2619 -- Error_Pragma_Arg -- 2620 ---------------------- 2621 2622 procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is 2623 MsgF : String := Msg; 2624 begin 2625 Error_Msg_Name_1 := Pname; 2626 Fix_Error (MsgF); 2627 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); 2628 raise Pragma_Exit; 2629 end Error_Pragma_Arg; 2630 2631 procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is 2632 MsgF : String := Msg1; 2633 begin 2634 Error_Msg_Name_1 := Pname; 2635 Fix_Error (MsgF); 2636 Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); 2637 Error_Pragma_Arg (Msg2, Arg); 2638 end Error_Pragma_Arg; 2639 2640 ---------------------------- 2641 -- Error_Pragma_Arg_Ident -- 2642 ---------------------------- 2643 2644 procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is 2645 MsgF : String := Msg; 2646 begin 2647 Error_Msg_Name_1 := Pname; 2648 Fix_Error (MsgF); 2649 Error_Msg_N (MsgF, Arg); 2650 raise Pragma_Exit; 2651 end Error_Pragma_Arg_Ident; 2652 2653 ---------------------- 2654 -- Error_Pragma_Ref -- 2655 ---------------------- 2656 2657 procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is 2658 MsgF : String := Msg; 2659 begin 2660 Error_Msg_Name_1 := Pname; 2661 Fix_Error (MsgF); 2662 Error_Msg_Sloc := Sloc (Ref); 2663 Error_Msg_NE (MsgF, N, Ref); 2664 raise Pragma_Exit; 2665 end Error_Pragma_Ref; 2666 2667 ------------------------ 2668 -- Find_Lib_Unit_Name -- 2669 ------------------------ 2670 2671 function Find_Lib_Unit_Name return Entity_Id is 2672 begin 2673 -- Return inner compilation unit entity, for case of nested 2674 -- categorization pragmas. This happens in generic unit. 2675 2676 if Nkind (Parent (N)) = N_Package_Specification 2677 and then Defining_Entity (Parent (N)) /= Current_Scope 2678 then 2679 return Defining_Entity (Parent (N)); 2680 else 2681 return Current_Scope; 2682 end if; 2683 end Find_Lib_Unit_Name; 2684 2685 ---------------------------- 2686 -- Find_Program_Unit_Name -- 2687 ---------------------------- 2688 2689 procedure Find_Program_Unit_Name (Id : Node_Id) is 2690 Unit_Name : Entity_Id; 2691 Unit_Kind : Node_Kind; 2692 P : constant Node_Id := Parent (N); 2693 2694 begin 2695 if Nkind (P) = N_Compilation_Unit then 2696 Unit_Kind := Nkind (Unit (P)); 2697 2698 if Unit_Kind = N_Subprogram_Declaration 2699 or else Unit_Kind = N_Package_Declaration 2700 or else Unit_Kind in N_Generic_Declaration 2701 then 2702 Unit_Name := Defining_Entity (Unit (P)); 2703 2704 if Chars (Id) = Chars (Unit_Name) then 2705 Set_Entity (Id, Unit_Name); 2706 Set_Etype (Id, Etype (Unit_Name)); 2707 else 2708 Set_Etype (Id, Any_Type); 2709 Error_Pragma 2710 ("cannot find program unit referenced by pragma%"); 2711 end if; 2712 2713 else 2714 Set_Etype (Id, Any_Type); 2715 Error_Pragma ("pragma% inapplicable to this unit"); 2716 end if; 2717 2718 else 2719 Analyze (Id); 2720 end if; 2721 end Find_Program_Unit_Name; 2722 2723 ----------------------------------------- 2724 -- Find_Unique_Parameterless_Procedure -- 2725 ----------------------------------------- 2726 2727 function Find_Unique_Parameterless_Procedure 2728 (Name : Entity_Id; 2729 Arg : Node_Id) return Entity_Id 2730 is 2731 Proc : Entity_Id := Empty; 2732 2733 begin 2734 -- The body of this procedure needs some comments ??? 2735 2736 if not Is_Entity_Name (Name) then 2737 Error_Pragma_Arg 2738 ("argument of pragma% must be entity name", Arg); 2739 2740 elsif not Is_Overloaded (Name) then 2741 Proc := Entity (Name); 2742 2743 if Ekind (Proc) /= E_Procedure 2744 or else Present (First_Formal (Proc)) 2745 then 2746 Error_Pragma_Arg 2747 ("argument of pragma% must be parameterless procedure", Arg); 2748 end if; 2749 2750 else 2751 declare 2752 Found : Boolean := False; 2753 It : Interp; 2754 Index : Interp_Index; 2755 2756 begin 2757 Get_First_Interp (Name, Index, It); 2758 while Present (It.Nam) loop 2759 Proc := It.Nam; 2760 2761 if Ekind (Proc) = E_Procedure 2762 and then No (First_Formal (Proc)) 2763 then 2764 if not Found then 2765 Found := True; 2766 Set_Entity (Name, Proc); 2767 Set_Is_Overloaded (Name, False); 2768 else 2769 Error_Pragma_Arg 2770 ("ambiguous handler name for pragma% ", Arg); 2771 end if; 2772 end if; 2773 2774 Get_Next_Interp (Index, It); 2775 end loop; 2776 2777 if not Found then 2778 Error_Pragma_Arg 2779 ("argument of pragma% must be parameterless procedure", 2780 Arg); 2781 else 2782 Proc := Entity (Name); 2783 end if; 2784 end; 2785 end if; 2786 2787 return Proc; 2788 end Find_Unique_Parameterless_Procedure; 2789 2790 --------------- 2791 -- Fix_Error -- 2792 --------------- 2793 2794 procedure Fix_Error (Msg : in out String) is 2795 begin 2796 if From_Aspect_Specification (N) then 2797 for J in Msg'First .. Msg'Last - 5 loop 2798 if Msg (J .. J + 5) = "pragma" then 2799 Msg (J .. J + 5) := "aspect"; 2800 end if; 2801 end loop; 2802 2803 if Error_Msg_Name_1 = Name_Precondition then 2804 Error_Msg_Name_1 := Name_Pre; 2805 elsif Error_Msg_Name_1 = Name_Postcondition then 2806 Error_Msg_Name_1 := Name_Post; 2807 end if; 2808 end if; 2809 end Fix_Error; 2810 2811 ------------------------- 2812 -- Gather_Associations -- 2813 ------------------------- 2814 2815 procedure Gather_Associations 2816 (Names : Name_List; 2817 Args : out Args_List) 2818 is 2819 Arg : Node_Id; 2820 2821 begin 2822 -- Initialize all parameters to Empty 2823 2824 for J in Args'Range loop 2825 Args (J) := Empty; 2826 end loop; 2827 2828 -- That's all we have to do if there are no argument associations 2829 2830 if No (Pragma_Argument_Associations (N)) then 2831 return; 2832 end if; 2833 2834 -- Otherwise first deal with any positional parameters present 2835 2836 Arg := First (Pragma_Argument_Associations (N)); 2837 for Index in Args'Range loop 2838 exit when No (Arg) or else Chars (Arg) /= No_Name; 2839 Args (Index) := Get_Pragma_Arg (Arg); 2840 Next (Arg); 2841 end loop; 2842 2843 -- Positional parameters all processed, if any left, then we 2844 -- have too many positional parameters. 2845 2846 if Present (Arg) and then Chars (Arg) = No_Name then 2847 Error_Pragma_Arg 2848 ("too many positional associations for pragma%", Arg); 2849 end if; 2850 2851 -- Process named parameters if any are present 2852 2853 while Present (Arg) loop 2854 if Chars (Arg) = No_Name then 2855 Error_Pragma_Arg 2856 ("positional association cannot follow named association", 2857 Arg); 2858 2859 else 2860 for Index in Names'Range loop 2861 if Names (Index) = Chars (Arg) then 2862 if Present (Args (Index)) then 2863 Error_Pragma_Arg 2864 ("duplicate argument association for pragma%", Arg); 2865 else 2866 Args (Index) := Get_Pragma_Arg (Arg); 2867 exit; 2868 end if; 2869 end if; 2870 2871 if Index = Names'Last then 2872 Error_Msg_Name_1 := Pname; 2873 Error_Msg_N ("pragma% does not allow & argument", Arg); 2874 2875 -- Check for possible misspelling 2876 2877 for Index1 in Names'Range loop 2878 if Is_Bad_Spelling_Of 2879 (Chars (Arg), Names (Index1)) 2880 then 2881 Error_Msg_Name_1 := Names (Index1); 2882 Error_Msg_N -- CODEFIX 2883 ("\possible misspelling of%", Arg); 2884 exit; 2885 end if; 2886 end loop; 2887 2888 raise Pragma_Exit; 2889 end if; 2890 end loop; 2891 end if; 2892 2893 Next (Arg); 2894 end loop; 2895 end Gather_Associations; 2896 2897 ----------------- 2898 -- GNAT_Pragma -- 2899 ----------------- 2900 2901 procedure GNAT_Pragma is 2902 begin 2903 -- We need to check the No_Implementation_Pragmas restriction for 2904 -- the case of a pragma from source. Note that the case of aspects 2905 -- generating corresponding pragmas marks these pragmas as not being 2906 -- from source, so this test also catches that case. 2907 2908 if Comes_From_Source (N) then 2909 Check_Restriction (No_Implementation_Pragmas, N); 2910 end if; 2911 end GNAT_Pragma; 2912 2913 -------------------------- 2914 -- Is_Before_First_Decl -- 2915 -------------------------- 2916 2917 function Is_Before_First_Decl 2918 (Pragma_Node : Node_Id; 2919 Decls : List_Id) return Boolean 2920 is 2921 Item : Node_Id := First (Decls); 2922 2923 begin 2924 -- Only other pragmas can come before this pragma 2925 2926 loop 2927 if No (Item) or else Nkind (Item) /= N_Pragma then 2928 return False; 2929 2930 elsif Item = Pragma_Node then 2931 return True; 2932 end if; 2933 2934 Next (Item); 2935 end loop; 2936 end Is_Before_First_Decl; 2937 2938 ----------------------------- 2939 -- Is_Configuration_Pragma -- 2940 ----------------------------- 2941 2942 -- A configuration pragma must appear in the context clause of a 2943 -- compilation unit, and only other pragmas may precede it. Note that 2944 -- the test below also permits use in a configuration pragma file. 2945 2946 function Is_Configuration_Pragma return Boolean is 2947 Lis : constant List_Id := List_Containing (N); 2948 Par : constant Node_Id := Parent (N); 2949 Prg : Node_Id; 2950 2951 begin 2952 -- If no parent, then we are in the configuration pragma file, 2953 -- so the placement is definitely appropriate. 2954 2955 if No (Par) then 2956 return True; 2957 2958 -- Otherwise we must be in the context clause of a compilation unit 2959 -- and the only thing allowed before us in the context list is more 2960 -- configuration pragmas. 2961 2962 elsif Nkind (Par) = N_Compilation_Unit 2963 and then Context_Items (Par) = Lis 2964 then 2965 Prg := First (Lis); 2966 2967 loop 2968 if Prg = N then 2969 return True; 2970 elsif Nkind (Prg) /= N_Pragma then 2971 return False; 2972 end if; 2973 2974 Next (Prg); 2975 end loop; 2976 2977 else 2978 return False; 2979 end if; 2980 end Is_Configuration_Pragma; 2981 2982 -------------------------- 2983 -- Is_In_Context_Clause -- 2984 -------------------------- 2985 2986 function Is_In_Context_Clause return Boolean is 2987 Plist : List_Id; 2988 Parent_Node : Node_Id; 2989 2990 begin 2991 if not Is_List_Member (N) then 2992 return False; 2993 2994 else 2995 Plist := List_Containing (N); 2996 Parent_Node := Parent (Plist); 2997 2998 if Parent_Node = Empty 2999 or else Nkind (Parent_Node) /= N_Compilation_Unit 3000 or else Context_Items (Parent_Node) /= Plist 3001 then 3002 return False; 3003 end if; 3004 end if; 3005 3006 return True; 3007 end Is_In_Context_Clause; 3008 3009 --------------------------------- 3010 -- Is_Static_String_Expression -- 3011 --------------------------------- 3012 3013 function Is_Static_String_Expression (Arg : Node_Id) return Boolean is 3014 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 3015 3016 begin 3017 Analyze_And_Resolve (Argx); 3018 return Is_OK_Static_Expression (Argx) 3019 and then Nkind (Argx) = N_String_Literal; 3020 end Is_Static_String_Expression; 3021 3022 ---------------------- 3023 -- Pragma_Misplaced -- 3024 ---------------------- 3025 3026 procedure Pragma_Misplaced is 3027 begin 3028 Error_Pragma ("incorrect placement of pragma%"); 3029 end Pragma_Misplaced; 3030 3031 ------------------------------------ 3032 -- Process_Atomic_Shared_Volatile -- 3033 ------------------------------------ 3034 3035 procedure Process_Atomic_Shared_Volatile is 3036 E_Id : Node_Id; 3037 E : Entity_Id; 3038 D : Node_Id; 3039 K : Node_Kind; 3040 Utyp : Entity_Id; 3041 3042 procedure Set_Atomic (E : Entity_Id); 3043 -- Set given type as atomic, and if no explicit alignment was given, 3044 -- set alignment to unknown, since back end knows what the alignment 3045 -- requirements are for atomic arrays. Note: this step is necessary 3046 -- for derived types. 3047 3048 ---------------- 3049 -- Set_Atomic -- 3050 ---------------- 3051 3052 procedure Set_Atomic (E : Entity_Id) is 3053 begin 3054 Set_Is_Atomic (E); 3055 3056 if not Has_Alignment_Clause (E) then 3057 Set_Alignment (E, Uint_0); 3058 end if; 3059 end Set_Atomic; 3060 3061 -- Start of processing for Process_Atomic_Shared_Volatile 3062 3063 begin 3064 Check_Ada_83_Warning; 3065 Check_No_Identifiers; 3066 Check_Arg_Count (1); 3067 Check_Arg_Is_Local_Name (Arg1); 3068 E_Id := Get_Pragma_Arg (Arg1); 3069 3070 if Etype (E_Id) = Any_Type then 3071 return; 3072 end if; 3073 3074 E := Entity (E_Id); 3075 D := Declaration_Node (E); 3076 K := Nkind (D); 3077 3078 -- Check duplicate before we chain ourselves! 3079 3080 Check_Duplicate_Pragma (E); 3081 3082 -- Now check appropriateness of the entity 3083 3084 if Is_Type (E) then 3085 if Rep_Item_Too_Early (E, N) 3086 or else 3087 Rep_Item_Too_Late (E, N) 3088 then 3089 return; 3090 else 3091 Check_First_Subtype (Arg1); 3092 end if; 3093 3094 if Prag_Id /= Pragma_Volatile then 3095 Set_Atomic (E); 3096 Set_Atomic (Underlying_Type (E)); 3097 Set_Atomic (Base_Type (E)); 3098 end if; 3099 3100 -- Attribute belongs on the base type. If the view of the type is 3101 -- currently private, it also belongs on the underlying type. 3102 3103 Set_Is_Volatile (Base_Type (E)); 3104 Set_Is_Volatile (Underlying_Type (E)); 3105 3106 Set_Treat_As_Volatile (E); 3107 Set_Treat_As_Volatile (Underlying_Type (E)); 3108 3109 elsif K = N_Object_Declaration 3110 or else (K = N_Component_Declaration 3111 and then Original_Record_Component (E) = E) 3112 then 3113 if Rep_Item_Too_Late (E, N) then 3114 return; 3115 end if; 3116 3117 if Prag_Id /= Pragma_Volatile then 3118 Set_Is_Atomic (E); 3119 3120 -- If the object declaration has an explicit initialization, a 3121 -- temporary may have to be created to hold the expression, to 3122 -- ensure that access to the object remain atomic. 3123 3124 if Nkind (Parent (E)) = N_Object_Declaration 3125 and then Present (Expression (Parent (E))) 3126 then 3127 Set_Has_Delayed_Freeze (E); 3128 end if; 3129 3130 -- An interesting improvement here. If an object of composite 3131 -- type X is declared atomic, and the type X isn't, that's a 3132 -- pity, since it may not have appropriate alignment etc. We 3133 -- can rescue this in the special case where the object and 3134 -- type are in the same unit by just setting the type as 3135 -- atomic, so that the back end will process it as atomic. 3136 3137 -- Note: we used to do this for elementary types as well, 3138 -- but that turns out to be a bad idea and can have unwanted 3139 -- effects, most notably if the type is elementary, the object 3140 -- a simple component within a record, and both are in a spec: 3141 -- every object of this type in the entire program will be 3142 -- treated as atomic, thus incurring a potentially costly 3143 -- synchronization operation for every access. 3144 3145 -- Of course it would be best if the back end could just adjust 3146 -- the alignment etc for the specific object, but that's not 3147 -- something we are capable of doing at this point. 3148 3149 Utyp := Underlying_Type (Etype (E)); 3150 3151 if Present (Utyp) 3152 and then Is_Composite_Type (Utyp) 3153 and then Sloc (E) > No_Location 3154 and then Sloc (Utyp) > No_Location 3155 and then 3156 Get_Source_File_Index (Sloc (E)) = 3157 Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) 3158 then 3159 Set_Is_Atomic (Underlying_Type (Etype (E))); 3160 end if; 3161 end if; 3162 3163 Set_Is_Volatile (E); 3164 Set_Treat_As_Volatile (E); 3165 3166 else 3167 Error_Pragma_Arg 3168 ("inappropriate entity for pragma%", Arg1); 3169 end if; 3170 end Process_Atomic_Shared_Volatile; 3171 3172 ------------------------------------------- 3173 -- Process_Compile_Time_Warning_Or_Error -- 3174 ------------------------------------------- 3175 3176 procedure Process_Compile_Time_Warning_Or_Error is 3177 Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); 3178 3179 begin 3180 Check_Arg_Count (2); 3181 Check_No_Identifiers; 3182 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 3183 Analyze_And_Resolve (Arg1x, Standard_Boolean); 3184 3185 if Compile_Time_Known_Value (Arg1x) then 3186 if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then 3187 declare 3188 Str : constant String_Id := 3189 Strval (Get_Pragma_Arg (Arg2)); 3190 Len : constant Int := String_Length (Str); 3191 Cont : Boolean; 3192 Ptr : Nat; 3193 CC : Char_Code; 3194 C : Character; 3195 Cent : constant Entity_Id := 3196 Cunit_Entity (Current_Sem_Unit); 3197 3198 Force : constant Boolean := 3199 Prag_Id = Pragma_Compile_Time_Warning 3200 and then 3201 Is_Spec_Name (Unit_Name (Current_Sem_Unit)) 3202 and then (Ekind (Cent) /= E_Package 3203 or else not In_Private_Part (Cent)); 3204 -- Set True if this is the warning case, and we are in the 3205 -- visible part of a package spec, or in a subprogram spec, 3206 -- in which case we want to force the client to see the 3207 -- warning, even though it is not in the main unit. 3208 3209 begin 3210 -- Loop through segments of message separated by line feeds. 3211 -- We output these segments as separate messages with 3212 -- continuation marks for all but the first. 3213 3214 Cont := False; 3215 Ptr := 1; 3216 loop 3217 Error_Msg_Strlen := 0; 3218 3219 -- Loop to copy characters from argument to error message 3220 -- string buffer. 3221 3222 loop 3223 exit when Ptr > Len; 3224 CC := Get_String_Char (Str, Ptr); 3225 Ptr := Ptr + 1; 3226 3227 -- Ignore wide chars ??? else store character 3228 3229 if In_Character_Range (CC) then 3230 C := Get_Character (CC); 3231 exit when C = ASCII.LF; 3232 Error_Msg_Strlen := Error_Msg_Strlen + 1; 3233 Error_Msg_String (Error_Msg_Strlen) := C; 3234 end if; 3235 end loop; 3236 3237 -- Here with one line ready to go 3238 3239 Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; 3240 3241 -- If this is a warning in a spec, then we want clients 3242 -- to see the warning, so mark the message with the 3243 -- special sequence !! to force the warning. In the case 3244 -- of a package spec, we do not force this if we are in 3245 -- the private part of the spec. 3246 3247 if Force then 3248 if Cont = False then 3249 Error_Msg_N ("<~!!", Arg1); 3250 Cont := True; 3251 else 3252 Error_Msg_N ("\<~!!", Arg1); 3253 end if; 3254 3255 -- Error, rather than warning, or in a body, so we do not 3256 -- need to force visibility for client (error will be 3257 -- output in any case, and this is the situation in which 3258 -- we do not want a client to get a warning, since the 3259 -- warning is in the body or the spec private part). 3260 3261 else 3262 if Cont = False then 3263 Error_Msg_N ("<~", Arg1); 3264 Cont := True; 3265 else 3266 Error_Msg_N ("\<~", Arg1); 3267 end if; 3268 end if; 3269 3270 exit when Ptr > Len; 3271 end loop; 3272 end; 3273 end if; 3274 end if; 3275 end Process_Compile_Time_Warning_Or_Error; 3276 3277 ------------------------ 3278 -- Process_Convention -- 3279 ------------------------ 3280 3281 procedure Process_Convention 3282 (C : out Convention_Id; 3283 Ent : out Entity_Id) 3284 is 3285 Id : Node_Id; 3286 E : Entity_Id; 3287 E1 : Entity_Id; 3288 Cname : Name_Id; 3289 Comp_Unit : Unit_Number_Type; 3290 3291 procedure Diagnose_Multiple_Pragmas (S : Entity_Id); 3292 -- Called if we have more than one Export/Import/Convention pragma. 3293 -- This is generally illegal, but we have a special case of allowing 3294 -- Import and Interface to coexist if they specify the convention in 3295 -- a consistent manner. We are allowed to do this, since Interface is 3296 -- an implementation defined pragma, and we choose to do it since we 3297 -- know Rational allows this combination. S is the entity id of the 3298 -- subprogram in question. This procedure also sets the special flag 3299 -- Import_Interface_Present in both pragmas in the case where we do 3300 -- have matching Import and Interface pragmas. 3301 3302 procedure Set_Convention_From_Pragma (E : Entity_Id); 3303 -- Set convention in entity E, and also flag that the entity has a 3304 -- convention pragma. If entity is for a private or incomplete type, 3305 -- also set convention and flag on underlying type. This procedure 3306 -- also deals with the special case of C_Pass_By_Copy convention. 3307 3308 ------------------------------- 3309 -- Diagnose_Multiple_Pragmas -- 3310 ------------------------------- 3311 3312 procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is 3313 Pdec : constant Node_Id := Declaration_Node (S); 3314 Decl : Node_Id; 3315 Err : Boolean; 3316 3317 function Same_Convention (Decl : Node_Id) return Boolean; 3318 -- Decl is a pragma node. This function returns True if this 3319 -- pragma has a first argument that is an identifier with a 3320 -- Chars field corresponding to the Convention_Id C. 3321 3322 function Same_Name (Decl : Node_Id) return Boolean; 3323 -- Decl is a pragma node. This function returns True if this 3324 -- pragma has a second argument that is an identifier with a 3325 -- Chars field that matches the Chars of the current subprogram. 3326 3327 --------------------- 3328 -- Same_Convention -- 3329 --------------------- 3330 3331 function Same_Convention (Decl : Node_Id) return Boolean is 3332 Arg1 : constant Node_Id := 3333 First (Pragma_Argument_Associations (Decl)); 3334 3335 begin 3336 if Present (Arg1) then 3337 declare 3338 Arg : constant Node_Id := Get_Pragma_Arg (Arg1); 3339 begin 3340 if Nkind (Arg) = N_Identifier 3341 and then Is_Convention_Name (Chars (Arg)) 3342 and then Get_Convention_Id (Chars (Arg)) = C 3343 then 3344 return True; 3345 end if; 3346 end; 3347 end if; 3348 3349 return False; 3350 end Same_Convention; 3351 3352 --------------- 3353 -- Same_Name -- 3354 --------------- 3355 3356 function Same_Name (Decl : Node_Id) return Boolean is 3357 Arg1 : constant Node_Id := 3358 First (Pragma_Argument_Associations (Decl)); 3359 Arg2 : Node_Id; 3360 3361 begin 3362 if No (Arg1) then 3363 return False; 3364 end if; 3365 3366 Arg2 := Next (Arg1); 3367 3368 if No (Arg2) then 3369 return False; 3370 end if; 3371 3372 declare 3373 Arg : constant Node_Id := Get_Pragma_Arg (Arg2); 3374 begin 3375 if Nkind (Arg) = N_Identifier 3376 and then Chars (Arg) = Chars (S) 3377 then 3378 return True; 3379 end if; 3380 end; 3381 3382 return False; 3383 end Same_Name; 3384 3385 -- Start of processing for Diagnose_Multiple_Pragmas 3386 3387 begin 3388 Err := True; 3389 3390 -- Definitely give message if we have Convention/Export here 3391 3392 if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then 3393 null; 3394 3395 -- If we have an Import or Export, scan back from pragma to 3396 -- find any previous pragma applying to the same procedure. 3397 -- The scan will be terminated by the start of the list, or 3398 -- hitting the subprogram declaration. This won't allow one 3399 -- pragma to appear in the public part and one in the private 3400 -- part, but that seems very unlikely in practice. 3401 3402 else 3403 Decl := Prev (N); 3404 while Present (Decl) and then Decl /= Pdec loop 3405 3406 -- Look for pragma with same name as us 3407 3408 if Nkind (Decl) = N_Pragma 3409 and then Same_Name (Decl) 3410 then 3411 -- Give error if same as our pragma or Export/Convention 3412 3413 if Pragma_Name (Decl) = Name_Export 3414 or else 3415 Pragma_Name (Decl) = Name_Convention 3416 or else 3417 Pragma_Name (Decl) = Pragma_Name (N) 3418 then 3419 exit; 3420 3421 -- Case of Import/Interface or the other way round 3422 3423 elsif Pragma_Name (Decl) = Name_Interface 3424 or else 3425 Pragma_Name (Decl) = Name_Import 3426 then 3427 -- Here we know that we have Import and Interface. It 3428 -- doesn't matter which way round they are. See if 3429 -- they specify the same convention. If so, all OK, 3430 -- and set special flags to stop other messages 3431 3432 if Same_Convention (Decl) then 3433 Set_Import_Interface_Present (N); 3434 Set_Import_Interface_Present (Decl); 3435 Err := False; 3436 3437 -- If different conventions, special message 3438 3439 else 3440 Error_Msg_Sloc := Sloc (Decl); 3441 Error_Pragma_Arg 3442 ("convention differs from that given#", Arg1); 3443 return; 3444 end if; 3445 end if; 3446 end if; 3447 3448 Next (Decl); 3449 end loop; 3450 end if; 3451 3452 -- Give message if needed if we fall through those tests 3453 3454 if Err then 3455 Error_Pragma_Arg 3456 ("at most one Convention/Export/Import pragma is allowed", 3457 Arg2); 3458 end if; 3459 end Diagnose_Multiple_Pragmas; 3460 3461 -------------------------------- 3462 -- Set_Convention_From_Pragma -- 3463 -------------------------------- 3464 3465 procedure Set_Convention_From_Pragma (E : Entity_Id) is 3466 begin 3467 -- Ada 2005 (AI-430): Check invalid attempt to change convention 3468 -- for an overridden dispatching operation. Technically this is 3469 -- an amendment and should only be done in Ada 2005 mode. However, 3470 -- this is clearly a mistake, since the problem that is addressed 3471 -- by this AI is that there is a clear gap in the RM! 3472 3473 if Is_Dispatching_Operation (E) 3474 and then Present (Overridden_Operation (E)) 3475 and then C /= Convention (Overridden_Operation (E)) 3476 then 3477 Error_Pragma_Arg 3478 ("cannot change convention for " & 3479 "overridden dispatching operation", 3480 Arg1); 3481 end if; 3482 3483 -- Set the convention 3484 3485 Set_Convention (E, C); 3486 Set_Has_Convention_Pragma (E); 3487 3488 if Is_Incomplete_Or_Private_Type (E) 3489 and then Present (Underlying_Type (E)) 3490 then 3491 Set_Convention (Underlying_Type (E), C); 3492 Set_Has_Convention_Pragma (Underlying_Type (E), True); 3493 end if; 3494 3495 -- A class-wide type should inherit the convention of the specific 3496 -- root type (although this isn't specified clearly by the RM). 3497 3498 if Is_Type (E) and then Present (Class_Wide_Type (E)) then 3499 Set_Convention (Class_Wide_Type (E), C); 3500 end if; 3501 3502 -- If the entity is a record type, then check for special case of 3503 -- C_Pass_By_Copy, which is treated the same as C except that the 3504 -- special record flag is set. This convention is only permitted 3505 -- on record types (see AI95-00131). 3506 3507 if Cname = Name_C_Pass_By_Copy then 3508 if Is_Record_Type (E) then 3509 Set_C_Pass_By_Copy (Base_Type (E)); 3510 elsif Is_Incomplete_Or_Private_Type (E) 3511 and then Is_Record_Type (Underlying_Type (E)) 3512 then 3513 Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); 3514 else 3515 Error_Pragma_Arg 3516 ("C_Pass_By_Copy convention allowed only for record type", 3517 Arg2); 3518 end if; 3519 end if; 3520 3521 -- If the entity is a derived boolean type, check for the special 3522 -- case of convention C, C++, or Fortran, where we consider any 3523 -- nonzero value to represent true. 3524 3525 if Is_Discrete_Type (E) 3526 and then Root_Type (Etype (E)) = Standard_Boolean 3527 and then 3528 (C = Convention_C 3529 or else 3530 C = Convention_CPP 3531 or else 3532 C = Convention_Fortran) 3533 then 3534 Set_Nonzero_Is_True (Base_Type (E)); 3535 end if; 3536 end Set_Convention_From_Pragma; 3537 3538 -- Start of processing for Process_Convention 3539 3540 begin 3541 Check_At_Least_N_Arguments (2); 3542 Check_Optional_Identifier (Arg1, Name_Convention); 3543 Check_Arg_Is_Identifier (Arg1); 3544 Cname := Chars (Get_Pragma_Arg (Arg1)); 3545 3546 -- C_Pass_By_Copy is treated as a synonym for convention C (this is 3547 -- tested again below to set the critical flag). 3548 3549 if Cname = Name_C_Pass_By_Copy then 3550 C := Convention_C; 3551 3552 -- Otherwise we must have something in the standard convention list 3553 3554 elsif Is_Convention_Name (Cname) then 3555 C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); 3556 3557 -- In DEC VMS, it seems that there is an undocumented feature that 3558 -- any unrecognized convention is treated as the default, which for 3559 -- us is convention C. It does not seem so terrible to do this 3560 -- unconditionally, silently in the VMS case, and with a warning 3561 -- in the non-VMS case. 3562 3563 else 3564 if Warn_On_Export_Import and not OpenVMS_On_Target then 3565 Error_Msg_N 3566 ("??unrecognized convention name, C assumed", 3567 Get_Pragma_Arg (Arg1)); 3568 end if; 3569 3570 C := Convention_C; 3571 end if; 3572 3573 Check_Optional_Identifier (Arg2, Name_Entity); 3574 Check_Arg_Is_Local_Name (Arg2); 3575 3576 Id := Get_Pragma_Arg (Arg2); 3577 Analyze (Id); 3578 3579 if not Is_Entity_Name (Id) then 3580 Error_Pragma_Arg ("entity name required", Arg2); 3581 end if; 3582 3583 E := Entity (Id); 3584 3585 -- Set entity to return 3586 3587 Ent := E; 3588 3589 -- Ada_Pass_By_Copy special checking 3590 3591 if C = Convention_Ada_Pass_By_Copy then 3592 if not Is_First_Subtype (E) then 3593 Error_Pragma_Arg 3594 ("convention `Ada_Pass_By_Copy` only " 3595 & "allowed for types", Arg2); 3596 end if; 3597 3598 if Is_By_Reference_Type (E) then 3599 Error_Pragma_Arg 3600 ("convention `Ada_Pass_By_Copy` not allowed for " 3601 & "by-reference type", Arg1); 3602 end if; 3603 end if; 3604 3605 -- Ada_Pass_By_Reference special checking 3606 3607 if C = Convention_Ada_Pass_By_Reference then 3608 if not Is_First_Subtype (E) then 3609 Error_Pragma_Arg 3610 ("convention `Ada_Pass_By_Reference` only " 3611 & "allowed for types", Arg2); 3612 end if; 3613 3614 if Is_By_Copy_Type (E) then 3615 Error_Pragma_Arg 3616 ("convention `Ada_Pass_By_Reference` not allowed for " 3617 & "by-copy type", Arg1); 3618 end if; 3619 end if; 3620 3621 -- Go to renamed subprogram if present, since convention applies to 3622 -- the actual renamed entity, not to the renaming entity. If the 3623 -- subprogram is inherited, go to parent subprogram. 3624 3625 if Is_Subprogram (E) 3626 and then Present (Alias (E)) 3627 then 3628 if Nkind (Parent (Declaration_Node (E))) = 3629 N_Subprogram_Renaming_Declaration 3630 then 3631 if Scope (E) /= Scope (Alias (E)) then 3632 Error_Pragma_Ref 3633 ("cannot apply pragma% to non-local entity&#", E); 3634 end if; 3635 3636 E := Alias (E); 3637 3638 elsif Nkind_In (Parent (E), N_Full_Type_Declaration, 3639 N_Private_Extension_Declaration) 3640 and then Scope (E) = Scope (Alias (E)) 3641 then 3642 E := Alias (E); 3643 3644 -- Return the parent subprogram the entity was inherited from 3645 3646 Ent := E; 3647 end if; 3648 end if; 3649 3650 -- Check that we are not applying this to a specless body 3651 3652 if Is_Subprogram (E) 3653 and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body 3654 then 3655 Error_Pragma 3656 ("pragma% requires separate spec and must come before body"); 3657 end if; 3658 3659 -- Check that we are not applying this to a named constant 3660 3661 if Ekind_In (E, E_Named_Integer, E_Named_Real) then 3662 Error_Msg_Name_1 := Pname; 3663 Error_Msg_N 3664 ("cannot apply pragma% to named constant!", 3665 Get_Pragma_Arg (Arg2)); 3666 Error_Pragma_Arg 3667 ("\supply appropriate type for&!", Arg2); 3668 end if; 3669 3670 if Ekind (E) = E_Enumeration_Literal then 3671 Error_Pragma ("enumeration literal not allowed for pragma%"); 3672 end if; 3673 3674 -- Check for rep item appearing too early or too late 3675 3676 if Etype (E) = Any_Type 3677 or else Rep_Item_Too_Early (E, N) 3678 then 3679 raise Pragma_Exit; 3680 3681 elsif Present (Underlying_Type (E)) then 3682 E := Underlying_Type (E); 3683 end if; 3684 3685 if Rep_Item_Too_Late (E, N) then 3686 raise Pragma_Exit; 3687 end if; 3688 3689 if Has_Convention_Pragma (E) then 3690 Diagnose_Multiple_Pragmas (E); 3691 3692 elsif Convention (E) = Convention_Protected 3693 or else Ekind (Scope (E)) = E_Protected_Type 3694 then 3695 Error_Pragma_Arg 3696 ("a protected operation cannot be given a different convention", 3697 Arg2); 3698 end if; 3699 3700 -- For Intrinsic, a subprogram is required 3701 3702 if C = Convention_Intrinsic 3703 and then not Is_Subprogram (E) 3704 and then not Is_Generic_Subprogram (E) 3705 then 3706 Error_Pragma_Arg 3707 ("second argument of pragma% must be a subprogram", Arg2); 3708 end if; 3709 3710 -- Stdcall case 3711 3712 if C = Convention_Stdcall then 3713 3714 -- A dispatching call is not allowed. A dispatching subprogram 3715 -- cannot be used to interface to the Win32 API, so in fact this 3716 -- check does not impose any effective restriction. 3717 3718 if Is_Dispatching_Operation (E) then 3719 3720 Error_Pragma 3721 ("dispatching subprograms cannot use Stdcall convention"); 3722 3723 -- Subprogram is allowed, but not a generic subprogram, and not a 3724 -- dispatching operation. 3725 3726 elsif not Is_Subprogram (E) 3727 and then not Is_Generic_Subprogram (E) 3728 3729 -- A variable is OK 3730 3731 and then Ekind (E) /= E_Variable 3732 3733 -- An access to subprogram is also allowed 3734 3735 and then not 3736 (Is_Access_Type (E) 3737 and then Ekind (Designated_Type (E)) = E_Subprogram_Type) 3738 then 3739 Error_Pragma_Arg 3740 ("second argument of pragma% must be subprogram (type)", 3741 Arg2); 3742 end if; 3743 end if; 3744 3745 if not Is_Subprogram (E) 3746 and then not Is_Generic_Subprogram (E) 3747 then 3748 Set_Convention_From_Pragma (E); 3749 3750 if Is_Type (E) then 3751 Check_First_Subtype (Arg2); 3752 Set_Convention_From_Pragma (Base_Type (E)); 3753 3754 -- For subprograms, we must set the convention on the 3755 -- internally generated directly designated type as well. 3756 3757 if Ekind (E) = E_Access_Subprogram_Type then 3758 Set_Convention_From_Pragma (Directly_Designated_Type (E)); 3759 end if; 3760 end if; 3761 3762 -- For the subprogram case, set proper convention for all homonyms 3763 -- in same scope and the same declarative part, i.e. the same 3764 -- compilation unit. 3765 3766 else 3767 Comp_Unit := Get_Source_Unit (E); 3768 Set_Convention_From_Pragma (E); 3769 3770 -- Treat a pragma Import as an implicit body, and pragma import 3771 -- as implicit reference (for navigation in GPS). 3772 3773 if Prag_Id = Pragma_Import then 3774 Generate_Reference (E, Id, 'b'); 3775 3776 -- For exported entities we restrict the generation of references 3777 -- to entities exported to foreign languages since entities 3778 -- exported to Ada do not provide further information to GPS and 3779 -- add undesired references to the output of the gnatxref tool. 3780 3781 elsif Prag_Id = Pragma_Export 3782 and then Convention (E) /= Convention_Ada 3783 then 3784 Generate_Reference (E, Id, 'i'); 3785 end if; 3786 3787 -- If the pragma comes from from an aspect, it only applies 3788 -- to the given entity, not its homonyms. 3789 3790 if From_Aspect_Specification (N) then 3791 return; 3792 end if; 3793 3794 -- Otherwise Loop through the homonyms of the pragma argument's 3795 -- entity, an apply convention to those in the current scope. 3796 3797 E1 := Ent; 3798 3799 loop 3800 E1 := Homonym (E1); 3801 exit when No (E1) or else Scope (E1) /= Current_Scope; 3802 3803 -- Do not set the pragma on inherited operations or on formal 3804 -- subprograms. 3805 3806 if Comes_From_Source (E1) 3807 and then Comp_Unit = Get_Source_Unit (E1) 3808 and then not Is_Formal_Subprogram (E1) 3809 and then Nkind (Original_Node (Parent (E1))) /= 3810 N_Full_Type_Declaration 3811 then 3812 if Present (Alias (E1)) 3813 and then Scope (E1) /= Scope (Alias (E1)) 3814 then 3815 Error_Pragma_Ref 3816 ("cannot apply pragma% to non-local entity& declared#", 3817 E1); 3818 end if; 3819 3820 Set_Convention_From_Pragma (E1); 3821 3822 if Prag_Id = Pragma_Import then 3823 Generate_Reference (E1, Id, 'b'); 3824 end if; 3825 end if; 3826 end loop; 3827 end if; 3828 end Process_Convention; 3829 3830 ---------------------------------------- 3831 -- Process_Disable_Enable_Atomic_Sync -- 3832 ---------------------------------------- 3833 3834 procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is 3835 begin 3836 GNAT_Pragma; 3837 Check_No_Identifiers; 3838 Check_At_Most_N_Arguments (1); 3839 3840 -- Modeled internally as 3841 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity]) 3842 3843 Rewrite (N, 3844 Make_Pragma (Loc, 3845 Pragma_Identifier => 3846 Make_Identifier (Loc, Nam), 3847 Pragma_Argument_Associations => New_List ( 3848 Make_Pragma_Argument_Association (Loc, 3849 Expression => 3850 Make_Identifier (Loc, Name_Atomic_Synchronization))))); 3851 3852 if Present (Arg1) then 3853 Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); 3854 end if; 3855 3856 Analyze (N); 3857 end Process_Disable_Enable_Atomic_Sync; 3858 3859 ----------------------------------------------------- 3860 -- Process_Extended_Import_Export_Exception_Pragma -- 3861 ----------------------------------------------------- 3862 3863 procedure Process_Extended_Import_Export_Exception_Pragma 3864 (Arg_Internal : Node_Id; 3865 Arg_External : Node_Id; 3866 Arg_Form : Node_Id; 3867 Arg_Code : Node_Id) 3868 is 3869 Def_Id : Entity_Id; 3870 Code_Val : Uint; 3871 3872 begin 3873 if not OpenVMS_On_Target then 3874 Error_Pragma 3875 ("??pragma% ignored (applies only to Open'V'M'S)"); 3876 end if; 3877 3878 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 3879 Def_Id := Entity (Arg_Internal); 3880 3881 if Ekind (Def_Id) /= E_Exception then 3882 Error_Pragma_Arg 3883 ("pragma% must refer to declared exception", Arg_Internal); 3884 end if; 3885 3886 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 3887 3888 if Present (Arg_Form) then 3889 Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); 3890 end if; 3891 3892 if Present (Arg_Form) 3893 and then Chars (Arg_Form) = Name_Ada 3894 then 3895 null; 3896 else 3897 Set_Is_VMS_Exception (Def_Id); 3898 Set_Exception_Code (Def_Id, No_Uint); 3899 end if; 3900 3901 if Present (Arg_Code) then 3902 if not Is_VMS_Exception (Def_Id) then 3903 Error_Pragma_Arg 3904 ("Code option for pragma% not allowed for Ada case", 3905 Arg_Code); 3906 end if; 3907 3908 Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer); 3909 Code_Val := Expr_Value (Arg_Code); 3910 3911 if not UI_Is_In_Int_Range (Code_Val) then 3912 Error_Pragma_Arg 3913 ("Code option for pragma% must be in 32-bit range", 3914 Arg_Code); 3915 3916 else 3917 Set_Exception_Code (Def_Id, Code_Val); 3918 end if; 3919 end if; 3920 end Process_Extended_Import_Export_Exception_Pragma; 3921 3922 ------------------------------------------------- 3923 -- Process_Extended_Import_Export_Internal_Arg -- 3924 ------------------------------------------------- 3925 3926 procedure Process_Extended_Import_Export_Internal_Arg 3927 (Arg_Internal : Node_Id := Empty) 3928 is 3929 begin 3930 if No (Arg_Internal) then 3931 Error_Pragma ("Internal parameter required for pragma%"); 3932 end if; 3933 3934 if Nkind (Arg_Internal) = N_Identifier then 3935 null; 3936 3937 elsif Nkind (Arg_Internal) = N_Operator_Symbol 3938 and then (Prag_Id = Pragma_Import_Function 3939 or else 3940 Prag_Id = Pragma_Export_Function) 3941 then 3942 null; 3943 3944 else 3945 Error_Pragma_Arg 3946 ("wrong form for Internal parameter for pragma%", Arg_Internal); 3947 end if; 3948 3949 Check_Arg_Is_Local_Name (Arg_Internal); 3950 end Process_Extended_Import_Export_Internal_Arg; 3951 3952 -------------------------------------------------- 3953 -- Process_Extended_Import_Export_Object_Pragma -- 3954 -------------------------------------------------- 3955 3956 procedure Process_Extended_Import_Export_Object_Pragma 3957 (Arg_Internal : Node_Id; 3958 Arg_External : Node_Id; 3959 Arg_Size : Node_Id) 3960 is 3961 Def_Id : Entity_Id; 3962 3963 begin 3964 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 3965 Def_Id := Entity (Arg_Internal); 3966 3967 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 3968 Error_Pragma_Arg 3969 ("pragma% must designate an object", Arg_Internal); 3970 end if; 3971 3972 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 3973 or else 3974 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 3975 then 3976 Error_Pragma_Arg 3977 ("previous Common/Psect_Object applies, pragma % not permitted", 3978 Arg_Internal); 3979 end if; 3980 3981 if Rep_Item_Too_Late (Def_Id, N) then 3982 raise Pragma_Exit; 3983 end if; 3984 3985 Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); 3986 3987 if Present (Arg_Size) then 3988 Check_Arg_Is_External_Name (Arg_Size); 3989 end if; 3990 3991 -- Export_Object case 3992 3993 if Prag_Id = Pragma_Export_Object then 3994 if not Is_Library_Level_Entity (Def_Id) then 3995 Error_Pragma_Arg 3996 ("argument for pragma% must be library level entity", 3997 Arg_Internal); 3998 end if; 3999 4000 if Ekind (Current_Scope) = E_Generic_Package then 4001 Error_Pragma ("pragma& cannot appear in a generic unit"); 4002 end if; 4003 4004 if not Size_Known_At_Compile_Time (Etype (Def_Id)) then 4005 Error_Pragma_Arg 4006 ("exported object must have compile time known size", 4007 Arg_Internal); 4008 end if; 4009 4010 if Warn_On_Export_Import and then Is_Exported (Def_Id) then 4011 Error_Msg_N ("??duplicate Export_Object pragma", N); 4012 else 4013 Set_Exported (Def_Id, Arg_Internal); 4014 end if; 4015 4016 -- Import_Object case 4017 4018 else 4019 if Is_Concurrent_Type (Etype (Def_Id)) then 4020 Error_Pragma_Arg 4021 ("cannot use pragma% for task/protected object", 4022 Arg_Internal); 4023 end if; 4024 4025 if Ekind (Def_Id) = E_Constant then 4026 Error_Pragma_Arg 4027 ("cannot import a constant", Arg_Internal); 4028 end if; 4029 4030 if Warn_On_Export_Import 4031 and then Has_Discriminants (Etype (Def_Id)) 4032 then 4033 Error_Msg_N 4034 ("imported value must be initialized??", Arg_Internal); 4035 end if; 4036 4037 if Warn_On_Export_Import 4038 and then Is_Access_Type (Etype (Def_Id)) 4039 then 4040 Error_Pragma_Arg 4041 ("cannot import object of an access type??", Arg_Internal); 4042 end if; 4043 4044 if Warn_On_Export_Import 4045 and then Is_Imported (Def_Id) 4046 then 4047 Error_Msg_N ("??duplicate Import_Object pragma", N); 4048 4049 -- Check for explicit initialization present. Note that an 4050 -- initialization generated by the code generator, e.g. for an 4051 -- access type, does not count here. 4052 4053 elsif Present (Expression (Parent (Def_Id))) 4054 and then 4055 Comes_From_Source 4056 (Original_Node (Expression (Parent (Def_Id)))) 4057 then 4058 Error_Msg_Sloc := Sloc (Def_Id); 4059 Error_Pragma_Arg 4060 ("imported entities cannot be initialized (RM B.1(24))", 4061 "\no initialization allowed for & declared#", Arg1); 4062 else 4063 Set_Imported (Def_Id); 4064 Note_Possible_Modification (Arg_Internal, Sure => False); 4065 end if; 4066 end if; 4067 end Process_Extended_Import_Export_Object_Pragma; 4068 4069 ------------------------------------------------------ 4070 -- Process_Extended_Import_Export_Subprogram_Pragma -- 4071 ------------------------------------------------------ 4072 4073 procedure Process_Extended_Import_Export_Subprogram_Pragma 4074 (Arg_Internal : Node_Id; 4075 Arg_External : Node_Id; 4076 Arg_Parameter_Types : Node_Id; 4077 Arg_Result_Type : Node_Id := Empty; 4078 Arg_Mechanism : Node_Id; 4079 Arg_Result_Mechanism : Node_Id := Empty; 4080 Arg_First_Optional_Parameter : Node_Id := Empty) 4081 is 4082 Ent : Entity_Id; 4083 Def_Id : Entity_Id; 4084 Hom_Id : Entity_Id; 4085 Formal : Entity_Id; 4086 Ambiguous : Boolean; 4087 Match : Boolean; 4088 Dval : Node_Id; 4089 4090 function Same_Base_Type 4091 (Ptype : Node_Id; 4092 Formal : Entity_Id) return Boolean; 4093 -- Determines if Ptype references the type of Formal. Note that only 4094 -- the base types need to match according to the spec. Ptype here is 4095 -- the argument from the pragma, which is either a type name, or an 4096 -- access attribute. 4097 4098 -------------------- 4099 -- Same_Base_Type -- 4100 -------------------- 4101 4102 function Same_Base_Type 4103 (Ptype : Node_Id; 4104 Formal : Entity_Id) return Boolean 4105 is 4106 Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); 4107 Pref : Node_Id; 4108 4109 begin 4110 -- Case where pragma argument is typ'Access 4111 4112 if Nkind (Ptype) = N_Attribute_Reference 4113 and then Attribute_Name (Ptype) = Name_Access 4114 then 4115 Pref := Prefix (Ptype); 4116 Find_Type (Pref); 4117 4118 if not Is_Entity_Name (Pref) 4119 or else Entity (Pref) = Any_Type 4120 then 4121 raise Pragma_Exit; 4122 end if; 4123 4124 -- We have a match if the corresponding argument is of an 4125 -- anonymous access type, and its designated type matches the 4126 -- type of the prefix of the access attribute 4127 4128 return Ekind (Ftyp) = E_Anonymous_Access_Type 4129 and then Base_Type (Entity (Pref)) = 4130 Base_Type (Etype (Designated_Type (Ftyp))); 4131 4132 -- Case where pragma argument is a type name 4133 4134 else 4135 Find_Type (Ptype); 4136 4137 if not Is_Entity_Name (Ptype) 4138 or else Entity (Ptype) = Any_Type 4139 then 4140 raise Pragma_Exit; 4141 end if; 4142 4143 -- We have a match if the corresponding argument is of the type 4144 -- given in the pragma (comparing base types) 4145 4146 return Base_Type (Entity (Ptype)) = Ftyp; 4147 end if; 4148 end Same_Base_Type; 4149 4150 -- Start of processing for 4151 -- Process_Extended_Import_Export_Subprogram_Pragma 4152 4153 begin 4154 Process_Extended_Import_Export_Internal_Arg (Arg_Internal); 4155 Ent := Empty; 4156 Ambiguous := False; 4157 4158 -- Loop through homonyms (overloadings) of the entity 4159 4160 Hom_Id := Entity (Arg_Internal); 4161 while Present (Hom_Id) loop 4162 Def_Id := Get_Base_Subprogram (Hom_Id); 4163 4164 -- We need a subprogram in the current scope 4165 4166 if not Is_Subprogram (Def_Id) 4167 or else Scope (Def_Id) /= Current_Scope 4168 then 4169 null; 4170 4171 else 4172 Match := True; 4173 4174 -- Pragma cannot apply to subprogram body 4175 4176 if Is_Subprogram (Def_Id) 4177 and then Nkind (Parent (Declaration_Node (Def_Id))) = 4178 N_Subprogram_Body 4179 then 4180 Error_Pragma 4181 ("pragma% requires separate spec" 4182 & " and must come before body"); 4183 end if; 4184 4185 -- Test result type if given, note that the result type 4186 -- parameter can only be present for the function cases. 4187 4188 if Present (Arg_Result_Type) 4189 and then not Same_Base_Type (Arg_Result_Type, Def_Id) 4190 then 4191 Match := False; 4192 4193 elsif Etype (Def_Id) /= Standard_Void_Type 4194 and then 4195 (Pname = Name_Export_Procedure 4196 or else 4197 Pname = Name_Import_Procedure) 4198 then 4199 Match := False; 4200 4201 -- Test parameter types if given. Note that this parameter 4202 -- has not been analyzed (and must not be, since it is 4203 -- semantic nonsense), so we get it as the parser left it. 4204 4205 elsif Present (Arg_Parameter_Types) then 4206 Check_Matching_Types : declare 4207 Formal : Entity_Id; 4208 Ptype : Node_Id; 4209 4210 begin 4211 Formal := First_Formal (Def_Id); 4212 4213 if Nkind (Arg_Parameter_Types) = N_Null then 4214 if Present (Formal) then 4215 Match := False; 4216 end if; 4217 4218 -- A list of one type, e.g. (List) is parsed as 4219 -- a parenthesized expression. 4220 4221 elsif Nkind (Arg_Parameter_Types) /= N_Aggregate 4222 and then Paren_Count (Arg_Parameter_Types) = 1 4223 then 4224 if No (Formal) 4225 or else Present (Next_Formal (Formal)) 4226 then 4227 Match := False; 4228 else 4229 Match := 4230 Same_Base_Type (Arg_Parameter_Types, Formal); 4231 end if; 4232 4233 -- A list of more than one type is parsed as a aggregate 4234 4235 elsif Nkind (Arg_Parameter_Types) = N_Aggregate 4236 and then Paren_Count (Arg_Parameter_Types) = 0 4237 then 4238 Ptype := First (Expressions (Arg_Parameter_Types)); 4239 while Present (Ptype) or else Present (Formal) loop 4240 if No (Ptype) 4241 or else No (Formal) 4242 or else not Same_Base_Type (Ptype, Formal) 4243 then 4244 Match := False; 4245 exit; 4246 else 4247 Next_Formal (Formal); 4248 Next (Ptype); 4249 end if; 4250 end loop; 4251 4252 -- Anything else is of the wrong form 4253 4254 else 4255 Error_Pragma_Arg 4256 ("wrong form for Parameter_Types parameter", 4257 Arg_Parameter_Types); 4258 end if; 4259 end Check_Matching_Types; 4260 end if; 4261 4262 -- Match is now False if the entry we found did not match 4263 -- either a supplied Parameter_Types or Result_Types argument 4264 4265 if Match then 4266 if No (Ent) then 4267 Ent := Def_Id; 4268 4269 -- Ambiguous case, the flag Ambiguous shows if we already 4270 -- detected this and output the initial messages. 4271 4272 else 4273 if not Ambiguous then 4274 Ambiguous := True; 4275 Error_Msg_Name_1 := Pname; 4276 Error_Msg_N 4277 ("pragma% does not uniquely identify subprogram!", 4278 N); 4279 Error_Msg_Sloc := Sloc (Ent); 4280 Error_Msg_N ("matching subprogram #!", N); 4281 Ent := Empty; 4282 end if; 4283 4284 Error_Msg_Sloc := Sloc (Def_Id); 4285 Error_Msg_N ("matching subprogram #!", N); 4286 end if; 4287 end if; 4288 end if; 4289 4290 Hom_Id := Homonym (Hom_Id); 4291 end loop; 4292 4293 -- See if we found an entry 4294 4295 if No (Ent) then 4296 if not Ambiguous then 4297 if Is_Generic_Subprogram (Entity (Arg_Internal)) then 4298 Error_Pragma 4299 ("pragma% cannot be given for generic subprogram"); 4300 else 4301 Error_Pragma 4302 ("pragma% does not identify local subprogram"); 4303 end if; 4304 end if; 4305 4306 return; 4307 end if; 4308 4309 -- Import pragmas must be for imported entities 4310 4311 if Prag_Id = Pragma_Import_Function 4312 or else 4313 Prag_Id = Pragma_Import_Procedure 4314 or else 4315 Prag_Id = Pragma_Import_Valued_Procedure 4316 then 4317 if not Is_Imported (Ent) then 4318 Error_Pragma 4319 ("pragma Import or Interface must precede pragma%"); 4320 end if; 4321 4322 -- Here we have the Export case which can set the entity as exported 4323 4324 -- But does not do so if the specified external name is null, since 4325 -- that is taken as a signal in DEC Ada 83 (with which we want to be 4326 -- compatible) to request no external name. 4327 4328 elsif Nkind (Arg_External) = N_String_Literal 4329 and then String_Length (Strval (Arg_External)) = 0 4330 then 4331 null; 4332 4333 -- In all other cases, set entity as exported 4334 4335 else 4336 Set_Exported (Ent, Arg_Internal); 4337 end if; 4338 4339 -- Special processing for Valued_Procedure cases 4340 4341 if Prag_Id = Pragma_Import_Valued_Procedure 4342 or else 4343 Prag_Id = Pragma_Export_Valued_Procedure 4344 then 4345 Formal := First_Formal (Ent); 4346 4347 if No (Formal) then 4348 Error_Pragma ("at least one parameter required for pragma%"); 4349 4350 elsif Ekind (Formal) /= E_Out_Parameter then 4351 Error_Pragma ("first parameter must have mode out for pragma%"); 4352 4353 else 4354 Set_Is_Valued_Procedure (Ent); 4355 end if; 4356 end if; 4357 4358 Set_Extended_Import_Export_External_Name (Ent, Arg_External); 4359 4360 -- Process Result_Mechanism argument if present. We have already 4361 -- checked that this is only allowed for the function case. 4362 4363 if Present (Arg_Result_Mechanism) then 4364 Set_Mechanism_Value (Ent, Arg_Result_Mechanism); 4365 end if; 4366 4367 -- Process Mechanism parameter if present. Note that this parameter 4368 -- is not analyzed, and must not be analyzed since it is semantic 4369 -- nonsense, so we get it in exactly as the parser left it. 4370 4371 if Present (Arg_Mechanism) then 4372 declare 4373 Formal : Entity_Id; 4374 Massoc : Node_Id; 4375 Mname : Node_Id; 4376 Choice : Node_Id; 4377 4378 begin 4379 -- A single mechanism association without a formal parameter 4380 -- name is parsed as a parenthesized expression. All other 4381 -- cases are parsed as aggregates, so we rewrite the single 4382 -- parameter case as an aggregate for consistency. 4383 4384 if Nkind (Arg_Mechanism) /= N_Aggregate 4385 and then Paren_Count (Arg_Mechanism) = 1 4386 then 4387 Rewrite (Arg_Mechanism, 4388 Make_Aggregate (Sloc (Arg_Mechanism), 4389 Expressions => New_List ( 4390 Relocate_Node (Arg_Mechanism)))); 4391 end if; 4392 4393 -- Case of only mechanism name given, applies to all formals 4394 4395 if Nkind (Arg_Mechanism) /= N_Aggregate then 4396 Formal := First_Formal (Ent); 4397 while Present (Formal) loop 4398 Set_Mechanism_Value (Formal, Arg_Mechanism); 4399 Next_Formal (Formal); 4400 end loop; 4401 4402 -- Case of list of mechanism associations given 4403 4404 else 4405 if Null_Record_Present (Arg_Mechanism) then 4406 Error_Pragma_Arg 4407 ("inappropriate form for Mechanism parameter", 4408 Arg_Mechanism); 4409 end if; 4410 4411 -- Deal with positional ones first 4412 4413 Formal := First_Formal (Ent); 4414 4415 if Present (Expressions (Arg_Mechanism)) then 4416 Mname := First (Expressions (Arg_Mechanism)); 4417 while Present (Mname) loop 4418 if No (Formal) then 4419 Error_Pragma_Arg 4420 ("too many mechanism associations", Mname); 4421 end if; 4422 4423 Set_Mechanism_Value (Formal, Mname); 4424 Next_Formal (Formal); 4425 Next (Mname); 4426 end loop; 4427 end if; 4428 4429 -- Deal with named entries 4430 4431 if Present (Component_Associations (Arg_Mechanism)) then 4432 Massoc := First (Component_Associations (Arg_Mechanism)); 4433 while Present (Massoc) loop 4434 Choice := First (Choices (Massoc)); 4435 4436 if Nkind (Choice) /= N_Identifier 4437 or else Present (Next (Choice)) 4438 then 4439 Error_Pragma_Arg 4440 ("incorrect form for mechanism association", 4441 Massoc); 4442 end if; 4443 4444 Formal := First_Formal (Ent); 4445 loop 4446 if No (Formal) then 4447 Error_Pragma_Arg 4448 ("parameter name & not present", Choice); 4449 end if; 4450 4451 if Chars (Choice) = Chars (Formal) then 4452 Set_Mechanism_Value 4453 (Formal, Expression (Massoc)); 4454 4455 -- Set entity on identifier (needed by ASIS) 4456 4457 Set_Entity (Choice, Formal); 4458 4459 exit; 4460 end if; 4461 4462 Next_Formal (Formal); 4463 end loop; 4464 4465 Next (Massoc); 4466 end loop; 4467 end if; 4468 end if; 4469 end; 4470 end if; 4471 4472 -- Process First_Optional_Parameter argument if present. We have 4473 -- already checked that this is only allowed for the Import case. 4474 4475 if Present (Arg_First_Optional_Parameter) then 4476 if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then 4477 Error_Pragma_Arg 4478 ("first optional parameter must be formal parameter name", 4479 Arg_First_Optional_Parameter); 4480 end if; 4481 4482 Formal := First_Formal (Ent); 4483 loop 4484 if No (Formal) then 4485 Error_Pragma_Arg 4486 ("specified formal parameter& not found", 4487 Arg_First_Optional_Parameter); 4488 end if; 4489 4490 exit when Chars (Formal) = 4491 Chars (Arg_First_Optional_Parameter); 4492 4493 Next_Formal (Formal); 4494 end loop; 4495 4496 Set_First_Optional_Parameter (Ent, Formal); 4497 4498 -- Check specified and all remaining formals have right form 4499 4500 while Present (Formal) loop 4501 if Ekind (Formal) /= E_In_Parameter then 4502 Error_Msg_NE 4503 ("optional formal& is not of mode in!", 4504 Arg_First_Optional_Parameter, Formal); 4505 4506 else 4507 Dval := Default_Value (Formal); 4508 4509 if No (Dval) then 4510 Error_Msg_NE 4511 ("optional formal& does not have default value!", 4512 Arg_First_Optional_Parameter, Formal); 4513 4514 elsif Compile_Time_Known_Value_Or_Aggr (Dval) then 4515 null; 4516 4517 else 4518 Error_Msg_FE 4519 ("default value for optional formal& is non-static!", 4520 Arg_First_Optional_Parameter, Formal); 4521 end if; 4522 end if; 4523 4524 Set_Is_Optional_Parameter (Formal); 4525 Next_Formal (Formal); 4526 end loop; 4527 end if; 4528 end Process_Extended_Import_Export_Subprogram_Pragma; 4529 4530 -------------------------- 4531 -- Process_Generic_List -- 4532 -------------------------- 4533 4534 procedure Process_Generic_List is 4535 Arg : Node_Id; 4536 Exp : Node_Id; 4537 4538 begin 4539 Check_No_Identifiers; 4540 Check_At_Least_N_Arguments (1); 4541 4542 Arg := Arg1; 4543 while Present (Arg) loop 4544 Exp := Get_Pragma_Arg (Arg); 4545 Analyze (Exp); 4546 4547 if not Is_Entity_Name (Exp) 4548 or else 4549 (not Is_Generic_Instance (Entity (Exp)) 4550 and then 4551 not Is_Generic_Unit (Entity (Exp))) 4552 then 4553 Error_Pragma_Arg 4554 ("pragma% argument must be name of generic unit/instance", 4555 Arg); 4556 end if; 4557 4558 Next (Arg); 4559 end loop; 4560 end Process_Generic_List; 4561 4562 ------------------------------------ 4563 -- Process_Import_Predefined_Type -- 4564 ------------------------------------ 4565 4566 procedure Process_Import_Predefined_Type is 4567 Loc : constant Source_Ptr := Sloc (N); 4568 Elmt : Elmt_Id; 4569 Ftyp : Node_Id := Empty; 4570 Decl : Node_Id; 4571 Def : Node_Id; 4572 Nam : Name_Id; 4573 4574 begin 4575 String_To_Name_Buffer (Strval (Expression (Arg3))); 4576 Nam := Name_Find; 4577 4578 Elmt := First_Elmt (Predefined_Float_Types); 4579 while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop 4580 Next_Elmt (Elmt); 4581 end loop; 4582 4583 Ftyp := Node (Elmt); 4584 4585 if Present (Ftyp) then 4586 4587 -- Don't build a derived type declaration, because predefined C 4588 -- types have no declaration anywhere, so cannot really be named. 4589 -- Instead build a full type declaration, starting with an 4590 -- appropriate type definition is built 4591 4592 if Is_Floating_Point_Type (Ftyp) then 4593 Def := Make_Floating_Point_Definition (Loc, 4594 Make_Integer_Literal (Loc, Digits_Value (Ftyp)), 4595 Make_Real_Range_Specification (Loc, 4596 Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))), 4597 Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp))))); 4598 4599 -- Should never have a predefined type we cannot handle 4600 4601 else 4602 raise Program_Error; 4603 end if; 4604 4605 -- Build and insert a Full_Type_Declaration, which will be 4606 -- analyzed as soon as this list entry has been analyzed. 4607 4608 Decl := Make_Full_Type_Declaration (Loc, 4609 Make_Defining_Identifier (Loc, Chars (Expression (Arg2))), 4610 Type_Definition => Def); 4611 4612 Insert_After (N, Decl); 4613 Mark_Rewrite_Insertion (Decl); 4614 4615 else 4616 Error_Pragma_Arg ("no matching type found for pragma%", 4617 Arg2); 4618 end if; 4619 end Process_Import_Predefined_Type; 4620 4621 --------------------------------- 4622 -- Process_Import_Or_Interface -- 4623 --------------------------------- 4624 4625 procedure Process_Import_Or_Interface is 4626 C : Convention_Id; 4627 Def_Id : Entity_Id; 4628 Hom_Id : Entity_Id; 4629 4630 begin 4631 Process_Convention (C, Def_Id); 4632 Kill_Size_Check_Code (Def_Id); 4633 Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); 4634 4635 if Ekind_In (Def_Id, E_Variable, E_Constant) then 4636 4637 -- We do not permit Import to apply to a renaming declaration 4638 4639 if Present (Renamed_Object (Def_Id)) then 4640 Error_Pragma_Arg 4641 ("pragma% not allowed for object renaming", Arg2); 4642 4643 -- User initialization is not allowed for imported object, but 4644 -- the object declaration may contain a default initialization, 4645 -- that will be discarded. Note that an explicit initialization 4646 -- only counts if it comes from source, otherwise it is simply 4647 -- the code generator making an implicit initialization explicit. 4648 4649 elsif Present (Expression (Parent (Def_Id))) 4650 and then Comes_From_Source (Expression (Parent (Def_Id))) 4651 then 4652 Error_Msg_Sloc := Sloc (Def_Id); 4653 Error_Pragma_Arg 4654 ("no initialization allowed for declaration of& #", 4655 "\imported entities cannot be initialized (RM B.1(24))", 4656 Arg2); 4657 4658 else 4659 Set_Imported (Def_Id); 4660 Process_Interface_Name (Def_Id, Arg3, Arg4); 4661 4662 -- Note that we do not set Is_Public here. That's because we 4663 -- only want to set it if there is no address clause, and we 4664 -- don't know that yet, so we delay that processing till 4665 -- freeze time. 4666 4667 -- pragma Import completes deferred constants 4668 4669 if Ekind (Def_Id) = E_Constant then 4670 Set_Has_Completion (Def_Id); 4671 end if; 4672 4673 -- It is not possible to import a constant of an unconstrained 4674 -- array type (e.g. string) because there is no simple way to 4675 -- write a meaningful subtype for it. 4676 4677 if Is_Array_Type (Etype (Def_Id)) 4678 and then not Is_Constrained (Etype (Def_Id)) 4679 then 4680 Error_Msg_NE 4681 ("imported constant& must have a constrained subtype", 4682 N, Def_Id); 4683 end if; 4684 end if; 4685 4686 elsif Is_Subprogram (Def_Id) 4687 or else Is_Generic_Subprogram (Def_Id) 4688 then 4689 -- If the name is overloaded, pragma applies to all of the denoted 4690 -- entities in the same declarative part, unless the pragma comes 4691 -- from an aspect specification. 4692 4693 Hom_Id := Def_Id; 4694 while Present (Hom_Id) loop 4695 4696 Def_Id := Get_Base_Subprogram (Hom_Id); 4697 4698 -- Ignore inherited subprograms because the pragma will apply 4699 -- to the parent operation, which is the one called. 4700 4701 if Is_Overloadable (Def_Id) 4702 and then Present (Alias (Def_Id)) 4703 then 4704 null; 4705 4706 -- If it is not a subprogram, it must be in an outer scope and 4707 -- pragma does not apply. 4708 4709 elsif not Is_Subprogram (Def_Id) 4710 and then not Is_Generic_Subprogram (Def_Id) 4711 then 4712 null; 4713 4714 -- The pragma does not apply to primitives of interfaces 4715 4716 elsif Is_Dispatching_Operation (Def_Id) 4717 and then Present (Find_Dispatching_Type (Def_Id)) 4718 and then Is_Interface (Find_Dispatching_Type (Def_Id)) 4719 then 4720 null; 4721 4722 -- Verify that the homonym is in the same declarative part (not 4723 -- just the same scope). If the pragma comes from an aspect 4724 -- specification we know that it is part of the declaration. 4725 4726 elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) 4727 and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux 4728 and then not From_Aspect_Specification (N) 4729 then 4730 exit; 4731 4732 else 4733 Set_Imported (Def_Id); 4734 4735 -- Reject an Import applied to an abstract subprogram 4736 4737 if Is_Subprogram (Def_Id) 4738 and then Is_Abstract_Subprogram (Def_Id) 4739 then 4740 Error_Msg_Sloc := Sloc (Def_Id); 4741 Error_Msg_NE 4742 ("cannot import abstract subprogram& declared#", 4743 Arg2, Def_Id); 4744 end if; 4745 4746 -- Special processing for Convention_Intrinsic 4747 4748 if C = Convention_Intrinsic then 4749 4750 -- Link_Name argument not allowed for intrinsic 4751 4752 Check_No_Link_Name; 4753 4754 Set_Is_Intrinsic_Subprogram (Def_Id); 4755 4756 -- If no external name is present, then check that this 4757 -- is a valid intrinsic subprogram. If an external name 4758 -- is present, then this is handled by the back end. 4759 4760 if No (Arg3) then 4761 Check_Intrinsic_Subprogram 4762 (Def_Id, Get_Pragma_Arg (Arg2)); 4763 end if; 4764 end if; 4765 4766 -- All interfaced procedures need an external symbol created 4767 -- for them since they are always referenced from another 4768 -- object file. 4769 4770 Set_Is_Public (Def_Id); 4771 4772 -- Verify that the subprogram does not have a completion 4773 -- through a renaming declaration. For other completions the 4774 -- pragma appears as a too late representation. 4775 4776 declare 4777 Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); 4778 4779 begin 4780 if Present (Decl) 4781 and then Nkind (Decl) = N_Subprogram_Declaration 4782 and then Present (Corresponding_Body (Decl)) 4783 and then Nkind (Unit_Declaration_Node 4784 (Corresponding_Body (Decl))) = 4785 N_Subprogram_Renaming_Declaration 4786 then 4787 Error_Msg_Sloc := Sloc (Def_Id); 4788 Error_Msg_NE 4789 ("cannot import&, renaming already provided for " & 4790 "declaration #", N, Def_Id); 4791 end if; 4792 end; 4793 4794 Set_Has_Completion (Def_Id); 4795 Process_Interface_Name (Def_Id, Arg3, Arg4); 4796 end if; 4797 4798 if Is_Compilation_Unit (Hom_Id) then 4799 4800 -- Its possible homonyms are not affected by the pragma. 4801 -- Such homonyms might be present in the context of other 4802 -- units being compiled. 4803 4804 exit; 4805 4806 elsif From_Aspect_Specification (N) then 4807 exit; 4808 4809 else 4810 Hom_Id := Homonym (Hom_Id); 4811 end if; 4812 end loop; 4813 4814 -- When the convention is Java or CIL, we also allow Import to be 4815 -- given for packages, generic packages, exceptions, record 4816 -- components, and access to subprograms. 4817 4818 elsif (C = Convention_Java or else C = Convention_CIL) 4819 and then 4820 (Is_Package_Or_Generic_Package (Def_Id) 4821 or else Ekind (Def_Id) = E_Exception 4822 or else Ekind (Def_Id) = E_Access_Subprogram_Type 4823 or else Nkind (Parent (Def_Id)) = N_Component_Declaration) 4824 then 4825 Set_Imported (Def_Id); 4826 Set_Is_Public (Def_Id); 4827 Process_Interface_Name (Def_Id, Arg3, Arg4); 4828 4829 -- Import a CPP class 4830 4831 elsif C = Convention_CPP 4832 and then (Is_Record_Type (Def_Id) 4833 or else Ekind (Def_Id) = E_Incomplete_Type) 4834 then 4835 if Ekind (Def_Id) = E_Incomplete_Type then 4836 if Present (Full_View (Def_Id)) then 4837 Def_Id := Full_View (Def_Id); 4838 4839 else 4840 Error_Msg_N 4841 ("cannot import 'C'P'P type before full declaration seen", 4842 Get_Pragma_Arg (Arg2)); 4843 4844 -- Although we have reported the error we decorate it as 4845 -- CPP_Class to avoid reporting spurious errors 4846 4847 Set_Is_CPP_Class (Def_Id); 4848 return; 4849 end if; 4850 end if; 4851 4852 -- Types treated as CPP classes must be declared limited (note: 4853 -- this used to be a warning but there is no real benefit to it 4854 -- since we did effectively intend to treat the type as limited 4855 -- anyway). 4856 4857 if not Is_Limited_Type (Def_Id) then 4858 Error_Msg_N 4859 ("imported 'C'P'P type must be limited", 4860 Get_Pragma_Arg (Arg2)); 4861 end if; 4862 4863 if Etype (Def_Id) /= Def_Id 4864 and then not Is_CPP_Class (Root_Type (Def_Id)) 4865 then 4866 Error_Msg_N ("root type must be a 'C'P'P type", Arg1); 4867 end if; 4868 4869 Set_Is_CPP_Class (Def_Id); 4870 4871 -- Imported CPP types must not have discriminants (because C++ 4872 -- classes do not have discriminants). 4873 4874 if Has_Discriminants (Def_Id) then 4875 Error_Msg_N 4876 ("imported 'C'P'P type cannot have discriminants", 4877 First (Discriminant_Specifications 4878 (Declaration_Node (Def_Id)))); 4879 end if; 4880 4881 -- Check that components of imported CPP types do not have default 4882 -- expressions. For private types this check is performed when the 4883 -- full view is analyzed (see Process_Full_View). 4884 4885 if not Is_Private_Type (Def_Id) then 4886 Check_CPP_Type_Has_No_Defaults (Def_Id); 4887 end if; 4888 4889 elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then 4890 Check_No_Link_Name; 4891 Check_Arg_Count (3); 4892 Check_Arg_Is_Static_Expression (Arg3, Standard_String); 4893 4894 Process_Import_Predefined_Type; 4895 4896 else 4897 Error_Pragma_Arg 4898 ("second argument of pragma% must be object, subprogram " 4899 & "or incomplete type", 4900 Arg2); 4901 end if; 4902 4903 -- If this pragma applies to a compilation unit, then the unit, which 4904 -- is a subprogram, does not require (or allow) a body. We also do 4905 -- not need to elaborate imported procedures. 4906 4907 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 4908 declare 4909 Cunit : constant Node_Id := Parent (Parent (N)); 4910 begin 4911 Set_Body_Required (Cunit, False); 4912 end; 4913 end if; 4914 end Process_Import_Or_Interface; 4915 4916 -------------------- 4917 -- Process_Inline -- 4918 -------------------- 4919 4920 procedure Process_Inline (Status : Inline_Status) is 4921 Assoc : Node_Id; 4922 Decl : Node_Id; 4923 Subp_Id : Node_Id; 4924 Subp : Entity_Id; 4925 Applies : Boolean; 4926 4927 Effective : Boolean := False; 4928 -- Set True if inline has some effect, i.e. if there is at least one 4929 -- subprogram set as inlined as a result of the use of the pragma. 4930 4931 procedure Make_Inline (Subp : Entity_Id); 4932 -- Subp is the defining unit name of the subprogram declaration. Set 4933 -- the flag, as well as the flag in the corresponding body, if there 4934 -- is one present. 4935 4936 procedure Set_Inline_Flags (Subp : Entity_Id); 4937 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also 4938 -- Has_Pragma_Inline_Always for the Inline_Always case. 4939 4940 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; 4941 -- Returns True if it can be determined at this stage that inlining 4942 -- is not possible, for example if the body is available and contains 4943 -- exception handlers, we prevent inlining, since otherwise we can 4944 -- get undefined symbols at link time. This function also emits a 4945 -- warning if front-end inlining is enabled and the pragma appears 4946 -- too late. 4947 -- 4948 -- ??? is business with link symbols still valid, or does it relate 4949 -- to front end ZCX which is being phased out ??? 4950 4951 --------------------------- 4952 -- Inlining_Not_Possible -- 4953 --------------------------- 4954 4955 function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is 4956 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 4957 Stats : Node_Id; 4958 4959 begin 4960 if Nkind (Decl) = N_Subprogram_Body then 4961 Stats := Handled_Statement_Sequence (Decl); 4962 return Present (Exception_Handlers (Stats)) 4963 or else Present (At_End_Proc (Stats)); 4964 4965 elsif Nkind (Decl) = N_Subprogram_Declaration 4966 and then Present (Corresponding_Body (Decl)) 4967 then 4968 if Front_End_Inlining 4969 and then Analyzed (Corresponding_Body (Decl)) 4970 then 4971 Error_Msg_N ("pragma appears too late, ignored??", N); 4972 return True; 4973 4974 -- If the subprogram is a renaming as body, the body is just a 4975 -- call to the renamed subprogram, and inlining is trivially 4976 -- possible. 4977 4978 elsif 4979 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = 4980 N_Subprogram_Renaming_Declaration 4981 then 4982 return False; 4983 4984 else 4985 Stats := 4986 Handled_Statement_Sequence 4987 (Unit_Declaration_Node (Corresponding_Body (Decl))); 4988 4989 return 4990 Present (Exception_Handlers (Stats)) 4991 or else Present (At_End_Proc (Stats)); 4992 end if; 4993 4994 else 4995 -- If body is not available, assume the best, the check is 4996 -- performed again when compiling enclosing package bodies. 4997 4998 return False; 4999 end if; 5000 end Inlining_Not_Possible; 5001 5002 ----------------- 5003 -- Make_Inline -- 5004 ----------------- 5005 5006 procedure Make_Inline (Subp : Entity_Id) is 5007 Kind : constant Entity_Kind := Ekind (Subp); 5008 Inner_Subp : Entity_Id := Subp; 5009 5010 begin 5011 -- Ignore if bad type, avoid cascaded error 5012 5013 if Etype (Subp) = Any_Type then 5014 Applies := True; 5015 return; 5016 5017 -- Ignore if all inlining is suppressed 5018 5019 elsif Suppress_All_Inlining then 5020 Applies := True; 5021 return; 5022 5023 -- If inlining is not possible, for now do not treat as an error 5024 5025 elsif Status /= Suppressed 5026 and then Inlining_Not_Possible (Subp) 5027 then 5028 Applies := True; 5029 return; 5030 5031 -- Here we have a candidate for inlining, but we must exclude 5032 -- derived operations. Otherwise we would end up trying to inline 5033 -- a phantom declaration, and the result would be to drag in a 5034 -- body which has no direct inlining associated with it. That 5035 -- would not only be inefficient but would also result in the 5036 -- backend doing cross-unit inlining in cases where it was 5037 -- definitely inappropriate to do so. 5038 5039 -- However, a simple Comes_From_Source test is insufficient, since 5040 -- we do want to allow inlining of generic instances which also do 5041 -- not come from source. We also need to recognize specs generated 5042 -- by the front-end for bodies that carry the pragma. Finally, 5043 -- predefined operators do not come from source but are not 5044 -- inlineable either. 5045 5046 elsif Is_Generic_Instance (Subp) 5047 or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration 5048 then 5049 null; 5050 5051 elsif not Comes_From_Source (Subp) 5052 and then Scope (Subp) /= Standard_Standard 5053 then 5054 Applies := True; 5055 return; 5056 end if; 5057 5058 -- The referenced entity must either be the enclosing entity, or 5059 -- an entity declared within the current open scope. 5060 5061 if Present (Scope (Subp)) 5062 and then Scope (Subp) /= Current_Scope 5063 and then Subp /= Current_Scope 5064 then 5065 Error_Pragma_Arg 5066 ("argument of% must be entity in current scope", Assoc); 5067 return; 5068 end if; 5069 5070 -- Processing for procedure, operator or function. If subprogram 5071 -- is aliased (as for an instance) indicate that the renamed 5072 -- entity (if declared in the same unit) is inlined. 5073 5074 if Is_Subprogram (Subp) then 5075 Inner_Subp := Ultimate_Alias (Inner_Subp); 5076 5077 if In_Same_Source_Unit (Subp, Inner_Subp) then 5078 Set_Inline_Flags (Inner_Subp); 5079 5080 Decl := Parent (Parent (Inner_Subp)); 5081 5082 if Nkind (Decl) = N_Subprogram_Declaration 5083 and then Present (Corresponding_Body (Decl)) 5084 then 5085 Set_Inline_Flags (Corresponding_Body (Decl)); 5086 5087 elsif Is_Generic_Instance (Subp) then 5088 5089 -- Indicate that the body needs to be created for 5090 -- inlining subsequent calls. The instantiation node 5091 -- follows the declaration of the wrapper package 5092 -- created for it. 5093 5094 if Scope (Subp) /= Standard_Standard 5095 and then 5096 Need_Subprogram_Instance_Body 5097 (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), 5098 Subp) 5099 then 5100 null; 5101 end if; 5102 5103 -- Inline is a program unit pragma (RM 10.1.5) and cannot 5104 -- appear in a formal part to apply to a formal subprogram. 5105 -- Do not apply check within an instance or a formal package 5106 -- the test will have been applied to the original generic. 5107 5108 elsif Nkind (Decl) in N_Formal_Subprogram_Declaration 5109 and then List_Containing (Decl) = List_Containing (N) 5110 and then not In_Instance 5111 then 5112 Error_Msg_N 5113 ("Inline cannot apply to a formal subprogram", N); 5114 5115 -- If Subp is a renaming, it is the renamed entity that 5116 -- will appear in any call, and be inlined. However, for 5117 -- ASIS uses it is convenient to indicate that the renaming 5118 -- itself is an inlined subprogram, so that some gnatcheck 5119 -- rules can be applied in the absence of expansion. 5120 5121 elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then 5122 Set_Inline_Flags (Subp); 5123 end if; 5124 end if; 5125 5126 Applies := True; 5127 5128 -- For a generic subprogram set flag as well, for use at the point 5129 -- of instantiation, to determine whether the body should be 5130 -- generated. 5131 5132 elsif Is_Generic_Subprogram (Subp) then 5133 Set_Inline_Flags (Subp); 5134 Applies := True; 5135 5136 -- Literals are by definition inlined 5137 5138 elsif Kind = E_Enumeration_Literal then 5139 null; 5140 5141 -- Anything else is an error 5142 5143 else 5144 Error_Pragma_Arg 5145 ("expect subprogram name for pragma%", Assoc); 5146 end if; 5147 end Make_Inline; 5148 5149 ---------------------- 5150 -- Set_Inline_Flags -- 5151 ---------------------- 5152 5153 procedure Set_Inline_Flags (Subp : Entity_Id) is 5154 begin 5155 -- First set the Has_Pragma_XXX flags and issue the appropriate 5156 -- errors and warnings for suspicious combinations. 5157 5158 if Prag_Id = Pragma_No_Inline then 5159 if Has_Pragma_Inline_Always (Subp) then 5160 Error_Msg_N 5161 ("Inline_Always and No_Inline are mutually exclusive", N); 5162 elsif Has_Pragma_Inline (Subp) then 5163 Error_Msg_NE 5164 ("Inline and No_Inline both specified for& ??", 5165 N, Entity (Subp_Id)); 5166 end if; 5167 5168 Set_Has_Pragma_No_Inline (Subp); 5169 else 5170 if Prag_Id = Pragma_Inline_Always then 5171 if Has_Pragma_No_Inline (Subp) then 5172 Error_Msg_N 5173 ("Inline_Always and No_Inline are mutually exclusive", 5174 N); 5175 end if; 5176 5177 Set_Has_Pragma_Inline_Always (Subp); 5178 else 5179 if Has_Pragma_No_Inline (Subp) then 5180 Error_Msg_NE 5181 ("Inline and No_Inline both specified for& ??", 5182 N, Entity (Subp_Id)); 5183 end if; 5184 end if; 5185 5186 if not Has_Pragma_Inline (Subp) then 5187 Set_Has_Pragma_Inline (Subp); 5188 Effective := True; 5189 end if; 5190 end if; 5191 5192 -- Then adjust the Is_Inlined flag. It can never be set if the 5193 -- subprogram is subject to pragma No_Inline. 5194 5195 case Status is 5196 when Suppressed => 5197 Set_Is_Inlined (Subp, False); 5198 when Disabled => 5199 null; 5200 when Enabled => 5201 if not Has_Pragma_No_Inline (Subp) then 5202 Set_Is_Inlined (Subp, True); 5203 end if; 5204 end case; 5205 end Set_Inline_Flags; 5206 5207 -- Start of processing for Process_Inline 5208 5209 begin 5210 Check_No_Identifiers; 5211 Check_At_Least_N_Arguments (1); 5212 5213 if Status = Enabled then 5214 Inline_Processing_Required := True; 5215 end if; 5216 5217 Assoc := Arg1; 5218 while Present (Assoc) loop 5219 Subp_Id := Get_Pragma_Arg (Assoc); 5220 Analyze (Subp_Id); 5221 Applies := False; 5222 5223 if Is_Entity_Name (Subp_Id) then 5224 Subp := Entity (Subp_Id); 5225 5226 if Subp = Any_Id then 5227 5228 -- If previous error, avoid cascaded errors 5229 5230 Check_Error_Detected; 5231 Applies := True; 5232 Effective := True; 5233 5234 else 5235 Make_Inline (Subp); 5236 5237 -- For the pragma case, climb homonym chain. This is 5238 -- what implements allowing the pragma in the renaming 5239 -- case, with the result applying to the ancestors, and 5240 -- also allows Inline to apply to all previous homonyms. 5241 5242 if not From_Aspect_Specification (N) then 5243 while Present (Homonym (Subp)) 5244 and then Scope (Homonym (Subp)) = Current_Scope 5245 loop 5246 Make_Inline (Homonym (Subp)); 5247 Subp := Homonym (Subp); 5248 end loop; 5249 end if; 5250 end if; 5251 end if; 5252 5253 if not Applies then 5254 Error_Pragma_Arg 5255 ("inappropriate argument for pragma%", Assoc); 5256 5257 elsif not Effective 5258 and then Warn_On_Redundant_Constructs 5259 and then not (Status = Suppressed or Suppress_All_Inlining) 5260 then 5261 if Inlining_Not_Possible (Subp) then 5262 Error_Msg_NE 5263 ("pragma Inline for& is ignored?r?", 5264 N, Entity (Subp_Id)); 5265 else 5266 Error_Msg_NE 5267 ("pragma Inline for& is redundant?r?", 5268 N, Entity (Subp_Id)); 5269 end if; 5270 end if; 5271 5272 Next (Assoc); 5273 end loop; 5274 end Process_Inline; 5275 5276 ---------------------------- 5277 -- Process_Interface_Name -- 5278 ---------------------------- 5279 5280 procedure Process_Interface_Name 5281 (Subprogram_Def : Entity_Id; 5282 Ext_Arg : Node_Id; 5283 Link_Arg : Node_Id) 5284 is 5285 Ext_Nam : Node_Id; 5286 Link_Nam : Node_Id; 5287 String_Val : String_Id; 5288 5289 procedure Check_Form_Of_Interface_Name 5290 (SN : Node_Id; 5291 Ext_Name_Case : Boolean); 5292 -- SN is a string literal node for an interface name. This routine 5293 -- performs some minimal checks that the name is reasonable. In 5294 -- particular that no spaces or other obviously incorrect characters 5295 -- appear. This is only a warning, since any characters are allowed. 5296 -- Ext_Name_Case is True for an External_Name, False for a Link_Name. 5297 5298 ---------------------------------- 5299 -- Check_Form_Of_Interface_Name -- 5300 ---------------------------------- 5301 5302 procedure Check_Form_Of_Interface_Name 5303 (SN : Node_Id; 5304 Ext_Name_Case : Boolean) 5305 is 5306 S : constant String_Id := Strval (Expr_Value_S (SN)); 5307 SL : constant Nat := String_Length (S); 5308 C : Char_Code; 5309 5310 begin 5311 if SL = 0 then 5312 Error_Msg_N ("interface name cannot be null string", SN); 5313 end if; 5314 5315 for J in 1 .. SL loop 5316 C := Get_String_Char (S, J); 5317 5318 -- Look for dubious character and issue unconditional warning. 5319 -- Definitely dubious if not in character range. 5320 5321 if not In_Character_Range (C) 5322 5323 -- For all cases except CLI target, 5324 -- commas, spaces and slashes are dubious (in CLI, we use 5325 -- commas and backslashes in external names to specify 5326 -- assembly version and public key, while slashes and spaces 5327 -- can be used in names to mark nested classes and 5328 -- valuetypes). 5329 5330 or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) 5331 and then (Get_Character (C) = ',' 5332 or else 5333 Get_Character (C) = '\')) 5334 or else (VM_Target /= CLI_Target 5335 and then (Get_Character (C) = ' ' 5336 or else 5337 Get_Character (C) = '/')) 5338 then 5339 Error_Msg 5340 ("??interface name contains illegal character", 5341 Sloc (SN) + Source_Ptr (J)); 5342 end if; 5343 end loop; 5344 end Check_Form_Of_Interface_Name; 5345 5346 -- Start of processing for Process_Interface_Name 5347 5348 begin 5349 if No (Link_Arg) then 5350 if No (Ext_Arg) then 5351 if VM_Target = CLI_Target 5352 and then Ekind (Subprogram_Def) = E_Package 5353 and then Nkind (Parent (Subprogram_Def)) = 5354 N_Package_Specification 5355 and then Present (Generic_Parent (Parent (Subprogram_Def))) 5356 then 5357 Set_Interface_Name 5358 (Subprogram_Def, 5359 Interface_Name 5360 (Generic_Parent (Parent (Subprogram_Def)))); 5361 end if; 5362 5363 return; 5364 5365 elsif Chars (Ext_Arg) = Name_Link_Name then 5366 Ext_Nam := Empty; 5367 Link_Nam := Expression (Ext_Arg); 5368 5369 else 5370 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 5371 Ext_Nam := Expression (Ext_Arg); 5372 Link_Nam := Empty; 5373 end if; 5374 5375 else 5376 Check_Optional_Identifier (Ext_Arg, Name_External_Name); 5377 Check_Optional_Identifier (Link_Arg, Name_Link_Name); 5378 Ext_Nam := Expression (Ext_Arg); 5379 Link_Nam := Expression (Link_Arg); 5380 end if; 5381 5382 -- Check expressions for external name and link name are static 5383 5384 if Present (Ext_Nam) then 5385 Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); 5386 Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); 5387 5388 -- Verify that external name is not the name of a local entity, 5389 -- which would hide the imported one and could lead to run-time 5390 -- surprises. The problem can only arise for entities declared in 5391 -- a package body (otherwise the external name is fully qualified 5392 -- and will not conflict). 5393 5394 declare 5395 Nam : Name_Id; 5396 E : Entity_Id; 5397 Par : Node_Id; 5398 5399 begin 5400 if Prag_Id = Pragma_Import then 5401 String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); 5402 Nam := Name_Find; 5403 E := Entity_Id (Get_Name_Table_Info (Nam)); 5404 5405 if Nam /= Chars (Subprogram_Def) 5406 and then Present (E) 5407 and then not Is_Overloadable (E) 5408 and then Is_Immediately_Visible (E) 5409 and then not Is_Imported (E) 5410 and then Ekind (Scope (E)) = E_Package 5411 then 5412 Par := Parent (E); 5413 while Present (Par) loop 5414 if Nkind (Par) = N_Package_Body then 5415 Error_Msg_Sloc := Sloc (E); 5416 Error_Msg_NE 5417 ("imported entity is hidden by & declared#", 5418 Ext_Arg, E); 5419 exit; 5420 end if; 5421 5422 Par := Parent (Par); 5423 end loop; 5424 end if; 5425 end if; 5426 end; 5427 end if; 5428 5429 if Present (Link_Nam) then 5430 Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); 5431 Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); 5432 end if; 5433 5434 -- If there is no link name, just set the external name 5435 5436 if No (Link_Nam) then 5437 Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); 5438 5439 -- For the Link_Name case, the given literal is preceded by an 5440 -- asterisk, which indicates to GCC that the given name should be 5441 -- taken literally, and in particular that no prepending of 5442 -- underlines should occur, even in systems where this is the 5443 -- normal default. 5444 5445 else 5446 Start_String; 5447 5448 if VM_Target = No_VM then 5449 Store_String_Char (Get_Char_Code ('*')); 5450 end if; 5451 5452 String_Val := Strval (Expr_Value_S (Link_Nam)); 5453 Store_String_Chars (String_Val); 5454 Link_Nam := 5455 Make_String_Literal (Sloc (Link_Nam), 5456 Strval => End_String); 5457 end if; 5458 5459 -- Set the interface name. If the entity is a generic instance, use 5460 -- its alias, which is the callable entity. 5461 5462 if Is_Generic_Instance (Subprogram_Def) then 5463 Set_Encoded_Interface_Name 5464 (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); 5465 else 5466 Set_Encoded_Interface_Name 5467 (Get_Base_Subprogram (Subprogram_Def), Link_Nam); 5468 end if; 5469 5470 -- We allow duplicated export names in CIL/Java, as they are always 5471 -- enclosed in a namespace that differentiates them, and overloaded 5472 -- entities are supported by the VM. 5473 5474 if Convention (Subprogram_Def) /= Convention_CIL 5475 and then 5476 Convention (Subprogram_Def) /= Convention_Java 5477 then 5478 Check_Duplicated_Export_Name (Link_Nam); 5479 end if; 5480 end Process_Interface_Name; 5481 5482 ----------------------------------------- 5483 -- Process_Interrupt_Or_Attach_Handler -- 5484 ----------------------------------------- 5485 5486 procedure Process_Interrupt_Or_Attach_Handler is 5487 Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); 5488 Handler_Proc : constant Entity_Id := Entity (Arg1_X); 5489 Proc_Scope : constant Entity_Id := Scope (Handler_Proc); 5490 5491 begin 5492 Set_Is_Interrupt_Handler (Handler_Proc); 5493 5494 -- If the pragma is not associated with a handler procedure within a 5495 -- protected type, then it must be for a nonprotected procedure for 5496 -- the AAMP target, in which case we don't associate a representation 5497 -- item with the procedure's scope. 5498 5499 if Ekind (Proc_Scope) = E_Protected_Type then 5500 if Prag_Id = Pragma_Interrupt_Handler 5501 or else 5502 Prag_Id = Pragma_Attach_Handler 5503 then 5504 Record_Rep_Item (Proc_Scope, N); 5505 end if; 5506 end if; 5507 end Process_Interrupt_Or_Attach_Handler; 5508 5509 -------------------------------------------------- 5510 -- Process_Restrictions_Or_Restriction_Warnings -- 5511 -------------------------------------------------- 5512 5513 -- Note: some of the simple identifier cases were handled in par-prag, 5514 -- but it is harmless (and more straightforward) to simply handle all 5515 -- cases here, even if it means we repeat a bit of work in some cases. 5516 5517 procedure Process_Restrictions_Or_Restriction_Warnings 5518 (Warn : Boolean) 5519 is 5520 Arg : Node_Id; 5521 R_Id : Restriction_Id; 5522 Id : Name_Id; 5523 Expr : Node_Id; 5524 Val : Uint; 5525 5526 procedure Check_Unit_Name (N : Node_Id); 5527 -- Checks unit name parameter for No_Dependence. Returns if it has 5528 -- an appropriate form, otherwise raises pragma argument error. 5529 5530 --------------------- 5531 -- Check_Unit_Name -- 5532 --------------------- 5533 5534 procedure Check_Unit_Name (N : Node_Id) is 5535 begin 5536 if Nkind (N) = N_Selected_Component then 5537 Check_Unit_Name (Prefix (N)); 5538 Check_Unit_Name (Selector_Name (N)); 5539 5540 elsif Nkind (N) = N_Identifier then 5541 return; 5542 5543 else 5544 Error_Pragma_Arg 5545 ("wrong form for unit name for No_Dependence", N); 5546 end if; 5547 end Check_Unit_Name; 5548 5549 -- Start of processing for Process_Restrictions_Or_Restriction_Warnings 5550 5551 begin 5552 -- Ignore all Restrictions pragma in CodePeer mode 5553 5554 if CodePeer_Mode then 5555 return; 5556 end if; 5557 5558 Check_Ada_83_Warning; 5559 Check_At_Least_N_Arguments (1); 5560 Check_Valid_Configuration_Pragma; 5561 5562 Arg := Arg1; 5563 while Present (Arg) loop 5564 Id := Chars (Arg); 5565 Expr := Get_Pragma_Arg (Arg); 5566 5567 -- Case of no restriction identifier present 5568 5569 if Id = No_Name then 5570 if Nkind (Expr) /= N_Identifier then 5571 Error_Pragma_Arg 5572 ("invalid form for restriction", Arg); 5573 end if; 5574 5575 R_Id := 5576 Get_Restriction_Id 5577 (Process_Restriction_Synonyms (Expr)); 5578 5579 if R_Id not in All_Boolean_Restrictions then 5580 Error_Msg_Name_1 := Pname; 5581 Error_Msg_N 5582 ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); 5583 5584 -- Check for possible misspelling 5585 5586 for J in Restriction_Id loop 5587 declare 5588 Rnm : constant String := Restriction_Id'Image (J); 5589 5590 begin 5591 Name_Buffer (1 .. Rnm'Length) := Rnm; 5592 Name_Len := Rnm'Length; 5593 Set_Casing (All_Lower_Case); 5594 5595 if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then 5596 Set_Casing 5597 (Identifier_Casing (Current_Source_File)); 5598 Error_Msg_String (1 .. Rnm'Length) := 5599 Name_Buffer (1 .. Name_Len); 5600 Error_Msg_Strlen := Rnm'Length; 5601 Error_Msg_N -- CODEFIX 5602 ("\possible misspelling of ""~""", 5603 Get_Pragma_Arg (Arg)); 5604 exit; 5605 end if; 5606 end; 5607 end loop; 5608 5609 raise Pragma_Exit; 5610 end if; 5611 5612 if Implementation_Restriction (R_Id) then 5613 Check_Restriction (No_Implementation_Restrictions, Arg); 5614 end if; 5615 5616 -- Special processing for No_Elaboration_Code restriction 5617 5618 if R_Id = No_Elaboration_Code then 5619 5620 -- Restriction is only recognized within a configuration 5621 -- pragma file, or within a unit of the main extended 5622 -- program. Note: the test for Main_Unit is needed to 5623 -- properly include the case of configuration pragma files. 5624 5625 if not (Current_Sem_Unit = Main_Unit 5626 or else In_Extended_Main_Source_Unit (N)) 5627 then 5628 return; 5629 5630 -- Don't allow in a subunit unless already specified in 5631 -- body or spec. 5632 5633 elsif Nkind (Parent (N)) = N_Compilation_Unit 5634 and then Nkind (Unit (Parent (N))) = N_Subunit 5635 and then not Restriction_Active (No_Elaboration_Code) 5636 then 5637 Error_Msg_N 5638 ("invalid specification of ""No_Elaboration_Code""", 5639 N); 5640 Error_Msg_N 5641 ("\restriction cannot be specified in a subunit", N); 5642 Error_Msg_N 5643 ("\unless also specified in body or spec", N); 5644 return; 5645 5646 -- If we have a No_Elaboration_Code pragma that we 5647 -- accept, then it needs to be added to the configuration 5648 -- restrcition set so that we get proper application to 5649 -- other units in the main extended source as required. 5650 5651 else 5652 Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); 5653 end if; 5654 end if; 5655 5656 -- If this is a warning, then set the warning unless we already 5657 -- have a real restriction active (we never want a warning to 5658 -- override a real restriction). 5659 5660 if Warn then 5661 if not Restriction_Active (R_Id) then 5662 Set_Restriction (R_Id, N); 5663 Restriction_Warnings (R_Id) := True; 5664 end if; 5665 5666 -- If real restriction case, then set it and make sure that the 5667 -- restriction warning flag is off, since a real restriction 5668 -- always overrides a warning. 5669 5670 else 5671 Set_Restriction (R_Id, N); 5672 Restriction_Warnings (R_Id) := False; 5673 end if; 5674 5675 -- Check for obsolescent restrictions in Ada 2005 mode 5676 5677 if not Warn 5678 and then Ada_Version >= Ada_2005 5679 and then (R_Id = No_Asynchronous_Control 5680 or else 5681 R_Id = No_Unchecked_Deallocation 5682 or else 5683 R_Id = No_Unchecked_Conversion) 5684 then 5685 Check_Restriction (No_Obsolescent_Features, N); 5686 end if; 5687 5688 -- A very special case that must be processed here: pragma 5689 -- Restrictions (No_Exceptions) turns off all run-time 5690 -- checking. This is a bit dubious in terms of the formal 5691 -- language definition, but it is what is intended by RM 5692 -- H.4(12). Restriction_Warnings never affects generated code 5693 -- so this is done only in the real restriction case. 5694 5695 -- Atomic_Synchronization is not a real check, so it is not 5696 -- affected by this processing). 5697 5698 if R_Id = No_Exceptions and then not Warn then 5699 for J in Scope_Suppress.Suppress'Range loop 5700 if J /= Atomic_Synchronization then 5701 Scope_Suppress.Suppress (J) := True; 5702 end if; 5703 end loop; 5704 end if; 5705 5706 -- Case of No_Dependence => unit-name. Note that the parser 5707 -- already made the necessary entry in the No_Dependence table. 5708 5709 elsif Id = Name_No_Dependence then 5710 Check_Unit_Name (Expr); 5711 5712 -- Case of No_Specification_Of_Aspect => Identifier. 5713 5714 elsif Id = Name_No_Specification_Of_Aspect then 5715 declare 5716 A_Id : Aspect_Id; 5717 5718 begin 5719 if Nkind (Expr) /= N_Identifier then 5720 A_Id := No_Aspect; 5721 else 5722 A_Id := Get_Aspect_Id (Chars (Expr)); 5723 end if; 5724 5725 if A_Id = No_Aspect then 5726 Error_Pragma_Arg ("invalid restriction name", Arg); 5727 else 5728 Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); 5729 end if; 5730 end; 5731 5732 -- All other cases of restriction identifier present 5733 5734 else 5735 R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); 5736 Analyze_And_Resolve (Expr, Any_Integer); 5737 5738 if R_Id not in All_Parameter_Restrictions then 5739 Error_Pragma_Arg 5740 ("invalid restriction parameter identifier", Arg); 5741 5742 elsif not Is_OK_Static_Expression (Expr) then 5743 Flag_Non_Static_Expr 5744 ("value must be static expression!", Expr); 5745 raise Pragma_Exit; 5746 5747 elsif not Is_Integer_Type (Etype (Expr)) 5748 or else Expr_Value (Expr) < 0 5749 then 5750 Error_Pragma_Arg 5751 ("value must be non-negative integer", Arg); 5752 end if; 5753 5754 -- Restriction pragma is active 5755 5756 Val := Expr_Value (Expr); 5757 5758 if not UI_Is_In_Int_Range (Val) then 5759 Error_Pragma_Arg 5760 ("pragma ignored, value too large??", Arg); 5761 end if; 5762 5763 -- Warning case. If the real restriction is active, then we 5764 -- ignore the request, since warning never overrides a real 5765 -- restriction. Otherwise we set the proper warning. Note that 5766 -- this circuit sets the warning again if it is already set, 5767 -- which is what we want, since the constant may have changed. 5768 5769 if Warn then 5770 if not Restriction_Active (R_Id) then 5771 Set_Restriction 5772 (R_Id, N, Integer (UI_To_Int (Val))); 5773 Restriction_Warnings (R_Id) := True; 5774 end if; 5775 5776 -- Real restriction case, set restriction and make sure warning 5777 -- flag is off since real restriction always overrides warning. 5778 5779 else 5780 Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); 5781 Restriction_Warnings (R_Id) := False; 5782 end if; 5783 end if; 5784 5785 Next (Arg); 5786 end loop; 5787 end Process_Restrictions_Or_Restriction_Warnings; 5788 5789 --------------------------------- 5790 -- Process_Suppress_Unsuppress -- 5791 --------------------------------- 5792 5793 -- Note: this procedure makes entries in the check suppress data 5794 -- structures managed by Sem. See spec of package Sem for full 5795 -- details on how we handle recording of check suppression. 5796 5797 procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is 5798 C : Check_Id; 5799 E_Id : Node_Id; 5800 E : Entity_Id; 5801 5802 In_Package_Spec : constant Boolean := 5803 Is_Package_Or_Generic_Package (Current_Scope) 5804 and then not In_Package_Body (Current_Scope); 5805 5806 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); 5807 -- Used to suppress a single check on the given entity 5808 5809 -------------------------------- 5810 -- Suppress_Unsuppress_Echeck -- 5811 -------------------------------- 5812 5813 procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is 5814 begin 5815 -- Check for error of trying to set atomic synchronization for 5816 -- a non-atomic variable. 5817 5818 if C = Atomic_Synchronization 5819 and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) 5820 then 5821 Error_Msg_N 5822 ("pragma & requires atomic type or variable", 5823 Pragma_Identifier (Original_Node (N))); 5824 end if; 5825 5826 Set_Checks_May_Be_Suppressed (E); 5827 5828 if In_Package_Spec then 5829 Push_Global_Suppress_Stack_Entry 5830 (Entity => E, 5831 Check => C, 5832 Suppress => Suppress_Case); 5833 else 5834 Push_Local_Suppress_Stack_Entry 5835 (Entity => E, 5836 Check => C, 5837 Suppress => Suppress_Case); 5838 end if; 5839 5840 -- If this is a first subtype, and the base type is distinct, 5841 -- then also set the suppress flags on the base type. 5842 5843 if Is_First_Subtype (E) and then Etype (E) /= E then 5844 Suppress_Unsuppress_Echeck (Etype (E), C); 5845 end if; 5846 end Suppress_Unsuppress_Echeck; 5847 5848 -- Start of processing for Process_Suppress_Unsuppress 5849 5850 begin 5851 -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on 5852 -- user code: we want to generate checks for analysis purposes, as 5853 -- set respectively by -gnatC and -gnatd.F 5854 5855 if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then 5856 return; 5857 end if; 5858 5859 -- Suppress/Unsuppress can appear as a configuration pragma, or in a 5860 -- declarative part or a package spec (RM 11.5(5)). 5861 5862 if not Is_Configuration_Pragma then 5863 Check_Is_In_Decl_Part_Or_Package_Spec; 5864 end if; 5865 5866 Check_At_Least_N_Arguments (1); 5867 Check_At_Most_N_Arguments (2); 5868 Check_No_Identifier (Arg1); 5869 Check_Arg_Is_Identifier (Arg1); 5870 5871 C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); 5872 5873 if C = No_Check_Id then 5874 Error_Pragma_Arg 5875 ("argument of pragma% is not valid check name", Arg1); 5876 end if; 5877 5878 if Arg_Count = 1 then 5879 5880 -- Make an entry in the local scope suppress table. This is the 5881 -- table that directly shows the current value of the scope 5882 -- suppress check for any check id value. 5883 5884 if C = All_Checks then 5885 5886 -- For All_Checks, we set all specific predefined checks with 5887 -- the exception of Elaboration_Check, which is handled 5888 -- specially because of not wanting All_Checks to have the 5889 -- effect of deactivating static elaboration order processing. 5890 -- Atomic_Synchronization is also not affected, since this is 5891 -- not a real check. 5892 5893 for J in Scope_Suppress.Suppress'Range loop 5894 if J /= Elaboration_Check 5895 and then 5896 J /= Atomic_Synchronization 5897 then 5898 Scope_Suppress.Suppress (J) := Suppress_Case; 5899 end if; 5900 end loop; 5901 5902 -- If not All_Checks, and predefined check, then set appropriate 5903 -- scope entry. Note that we will set Elaboration_Check if this 5904 -- is explicitly specified. Atomic_Synchronization is allowed 5905 -- only if internally generated and entity is atomic. 5906 5907 elsif C in Predefined_Check_Id 5908 and then (not Comes_From_Source (N) 5909 or else C /= Atomic_Synchronization) 5910 then 5911 Scope_Suppress.Suppress (C) := Suppress_Case; 5912 end if; 5913 5914 -- Also make an entry in the Local_Entity_Suppress table 5915 5916 Push_Local_Suppress_Stack_Entry 5917 (Entity => Empty, 5918 Check => C, 5919 Suppress => Suppress_Case); 5920 5921 -- Case of two arguments present, where the check is suppressed for 5922 -- a specified entity (given as the second argument of the pragma) 5923 5924 else 5925 -- This is obsolescent in Ada 2005 mode 5926 5927 if Ada_Version >= Ada_2005 then 5928 Check_Restriction (No_Obsolescent_Features, Arg2); 5929 end if; 5930 5931 Check_Optional_Identifier (Arg2, Name_On); 5932 E_Id := Get_Pragma_Arg (Arg2); 5933 Analyze (E_Id); 5934 5935 if not Is_Entity_Name (E_Id) then 5936 Error_Pragma_Arg 5937 ("second argument of pragma% must be entity name", Arg2); 5938 end if; 5939 5940 E := Entity (E_Id); 5941 5942 if E = Any_Id then 5943 return; 5944 end if; 5945 5946 -- Enforce RM 11.5(7) which requires that for a pragma that 5947 -- appears within a package spec, the named entity must be 5948 -- within the package spec. We allow the package name itself 5949 -- to be mentioned since that makes sense, although it is not 5950 -- strictly allowed by 11.5(7). 5951 5952 if In_Package_Spec 5953 and then E /= Current_Scope 5954 and then Scope (E) /= Current_Scope 5955 then 5956 Error_Pragma_Arg 5957 ("entity in pragma% is not in package spec (RM 11.5(7))", 5958 Arg2); 5959 end if; 5960 5961 -- Loop through homonyms. As noted below, in the case of a package 5962 -- spec, only homonyms within the package spec are considered. 5963 5964 loop 5965 Suppress_Unsuppress_Echeck (E, C); 5966 5967 if Is_Generic_Instance (E) 5968 and then Is_Subprogram (E) 5969 and then Present (Alias (E)) 5970 then 5971 Suppress_Unsuppress_Echeck (Alias (E), C); 5972 end if; 5973 5974 -- Move to next homonym if not aspect spec case 5975 5976 exit when From_Aspect_Specification (N); 5977 E := Homonym (E); 5978 exit when No (E); 5979 5980 -- If we are within a package specification, the pragma only 5981 -- applies to homonyms in the same scope. 5982 5983 exit when In_Package_Spec 5984 and then Scope (E) /= Current_Scope; 5985 end loop; 5986 end if; 5987 end Process_Suppress_Unsuppress; 5988 5989 ------------------ 5990 -- Set_Exported -- 5991 ------------------ 5992 5993 procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is 5994 begin 5995 if Is_Imported (E) then 5996 Error_Pragma_Arg 5997 ("cannot export entity& that was previously imported", Arg); 5998 5999 elsif Present (Address_Clause (E)) and then not CodePeer_Mode then 6000 Error_Pragma_Arg 6001 ("cannot export entity& that has an address clause", Arg); 6002 end if; 6003 6004 Set_Is_Exported (E); 6005 6006 -- Generate a reference for entity explicitly, because the 6007 -- identifier may be overloaded and name resolution will not 6008 -- generate one. 6009 6010 Generate_Reference (E, Arg); 6011 6012 -- Deal with exporting non-library level entity 6013 6014 if not Is_Library_Level_Entity (E) then 6015 6016 -- Not allowed at all for subprograms 6017 6018 if Is_Subprogram (E) then 6019 Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); 6020 6021 -- Otherwise set public and statically allocated 6022 6023 else 6024 Set_Is_Public (E); 6025 Set_Is_Statically_Allocated (E); 6026 6027 -- Warn if the corresponding W flag is set and the pragma comes 6028 -- from source. The latter may not be true e.g. on VMS where we 6029 -- expand export pragmas for exception codes associated with 6030 -- imported or exported exceptions. We do not want to generate 6031 -- a warning for something that the user did not write. 6032 6033 if Warn_On_Export_Import 6034 and then Comes_From_Source (Arg) 6035 then 6036 Error_Msg_NE 6037 ("?x?& has been made static as a result of Export", 6038 Arg, E); 6039 Error_Msg_N 6040 ("\?x?this usage is non-standard and non-portable", 6041 Arg); 6042 end if; 6043 end if; 6044 end if; 6045 6046 if Warn_On_Export_Import and then Is_Type (E) then 6047 Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); 6048 end if; 6049 6050 if Warn_On_Export_Import and Inside_A_Generic then 6051 Error_Msg_NE 6052 ("all instances of& will have the same external name?x?", 6053 Arg, E); 6054 end if; 6055 end Set_Exported; 6056 6057 ---------------------------------------------- 6058 -- Set_Extended_Import_Export_External_Name -- 6059 ---------------------------------------------- 6060 6061 procedure Set_Extended_Import_Export_External_Name 6062 (Internal_Ent : Entity_Id; 6063 Arg_External : Node_Id) 6064 is 6065 Old_Name : constant Node_Id := Interface_Name (Internal_Ent); 6066 New_Name : Node_Id; 6067 6068 begin 6069 if No (Arg_External) then 6070 return; 6071 end if; 6072 6073 Check_Arg_Is_External_Name (Arg_External); 6074 6075 if Nkind (Arg_External) = N_String_Literal then 6076 if String_Length (Strval (Arg_External)) = 0 then 6077 return; 6078 else 6079 New_Name := Adjust_External_Name_Case (Arg_External); 6080 end if; 6081 6082 elsif Nkind (Arg_External) = N_Identifier then 6083 New_Name := Get_Default_External_Name (Arg_External); 6084 6085 -- Check_Arg_Is_External_Name should let through only identifiers and 6086 -- string literals or static string expressions (which are folded to 6087 -- string literals). 6088 6089 else 6090 raise Program_Error; 6091 end if; 6092 6093 -- If we already have an external name set (by a prior normal Import 6094 -- or Export pragma), then the external names must match 6095 6096 if Present (Interface_Name (Internal_Ent)) then 6097 Check_Matching_Internal_Names : declare 6098 S1 : constant String_Id := Strval (Old_Name); 6099 S2 : constant String_Id := Strval (New_Name); 6100 6101 procedure Mismatch; 6102 pragma No_Return (Mismatch); 6103 -- Called if names do not match 6104 6105 -------------- 6106 -- Mismatch -- 6107 -------------- 6108 6109 procedure Mismatch is 6110 begin 6111 Error_Msg_Sloc := Sloc (Old_Name); 6112 Error_Pragma_Arg 6113 ("external name does not match that given #", 6114 Arg_External); 6115 end Mismatch; 6116 6117 -- Start of processing for Check_Matching_Internal_Names 6118 6119 begin 6120 if String_Length (S1) /= String_Length (S2) then 6121 Mismatch; 6122 6123 else 6124 for J in 1 .. String_Length (S1) loop 6125 if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then 6126 Mismatch; 6127 end if; 6128 end loop; 6129 end if; 6130 end Check_Matching_Internal_Names; 6131 6132 -- Otherwise set the given name 6133 6134 else 6135 Set_Encoded_Interface_Name (Internal_Ent, New_Name); 6136 Check_Duplicated_Export_Name (New_Name); 6137 end if; 6138 end Set_Extended_Import_Export_External_Name; 6139 6140 ------------------ 6141 -- Set_Imported -- 6142 ------------------ 6143 6144 procedure Set_Imported (E : Entity_Id) is 6145 begin 6146 -- Error message if already imported or exported 6147 6148 if Is_Exported (E) or else Is_Imported (E) then 6149 6150 -- Error if being set Exported twice 6151 6152 if Is_Exported (E) then 6153 Error_Msg_NE ("entity& was previously exported", N, E); 6154 6155 -- OK if Import/Interface case 6156 6157 elsif Import_Interface_Present (N) then 6158 goto OK; 6159 6160 -- Error if being set Imported twice 6161 6162 else 6163 Error_Msg_NE ("entity& was previously imported", N, E); 6164 end if; 6165 6166 Error_Msg_Name_1 := Pname; 6167 Error_Msg_N 6168 ("\(pragma% applies to all previous entities)", N); 6169 6170 Error_Msg_Sloc := Sloc (E); 6171 Error_Msg_NE ("\import not allowed for& declared#", N, E); 6172 6173 -- Here if not previously imported or exported, OK to import 6174 6175 else 6176 Set_Is_Imported (E); 6177 6178 -- If the entity is an object that is not at the library level, 6179 -- then it is statically allocated. We do not worry about objects 6180 -- with address clauses in this context since they are not really 6181 -- imported in the linker sense. 6182 6183 if Is_Object (E) 6184 and then not Is_Library_Level_Entity (E) 6185 and then No (Address_Clause (E)) 6186 then 6187 Set_Is_Statically_Allocated (E); 6188 end if; 6189 end if; 6190 6191 <<OK>> null; 6192 end Set_Imported; 6193 6194 ------------------------- 6195 -- Set_Mechanism_Value -- 6196 ------------------------- 6197 6198 -- Note: the mechanism name has not been analyzed (and cannot indeed be 6199 -- analyzed, since it is semantic nonsense), so we get it in the exact 6200 -- form created by the parser. 6201 6202 procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is 6203 Class : Node_Id; 6204 Param : Node_Id; 6205 Mech_Name_Id : Name_Id; 6206 6207 procedure Bad_Class; 6208 pragma No_Return (Bad_Class); 6209 -- Signal bad descriptor class name 6210 6211 procedure Bad_Mechanism; 6212 pragma No_Return (Bad_Mechanism); 6213 -- Signal bad mechanism name 6214 6215 --------------- 6216 -- Bad_Class -- 6217 --------------- 6218 6219 procedure Bad_Class is 6220 begin 6221 Error_Pragma_Arg ("unrecognized descriptor class name", Class); 6222 end Bad_Class; 6223 6224 ------------------------- 6225 -- Bad_Mechanism_Value -- 6226 ------------------------- 6227 6228 procedure Bad_Mechanism is 6229 begin 6230 Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); 6231 end Bad_Mechanism; 6232 6233 -- Start of processing for Set_Mechanism_Value 6234 6235 begin 6236 if Mechanism (Ent) /= Default_Mechanism then 6237 Error_Msg_NE 6238 ("mechanism for & has already been set", Mech_Name, Ent); 6239 end if; 6240 6241 -- MECHANISM_NAME ::= value | reference | descriptor | 6242 -- short_descriptor 6243 6244 if Nkind (Mech_Name) = N_Identifier then 6245 if Chars (Mech_Name) = Name_Value then 6246 Set_Mechanism (Ent, By_Copy); 6247 return; 6248 6249 elsif Chars (Mech_Name) = Name_Reference then 6250 Set_Mechanism (Ent, By_Reference); 6251 return; 6252 6253 elsif Chars (Mech_Name) = Name_Descriptor then 6254 Check_VMS (Mech_Name); 6255 6256 -- Descriptor => Short_Descriptor if pragma was given 6257 6258 if Short_Descriptors then 6259 Set_Mechanism (Ent, By_Short_Descriptor); 6260 else 6261 Set_Mechanism (Ent, By_Descriptor); 6262 end if; 6263 6264 return; 6265 6266 elsif Chars (Mech_Name) = Name_Short_Descriptor then 6267 Check_VMS (Mech_Name); 6268 Set_Mechanism (Ent, By_Short_Descriptor); 6269 return; 6270 6271 elsif Chars (Mech_Name) = Name_Copy then 6272 Error_Pragma_Arg 6273 ("bad mechanism name, Value assumed", Mech_Name); 6274 6275 else 6276 Bad_Mechanism; 6277 end if; 6278 6279 -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | 6280 -- short_descriptor (CLASS_NAME) 6281 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 6282 6283 -- Note: this form is parsed as an indexed component 6284 6285 elsif Nkind (Mech_Name) = N_Indexed_Component then 6286 Class := First (Expressions (Mech_Name)); 6287 6288 if Nkind (Prefix (Mech_Name)) /= N_Identifier 6289 or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else 6290 Chars (Prefix (Mech_Name)) = Name_Short_Descriptor) 6291 or else Present (Next (Class)) 6292 then 6293 Bad_Mechanism; 6294 else 6295 Mech_Name_Id := Chars (Prefix (Mech_Name)); 6296 6297 -- Change Descriptor => Short_Descriptor if pragma was given 6298 6299 if Mech_Name_Id = Name_Descriptor 6300 and then Short_Descriptors 6301 then 6302 Mech_Name_Id := Name_Short_Descriptor; 6303 end if; 6304 end if; 6305 6306 -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | 6307 -- short_descriptor (Class => CLASS_NAME) 6308 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 6309 6310 -- Note: this form is parsed as a function call 6311 6312 elsif Nkind (Mech_Name) = N_Function_Call then 6313 Param := First (Parameter_Associations (Mech_Name)); 6314 6315 if Nkind (Name (Mech_Name)) /= N_Identifier 6316 or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else 6317 Chars (Name (Mech_Name)) = Name_Short_Descriptor) 6318 or else Present (Next (Param)) 6319 or else No (Selector_Name (Param)) 6320 or else Chars (Selector_Name (Param)) /= Name_Class 6321 then 6322 Bad_Mechanism; 6323 else 6324 Class := Explicit_Actual_Parameter (Param); 6325 Mech_Name_Id := Chars (Name (Mech_Name)); 6326 end if; 6327 6328 else 6329 Bad_Mechanism; 6330 end if; 6331 6332 -- Fall through here with Class set to descriptor class name 6333 6334 Check_VMS (Mech_Name); 6335 6336 if Nkind (Class) /= N_Identifier then 6337 Bad_Class; 6338 6339 elsif Mech_Name_Id = Name_Descriptor 6340 and then Chars (Class) = Name_UBS 6341 then 6342 Set_Mechanism (Ent, By_Descriptor_UBS); 6343 6344 elsif Mech_Name_Id = Name_Descriptor 6345 and then Chars (Class) = Name_UBSB 6346 then 6347 Set_Mechanism (Ent, By_Descriptor_UBSB); 6348 6349 elsif Mech_Name_Id = Name_Descriptor 6350 and then Chars (Class) = Name_UBA 6351 then 6352 Set_Mechanism (Ent, By_Descriptor_UBA); 6353 6354 elsif Mech_Name_Id = Name_Descriptor 6355 and then Chars (Class) = Name_S 6356 then 6357 Set_Mechanism (Ent, By_Descriptor_S); 6358 6359 elsif Mech_Name_Id = Name_Descriptor 6360 and then Chars (Class) = Name_SB 6361 then 6362 Set_Mechanism (Ent, By_Descriptor_SB); 6363 6364 elsif Mech_Name_Id = Name_Descriptor 6365 and then Chars (Class) = Name_A 6366 then 6367 Set_Mechanism (Ent, By_Descriptor_A); 6368 6369 elsif Mech_Name_Id = Name_Descriptor 6370 and then Chars (Class) = Name_NCA 6371 then 6372 Set_Mechanism (Ent, By_Descriptor_NCA); 6373 6374 elsif Mech_Name_Id = Name_Short_Descriptor 6375 and then Chars (Class) = Name_UBS 6376 then 6377 Set_Mechanism (Ent, By_Short_Descriptor_UBS); 6378 6379 elsif Mech_Name_Id = Name_Short_Descriptor 6380 and then Chars (Class) = Name_UBSB 6381 then 6382 Set_Mechanism (Ent, By_Short_Descriptor_UBSB); 6383 6384 elsif Mech_Name_Id = Name_Short_Descriptor 6385 and then Chars (Class) = Name_UBA 6386 then 6387 Set_Mechanism (Ent, By_Short_Descriptor_UBA); 6388 6389 elsif Mech_Name_Id = Name_Short_Descriptor 6390 and then Chars (Class) = Name_S 6391 then 6392 Set_Mechanism (Ent, By_Short_Descriptor_S); 6393 6394 elsif Mech_Name_Id = Name_Short_Descriptor 6395 and then Chars (Class) = Name_SB 6396 then 6397 Set_Mechanism (Ent, By_Short_Descriptor_SB); 6398 6399 elsif Mech_Name_Id = Name_Short_Descriptor 6400 and then Chars (Class) = Name_A 6401 then 6402 Set_Mechanism (Ent, By_Short_Descriptor_A); 6403 6404 elsif Mech_Name_Id = Name_Short_Descriptor 6405 and then Chars (Class) = Name_NCA 6406 then 6407 Set_Mechanism (Ent, By_Short_Descriptor_NCA); 6408 6409 else 6410 Bad_Class; 6411 end if; 6412 end Set_Mechanism_Value; 6413 6414 -------------------------- 6415 -- Set_Rational_Profile -- 6416 -------------------------- 6417 6418 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and 6419 -- and extension to the semantics of renaming declarations. 6420 6421 procedure Set_Rational_Profile is 6422 begin 6423 Implicit_Packing := True; 6424 Overriding_Renamings := True; 6425 Use_VADS_Size := True; 6426 end Set_Rational_Profile; 6427 6428 --------------------------- 6429 -- Set_Ravenscar_Profile -- 6430 --------------------------- 6431 6432 -- The tasks to be done here are 6433 6434 -- Set required policies 6435 6436 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 6437 -- pragma Locking_Policy (Ceiling_Locking) 6438 6439 -- Set Detect_Blocking mode 6440 6441 -- Set required restrictions (see System.Rident for detailed list) 6442 6443 -- Set the No_Dependence rules 6444 -- No_Dependence => Ada.Asynchronous_Task_Control 6445 -- No_Dependence => Ada.Calendar 6446 -- No_Dependence => Ada.Execution_Time.Group_Budget 6447 -- No_Dependence => Ada.Execution_Time.Timers 6448 -- No_Dependence => Ada.Task_Attributes 6449 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 6450 6451 procedure Set_Ravenscar_Profile (N : Node_Id) is 6452 Prefix_Entity : Entity_Id; 6453 Selector_Entity : Entity_Id; 6454 Prefix_Node : Node_Id; 6455 Node : Node_Id; 6456 6457 begin 6458 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) 6459 6460 if Task_Dispatching_Policy /= ' ' 6461 and then Task_Dispatching_Policy /= 'F' 6462 then 6463 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 6464 Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); 6465 6466 -- Set the FIFO_Within_Priorities policy, but always preserve 6467 -- System_Location since we like the error message with the run time 6468 -- name. 6469 6470 else 6471 Task_Dispatching_Policy := 'F'; 6472 6473 if Task_Dispatching_Policy_Sloc /= System_Location then 6474 Task_Dispatching_Policy_Sloc := Loc; 6475 end if; 6476 end if; 6477 6478 -- pragma Locking_Policy (Ceiling_Locking) 6479 6480 if Locking_Policy /= ' ' 6481 and then Locking_Policy /= 'C' 6482 then 6483 Error_Msg_Sloc := Locking_Policy_Sloc; 6484 Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); 6485 6486 -- Set the Ceiling_Locking policy, but preserve System_Location since 6487 -- we like the error message with the run time name. 6488 6489 else 6490 Locking_Policy := 'C'; 6491 6492 if Locking_Policy_Sloc /= System_Location then 6493 Locking_Policy_Sloc := Loc; 6494 end if; 6495 end if; 6496 6497 -- pragma Detect_Blocking 6498 6499 Detect_Blocking := True; 6500 6501 -- Set the corresponding restrictions 6502 6503 Set_Profile_Restrictions 6504 (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); 6505 6506 -- Set the No_Dependence restrictions 6507 6508 -- The following No_Dependence restrictions: 6509 -- No_Dependence => Ada.Asynchronous_Task_Control 6510 -- No_Dependence => Ada.Calendar 6511 -- No_Dependence => Ada.Task_Attributes 6512 -- are already set by previous call to Set_Profile_Restrictions. 6513 6514 -- Set the following restrictions which were added to Ada 2005: 6515 -- No_Dependence => Ada.Execution_Time.Group_Budget 6516 -- No_Dependence => Ada.Execution_Time.Timers 6517 6518 if Ada_Version >= Ada_2005 then 6519 Name_Buffer (1 .. 3) := "ada"; 6520 Name_Len := 3; 6521 6522 Prefix_Entity := Make_Identifier (Loc, Name_Find); 6523 6524 Name_Buffer (1 .. 14) := "execution_time"; 6525 Name_Len := 14; 6526 6527 Selector_Entity := Make_Identifier (Loc, Name_Find); 6528 6529 Prefix_Node := 6530 Make_Selected_Component 6531 (Sloc => Loc, 6532 Prefix => Prefix_Entity, 6533 Selector_Name => Selector_Entity); 6534 6535 Name_Buffer (1 .. 13) := "group_budgets"; 6536 Name_Len := 13; 6537 6538 Selector_Entity := Make_Identifier (Loc, Name_Find); 6539 6540 Node := 6541 Make_Selected_Component 6542 (Sloc => Loc, 6543 Prefix => Prefix_Node, 6544 Selector_Name => Selector_Entity); 6545 6546 Set_Restriction_No_Dependence 6547 (Unit => Node, 6548 Warn => Treat_Restrictions_As_Warnings, 6549 Profile => Ravenscar); 6550 6551 Name_Buffer (1 .. 6) := "timers"; 6552 Name_Len := 6; 6553 6554 Selector_Entity := Make_Identifier (Loc, Name_Find); 6555 6556 Node := 6557 Make_Selected_Component 6558 (Sloc => Loc, 6559 Prefix => Prefix_Node, 6560 Selector_Name => Selector_Entity); 6561 6562 Set_Restriction_No_Dependence 6563 (Unit => Node, 6564 Warn => Treat_Restrictions_As_Warnings, 6565 Profile => Ravenscar); 6566 end if; 6567 6568 -- Set the following restrictions which was added to Ada 2012 (see 6569 -- AI-0171): 6570 -- No_Dependence => System.Multiprocessors.Dispatching_Domains 6571 6572 if Ada_Version >= Ada_2012 then 6573 Name_Buffer (1 .. 6) := "system"; 6574 Name_Len := 6; 6575 6576 Prefix_Entity := Make_Identifier (Loc, Name_Find); 6577 6578 Name_Buffer (1 .. 15) := "multiprocessors"; 6579 Name_Len := 15; 6580 6581 Selector_Entity := Make_Identifier (Loc, Name_Find); 6582 6583 Prefix_Node := 6584 Make_Selected_Component 6585 (Sloc => Loc, 6586 Prefix => Prefix_Entity, 6587 Selector_Name => Selector_Entity); 6588 6589 Name_Buffer (1 .. 19) := "dispatching_domains"; 6590 Name_Len := 19; 6591 6592 Selector_Entity := Make_Identifier (Loc, Name_Find); 6593 6594 Node := 6595 Make_Selected_Component 6596 (Sloc => Loc, 6597 Prefix => Prefix_Node, 6598 Selector_Name => Selector_Entity); 6599 6600 Set_Restriction_No_Dependence 6601 (Unit => Node, 6602 Warn => Treat_Restrictions_As_Warnings, 6603 Profile => Ravenscar); 6604 end if; 6605 end Set_Ravenscar_Profile; 6606 6607 ---------------- 6608 -- S14_Pragma -- 6609 ---------------- 6610 6611 procedure S14_Pragma is 6612 begin 6613 if not Formal_Extensions then 6614 Error_Pragma ("pragma% requires the use of debug switch -gnatd.V"); 6615 end if; 6616 end S14_Pragma; 6617 6618 -- Start of processing for Analyze_Pragma 6619 6620 begin 6621 -- The following code is a defense against recursion. Not clear that 6622 -- this can happen legitimately, but perhaps some error situations 6623 -- can cause it, and we did see this recursion during testing. 6624 6625 if Analyzed (N) then 6626 return; 6627 else 6628 Set_Analyzed (N, True); 6629 end if; 6630 6631 -- Deal with unrecognized pragma 6632 6633 Pname := Pragma_Name (N); 6634 6635 if not Is_Pragma_Name (Pname) then 6636 if Warn_On_Unrecognized_Pragma then 6637 Error_Msg_Name_1 := Pname; 6638 Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N)); 6639 6640 for PN in First_Pragma_Name .. Last_Pragma_Name loop 6641 if Is_Bad_Spelling_Of (Pname, PN) then 6642 Error_Msg_Name_1 := PN; 6643 Error_Msg_N -- CODEFIX 6644 ("\?g?possible misspelling of %!", Pragma_Identifier (N)); 6645 exit; 6646 end if; 6647 end loop; 6648 end if; 6649 6650 return; 6651 end if; 6652 6653 -- Here to start processing for recognized pragma 6654 6655 Prag_Id := Get_Pragma_Id (Pname); 6656 6657 if Present (Corresponding_Aspect (N)) then 6658 Pname := Chars (Identifier (Corresponding_Aspect (N))); 6659 end if; 6660 6661 -- Preset arguments 6662 6663 Arg_Count := 0; 6664 Arg1 := Empty; 6665 Arg2 := Empty; 6666 Arg3 := Empty; 6667 Arg4 := Empty; 6668 6669 if Present (Pragma_Argument_Associations (N)) then 6670 Arg_Count := List_Length (Pragma_Argument_Associations (N)); 6671 Arg1 := First (Pragma_Argument_Associations (N)); 6672 6673 if Present (Arg1) then 6674 Arg2 := Next (Arg1); 6675 6676 if Present (Arg2) then 6677 Arg3 := Next (Arg2); 6678 6679 if Present (Arg3) then 6680 Arg4 := Next (Arg3); 6681 end if; 6682 end if; 6683 end if; 6684 end if; 6685 6686 -- An enumeration type defines the pragmas that are supported by the 6687 -- implementation. Get_Pragma_Id (in package Prag) transforms a name 6688 -- into the corresponding enumeration value for the following case. 6689 6690 case Prag_Id is 6691 6692 ----------------- 6693 -- Abort_Defer -- 6694 ----------------- 6695 6696 -- pragma Abort_Defer; 6697 6698 when Pragma_Abort_Defer => 6699 GNAT_Pragma; 6700 Check_Arg_Count (0); 6701 6702 -- The only required semantic processing is to check the 6703 -- placement. This pragma must appear at the start of the 6704 -- statement sequence of a handled sequence of statements. 6705 6706 if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements 6707 or else N /= First (Statements (Parent (N))) 6708 then 6709 Pragma_Misplaced; 6710 end if; 6711 6712 -------------------- 6713 -- Abstract_State -- 6714 -------------------- 6715 6716 -- pragma Abstract_State (ABSTRACT_STATE_LIST) 6717 6718 -- ABSTRACT_STATE_LIST ::= 6719 -- null 6720 -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES} 6721 6722 -- STATE_NAME_WITH_PROPERTIES ::= 6723 -- STATE_NAME 6724 -- | (STATE_NAME with PROPERTY_LIST) 6725 6726 -- PROPERTY_LIST ::= PROPERTY {, PROPERTY} 6727 -- PROPERTY ::= SIMPLE_PROPERTY 6728 -- | NAME_VALUE_PROPERTY 6729 -- SIMPLE_PROPERTY ::= IDENTIFIER 6730 -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION 6731 -- STATE_NAME ::= DEFINING_IDENTIFIER 6732 6733 when Pragma_Abstract_State => Abstract_State : declare 6734 Pack_Id : Entity_Id; 6735 6736 -- Flags used to verify the consistency of states 6737 6738 Non_Null_Seen : Boolean := False; 6739 Null_Seen : Boolean := False; 6740 6741 procedure Analyze_Abstract_State (State : Node_Id); 6742 -- Verify the legality of a single state declaration. Create and 6743 -- decorate a state abstraction entity and introduce it into the 6744 -- visibility chain. 6745 6746 ---------------------------- 6747 -- Analyze_Abstract_State -- 6748 ---------------------------- 6749 6750 procedure Analyze_Abstract_State (State : Node_Id) is 6751 procedure Check_Duplicate_Property 6752 (Prop : Node_Id; 6753 Status : in out Boolean); 6754 -- Flag Status denotes whether a particular property has been 6755 -- seen while processing a state. This routine verifies that 6756 -- Prop is not a duplicate property and sets the flag Status. 6757 6758 ------------------------------ 6759 -- Check_Duplicate_Property -- 6760 ------------------------------ 6761 6762 procedure Check_Duplicate_Property 6763 (Prop : Node_Id; 6764 Status : in out Boolean) 6765 is 6766 begin 6767 if Status then 6768 Error_Msg_N ("duplicate state property", Prop); 6769 end if; 6770 6771 Status := True; 6772 end Check_Duplicate_Property; 6773 6774 -- Local variables 6775 6776 Errors : constant Nat := Serious_Errors_Detected; 6777 Loc : constant Source_Ptr := Sloc (State); 6778 Assoc : Node_Id; 6779 Id : Entity_Id; 6780 Is_Null : Boolean := False; 6781 Level : Uint := Uint_0; 6782 Name : Name_Id; 6783 Prop : Node_Id; 6784 6785 -- Flags used to verify the consistency of properties 6786 6787 Input_Seen : Boolean := False; 6788 Integrity_Seen : Boolean := False; 6789 Output_Seen : Boolean := False; 6790 Volatile_Seen : Boolean := False; 6791 6792 -- Start of processing for Analyze_Abstract_State 6793 6794 begin 6795 -- A package with a null abstract state is not allowed to 6796 -- declare additional states. 6797 6798 if Null_Seen then 6799 Error_Msg_Name_1 := Chars (Pack_Id); 6800 Error_Msg_N ("package % has null abstract state", State); 6801 6802 -- Null states appear as internally generated entities 6803 6804 elsif Nkind (State) = N_Null then 6805 Name := New_Internal_Name ('S'); 6806 Is_Null := True; 6807 Null_Seen := True; 6808 6809 -- Catch a case where a null state appears in a list of 6810 -- non-null states. 6811 6812 if Non_Null_Seen then 6813 Error_Msg_Name_1 := Chars (Pack_Id); 6814 Error_Msg_N 6815 ("package % has non-null abstract state", State); 6816 end if; 6817 6818 -- Simple state declaration 6819 6820 elsif Nkind (State) = N_Identifier then 6821 Name := Chars (State); 6822 Non_Null_Seen := True; 6823 6824 -- State declaration with various properties. This construct 6825 -- appears as an extension aggregate in the tree. 6826 6827 elsif Nkind (State) = N_Extension_Aggregate then 6828 if Nkind (Ancestor_Part (State)) = N_Identifier then 6829 Name := Chars (Ancestor_Part (State)); 6830 Non_Null_Seen := True; 6831 else 6832 Error_Msg_N 6833 ("state name must be an identifier", 6834 Ancestor_Part (State)); 6835 end if; 6836 6837 -- Process properties Input, Output and Volatile. Ensure 6838 -- that none of them appear more than once. 6839 6840 Prop := First (Expressions (State)); 6841 while Present (Prop) loop 6842 if Nkind (Prop) = N_Identifier then 6843 if Chars (Prop) = Name_Input then 6844 Check_Duplicate_Property (Prop, Input_Seen); 6845 elsif Chars (Prop) = Name_Output then 6846 Check_Duplicate_Property (Prop, Output_Seen); 6847 elsif Chars (Prop) = Name_Volatile then 6848 Check_Duplicate_Property (Prop, Volatile_Seen); 6849 else 6850 Error_Msg_N ("invalid state property", Prop); 6851 end if; 6852 else 6853 Error_Msg_N ("invalid state property", Prop); 6854 end if; 6855 6856 Next (Prop); 6857 end loop; 6858 6859 -- Volatile requires exactly one Input or Output 6860 6861 if Volatile_Seen 6862 and then 6863 ((Input_Seen and then Output_Seen) -- both 6864 or else 6865 (not Input_Seen and then not Output_Seen)) -- none 6866 then 6867 Error_Msg_N 6868 ("property Volatile requires exactly one Input or " & 6869 "Output", State); 6870 end if; 6871 6872 -- Either Input or Output require Volatile 6873 6874 if (Input_Seen or Output_Seen) 6875 and then not Volatile_Seen 6876 then 6877 Error_Msg_N 6878 ("properties Input and Output require Volatile", State); 6879 end if; 6880 6881 -- State property Integrity appears as a component 6882 -- association. 6883 6884 Assoc := First (Component_Associations (State)); 6885 while Present (Assoc) loop 6886 Prop := First (Choices (Assoc)); 6887 while Present (Prop) loop 6888 if Nkind (Prop) = N_Identifier 6889 and then Chars (Prop) = Name_Integrity 6890 then 6891 Check_Duplicate_Property (Prop, Integrity_Seen); 6892 else 6893 Error_Msg_N ("invalid state property", Prop); 6894 end if; 6895 6896 Next (Prop); 6897 end loop; 6898 6899 if Nkind (Expression (Assoc)) = N_Integer_Literal then 6900 Level := Intval (Expression (Assoc)); 6901 else 6902 Error_Msg_N 6903 ("integrity level must be an integer literal", 6904 Expression (Assoc)); 6905 end if; 6906 6907 Next (Assoc); 6908 end loop; 6909 6910 -- Any other attempt to declare a state is erroneous 6911 6912 else 6913 Error_Msg_N ("malformed abstract state declaration", State); 6914 end if; 6915 6916 -- Do not generate a state abstraction entity if it was not 6917 -- properly declared. 6918 6919 if Serious_Errors_Detected > Errors then 6920 return; 6921 end if; 6922 6923 -- The generated state abstraction reuses the same characters 6924 -- from the original state declaration. Decorate the entity. 6925 6926 Id := Make_Defining_Identifier (Loc, New_External_Name (Name)); 6927 Set_Comes_From_Source (Id, not Is_Null); 6928 Set_Parent (Id, State); 6929 Set_Ekind (Id, E_Abstract_State); 6930 Set_Etype (Id, Standard_Void_Type); 6931 Set_Integrity_Level (Id, Level); 6932 Set_Refined_State (Id, Empty); 6933 6934 -- Every non-null state must be nameable and resolvable the 6935 -- same way a constant is. 6936 6937 if not Is_Null then 6938 Push_Scope (Pack_Id); 6939 Enter_Name (Id); 6940 Pop_Scope; 6941 end if; 6942 6943 -- Associate the state with its related package 6944 6945 if No (Abstract_States (Pack_Id)) then 6946 Set_Abstract_States (Pack_Id, New_Elmt_List); 6947 end if; 6948 6949 Append_Elmt (Id, Abstract_States (Pack_Id)); 6950 end Analyze_Abstract_State; 6951 6952 -- Local variables 6953 6954 Par : Node_Id; 6955 State : Node_Id; 6956 6957 -- Start of processing for Abstract_State 6958 6959 begin 6960 GNAT_Pragma; 6961 S14_Pragma; 6962 Check_Arg_Count (1); 6963 6964 -- Ensure the proper placement of the pragma. Abstract states must 6965 -- be associated with a package declaration. 6966 6967 if From_Aspect_Specification (N) then 6968 Par := Parent (Corresponding_Aspect (N)); 6969 else 6970 Par := Parent (Parent (N)); 6971 end if; 6972 6973 if Nkind (Par) = N_Compilation_Unit then 6974 Par := Unit (Par); 6975 end if; 6976 6977 if Nkind (Par) /= N_Package_Declaration then 6978 Pragma_Misplaced; 6979 return; 6980 end if; 6981 6982 Pack_Id := Defining_Unit_Name (Specification (Par)); 6983 State := Expression (Arg1); 6984 6985 -- Multiple abstract states appear as an aggregate 6986 6987 if Nkind (State) = N_Aggregate then 6988 State := First (Expressions (State)); 6989 while Present (State) loop 6990 Analyze_Abstract_State (State); 6991 6992 Next (State); 6993 end loop; 6994 6995 -- Various forms of a single abstract state. Note that these may 6996 -- include malformed state declarations. 6997 6998 else 6999 Analyze_Abstract_State (State); 7000 end if; 7001 end Abstract_State; 7002 7003 ------------ 7004 -- Ada_83 -- 7005 ------------ 7006 7007 -- pragma Ada_83; 7008 7009 -- Note: this pragma also has some specific processing in Par.Prag 7010 -- because we want to set the Ada version mode during parsing. 7011 7012 when Pragma_Ada_83 => 7013 GNAT_Pragma; 7014 Check_Arg_Count (0); 7015 7016 -- We really should check unconditionally for proper configuration 7017 -- pragma placement, since we really don't want mixed Ada modes 7018 -- within a single unit, and the GNAT reference manual has always 7019 -- said this was a configuration pragma, but we did not check and 7020 -- are hesitant to add the check now. 7021 7022 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 7023 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 7024 -- or Ada 2012 mode. 7025 7026 if Ada_Version >= Ada_2005 then 7027 Check_Valid_Configuration_Pragma; 7028 end if; 7029 7030 -- Now set Ada 83 mode 7031 7032 Ada_Version := Ada_83; 7033 Ada_Version_Explicit := Ada_Version; 7034 7035 ------------ 7036 -- Ada_95 -- 7037 ------------ 7038 7039 -- pragma Ada_95; 7040 7041 -- Note: this pragma also has some specific processing in Par.Prag 7042 -- because we want to set the Ada 83 version mode during parsing. 7043 7044 when Pragma_Ada_95 => 7045 GNAT_Pragma; 7046 Check_Arg_Count (0); 7047 7048 -- We really should check unconditionally for proper configuration 7049 -- pragma placement, since we really don't want mixed Ada modes 7050 -- within a single unit, and the GNAT reference manual has always 7051 -- said this was a configuration pragma, but we did not check and 7052 -- are hesitant to add the check now. 7053 7054 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 7055 -- or Ada 95, so we must check if we are in Ada 2005 mode. 7056 7057 if Ada_Version >= Ada_2005 then 7058 Check_Valid_Configuration_Pragma; 7059 end if; 7060 7061 -- Now set Ada 95 mode 7062 7063 Ada_Version := Ada_95; 7064 Ada_Version_Explicit := Ada_Version; 7065 7066 --------------------- 7067 -- Ada_05/Ada_2005 -- 7068 --------------------- 7069 7070 -- pragma Ada_05; 7071 -- pragma Ada_05 (LOCAL_NAME); 7072 7073 -- pragma Ada_2005; 7074 -- pragma Ada_2005 (LOCAL_NAME): 7075 7076 -- Note: these pragmas also have some specific processing in Par.Prag 7077 -- because we want to set the Ada 2005 version mode during parsing. 7078 7079 when Pragma_Ada_05 | Pragma_Ada_2005 => declare 7080 E_Id : Node_Id; 7081 7082 begin 7083 GNAT_Pragma; 7084 7085 if Arg_Count = 1 then 7086 Check_Arg_Is_Local_Name (Arg1); 7087 E_Id := Get_Pragma_Arg (Arg1); 7088 7089 if Etype (E_Id) = Any_Type then 7090 return; 7091 end if; 7092 7093 Set_Is_Ada_2005_Only (Entity (E_Id)); 7094 Record_Rep_Item (Entity (E_Id), N); 7095 7096 else 7097 Check_Arg_Count (0); 7098 7099 -- For Ada_2005 we unconditionally enforce the documented 7100 -- configuration pragma placement, since we do not want to 7101 -- tolerate mixed modes in a unit involving Ada 2005. That 7102 -- would cause real difficulties for those cases where there 7103 -- are incompatibilities between Ada 95 and Ada 2005. 7104 7105 Check_Valid_Configuration_Pragma; 7106 7107 -- Now set appropriate Ada mode 7108 7109 Ada_Version := Ada_2005; 7110 Ada_Version_Explicit := Ada_2005; 7111 end if; 7112 end; 7113 7114 --------------------- 7115 -- Ada_12/Ada_2012 -- 7116 --------------------- 7117 7118 -- pragma Ada_12; 7119 -- pragma Ada_12 (LOCAL_NAME); 7120 7121 -- pragma Ada_2012; 7122 -- pragma Ada_2012 (LOCAL_NAME): 7123 7124 -- Note: these pragmas also have some specific processing in Par.Prag 7125 -- because we want to set the Ada 2012 version mode during parsing. 7126 7127 when Pragma_Ada_12 | Pragma_Ada_2012 => declare 7128 E_Id : Node_Id; 7129 7130 begin 7131 GNAT_Pragma; 7132 7133 if Arg_Count = 1 then 7134 Check_Arg_Is_Local_Name (Arg1); 7135 E_Id := Get_Pragma_Arg (Arg1); 7136 7137 if Etype (E_Id) = Any_Type then 7138 return; 7139 end if; 7140 7141 Set_Is_Ada_2012_Only (Entity (E_Id)); 7142 Record_Rep_Item (Entity (E_Id), N); 7143 7144 else 7145 Check_Arg_Count (0); 7146 7147 -- For Ada_2012 we unconditionally enforce the documented 7148 -- configuration pragma placement, since we do not want to 7149 -- tolerate mixed modes in a unit involving Ada 2012. That 7150 -- would cause real difficulties for those cases where there 7151 -- are incompatibilities between Ada 95 and Ada 2012. We could 7152 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. 7153 7154 Check_Valid_Configuration_Pragma; 7155 7156 -- Now set appropriate Ada mode 7157 7158 Ada_Version := Ada_2012; 7159 Ada_Version_Explicit := Ada_2012; 7160 end if; 7161 end; 7162 7163 ---------------------- 7164 -- All_Calls_Remote -- 7165 ---------------------- 7166 7167 -- pragma All_Calls_Remote [(library_package_NAME)]; 7168 7169 when Pragma_All_Calls_Remote => All_Calls_Remote : declare 7170 Lib_Entity : Entity_Id; 7171 7172 begin 7173 Check_Ada_83_Warning; 7174 Check_Valid_Library_Unit_Pragma; 7175 7176 if Nkind (N) = N_Null_Statement then 7177 return; 7178 end if; 7179 7180 Lib_Entity := Find_Lib_Unit_Name; 7181 7182 -- This pragma should only apply to a RCI unit (RM E.2.3(23)) 7183 7184 if Present (Lib_Entity) 7185 and then not Debug_Flag_U 7186 then 7187 if not Is_Remote_Call_Interface (Lib_Entity) then 7188 Error_Pragma ("pragma% only apply to rci unit"); 7189 7190 -- Set flag for entity of the library unit 7191 7192 else 7193 Set_Has_All_Calls_Remote (Lib_Entity); 7194 end if; 7195 7196 end if; 7197 end All_Calls_Remote; 7198 7199 -------------- 7200 -- Annotate -- 7201 -------------- 7202 7203 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); 7204 -- ARG ::= NAME | EXPRESSION 7205 7206 -- The first two arguments are by convention intended to refer to an 7207 -- external tool and a tool-specific function. These arguments are 7208 -- not analyzed. 7209 7210 when Pragma_Annotate => Annotate : declare 7211 Arg : Node_Id; 7212 Exp : Node_Id; 7213 7214 begin 7215 GNAT_Pragma; 7216 Check_At_Least_N_Arguments (1); 7217 Check_Arg_Is_Identifier (Arg1); 7218 Check_No_Identifiers; 7219 Store_Note (N); 7220 7221 -- Second parameter is optional, it is never analyzed 7222 7223 if No (Arg2) then 7224 null; 7225 7226 -- Here if we have a second parameter 7227 7228 else 7229 -- Second parameter must be identifier 7230 7231 Check_Arg_Is_Identifier (Arg2); 7232 7233 -- Process remaining parameters if any 7234 7235 Arg := Next (Arg2); 7236 while Present (Arg) loop 7237 Exp := Get_Pragma_Arg (Arg); 7238 Analyze (Exp); 7239 7240 if Is_Entity_Name (Exp) then 7241 null; 7242 7243 -- For string literals, we assume Standard_String as the 7244 -- type, unless the string contains wide or wide_wide 7245 -- characters. 7246 7247 elsif Nkind (Exp) = N_String_Literal then 7248 if Has_Wide_Wide_Character (Exp) then 7249 Resolve (Exp, Standard_Wide_Wide_String); 7250 elsif Has_Wide_Character (Exp) then 7251 Resolve (Exp, Standard_Wide_String); 7252 else 7253 Resolve (Exp, Standard_String); 7254 end if; 7255 7256 elsif Is_Overloaded (Exp) then 7257 Error_Pragma_Arg 7258 ("ambiguous argument for pragma%", Exp); 7259 7260 else 7261 Resolve (Exp); 7262 end if; 7263 7264 Next (Arg); 7265 end loop; 7266 end if; 7267 end Annotate; 7268 7269 --------------------------- 7270 -- Assert/Assert_And_Cut -- 7271 --------------------------- 7272 7273 -- pragma Assert 7274 -- ( [Check => ] Boolean_EXPRESSION 7275 -- [, [Message =>] Static_String_EXPRESSION]); 7276 7277 -- pragma Assert_And_Cut 7278 -- ( [Check => ] Boolean_EXPRESSION 7279 -- [, [Message =>] Static_String_EXPRESSION]); 7280 7281 when Pragma_Assert | Pragma_Assert_And_Cut => Assert : declare 7282 Expr : Node_Id; 7283 Newa : List_Id; 7284 7285 begin 7286 if Prag_Id = Pragma_Assert then 7287 Ada_2005_Pragma; 7288 else -- Pragma_Assert_And_Cut 7289 GNAT_Pragma; 7290 S14_Pragma; 7291 end if; 7292 7293 Check_At_Least_N_Arguments (1); 7294 Check_At_Most_N_Arguments (2); 7295 Check_Arg_Order ((Name_Check, Name_Message)); 7296 Check_Optional_Identifier (Arg1, Name_Check); 7297 7298 -- We treat pragma Assert as equivalent to: 7299 7300 -- pragma Check (Assertion, condition [, msg]); 7301 7302 -- So rewrite pragma in this manner, transfer the message 7303 -- argument if present, and analyze the result 7304 7305 -- Pragma Assert_And_Cut is treated exactly like pragma Assert by 7306 -- the frontend. Formal verification tools may use it to "cut" the 7307 -- paths through the code, to make verification tractable. When 7308 -- dealing with a semantically analyzed tree, the information that 7309 -- a Check node N corresponds to a source Assert_And_Cut pragma 7310 -- can be retrieved from the pragma kind of Original_Node(N). 7311 7312 Expr := Get_Pragma_Arg (Arg1); 7313 Newa := New_List ( 7314 Make_Pragma_Argument_Association (Loc, 7315 Expression => Make_Identifier (Loc, Name_Assertion)), 7316 7317 Make_Pragma_Argument_Association (Sloc (Expr), 7318 Expression => Expr)); 7319 7320 if Arg_Count > 1 then 7321 Check_Optional_Identifier (Arg2, Name_Message); 7322 Append_To (Newa, New_Copy_Tree (Arg2)); 7323 end if; 7324 7325 Rewrite (N, 7326 Make_Pragma (Loc, 7327 Chars => Name_Check, 7328 Pragma_Argument_Associations => Newa)); 7329 Analyze (N); 7330 end Assert; 7331 7332 ---------------------- 7333 -- Assertion_Policy -- 7334 ---------------------- 7335 7336 -- pragma Assertion_Policy (Check | Disable | Ignore) 7337 7338 when Pragma_Assertion_Policy => Assertion_Policy : declare 7339 Policy : Node_Id; 7340 7341 begin 7342 Ada_2005_Pragma; 7343 Check_Valid_Configuration_Pragma; 7344 Check_Arg_Count (1); 7345 Check_No_Identifiers; 7346 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore); 7347 7348 -- We treat pragma Assertion_Policy as equivalent to: 7349 7350 -- pragma Check_Policy (Assertion, policy) 7351 7352 -- So rewrite the pragma in that manner and link on to the chain 7353 -- of Check_Policy pragmas, marking the pragma as analyzed. 7354 7355 Policy := Get_Pragma_Arg (Arg1); 7356 7357 Rewrite (N, 7358 Make_Pragma (Loc, 7359 Chars => Name_Check_Policy, 7360 Pragma_Argument_Associations => New_List ( 7361 Make_Pragma_Argument_Association (Loc, 7362 Expression => Make_Identifier (Loc, Name_Assertion)), 7363 7364 Make_Pragma_Argument_Association (Loc, 7365 Expression => 7366 Make_Identifier (Sloc (Policy), Chars (Policy)))))); 7367 7368 Set_Analyzed (N); 7369 Set_Next_Pragma (N, Opt.Check_Policy_List); 7370 Opt.Check_Policy_List := N; 7371 end Assertion_Policy; 7372 7373 ------------ 7374 -- Assume -- 7375 ------------ 7376 7377 -- pragma Assume (boolean_EXPRESSION); 7378 7379 when Pragma_Assume => Assume : declare 7380 begin 7381 GNAT_Pragma; 7382 S14_Pragma; 7383 Check_Arg_Count (1); 7384 7385 -- Pragma Assume is transformed into pragma Check in the following 7386 -- manner: 7387 7388 -- pragma Check (Assume, Expr); 7389 7390 Rewrite (N, 7391 Make_Pragma (Loc, 7392 Chars => Name_Check, 7393 Pragma_Argument_Associations => New_List ( 7394 Make_Pragma_Argument_Association (Loc, 7395 Expression => Make_Identifier (Loc, Name_Assume)), 7396 7397 Make_Pragma_Argument_Association (Loc, 7398 Expression => Relocate_Node (Expression (Arg1)))))); 7399 Analyze (N); 7400 end Assume; 7401 7402 ------------------------------ 7403 -- Assume_No_Invalid_Values -- 7404 ------------------------------ 7405 7406 -- pragma Assume_No_Invalid_Values (On | Off); 7407 7408 when Pragma_Assume_No_Invalid_Values => 7409 GNAT_Pragma; 7410 Check_Valid_Configuration_Pragma; 7411 Check_Arg_Count (1); 7412 Check_No_Identifiers; 7413 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 7414 7415 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 7416 Assume_No_Invalid_Values := True; 7417 else 7418 Assume_No_Invalid_Values := False; 7419 end if; 7420 7421 -------------------------- 7422 -- Attribute_Definition -- 7423 -------------------------- 7424 7425 -- pragma Attribute_Definition 7426 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, 7427 -- [Entity =>] LOCAL_NAME, 7428 -- [Expression =>] EXPRESSION | NAME); 7429 7430 when Pragma_Attribute_Definition => Attribute_Definition : declare 7431 Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); 7432 Aname : Name_Id; 7433 7434 begin 7435 GNAT_Pragma; 7436 Check_Arg_Count (3); 7437 Check_Optional_Identifier (Arg1, "attribute"); 7438 Check_Optional_Identifier (Arg2, "entity"); 7439 Check_Optional_Identifier (Arg3, "expression"); 7440 7441 if Nkind (Attribute_Designator) /= N_Identifier then 7442 Error_Msg_N ("attribute name expected", Attribute_Designator); 7443 return; 7444 end if; 7445 7446 Check_Arg_Is_Local_Name (Arg2); 7447 7448 -- If the attribute is not recognized, then issue a warning (not 7449 -- an error), and ignore the pragma. 7450 7451 Aname := Chars (Attribute_Designator); 7452 7453 if not Is_Attribute_Name (Aname) then 7454 Bad_Attribute (Attribute_Designator, Aname, Warn => True); 7455 return; 7456 end if; 7457 7458 -- Otherwise, rewrite the pragma as an attribute definition clause 7459 7460 Rewrite (N, 7461 Make_Attribute_Definition_Clause (Loc, 7462 Name => Get_Pragma_Arg (Arg2), 7463 Chars => Aname, 7464 Expression => Get_Pragma_Arg (Arg3))); 7465 Analyze (N); 7466 end Attribute_Definition; 7467 7468 --------------- 7469 -- AST_Entry -- 7470 --------------- 7471 7472 -- pragma AST_Entry (entry_IDENTIFIER); 7473 7474 when Pragma_AST_Entry => AST_Entry : declare 7475 Ent : Node_Id; 7476 7477 begin 7478 GNAT_Pragma; 7479 Check_VMS (N); 7480 Check_Arg_Count (1); 7481 Check_No_Identifiers; 7482 Check_Arg_Is_Local_Name (Arg1); 7483 Ent := Entity (Get_Pragma_Arg (Arg1)); 7484 7485 -- Note: the implementation of the AST_Entry pragma could handle 7486 -- the entry family case fine, but for now we are consistent with 7487 -- the DEC rules, and do not allow the pragma, which of course 7488 -- has the effect of also forbidding the attribute. 7489 7490 if Ekind (Ent) /= E_Entry then 7491 Error_Pragma_Arg 7492 ("pragma% argument must be simple entry name", Arg1); 7493 7494 elsif Is_AST_Entry (Ent) then 7495 Error_Pragma_Arg 7496 ("duplicate % pragma for entry", Arg1); 7497 7498 elsif Has_Homonym (Ent) then 7499 Error_Pragma_Arg 7500 ("pragma% argument cannot specify overloaded entry", Arg1); 7501 7502 else 7503 declare 7504 FF : constant Entity_Id := First_Formal (Ent); 7505 7506 begin 7507 if Present (FF) then 7508 if Present (Next_Formal (FF)) then 7509 Error_Pragma_Arg 7510 ("entry for pragma% can have only one argument", 7511 Arg1); 7512 7513 elsif Parameter_Mode (FF) /= E_In_Parameter then 7514 Error_Pragma_Arg 7515 ("entry parameter for pragma% must have mode IN", 7516 Arg1); 7517 end if; 7518 end if; 7519 end; 7520 7521 Set_Is_AST_Entry (Ent); 7522 end if; 7523 end AST_Entry; 7524 7525 ------------------ 7526 -- Asynchronous -- 7527 ------------------ 7528 7529 -- pragma Asynchronous (LOCAL_NAME); 7530 7531 when Pragma_Asynchronous => Asynchronous : declare 7532 Nm : Entity_Id; 7533 C_Ent : Entity_Id; 7534 L : List_Id; 7535 S : Node_Id; 7536 N : Node_Id; 7537 Formal : Entity_Id; 7538 7539 procedure Process_Async_Pragma; 7540 -- Common processing for procedure and access-to-procedure case 7541 7542 -------------------------- 7543 -- Process_Async_Pragma -- 7544 -------------------------- 7545 7546 procedure Process_Async_Pragma is 7547 begin 7548 if No (L) then 7549 Set_Is_Asynchronous (Nm); 7550 return; 7551 end if; 7552 7553 -- The formals should be of mode IN (RM E.4.1(6)) 7554 7555 S := First (L); 7556 while Present (S) loop 7557 Formal := Defining_Identifier (S); 7558 7559 if Nkind (Formal) = N_Defining_Identifier 7560 and then Ekind (Formal) /= E_In_Parameter 7561 then 7562 Error_Pragma_Arg 7563 ("pragma% procedure can only have IN parameter", 7564 Arg1); 7565 end if; 7566 7567 Next (S); 7568 end loop; 7569 7570 Set_Is_Asynchronous (Nm); 7571 end Process_Async_Pragma; 7572 7573 -- Start of processing for pragma Asynchronous 7574 7575 begin 7576 Check_Ada_83_Warning; 7577 Check_No_Identifiers; 7578 Check_Arg_Count (1); 7579 Check_Arg_Is_Local_Name (Arg1); 7580 7581 if Debug_Flag_U then 7582 return; 7583 end if; 7584 7585 C_Ent := Cunit_Entity (Current_Sem_Unit); 7586 Analyze (Get_Pragma_Arg (Arg1)); 7587 Nm := Entity (Get_Pragma_Arg (Arg1)); 7588 7589 if not Is_Remote_Call_Interface (C_Ent) 7590 and then not Is_Remote_Types (C_Ent) 7591 then 7592 -- This pragma should only appear in an RCI or Remote Types 7593 -- unit (RM E.4.1(4)). 7594 7595 Error_Pragma 7596 ("pragma% not in Remote_Call_Interface or " & 7597 "Remote_Types unit"); 7598 end if; 7599 7600 if Ekind (Nm) = E_Procedure 7601 and then Nkind (Parent (Nm)) = N_Procedure_Specification 7602 then 7603 if not Is_Remote_Call_Interface (Nm) then 7604 Error_Pragma_Arg 7605 ("pragma% cannot be applied on non-remote procedure", 7606 Arg1); 7607 end if; 7608 7609 L := Parameter_Specifications (Parent (Nm)); 7610 Process_Async_Pragma; 7611 return; 7612 7613 elsif Ekind (Nm) = E_Function then 7614 Error_Pragma_Arg 7615 ("pragma% cannot be applied to function", Arg1); 7616 7617 elsif Is_Remote_Access_To_Subprogram_Type (Nm) then 7618 if Is_Record_Type (Nm) then 7619 7620 -- A record type that is the Equivalent_Type for a remote 7621 -- access-to-subprogram type. 7622 7623 N := Declaration_Node (Corresponding_Remote_Type (Nm)); 7624 7625 else 7626 -- A non-expanded RAS type (distribution is not enabled) 7627 7628 N := Declaration_Node (Nm); 7629 end if; 7630 7631 if Nkind (N) = N_Full_Type_Declaration 7632 and then Nkind (Type_Definition (N)) = 7633 N_Access_Procedure_Definition 7634 then 7635 L := Parameter_Specifications (Type_Definition (N)); 7636 Process_Async_Pragma; 7637 7638 if Is_Asynchronous (Nm) 7639 and then Expander_Active 7640 and then Get_PCS_Name /= Name_No_DSA 7641 then 7642 RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); 7643 end if; 7644 7645 else 7646 Error_Pragma_Arg 7647 ("pragma% cannot reference access-to-function type", 7648 Arg1); 7649 end if; 7650 7651 -- Only other possibility is Access-to-class-wide type 7652 7653 elsif Is_Access_Type (Nm) 7654 and then Is_Class_Wide_Type (Designated_Type (Nm)) 7655 then 7656 Check_First_Subtype (Arg1); 7657 Set_Is_Asynchronous (Nm); 7658 if Expander_Active then 7659 RACW_Type_Is_Asynchronous (Nm); 7660 end if; 7661 7662 else 7663 Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); 7664 end if; 7665 end Asynchronous; 7666 7667 ------------ 7668 -- Atomic -- 7669 ------------ 7670 7671 -- pragma Atomic (LOCAL_NAME); 7672 7673 when Pragma_Atomic => 7674 Process_Atomic_Shared_Volatile; 7675 7676 ----------------------- 7677 -- Atomic_Components -- 7678 ----------------------- 7679 7680 -- pragma Atomic_Components (array_LOCAL_NAME); 7681 7682 -- This processing is shared by Volatile_Components 7683 7684 when Pragma_Atomic_Components | 7685 Pragma_Volatile_Components => 7686 7687 Atomic_Components : declare 7688 E_Id : Node_Id; 7689 E : Entity_Id; 7690 D : Node_Id; 7691 K : Node_Kind; 7692 7693 begin 7694 Check_Ada_83_Warning; 7695 Check_No_Identifiers; 7696 Check_Arg_Count (1); 7697 Check_Arg_Is_Local_Name (Arg1); 7698 E_Id := Get_Pragma_Arg (Arg1); 7699 7700 if Etype (E_Id) = Any_Type then 7701 return; 7702 end if; 7703 7704 E := Entity (E_Id); 7705 7706 Check_Duplicate_Pragma (E); 7707 7708 if Rep_Item_Too_Early (E, N) 7709 or else 7710 Rep_Item_Too_Late (E, N) 7711 then 7712 return; 7713 end if; 7714 7715 D := Declaration_Node (E); 7716 K := Nkind (D); 7717 7718 if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) 7719 or else 7720 ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 7721 and then Nkind (D) = N_Object_Declaration 7722 and then Nkind (Object_Definition (D)) = 7723 N_Constrained_Array_Definition) 7724 then 7725 -- The flag is set on the object, or on the base type 7726 7727 if Nkind (D) /= N_Object_Declaration then 7728 E := Base_Type (E); 7729 end if; 7730 7731 Set_Has_Volatile_Components (E); 7732 7733 if Prag_Id = Pragma_Atomic_Components then 7734 Set_Has_Atomic_Components (E); 7735 end if; 7736 7737 else 7738 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 7739 end if; 7740 end Atomic_Components; 7741 7742 -------------------- 7743 -- Attach_Handler -- 7744 -------------------- 7745 7746 -- pragma Attach_Handler (handler_NAME, EXPRESSION); 7747 7748 when Pragma_Attach_Handler => 7749 Check_Ada_83_Warning; 7750 Check_No_Identifiers; 7751 Check_Arg_Count (2); 7752 7753 if No_Run_Time_Mode then 7754 Error_Msg_CRT ("Attach_Handler pragma", N); 7755 else 7756 Check_Interrupt_Or_Attach_Handler; 7757 7758 -- The expression that designates the attribute may depend on a 7759 -- discriminant, and is therefore a per-object expression, to 7760 -- be expanded in the init proc. If expansion is enabled, then 7761 -- perform semantic checks on a copy only. 7762 7763 if Expander_Active then 7764 declare 7765 Temp : constant Node_Id := 7766 New_Copy_Tree (Get_Pragma_Arg (Arg2)); 7767 begin 7768 Set_Parent (Temp, N); 7769 Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); 7770 end; 7771 7772 else 7773 Analyze (Get_Pragma_Arg (Arg2)); 7774 Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID)); 7775 end if; 7776 7777 Process_Interrupt_Or_Attach_Handler; 7778 end if; 7779 7780 -------------------- 7781 -- C_Pass_By_Copy -- 7782 -------------------- 7783 7784 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); 7785 7786 when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare 7787 Arg : Node_Id; 7788 Val : Uint; 7789 7790 begin 7791 GNAT_Pragma; 7792 Check_Valid_Configuration_Pragma; 7793 Check_Arg_Count (1); 7794 Check_Optional_Identifier (Arg1, "max_size"); 7795 7796 Arg := Get_Pragma_Arg (Arg1); 7797 Check_Arg_Is_Static_Expression (Arg, Any_Integer); 7798 7799 Val := Expr_Value (Arg); 7800 7801 if Val <= 0 then 7802 Error_Pragma_Arg 7803 ("maximum size for pragma% must be positive", Arg1); 7804 7805 elsif UI_Is_In_Int_Range (Val) then 7806 Default_C_Record_Mechanism := UI_To_Int (Val); 7807 7808 -- If a giant value is given, Int'Last will do well enough. 7809 -- If sometime someone complains that a record larger than 7810 -- two gigabytes is not copied, we will worry about it then! 7811 7812 else 7813 Default_C_Record_Mechanism := Mechanism_Type'Last; 7814 end if; 7815 end C_Pass_By_Copy; 7816 7817 ----------- 7818 -- Check -- 7819 ----------- 7820 7821 -- pragma Check ([Name =>] IDENTIFIER, 7822 -- [Check =>] Boolean_EXPRESSION 7823 -- [,[Message =>] String_EXPRESSION]); 7824 7825 when Pragma_Check => Check : declare 7826 Expr : Node_Id; 7827 Eloc : Source_Ptr; 7828 Cname : Name_Id; 7829 7830 Check_On : Boolean; 7831 -- Set True if category of assertions referenced by Name enabled 7832 7833 begin 7834 GNAT_Pragma; 7835 Check_At_Least_N_Arguments (2); 7836 Check_At_Most_N_Arguments (3); 7837 Check_Optional_Identifier (Arg1, Name_Name); 7838 Check_Optional_Identifier (Arg2, Name_Check); 7839 7840 if Arg_Count = 3 then 7841 Check_Optional_Identifier (Arg3, Name_Message); 7842 Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String); 7843 end if; 7844 7845 Check_Arg_Is_Identifier (Arg1); 7846 7847 -- Completely ignore if disabled 7848 7849 if Check_Disabled (Chars (Get_Pragma_Arg (Arg1))) then 7850 Rewrite (N, Make_Null_Statement (Loc)); 7851 Analyze (N); 7852 return; 7853 end if; 7854 7855 Cname := Chars (Get_Pragma_Arg (Arg1)); 7856 Check_On := Check_Enabled (Cname); 7857 7858 case Cname is 7859 when Name_Predicate | 7860 Name_Invariant => 7861 7862 -- Nothing to do: since checks occur in client units, 7863 -- the SCO for the aspect in the declaration unit is 7864 -- conservatively always enabled. 7865 7866 null; 7867 7868 when others => 7869 7870 if Check_On and then not Split_PPC (N) then 7871 7872 -- Mark pragma/aspect SCO as enabled 7873 7874 Set_SCO_Pragma_Enabled (Loc); 7875 end if; 7876 end case; 7877 7878 -- If expansion is active and the check is not enabled then we 7879 -- rewrite the Check as: 7880 7881 -- if False and then condition then 7882 -- null; 7883 -- end if; 7884 7885 -- The reason we do this rewriting during semantic analysis rather 7886 -- than as part of normal expansion is that we cannot analyze and 7887 -- expand the code for the boolean expression directly, or it may 7888 -- cause insertion of actions that would escape the attempt to 7889 -- suppress the check code. 7890 7891 -- Note that the Sloc for the if statement corresponds to the 7892 -- argument condition, not the pragma itself. The reason for this 7893 -- is that we may generate a warning if the condition is False at 7894 -- compile time, and we do not want to delete this warning when we 7895 -- delete the if statement. 7896 7897 Expr := Get_Pragma_Arg (Arg2); 7898 7899 if Expander_Active and then not Check_On then 7900 Eloc := Sloc (Expr); 7901 7902 Rewrite (N, 7903 Make_If_Statement (Eloc, 7904 Condition => 7905 Make_And_Then (Eloc, 7906 Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), 7907 Right_Opnd => Expr), 7908 Then_Statements => New_List ( 7909 Make_Null_Statement (Eloc)))); 7910 7911 Analyze (N); 7912 7913 -- Check is active 7914 7915 else 7916 In_Assertion_Expr := In_Assertion_Expr + 1; 7917 Analyze_And_Resolve (Expr, Any_Boolean); 7918 In_Assertion_Expr := In_Assertion_Expr - 1; 7919 end if; 7920 end Check; 7921 7922 -------------------------- 7923 -- Check_Float_Overflow -- 7924 -------------------------- 7925 7926 -- pragma Check_Float_Overflow; 7927 7928 when Pragma_Check_Float_Overflow => 7929 GNAT_Pragma; 7930 Check_Valid_Configuration_Pragma; 7931 Check_Arg_Count (0); 7932 Check_Float_Overflow := True; 7933 7934 ---------------- 7935 -- Check_Name -- 7936 ---------------- 7937 7938 -- pragma Check_Name (check_IDENTIFIER); 7939 7940 when Pragma_Check_Name => 7941 Check_No_Identifiers; 7942 GNAT_Pragma; 7943 Check_Valid_Configuration_Pragma; 7944 Check_Arg_Count (1); 7945 Check_Arg_Is_Identifier (Arg1); 7946 7947 declare 7948 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 7949 7950 begin 7951 for J in Check_Names.First .. Check_Names.Last loop 7952 if Check_Names.Table (J) = Nam then 7953 return; 7954 end if; 7955 end loop; 7956 7957 Check_Names.Append (Nam); 7958 end; 7959 7960 ------------------ 7961 -- Check_Policy -- 7962 ------------------ 7963 7964 -- pragma Check_Policy ( 7965 -- [Name =>] IDENTIFIER, 7966 -- [Policy =>] POLICY_IDENTIFIER); 7967 7968 -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE 7969 7970 -- Note: this is a configuration pragma, but it is allowed to appear 7971 -- anywhere else. 7972 7973 when Pragma_Check_Policy => 7974 GNAT_Pragma; 7975 Check_Arg_Count (2); 7976 Check_Optional_Identifier (Arg1, Name_Name); 7977 Check_Optional_Identifier (Arg2, Name_Policy); 7978 Check_Arg_Is_One_Of 7979 (Arg2, Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); 7980 7981 -- A Check_Policy pragma can appear either as a configuration 7982 -- pragma, or in a declarative part or a package spec (see RM 7983 -- 11.5(5) for rules for Suppress/Unsuppress which are also 7984 -- followed for Check_Policy). 7985 7986 if not Is_Configuration_Pragma then 7987 Check_Is_In_Decl_Part_Or_Package_Spec; 7988 end if; 7989 7990 Set_Next_Pragma (N, Opt.Check_Policy_List); 7991 Opt.Check_Policy_List := N; 7992 7993 --------------------- 7994 -- CIL_Constructor -- 7995 --------------------- 7996 7997 -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME); 7998 7999 -- Processing for this pragma is shared with Java_Constructor 8000 8001 ------------- 8002 -- Comment -- 8003 ------------- 8004 8005 -- pragma Comment (static_string_EXPRESSION) 8006 8007 -- Processing for pragma Comment shares the circuitry for pragma 8008 -- Ident. The only differences are that Ident enforces a limit of 31 8009 -- characters on its argument, and also enforces limitations on 8010 -- placement for DEC compatibility. Pragma Comment shares neither of 8011 -- these restrictions. 8012 8013 ------------------- 8014 -- Common_Object -- 8015 ------------------- 8016 8017 -- pragma Common_Object ( 8018 -- [Internal =>] LOCAL_NAME 8019 -- [, [External =>] EXTERNAL_SYMBOL] 8020 -- [, [Size =>] EXTERNAL_SYMBOL]); 8021 8022 -- Processing for this pragma is shared with Psect_Object 8023 8024 ------------------------ 8025 -- Compile_Time_Error -- 8026 ------------------------ 8027 8028 -- pragma Compile_Time_Error 8029 -- (boolean_EXPRESSION, static_string_EXPRESSION); 8030 8031 when Pragma_Compile_Time_Error => 8032 GNAT_Pragma; 8033 Process_Compile_Time_Warning_Or_Error; 8034 8035 -------------------------- 8036 -- Compile_Time_Warning -- 8037 -------------------------- 8038 8039 -- pragma Compile_Time_Warning 8040 -- (boolean_EXPRESSION, static_string_EXPRESSION); 8041 8042 when Pragma_Compile_Time_Warning => 8043 GNAT_Pragma; 8044 Process_Compile_Time_Warning_Or_Error; 8045 8046 ------------------- 8047 -- Compiler_Unit -- 8048 ------------------- 8049 8050 when Pragma_Compiler_Unit => 8051 GNAT_Pragma; 8052 Check_Arg_Count (0); 8053 Set_Is_Compiler_Unit (Get_Source_Unit (N)); 8054 8055 ----------------------------- 8056 -- Complete_Representation -- 8057 ----------------------------- 8058 8059 -- pragma Complete_Representation; 8060 8061 when Pragma_Complete_Representation => 8062 GNAT_Pragma; 8063 Check_Arg_Count (0); 8064 8065 if Nkind (Parent (N)) /= N_Record_Representation_Clause then 8066 Error_Pragma 8067 ("pragma & must appear within record representation clause"); 8068 end if; 8069 8070 ---------------------------- 8071 -- Complex_Representation -- 8072 ---------------------------- 8073 8074 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); 8075 8076 when Pragma_Complex_Representation => Complex_Representation : declare 8077 E_Id : Entity_Id; 8078 E : Entity_Id; 8079 Ent : Entity_Id; 8080 8081 begin 8082 GNAT_Pragma; 8083 Check_Arg_Count (1); 8084 Check_Optional_Identifier (Arg1, Name_Entity); 8085 Check_Arg_Is_Local_Name (Arg1); 8086 E_Id := Get_Pragma_Arg (Arg1); 8087 8088 if Etype (E_Id) = Any_Type then 8089 return; 8090 end if; 8091 8092 E := Entity (E_Id); 8093 8094 if not Is_Record_Type (E) then 8095 Error_Pragma_Arg 8096 ("argument for pragma% must be record type", Arg1); 8097 end if; 8098 8099 Ent := First_Entity (E); 8100 8101 if No (Ent) 8102 or else No (Next_Entity (Ent)) 8103 or else Present (Next_Entity (Next_Entity (Ent))) 8104 or else not Is_Floating_Point_Type (Etype (Ent)) 8105 or else Etype (Ent) /= Etype (Next_Entity (Ent)) 8106 then 8107 Error_Pragma_Arg 8108 ("record for pragma% must have two fields of the same " 8109 & "floating-point type", Arg1); 8110 8111 else 8112 Set_Has_Complex_Representation (Base_Type (E)); 8113 8114 -- We need to treat the type has having a non-standard 8115 -- representation, for back-end purposes, even though in 8116 -- general a complex will have the default representation 8117 -- of a record with two real components. 8118 8119 Set_Has_Non_Standard_Rep (Base_Type (E)); 8120 end if; 8121 end Complex_Representation; 8122 8123 ------------------------- 8124 -- Component_Alignment -- 8125 ------------------------- 8126 8127 -- pragma Component_Alignment ( 8128 -- [Form =>] ALIGNMENT_CHOICE 8129 -- [, [Name =>] type_LOCAL_NAME]); 8130 -- 8131 -- ALIGNMENT_CHOICE ::= 8132 -- Component_Size 8133 -- | Component_Size_4 8134 -- | Storage_Unit 8135 -- | Default 8136 8137 when Pragma_Component_Alignment => Component_AlignmentP : declare 8138 Args : Args_List (1 .. 2); 8139 Names : constant Name_List (1 .. 2) := ( 8140 Name_Form, 8141 Name_Name); 8142 8143 Form : Node_Id renames Args (1); 8144 Name : Node_Id renames Args (2); 8145 8146 Atype : Component_Alignment_Kind; 8147 Typ : Entity_Id; 8148 8149 begin 8150 GNAT_Pragma; 8151 Gather_Associations (Names, Args); 8152 8153 if No (Form) then 8154 Error_Pragma ("missing Form argument for pragma%"); 8155 end if; 8156 8157 Check_Arg_Is_Identifier (Form); 8158 8159 -- Get proper alignment, note that Default = Component_Size on all 8160 -- machines we have so far, and we want to set this value rather 8161 -- than the default value to indicate that it has been explicitly 8162 -- set (and thus will not get overridden by the default component 8163 -- alignment for the current scope) 8164 8165 if Chars (Form) = Name_Component_Size then 8166 Atype := Calign_Component_Size; 8167 8168 elsif Chars (Form) = Name_Component_Size_4 then 8169 Atype := Calign_Component_Size_4; 8170 8171 elsif Chars (Form) = Name_Default then 8172 Atype := Calign_Component_Size; 8173 8174 elsif Chars (Form) = Name_Storage_Unit then 8175 Atype := Calign_Storage_Unit; 8176 8177 else 8178 Error_Pragma_Arg 8179 ("invalid Form parameter for pragma%", Form); 8180 end if; 8181 8182 -- Case with no name, supplied, affects scope table entry 8183 8184 if No (Name) then 8185 Scope_Stack.Table 8186 (Scope_Stack.Last).Component_Alignment_Default := Atype; 8187 8188 -- Case of name supplied 8189 8190 else 8191 Check_Arg_Is_Local_Name (Name); 8192 Find_Type (Name); 8193 Typ := Entity (Name); 8194 8195 if Typ = Any_Type 8196 or else Rep_Item_Too_Early (Typ, N) 8197 then 8198 return; 8199 else 8200 Typ := Underlying_Type (Typ); 8201 end if; 8202 8203 if not Is_Record_Type (Typ) 8204 and then not Is_Array_Type (Typ) 8205 then 8206 Error_Pragma_Arg 8207 ("Name parameter of pragma% must identify record or " & 8208 "array type", Name); 8209 end if; 8210 8211 -- An explicit Component_Alignment pragma overrides an 8212 -- implicit pragma Pack, but not an explicit one. 8213 8214 if not Has_Pragma_Pack (Base_Type (Typ)) then 8215 Set_Is_Packed (Base_Type (Typ), False); 8216 Set_Component_Alignment (Base_Type (Typ), Atype); 8217 end if; 8218 end if; 8219 end Component_AlignmentP; 8220 8221 ------------------- 8222 -- Contract_Case -- 8223 ------------------- 8224 8225 -- pragma Contract_Case 8226 -- ([Name =>] Static_String_EXPRESSION 8227 -- ,[Mode =>] MODE_TYPE 8228 -- [, Requires => Boolean_EXPRESSION] 8229 -- [, Ensures => Boolean_EXPRESSION]); 8230 8231 -- MODE_TYPE ::= Nominal | Robustness 8232 8233 when Pragma_Contract_Case => 8234 Check_Contract_Or_Test_Case; 8235 8236 -------------------- 8237 -- Contract_Cases -- 8238 -------------------- 8239 8240 -- pragma Contract_Cases (CONTRACT_CASE_LIST); 8241 8242 -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE} 8243 8244 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE 8245 8246 -- CASE_GUARD ::= boolean_EXPRESSION | others 8247 8248 -- CONSEQUENCE ::= boolean_EXPRESSION 8249 8250 when Pragma_Contract_Cases => Contract_Cases : declare 8251 procedure Chain_Contract_Cases (Subp_Decl : Node_Id); 8252 -- Chain pragma Contract_Cases to the contract of a subprogram. 8253 -- Subp_Decl is the declaration of the subprogram. 8254 8255 -------------------------- 8256 -- Chain_Contract_Cases -- 8257 -------------------------- 8258 8259 procedure Chain_Contract_Cases (Subp_Decl : Node_Id) is 8260 Subp : constant Entity_Id := 8261 Defining_Unit_Name (Specification (Subp_Decl)); 8262 CTC : Node_Id; 8263 8264 begin 8265 Check_Duplicate_Pragma (Subp); 8266 CTC := Spec_CTC_List (Contract (Subp)); 8267 while Present (CTC) loop 8268 if Chars (Pragma_Identifier (CTC)) = Pname then 8269 Error_Msg_Name_1 := Pname; 8270 Error_Msg_Sloc := Sloc (CTC); 8271 8272 if From_Aspect_Specification (CTC) then 8273 Error_Msg_NE 8274 ("aspect% for & previously given#", N, Subp); 8275 else 8276 Error_Msg_NE 8277 ("pragma% for & duplicates pragma#", N, Subp); 8278 end if; 8279 8280 raise Pragma_Exit; 8281 end if; 8282 8283 CTC := Next_Pragma (CTC); 8284 end loop; 8285 8286 -- Prepend pragma Contract_Cases to the contract 8287 8288 Set_Next_Pragma (N, Spec_CTC_List (Contract (Subp))); 8289 Set_Spec_CTC_List (Contract (Subp), N); 8290 end Chain_Contract_Cases; 8291 8292 -- Local variables 8293 8294 Case_Guard : Node_Id; 8295 Decl : Node_Id; 8296 Extra : Node_Id; 8297 Others_Seen : Boolean := False; 8298 Contract_Case : Node_Id; 8299 Subp_Decl : Node_Id; 8300 8301 -- Start of processing for Contract_Cases 8302 8303 begin 8304 GNAT_Pragma; 8305 S14_Pragma; 8306 Check_Arg_Count (1); 8307 8308 -- Completely ignore if disabled 8309 8310 if Check_Disabled (Pname) then 8311 Rewrite (N, Make_Null_Statement (Loc)); 8312 Analyze (N); 8313 return; 8314 end if; 8315 8316 -- Check the placement of the pragma 8317 8318 if not Is_List_Member (N) then 8319 Pragma_Misplaced; 8320 end if; 8321 8322 -- Pragma Contract_Cases must be associated with a subprogram 8323 8324 Decl := N; 8325 while Present (Prev (Decl)) loop 8326 Decl := Prev (Decl); 8327 8328 if Nkind (Decl) in N_Generic_Declaration then 8329 Subp_Decl := Decl; 8330 else 8331 Subp_Decl := Original_Node (Decl); 8332 end if; 8333 8334 -- Skip prior pragmas 8335 8336 if Nkind (Subp_Decl) = N_Pragma then 8337 null; 8338 8339 -- Skip internally generated code 8340 8341 elsif not Comes_From_Source (Subp_Decl) then 8342 null; 8343 8344 -- We have found the related subprogram 8345 8346 elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, 8347 N_Subprogram_Declaration) 8348 then 8349 exit; 8350 8351 else 8352 Pragma_Misplaced; 8353 end if; 8354 end loop; 8355 8356 -- All contract cases must appear as an aggregate 8357 8358 if Nkind (Expression (Arg1)) /= N_Aggregate then 8359 Error_Pragma ("wrong syntax for pragma %"); 8360 return; 8361 end if; 8362 8363 -- Verify the legality of individual contract cases 8364 8365 Contract_Case := 8366 First (Component_Associations (Expression (Arg1))); 8367 while Present (Contract_Case) loop 8368 if Nkind (Contract_Case) /= N_Component_Association then 8369 Error_Pragma_Arg 8370 ("wrong syntax in contract case", Contract_Case); 8371 return; 8372 end if; 8373 8374 Case_Guard := First (Choices (Contract_Case)); 8375 8376 -- Each contract case must have exactly on case guard 8377 8378 Extra := Next (Case_Guard); 8379 if Present (Extra) then 8380 Error_Pragma_Arg 8381 ("contract case may have only one case guard", Extra); 8382 return; 8383 end if; 8384 8385 -- Check the placement of "others" (if available) 8386 8387 if Nkind (Case_Guard) = N_Others_Choice then 8388 if Others_Seen then 8389 Error_Pragma_Arg 8390 ("only one others choice allowed in pragma %", 8391 Case_Guard); 8392 return; 8393 else 8394 Others_Seen := True; 8395 end if; 8396 8397 elsif Others_Seen then 8398 Error_Pragma_Arg 8399 ("others must be the last choice in pragma %", N); 8400 return; 8401 end if; 8402 8403 Next (Contract_Case); 8404 end loop; 8405 8406 Chain_Contract_Cases (Subp_Decl); 8407 end Contract_Cases; 8408 8409 ---------------- 8410 -- Controlled -- 8411 ---------------- 8412 8413 -- pragma Controlled (first_subtype_LOCAL_NAME); 8414 8415 when Pragma_Controlled => Controlled : declare 8416 Arg : Node_Id; 8417 8418 begin 8419 Check_No_Identifiers; 8420 Check_Arg_Count (1); 8421 Check_Arg_Is_Local_Name (Arg1); 8422 Arg := Get_Pragma_Arg (Arg1); 8423 8424 if not Is_Entity_Name (Arg) 8425 or else not Is_Access_Type (Entity (Arg)) 8426 then 8427 Error_Pragma_Arg ("pragma% requires access type", Arg1); 8428 else 8429 Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); 8430 end if; 8431 end Controlled; 8432 8433 ---------------- 8434 -- Convention -- 8435 ---------------- 8436 8437 -- pragma Convention ([Convention =>] convention_IDENTIFIER, 8438 -- [Entity =>] LOCAL_NAME); 8439 8440 when Pragma_Convention => Convention : declare 8441 C : Convention_Id; 8442 E : Entity_Id; 8443 pragma Warnings (Off, C); 8444 pragma Warnings (Off, E); 8445 begin 8446 Check_Arg_Order ((Name_Convention, Name_Entity)); 8447 Check_Ada_83_Warning; 8448 Check_Arg_Count (2); 8449 Process_Convention (C, E); 8450 end Convention; 8451 8452 --------------------------- 8453 -- Convention_Identifier -- 8454 --------------------------- 8455 8456 -- pragma Convention_Identifier ([Name =>] IDENTIFIER, 8457 -- [Convention =>] convention_IDENTIFIER); 8458 8459 when Pragma_Convention_Identifier => Convention_Identifier : declare 8460 Idnam : Name_Id; 8461 Cname : Name_Id; 8462 8463 begin 8464 GNAT_Pragma; 8465 Check_Arg_Order ((Name_Name, Name_Convention)); 8466 Check_Arg_Count (2); 8467 Check_Optional_Identifier (Arg1, Name_Name); 8468 Check_Optional_Identifier (Arg2, Name_Convention); 8469 Check_Arg_Is_Identifier (Arg1); 8470 Check_Arg_Is_Identifier (Arg2); 8471 Idnam := Chars (Get_Pragma_Arg (Arg1)); 8472 Cname := Chars (Get_Pragma_Arg (Arg2)); 8473 8474 if Is_Convention_Name (Cname) then 8475 Record_Convention_Identifier 8476 (Idnam, Get_Convention_Id (Cname)); 8477 else 8478 Error_Pragma_Arg 8479 ("second arg for % pragma must be convention", Arg2); 8480 end if; 8481 end Convention_Identifier; 8482 8483 --------------- 8484 -- CPP_Class -- 8485 --------------- 8486 8487 -- pragma CPP_Class ([Entity =>] local_NAME) 8488 8489 when Pragma_CPP_Class => CPP_Class : declare 8490 begin 8491 GNAT_Pragma; 8492 8493 if Warn_On_Obsolescent_Feature then 8494 -- Following message is obsolete ??? 8495 Error_Msg_N 8496 ("'G'N'A'T pragma cpp'_class is now obsolete and has no " & 8497 "effect; replace it by pragma import?j?", N); 8498 end if; 8499 8500 Check_Arg_Count (1); 8501 8502 Rewrite (N, 8503 Make_Pragma (Loc, 8504 Chars => Name_Import, 8505 Pragma_Argument_Associations => New_List ( 8506 Make_Pragma_Argument_Association (Loc, 8507 Expression => Make_Identifier (Loc, Name_CPP)), 8508 New_Copy (First (Pragma_Argument_Associations (N)))))); 8509 Analyze (N); 8510 end CPP_Class; 8511 8512 --------------------- 8513 -- CPP_Constructor -- 8514 --------------------- 8515 8516 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME 8517 -- [, [External_Name =>] static_string_EXPRESSION ] 8518 -- [, [Link_Name =>] static_string_EXPRESSION ]); 8519 8520 when Pragma_CPP_Constructor => CPP_Constructor : declare 8521 Elmt : Elmt_Id; 8522 Id : Entity_Id; 8523 Def_Id : Entity_Id; 8524 Tag_Typ : Entity_Id; 8525 8526 begin 8527 GNAT_Pragma; 8528 Check_At_Least_N_Arguments (1); 8529 Check_At_Most_N_Arguments (3); 8530 Check_Optional_Identifier (Arg1, Name_Entity); 8531 Check_Arg_Is_Local_Name (Arg1); 8532 8533 Id := Get_Pragma_Arg (Arg1); 8534 Find_Program_Unit_Name (Id); 8535 8536 -- If we did not find the name, we are done 8537 8538 if Etype (Id) = Any_Type then 8539 return; 8540 end if; 8541 8542 Def_Id := Entity (Id); 8543 8544 -- Check if already defined as constructor 8545 8546 if Is_Constructor (Def_Id) then 8547 Error_Msg_N 8548 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1); 8549 return; 8550 end if; 8551 8552 if Ekind (Def_Id) = E_Function 8553 and then (Is_CPP_Class (Etype (Def_Id)) 8554 or else (Is_Class_Wide_Type (Etype (Def_Id)) 8555 and then 8556 Is_CPP_Class (Root_Type (Etype (Def_Id))))) 8557 then 8558 if Scope (Def_Id) /= Scope (Etype (Def_Id)) then 8559 Error_Msg_N 8560 ("'C'P'P constructor must be defined in the scope of " & 8561 "its returned type", Arg1); 8562 end if; 8563 8564 if Arg_Count >= 2 then 8565 Set_Imported (Def_Id); 8566 Set_Is_Public (Def_Id); 8567 Process_Interface_Name (Def_Id, Arg2, Arg3); 8568 end if; 8569 8570 Set_Has_Completion (Def_Id); 8571 Set_Is_Constructor (Def_Id); 8572 Set_Convention (Def_Id, Convention_CPP); 8573 8574 -- Imported C++ constructors are not dispatching primitives 8575 -- because in C++ they don't have a dispatch table slot. 8576 -- However, in Ada the constructor has the profile of a 8577 -- function that returns a tagged type and therefore it has 8578 -- been treated as a primitive operation during semantic 8579 -- analysis. We now remove it from the list of primitive 8580 -- operations of the type. 8581 8582 if Is_Tagged_Type (Etype (Def_Id)) 8583 and then not Is_Class_Wide_Type (Etype (Def_Id)) 8584 and then Is_Dispatching_Operation (Def_Id) 8585 then 8586 Tag_Typ := Etype (Def_Id); 8587 8588 Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); 8589 while Present (Elmt) and then Node (Elmt) /= Def_Id loop 8590 Next_Elmt (Elmt); 8591 end loop; 8592 8593 Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); 8594 Set_Is_Dispatching_Operation (Def_Id, False); 8595 end if; 8596 8597 -- For backward compatibility, if the constructor returns a 8598 -- class wide type, and we internally change the return type to 8599 -- the corresponding root type. 8600 8601 if Is_Class_Wide_Type (Etype (Def_Id)) then 8602 Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); 8603 end if; 8604 else 8605 Error_Pragma_Arg 8606 ("pragma% requires function returning a 'C'P'P_Class type", 8607 Arg1); 8608 end if; 8609 end CPP_Constructor; 8610 8611 ----------------- 8612 -- CPP_Virtual -- 8613 ----------------- 8614 8615 when Pragma_CPP_Virtual => CPP_Virtual : declare 8616 begin 8617 GNAT_Pragma; 8618 8619 if Warn_On_Obsolescent_Feature then 8620 Error_Msg_N 8621 ("'G'N'A'T pragma cpp'_virtual is now obsolete and has " & 8622 "no effect?j?", N); 8623 end if; 8624 end CPP_Virtual; 8625 8626 ---------------- 8627 -- CPP_Vtable -- 8628 ---------------- 8629 8630 when Pragma_CPP_Vtable => CPP_Vtable : declare 8631 begin 8632 GNAT_Pragma; 8633 8634 if Warn_On_Obsolescent_Feature then 8635 Error_Msg_N 8636 ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " & 8637 "no effect?j?", N); 8638 end if; 8639 end CPP_Vtable; 8640 8641 --------- 8642 -- CPU -- 8643 --------- 8644 8645 -- pragma CPU (EXPRESSION); 8646 8647 when Pragma_CPU => CPU : declare 8648 P : constant Node_Id := Parent (N); 8649 Arg : Node_Id; 8650 Ent : Entity_Id; 8651 8652 begin 8653 Ada_2012_Pragma; 8654 Check_No_Identifiers; 8655 Check_Arg_Count (1); 8656 8657 -- Subprogram case 8658 8659 if Nkind (P) = N_Subprogram_Body then 8660 Check_In_Main_Program; 8661 8662 Arg := Get_Pragma_Arg (Arg1); 8663 Analyze_And_Resolve (Arg, Any_Integer); 8664 8665 Ent := Defining_Unit_Name (Specification (P)); 8666 8667 if Nkind (Ent) = N_Defining_Program_Unit_Name then 8668 Ent := Defining_Identifier (Ent); 8669 end if; 8670 8671 -- Must be static 8672 8673 if not Is_Static_Expression (Arg) then 8674 Flag_Non_Static_Expr 8675 ("main subprogram affinity is not static!", Arg); 8676 raise Pragma_Exit; 8677 8678 -- If constraint error, then we already signalled an error 8679 8680 elsif Raises_Constraint_Error (Arg) then 8681 null; 8682 8683 -- Otherwise check in range 8684 8685 else 8686 declare 8687 CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); 8688 -- This is the entity System.Multiprocessors.CPU_Range; 8689 8690 Val : constant Uint := Expr_Value (Arg); 8691 8692 begin 8693 if Val < Expr_Value (Type_Low_Bound (CPU_Id)) 8694 or else 8695 Val > Expr_Value (Type_High_Bound (CPU_Id)) 8696 then 8697 Error_Pragma_Arg 8698 ("main subprogram CPU is out of range", Arg1); 8699 end if; 8700 end; 8701 end if; 8702 8703 Set_Main_CPU 8704 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 8705 8706 -- Task case 8707 8708 elsif Nkind (P) = N_Task_Definition then 8709 Arg := Get_Pragma_Arg (Arg1); 8710 Ent := Defining_Identifier (Parent (P)); 8711 8712 -- The expression must be analyzed in the special manner 8713 -- described in "Handling of Default and Per-Object 8714 -- Expressions" in sem.ads. 8715 8716 Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); 8717 8718 -- Anything else is incorrect 8719 8720 else 8721 Pragma_Misplaced; 8722 end if; 8723 8724 -- Check duplicate pragma before we chain the pragma in the Rep 8725 -- Item chain of Ent. 8726 8727 Check_Duplicate_Pragma (Ent); 8728 Record_Rep_Item (Ent, N); 8729 end CPU; 8730 8731 ----------- 8732 -- Debug -- 8733 ----------- 8734 8735 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); 8736 8737 when Pragma_Debug => Debug : declare 8738 Cond : Node_Id; 8739 Call : Node_Id; 8740 8741 begin 8742 GNAT_Pragma; 8743 8744 -- Skip analysis if disabled 8745 8746 if Debug_Pragmas_Disabled then 8747 Rewrite (N, Make_Null_Statement (Loc)); 8748 Analyze (N); 8749 return; 8750 end if; 8751 8752 Cond := 8753 New_Occurrence_Of 8754 (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active), 8755 Loc); 8756 8757 if Debug_Pragmas_Enabled then 8758 Set_SCO_Pragma_Enabled (Loc); 8759 end if; 8760 8761 if Arg_Count = 2 then 8762 Cond := 8763 Make_And_Then (Loc, 8764 Left_Opnd => Relocate_Node (Cond), 8765 Right_Opnd => Get_Pragma_Arg (Arg1)); 8766 Call := Get_Pragma_Arg (Arg2); 8767 else 8768 Call := Get_Pragma_Arg (Arg1); 8769 end if; 8770 8771 if Nkind_In (Call, 8772 N_Indexed_Component, 8773 N_Function_Call, 8774 N_Identifier, 8775 N_Expanded_Name, 8776 N_Selected_Component) 8777 then 8778 -- If this pragma Debug comes from source, its argument was 8779 -- parsed as a name form (which is syntactically identical). 8780 -- In a generic context a parameterless call will be left as 8781 -- an expanded name (if global) or selected_component if local. 8782 -- Change it to a procedure call statement now. 8783 8784 Change_Name_To_Procedure_Call_Statement (Call); 8785 8786 elsif Nkind (Call) = N_Procedure_Call_Statement then 8787 8788 -- Already in the form of a procedure call statement: nothing 8789 -- to do (could happen in case of an internally generated 8790 -- pragma Debug). 8791 8792 null; 8793 8794 else 8795 -- All other cases: diagnose error 8796 8797 Error_Msg 8798 ("argument of pragma ""Debug"" is not procedure call", 8799 Sloc (Call)); 8800 return; 8801 end if; 8802 8803 -- Rewrite into a conditional with an appropriate condition. We 8804 -- wrap the procedure call in a block so that overhead from e.g. 8805 -- use of the secondary stack does not generate execution overhead 8806 -- for suppressed conditions. 8807 8808 -- Normally the analysis that follows will freeze the subprogram 8809 -- being called. However, if the call is to a null procedure, 8810 -- we want to freeze it before creating the block, because the 8811 -- analysis that follows may be done with expansion disabled, in 8812 -- which case the body will not be generated, leading to spurious 8813 -- errors. 8814 8815 if Nkind (Call) = N_Procedure_Call_Statement 8816 and then Is_Entity_Name (Name (Call)) 8817 then 8818 Analyze (Name (Call)); 8819 Freeze_Before (N, Entity (Name (Call))); 8820 end if; 8821 8822 Rewrite (N, Make_Implicit_If_Statement (N, 8823 Condition => Cond, 8824 Then_Statements => New_List ( 8825 Make_Block_Statement (Loc, 8826 Handled_Statement_Sequence => 8827 Make_Handled_Sequence_Of_Statements (Loc, 8828 Statements => New_List (Relocate_Node (Call))))))); 8829 Analyze (N); 8830 end Debug; 8831 8832 ------------------ 8833 -- Debug_Policy -- 8834 ------------------ 8835 8836 -- pragma Debug_Policy (Check | Ignore) 8837 8838 when Pragma_Debug_Policy => 8839 GNAT_Pragma; 8840 Check_Arg_Count (1); 8841 Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore); 8842 Debug_Pragmas_Enabled := 8843 Chars (Get_Pragma_Arg (Arg1)) = Name_Check; 8844 Debug_Pragmas_Disabled := 8845 Chars (Get_Pragma_Arg (Arg1)) = Name_Disable; 8846 8847 --------------------- 8848 -- Detect_Blocking -- 8849 --------------------- 8850 8851 -- pragma Detect_Blocking; 8852 8853 when Pragma_Detect_Blocking => 8854 Ada_2005_Pragma; 8855 Check_Arg_Count (0); 8856 Check_Valid_Configuration_Pragma; 8857 Detect_Blocking := True; 8858 8859 -------------------------- 8860 -- Default_Storage_Pool -- 8861 -------------------------- 8862 8863 -- pragma Default_Storage_Pool (storage_pool_NAME | null); 8864 8865 when Pragma_Default_Storage_Pool => 8866 Ada_2012_Pragma; 8867 Check_Arg_Count (1); 8868 8869 -- Default_Storage_Pool can appear as a configuration pragma, or 8870 -- in a declarative part or a package spec. 8871 8872 if not Is_Configuration_Pragma then 8873 Check_Is_In_Decl_Part_Or_Package_Spec; 8874 end if; 8875 8876 -- Case of Default_Storage_Pool (null); 8877 8878 if Nkind (Expression (Arg1)) = N_Null then 8879 Analyze (Expression (Arg1)); 8880 8881 -- This is an odd case, this is not really an expression, so 8882 -- we don't have a type for it. So just set the type to Empty. 8883 8884 Set_Etype (Expression (Arg1), Empty); 8885 8886 -- Case of Default_Storage_Pool (storage_pool_NAME); 8887 8888 else 8889 -- If it's a configuration pragma, then the only allowed 8890 -- argument is "null". 8891 8892 if Is_Configuration_Pragma then 8893 Error_Pragma_Arg ("NULL expected", Arg1); 8894 end if; 8895 8896 -- The expected type for a non-"null" argument is 8897 -- Root_Storage_Pool'Class. 8898 8899 Analyze_And_Resolve 8900 (Get_Pragma_Arg (Arg1), 8901 Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 8902 end if; 8903 8904 -- Finally, record the pool name (or null). Freeze.Freeze_Entity 8905 -- for an access type will use this information to set the 8906 -- appropriate attributes of the access type. 8907 8908 Default_Pool := Expression (Arg1); 8909 8910 ------------------------------------ 8911 -- Disable_Atomic_Synchronization -- 8912 ------------------------------------ 8913 8914 -- pragma Disable_Atomic_Synchronization [(Entity)]; 8915 8916 when Pragma_Disable_Atomic_Synchronization => 8917 Process_Disable_Enable_Atomic_Sync (Name_Suppress); 8918 8919 ------------------- 8920 -- Discard_Names -- 8921 ------------------- 8922 8923 -- pragma Discard_Names [([On =>] LOCAL_NAME)]; 8924 8925 when Pragma_Discard_Names => Discard_Names : declare 8926 E : Entity_Id; 8927 E_Id : Entity_Id; 8928 8929 begin 8930 Check_Ada_83_Warning; 8931 8932 -- Deal with configuration pragma case 8933 8934 if Arg_Count = 0 and then Is_Configuration_Pragma then 8935 Global_Discard_Names := True; 8936 return; 8937 8938 -- Otherwise, check correct appropriate context 8939 8940 else 8941 Check_Is_In_Decl_Part_Or_Package_Spec; 8942 8943 if Arg_Count = 0 then 8944 8945 -- If there is no parameter, then from now on this pragma 8946 -- applies to any enumeration, exception or tagged type 8947 -- defined in the current declarative part, and recursively 8948 -- to any nested scope. 8949 8950 Set_Discard_Names (Current_Scope); 8951 return; 8952 8953 else 8954 Check_Arg_Count (1); 8955 Check_Optional_Identifier (Arg1, Name_On); 8956 Check_Arg_Is_Local_Name (Arg1); 8957 8958 E_Id := Get_Pragma_Arg (Arg1); 8959 8960 if Etype (E_Id) = Any_Type then 8961 return; 8962 else 8963 E := Entity (E_Id); 8964 end if; 8965 8966 if (Is_First_Subtype (E) 8967 and then 8968 (Is_Enumeration_Type (E) or else Is_Tagged_Type (E))) 8969 or else Ekind (E) = E_Exception 8970 then 8971 Set_Discard_Names (E); 8972 Record_Rep_Item (E, N); 8973 8974 else 8975 Error_Pragma_Arg 8976 ("inappropriate entity for pragma%", Arg1); 8977 end if; 8978 8979 end if; 8980 end if; 8981 end Discard_Names; 8982 8983 ------------------------ 8984 -- Dispatching_Domain -- 8985 ------------------------ 8986 8987 -- pragma Dispatching_Domain (EXPRESSION); 8988 8989 when Pragma_Dispatching_Domain => Dispatching_Domain : declare 8990 P : constant Node_Id := Parent (N); 8991 Arg : Node_Id; 8992 Ent : Entity_Id; 8993 8994 begin 8995 Ada_2012_Pragma; 8996 Check_No_Identifiers; 8997 Check_Arg_Count (1); 8998 8999 -- This pragma is born obsolete, but not the aspect 9000 9001 if not From_Aspect_Specification (N) then 9002 Check_Restriction 9003 (No_Obsolescent_Features, Pragma_Identifier (N)); 9004 end if; 9005 9006 if Nkind (P) = N_Task_Definition then 9007 Arg := Get_Pragma_Arg (Arg1); 9008 Ent := Defining_Identifier (Parent (P)); 9009 9010 -- The expression must be analyzed in the special manner 9011 -- described in "Handling of Default and Per-Object 9012 -- Expressions" in sem.ads. 9013 9014 Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); 9015 9016 -- Check duplicate pragma before we chain the pragma in the Rep 9017 -- Item chain of Ent. 9018 9019 Check_Duplicate_Pragma (Ent); 9020 Record_Rep_Item (Ent, N); 9021 9022 -- Anything else is incorrect 9023 9024 else 9025 Pragma_Misplaced; 9026 end if; 9027 end Dispatching_Domain; 9028 9029 --------------- 9030 -- Elaborate -- 9031 --------------- 9032 9033 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); 9034 9035 when Pragma_Elaborate => Elaborate : declare 9036 Arg : Node_Id; 9037 Citem : Node_Id; 9038 9039 begin 9040 -- Pragma must be in context items list of a compilation unit 9041 9042 if not Is_In_Context_Clause then 9043 Pragma_Misplaced; 9044 end if; 9045 9046 -- Must be at least one argument 9047 9048 if Arg_Count = 0 then 9049 Error_Pragma ("pragma% requires at least one argument"); 9050 end if; 9051 9052 -- In Ada 83 mode, there can be no items following it in the 9053 -- context list except other pragmas and implicit with clauses 9054 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this 9055 -- placement rule does not apply. 9056 9057 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 9058 Citem := Next (N); 9059 while Present (Citem) loop 9060 if Nkind (Citem) = N_Pragma 9061 or else (Nkind (Citem) = N_With_Clause 9062 and then Implicit_With (Citem)) 9063 then 9064 null; 9065 else 9066 Error_Pragma 9067 ("(Ada 83) pragma% must be at end of context clause"); 9068 end if; 9069 9070 Next (Citem); 9071 end loop; 9072 end if; 9073 9074 -- Finally, the arguments must all be units mentioned in a with 9075 -- clause in the same context clause. Note we already checked (in 9076 -- Par.Prag) that the arguments are all identifiers or selected 9077 -- components. 9078 9079 Arg := Arg1; 9080 Outer : while Present (Arg) loop 9081 Citem := First (List_Containing (N)); 9082 Inner : while Citem /= N loop 9083 if Nkind (Citem) = N_With_Clause 9084 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 9085 then 9086 Set_Elaborate_Present (Citem, True); 9087 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 9088 Generate_Reference (Entity (Name (Citem)), Citem); 9089 9090 -- With the pragma present, elaboration calls on 9091 -- subprograms from the named unit need no further 9092 -- checks, as long as the pragma appears in the current 9093 -- compilation unit. If the pragma appears in some unit 9094 -- in the context, there might still be a need for an 9095 -- Elaborate_All_Desirable from the current compilation 9096 -- to the named unit, so we keep the check enabled. 9097 9098 if In_Extended_Main_Source_Unit (N) then 9099 Set_Suppress_Elaboration_Warnings 9100 (Entity (Name (Citem))); 9101 end if; 9102 9103 exit Inner; 9104 end if; 9105 9106 Next (Citem); 9107 end loop Inner; 9108 9109 if Citem = N then 9110 Error_Pragma_Arg 9111 ("argument of pragma% is not withed unit", Arg); 9112 end if; 9113 9114 Next (Arg); 9115 end loop Outer; 9116 9117 -- Give a warning if operating in static mode with -gnatwl 9118 -- (elaboration warnings enabled) switch set. 9119 9120 if Elab_Warnings and not Dynamic_Elaboration_Checks then 9121 Error_Msg_N 9122 ("?l?use of pragma Elaborate may not be safe", N); 9123 Error_Msg_N 9124 ("?l?use pragma Elaborate_All instead if possible", N); 9125 end if; 9126 end Elaborate; 9127 9128 ------------------- 9129 -- Elaborate_All -- 9130 ------------------- 9131 9132 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); 9133 9134 when Pragma_Elaborate_All => Elaborate_All : declare 9135 Arg : Node_Id; 9136 Citem : Node_Id; 9137 9138 begin 9139 Check_Ada_83_Warning; 9140 9141 -- Pragma must be in context items list of a compilation unit 9142 9143 if not Is_In_Context_Clause then 9144 Pragma_Misplaced; 9145 end if; 9146 9147 -- Must be at least one argument 9148 9149 if Arg_Count = 0 then 9150 Error_Pragma ("pragma% requires at least one argument"); 9151 end if; 9152 9153 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not 9154 -- have to appear at the end of the context clause, but may 9155 -- appear mixed in with other items, even in Ada 83 mode. 9156 9157 -- Final check: the arguments must all be units mentioned in 9158 -- a with clause in the same context clause. Note that we 9159 -- already checked (in Par.Prag) that all the arguments are 9160 -- either identifiers or selected components. 9161 9162 Arg := Arg1; 9163 Outr : while Present (Arg) loop 9164 Citem := First (List_Containing (N)); 9165 Innr : while Citem /= N loop 9166 if Nkind (Citem) = N_With_Clause 9167 and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg)) 9168 then 9169 Set_Elaborate_All_Present (Citem, True); 9170 Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem)); 9171 9172 -- Suppress warnings and elaboration checks on the named 9173 -- unit if the pragma is in the current compilation, as 9174 -- for pragma Elaborate. 9175 9176 if In_Extended_Main_Source_Unit (N) then 9177 Set_Suppress_Elaboration_Warnings 9178 (Entity (Name (Citem))); 9179 end if; 9180 exit Innr; 9181 end if; 9182 9183 Next (Citem); 9184 end loop Innr; 9185 9186 if Citem = N then 9187 Set_Error_Posted (N); 9188 Error_Pragma_Arg 9189 ("argument of pragma% is not withed unit", Arg); 9190 end if; 9191 9192 Next (Arg); 9193 end loop Outr; 9194 end Elaborate_All; 9195 9196 -------------------- 9197 -- Elaborate_Body -- 9198 -------------------- 9199 9200 -- pragma Elaborate_Body [( library_unit_NAME )]; 9201 9202 when Pragma_Elaborate_Body => Elaborate_Body : declare 9203 Cunit_Node : Node_Id; 9204 Cunit_Ent : Entity_Id; 9205 9206 begin 9207 Check_Ada_83_Warning; 9208 Check_Valid_Library_Unit_Pragma; 9209 9210 if Nkind (N) = N_Null_Statement then 9211 return; 9212 end if; 9213 9214 Cunit_Node := Cunit (Current_Sem_Unit); 9215 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 9216 9217 if Nkind_In (Unit (Cunit_Node), N_Package_Body, 9218 N_Subprogram_Body) 9219 then 9220 Error_Pragma ("pragma% must refer to a spec, not a body"); 9221 else 9222 Set_Body_Required (Cunit_Node, True); 9223 Set_Has_Pragma_Elaborate_Body (Cunit_Ent); 9224 9225 -- If we are in dynamic elaboration mode, then we suppress 9226 -- elaboration warnings for the unit, since it is definitely 9227 -- fine NOT to do dynamic checks at the first level (and such 9228 -- checks will be suppressed because no elaboration boolean 9229 -- is created for Elaborate_Body packages). 9230 9231 -- But in the static model of elaboration, Elaborate_Body is 9232 -- definitely NOT good enough to ensure elaboration safety on 9233 -- its own, since the body may WITH other units that are not 9234 -- safe from an elaboration point of view, so a client must 9235 -- still do an Elaborate_All on such units. 9236 9237 -- Debug flag -gnatdD restores the old behavior of 3.13, where 9238 -- Elaborate_Body always suppressed elab warnings. 9239 9240 if Dynamic_Elaboration_Checks or Debug_Flag_DD then 9241 Set_Suppress_Elaboration_Warnings (Cunit_Ent); 9242 end if; 9243 end if; 9244 end Elaborate_Body; 9245 9246 ------------------------ 9247 -- Elaboration_Checks -- 9248 ------------------------ 9249 9250 -- pragma Elaboration_Checks (Static | Dynamic); 9251 9252 when Pragma_Elaboration_Checks => 9253 GNAT_Pragma; 9254 Check_Arg_Count (1); 9255 Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic); 9256 Dynamic_Elaboration_Checks := 9257 (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic); 9258 9259 --------------- 9260 -- Eliminate -- 9261 --------------- 9262 9263 -- pragma Eliminate ( 9264 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT, 9265 -- [,[Entity =>] IDENTIFIER | 9266 -- SELECTED_COMPONENT | 9267 -- STRING_LITERAL] 9268 -- [, OVERLOADING_RESOLUTION]); 9269 9270 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE | 9271 -- SOURCE_LOCATION 9272 9273 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE | 9274 -- FUNCTION_PROFILE 9275 9276 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES 9277 9278 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,] 9279 -- Result_Type => result_SUBTYPE_NAME] 9280 9281 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME}) 9282 -- SUBTYPE_NAME ::= STRING_LITERAL 9283 9284 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE 9285 -- SOURCE_TRACE ::= STRING_LITERAL 9286 9287 when Pragma_Eliminate => Eliminate : declare 9288 Args : Args_List (1 .. 5); 9289 Names : constant Name_List (1 .. 5) := ( 9290 Name_Unit_Name, 9291 Name_Entity, 9292 Name_Parameter_Types, 9293 Name_Result_Type, 9294 Name_Source_Location); 9295 9296 Unit_Name : Node_Id renames Args (1); 9297 Entity : Node_Id renames Args (2); 9298 Parameter_Types : Node_Id renames Args (3); 9299 Result_Type : Node_Id renames Args (4); 9300 Source_Location : Node_Id renames Args (5); 9301 9302 begin 9303 GNAT_Pragma; 9304 Check_Valid_Configuration_Pragma; 9305 Gather_Associations (Names, Args); 9306 9307 if No (Unit_Name) then 9308 Error_Pragma ("missing Unit_Name argument for pragma%"); 9309 end if; 9310 9311 if No (Entity) 9312 and then (Present (Parameter_Types) 9313 or else 9314 Present (Result_Type) 9315 or else 9316 Present (Source_Location)) 9317 then 9318 Error_Pragma ("missing Entity argument for pragma%"); 9319 end if; 9320 9321 if (Present (Parameter_Types) 9322 or else 9323 Present (Result_Type)) 9324 and then 9325 Present (Source_Location) 9326 then 9327 Error_Pragma 9328 ("parameter profile and source location cannot " & 9329 "be used together in pragma%"); 9330 end if; 9331 9332 Process_Eliminate_Pragma 9333 (N, 9334 Unit_Name, 9335 Entity, 9336 Parameter_Types, 9337 Result_Type, 9338 Source_Location); 9339 end Eliminate; 9340 9341 ----------------------------------- 9342 -- Enable_Atomic_Synchronization -- 9343 ----------------------------------- 9344 9345 -- pragma Enable_Atomic_Synchronization [(Entity)]; 9346 9347 when Pragma_Enable_Atomic_Synchronization => 9348 Process_Disable_Enable_Atomic_Sync (Name_Unsuppress); 9349 9350 ------------ 9351 -- Export -- 9352 ------------ 9353 9354 -- pragma Export ( 9355 -- [ Convention =>] convention_IDENTIFIER, 9356 -- [ Entity =>] local_NAME 9357 -- [, [External_Name =>] static_string_EXPRESSION ] 9358 -- [, [Link_Name =>] static_string_EXPRESSION ]); 9359 9360 when Pragma_Export => Export : declare 9361 C : Convention_Id; 9362 Def_Id : Entity_Id; 9363 9364 pragma Warnings (Off, C); 9365 9366 begin 9367 Check_Ada_83_Warning; 9368 Check_Arg_Order 9369 ((Name_Convention, 9370 Name_Entity, 9371 Name_External_Name, 9372 Name_Link_Name)); 9373 9374 Check_At_Least_N_Arguments (2); 9375 9376 Check_At_Most_N_Arguments (4); 9377 Process_Convention (C, Def_Id); 9378 9379 if Ekind (Def_Id) /= E_Constant then 9380 Note_Possible_Modification 9381 (Get_Pragma_Arg (Arg2), Sure => False); 9382 end if; 9383 9384 Process_Interface_Name (Def_Id, Arg3, Arg4); 9385 Set_Exported (Def_Id, Arg2); 9386 9387 -- If the entity is a deferred constant, propagate the information 9388 -- to the full view, because gigi elaborates the full view only. 9389 9390 if Ekind (Def_Id) = E_Constant 9391 and then Present (Full_View (Def_Id)) 9392 then 9393 declare 9394 Id2 : constant Entity_Id := Full_View (Def_Id); 9395 begin 9396 Set_Is_Exported (Id2, Is_Exported (Def_Id)); 9397 Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id)); 9398 Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id)); 9399 end; 9400 end if; 9401 end Export; 9402 9403 ---------------------- 9404 -- Export_Exception -- 9405 ---------------------- 9406 9407 -- pragma Export_Exception ( 9408 -- [Internal =>] LOCAL_NAME 9409 -- [, [External =>] EXTERNAL_SYMBOL] 9410 -- [, [Form =>] Ada | VMS] 9411 -- [, [Code =>] static_integer_EXPRESSION]); 9412 9413 when Pragma_Export_Exception => Export_Exception : declare 9414 Args : Args_List (1 .. 4); 9415 Names : constant Name_List (1 .. 4) := ( 9416 Name_Internal, 9417 Name_External, 9418 Name_Form, 9419 Name_Code); 9420 9421 Internal : Node_Id renames Args (1); 9422 External : Node_Id renames Args (2); 9423 Form : Node_Id renames Args (3); 9424 Code : Node_Id renames Args (4); 9425 9426 begin 9427 GNAT_Pragma; 9428 9429 if Inside_A_Generic then 9430 Error_Pragma ("pragma% cannot be used for generic entities"); 9431 end if; 9432 9433 Gather_Associations (Names, Args); 9434 Process_Extended_Import_Export_Exception_Pragma ( 9435 Arg_Internal => Internal, 9436 Arg_External => External, 9437 Arg_Form => Form, 9438 Arg_Code => Code); 9439 9440 if not Is_VMS_Exception (Entity (Internal)) then 9441 Set_Exported (Entity (Internal), Internal); 9442 end if; 9443 end Export_Exception; 9444 9445 --------------------- 9446 -- Export_Function -- 9447 --------------------- 9448 9449 -- pragma Export_Function ( 9450 -- [Internal =>] LOCAL_NAME 9451 -- [, [External =>] EXTERNAL_SYMBOL] 9452 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 9453 -- [, [Result_Type =>] TYPE_DESIGNATOR] 9454 -- [, [Mechanism =>] MECHANISM] 9455 -- [, [Result_Mechanism =>] MECHANISM_NAME]); 9456 9457 -- EXTERNAL_SYMBOL ::= 9458 -- IDENTIFIER 9459 -- | static_string_EXPRESSION 9460 9461 -- PARAMETER_TYPES ::= 9462 -- null 9463 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 9464 9465 -- TYPE_DESIGNATOR ::= 9466 -- subtype_NAME 9467 -- | subtype_Name ' Access 9468 9469 -- MECHANISM ::= 9470 -- MECHANISM_NAME 9471 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 9472 9473 -- MECHANISM_ASSOCIATION ::= 9474 -- [formal_parameter_NAME =>] MECHANISM_NAME 9475 9476 -- MECHANISM_NAME ::= 9477 -- Value 9478 -- | Reference 9479 -- | Descriptor [([Class =>] CLASS_NAME)] 9480 9481 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 9482 9483 when Pragma_Export_Function => Export_Function : declare 9484 Args : Args_List (1 .. 6); 9485 Names : constant Name_List (1 .. 6) := ( 9486 Name_Internal, 9487 Name_External, 9488 Name_Parameter_Types, 9489 Name_Result_Type, 9490 Name_Mechanism, 9491 Name_Result_Mechanism); 9492 9493 Internal : Node_Id renames Args (1); 9494 External : Node_Id renames Args (2); 9495 Parameter_Types : Node_Id renames Args (3); 9496 Result_Type : Node_Id renames Args (4); 9497 Mechanism : Node_Id renames Args (5); 9498 Result_Mechanism : Node_Id renames Args (6); 9499 9500 begin 9501 GNAT_Pragma; 9502 Gather_Associations (Names, Args); 9503 Process_Extended_Import_Export_Subprogram_Pragma ( 9504 Arg_Internal => Internal, 9505 Arg_External => External, 9506 Arg_Parameter_Types => Parameter_Types, 9507 Arg_Result_Type => Result_Type, 9508 Arg_Mechanism => Mechanism, 9509 Arg_Result_Mechanism => Result_Mechanism); 9510 end Export_Function; 9511 9512 ------------------- 9513 -- Export_Object -- 9514 ------------------- 9515 9516 -- pragma Export_Object ( 9517 -- [Internal =>] LOCAL_NAME 9518 -- [, [External =>] EXTERNAL_SYMBOL] 9519 -- [, [Size =>] EXTERNAL_SYMBOL]); 9520 9521 -- EXTERNAL_SYMBOL ::= 9522 -- IDENTIFIER 9523 -- | static_string_EXPRESSION 9524 9525 -- PARAMETER_TYPES ::= 9526 -- null 9527 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 9528 9529 -- TYPE_DESIGNATOR ::= 9530 -- subtype_NAME 9531 -- | subtype_Name ' Access 9532 9533 -- MECHANISM ::= 9534 -- MECHANISM_NAME 9535 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 9536 9537 -- MECHANISM_ASSOCIATION ::= 9538 -- [formal_parameter_NAME =>] MECHANISM_NAME 9539 9540 -- MECHANISM_NAME ::= 9541 -- Value 9542 -- | Reference 9543 -- | Descriptor [([Class =>] CLASS_NAME)] 9544 9545 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 9546 9547 when Pragma_Export_Object => Export_Object : declare 9548 Args : Args_List (1 .. 3); 9549 Names : constant Name_List (1 .. 3) := ( 9550 Name_Internal, 9551 Name_External, 9552 Name_Size); 9553 9554 Internal : Node_Id renames Args (1); 9555 External : Node_Id renames Args (2); 9556 Size : Node_Id renames Args (3); 9557 9558 begin 9559 GNAT_Pragma; 9560 Gather_Associations (Names, Args); 9561 Process_Extended_Import_Export_Object_Pragma ( 9562 Arg_Internal => Internal, 9563 Arg_External => External, 9564 Arg_Size => Size); 9565 end Export_Object; 9566 9567 ---------------------- 9568 -- Export_Procedure -- 9569 ---------------------- 9570 9571 -- pragma Export_Procedure ( 9572 -- [Internal =>] LOCAL_NAME 9573 -- [, [External =>] EXTERNAL_SYMBOL] 9574 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 9575 -- [, [Mechanism =>] MECHANISM]); 9576 9577 -- EXTERNAL_SYMBOL ::= 9578 -- IDENTIFIER 9579 -- | static_string_EXPRESSION 9580 9581 -- PARAMETER_TYPES ::= 9582 -- null 9583 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 9584 9585 -- TYPE_DESIGNATOR ::= 9586 -- subtype_NAME 9587 -- | subtype_Name ' Access 9588 9589 -- MECHANISM ::= 9590 -- MECHANISM_NAME 9591 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 9592 9593 -- MECHANISM_ASSOCIATION ::= 9594 -- [formal_parameter_NAME =>] MECHANISM_NAME 9595 9596 -- MECHANISM_NAME ::= 9597 -- Value 9598 -- | Reference 9599 -- | Descriptor [([Class =>] CLASS_NAME)] 9600 9601 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 9602 9603 when Pragma_Export_Procedure => Export_Procedure : declare 9604 Args : Args_List (1 .. 4); 9605 Names : constant Name_List (1 .. 4) := ( 9606 Name_Internal, 9607 Name_External, 9608 Name_Parameter_Types, 9609 Name_Mechanism); 9610 9611 Internal : Node_Id renames Args (1); 9612 External : Node_Id renames Args (2); 9613 Parameter_Types : Node_Id renames Args (3); 9614 Mechanism : Node_Id renames Args (4); 9615 9616 begin 9617 GNAT_Pragma; 9618 Gather_Associations (Names, Args); 9619 Process_Extended_Import_Export_Subprogram_Pragma ( 9620 Arg_Internal => Internal, 9621 Arg_External => External, 9622 Arg_Parameter_Types => Parameter_Types, 9623 Arg_Mechanism => Mechanism); 9624 end Export_Procedure; 9625 9626 ------------------ 9627 -- Export_Value -- 9628 ------------------ 9629 9630 -- pragma Export_Value ( 9631 -- [Value =>] static_integer_EXPRESSION, 9632 -- [Link_Name =>] static_string_EXPRESSION); 9633 9634 when Pragma_Export_Value => 9635 GNAT_Pragma; 9636 Check_Arg_Order ((Name_Value, Name_Link_Name)); 9637 Check_Arg_Count (2); 9638 9639 Check_Optional_Identifier (Arg1, Name_Value); 9640 Check_Arg_Is_Static_Expression (Arg1, Any_Integer); 9641 9642 Check_Optional_Identifier (Arg2, Name_Link_Name); 9643 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 9644 9645 ----------------------------- 9646 -- Export_Valued_Procedure -- 9647 ----------------------------- 9648 9649 -- pragma Export_Valued_Procedure ( 9650 -- [Internal =>] LOCAL_NAME 9651 -- [, [External =>] EXTERNAL_SYMBOL,] 9652 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 9653 -- [, [Mechanism =>] MECHANISM]); 9654 9655 -- EXTERNAL_SYMBOL ::= 9656 -- IDENTIFIER 9657 -- | static_string_EXPRESSION 9658 9659 -- PARAMETER_TYPES ::= 9660 -- null 9661 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 9662 9663 -- TYPE_DESIGNATOR ::= 9664 -- subtype_NAME 9665 -- | subtype_Name ' Access 9666 9667 -- MECHANISM ::= 9668 -- MECHANISM_NAME 9669 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 9670 9671 -- MECHANISM_ASSOCIATION ::= 9672 -- [formal_parameter_NAME =>] MECHANISM_NAME 9673 9674 -- MECHANISM_NAME ::= 9675 -- Value 9676 -- | Reference 9677 -- | Descriptor [([Class =>] CLASS_NAME)] 9678 9679 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 9680 9681 when Pragma_Export_Valued_Procedure => 9682 Export_Valued_Procedure : declare 9683 Args : Args_List (1 .. 4); 9684 Names : constant Name_List (1 .. 4) := ( 9685 Name_Internal, 9686 Name_External, 9687 Name_Parameter_Types, 9688 Name_Mechanism); 9689 9690 Internal : Node_Id renames Args (1); 9691 External : Node_Id renames Args (2); 9692 Parameter_Types : Node_Id renames Args (3); 9693 Mechanism : Node_Id renames Args (4); 9694 9695 begin 9696 GNAT_Pragma; 9697 Gather_Associations (Names, Args); 9698 Process_Extended_Import_Export_Subprogram_Pragma ( 9699 Arg_Internal => Internal, 9700 Arg_External => External, 9701 Arg_Parameter_Types => Parameter_Types, 9702 Arg_Mechanism => Mechanism); 9703 end Export_Valued_Procedure; 9704 9705 ------------------- 9706 -- Extend_System -- 9707 ------------------- 9708 9709 -- pragma Extend_System ([Name =>] Identifier); 9710 9711 when Pragma_Extend_System => Extend_System : declare 9712 begin 9713 GNAT_Pragma; 9714 Check_Valid_Configuration_Pragma; 9715 Check_Arg_Count (1); 9716 Check_Optional_Identifier (Arg1, Name_Name); 9717 Check_Arg_Is_Identifier (Arg1); 9718 9719 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 9720 9721 if Name_Len > 4 9722 and then Name_Buffer (1 .. 4) = "aux_" 9723 then 9724 if Present (System_Extend_Pragma_Arg) then 9725 if Chars (Get_Pragma_Arg (Arg1)) = 9726 Chars (Expression (System_Extend_Pragma_Arg)) 9727 then 9728 null; 9729 else 9730 Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg); 9731 Error_Pragma ("pragma% conflicts with that #"); 9732 end if; 9733 9734 else 9735 System_Extend_Pragma_Arg := Arg1; 9736 9737 if not GNAT_Mode then 9738 System_Extend_Unit := Arg1; 9739 end if; 9740 end if; 9741 else 9742 Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); 9743 end if; 9744 end Extend_System; 9745 9746 ------------------------ 9747 -- Extensions_Allowed -- 9748 ------------------------ 9749 9750 -- pragma Extensions_Allowed (ON | OFF); 9751 9752 when Pragma_Extensions_Allowed => 9753 GNAT_Pragma; 9754 Check_Arg_Count (1); 9755 Check_No_Identifiers; 9756 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 9757 9758 if Chars (Get_Pragma_Arg (Arg1)) = Name_On then 9759 Extensions_Allowed := True; 9760 Ada_Version := Ada_Version_Type'Last; 9761 9762 else 9763 Extensions_Allowed := False; 9764 Ada_Version := Ada_Version_Explicit; 9765 end if; 9766 9767 -------------- 9768 -- External -- 9769 -------------- 9770 9771 -- pragma External ( 9772 -- [ Convention =>] convention_IDENTIFIER, 9773 -- [ Entity =>] local_NAME 9774 -- [, [External_Name =>] static_string_EXPRESSION ] 9775 -- [, [Link_Name =>] static_string_EXPRESSION ]); 9776 9777 when Pragma_External => External : declare 9778 Def_Id : Entity_Id; 9779 9780 C : Convention_Id; 9781 pragma Warnings (Off, C); 9782 9783 begin 9784 GNAT_Pragma; 9785 Check_Arg_Order 9786 ((Name_Convention, 9787 Name_Entity, 9788 Name_External_Name, 9789 Name_Link_Name)); 9790 Check_At_Least_N_Arguments (2); 9791 Check_At_Most_N_Arguments (4); 9792 Process_Convention (C, Def_Id); 9793 Note_Possible_Modification 9794 (Get_Pragma_Arg (Arg2), Sure => False); 9795 Process_Interface_Name (Def_Id, Arg3, Arg4); 9796 Set_Exported (Def_Id, Arg2); 9797 end External; 9798 9799 -------------------------- 9800 -- External_Name_Casing -- 9801 -------------------------- 9802 9803 -- pragma External_Name_Casing ( 9804 -- UPPERCASE | LOWERCASE 9805 -- [, AS_IS | UPPERCASE | LOWERCASE]); 9806 9807 when Pragma_External_Name_Casing => External_Name_Casing : declare 9808 begin 9809 GNAT_Pragma; 9810 Check_No_Identifiers; 9811 9812 if Arg_Count = 2 then 9813 Check_Arg_Is_One_Of 9814 (Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase); 9815 9816 case Chars (Get_Pragma_Arg (Arg2)) is 9817 when Name_As_Is => 9818 Opt.External_Name_Exp_Casing := As_Is; 9819 9820 when Name_Uppercase => 9821 Opt.External_Name_Exp_Casing := Uppercase; 9822 9823 when Name_Lowercase => 9824 Opt.External_Name_Exp_Casing := Lowercase; 9825 9826 when others => 9827 null; 9828 end case; 9829 9830 else 9831 Check_Arg_Count (1); 9832 end if; 9833 9834 Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase); 9835 9836 case Chars (Get_Pragma_Arg (Arg1)) is 9837 when Name_Uppercase => 9838 Opt.External_Name_Imp_Casing := Uppercase; 9839 9840 when Name_Lowercase => 9841 Opt.External_Name_Imp_Casing := Lowercase; 9842 9843 when others => 9844 null; 9845 end case; 9846 end External_Name_Casing; 9847 9848 -------------------------- 9849 -- Favor_Top_Level -- 9850 -------------------------- 9851 9852 -- pragma Favor_Top_Level (type_NAME); 9853 9854 when Pragma_Favor_Top_Level => Favor_Top_Level : declare 9855 Named_Entity : Entity_Id; 9856 9857 begin 9858 GNAT_Pragma; 9859 Check_No_Identifiers; 9860 Check_Arg_Count (1); 9861 Check_Arg_Is_Local_Name (Arg1); 9862 Named_Entity := Entity (Get_Pragma_Arg (Arg1)); 9863 9864 -- If it's an access-to-subprogram type (in particular, not a 9865 -- subtype), set the flag on that type. 9866 9867 if Is_Access_Subprogram_Type (Named_Entity) then 9868 Set_Can_Use_Internal_Rep (Named_Entity, False); 9869 9870 -- Otherwise it's an error (name denotes the wrong sort of entity) 9871 9872 else 9873 Error_Pragma_Arg 9874 ("access-to-subprogram type expected", 9875 Get_Pragma_Arg (Arg1)); 9876 end if; 9877 end Favor_Top_Level; 9878 9879 --------------- 9880 -- Fast_Math -- 9881 --------------- 9882 9883 -- pragma Fast_Math; 9884 9885 when Pragma_Fast_Math => 9886 GNAT_Pragma; 9887 Check_No_Identifiers; 9888 Check_Valid_Configuration_Pragma; 9889 Fast_Math := True; 9890 9891 --------------------------- 9892 -- Finalize_Storage_Only -- 9893 --------------------------- 9894 9895 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); 9896 9897 when Pragma_Finalize_Storage_Only => Finalize_Storage : declare 9898 Assoc : constant Node_Id := Arg1; 9899 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 9900 Typ : Entity_Id; 9901 9902 begin 9903 GNAT_Pragma; 9904 Check_No_Identifiers; 9905 Check_Arg_Count (1); 9906 Check_Arg_Is_Local_Name (Arg1); 9907 9908 Find_Type (Type_Id); 9909 Typ := Entity (Type_Id); 9910 9911 if Typ = Any_Type 9912 or else Rep_Item_Too_Early (Typ, N) 9913 then 9914 return; 9915 else 9916 Typ := Underlying_Type (Typ); 9917 end if; 9918 9919 if not Is_Controlled (Typ) then 9920 Error_Pragma ("pragma% must specify controlled type"); 9921 end if; 9922 9923 Check_First_Subtype (Arg1); 9924 9925 if Finalize_Storage_Only (Typ) then 9926 Error_Pragma ("duplicate pragma%, only one allowed"); 9927 9928 elsif not Rep_Item_Too_Late (Typ, N) then 9929 Set_Finalize_Storage_Only (Base_Type (Typ), True); 9930 end if; 9931 end Finalize_Storage; 9932 9933 -------------------------- 9934 -- Float_Representation -- 9935 -------------------------- 9936 9937 -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]); 9938 9939 -- FLOAT_REP ::= VAX_Float | IEEE_Float 9940 9941 when Pragma_Float_Representation => Float_Representation : declare 9942 Argx : Node_Id; 9943 Digs : Nat; 9944 Ent : Entity_Id; 9945 9946 begin 9947 GNAT_Pragma; 9948 9949 if Arg_Count = 1 then 9950 Check_Valid_Configuration_Pragma; 9951 else 9952 Check_Arg_Count (2); 9953 Check_Optional_Identifier (Arg2, Name_Entity); 9954 Check_Arg_Is_Local_Name (Arg2); 9955 end if; 9956 9957 Check_No_Identifier (Arg1); 9958 Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); 9959 9960 if not OpenVMS_On_Target then 9961 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then 9962 Error_Pragma 9963 ("??pragma% ignored (applies only to Open'V'M'S)"); 9964 end if; 9965 9966 return; 9967 end if; 9968 9969 -- One argument case 9970 9971 if Arg_Count = 1 then 9972 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then 9973 if Opt.Float_Format = 'I' then 9974 Error_Pragma ("'I'E'E'E format previously specified"); 9975 end if; 9976 9977 Opt.Float_Format := 'V'; 9978 9979 else 9980 if Opt.Float_Format = 'V' then 9981 Error_Pragma ("'V'A'X format previously specified"); 9982 end if; 9983 9984 Opt.Float_Format := 'I'; 9985 end if; 9986 9987 Set_Standard_Fpt_Formats; 9988 9989 -- Two argument case 9990 9991 else 9992 Argx := Get_Pragma_Arg (Arg2); 9993 9994 if not Is_Entity_Name (Argx) 9995 or else not Is_Floating_Point_Type (Entity (Argx)) 9996 then 9997 Error_Pragma_Arg 9998 ("second argument of% pragma must be floating-point type", 9999 Arg2); 10000 end if; 10001 10002 Ent := Entity (Argx); 10003 Digs := UI_To_Int (Digits_Value (Ent)); 10004 10005 -- Two arguments, VAX_Float case 10006 10007 if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then 10008 case Digs is 10009 when 6 => Set_F_Float (Ent); 10010 when 9 => Set_D_Float (Ent); 10011 when 15 => Set_G_Float (Ent); 10012 10013 when others => 10014 Error_Pragma_Arg 10015 ("wrong digits value, must be 6,9 or 15", Arg2); 10016 end case; 10017 10018 -- Two arguments, IEEE_Float case 10019 10020 else 10021 case Digs is 10022 when 6 => Set_IEEE_Short (Ent); 10023 when 15 => Set_IEEE_Long (Ent); 10024 10025 when others => 10026 Error_Pragma_Arg 10027 ("wrong digits value, must be 6 or 15", Arg2); 10028 end case; 10029 end if; 10030 end if; 10031 end Float_Representation; 10032 10033 ------------ 10034 -- Global -- 10035 ------------ 10036 10037 -- pragma Global (GLOBAL_SPECIFICATION) 10038 10039 -- GLOBAL_SPECIFICATION ::= MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST} 10040 -- | GLOBAL_LIST 10041 -- | null 10042 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST 10043 -- MODE_SELECTOR ::= Input | Output | In_Out | Contract_In 10044 -- GLOBAL_LIST ::= GLOBAL_ITEM 10045 -- | (GLOBAL_ITEM {, GLOBAL_ITEM}) 10046 -- GLOBAL_ITEM ::= NAME 10047 10048 when Pragma_Global => Global : declare 10049 Subp_Id : Entity_Id; 10050 10051 Seen : Elist_Id := No_Elist; 10052 -- A list containing the entities of all the items processed so 10053 -- far. It plays a role in detecting distinct entities. 10054 10055 -- Flags used to verify the consistency of modes 10056 10057 Contract_Seen : Boolean := False; 10058 In_Out_Seen : Boolean := False; 10059 Input_Seen : Boolean := False; 10060 Output_Seen : Boolean := False; 10061 10062 procedure Analyze_Global_List 10063 (List : Node_Id; 10064 Global_Mode : Name_Id := Name_Input); 10065 -- Verify the legality of a single global list declaration. 10066 -- Global_Mode denotes the current mode in effect. 10067 10068 ------------------------- 10069 -- Analyze_Global_List -- 10070 ------------------------- 10071 10072 procedure Analyze_Global_List 10073 (List : Node_Id; 10074 Global_Mode : Name_Id := Name_Input) 10075 is 10076 procedure Analyze_Global_Item 10077 (Item : Node_Id; 10078 Global_Mode : Name_Id); 10079 -- Verify the legality of a single global item declaration. 10080 -- Global_Mode denotes the current mode in effect. 10081 10082 procedure Check_Duplicate_Mode 10083 (Mode : Node_Id; 10084 Status : in out Boolean); 10085 -- Flag Status denotes whether a particular mode has been seen 10086 -- while processing a global list. This routine verifies that 10087 -- Mode is not a duplicate mode and sets the flag Status. 10088 10089 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); 10090 -- Mode denotes either In_Out or Output. Depending on the kind 10091 -- of the related subprogram, emit an error if those two modes 10092 -- apply to a function. 10093 10094 ------------------------- 10095 -- Analyze_Global_Item -- 10096 ------------------------- 10097 10098 procedure Analyze_Global_Item 10099 (Item : Node_Id; 10100 Global_Mode : Name_Id) 10101 is 10102 function Is_Duplicate_Item (Id : Entity_Id) return Boolean; 10103 -- Determine whether Id has already been processed 10104 10105 ----------------------- 10106 -- Is_Duplicate_Item -- 10107 ----------------------- 10108 10109 function Is_Duplicate_Item (Id : Entity_Id) return Boolean is 10110 Item_Elmt : Elmt_Id; 10111 10112 begin 10113 if Present (Seen) then 10114 Item_Elmt := First_Elmt (Seen); 10115 while Present (Item_Elmt) loop 10116 if Node (Item_Elmt) = Id then 10117 return True; 10118 end if; 10119 10120 Next_Elmt (Item_Elmt); 10121 end loop; 10122 end if; 10123 10124 return False; 10125 end Is_Duplicate_Item; 10126 10127 -- Local declarations 10128 10129 Id : Entity_Id; 10130 10131 -- Start of processing for Analyze_Global_Item 10132 10133 begin 10134 -- Detect one of the following cases 10135 10136 -- with Global => (null, Name) 10137 -- with Global => (Name_1, null, Name_2) 10138 -- with Global => (Name, null) 10139 10140 if Nkind (Item) = N_Null then 10141 Error_Msg_N 10142 ("cannot mix null and non-null global items", Item); 10143 return; 10144 end if; 10145 10146 Analyze (Item); 10147 10148 if Is_Entity_Name (Item) then 10149 Id := Entity (Item); 10150 10151 -- A global item cannot reference a formal parameter. Do 10152 -- this check first to provide a better error diagnostic. 10153 10154 if Is_Formal (Id) then 10155 Error_Msg_N 10156 ("global item cannot reference formal parameter", 10157 Item); 10158 return; 10159 10160 -- The only legal references are those to abstract states 10161 -- and variables. 10162 10163 elsif not Ekind_In (Entity (Item), E_Abstract_State, 10164 E_Variable) 10165 then 10166 Error_Msg_N 10167 ("global item must denote variable or state", Item); 10168 return; 10169 end if; 10170 10171 -- Some form of illegal construct masquerading as a name 10172 10173 else 10174 Error_Msg_N 10175 ("global item must denote variable or state", Item); 10176 return; 10177 end if; 10178 10179 -- The same entity might be referenced through various way. 10180 -- Check the entity of the item rather than the item itself. 10181 10182 if Is_Duplicate_Item (Id) then 10183 Error_Msg_N ("duplicate global item", Item); 10184 10185 -- Add the entity of the current item to the list of 10186 -- processed items. 10187 10188 else 10189 if No (Seen) then 10190 Seen := New_Elmt_List; 10191 end if; 10192 10193 Append_Elmt (Id, Seen); 10194 end if; 10195 10196 if Ekind (Id) = E_Abstract_State 10197 and then Is_Volatile_State (Id) 10198 then 10199 -- A global item of mode In_Out or Output cannot denote a 10200 -- volatile Input state. 10201 10202 if Is_Input_State (Id) 10203 and then (Global_Mode = Name_In_Out 10204 or else 10205 Global_Mode = Name_Output) 10206 then 10207 Error_Msg_N 10208 ("global item of mode In_Out or Output cannot " & 10209 "reference Volatile Input state", Item); 10210 10211 -- A global item of mode In_Out or Input cannot reference 10212 -- a volatile Output state. 10213 10214 elsif Is_Output_State (Id) 10215 and then (Global_Mode = Name_In_Out 10216 or else 10217 Global_Mode = Name_Input) 10218 then 10219 Error_Msg_N 10220 ("global item of mode In_Out or Input cannot " 10221 & "reference Volatile Output state", Item); 10222 end if; 10223 end if; 10224 end Analyze_Global_Item; 10225 10226 -------------------------- 10227 -- Check_Duplicate_Mode -- 10228 -------------------------- 10229 10230 procedure Check_Duplicate_Mode 10231 (Mode : Node_Id; 10232 Status : in out Boolean) 10233 is 10234 begin 10235 if Status then 10236 Error_Msg_N ("duplicate global mode", Mode); 10237 end if; 10238 10239 Status := True; 10240 end Check_Duplicate_Mode; 10241 10242 ---------------------------------------- 10243 -- Check_Mode_Restriction_In_Function -- 10244 ---------------------------------------- 10245 10246 procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is 10247 begin 10248 if Ekind (Subp_Id) = E_Function then 10249 Error_Msg_Name_1 := Chars (Mode); 10250 Error_Msg_N 10251 ("global mode % not applicable to functions", Mode); 10252 end if; 10253 end Check_Mode_Restriction_In_Function; 10254 10255 -- Local variables 10256 10257 Assoc : Node_Id; 10258 Item : Node_Id; 10259 Mode : Node_Id; 10260 10261 -- Start of processing for Analyze_Global_List 10262 10263 begin 10264 -- Single global item declaration 10265 10266 if Nkind_In (List, N_Identifier, N_Selected_Component) then 10267 Analyze_Global_Item (List, Global_Mode); 10268 10269 -- Simple global list or moded global list declaration 10270 10271 elsif Nkind (List) = N_Aggregate then 10272 10273 -- The declaration of a simple global list appear as a 10274 -- collection of expressions. 10275 10276 if Present (Expressions (List)) then 10277 if Present (Component_Associations (List)) then 10278 Error_Msg_N 10279 ("cannot mix moded and non-moded global lists", 10280 List); 10281 end if; 10282 10283 Item := First (Expressions (List)); 10284 while Present (Item) loop 10285 Analyze_Global_Item (Item, Global_Mode); 10286 10287 Next (Item); 10288 end loop; 10289 10290 -- The declaration of a moded global list appears as a 10291 -- collection of component associations where individual 10292 -- choices denote modes. 10293 10294 elsif Present (Component_Associations (List)) then 10295 if Present (Expressions (List)) then 10296 Error_Msg_N 10297 ("cannot mix moded and non-moded global lists", 10298 List); 10299 end if; 10300 10301 Assoc := First (Component_Associations (List)); 10302 while Present (Assoc) loop 10303 Mode := First (Choices (Assoc)); 10304 10305 if Nkind (Mode) = N_Identifier then 10306 if Chars (Mode) = Name_Contract_In then 10307 Check_Duplicate_Mode (Mode, Contract_Seen); 10308 10309 elsif Chars (Mode) = Name_In_Out then 10310 Check_Duplicate_Mode (Mode, In_Out_Seen); 10311 Check_Mode_Restriction_In_Function (Mode); 10312 10313 elsif Chars (Mode) = Name_Input then 10314 Check_Duplicate_Mode (Mode, Input_Seen); 10315 10316 elsif Chars (Mode) = Name_Output then 10317 Check_Duplicate_Mode (Mode, Output_Seen); 10318 Check_Mode_Restriction_In_Function (Mode); 10319 10320 else 10321 Error_Msg_N ("invalid mode selector", Mode); 10322 end if; 10323 10324 else 10325 Error_Msg_N ("invalid mode selector", Mode); 10326 end if; 10327 10328 -- Items in a moded list appear as a collection of 10329 -- expressions. Reuse the existing machinery to 10330 -- analyze them. 10331 10332 Analyze_Global_List 10333 (List => Expression (Assoc), 10334 Global_Mode => Chars (Mode)); 10335 10336 Next (Assoc); 10337 end loop; 10338 10339 -- Something went horribly wrong, we have a malformed tree 10340 10341 else 10342 raise Program_Error; 10343 end if; 10344 10345 -- Any other attempt to declare a global item is erroneous 10346 10347 else 10348 Error_Msg_N ("malformed global list declaration", List); 10349 end if; 10350 end Analyze_Global_List; 10351 10352 -- Local variables 10353 10354 List : Node_Id; 10355 Subp : Node_Id; 10356 10357 -- Start of processing for Global 10358 10359 begin 10360 GNAT_Pragma; 10361 S14_Pragma; 10362 Check_Arg_Count (1); 10363 10364 -- Ensure the proper placement of the pragma. Global must be 10365 -- associated with a subprogram declaration. 10366 10367 Subp := Parent (Corresponding_Aspect (N)); 10368 10369 if Nkind (Subp) /= N_Subprogram_Declaration then 10370 Pragma_Misplaced; 10371 return; 10372 end if; 10373 10374 Subp_Id := Defining_Unit_Name (Specification (Subp)); 10375 List := Expression (Arg1); 10376 10377 -- There is nothing to be done for a null global list 10378 10379 if Nkind (List) = N_Null then 10380 null; 10381 10382 -- Analyze the various forms of global lists and items. Note that 10383 -- some of these may be malformed in which case the analysis emits 10384 -- error messages. 10385 10386 else 10387 -- Ensure that the formal parameters are visible when 10388 -- processing an item. This falls out of the general rule of 10389 -- aspects pertaining to subprogram declarations. 10390 10391 Push_Scope (Subp_Id); 10392 Install_Formals (Subp_Id); 10393 10394 Analyze_Global_List (List); 10395 10396 Pop_Scope; 10397 end if; 10398 end Global; 10399 10400 ----------- 10401 -- Ident -- 10402 ----------- 10403 10404 -- pragma Ident (static_string_EXPRESSION) 10405 10406 -- Note: pragma Comment shares this processing. Pragma Comment is 10407 -- identical to Ident, except that the restriction of the argument to 10408 -- 31 characters and the placement restrictions are not enforced for 10409 -- pragma Comment. 10410 10411 when Pragma_Ident | Pragma_Comment => Ident : declare 10412 Str : Node_Id; 10413 10414 begin 10415 GNAT_Pragma; 10416 Check_Arg_Count (1); 10417 Check_No_Identifiers; 10418 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 10419 Store_Note (N); 10420 10421 -- For pragma Ident, preserve DEC compatibility by requiring the 10422 -- pragma to appear in a declarative part or package spec. 10423 10424 if Prag_Id = Pragma_Ident then 10425 Check_Is_In_Decl_Part_Or_Package_Spec; 10426 end if; 10427 10428 Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); 10429 10430 declare 10431 CS : Node_Id; 10432 GP : Node_Id; 10433 10434 begin 10435 GP := Parent (Parent (N)); 10436 10437 if Nkind_In (GP, N_Package_Declaration, 10438 N_Generic_Package_Declaration) 10439 then 10440 GP := Parent (GP); 10441 end if; 10442 10443 -- If we have a compilation unit, then record the ident value, 10444 -- checking for improper duplication. 10445 10446 if Nkind (GP) = N_Compilation_Unit then 10447 CS := Ident_String (Current_Sem_Unit); 10448 10449 if Present (CS) then 10450 10451 -- For Ident, we do not permit multiple instances 10452 10453 if Prag_Id = Pragma_Ident then 10454 Error_Pragma ("duplicate% pragma not permitted"); 10455 10456 -- For Comment, we concatenate the string, unless we want 10457 -- to preserve the tree structure for ASIS. 10458 10459 elsif not ASIS_Mode then 10460 Start_String (Strval (CS)); 10461 Store_String_Char (' '); 10462 Store_String_Chars (Strval (Str)); 10463 Set_Strval (CS, End_String); 10464 end if; 10465 10466 else 10467 -- In VMS, the effect of IDENT is achieved by passing 10468 -- --identification=name as a --for-linker switch. 10469 10470 if OpenVMS_On_Target then 10471 Start_String; 10472 Store_String_Chars 10473 ("--for-linker=--identification="); 10474 String_To_Name_Buffer (Strval (Str)); 10475 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 10476 10477 -- Only the last processed IDENT is saved. The main 10478 -- purpose is so an IDENT associated with a main 10479 -- procedure will be used in preference to an IDENT 10480 -- associated with a with'd package. 10481 10482 Replace_Linker_Option_String 10483 (End_String, "--for-linker=--identification="); 10484 end if; 10485 10486 Set_Ident_String (Current_Sem_Unit, Str); 10487 end if; 10488 10489 -- For subunits, we just ignore the Ident, since in GNAT these 10490 -- are not separate object files, and hence not separate units 10491 -- in the unit table. 10492 10493 elsif Nkind (GP) = N_Subunit then 10494 null; 10495 10496 -- Otherwise we have a misplaced pragma Ident, but we ignore 10497 -- this if we are in an instantiation, since it comes from 10498 -- a generic, and has no relevance to the instantiation. 10499 10500 elsif Prag_Id = Pragma_Ident then 10501 if Instantiation_Location (Loc) = No_Location then 10502 Error_Pragma ("pragma% only allowed at outer level"); 10503 end if; 10504 end if; 10505 end; 10506 end Ident; 10507 10508 ---------------------------- 10509 -- Implementation_Defined -- 10510 ---------------------------- 10511 10512 -- pragma Implementation_Defined (local_NAME); 10513 10514 -- Marks previously declared entity as implementation defined. For 10515 -- an overloaded entity, applies to the most recent homonym. 10516 10517 -- pragma Implementation_Defined; 10518 10519 -- The form with no arguments appears anywhere within a scope, most 10520 -- typically a package spec, and indicates that all entities that are 10521 -- defined within the package spec are Implementation_Defined. 10522 10523 when Pragma_Implementation_Defined => Implementation_Defined : declare 10524 Ent : Entity_Id; 10525 10526 begin 10527 Check_No_Identifiers; 10528 10529 -- Form with no arguments 10530 10531 if Arg_Count = 0 then 10532 Set_Is_Implementation_Defined (Current_Scope); 10533 10534 -- Form with one argument 10535 10536 else 10537 Check_Arg_Count (1); 10538 Check_Arg_Is_Local_Name (Arg1); 10539 Ent := Entity (Get_Pragma_Arg (Arg1)); 10540 Set_Is_Implementation_Defined (Ent); 10541 end if; 10542 end Implementation_Defined; 10543 10544 ----------------- 10545 -- Implemented -- 10546 ----------------- 10547 10548 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND); 10549 10550 -- IMPLEMENTATION_KIND ::= 10551 -- By_Entry | By_Protected_Procedure | By_Any | Optional 10552 10553 -- "By_Any" and "Optional" are treated as synonyms in order to 10554 -- support Ada 2012 aspect Synchronization. 10555 10556 when Pragma_Implemented => Implemented : declare 10557 Proc_Id : Entity_Id; 10558 Typ : Entity_Id; 10559 10560 begin 10561 Ada_2012_Pragma; 10562 Check_Arg_Count (2); 10563 Check_No_Identifiers; 10564 Check_Arg_Is_Identifier (Arg1); 10565 Check_Arg_Is_Local_Name (Arg1); 10566 Check_Arg_Is_One_Of (Arg2, 10567 Name_By_Any, 10568 Name_By_Entry, 10569 Name_By_Protected_Procedure, 10570 Name_Optional); 10571 10572 -- Extract the name of the local procedure 10573 10574 Proc_Id := Entity (Get_Pragma_Arg (Arg1)); 10575 10576 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a 10577 -- primitive procedure of a synchronized tagged type. 10578 10579 if Ekind (Proc_Id) = E_Procedure 10580 and then Is_Primitive (Proc_Id) 10581 and then Present (First_Formal (Proc_Id)) 10582 then 10583 Typ := Etype (First_Formal (Proc_Id)); 10584 10585 if Is_Tagged_Type (Typ) 10586 and then 10587 10588 -- Check for a protected, a synchronized or a task interface 10589 10590 ((Is_Interface (Typ) 10591 and then Is_Synchronized_Interface (Typ)) 10592 10593 -- Check for a protected type or a task type that implements 10594 -- an interface. 10595 10596 or else 10597 (Is_Concurrent_Record_Type (Typ) 10598 and then Present (Interfaces (Typ))) 10599 10600 -- Check for a private record extension with keyword 10601 -- "synchronized". 10602 10603 or else 10604 (Ekind_In (Typ, E_Record_Type_With_Private, 10605 E_Record_Subtype_With_Private) 10606 and then Synchronized_Present (Parent (Typ)))) 10607 then 10608 null; 10609 else 10610 Error_Pragma_Arg 10611 ("controlling formal must be of synchronized " & 10612 "tagged type", Arg1); 10613 return; 10614 end if; 10615 10616 -- Procedures declared inside a protected type must be accepted 10617 10618 elsif Ekind (Proc_Id) = E_Procedure 10619 and then Is_Protected_Type (Scope (Proc_Id)) 10620 then 10621 null; 10622 10623 -- The first argument is not a primitive procedure 10624 10625 else 10626 Error_Pragma_Arg 10627 ("pragma % must be applied to a primitive procedure", Arg1); 10628 return; 10629 end if; 10630 10631 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind 10632 -- By_Protected_Procedure to the primitive procedure of a task 10633 -- interface. 10634 10635 if Chars (Arg2) = Name_By_Protected_Procedure 10636 and then Is_Interface (Typ) 10637 and then Is_Task_Interface (Typ) 10638 then 10639 Error_Pragma_Arg 10640 ("implementation kind By_Protected_Procedure cannot be " & 10641 "applied to a task interface primitive", Arg2); 10642 return; 10643 end if; 10644 10645 Record_Rep_Item (Proc_Id, N); 10646 end Implemented; 10647 10648 ---------------------- 10649 -- Implicit_Packing -- 10650 ---------------------- 10651 10652 -- pragma Implicit_Packing; 10653 10654 when Pragma_Implicit_Packing => 10655 GNAT_Pragma; 10656 Check_Arg_Count (0); 10657 Implicit_Packing := True; 10658 10659 ------------ 10660 -- Import -- 10661 ------------ 10662 10663 -- pragma Import ( 10664 -- [Convention =>] convention_IDENTIFIER, 10665 -- [Entity =>] local_NAME 10666 -- [, [External_Name =>] static_string_EXPRESSION ] 10667 -- [, [Link_Name =>] static_string_EXPRESSION ]); 10668 10669 when Pragma_Import => 10670 Check_Ada_83_Warning; 10671 Check_Arg_Order 10672 ((Name_Convention, 10673 Name_Entity, 10674 Name_External_Name, 10675 Name_Link_Name)); 10676 10677 Check_At_Least_N_Arguments (2); 10678 Check_At_Most_N_Arguments (4); 10679 Process_Import_Or_Interface; 10680 10681 ---------------------- 10682 -- Import_Exception -- 10683 ---------------------- 10684 10685 -- pragma Import_Exception ( 10686 -- [Internal =>] LOCAL_NAME 10687 -- [, [External =>] EXTERNAL_SYMBOL] 10688 -- [, [Form =>] Ada | VMS] 10689 -- [, [Code =>] static_integer_EXPRESSION]); 10690 10691 when Pragma_Import_Exception => Import_Exception : declare 10692 Args : Args_List (1 .. 4); 10693 Names : constant Name_List (1 .. 4) := ( 10694 Name_Internal, 10695 Name_External, 10696 Name_Form, 10697 Name_Code); 10698 10699 Internal : Node_Id renames Args (1); 10700 External : Node_Id renames Args (2); 10701 Form : Node_Id renames Args (3); 10702 Code : Node_Id renames Args (4); 10703 10704 begin 10705 GNAT_Pragma; 10706 Gather_Associations (Names, Args); 10707 10708 if Present (External) and then Present (Code) then 10709 Error_Pragma 10710 ("cannot give both External and Code options for pragma%"); 10711 end if; 10712 10713 Process_Extended_Import_Export_Exception_Pragma ( 10714 Arg_Internal => Internal, 10715 Arg_External => External, 10716 Arg_Form => Form, 10717 Arg_Code => Code); 10718 10719 if not Is_VMS_Exception (Entity (Internal)) then 10720 Set_Imported (Entity (Internal)); 10721 end if; 10722 end Import_Exception; 10723 10724 --------------------- 10725 -- Import_Function -- 10726 --------------------- 10727 10728 -- pragma Import_Function ( 10729 -- [Internal =>] LOCAL_NAME, 10730 -- [, [External =>] EXTERNAL_SYMBOL] 10731 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 10732 -- [, [Result_Type =>] SUBTYPE_MARK] 10733 -- [, [Mechanism =>] MECHANISM] 10734 -- [, [Result_Mechanism =>] MECHANISM_NAME] 10735 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 10736 10737 -- EXTERNAL_SYMBOL ::= 10738 -- IDENTIFIER 10739 -- | static_string_EXPRESSION 10740 10741 -- PARAMETER_TYPES ::= 10742 -- null 10743 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 10744 10745 -- TYPE_DESIGNATOR ::= 10746 -- subtype_NAME 10747 -- | subtype_Name ' Access 10748 10749 -- MECHANISM ::= 10750 -- MECHANISM_NAME 10751 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 10752 10753 -- MECHANISM_ASSOCIATION ::= 10754 -- [formal_parameter_NAME =>] MECHANISM_NAME 10755 10756 -- MECHANISM_NAME ::= 10757 -- Value 10758 -- | Reference 10759 -- | Descriptor [([Class =>] CLASS_NAME)] 10760 10761 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 10762 10763 when Pragma_Import_Function => Import_Function : declare 10764 Args : Args_List (1 .. 7); 10765 Names : constant Name_List (1 .. 7) := ( 10766 Name_Internal, 10767 Name_External, 10768 Name_Parameter_Types, 10769 Name_Result_Type, 10770 Name_Mechanism, 10771 Name_Result_Mechanism, 10772 Name_First_Optional_Parameter); 10773 10774 Internal : Node_Id renames Args (1); 10775 External : Node_Id renames Args (2); 10776 Parameter_Types : Node_Id renames Args (3); 10777 Result_Type : Node_Id renames Args (4); 10778 Mechanism : Node_Id renames Args (5); 10779 Result_Mechanism : Node_Id renames Args (6); 10780 First_Optional_Parameter : Node_Id renames Args (7); 10781 10782 begin 10783 GNAT_Pragma; 10784 Gather_Associations (Names, Args); 10785 Process_Extended_Import_Export_Subprogram_Pragma ( 10786 Arg_Internal => Internal, 10787 Arg_External => External, 10788 Arg_Parameter_Types => Parameter_Types, 10789 Arg_Result_Type => Result_Type, 10790 Arg_Mechanism => Mechanism, 10791 Arg_Result_Mechanism => Result_Mechanism, 10792 Arg_First_Optional_Parameter => First_Optional_Parameter); 10793 end Import_Function; 10794 10795 ------------------- 10796 -- Import_Object -- 10797 ------------------- 10798 10799 -- pragma Import_Object ( 10800 -- [Internal =>] LOCAL_NAME 10801 -- [, [External =>] EXTERNAL_SYMBOL] 10802 -- [, [Size =>] EXTERNAL_SYMBOL]); 10803 10804 -- EXTERNAL_SYMBOL ::= 10805 -- IDENTIFIER 10806 -- | static_string_EXPRESSION 10807 10808 when Pragma_Import_Object => Import_Object : declare 10809 Args : Args_List (1 .. 3); 10810 Names : constant Name_List (1 .. 3) := ( 10811 Name_Internal, 10812 Name_External, 10813 Name_Size); 10814 10815 Internal : Node_Id renames Args (1); 10816 External : Node_Id renames Args (2); 10817 Size : Node_Id renames Args (3); 10818 10819 begin 10820 GNAT_Pragma; 10821 Gather_Associations (Names, Args); 10822 Process_Extended_Import_Export_Object_Pragma ( 10823 Arg_Internal => Internal, 10824 Arg_External => External, 10825 Arg_Size => Size); 10826 end Import_Object; 10827 10828 ---------------------- 10829 -- Import_Procedure -- 10830 ---------------------- 10831 10832 -- pragma Import_Procedure ( 10833 -- [Internal =>] LOCAL_NAME 10834 -- [, [External =>] EXTERNAL_SYMBOL] 10835 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 10836 -- [, [Mechanism =>] MECHANISM] 10837 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 10838 10839 -- EXTERNAL_SYMBOL ::= 10840 -- IDENTIFIER 10841 -- | static_string_EXPRESSION 10842 10843 -- PARAMETER_TYPES ::= 10844 -- null 10845 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 10846 10847 -- TYPE_DESIGNATOR ::= 10848 -- subtype_NAME 10849 -- | subtype_Name ' Access 10850 10851 -- MECHANISM ::= 10852 -- MECHANISM_NAME 10853 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 10854 10855 -- MECHANISM_ASSOCIATION ::= 10856 -- [formal_parameter_NAME =>] MECHANISM_NAME 10857 10858 -- MECHANISM_NAME ::= 10859 -- Value 10860 -- | Reference 10861 -- | Descriptor [([Class =>] CLASS_NAME)] 10862 10863 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 10864 10865 when Pragma_Import_Procedure => Import_Procedure : declare 10866 Args : Args_List (1 .. 5); 10867 Names : constant Name_List (1 .. 5) := ( 10868 Name_Internal, 10869 Name_External, 10870 Name_Parameter_Types, 10871 Name_Mechanism, 10872 Name_First_Optional_Parameter); 10873 10874 Internal : Node_Id renames Args (1); 10875 External : Node_Id renames Args (2); 10876 Parameter_Types : Node_Id renames Args (3); 10877 Mechanism : Node_Id renames Args (4); 10878 First_Optional_Parameter : Node_Id renames Args (5); 10879 10880 begin 10881 GNAT_Pragma; 10882 Gather_Associations (Names, Args); 10883 Process_Extended_Import_Export_Subprogram_Pragma ( 10884 Arg_Internal => Internal, 10885 Arg_External => External, 10886 Arg_Parameter_Types => Parameter_Types, 10887 Arg_Mechanism => Mechanism, 10888 Arg_First_Optional_Parameter => First_Optional_Parameter); 10889 end Import_Procedure; 10890 10891 ----------------------------- 10892 -- Import_Valued_Procedure -- 10893 ----------------------------- 10894 10895 -- pragma Import_Valued_Procedure ( 10896 -- [Internal =>] LOCAL_NAME 10897 -- [, [External =>] EXTERNAL_SYMBOL] 10898 -- [, [Parameter_Types =>] (PARAMETER_TYPES)] 10899 -- [, [Mechanism =>] MECHANISM] 10900 -- [, [First_Optional_Parameter =>] IDENTIFIER]); 10901 10902 -- EXTERNAL_SYMBOL ::= 10903 -- IDENTIFIER 10904 -- | static_string_EXPRESSION 10905 10906 -- PARAMETER_TYPES ::= 10907 -- null 10908 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} 10909 10910 -- TYPE_DESIGNATOR ::= 10911 -- subtype_NAME 10912 -- | subtype_Name ' Access 10913 10914 -- MECHANISM ::= 10915 -- MECHANISM_NAME 10916 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) 10917 10918 -- MECHANISM_ASSOCIATION ::= 10919 -- [formal_parameter_NAME =>] MECHANISM_NAME 10920 10921 -- MECHANISM_NAME ::= 10922 -- Value 10923 -- | Reference 10924 -- | Descriptor [([Class =>] CLASS_NAME)] 10925 10926 -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca 10927 10928 when Pragma_Import_Valued_Procedure => 10929 Import_Valued_Procedure : declare 10930 Args : Args_List (1 .. 5); 10931 Names : constant Name_List (1 .. 5) := ( 10932 Name_Internal, 10933 Name_External, 10934 Name_Parameter_Types, 10935 Name_Mechanism, 10936 Name_First_Optional_Parameter); 10937 10938 Internal : Node_Id renames Args (1); 10939 External : Node_Id renames Args (2); 10940 Parameter_Types : Node_Id renames Args (3); 10941 Mechanism : Node_Id renames Args (4); 10942 First_Optional_Parameter : Node_Id renames Args (5); 10943 10944 begin 10945 GNAT_Pragma; 10946 Gather_Associations (Names, Args); 10947 Process_Extended_Import_Export_Subprogram_Pragma ( 10948 Arg_Internal => Internal, 10949 Arg_External => External, 10950 Arg_Parameter_Types => Parameter_Types, 10951 Arg_Mechanism => Mechanism, 10952 Arg_First_Optional_Parameter => First_Optional_Parameter); 10953 end Import_Valued_Procedure; 10954 10955 ----------------- 10956 -- Independent -- 10957 ----------------- 10958 10959 -- pragma Independent (LOCAL_NAME); 10960 10961 when Pragma_Independent => Independent : declare 10962 E_Id : Node_Id; 10963 E : Entity_Id; 10964 D : Node_Id; 10965 K : Node_Kind; 10966 10967 begin 10968 Check_Ada_83_Warning; 10969 Ada_2012_Pragma; 10970 Check_No_Identifiers; 10971 Check_Arg_Count (1); 10972 Check_Arg_Is_Local_Name (Arg1); 10973 E_Id := Get_Pragma_Arg (Arg1); 10974 10975 if Etype (E_Id) = Any_Type then 10976 return; 10977 end if; 10978 10979 E := Entity (E_Id); 10980 D := Declaration_Node (E); 10981 K := Nkind (D); 10982 10983 -- Check duplicate before we chain ourselves! 10984 10985 Check_Duplicate_Pragma (E); 10986 10987 -- Check appropriate entity 10988 10989 if Is_Type (E) then 10990 if Rep_Item_Too_Early (E, N) 10991 or else 10992 Rep_Item_Too_Late (E, N) 10993 then 10994 return; 10995 else 10996 Check_First_Subtype (Arg1); 10997 end if; 10998 10999 elsif K = N_Object_Declaration 11000 or else (K = N_Component_Declaration 11001 and then Original_Record_Component (E) = E) 11002 then 11003 if Rep_Item_Too_Late (E, N) then 11004 return; 11005 end if; 11006 11007 else 11008 Error_Pragma_Arg 11009 ("inappropriate entity for pragma%", Arg1); 11010 end if; 11011 11012 Independence_Checks.Append ((N, E)); 11013 end Independent; 11014 11015 ---------------------------- 11016 -- Independent_Components -- 11017 ---------------------------- 11018 11019 -- pragma Atomic_Components (array_LOCAL_NAME); 11020 11021 -- This processing is shared by Volatile_Components 11022 11023 when Pragma_Independent_Components => Independent_Components : declare 11024 E_Id : Node_Id; 11025 E : Entity_Id; 11026 D : Node_Id; 11027 K : Node_Kind; 11028 11029 begin 11030 Check_Ada_83_Warning; 11031 Ada_2012_Pragma; 11032 Check_No_Identifiers; 11033 Check_Arg_Count (1); 11034 Check_Arg_Is_Local_Name (Arg1); 11035 E_Id := Get_Pragma_Arg (Arg1); 11036 11037 if Etype (E_Id) = Any_Type then 11038 return; 11039 end if; 11040 11041 E := Entity (E_Id); 11042 11043 -- Check duplicate before we chain ourselves! 11044 11045 Check_Duplicate_Pragma (E); 11046 11047 -- Check appropriate entity 11048 11049 if Rep_Item_Too_Early (E, N) 11050 or else 11051 Rep_Item_Too_Late (E, N) 11052 then 11053 return; 11054 end if; 11055 11056 D := Declaration_Node (E); 11057 K := Nkind (D); 11058 11059 if K = N_Full_Type_Declaration 11060 and then (Is_Array_Type (E) or else Is_Record_Type (E)) 11061 then 11062 Independence_Checks.Append ((N, E)); 11063 Set_Has_Independent_Components (Base_Type (E)); 11064 11065 elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) 11066 and then Nkind (D) = N_Object_Declaration 11067 and then Nkind (Object_Definition (D)) = 11068 N_Constrained_Array_Definition 11069 then 11070 Independence_Checks.Append ((N, E)); 11071 Set_Has_Independent_Components (E); 11072 11073 else 11074 Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); 11075 end if; 11076 end Independent_Components; 11077 11078 ------------------------ 11079 -- Initialize_Scalars -- 11080 ------------------------ 11081 11082 -- pragma Initialize_Scalars; 11083 11084 when Pragma_Initialize_Scalars => 11085 GNAT_Pragma; 11086 Check_Arg_Count (0); 11087 Check_Valid_Configuration_Pragma; 11088 Check_Restriction (No_Initialize_Scalars, N); 11089 11090 -- Initialize_Scalars creates false positives in CodePeer, and 11091 -- incorrect negative results in Alfa mode, so ignore this pragma 11092 -- in these modes. 11093 11094 if not Restriction_Active (No_Initialize_Scalars) 11095 and then not (CodePeer_Mode or Alfa_Mode) 11096 then 11097 Init_Or_Norm_Scalars := True; 11098 Initialize_Scalars := True; 11099 end if; 11100 11101 ------------ 11102 -- Inline -- 11103 ------------ 11104 11105 -- pragma Inline ( NAME {, NAME} ); 11106 11107 when Pragma_Inline => 11108 11109 -- Inline status is Enabled if inlining option is active 11110 11111 if Inline_Active then 11112 Process_Inline (Enabled); 11113 else 11114 Process_Inline (Disabled); 11115 end if; 11116 11117 ------------------- 11118 -- Inline_Always -- 11119 ------------------- 11120 11121 -- pragma Inline_Always ( NAME {, NAME} ); 11122 11123 when Pragma_Inline_Always => 11124 GNAT_Pragma; 11125 11126 -- Pragma always active unless in CodePeer or Alfa mode, since 11127 -- this causes walk order issues. 11128 11129 if not (CodePeer_Mode or Alfa_Mode) then 11130 Process_Inline (Enabled); 11131 end if; 11132 11133 -------------------- 11134 -- Inline_Generic -- 11135 -------------------- 11136 11137 -- pragma Inline_Generic (NAME {, NAME}); 11138 11139 when Pragma_Inline_Generic => 11140 GNAT_Pragma; 11141 Process_Generic_List; 11142 11143 ---------------------- 11144 -- Inspection_Point -- 11145 ---------------------- 11146 11147 -- pragma Inspection_Point [(object_NAME {, object_NAME})]; 11148 11149 when Pragma_Inspection_Point => Inspection_Point : declare 11150 Arg : Node_Id; 11151 Exp : Node_Id; 11152 11153 begin 11154 if Arg_Count > 0 then 11155 Arg := Arg1; 11156 loop 11157 Exp := Get_Pragma_Arg (Arg); 11158 Analyze (Exp); 11159 11160 if not Is_Entity_Name (Exp) 11161 or else not Is_Object (Entity (Exp)) 11162 then 11163 Error_Pragma_Arg ("object name required", Arg); 11164 end if; 11165 11166 Next (Arg); 11167 exit when No (Arg); 11168 end loop; 11169 end if; 11170 end Inspection_Point; 11171 11172 --------------- 11173 -- Interface -- 11174 --------------- 11175 11176 -- pragma Interface ( 11177 -- [ Convention =>] convention_IDENTIFIER, 11178 -- [ Entity =>] local_NAME 11179 -- [, [External_Name =>] static_string_EXPRESSION ] 11180 -- [, [Link_Name =>] static_string_EXPRESSION ]); 11181 11182 when Pragma_Interface => 11183 GNAT_Pragma; 11184 Check_Arg_Order 11185 ((Name_Convention, 11186 Name_Entity, 11187 Name_External_Name, 11188 Name_Link_Name)); 11189 Check_At_Least_N_Arguments (2); 11190 Check_At_Most_N_Arguments (4); 11191 Process_Import_Or_Interface; 11192 11193 -- In Ada 2005, the permission to use Interface (a reserved word) 11194 -- as a pragma name is considered an obsolescent feature, and this 11195 -- pragma was already obsolescent in Ada 95. 11196 11197 if Ada_Version >= Ada_95 then 11198 Check_Restriction 11199 (No_Obsolescent_Features, Pragma_Identifier (N)); 11200 11201 if Warn_On_Obsolescent_Feature then 11202 Error_Msg_N 11203 ("pragma Interface is an obsolescent feature?j?", N); 11204 Error_Msg_N 11205 ("|use pragma Import instead?j?", N); 11206 end if; 11207 end if; 11208 11209 -------------------- 11210 -- Interface_Name -- 11211 -------------------- 11212 11213 -- pragma Interface_Name ( 11214 -- [ Entity =>] local_NAME 11215 -- [,[External_Name =>] static_string_EXPRESSION ] 11216 -- [,[Link_Name =>] static_string_EXPRESSION ]); 11217 11218 when Pragma_Interface_Name => Interface_Name : declare 11219 Id : Node_Id; 11220 Def_Id : Entity_Id; 11221 Hom_Id : Entity_Id; 11222 Found : Boolean; 11223 11224 begin 11225 GNAT_Pragma; 11226 Check_Arg_Order 11227 ((Name_Entity, Name_External_Name, Name_Link_Name)); 11228 Check_At_Least_N_Arguments (2); 11229 Check_At_Most_N_Arguments (3); 11230 Id := Get_Pragma_Arg (Arg1); 11231 Analyze (Id); 11232 11233 -- This is obsolete from Ada 95 on, but it is an implementation 11234 -- defined pragma, so we do not consider that it violates the 11235 -- restriction (No_Obsolescent_Features). 11236 11237 if Ada_Version >= Ada_95 then 11238 if Warn_On_Obsolescent_Feature then 11239 Error_Msg_N 11240 ("pragma Interface_Name is an obsolescent feature?j?", N); 11241 Error_Msg_N 11242 ("|use pragma Import instead?j?", N); 11243 end if; 11244 end if; 11245 11246 if not Is_Entity_Name (Id) then 11247 Error_Pragma_Arg 11248 ("first argument for pragma% must be entity name", Arg1); 11249 elsif Etype (Id) = Any_Type then 11250 return; 11251 else 11252 Def_Id := Entity (Id); 11253 end if; 11254 11255 -- Special DEC-compatible processing for the object case, forces 11256 -- object to be imported. 11257 11258 if Ekind (Def_Id) = E_Variable then 11259 Kill_Size_Check_Code (Def_Id); 11260 Note_Possible_Modification (Id, Sure => False); 11261 11262 -- Initialization is not allowed for imported variable 11263 11264 if Present (Expression (Parent (Def_Id))) 11265 and then Comes_From_Source (Expression (Parent (Def_Id))) 11266 then 11267 Error_Msg_Sloc := Sloc (Def_Id); 11268 Error_Pragma_Arg 11269 ("no initialization allowed for declaration of& #", 11270 Arg2); 11271 11272 else 11273 -- For compatibility, support VADS usage of providing both 11274 -- pragmas Interface and Interface_Name to obtain the effect 11275 -- of a single Import pragma. 11276 11277 if Is_Imported (Def_Id) 11278 and then Present (First_Rep_Item (Def_Id)) 11279 and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma 11280 and then 11281 Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface 11282 then 11283 null; 11284 else 11285 Set_Imported (Def_Id); 11286 end if; 11287 11288 Set_Is_Public (Def_Id); 11289 Process_Interface_Name (Def_Id, Arg2, Arg3); 11290 end if; 11291 11292 -- Otherwise must be subprogram 11293 11294 elsif not Is_Subprogram (Def_Id) then 11295 Error_Pragma_Arg 11296 ("argument of pragma% is not subprogram", Arg1); 11297 11298 else 11299 Check_At_Most_N_Arguments (3); 11300 Hom_Id := Def_Id; 11301 Found := False; 11302 11303 -- Loop through homonyms 11304 11305 loop 11306 Def_Id := Get_Base_Subprogram (Hom_Id); 11307 11308 if Is_Imported (Def_Id) then 11309 Process_Interface_Name (Def_Id, Arg2, Arg3); 11310 Found := True; 11311 end if; 11312 11313 exit when From_Aspect_Specification (N); 11314 Hom_Id := Homonym (Hom_Id); 11315 11316 exit when No (Hom_Id) 11317 or else Scope (Hom_Id) /= Current_Scope; 11318 end loop; 11319 11320 if not Found then 11321 Error_Pragma_Arg 11322 ("argument of pragma% is not imported subprogram", 11323 Arg1); 11324 end if; 11325 end if; 11326 end Interface_Name; 11327 11328 ----------------------- 11329 -- Interrupt_Handler -- 11330 ----------------------- 11331 11332 -- pragma Interrupt_Handler (handler_NAME); 11333 11334 when Pragma_Interrupt_Handler => 11335 Check_Ada_83_Warning; 11336 Check_Arg_Count (1); 11337 Check_No_Identifiers; 11338 11339 if No_Run_Time_Mode then 11340 Error_Msg_CRT ("Interrupt_Handler pragma", N); 11341 else 11342 Check_Interrupt_Or_Attach_Handler; 11343 Process_Interrupt_Or_Attach_Handler; 11344 end if; 11345 11346 ------------------------ 11347 -- Interrupt_Priority -- 11348 ------------------------ 11349 11350 -- pragma Interrupt_Priority [(EXPRESSION)]; 11351 11352 when Pragma_Interrupt_Priority => Interrupt_Priority : declare 11353 P : constant Node_Id := Parent (N); 11354 Arg : Node_Id; 11355 Ent : Entity_Id; 11356 11357 begin 11358 Check_Ada_83_Warning; 11359 11360 if Arg_Count /= 0 then 11361 Arg := Get_Pragma_Arg (Arg1); 11362 Check_Arg_Count (1); 11363 Check_No_Identifiers; 11364 11365 -- The expression must be analyzed in the special manner 11366 -- described in "Handling of Default and Per-Object 11367 -- Expressions" in sem.ads. 11368 11369 Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority)); 11370 end if; 11371 11372 if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then 11373 Pragma_Misplaced; 11374 return; 11375 11376 else 11377 Ent := Defining_Identifier (Parent (P)); 11378 11379 -- Check duplicate pragma before we chain the pragma in the Rep 11380 -- Item chain of Ent. 11381 11382 Check_Duplicate_Pragma (Ent); 11383 Record_Rep_Item (Ent, N); 11384 end if; 11385 end Interrupt_Priority; 11386 11387 --------------------- 11388 -- Interrupt_State -- 11389 --------------------- 11390 11391 -- pragma Interrupt_State ( 11392 -- [Name =>] INTERRUPT_ID, 11393 -- [State =>] INTERRUPT_STATE); 11394 11395 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION 11396 -- INTERRUPT_STATE => System | Runtime | User 11397 11398 -- Note: if the interrupt id is given as an identifier, then it must 11399 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is 11400 -- given as a static integer expression which must be in the range of 11401 -- Ada.Interrupts.Interrupt_ID. 11402 11403 when Pragma_Interrupt_State => Interrupt_State : declare 11404 11405 Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); 11406 -- This is the entity Ada.Interrupts.Interrupt_ID; 11407 11408 State_Type : Character; 11409 -- Set to 's'/'r'/'u' for System/Runtime/User 11410 11411 IST_Num : Pos; 11412 -- Index to entry in Interrupt_States table 11413 11414 Int_Val : Uint; 11415 -- Value of interrupt 11416 11417 Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); 11418 -- The first argument to the pragma 11419 11420 Int_Ent : Entity_Id; 11421 -- Interrupt entity in Ada.Interrupts.Names 11422 11423 begin 11424 GNAT_Pragma; 11425 Check_Arg_Order ((Name_Name, Name_State)); 11426 Check_Arg_Count (2); 11427 11428 Check_Optional_Identifier (Arg1, Name_Name); 11429 Check_Optional_Identifier (Arg2, Name_State); 11430 Check_Arg_Is_Identifier (Arg2); 11431 11432 -- First argument is identifier 11433 11434 if Nkind (Arg1X) = N_Identifier then 11435 11436 -- Search list of names in Ada.Interrupts.Names 11437 11438 Int_Ent := First_Entity (RTE (RE_Names)); 11439 loop 11440 if No (Int_Ent) then 11441 Error_Pragma_Arg ("invalid interrupt name", Arg1); 11442 11443 elsif Chars (Int_Ent) = Chars (Arg1X) then 11444 Int_Val := Expr_Value (Constant_Value (Int_Ent)); 11445 exit; 11446 end if; 11447 11448 Next_Entity (Int_Ent); 11449 end loop; 11450 11451 -- First argument is not an identifier, so it must be a static 11452 -- expression of type Ada.Interrupts.Interrupt_ID. 11453 11454 else 11455 Check_Arg_Is_Static_Expression (Arg1, Any_Integer); 11456 Int_Val := Expr_Value (Arg1X); 11457 11458 if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) 11459 or else 11460 Int_Val > Expr_Value (Type_High_Bound (Int_Id)) 11461 then 11462 Error_Pragma_Arg 11463 ("value not in range of type " & 11464 """Ada.Interrupts.Interrupt_'I'D""", Arg1); 11465 end if; 11466 end if; 11467 11468 -- Check OK state 11469 11470 case Chars (Get_Pragma_Arg (Arg2)) is 11471 when Name_Runtime => State_Type := 'r'; 11472 when Name_System => State_Type := 's'; 11473 when Name_User => State_Type := 'u'; 11474 11475 when others => 11476 Error_Pragma_Arg ("invalid interrupt state", Arg2); 11477 end case; 11478 11479 -- Check if entry is already stored 11480 11481 IST_Num := Interrupt_States.First; 11482 loop 11483 -- If entry not found, add it 11484 11485 if IST_Num > Interrupt_States.Last then 11486 Interrupt_States.Append 11487 ((Interrupt_Number => UI_To_Int (Int_Val), 11488 Interrupt_State => State_Type, 11489 Pragma_Loc => Loc)); 11490 exit; 11491 11492 -- Case of entry for the same entry 11493 11494 elsif Int_Val = Interrupt_States.Table (IST_Num). 11495 Interrupt_Number 11496 then 11497 -- If state matches, done, no need to make redundant entry 11498 11499 exit when 11500 State_Type = Interrupt_States.Table (IST_Num). 11501 Interrupt_State; 11502 11503 -- Otherwise if state does not match, error 11504 11505 Error_Msg_Sloc := 11506 Interrupt_States.Table (IST_Num).Pragma_Loc; 11507 Error_Pragma_Arg 11508 ("state conflicts with that given #", Arg2); 11509 exit; 11510 end if; 11511 11512 IST_Num := IST_Num + 1; 11513 end loop; 11514 end Interrupt_State; 11515 11516 --------------- 11517 -- Invariant -- 11518 --------------- 11519 11520 -- pragma Invariant 11521 -- ([Entity =>] type_LOCAL_NAME, 11522 -- [Check =>] EXPRESSION 11523 -- [,[Message =>] String_Expression]); 11524 11525 when Pragma_Invariant => Invariant : declare 11526 Type_Id : Node_Id; 11527 Typ : Entity_Id; 11528 PDecl : Node_Id; 11529 11530 Discard : Boolean; 11531 pragma Unreferenced (Discard); 11532 11533 begin 11534 GNAT_Pragma; 11535 Check_At_Least_N_Arguments (2); 11536 Check_At_Most_N_Arguments (3); 11537 Check_Optional_Identifier (Arg1, Name_Entity); 11538 Check_Optional_Identifier (Arg2, Name_Check); 11539 11540 if Arg_Count = 3 then 11541 Check_Optional_Identifier (Arg3, Name_Message); 11542 Check_Arg_Is_Static_Expression (Arg3, Standard_String); 11543 end if; 11544 11545 Check_Arg_Is_Local_Name (Arg1); 11546 11547 Type_Id := Get_Pragma_Arg (Arg1); 11548 Find_Type (Type_Id); 11549 Typ := Entity (Type_Id); 11550 11551 if Typ = Any_Type then 11552 return; 11553 11554 -- An invariant must apply to a private type, or appear in the 11555 -- private part of a package spec and apply to a completion. 11556 11557 elsif Ekind_In (Typ, E_Private_Type, 11558 E_Record_Type_With_Private, 11559 E_Limited_Private_Type) 11560 then 11561 null; 11562 11563 elsif In_Private_Part (Current_Scope) 11564 and then Has_Private_Declaration (Typ) 11565 then 11566 null; 11567 11568 elsif In_Private_Part (Current_Scope) then 11569 Error_Pragma_Arg 11570 ("pragma% only allowed for private type " & 11571 "declared in visible part", Arg1); 11572 11573 else 11574 Error_Pragma_Arg 11575 ("pragma% only allowed for private type", Arg1); 11576 end if; 11577 11578 -- Note that the type has at least one invariant, and also that 11579 -- it has inheritable invariants if we have Invariant'Class. 11580 -- Build the corresponding invariant procedure declaration, so 11581 -- that calls to it can be generated before the body is built 11582 -- (for example wihin an expression function). 11583 11584 PDecl := Build_Invariant_Procedure_Declaration (Typ); 11585 Insert_After (N, PDecl); 11586 Analyze (PDecl); 11587 11588 if Class_Present (N) then 11589 Set_Has_Inheritable_Invariants (Typ); 11590 end if; 11591 11592 -- The remaining processing is simply to link the pragma on to 11593 -- the rep item chain, for processing when the type is frozen. 11594 -- This is accomplished by a call to Rep_Item_Too_Late. 11595 11596 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 11597 end Invariant; 11598 11599 ---------------------- 11600 -- Java_Constructor -- 11601 ---------------------- 11602 11603 -- pragma Java_Constructor ([Entity =>] LOCAL_NAME); 11604 11605 -- Also handles pragma CIL_Constructor 11606 11607 when Pragma_CIL_Constructor | Pragma_Java_Constructor => 11608 Java_Constructor : declare 11609 Convention : Convention_Id; 11610 Def_Id : Entity_Id; 11611 Hom_Id : Entity_Id; 11612 Id : Entity_Id; 11613 This_Formal : Entity_Id; 11614 11615 begin 11616 GNAT_Pragma; 11617 Check_Arg_Count (1); 11618 Check_Optional_Identifier (Arg1, Name_Entity); 11619 Check_Arg_Is_Local_Name (Arg1); 11620 11621 Id := Get_Pragma_Arg (Arg1); 11622 Find_Program_Unit_Name (Id); 11623 11624 -- If we did not find the name, we are done 11625 11626 if Etype (Id) = Any_Type then 11627 return; 11628 end if; 11629 11630 -- Check wrong use of pragma in wrong VM target 11631 11632 if VM_Target = No_VM then 11633 return; 11634 11635 elsif VM_Target = CLI_Target 11636 and then Prag_Id = Pragma_Java_Constructor 11637 then 11638 Error_Pragma ("must use pragma 'C'I'L_'Constructor"); 11639 11640 elsif VM_Target = JVM_Target 11641 and then Prag_Id = Pragma_CIL_Constructor 11642 then 11643 Error_Pragma ("must use pragma 'Java_'Constructor"); 11644 end if; 11645 11646 case Prag_Id is 11647 when Pragma_CIL_Constructor => Convention := Convention_CIL; 11648 when Pragma_Java_Constructor => Convention := Convention_Java; 11649 when others => null; 11650 end case; 11651 11652 Hom_Id := Entity (Id); 11653 11654 -- Loop through homonyms 11655 11656 loop 11657 Def_Id := Get_Base_Subprogram (Hom_Id); 11658 11659 -- The constructor is required to be a function 11660 11661 if Ekind (Def_Id) /= E_Function then 11662 if VM_Target = JVM_Target then 11663 Error_Pragma_Arg 11664 ("pragma% requires function returning a " & 11665 "'Java access type", Def_Id); 11666 else 11667 Error_Pragma_Arg 11668 ("pragma% requires function returning a " & 11669 "'C'I'L access type", Def_Id); 11670 end if; 11671 end if; 11672 11673 -- Check arguments: For tagged type the first formal must be 11674 -- named "this" and its type must be a named access type 11675 -- designating a class-wide tagged type that has convention 11676 -- CIL/Java. The first formal must also have a null default 11677 -- value. For example: 11678 11679 -- type Typ is tagged ... 11680 -- type Ref is access all Typ; 11681 -- pragma Convention (CIL, Typ); 11682 11683 -- function New_Typ (This : Ref) return Ref; 11684 -- function New_Typ (This : Ref; I : Integer) return Ref; 11685 -- pragma Cil_Constructor (New_Typ); 11686 11687 -- Reason: The first formal must NOT be a primitive of the 11688 -- tagged type. 11689 11690 -- This rule also applies to constructors of delegates used 11691 -- to interface with standard target libraries. For example: 11692 11693 -- type Delegate is access procedure ... 11694 -- pragma Import (CIL, Delegate, ...); 11695 11696 -- function new_Delegate 11697 -- (This : Delegate := null; ... ) return Delegate; 11698 11699 -- For value-types this rule does not apply. 11700 11701 if not Is_Value_Type (Etype (Def_Id)) then 11702 if No (First_Formal (Def_Id)) then 11703 Error_Msg_Name_1 := Pname; 11704 Error_Msg_N ("% function must have parameters", Def_Id); 11705 return; 11706 end if; 11707 11708 -- In the JRE library we have several occurrences in which 11709 -- the "this" parameter is not the first formal. 11710 11711 This_Formal := First_Formal (Def_Id); 11712 11713 -- In the JRE library we have several occurrences in which 11714 -- the "this" parameter is not the first formal. Search for 11715 -- it. 11716 11717 if VM_Target = JVM_Target then 11718 while Present (This_Formal) 11719 and then Get_Name_String (Chars (This_Formal)) /= "this" 11720 loop 11721 Next_Formal (This_Formal); 11722 end loop; 11723 11724 if No (This_Formal) then 11725 This_Formal := First_Formal (Def_Id); 11726 end if; 11727 end if; 11728 11729 -- Warning: The first parameter should be named "this". 11730 -- We temporarily allow it because we have the following 11731 -- case in the Java runtime (file s-osinte.ads) ??? 11732 11733 -- function new_Thread 11734 -- (Self_Id : System.Address) return Thread_Id; 11735 -- pragma Java_Constructor (new_Thread); 11736 11737 if VM_Target = JVM_Target 11738 and then Get_Name_String (Chars (First_Formal (Def_Id))) 11739 = "self_id" 11740 and then Etype (First_Formal (Def_Id)) = RTE (RE_Address) 11741 then 11742 null; 11743 11744 elsif Get_Name_String (Chars (This_Formal)) /= "this" then 11745 Error_Msg_Name_1 := Pname; 11746 Error_Msg_N 11747 ("first formal of % function must be named `this`", 11748 Parent (This_Formal)); 11749 11750 elsif not Is_Access_Type (Etype (This_Formal)) then 11751 Error_Msg_Name_1 := Pname; 11752 Error_Msg_N 11753 ("first formal of % function must be an access type", 11754 Parameter_Type (Parent (This_Formal))); 11755 11756 -- For delegates the type of the first formal must be a 11757 -- named access-to-subprogram type (see previous example) 11758 11759 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type 11760 and then Ekind (Etype (This_Formal)) 11761 /= E_Access_Subprogram_Type 11762 then 11763 Error_Msg_Name_1 := Pname; 11764 Error_Msg_N 11765 ("first formal of % function must be a named access" & 11766 " to subprogram type", 11767 Parameter_Type (Parent (This_Formal))); 11768 11769 -- Warning: We should reject anonymous access types because 11770 -- the constructor must not be handled as a primitive of the 11771 -- tagged type. We temporarily allow it because this profile 11772 -- is currently generated by cil2ada??? 11773 11774 elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type 11775 and then not Ekind_In (Etype (This_Formal), 11776 E_Access_Type, 11777 E_General_Access_Type, 11778 E_Anonymous_Access_Type) 11779 then 11780 Error_Msg_Name_1 := Pname; 11781 Error_Msg_N 11782 ("first formal of % function must be a named access" & 11783 " type", 11784 Parameter_Type (Parent (This_Formal))); 11785 11786 elsif Atree.Convention 11787 (Designated_Type (Etype (This_Formal))) /= Convention 11788 then 11789 Error_Msg_Name_1 := Pname; 11790 11791 if Convention = Convention_Java then 11792 Error_Msg_N 11793 ("pragma% requires convention 'Cil in designated" & 11794 " type", 11795 Parameter_Type (Parent (This_Formal))); 11796 else 11797 Error_Msg_N 11798 ("pragma% requires convention 'Java in designated" & 11799 " type", 11800 Parameter_Type (Parent (This_Formal))); 11801 end if; 11802 11803 elsif No (Expression (Parent (This_Formal))) 11804 or else Nkind (Expression (Parent (This_Formal))) /= N_Null 11805 then 11806 Error_Msg_Name_1 := Pname; 11807 Error_Msg_N 11808 ("pragma% requires first formal with default `null`", 11809 Parameter_Type (Parent (This_Formal))); 11810 end if; 11811 end if; 11812 11813 -- Check result type: the constructor must be a function 11814 -- returning: 11815 -- * a value type (only allowed in the CIL compiler) 11816 -- * an access-to-subprogram type with convention Java/CIL 11817 -- * an access-type designating a type that has convention 11818 -- Java/CIL. 11819 11820 if Is_Value_Type (Etype (Def_Id)) then 11821 null; 11822 11823 -- Access-to-subprogram type with convention Java/CIL 11824 11825 elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then 11826 if Atree.Convention (Etype (Def_Id)) /= Convention then 11827 if Convention = Convention_Java then 11828 Error_Pragma_Arg 11829 ("pragma% requires function returning a " & 11830 "'Java access type", Arg1); 11831 else 11832 pragma Assert (Convention = Convention_CIL); 11833 Error_Pragma_Arg 11834 ("pragma% requires function returning a " & 11835 "'C'I'L access type", Arg1); 11836 end if; 11837 end if; 11838 11839 elsif Ekind (Etype (Def_Id)) in Access_Kind then 11840 if not Ekind_In (Etype (Def_Id), E_Access_Type, 11841 E_General_Access_Type) 11842 or else 11843 Atree.Convention 11844 (Designated_Type (Etype (Def_Id))) /= Convention 11845 then 11846 Error_Msg_Name_1 := Pname; 11847 11848 if Convention = Convention_Java then 11849 Error_Pragma_Arg 11850 ("pragma% requires function returning a named" & 11851 "'Java access type", Arg1); 11852 else 11853 Error_Pragma_Arg 11854 ("pragma% requires function returning a named" & 11855 "'C'I'L access type", Arg1); 11856 end if; 11857 end if; 11858 end if; 11859 11860 Set_Is_Constructor (Def_Id); 11861 Set_Convention (Def_Id, Convention); 11862 Set_Is_Imported (Def_Id); 11863 11864 exit when From_Aspect_Specification (N); 11865 Hom_Id := Homonym (Hom_Id); 11866 11867 exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope; 11868 end loop; 11869 end Java_Constructor; 11870 11871 ---------------------- 11872 -- Java_Interface -- 11873 ---------------------- 11874 11875 -- pragma Java_Interface ([Entity =>] LOCAL_NAME); 11876 11877 when Pragma_Java_Interface => Java_Interface : declare 11878 Arg : Node_Id; 11879 Typ : Entity_Id; 11880 11881 begin 11882 GNAT_Pragma; 11883 Check_Arg_Count (1); 11884 Check_Optional_Identifier (Arg1, Name_Entity); 11885 Check_Arg_Is_Local_Name (Arg1); 11886 11887 Arg := Get_Pragma_Arg (Arg1); 11888 Analyze (Arg); 11889 11890 if Etype (Arg) = Any_Type then 11891 return; 11892 end if; 11893 11894 if not Is_Entity_Name (Arg) 11895 or else not Is_Type (Entity (Arg)) 11896 then 11897 Error_Pragma_Arg ("pragma% requires a type mark", Arg1); 11898 end if; 11899 11900 Typ := Underlying_Type (Entity (Arg)); 11901 11902 -- For now simply check some of the semantic constraints on the 11903 -- type. This currently leaves out some restrictions on interface 11904 -- types, namely that the parent type must be java.lang.Object.Typ 11905 -- and that all primitives of the type should be declared 11906 -- abstract. ??? 11907 11908 if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then 11909 Error_Pragma_Arg ("pragma% requires an abstract " 11910 & "tagged type", Arg1); 11911 11912 elsif not Has_Discriminants (Typ) 11913 or else Ekind (Etype (First_Discriminant (Typ))) 11914 /= E_Anonymous_Access_Type 11915 or else 11916 not Is_Class_Wide_Type 11917 (Designated_Type (Etype (First_Discriminant (Typ)))) 11918 then 11919 Error_Pragma_Arg 11920 ("type must have a class-wide access discriminant", Arg1); 11921 end if; 11922 end Java_Interface; 11923 11924 ---------------- 11925 -- Keep_Names -- 11926 ---------------- 11927 11928 -- pragma Keep_Names ([On => ] local_NAME); 11929 11930 when Pragma_Keep_Names => Keep_Names : declare 11931 Arg : Node_Id; 11932 11933 begin 11934 GNAT_Pragma; 11935 Check_Arg_Count (1); 11936 Check_Optional_Identifier (Arg1, Name_On); 11937 Check_Arg_Is_Local_Name (Arg1); 11938 11939 Arg := Get_Pragma_Arg (Arg1); 11940 Analyze (Arg); 11941 11942 if Etype (Arg) = Any_Type then 11943 return; 11944 end if; 11945 11946 if not Is_Entity_Name (Arg) 11947 or else Ekind (Entity (Arg)) /= E_Enumeration_Type 11948 then 11949 Error_Pragma_Arg 11950 ("pragma% requires a local enumeration type", Arg1); 11951 end if; 11952 11953 Set_Discard_Names (Entity (Arg), False); 11954 end Keep_Names; 11955 11956 ------------- 11957 -- License -- 11958 ------------- 11959 11960 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL); 11961 11962 when Pragma_License => 11963 GNAT_Pragma; 11964 Check_Arg_Count (1); 11965 Check_No_Identifiers; 11966 Check_Valid_Configuration_Pragma; 11967 Check_Arg_Is_Identifier (Arg1); 11968 11969 declare 11970 Sind : constant Source_File_Index := 11971 Source_Index (Current_Sem_Unit); 11972 11973 begin 11974 case Chars (Get_Pragma_Arg (Arg1)) is 11975 when Name_GPL => 11976 Set_License (Sind, GPL); 11977 11978 when Name_Modified_GPL => 11979 Set_License (Sind, Modified_GPL); 11980 11981 when Name_Restricted => 11982 Set_License (Sind, Restricted); 11983 11984 when Name_Unrestricted => 11985 Set_License (Sind, Unrestricted); 11986 11987 when others => 11988 Error_Pragma_Arg ("invalid license name", Arg1); 11989 end case; 11990 end; 11991 11992 --------------- 11993 -- Link_With -- 11994 --------------- 11995 11996 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION}); 11997 11998 when Pragma_Link_With => Link_With : declare 11999 Arg : Node_Id; 12000 12001 begin 12002 GNAT_Pragma; 12003 12004 if Operating_Mode = Generate_Code 12005 and then In_Extended_Main_Source_Unit (N) 12006 then 12007 Check_At_Least_N_Arguments (1); 12008 Check_No_Identifiers; 12009 Check_Is_In_Decl_Part_Or_Package_Spec; 12010 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 12011 Start_String; 12012 12013 Arg := Arg1; 12014 while Present (Arg) loop 12015 Check_Arg_Is_Static_Expression (Arg, Standard_String); 12016 12017 -- Store argument, converting sequences of spaces to a 12018 -- single null character (this is one of the differences 12019 -- in processing between Link_With and Linker_Options). 12020 12021 Arg_Store : declare 12022 C : constant Char_Code := Get_Char_Code (' '); 12023 S : constant String_Id := 12024 Strval (Expr_Value_S (Get_Pragma_Arg (Arg))); 12025 L : constant Nat := String_Length (S); 12026 F : Nat := 1; 12027 12028 procedure Skip_Spaces; 12029 -- Advance F past any spaces 12030 12031 ----------------- 12032 -- Skip_Spaces -- 12033 ----------------- 12034 12035 procedure Skip_Spaces is 12036 begin 12037 while F <= L and then Get_String_Char (S, F) = C loop 12038 F := F + 1; 12039 end loop; 12040 end Skip_Spaces; 12041 12042 -- Start of processing for Arg_Store 12043 12044 begin 12045 Skip_Spaces; -- skip leading spaces 12046 12047 -- Loop through characters, changing any embedded 12048 -- sequence of spaces to a single null character (this 12049 -- is how Link_With/Linker_Options differ) 12050 12051 while F <= L loop 12052 if Get_String_Char (S, F) = C then 12053 Skip_Spaces; 12054 exit when F > L; 12055 Store_String_Char (ASCII.NUL); 12056 12057 else 12058 Store_String_Char (Get_String_Char (S, F)); 12059 F := F + 1; 12060 end if; 12061 end loop; 12062 end Arg_Store; 12063 12064 Arg := Next (Arg); 12065 12066 if Present (Arg) then 12067 Store_String_Char (ASCII.NUL); 12068 end if; 12069 end loop; 12070 12071 Store_Linker_Option_String (End_String); 12072 end if; 12073 end Link_With; 12074 12075 ------------------ 12076 -- Linker_Alias -- 12077 ------------------ 12078 12079 -- pragma Linker_Alias ( 12080 -- [Entity =>] LOCAL_NAME 12081 -- [Target =>] static_string_EXPRESSION); 12082 12083 when Pragma_Linker_Alias => 12084 GNAT_Pragma; 12085 Check_Arg_Order ((Name_Entity, Name_Target)); 12086 Check_Arg_Count (2); 12087 Check_Optional_Identifier (Arg1, Name_Entity); 12088 Check_Optional_Identifier (Arg2, Name_Target); 12089 Check_Arg_Is_Library_Level_Local_Name (Arg1); 12090 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 12091 12092 -- The only processing required is to link this item on to the 12093 -- list of rep items for the given entity. This is accomplished 12094 -- by the call to Rep_Item_Too_Late (when no error is detected 12095 -- and False is returned). 12096 12097 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then 12098 return; 12099 else 12100 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 12101 end if; 12102 12103 ------------------------ 12104 -- Linker_Constructor -- 12105 ------------------------ 12106 12107 -- pragma Linker_Constructor (procedure_LOCAL_NAME); 12108 12109 -- Code is shared with Linker_Destructor 12110 12111 ----------------------- 12112 -- Linker_Destructor -- 12113 ----------------------- 12114 12115 -- pragma Linker_Destructor (procedure_LOCAL_NAME); 12116 12117 when Pragma_Linker_Constructor | 12118 Pragma_Linker_Destructor => 12119 Linker_Constructor : declare 12120 Arg1_X : Node_Id; 12121 Proc : Entity_Id; 12122 12123 begin 12124 GNAT_Pragma; 12125 Check_Arg_Count (1); 12126 Check_No_Identifiers; 12127 Check_Arg_Is_Local_Name (Arg1); 12128 Arg1_X := Get_Pragma_Arg (Arg1); 12129 Analyze (Arg1_X); 12130 Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); 12131 12132 if not Is_Library_Level_Entity (Proc) then 12133 Error_Pragma_Arg 12134 ("argument for pragma% must be library level entity", Arg1); 12135 end if; 12136 12137 -- The only processing required is to link this item on to the 12138 -- list of rep items for the given entity. This is accomplished 12139 -- by the call to Rep_Item_Too_Late (when no error is detected 12140 -- and False is returned). 12141 12142 if Rep_Item_Too_Late (Proc, N) then 12143 return; 12144 else 12145 Set_Has_Gigi_Rep_Item (Proc); 12146 end if; 12147 end Linker_Constructor; 12148 12149 -------------------- 12150 -- Linker_Options -- 12151 -------------------- 12152 12153 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION}); 12154 12155 when Pragma_Linker_Options => Linker_Options : declare 12156 Arg : Node_Id; 12157 12158 begin 12159 Check_Ada_83_Warning; 12160 Check_No_Identifiers; 12161 Check_Arg_Count (1); 12162 Check_Is_In_Decl_Part_Or_Package_Spec; 12163 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 12164 Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); 12165 12166 Arg := Arg2; 12167 while Present (Arg) loop 12168 Check_Arg_Is_Static_Expression (Arg, Standard_String); 12169 Store_String_Char (ASCII.NUL); 12170 Store_String_Chars 12171 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); 12172 Arg := Next (Arg); 12173 end loop; 12174 12175 if Operating_Mode = Generate_Code 12176 and then In_Extended_Main_Source_Unit (N) 12177 then 12178 Store_Linker_Option_String (End_String); 12179 end if; 12180 end Linker_Options; 12181 12182 -------------------- 12183 -- Linker_Section -- 12184 -------------------- 12185 12186 -- pragma Linker_Section ( 12187 -- [Entity =>] LOCAL_NAME 12188 -- [Section =>] static_string_EXPRESSION); 12189 12190 when Pragma_Linker_Section => 12191 GNAT_Pragma; 12192 Check_Arg_Order ((Name_Entity, Name_Section)); 12193 Check_Arg_Count (2); 12194 Check_Optional_Identifier (Arg1, Name_Entity); 12195 Check_Optional_Identifier (Arg2, Name_Section); 12196 Check_Arg_Is_Library_Level_Local_Name (Arg1); 12197 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 12198 12199 -- This pragma applies only to objects 12200 12201 if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then 12202 Error_Pragma_Arg ("pragma% applies only to objects", Arg1); 12203 end if; 12204 12205 -- The only processing required is to link this item on to the 12206 -- list of rep items for the given entity. This is accomplished 12207 -- by the call to Rep_Item_Too_Late (when no error is detected 12208 -- and False is returned). 12209 12210 if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then 12211 return; 12212 else 12213 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 12214 end if; 12215 12216 ---------- 12217 -- List -- 12218 ---------- 12219 12220 -- pragma List (On | Off) 12221 12222 -- There is nothing to do here, since we did all the processing for 12223 -- this pragma in Par.Prag (so that it works properly even in syntax 12224 -- only mode). 12225 12226 when Pragma_List => 12227 null; 12228 12229 --------------- 12230 -- Lock_Free -- 12231 --------------- 12232 12233 -- pragma Lock_Free [(Boolean_EXPRESSION)]; 12234 12235 when Pragma_Lock_Free => Lock_Free : declare 12236 P : constant Node_Id := Parent (N); 12237 Arg : Node_Id; 12238 Ent : Entity_Id; 12239 Val : Boolean; 12240 12241 begin 12242 Check_No_Identifiers; 12243 Check_At_Most_N_Arguments (1); 12244 12245 -- Protected definition case 12246 12247 if Nkind (P) = N_Protected_Definition then 12248 Ent := Defining_Identifier (Parent (P)); 12249 12250 -- One argument 12251 12252 if Arg_Count = 1 then 12253 Arg := Get_Pragma_Arg (Arg1); 12254 Val := Is_True (Static_Boolean (Arg)); 12255 12256 -- No arguments (expression is considered to be True) 12257 12258 else 12259 Val := True; 12260 end if; 12261 12262 -- Check duplicate pragma before we chain the pragma in the Rep 12263 -- Item chain of Ent. 12264 12265 Check_Duplicate_Pragma (Ent); 12266 Record_Rep_Item (Ent, N); 12267 Set_Uses_Lock_Free (Ent, Val); 12268 12269 -- Anything else is incorrect placement 12270 12271 else 12272 Pragma_Misplaced; 12273 end if; 12274 end Lock_Free; 12275 12276 -------------------- 12277 -- Locking_Policy -- 12278 -------------------- 12279 12280 -- pragma Locking_Policy (policy_IDENTIFIER); 12281 12282 when Pragma_Locking_Policy => declare 12283 subtype LP_Range is Name_Id 12284 range First_Locking_Policy_Name .. Last_Locking_Policy_Name; 12285 LP_Val : LP_Range; 12286 LP : Character; 12287 12288 begin 12289 Check_Ada_83_Warning; 12290 Check_Arg_Count (1); 12291 Check_No_Identifiers; 12292 Check_Arg_Is_Locking_Policy (Arg1); 12293 Check_Valid_Configuration_Pragma; 12294 LP_Val := Chars (Get_Pragma_Arg (Arg1)); 12295 12296 case LP_Val is 12297 when Name_Ceiling_Locking => 12298 LP := 'C'; 12299 when Name_Inheritance_Locking => 12300 LP := 'I'; 12301 when Name_Concurrent_Readers_Locking => 12302 LP := 'R'; 12303 end case; 12304 12305 if Locking_Policy /= ' ' 12306 and then Locking_Policy /= LP 12307 then 12308 Error_Msg_Sloc := Locking_Policy_Sloc; 12309 Error_Pragma ("locking policy incompatible with policy#"); 12310 12311 -- Set new policy, but always preserve System_Location since we 12312 -- like the error message with the run time name. 12313 12314 else 12315 Locking_Policy := LP; 12316 12317 if Locking_Policy_Sloc /= System_Location then 12318 Locking_Policy_Sloc := Loc; 12319 end if; 12320 end if; 12321 end; 12322 12323 ---------------- 12324 -- Long_Float -- 12325 ---------------- 12326 12327 -- pragma Long_Float (D_Float | G_Float); 12328 12329 when Pragma_Long_Float => Long_Float : declare 12330 begin 12331 GNAT_Pragma; 12332 Check_Valid_Configuration_Pragma; 12333 Check_Arg_Count (1); 12334 Check_No_Identifier (Arg1); 12335 Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float); 12336 12337 if not OpenVMS_On_Target then 12338 Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)"); 12339 end if; 12340 12341 -- D_Float case 12342 12343 if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then 12344 if Opt.Float_Format_Long = 'G' then 12345 Error_Pragma_Arg 12346 ("G_Float previously specified", Arg1); 12347 12348 elsif Current_Sem_Unit /= Main_Unit 12349 and then Opt.Float_Format_Long /= 'D' 12350 then 12351 Error_Pragma_Arg 12352 ("main unit not compiled with pragma Long_Float (D_Float)", 12353 "\pragma% must be used consistently for whole partition", 12354 Arg1); 12355 12356 else 12357 Opt.Float_Format_Long := 'D'; 12358 end if; 12359 12360 -- G_Float case (this is the default, does not need overriding) 12361 12362 else 12363 if Opt.Float_Format_Long = 'D' then 12364 Error_Pragma ("D_Float previously specified"); 12365 12366 elsif Current_Sem_Unit /= Main_Unit 12367 and then Opt.Float_Format_Long /= 'G' 12368 then 12369 Error_Pragma_Arg 12370 ("main unit not compiled with pragma Long_Float (G_Float)", 12371 "\pragma% must be used consistently for whole partition", 12372 Arg1); 12373 12374 else 12375 Opt.Float_Format_Long := 'G'; 12376 end if; 12377 end if; 12378 12379 Set_Standard_Fpt_Formats; 12380 end Long_Float; 12381 12382 -------------------- 12383 -- Loop_Invariant -- 12384 -------------------- 12385 12386 -- pragma Loop_Invariant ( boolean_EXPRESSION ); 12387 12388 when Pragma_Loop_Invariant => Loop_Invariant : declare 12389 begin 12390 GNAT_Pragma; 12391 S14_Pragma; 12392 Check_Arg_Count (1); 12393 Check_Loop_Pragma_Placement; 12394 12395 -- Completely ignore if disabled 12396 12397 if Check_Disabled (Pname) then 12398 Rewrite (N, Make_Null_Statement (Loc)); 12399 Analyze (N); 12400 return; 12401 end if; 12402 12403 Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean); 12404 12405 -- Transform pragma Loop_Invariant into equivalent pragma Check 12406 -- Generate: 12407 -- pragma Check (Loop_Invaraint, Arg1); 12408 12409 -- Seems completely wrong to hijack pragma Check this way ??? 12410 12411 Rewrite (N, 12412 Make_Pragma (Loc, 12413 Chars => Name_Check, 12414 Pragma_Argument_Associations => New_List ( 12415 Make_Pragma_Argument_Association (Loc, 12416 Expression => Make_Identifier (Loc, Name_Loop_Invariant)), 12417 Relocate_Node (Arg1)))); 12418 12419 Analyze (N); 12420 end Loop_Invariant; 12421 12422 ------------------- 12423 -- Loop_Optimize -- 12424 ------------------- 12425 12426 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } ); 12427 12428 -- OPTIMIZATION_HINT ::= No_Unroll | Unroll | No_Vector | Vector 12429 12430 when Pragma_Loop_Optimize => Loop_Optimize : declare 12431 Hint : Node_Id; 12432 12433 begin 12434 GNAT_Pragma; 12435 Check_At_Least_N_Arguments (1); 12436 Check_No_Identifiers; 12437 Hint := First (Pragma_Argument_Associations (N)); 12438 while Present (Hint) loop 12439 Check_Arg_Is_One_Of (Hint, 12440 Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector); 12441 Next (Hint); 12442 end loop; 12443 Check_Loop_Pragma_Placement; 12444 end Loop_Optimize; 12445 12446 ------------------ 12447 -- Loop_Variant -- 12448 ------------------ 12449 12450 -- pragma Loop_Variant 12451 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } ); 12452 12453 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION 12454 12455 -- CHANGE_DIRECTION ::= Increases | Decreases 12456 12457 when Pragma_Loop_Variant => Loop_Variant : declare 12458 Variant : Node_Id; 12459 12460 begin 12461 GNAT_Pragma; 12462 S14_Pragma; 12463 Check_At_Least_N_Arguments (1); 12464 Check_Loop_Pragma_Placement; 12465 12466 -- Completely ignore if disabled 12467 12468 if Check_Disabled (Pname) then 12469 Rewrite (N, Make_Null_Statement (Loc)); 12470 Analyze (N); 12471 return; 12472 end if; 12473 12474 -- Process all increasing / decreasing expressions 12475 12476 Variant := First (Pragma_Argument_Associations (N)); 12477 while Present (Variant) loop 12478 if Chars (Variant) /= Name_Decreases 12479 and then Chars (Variant) /= Name_Increases 12480 then 12481 Error_Pragma_Arg ("wrong change modifier", Variant); 12482 end if; 12483 12484 Preanalyze_And_Resolve (Expression (Variant), Any_Discrete); 12485 12486 Next (Variant); 12487 end loop; 12488 end Loop_Variant; 12489 12490 ----------------------- 12491 -- Machine_Attribute -- 12492 ----------------------- 12493 12494 -- pragma Machine_Attribute ( 12495 -- [Entity =>] LOCAL_NAME, 12496 -- [Attribute_Name =>] static_string_EXPRESSION 12497 -- [, [Info =>] static_EXPRESSION] ); 12498 12499 when Pragma_Machine_Attribute => Machine_Attribute : declare 12500 Def_Id : Entity_Id; 12501 12502 begin 12503 GNAT_Pragma; 12504 Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info)); 12505 12506 if Arg_Count = 3 then 12507 Check_Optional_Identifier (Arg3, Name_Info); 12508 Check_Arg_Is_Static_Expression (Arg3); 12509 else 12510 Check_Arg_Count (2); 12511 end if; 12512 12513 Check_Optional_Identifier (Arg1, Name_Entity); 12514 Check_Optional_Identifier (Arg2, Name_Attribute_Name); 12515 Check_Arg_Is_Local_Name (Arg1); 12516 Check_Arg_Is_Static_Expression (Arg2, Standard_String); 12517 Def_Id := Entity (Get_Pragma_Arg (Arg1)); 12518 12519 if Is_Access_Type (Def_Id) then 12520 Def_Id := Designated_Type (Def_Id); 12521 end if; 12522 12523 if Rep_Item_Too_Early (Def_Id, N) then 12524 return; 12525 end if; 12526 12527 Def_Id := Underlying_Type (Def_Id); 12528 12529 -- The only processing required is to link this item on to the 12530 -- list of rep items for the given entity. This is accomplished 12531 -- by the call to Rep_Item_Too_Late (when no error is detected 12532 -- and False is returned). 12533 12534 if Rep_Item_Too_Late (Def_Id, N) then 12535 return; 12536 else 12537 Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1))); 12538 end if; 12539 end Machine_Attribute; 12540 12541 ---------- 12542 -- Main -- 12543 ---------- 12544 12545 -- pragma Main 12546 -- (MAIN_OPTION [, MAIN_OPTION]); 12547 12548 -- MAIN_OPTION ::= 12549 -- [STACK_SIZE =>] static_integer_EXPRESSION 12550 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION 12551 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION 12552 12553 when Pragma_Main => Main : declare 12554 Args : Args_List (1 .. 3); 12555 Names : constant Name_List (1 .. 3) := ( 12556 Name_Stack_Size, 12557 Name_Task_Stack_Size_Default, 12558 Name_Time_Slicing_Enabled); 12559 12560 Nod : Node_Id; 12561 12562 begin 12563 GNAT_Pragma; 12564 Gather_Associations (Names, Args); 12565 12566 for J in 1 .. 2 loop 12567 if Present (Args (J)) then 12568 Check_Arg_Is_Static_Expression (Args (J), Any_Integer); 12569 end if; 12570 end loop; 12571 12572 if Present (Args (3)) then 12573 Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean); 12574 end if; 12575 12576 Nod := Next (N); 12577 while Present (Nod) loop 12578 if Nkind (Nod) = N_Pragma 12579 and then Pragma_Name (Nod) = Name_Main 12580 then 12581 Error_Msg_Name_1 := Pname; 12582 Error_Msg_N ("duplicate pragma% not permitted", Nod); 12583 end if; 12584 12585 Next (Nod); 12586 end loop; 12587 end Main; 12588 12589 ------------------ 12590 -- Main_Storage -- 12591 ------------------ 12592 12593 -- pragma Main_Storage 12594 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]); 12595 12596 -- MAIN_STORAGE_OPTION ::= 12597 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION 12598 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION 12599 12600 when Pragma_Main_Storage => Main_Storage : declare 12601 Args : Args_List (1 .. 2); 12602 Names : constant Name_List (1 .. 2) := ( 12603 Name_Working_Storage, 12604 Name_Top_Guard); 12605 12606 Nod : Node_Id; 12607 12608 begin 12609 GNAT_Pragma; 12610 Gather_Associations (Names, Args); 12611 12612 for J in 1 .. 2 loop 12613 if Present (Args (J)) then 12614 Check_Arg_Is_Static_Expression (Args (J), Any_Integer); 12615 end if; 12616 end loop; 12617 12618 Check_In_Main_Program; 12619 12620 Nod := Next (N); 12621 while Present (Nod) loop 12622 if Nkind (Nod) = N_Pragma 12623 and then Pragma_Name (Nod) = Name_Main_Storage 12624 then 12625 Error_Msg_Name_1 := Pname; 12626 Error_Msg_N ("duplicate pragma% not permitted", Nod); 12627 end if; 12628 12629 Next (Nod); 12630 end loop; 12631 end Main_Storage; 12632 12633 ----------------- 12634 -- Memory_Size -- 12635 ----------------- 12636 12637 -- pragma Memory_Size (NUMERIC_LITERAL) 12638 12639 when Pragma_Memory_Size => 12640 GNAT_Pragma; 12641 12642 -- Memory size is simply ignored 12643 12644 Check_No_Identifiers; 12645 Check_Arg_Count (1); 12646 Check_Arg_Is_Integer_Literal (Arg1); 12647 12648 ------------- 12649 -- No_Body -- 12650 ------------- 12651 12652 -- pragma No_Body; 12653 12654 -- The only correct use of this pragma is on its own in a file, in 12655 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body 12656 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to 12657 -- check for a file containing nothing but a No_Body pragma). If we 12658 -- attempt to process it during normal semantics processing, it means 12659 -- it was misplaced. 12660 12661 when Pragma_No_Body => 12662 GNAT_Pragma; 12663 Pragma_Misplaced; 12664 12665 --------------- 12666 -- No_Inline -- 12667 --------------- 12668 12669 -- pragma No_Inline ( NAME {, NAME} ); 12670 12671 when Pragma_No_Inline => 12672 GNAT_Pragma; 12673 Process_Inline (Suppressed); 12674 12675 --------------- 12676 -- No_Return -- 12677 --------------- 12678 12679 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name}); 12680 12681 when Pragma_No_Return => No_Return : declare 12682 Id : Node_Id; 12683 E : Entity_Id; 12684 Found : Boolean; 12685 Arg : Node_Id; 12686 12687 begin 12688 Ada_2005_Pragma; 12689 Check_At_Least_N_Arguments (1); 12690 12691 -- Loop through arguments of pragma 12692 12693 Arg := Arg1; 12694 while Present (Arg) loop 12695 Check_Arg_Is_Local_Name (Arg); 12696 Id := Get_Pragma_Arg (Arg); 12697 Analyze (Id); 12698 12699 if not Is_Entity_Name (Id) then 12700 Error_Pragma_Arg ("entity name required", Arg); 12701 end if; 12702 12703 if Etype (Id) = Any_Type then 12704 raise Pragma_Exit; 12705 end if; 12706 12707 -- Loop to find matching procedures 12708 12709 E := Entity (Id); 12710 Found := False; 12711 while Present (E) 12712 and then Scope (E) = Current_Scope 12713 loop 12714 if Ekind_In (E, E_Procedure, E_Generic_Procedure) then 12715 Set_No_Return (E); 12716 12717 -- Set flag on any alias as well 12718 12719 if Is_Overloadable (E) and then Present (Alias (E)) then 12720 Set_No_Return (Alias (E)); 12721 end if; 12722 12723 Found := True; 12724 end if; 12725 12726 exit when From_Aspect_Specification (N); 12727 E := Homonym (E); 12728 end loop; 12729 12730 if not Found then 12731 Error_Pragma_Arg ("no procedure & found for pragma%", Arg); 12732 end if; 12733 12734 Next (Arg); 12735 end loop; 12736 end No_Return; 12737 12738 ----------------- 12739 -- No_Run_Time -- 12740 ----------------- 12741 12742 -- pragma No_Run_Time; 12743 12744 -- Note: this pragma is retained for backwards compatibility. See 12745 -- body of Rtsfind for full details on its handling. 12746 12747 when Pragma_No_Run_Time => 12748 GNAT_Pragma; 12749 Check_Valid_Configuration_Pragma; 12750 Check_Arg_Count (0); 12751 12752 No_Run_Time_Mode := True; 12753 Configurable_Run_Time_Mode := True; 12754 12755 -- Set Duration to 32 bits if word size is 32 12756 12757 if Ttypes.System_Word_Size = 32 then 12758 Duration_32_Bits_On_Target := True; 12759 end if; 12760 12761 -- Set appropriate restrictions 12762 12763 Set_Restriction (No_Finalization, N); 12764 Set_Restriction (No_Exception_Handlers, N); 12765 Set_Restriction (Max_Tasks, N, 0); 12766 Set_Restriction (No_Tasking, N); 12767 12768 ------------------------ 12769 -- No_Strict_Aliasing -- 12770 ------------------------ 12771 12772 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)]; 12773 12774 when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare 12775 E_Id : Entity_Id; 12776 12777 begin 12778 GNAT_Pragma; 12779 Check_At_Most_N_Arguments (1); 12780 12781 if Arg_Count = 0 then 12782 Check_Valid_Configuration_Pragma; 12783 Opt.No_Strict_Aliasing := True; 12784 12785 else 12786 Check_Optional_Identifier (Arg2, Name_Entity); 12787 Check_Arg_Is_Local_Name (Arg1); 12788 E_Id := Entity (Get_Pragma_Arg (Arg1)); 12789 12790 if E_Id = Any_Type then 12791 return; 12792 elsif No (E_Id) or else not Is_Access_Type (E_Id) then 12793 Error_Pragma_Arg ("pragma% requires access type", Arg1); 12794 end if; 12795 12796 Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id)); 12797 end if; 12798 end No_Strict_Aliasing; 12799 12800 ----------------------- 12801 -- Normalize_Scalars -- 12802 ----------------------- 12803 12804 -- pragma Normalize_Scalars; 12805 12806 when Pragma_Normalize_Scalars => 12807 Check_Ada_83_Warning; 12808 Check_Arg_Count (0); 12809 Check_Valid_Configuration_Pragma; 12810 12811 -- Normalize_Scalars creates false positives in CodePeer, and 12812 -- incorrect negative results in Alfa mode, so ignore this pragma 12813 -- in these modes. 12814 12815 if not (CodePeer_Mode or Alfa_Mode) then 12816 Normalize_Scalars := True; 12817 Init_Or_Norm_Scalars := True; 12818 end if; 12819 12820 ----------------- 12821 -- Obsolescent -- 12822 ----------------- 12823 12824 -- pragma Obsolescent; 12825 12826 -- pragma Obsolescent ( 12827 -- [Message =>] static_string_EXPRESSION 12828 -- [,[Version =>] Ada_05]]); 12829 12830 -- pragma Obsolescent ( 12831 -- [Entity =>] NAME 12832 -- [,[Message =>] static_string_EXPRESSION 12833 -- [,[Version =>] Ada_05]] ); 12834 12835 when Pragma_Obsolescent => Obsolescent : declare 12836 Ename : Node_Id; 12837 Decl : Node_Id; 12838 12839 procedure Set_Obsolescent (E : Entity_Id); 12840 -- Given an entity Ent, mark it as obsolescent if appropriate 12841 12842 --------------------- 12843 -- Set_Obsolescent -- 12844 --------------------- 12845 12846 procedure Set_Obsolescent (E : Entity_Id) is 12847 Active : Boolean; 12848 Ent : Entity_Id; 12849 S : String_Id; 12850 12851 begin 12852 Active := True; 12853 Ent := E; 12854 12855 -- Entity name was given 12856 12857 if Present (Ename) then 12858 12859 -- If entity name matches, we are fine. Save entity in 12860 -- pragma argument, for ASIS use. 12861 12862 if Chars (Ename) = Chars (Ent) then 12863 Set_Entity (Ename, Ent); 12864 Generate_Reference (Ent, Ename); 12865 12866 -- If entity name does not match, only possibility is an 12867 -- enumeration literal from an enumeration type declaration. 12868 12869 elsif Ekind (Ent) /= E_Enumeration_Type then 12870 Error_Pragma 12871 ("pragma % entity name does not match declaration"); 12872 12873 else 12874 Ent := First_Literal (E); 12875 loop 12876 if No (Ent) then 12877 Error_Pragma 12878 ("pragma % entity name does not match any " & 12879 "enumeration literal"); 12880 12881 elsif Chars (Ent) = Chars (Ename) then 12882 Set_Entity (Ename, Ent); 12883 Generate_Reference (Ent, Ename); 12884 exit; 12885 12886 else 12887 Ent := Next_Literal (Ent); 12888 end if; 12889 end loop; 12890 end if; 12891 end if; 12892 12893 -- Ent points to entity to be marked 12894 12895 if Arg_Count >= 1 then 12896 12897 -- Deal with static string argument 12898 12899 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 12900 S := Strval (Get_Pragma_Arg (Arg1)); 12901 12902 for J in 1 .. String_Length (S) loop 12903 if not In_Character_Range (Get_String_Char (S, J)) then 12904 Error_Pragma_Arg 12905 ("pragma% argument does not allow wide characters", 12906 Arg1); 12907 end if; 12908 end loop; 12909 12910 Obsolescent_Warnings.Append 12911 ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1)))); 12912 12913 -- Check for Ada_05 parameter 12914 12915 if Arg_Count /= 1 then 12916 Check_Arg_Count (2); 12917 12918 declare 12919 Argx : constant Node_Id := Get_Pragma_Arg (Arg2); 12920 12921 begin 12922 Check_Arg_Is_Identifier (Argx); 12923 12924 if Chars (Argx) /= Name_Ada_05 then 12925 Error_Msg_Name_2 := Name_Ada_05; 12926 Error_Pragma_Arg 12927 ("only allowed argument for pragma% is %", Argx); 12928 end if; 12929 12930 if Ada_Version_Explicit < Ada_2005 12931 or else not Warn_On_Ada_2005_Compatibility 12932 then 12933 Active := False; 12934 end if; 12935 end; 12936 end if; 12937 end if; 12938 12939 -- Set flag if pragma active 12940 12941 if Active then 12942 Set_Is_Obsolescent (Ent); 12943 end if; 12944 12945 return; 12946 end Set_Obsolescent; 12947 12948 -- Start of processing for pragma Obsolescent 12949 12950 begin 12951 GNAT_Pragma; 12952 12953 Check_At_Most_N_Arguments (3); 12954 12955 -- See if first argument specifies an entity name 12956 12957 if Arg_Count >= 1 12958 and then 12959 (Chars (Arg1) = Name_Entity 12960 or else 12961 Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal, 12962 N_Identifier, 12963 N_Operator_Symbol)) 12964 then 12965 Ename := Get_Pragma_Arg (Arg1); 12966 12967 -- Eliminate first argument, so we can share processing 12968 12969 Arg1 := Arg2; 12970 Arg2 := Arg3; 12971 Arg_Count := Arg_Count - 1; 12972 12973 -- No Entity name argument given 12974 12975 else 12976 Ename := Empty; 12977 end if; 12978 12979 if Arg_Count >= 1 then 12980 Check_Optional_Identifier (Arg1, Name_Message); 12981 12982 if Arg_Count = 2 then 12983 Check_Optional_Identifier (Arg2, Name_Version); 12984 end if; 12985 end if; 12986 12987 -- Get immediately preceding declaration 12988 12989 Decl := Prev (N); 12990 while Present (Decl) and then Nkind (Decl) = N_Pragma loop 12991 Prev (Decl); 12992 end loop; 12993 12994 -- Cases where we do not follow anything other than another pragma 12995 12996 if No (Decl) then 12997 12998 -- First case: library level compilation unit declaration with 12999 -- the pragma immediately following the declaration. 13000 13001 if Nkind (Parent (N)) = N_Compilation_Unit_Aux then 13002 Set_Obsolescent 13003 (Defining_Entity (Unit (Parent (Parent (N))))); 13004 return; 13005 13006 -- Case 2: library unit placement for package 13007 13008 else 13009 declare 13010 Ent : constant Entity_Id := Find_Lib_Unit_Name; 13011 begin 13012 if Is_Package_Or_Generic_Package (Ent) then 13013 Set_Obsolescent (Ent); 13014 return; 13015 end if; 13016 end; 13017 end if; 13018 13019 -- Cases where we must follow a declaration 13020 13021 else 13022 if Nkind (Decl) not in N_Declaration 13023 and then Nkind (Decl) not in N_Later_Decl_Item 13024 and then Nkind (Decl) not in N_Generic_Declaration 13025 and then Nkind (Decl) not in N_Renaming_Declaration 13026 then 13027 Error_Pragma 13028 ("pragma% misplaced, " 13029 & "must immediately follow a declaration"); 13030 13031 else 13032 Set_Obsolescent (Defining_Entity (Decl)); 13033 return; 13034 end if; 13035 end if; 13036 end Obsolescent; 13037 13038 -------------- 13039 -- Optimize -- 13040 -------------- 13041 13042 -- pragma Optimize (Time | Space | Off); 13043 13044 -- The actual check for optimize is done in Gigi. Note that this 13045 -- pragma does not actually change the optimization setting, it 13046 -- simply checks that it is consistent with the pragma. 13047 13048 when Pragma_Optimize => 13049 Check_No_Identifiers; 13050 Check_Arg_Count (1); 13051 Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); 13052 13053 ------------------------ 13054 -- Optimize_Alignment -- 13055 ------------------------ 13056 13057 -- pragma Optimize_Alignment (Time | Space | Off); 13058 13059 when Pragma_Optimize_Alignment => Optimize_Alignment : begin 13060 GNAT_Pragma; 13061 Check_No_Identifiers; 13062 Check_Arg_Count (1); 13063 Check_Valid_Configuration_Pragma; 13064 13065 declare 13066 Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); 13067 begin 13068 case Nam is 13069 when Name_Time => 13070 Opt.Optimize_Alignment := 'T'; 13071 when Name_Space => 13072 Opt.Optimize_Alignment := 'S'; 13073 when Name_Off => 13074 Opt.Optimize_Alignment := 'O'; 13075 when others => 13076 Error_Pragma_Arg ("invalid argument for pragma%", Arg1); 13077 end case; 13078 end; 13079 13080 -- Set indication that mode is set locally. If we are in fact in a 13081 -- configuration pragma file, this setting is harmless since the 13082 -- switch will get reset anyway at the start of each unit. 13083 13084 Optimize_Alignment_Local := True; 13085 end Optimize_Alignment; 13086 13087 ------------------- 13088 -- Overflow_Mode -- 13089 ------------------- 13090 13091 -- pragma Overflow_Mode 13092 -- ([General => ] MODE [, [Assertions => ] MODE]); 13093 13094 -- MODE := STRICT | MINIMIZED | ELIMINATED 13095 13096 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64 13097 -- since System.Bignums makes this assumption. This is true of nearly 13098 -- all (all?) targets. 13099 13100 when Pragma_Overflow_Mode => Overflow_Mode : declare 13101 function Get_Overflow_Mode 13102 (Name : Name_Id; 13103 Arg : Node_Id) return Overflow_Mode_Type; 13104 -- Function to process one pragma argument, Arg. If an identifier 13105 -- is present, it must be Name. Mode type is returned if a valid 13106 -- argument exists, otherwise an error is signalled. 13107 13108 ----------------------- 13109 -- Get_Overflow_Mode -- 13110 ----------------------- 13111 13112 function Get_Overflow_Mode 13113 (Name : Name_Id; 13114 Arg : Node_Id) return Overflow_Mode_Type 13115 is 13116 Argx : constant Node_Id := Get_Pragma_Arg (Arg); 13117 13118 begin 13119 Check_Optional_Identifier (Arg, Name); 13120 Check_Arg_Is_Identifier (Argx); 13121 13122 if Chars (Argx) = Name_Strict then 13123 return Strict; 13124 13125 elsif Chars (Argx) = Name_Minimized then 13126 return Minimized; 13127 13128 elsif Chars (Argx) = Name_Eliminated then 13129 if Ttypes.Standard_Long_Long_Integer_Size /= 64 then 13130 Error_Pragma_Arg 13131 ("Eliminated not implemented on this target", Argx); 13132 else 13133 return Eliminated; 13134 end if; 13135 13136 else 13137 Error_Pragma_Arg ("invalid argument for pragma%", Argx); 13138 end if; 13139 end Get_Overflow_Mode; 13140 13141 -- Start of processing for Overflow_Mode 13142 13143 begin 13144 GNAT_Pragma; 13145 Check_At_Least_N_Arguments (1); 13146 Check_At_Most_N_Arguments (2); 13147 13148 -- Process first argument 13149 13150 Scope_Suppress.Overflow_Mode_General := 13151 Get_Overflow_Mode (Name_General, Arg1); 13152 13153 -- Case of only one argument 13154 13155 if Arg_Count = 1 then 13156 Scope_Suppress.Overflow_Mode_Assertions := 13157 Scope_Suppress.Overflow_Mode_General; 13158 13159 -- Case of two arguments present 13160 13161 else 13162 Scope_Suppress.Overflow_Mode_Assertions := 13163 Get_Overflow_Mode (Name_Assertions, Arg2); 13164 end if; 13165 end Overflow_Mode; 13166 13167 when Pragma_Overriding_Renamings => 13168 Overriding_Renamings := True; 13169 13170 ------------- 13171 -- Ordered -- 13172 ------------- 13173 13174 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); 13175 13176 when Pragma_Ordered => Ordered : declare 13177 Assoc : constant Node_Id := Arg1; 13178 Type_Id : Node_Id; 13179 Typ : Entity_Id; 13180 13181 begin 13182 GNAT_Pragma; 13183 Check_No_Identifiers; 13184 Check_Arg_Count (1); 13185 Check_Arg_Is_Local_Name (Arg1); 13186 13187 Type_Id := Get_Pragma_Arg (Assoc); 13188 Find_Type (Type_Id); 13189 Typ := Entity (Type_Id); 13190 13191 if Typ = Any_Type then 13192 return; 13193 else 13194 Typ := Underlying_Type (Typ); 13195 end if; 13196 13197 if not Is_Enumeration_Type (Typ) then 13198 Error_Pragma ("pragma% must specify enumeration type"); 13199 end if; 13200 13201 Check_First_Subtype (Arg1); 13202 Set_Has_Pragma_Ordered (Base_Type (Typ)); 13203 end Ordered; 13204 13205 ---------- 13206 -- Pack -- 13207 ---------- 13208 13209 -- pragma Pack (first_subtype_LOCAL_NAME); 13210 13211 when Pragma_Pack => Pack : declare 13212 Assoc : constant Node_Id := Arg1; 13213 Type_Id : Node_Id; 13214 Typ : Entity_Id; 13215 Ctyp : Entity_Id; 13216 Ignore : Boolean := False; 13217 13218 begin 13219 Check_No_Identifiers; 13220 Check_Arg_Count (1); 13221 Check_Arg_Is_Local_Name (Arg1); 13222 13223 Type_Id := Get_Pragma_Arg (Assoc); 13224 Find_Type (Type_Id); 13225 Typ := Entity (Type_Id); 13226 13227 if Typ = Any_Type 13228 or else Rep_Item_Too_Early (Typ, N) 13229 then 13230 return; 13231 else 13232 Typ := Underlying_Type (Typ); 13233 end if; 13234 13235 if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then 13236 Error_Pragma ("pragma% must specify array or record type"); 13237 end if; 13238 13239 Check_First_Subtype (Arg1); 13240 Check_Duplicate_Pragma (Typ); 13241 13242 -- Array type 13243 13244 if Is_Array_Type (Typ) then 13245 Ctyp := Component_Type (Typ); 13246 13247 -- Ignore pack that does nothing 13248 13249 if Known_Static_Esize (Ctyp) 13250 and then Known_Static_RM_Size (Ctyp) 13251 and then Esize (Ctyp) = RM_Size (Ctyp) 13252 and then Addressable (Esize (Ctyp)) 13253 then 13254 Ignore := True; 13255 end if; 13256 13257 -- Process OK pragma Pack. Note that if there is a separate 13258 -- component clause present, the Pack will be cancelled. This 13259 -- processing is in Freeze. 13260 13261 if not Rep_Item_Too_Late (Typ, N) then 13262 13263 -- In the context of static code analysis, we do not need 13264 -- complex front-end expansions related to pragma Pack, 13265 -- so disable handling of pragma Pack in these cases. 13266 13267 if CodePeer_Mode or Alfa_Mode then 13268 null; 13269 13270 -- Don't attempt any packing for VM targets. We possibly 13271 -- could deal with some cases of array bit-packing, but we 13272 -- don't bother, since this is not a typical kind of 13273 -- representation in the VM context anyway (and would not 13274 -- for example work nicely with the debugger). 13275 13276 elsif VM_Target /= No_VM then 13277 if not GNAT_Mode then 13278 Error_Pragma 13279 ("??pragma% ignored in this configuration"); 13280 end if; 13281 13282 -- Normal case where we do the pack action 13283 13284 else 13285 if not Ignore then 13286 Set_Is_Packed (Base_Type (Typ)); 13287 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 13288 end if; 13289 13290 Set_Has_Pragma_Pack (Base_Type (Typ)); 13291 end if; 13292 end if; 13293 13294 -- For record types, the pack is always effective 13295 13296 else pragma Assert (Is_Record_Type (Typ)); 13297 if not Rep_Item_Too_Late (Typ, N) then 13298 13299 -- Ignore pack request with warning in VM mode (skip warning 13300 -- if we are compiling GNAT run time library). 13301 13302 if VM_Target /= No_VM then 13303 if not GNAT_Mode then 13304 Error_Pragma 13305 ("??pragma% ignored in this configuration"); 13306 end if; 13307 13308 -- Normal case of pack request active 13309 13310 else 13311 Set_Is_Packed (Base_Type (Typ)); 13312 Set_Has_Pragma_Pack (Base_Type (Typ)); 13313 Set_Has_Non_Standard_Rep (Base_Type (Typ)); 13314 end if; 13315 end if; 13316 end if; 13317 end Pack; 13318 13319 ---------- 13320 -- Page -- 13321 ---------- 13322 13323 -- pragma Page; 13324 13325 -- There is nothing to do here, since we did all the processing for 13326 -- this pragma in Par.Prag (so that it works properly even in syntax 13327 -- only mode). 13328 13329 when Pragma_Page => 13330 null; 13331 13332 ---------------------------------- 13333 -- Partition_Elaboration_Policy -- 13334 ---------------------------------- 13335 13336 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER); 13337 13338 when Pragma_Partition_Elaboration_Policy => declare 13339 subtype PEP_Range is Name_Id 13340 range First_Partition_Elaboration_Policy_Name 13341 .. Last_Partition_Elaboration_Policy_Name; 13342 PEP_Val : PEP_Range; 13343 PEP : Character; 13344 13345 begin 13346 Ada_2005_Pragma; 13347 Check_Arg_Count (1); 13348 Check_No_Identifiers; 13349 Check_Arg_Is_Partition_Elaboration_Policy (Arg1); 13350 Check_Valid_Configuration_Pragma; 13351 PEP_Val := Chars (Get_Pragma_Arg (Arg1)); 13352 13353 case PEP_Val is 13354 when Name_Concurrent => 13355 PEP := 'C'; 13356 when Name_Sequential => 13357 PEP := 'S'; 13358 end case; 13359 13360 if Partition_Elaboration_Policy /= ' ' 13361 and then Partition_Elaboration_Policy /= PEP 13362 then 13363 Error_Msg_Sloc := Partition_Elaboration_Policy_Sloc; 13364 Error_Pragma 13365 ("partition elaboration policy incompatible with policy#"); 13366 13367 -- Set new policy, but always preserve System_Location since we 13368 -- like the error message with the run time name. 13369 13370 else 13371 Partition_Elaboration_Policy := PEP; 13372 13373 if Partition_Elaboration_Policy_Sloc /= System_Location then 13374 Partition_Elaboration_Policy_Sloc := Loc; 13375 end if; 13376 end if; 13377 end; 13378 13379 ------------- 13380 -- Passive -- 13381 ------------- 13382 13383 -- pragma Passive [(PASSIVE_FORM)]; 13384 13385 -- PASSIVE_FORM ::= Semaphore | No 13386 13387 when Pragma_Passive => 13388 GNAT_Pragma; 13389 13390 if Nkind (Parent (N)) /= N_Task_Definition then 13391 Error_Pragma ("pragma% must be within task definition"); 13392 end if; 13393 13394 if Arg_Count /= 0 then 13395 Check_Arg_Count (1); 13396 Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); 13397 end if; 13398 13399 ---------------------------------- 13400 -- Preelaborable_Initialization -- 13401 ---------------------------------- 13402 13403 -- pragma Preelaborable_Initialization (DIRECT_NAME); 13404 13405 when Pragma_Preelaborable_Initialization => Preelab_Init : declare 13406 Ent : Entity_Id; 13407 13408 begin 13409 Ada_2005_Pragma; 13410 Check_Arg_Count (1); 13411 Check_No_Identifiers; 13412 Check_Arg_Is_Identifier (Arg1); 13413 Check_Arg_Is_Local_Name (Arg1); 13414 Check_First_Subtype (Arg1); 13415 Ent := Entity (Get_Pragma_Arg (Arg1)); 13416 13417 if not (Is_Private_Type (Ent) 13418 or else 13419 Is_Protected_Type (Ent) 13420 or else 13421 (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent))) 13422 then 13423 Error_Pragma_Arg 13424 ("pragma % can only be applied to private, formal derived or " 13425 & "protected type", 13426 Arg1); 13427 end if; 13428 13429 -- Give an error if the pragma is applied to a protected type that 13430 -- does not qualify (due to having entries, or due to components 13431 -- that do not qualify). 13432 13433 if Is_Protected_Type (Ent) 13434 and then not Has_Preelaborable_Initialization (Ent) 13435 then 13436 Error_Msg_N 13437 ("protected type & does not have preelaborable " & 13438 "initialization", Ent); 13439 13440 -- Otherwise mark the type as definitely having preelaborable 13441 -- initialization. 13442 13443 else 13444 Set_Known_To_Have_Preelab_Init (Ent); 13445 end if; 13446 13447 if Has_Pragma_Preelab_Init (Ent) 13448 and then Warn_On_Redundant_Constructs 13449 then 13450 Error_Pragma ("?r?duplicate pragma%!"); 13451 else 13452 Set_Has_Pragma_Preelab_Init (Ent); 13453 end if; 13454 end Preelab_Init; 13455 13456 -------------------- 13457 -- Persistent_BSS -- 13458 -------------------- 13459 13460 -- pragma Persistent_BSS [(object_NAME)]; 13461 13462 when Pragma_Persistent_BSS => Persistent_BSS : declare 13463 Decl : Node_Id; 13464 Ent : Entity_Id; 13465 Prag : Node_Id; 13466 13467 begin 13468 GNAT_Pragma; 13469 Check_At_Most_N_Arguments (1); 13470 13471 -- Case of application to specific object (one argument) 13472 13473 if Arg_Count = 1 then 13474 Check_Arg_Is_Library_Level_Local_Name (Arg1); 13475 13476 if not Is_Entity_Name (Get_Pragma_Arg (Arg1)) 13477 or else not 13478 Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable, 13479 E_Constant) 13480 then 13481 Error_Pragma_Arg ("pragma% only applies to objects", Arg1); 13482 end if; 13483 13484 Ent := Entity (Get_Pragma_Arg (Arg1)); 13485 Decl := Parent (Ent); 13486 13487 -- Check for duplication before inserting in list of 13488 -- representation items. 13489 13490 Check_Duplicate_Pragma (Ent); 13491 13492 if Rep_Item_Too_Late (Ent, N) then 13493 return; 13494 end if; 13495 13496 if Present (Expression (Decl)) then 13497 Error_Pragma_Arg 13498 ("object for pragma% cannot have initialization", Arg1); 13499 end if; 13500 13501 if not Is_Potentially_Persistent_Type (Etype (Ent)) then 13502 Error_Pragma_Arg 13503 ("object type for pragma% is not potentially persistent", 13504 Arg1); 13505 end if; 13506 13507 Prag := 13508 Make_Linker_Section_Pragma 13509 (Ent, Sloc (N), ".persistent.bss"); 13510 Insert_After (N, Prag); 13511 Analyze (Prag); 13512 13513 -- Case of use as configuration pragma with no arguments 13514 13515 else 13516 Check_Valid_Configuration_Pragma; 13517 Persistent_BSS_Mode := True; 13518 end if; 13519 end Persistent_BSS; 13520 13521 ------------- 13522 -- Polling -- 13523 ------------- 13524 13525 -- pragma Polling (ON | OFF); 13526 13527 when Pragma_Polling => 13528 GNAT_Pragma; 13529 Check_Arg_Count (1); 13530 Check_No_Identifiers; 13531 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 13532 Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On); 13533 13534 ------------------- 13535 -- Postcondition -- 13536 ------------------- 13537 13538 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION 13539 -- [,[Message =>] String_EXPRESSION]); 13540 13541 when Pragma_Postcondition => Postcondition : declare 13542 In_Body : Boolean; 13543 13544 begin 13545 GNAT_Pragma; 13546 Check_At_Least_N_Arguments (1); 13547 Check_At_Most_N_Arguments (2); 13548 Check_Optional_Identifier (Arg1, Name_Check); 13549 13550 -- Verify the proper placement of the pragma. The remainder of the 13551 -- processing is found in Sem_Ch6/Sem_Ch7. 13552 13553 Check_Precondition_Postcondition (In_Body); 13554 13555 -- When the pragma is a source contruct and appears inside a body, 13556 -- preanalyze the boolean_expression to detect illegal forward 13557 -- references: 13558 13559 -- procedure P is 13560 -- pragma Postcondition (X'Old ...); 13561 -- X : ... 13562 13563 if Comes_From_Source (N) and then In_Body then 13564 Preanalyze_Spec_Expression (Expression (Arg1), Any_Boolean); 13565 end if; 13566 end Postcondition; 13567 13568 ------------------ 13569 -- Precondition -- 13570 ------------------ 13571 13572 -- pragma Precondition ([Check =>] Boolean_EXPRESSION 13573 -- [,[Message =>] String_EXPRESSION]); 13574 13575 when Pragma_Precondition => Precondition : declare 13576 In_Body : Boolean; 13577 13578 begin 13579 GNAT_Pragma; 13580 Check_At_Least_N_Arguments (1); 13581 Check_At_Most_N_Arguments (2); 13582 Check_Optional_Identifier (Arg1, Name_Check); 13583 Check_Precondition_Postcondition (In_Body); 13584 13585 -- If in spec, nothing more to do. If in body, then we convert the 13586 -- pragma to pragma Check (Precondition, cond [, msg]). Note we do 13587 -- this whether or not precondition checks are enabled. That works 13588 -- fine since pragma Check will do this check, and will also 13589 -- analyze the condition itself in the proper context. 13590 13591 if In_Body then 13592 Rewrite (N, 13593 Make_Pragma (Loc, 13594 Chars => Name_Check, 13595 Pragma_Argument_Associations => New_List ( 13596 Make_Pragma_Argument_Association (Loc, 13597 Expression => Make_Identifier (Loc, Name_Precondition)), 13598 13599 Make_Pragma_Argument_Association (Sloc (Arg1), 13600 Expression => Relocate_Node (Get_Pragma_Arg (Arg1)))))); 13601 13602 if Arg_Count = 2 then 13603 Append_To (Pragma_Argument_Associations (N), 13604 Make_Pragma_Argument_Association (Sloc (Arg2), 13605 Expression => Relocate_Node (Get_Pragma_Arg (Arg2)))); 13606 end if; 13607 13608 Analyze (N); 13609 end if; 13610 end Precondition; 13611 13612 --------------- 13613 -- Predicate -- 13614 --------------- 13615 13616 -- pragma Predicate 13617 -- ([Entity =>] type_LOCAL_NAME, 13618 -- [Check =>] EXPRESSION); 13619 13620 when Pragma_Predicate => Predicate : declare 13621 Type_Id : Node_Id; 13622 Typ : Entity_Id; 13623 13624 Discard : Boolean; 13625 pragma Unreferenced (Discard); 13626 13627 begin 13628 GNAT_Pragma; 13629 Check_Arg_Count (2); 13630 Check_Optional_Identifier (Arg1, Name_Entity); 13631 Check_Optional_Identifier (Arg2, Name_Check); 13632 13633 Check_Arg_Is_Local_Name (Arg1); 13634 13635 Type_Id := Get_Pragma_Arg (Arg1); 13636 Find_Type (Type_Id); 13637 Typ := Entity (Type_Id); 13638 13639 if Typ = Any_Type then 13640 return; 13641 end if; 13642 13643 -- The remaining processing is simply to link the pragma on to 13644 -- the rep item chain, for processing when the type is frozen. 13645 -- This is accomplished by a call to Rep_Item_Too_Late. We also 13646 -- mark the type as having predicates. 13647 13648 Set_Has_Predicates (Typ); 13649 Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); 13650 end Predicate; 13651 13652 ------------------ 13653 -- Preelaborate -- 13654 ------------------ 13655 13656 -- pragma Preelaborate [(library_unit_NAME)]; 13657 13658 -- Set the flag Is_Preelaborated of program unit name entity 13659 13660 when Pragma_Preelaborate => Preelaborate : declare 13661 Pa : constant Node_Id := Parent (N); 13662 Pk : constant Node_Kind := Nkind (Pa); 13663 Ent : Entity_Id; 13664 13665 begin 13666 Check_Ada_83_Warning; 13667 Check_Valid_Library_Unit_Pragma; 13668 13669 if Nkind (N) = N_Null_Statement then 13670 return; 13671 end if; 13672 13673 Ent := Find_Lib_Unit_Name; 13674 Check_Duplicate_Pragma (Ent); 13675 13676 -- This filters out pragmas inside generic parent then 13677 -- show up inside instantiation 13678 13679 if Present (Ent) 13680 and then not (Pk = N_Package_Specification 13681 and then Present (Generic_Parent (Pa))) 13682 then 13683 if not Debug_Flag_U then 13684 Set_Is_Preelaborated (Ent); 13685 Set_Suppress_Elaboration_Warnings (Ent); 13686 end if; 13687 end if; 13688 end Preelaborate; 13689 13690 --------------------- 13691 -- Preelaborate_05 -- 13692 --------------------- 13693 13694 -- pragma Preelaborate_05 [(library_unit_NAME)]; 13695 13696 -- This pragma is useable only in GNAT_Mode, where it is used like 13697 -- pragma Preelaborate but it is only effective in Ada 2005 mode 13698 -- (otherwise it is ignored). This is used to implement AI-362 which 13699 -- recategorizes some run-time packages in Ada 2005 mode. 13700 13701 when Pragma_Preelaborate_05 => Preelaborate_05 : declare 13702 Ent : Entity_Id; 13703 13704 begin 13705 GNAT_Pragma; 13706 Check_Valid_Library_Unit_Pragma; 13707 13708 if not GNAT_Mode then 13709 Error_Pragma ("pragma% only available in GNAT mode"); 13710 end if; 13711 13712 if Nkind (N) = N_Null_Statement then 13713 return; 13714 end if; 13715 13716 -- This is one of the few cases where we need to test the value of 13717 -- Ada_Version_Explicit rather than Ada_Version (which is always 13718 -- set to Ada_2012 in a predefined unit), we need to know the 13719 -- explicit version set to know if this pragma is active. 13720 13721 if Ada_Version_Explicit >= Ada_2005 then 13722 Ent := Find_Lib_Unit_Name; 13723 Set_Is_Preelaborated (Ent); 13724 Set_Suppress_Elaboration_Warnings (Ent); 13725 end if; 13726 end Preelaborate_05; 13727 13728 -------------- 13729 -- Priority -- 13730 -------------- 13731 13732 -- pragma Priority (EXPRESSION); 13733 13734 when Pragma_Priority => Priority : declare 13735 P : constant Node_Id := Parent (N); 13736 Arg : Node_Id; 13737 Ent : Entity_Id; 13738 13739 begin 13740 Check_No_Identifiers; 13741 Check_Arg_Count (1); 13742 13743 -- Subprogram case 13744 13745 if Nkind (P) = N_Subprogram_Body then 13746 Check_In_Main_Program; 13747 13748 Ent := Defining_Unit_Name (Specification (P)); 13749 13750 if Nkind (Ent) = N_Defining_Program_Unit_Name then 13751 Ent := Defining_Identifier (Ent); 13752 end if; 13753 13754 Arg := Get_Pragma_Arg (Arg1); 13755 Analyze_And_Resolve (Arg, Standard_Integer); 13756 13757 -- Must be static 13758 13759 if not Is_Static_Expression (Arg) then 13760 Flag_Non_Static_Expr 13761 ("main subprogram priority is not static!", Arg); 13762 raise Pragma_Exit; 13763 13764 -- If constraint error, then we already signalled an error 13765 13766 elsif Raises_Constraint_Error (Arg) then 13767 null; 13768 13769 -- Otherwise check in range 13770 13771 else 13772 declare 13773 Val : constant Uint := Expr_Value (Arg); 13774 13775 begin 13776 if Val < 0 13777 or else Val > Expr_Value (Expression 13778 (Parent (RTE (RE_Max_Priority)))) 13779 then 13780 Error_Pragma_Arg 13781 ("main subprogram priority is out of range", Arg1); 13782 end if; 13783 end; 13784 end if; 13785 13786 Set_Main_Priority 13787 (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); 13788 13789 -- Load an arbitrary entity from System.Tasking to make sure 13790 -- this package is implicitly with'ed, since we need to have 13791 -- the tasking run-time active for the pragma Priority to have 13792 -- any effect. 13793 13794 declare 13795 Discard : Entity_Id; 13796 pragma Warnings (Off, Discard); 13797 begin 13798 Discard := RTE (RE_Task_List); 13799 end; 13800 13801 -- Task or Protected, must be of type Integer 13802 13803 elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then 13804 Arg := Get_Pragma_Arg (Arg1); 13805 Ent := Defining_Identifier (Parent (P)); 13806 13807 -- The expression must be analyzed in the special manner 13808 -- described in "Handling of Default and Per-Object 13809 -- Expressions" in sem.ads. 13810 13811 Preanalyze_Spec_Expression (Arg, Standard_Integer); 13812 13813 if not Is_Static_Expression (Arg) then 13814 Check_Restriction (Static_Priorities, Arg); 13815 end if; 13816 13817 -- Anything else is incorrect 13818 13819 else 13820 Pragma_Misplaced; 13821 end if; 13822 13823 -- Check duplicate pragma before we chain the pragma in the Rep 13824 -- Item chain of Ent. 13825 13826 Check_Duplicate_Pragma (Ent); 13827 Record_Rep_Item (Ent, N); 13828 end Priority; 13829 13830 ----------------------------------- 13831 -- Priority_Specific_Dispatching -- 13832 ----------------------------------- 13833 13834 -- pragma Priority_Specific_Dispatching ( 13835 -- policy_IDENTIFIER, 13836 -- first_priority_EXPRESSION, 13837 -- last_priority_EXPRESSION); 13838 13839 when Pragma_Priority_Specific_Dispatching => 13840 Priority_Specific_Dispatching : declare 13841 Prio_Id : constant Entity_Id := RTE (RE_Any_Priority); 13842 -- This is the entity System.Any_Priority; 13843 13844 DP : Character; 13845 Lower_Bound : Node_Id; 13846 Upper_Bound : Node_Id; 13847 Lower_Val : Uint; 13848 Upper_Val : Uint; 13849 13850 begin 13851 Ada_2005_Pragma; 13852 Check_Arg_Count (3); 13853 Check_No_Identifiers; 13854 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 13855 Check_Valid_Configuration_Pragma; 13856 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 13857 DP := Fold_Upper (Name_Buffer (1)); 13858 13859 Lower_Bound := Get_Pragma_Arg (Arg2); 13860 Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer); 13861 Lower_Val := Expr_Value (Lower_Bound); 13862 13863 Upper_Bound := Get_Pragma_Arg (Arg3); 13864 Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer); 13865 Upper_Val := Expr_Value (Upper_Bound); 13866 13867 -- It is not allowed to use Task_Dispatching_Policy and 13868 -- Priority_Specific_Dispatching in the same partition. 13869 13870 if Task_Dispatching_Policy /= ' ' then 13871 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 13872 Error_Pragma 13873 ("pragma% incompatible with Task_Dispatching_Policy#"); 13874 13875 -- Check lower bound in range 13876 13877 elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 13878 or else 13879 Lower_Val > Expr_Value (Type_High_Bound (Prio_Id)) 13880 then 13881 Error_Pragma_Arg 13882 ("first_priority is out of range", Arg2); 13883 13884 -- Check upper bound in range 13885 13886 elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id)) 13887 or else 13888 Upper_Val > Expr_Value (Type_High_Bound (Prio_Id)) 13889 then 13890 Error_Pragma_Arg 13891 ("last_priority is out of range", Arg3); 13892 13893 -- Check that the priority range is valid 13894 13895 elsif Lower_Val > Upper_Val then 13896 Error_Pragma 13897 ("last_priority_expression must be greater than" & 13898 " or equal to first_priority_expression"); 13899 13900 -- Store the new policy, but always preserve System_Location since 13901 -- we like the error message with the run-time name. 13902 13903 else 13904 -- Check overlapping in the priority ranges specified in other 13905 -- Priority_Specific_Dispatching pragmas within the same 13906 -- partition. We can only check those we know about! 13907 13908 for J in 13909 Specific_Dispatching.First .. Specific_Dispatching.Last 13910 loop 13911 if Specific_Dispatching.Table (J).First_Priority in 13912 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 13913 or else Specific_Dispatching.Table (J).Last_Priority in 13914 UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val) 13915 then 13916 Error_Msg_Sloc := 13917 Specific_Dispatching.Table (J).Pragma_Loc; 13918 Error_Pragma 13919 ("priority range overlaps with " 13920 & "Priority_Specific_Dispatching#"); 13921 end if; 13922 end loop; 13923 13924 -- The use of Priority_Specific_Dispatching is incompatible 13925 -- with Task_Dispatching_Policy. 13926 13927 if Task_Dispatching_Policy /= ' ' then 13928 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 13929 Error_Pragma 13930 ("Priority_Specific_Dispatching incompatible " 13931 & "with Task_Dispatching_Policy#"); 13932 end if; 13933 13934 -- The use of Priority_Specific_Dispatching forces ceiling 13935 -- locking policy. 13936 13937 if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then 13938 Error_Msg_Sloc := Locking_Policy_Sloc; 13939 Error_Pragma 13940 ("Priority_Specific_Dispatching incompatible " 13941 & "with Locking_Policy#"); 13942 13943 -- Set the Ceiling_Locking policy, but preserve System_Location 13944 -- since we like the error message with the run time name. 13945 13946 else 13947 Locking_Policy := 'C'; 13948 13949 if Locking_Policy_Sloc /= System_Location then 13950 Locking_Policy_Sloc := Loc; 13951 end if; 13952 end if; 13953 13954 -- Add entry in the table 13955 13956 Specific_Dispatching.Append 13957 ((Dispatching_Policy => DP, 13958 First_Priority => UI_To_Int (Lower_Val), 13959 Last_Priority => UI_To_Int (Upper_Val), 13960 Pragma_Loc => Loc)); 13961 end if; 13962 end Priority_Specific_Dispatching; 13963 13964 ------------- 13965 -- Profile -- 13966 ------------- 13967 13968 -- pragma Profile (profile_IDENTIFIER); 13969 13970 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational 13971 13972 when Pragma_Profile => 13973 Ada_2005_Pragma; 13974 Check_Arg_Count (1); 13975 Check_Valid_Configuration_Pragma; 13976 Check_No_Identifiers; 13977 13978 declare 13979 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 13980 13981 begin 13982 if Chars (Argx) = Name_Ravenscar then 13983 Set_Ravenscar_Profile (N); 13984 13985 elsif Chars (Argx) = Name_Restricted then 13986 Set_Profile_Restrictions 13987 (Restricted, 13988 N, Warn => Treat_Restrictions_As_Warnings); 13989 13990 elsif Chars (Argx) = Name_Rational then 13991 Set_Rational_Profile; 13992 13993 elsif Chars (Argx) = Name_No_Implementation_Extensions then 13994 Set_Profile_Restrictions 13995 (No_Implementation_Extensions, 13996 N, Warn => Treat_Restrictions_As_Warnings); 13997 13998 else 13999 Error_Pragma_Arg ("& is not a valid profile", Argx); 14000 end if; 14001 end; 14002 14003 ---------------------- 14004 -- Profile_Warnings -- 14005 ---------------------- 14006 14007 -- pragma Profile_Warnings (profile_IDENTIFIER); 14008 14009 -- profile_IDENTIFIER => Restricted | Ravenscar 14010 14011 when Pragma_Profile_Warnings => 14012 GNAT_Pragma; 14013 Check_Arg_Count (1); 14014 Check_Valid_Configuration_Pragma; 14015 Check_No_Identifiers; 14016 14017 declare 14018 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 14019 14020 begin 14021 if Chars (Argx) = Name_Ravenscar then 14022 Set_Profile_Restrictions (Ravenscar, N, Warn => True); 14023 14024 elsif Chars (Argx) = Name_Restricted then 14025 Set_Profile_Restrictions (Restricted, N, Warn => True); 14026 14027 elsif Chars (Argx) = Name_No_Implementation_Extensions then 14028 Set_Profile_Restrictions 14029 (No_Implementation_Extensions, N, Warn => True); 14030 14031 else 14032 Error_Pragma_Arg ("& is not a valid profile", Argx); 14033 end if; 14034 end; 14035 14036 -------------------------- 14037 -- Propagate_Exceptions -- 14038 -------------------------- 14039 14040 -- pragma Propagate_Exceptions; 14041 14042 -- Note: this pragma is obsolete and has no effect 14043 14044 when Pragma_Propagate_Exceptions => 14045 GNAT_Pragma; 14046 Check_Arg_Count (0); 14047 14048 if In_Extended_Main_Source_Unit (N) then 14049 Propagate_Exceptions := True; 14050 end if; 14051 14052 ------------------ 14053 -- Psect_Object -- 14054 ------------------ 14055 14056 -- pragma Psect_Object ( 14057 -- [Internal =>] LOCAL_NAME, 14058 -- [, [External =>] EXTERNAL_SYMBOL] 14059 -- [, [Size =>] EXTERNAL_SYMBOL]); 14060 14061 when Pragma_Psect_Object | Pragma_Common_Object => 14062 Psect_Object : declare 14063 Args : Args_List (1 .. 3); 14064 Names : constant Name_List (1 .. 3) := ( 14065 Name_Internal, 14066 Name_External, 14067 Name_Size); 14068 14069 Internal : Node_Id renames Args (1); 14070 External : Node_Id renames Args (2); 14071 Size : Node_Id renames Args (3); 14072 14073 Def_Id : Entity_Id; 14074 14075 procedure Check_Too_Long (Arg : Node_Id); 14076 -- Posts message if the argument is an identifier with more 14077 -- than 31 characters, or a string literal with more than 14078 -- 31 characters, and we are operating under VMS 14079 14080 -------------------- 14081 -- Check_Too_Long -- 14082 -------------------- 14083 14084 procedure Check_Too_Long (Arg : Node_Id) is 14085 X : constant Node_Id := Original_Node (Arg); 14086 14087 begin 14088 if not Nkind_In (X, N_String_Literal, N_Identifier) then 14089 Error_Pragma_Arg 14090 ("inappropriate argument for pragma %", Arg); 14091 end if; 14092 14093 if OpenVMS_On_Target then 14094 if (Nkind (X) = N_String_Literal 14095 and then String_Length (Strval (X)) > 31) 14096 or else 14097 (Nkind (X) = N_Identifier 14098 and then Length_Of_Name (Chars (X)) > 31) 14099 then 14100 Error_Pragma_Arg 14101 ("argument for pragma % is longer than 31 characters", 14102 Arg); 14103 end if; 14104 end if; 14105 end Check_Too_Long; 14106 14107 -- Start of processing for Common_Object/Psect_Object 14108 14109 begin 14110 GNAT_Pragma; 14111 Gather_Associations (Names, Args); 14112 Process_Extended_Import_Export_Internal_Arg (Internal); 14113 14114 Def_Id := Entity (Internal); 14115 14116 if not Ekind_In (Def_Id, E_Constant, E_Variable) then 14117 Error_Pragma_Arg 14118 ("pragma% must designate an object", Internal); 14119 end if; 14120 14121 Check_Too_Long (Internal); 14122 14123 if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then 14124 Error_Pragma_Arg 14125 ("cannot use pragma% for imported/exported object", 14126 Internal); 14127 end if; 14128 14129 if Is_Concurrent_Type (Etype (Internal)) then 14130 Error_Pragma_Arg 14131 ("cannot specify pragma % for task/protected object", 14132 Internal); 14133 end if; 14134 14135 if Has_Rep_Pragma (Def_Id, Name_Common_Object) 14136 or else 14137 Has_Rep_Pragma (Def_Id, Name_Psect_Object) 14138 then 14139 Error_Msg_N ("??duplicate Common/Psect_Object pragma", N); 14140 end if; 14141 14142 if Ekind (Def_Id) = E_Constant then 14143 Error_Pragma_Arg 14144 ("cannot specify pragma % for a constant", Internal); 14145 end if; 14146 14147 if Is_Record_Type (Etype (Internal)) then 14148 declare 14149 Ent : Entity_Id; 14150 Decl : Entity_Id; 14151 14152 begin 14153 Ent := First_Entity (Etype (Internal)); 14154 while Present (Ent) loop 14155 Decl := Declaration_Node (Ent); 14156 14157 if Ekind (Ent) = E_Component 14158 and then Nkind (Decl) = N_Component_Declaration 14159 and then Present (Expression (Decl)) 14160 and then Warn_On_Export_Import 14161 then 14162 Error_Msg_N 14163 ("?x?object for pragma % has defaults", Internal); 14164 exit; 14165 14166 else 14167 Next_Entity (Ent); 14168 end if; 14169 end loop; 14170 end; 14171 end if; 14172 14173 if Present (Size) then 14174 Check_Too_Long (Size); 14175 end if; 14176 14177 if Present (External) then 14178 Check_Arg_Is_External_Name (External); 14179 Check_Too_Long (External); 14180 end if; 14181 14182 -- If all error tests pass, link pragma on to the rep item chain 14183 14184 Record_Rep_Item (Def_Id, N); 14185 end Psect_Object; 14186 14187 ---------- 14188 -- Pure -- 14189 ---------- 14190 14191 -- pragma Pure [(library_unit_NAME)]; 14192 14193 when Pragma_Pure => Pure : declare 14194 Ent : Entity_Id; 14195 14196 begin 14197 Check_Ada_83_Warning; 14198 Check_Valid_Library_Unit_Pragma; 14199 14200 if Nkind (N) = N_Null_Statement then 14201 return; 14202 end if; 14203 14204 Ent := Find_Lib_Unit_Name; 14205 Set_Is_Pure (Ent); 14206 Set_Has_Pragma_Pure (Ent); 14207 Set_Suppress_Elaboration_Warnings (Ent); 14208 end Pure; 14209 14210 ------------- 14211 -- Pure_05 -- 14212 ------------- 14213 14214 -- pragma Pure_05 [(library_unit_NAME)]; 14215 14216 -- This pragma is useable only in GNAT_Mode, where it is used like 14217 -- pragma Pure but it is only effective in Ada 2005 mode (otherwise 14218 -- it is ignored). It may be used after a pragma Preelaborate, in 14219 -- which case it overrides the effect of the pragma Preelaborate. 14220 -- This is used to implement AI-362 which recategorizes some run-time 14221 -- packages in Ada 2005 mode. 14222 14223 when Pragma_Pure_05 => Pure_05 : declare 14224 Ent : Entity_Id; 14225 14226 begin 14227 GNAT_Pragma; 14228 Check_Valid_Library_Unit_Pragma; 14229 14230 if not GNAT_Mode then 14231 Error_Pragma ("pragma% only available in GNAT mode"); 14232 end if; 14233 14234 if Nkind (N) = N_Null_Statement then 14235 return; 14236 end if; 14237 14238 -- This is one of the few cases where we need to test the value of 14239 -- Ada_Version_Explicit rather than Ada_Version (which is always 14240 -- set to Ada_2012 in a predefined unit), we need to know the 14241 -- explicit version set to know if this pragma is active. 14242 14243 if Ada_Version_Explicit >= Ada_2005 then 14244 Ent := Find_Lib_Unit_Name; 14245 Set_Is_Preelaborated (Ent, False); 14246 Set_Is_Pure (Ent); 14247 Set_Suppress_Elaboration_Warnings (Ent); 14248 end if; 14249 end Pure_05; 14250 14251 ------------- 14252 -- Pure_12 -- 14253 ------------- 14254 14255 -- pragma Pure_12 [(library_unit_NAME)]; 14256 14257 -- This pragma is useable only in GNAT_Mode, where it is used like 14258 -- pragma Pure but it is only effective in Ada 2012 mode (otherwise 14259 -- it is ignored). It may be used after a pragma Preelaborate, in 14260 -- which case it overrides the effect of the pragma Preelaborate. 14261 -- This is used to implement AI05-0212 which recategorizes some 14262 -- run-time packages in Ada 2012 mode. 14263 14264 when Pragma_Pure_12 => Pure_12 : declare 14265 Ent : Entity_Id; 14266 14267 begin 14268 GNAT_Pragma; 14269 Check_Valid_Library_Unit_Pragma; 14270 14271 if not GNAT_Mode then 14272 Error_Pragma ("pragma% only available in GNAT mode"); 14273 end if; 14274 14275 if Nkind (N) = N_Null_Statement then 14276 return; 14277 end if; 14278 14279 -- This is one of the few cases where we need to test the value of 14280 -- Ada_Version_Explicit rather than Ada_Version (which is always 14281 -- set to Ada_2012 in a predefined unit), we need to know the 14282 -- explicit version set to know if this pragma is active. 14283 14284 if Ada_Version_Explicit >= Ada_2012 then 14285 Ent := Find_Lib_Unit_Name; 14286 Set_Is_Preelaborated (Ent, False); 14287 Set_Is_Pure (Ent); 14288 Set_Suppress_Elaboration_Warnings (Ent); 14289 end if; 14290 end Pure_12; 14291 14292 ------------------- 14293 -- Pure_Function -- 14294 ------------------- 14295 14296 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME); 14297 14298 when Pragma_Pure_Function => Pure_Function : declare 14299 E_Id : Node_Id; 14300 E : Entity_Id; 14301 Def_Id : Entity_Id; 14302 Effective : Boolean := False; 14303 14304 begin 14305 GNAT_Pragma; 14306 Check_Arg_Count (1); 14307 Check_Optional_Identifier (Arg1, Name_Entity); 14308 Check_Arg_Is_Local_Name (Arg1); 14309 E_Id := Get_Pragma_Arg (Arg1); 14310 14311 if Error_Posted (E_Id) then 14312 return; 14313 end if; 14314 14315 -- Loop through homonyms (overloadings) of referenced entity 14316 14317 E := Entity (E_Id); 14318 14319 if Present (E) then 14320 loop 14321 Def_Id := Get_Base_Subprogram (E); 14322 14323 if not Ekind_In (Def_Id, E_Function, 14324 E_Generic_Function, 14325 E_Operator) 14326 then 14327 Error_Pragma_Arg 14328 ("pragma% requires a function name", Arg1); 14329 end if; 14330 14331 Set_Is_Pure (Def_Id); 14332 14333 if not Has_Pragma_Pure_Function (Def_Id) then 14334 Set_Has_Pragma_Pure_Function (Def_Id); 14335 Effective := True; 14336 end if; 14337 14338 exit when From_Aspect_Specification (N); 14339 E := Homonym (E); 14340 exit when No (E) or else Scope (E) /= Current_Scope; 14341 end loop; 14342 14343 if not Effective 14344 and then Warn_On_Redundant_Constructs 14345 then 14346 Error_Msg_NE 14347 ("pragma Pure_Function on& is redundant?r?", 14348 N, Entity (E_Id)); 14349 end if; 14350 end if; 14351 end Pure_Function; 14352 14353 -------------------- 14354 -- Queuing_Policy -- 14355 -------------------- 14356 14357 -- pragma Queuing_Policy (policy_IDENTIFIER); 14358 14359 when Pragma_Queuing_Policy => declare 14360 QP : Character; 14361 14362 begin 14363 Check_Ada_83_Warning; 14364 Check_Arg_Count (1); 14365 Check_No_Identifiers; 14366 Check_Arg_Is_Queuing_Policy (Arg1); 14367 Check_Valid_Configuration_Pragma; 14368 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 14369 QP := Fold_Upper (Name_Buffer (1)); 14370 14371 if Queuing_Policy /= ' ' 14372 and then Queuing_Policy /= QP 14373 then 14374 Error_Msg_Sloc := Queuing_Policy_Sloc; 14375 Error_Pragma ("queuing policy incompatible with policy#"); 14376 14377 -- Set new policy, but always preserve System_Location since we 14378 -- like the error message with the run time name. 14379 14380 else 14381 Queuing_Policy := QP; 14382 14383 if Queuing_Policy_Sloc /= System_Location then 14384 Queuing_Policy_Sloc := Loc; 14385 end if; 14386 end if; 14387 end; 14388 14389 -------------- 14390 -- Rational -- 14391 -------------- 14392 14393 -- pragma Rational, for compatibility with foreign compiler 14394 14395 when Pragma_Rational => 14396 Set_Rational_Profile; 14397 14398 ----------------------- 14399 -- Relative_Deadline -- 14400 ----------------------- 14401 14402 -- pragma Relative_Deadline (time_span_EXPRESSION); 14403 14404 when Pragma_Relative_Deadline => Relative_Deadline : declare 14405 P : constant Node_Id := Parent (N); 14406 Arg : Node_Id; 14407 14408 begin 14409 Ada_2005_Pragma; 14410 Check_No_Identifiers; 14411 Check_Arg_Count (1); 14412 14413 Arg := Get_Pragma_Arg (Arg1); 14414 14415 -- The expression must be analyzed in the special manner described 14416 -- in "Handling of Default and Per-Object Expressions" in sem.ads. 14417 14418 Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span)); 14419 14420 -- Subprogram case 14421 14422 if Nkind (P) = N_Subprogram_Body then 14423 Check_In_Main_Program; 14424 14425 -- Only Task and subprogram cases allowed 14426 14427 elsif Nkind (P) /= N_Task_Definition then 14428 Pragma_Misplaced; 14429 end if; 14430 14431 -- Check duplicate pragma before we set the corresponding flag 14432 14433 if Has_Relative_Deadline_Pragma (P) then 14434 Error_Pragma ("duplicate pragma% not allowed"); 14435 end if; 14436 14437 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that 14438 -- Relative_Deadline pragma node cannot be inserted in the Rep 14439 -- Item chain of Ent since it is rewritten by the expander as a 14440 -- procedure call statement that will break the chain. 14441 14442 Set_Has_Relative_Deadline_Pragma (P, True); 14443 end Relative_Deadline; 14444 14445 ------------------------ 14446 -- Remote_Access_Type -- 14447 ------------------------ 14448 14449 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME); 14450 14451 when Pragma_Remote_Access_Type => Remote_Access_Type : declare 14452 E : Entity_Id; 14453 14454 begin 14455 GNAT_Pragma; 14456 Check_Arg_Count (1); 14457 Check_Optional_Identifier (Arg1, Name_Entity); 14458 Check_Arg_Is_Local_Name (Arg1); 14459 14460 E := Entity (Get_Pragma_Arg (Arg1)); 14461 14462 if Nkind (Parent (E)) = N_Formal_Type_Declaration 14463 and then Ekind (E) = E_General_Access_Type 14464 and then Is_Class_Wide_Type (Directly_Designated_Type (E)) 14465 and then Scope (Root_Type (Directly_Designated_Type (E))) 14466 = Scope (E) 14467 and then Is_Valid_Remote_Object_Type 14468 (Root_Type (Directly_Designated_Type (E))) 14469 then 14470 Set_Is_Remote_Types (E); 14471 14472 else 14473 Error_Pragma_Arg 14474 ("pragma% applies only to formal access to classwide types", 14475 Arg1); 14476 end if; 14477 end Remote_Access_Type; 14478 14479 --------------------------- 14480 -- Remote_Call_Interface -- 14481 --------------------------- 14482 14483 -- pragma Remote_Call_Interface [(library_unit_NAME)]; 14484 14485 when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare 14486 Cunit_Node : Node_Id; 14487 Cunit_Ent : Entity_Id; 14488 K : Node_Kind; 14489 14490 begin 14491 Check_Ada_83_Warning; 14492 Check_Valid_Library_Unit_Pragma; 14493 14494 if Nkind (N) = N_Null_Statement then 14495 return; 14496 end if; 14497 14498 Cunit_Node := Cunit (Current_Sem_Unit); 14499 K := Nkind (Unit (Cunit_Node)); 14500 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 14501 14502 if K = N_Package_Declaration 14503 or else K = N_Generic_Package_Declaration 14504 or else K = N_Subprogram_Declaration 14505 or else K = N_Generic_Subprogram_Declaration 14506 or else (K = N_Subprogram_Body 14507 and then Acts_As_Spec (Unit (Cunit_Node))) 14508 then 14509 null; 14510 else 14511 Error_Pragma ( 14512 "pragma% must apply to package or subprogram declaration"); 14513 end if; 14514 14515 Set_Is_Remote_Call_Interface (Cunit_Ent); 14516 end Remote_Call_Interface; 14517 14518 ------------------ 14519 -- Remote_Types -- 14520 ------------------ 14521 14522 -- pragma Remote_Types [(library_unit_NAME)]; 14523 14524 when Pragma_Remote_Types => Remote_Types : declare 14525 Cunit_Node : Node_Id; 14526 Cunit_Ent : Entity_Id; 14527 14528 begin 14529 Check_Ada_83_Warning; 14530 Check_Valid_Library_Unit_Pragma; 14531 14532 if Nkind (N) = N_Null_Statement then 14533 return; 14534 end if; 14535 14536 Cunit_Node := Cunit (Current_Sem_Unit); 14537 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 14538 14539 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 14540 N_Generic_Package_Declaration) 14541 then 14542 Error_Pragma 14543 ("pragma% can only apply to a package declaration"); 14544 end if; 14545 14546 Set_Is_Remote_Types (Cunit_Ent); 14547 end Remote_Types; 14548 14549 --------------- 14550 -- Ravenscar -- 14551 --------------- 14552 14553 -- pragma Ravenscar; 14554 14555 when Pragma_Ravenscar => 14556 GNAT_Pragma; 14557 Check_Arg_Count (0); 14558 Check_Valid_Configuration_Pragma; 14559 Set_Ravenscar_Profile (N); 14560 14561 if Warn_On_Obsolescent_Feature then 14562 Error_Msg_N 14563 ("pragma Ravenscar is an obsolescent feature?j?", N); 14564 Error_Msg_N 14565 ("|use pragma Profile (Ravenscar) instead?j?", N); 14566 end if; 14567 14568 ------------------------- 14569 -- Restricted_Run_Time -- 14570 ------------------------- 14571 14572 -- pragma Restricted_Run_Time; 14573 14574 when Pragma_Restricted_Run_Time => 14575 GNAT_Pragma; 14576 Check_Arg_Count (0); 14577 Check_Valid_Configuration_Pragma; 14578 Set_Profile_Restrictions 14579 (Restricted, N, Warn => Treat_Restrictions_As_Warnings); 14580 14581 if Warn_On_Obsolescent_Feature then 14582 Error_Msg_N 14583 ("pragma Restricted_Run_Time is an obsolescent feature?j?", 14584 N); 14585 Error_Msg_N 14586 ("|use pragma Profile (Restricted) instead?j?", N); 14587 end if; 14588 14589 ------------------ 14590 -- Restrictions -- 14591 ------------------ 14592 14593 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 14594 14595 -- RESTRICTION ::= 14596 -- restriction_IDENTIFIER 14597 -- | restriction_parameter_IDENTIFIER => EXPRESSION 14598 14599 when Pragma_Restrictions => 14600 Process_Restrictions_Or_Restriction_Warnings 14601 (Warn => Treat_Restrictions_As_Warnings); 14602 14603 -------------------------- 14604 -- Restriction_Warnings -- 14605 -------------------------- 14606 14607 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 14608 14609 -- RESTRICTION ::= 14610 -- restriction_IDENTIFIER 14611 -- | restriction_parameter_IDENTIFIER => EXPRESSION 14612 14613 when Pragma_Restriction_Warnings => 14614 GNAT_Pragma; 14615 Process_Restrictions_Or_Restriction_Warnings (Warn => True); 14616 14617 ---------------- 14618 -- Reviewable -- 14619 ---------------- 14620 14621 -- pragma Reviewable; 14622 14623 when Pragma_Reviewable => 14624 Check_Ada_83_Warning; 14625 Check_Arg_Count (0); 14626 14627 -- Call dummy debugging function rv. This is done to assist front 14628 -- end debugging. By placing a Reviewable pragma in the source 14629 -- program, a breakpoint on rv catches this place in the source, 14630 -- allowing convenient stepping to the point of interest. 14631 14632 rv; 14633 14634 -------------------------- 14635 -- Short_Circuit_And_Or -- 14636 -------------------------- 14637 14638 when Pragma_Short_Circuit_And_Or => 14639 GNAT_Pragma; 14640 Check_Arg_Count (0); 14641 Check_Valid_Configuration_Pragma; 14642 Short_Circuit_And_Or := True; 14643 14644 ------------------- 14645 -- Share_Generic -- 14646 ------------------- 14647 14648 -- pragma Share_Generic (NAME {, NAME}); 14649 14650 when Pragma_Share_Generic => 14651 GNAT_Pragma; 14652 Process_Generic_List; 14653 14654 ------------ 14655 -- Shared -- 14656 ------------ 14657 14658 -- pragma Shared (LOCAL_NAME); 14659 14660 when Pragma_Shared => 14661 GNAT_Pragma; 14662 Process_Atomic_Shared_Volatile; 14663 14664 -------------------- 14665 -- Shared_Passive -- 14666 -------------------- 14667 14668 -- pragma Shared_Passive [(library_unit_NAME)]; 14669 14670 -- Set the flag Is_Shared_Passive of program unit name entity 14671 14672 when Pragma_Shared_Passive => Shared_Passive : declare 14673 Cunit_Node : Node_Id; 14674 Cunit_Ent : Entity_Id; 14675 14676 begin 14677 Check_Ada_83_Warning; 14678 Check_Valid_Library_Unit_Pragma; 14679 14680 if Nkind (N) = N_Null_Statement then 14681 return; 14682 end if; 14683 14684 Cunit_Node := Cunit (Current_Sem_Unit); 14685 Cunit_Ent := Cunit_Entity (Current_Sem_Unit); 14686 14687 if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration, 14688 N_Generic_Package_Declaration) 14689 then 14690 Error_Pragma 14691 ("pragma% can only apply to a package declaration"); 14692 end if; 14693 14694 Set_Is_Shared_Passive (Cunit_Ent); 14695 end Shared_Passive; 14696 14697 ----------------------- 14698 -- Short_Descriptors -- 14699 ----------------------- 14700 14701 -- pragma Short_Descriptors; 14702 14703 when Pragma_Short_Descriptors => 14704 GNAT_Pragma; 14705 Check_Arg_Count (0); 14706 Check_Valid_Configuration_Pragma; 14707 Short_Descriptors := True; 14708 14709 ------------------------------ 14710 -- Simple_Storage_Pool_Type -- 14711 ------------------------------ 14712 14713 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME); 14714 14715 when Pragma_Simple_Storage_Pool_Type => 14716 Simple_Storage_Pool_Type : declare 14717 Type_Id : Node_Id; 14718 Typ : Entity_Id; 14719 14720 begin 14721 GNAT_Pragma; 14722 Check_Arg_Count (1); 14723 Check_Arg_Is_Library_Level_Local_Name (Arg1); 14724 14725 Type_Id := Get_Pragma_Arg (Arg1); 14726 Find_Type (Type_Id); 14727 Typ := Entity (Type_Id); 14728 14729 if Typ = Any_Type then 14730 return; 14731 end if; 14732 14733 -- We require the pragma to apply to a type declared in a package 14734 -- declaration, but not (immediately) within a package body. 14735 14736 if Ekind (Current_Scope) /= E_Package 14737 or else In_Package_Body (Current_Scope) 14738 then 14739 Error_Pragma 14740 ("pragma% can only apply to type declared immediately " & 14741 "within a package declaration"); 14742 end if; 14743 14744 -- A simple storage pool type must be an immutably limited record 14745 -- or private type. If the pragma is given for a private type, 14746 -- the full type is similarly restricted (which is checked later 14747 -- in Freeze_Entity). 14748 14749 if Is_Record_Type (Typ) 14750 and then not Is_Immutably_Limited_Type (Typ) 14751 then 14752 Error_Pragma 14753 ("pragma% can only apply to explicitly limited record type"); 14754 14755 elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then 14756 Error_Pragma 14757 ("pragma% can only apply to a private type that is limited"); 14758 14759 elsif not Is_Record_Type (Typ) 14760 and then not Is_Private_Type (Typ) 14761 then 14762 Error_Pragma 14763 ("pragma% can only apply to limited record or private type"); 14764 end if; 14765 14766 Record_Rep_Item (Typ, N); 14767 end Simple_Storage_Pool_Type; 14768 14769 ---------------------- 14770 -- Source_File_Name -- 14771 ---------------------- 14772 14773 -- There are five forms for this pragma: 14774 14775 -- pragma Source_File_Name ( 14776 -- [UNIT_NAME =>] unit_NAME, 14777 -- BODY_FILE_NAME => STRING_LITERAL 14778 -- [, [INDEX =>] INTEGER_LITERAL]); 14779 14780 -- pragma Source_File_Name ( 14781 -- [UNIT_NAME =>] unit_NAME, 14782 -- SPEC_FILE_NAME => STRING_LITERAL 14783 -- [, [INDEX =>] INTEGER_LITERAL]); 14784 14785 -- pragma Source_File_Name ( 14786 -- BODY_FILE_NAME => STRING_LITERAL 14787 -- [, DOT_REPLACEMENT => STRING_LITERAL] 14788 -- [, CASING => CASING_SPEC]); 14789 14790 -- pragma Source_File_Name ( 14791 -- SPEC_FILE_NAME => STRING_LITERAL 14792 -- [, DOT_REPLACEMENT => STRING_LITERAL] 14793 -- [, CASING => CASING_SPEC]); 14794 14795 -- pragma Source_File_Name ( 14796 -- SUBUNIT_FILE_NAME => STRING_LITERAL 14797 -- [, DOT_REPLACEMENT => STRING_LITERAL] 14798 -- [, CASING => CASING_SPEC]); 14799 14800 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 14801 14802 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 14803 -- Source_File_Name (SFN), however their usage is exclusive: SFN can 14804 -- only be used when no project file is used, while SFNP can only be 14805 -- used when a project file is used. 14806 14807 -- No processing here. Processing was completed during parsing, since 14808 -- we need to have file names set as early as possible. Units are 14809 -- loaded well before semantic processing starts. 14810 14811 -- The only processing we defer to this point is the check for 14812 -- correct placement. 14813 14814 when Pragma_Source_File_Name => 14815 GNAT_Pragma; 14816 Check_Valid_Configuration_Pragma; 14817 14818 ------------------------------ 14819 -- Source_File_Name_Project -- 14820 ------------------------------ 14821 14822 -- See Source_File_Name for syntax 14823 14824 -- No processing here. Processing was completed during parsing, since 14825 -- we need to have file names set as early as possible. Units are 14826 -- loaded well before semantic processing starts. 14827 14828 -- The only processing we defer to this point is the check for 14829 -- correct placement. 14830 14831 when Pragma_Source_File_Name_Project => 14832 GNAT_Pragma; 14833 Check_Valid_Configuration_Pragma; 14834 14835 -- Check that a pragma Source_File_Name_Project is used only in a 14836 -- configuration pragmas file. 14837 14838 -- Pragmas Source_File_Name_Project should only be generated by 14839 -- the Project Manager in configuration pragmas files. 14840 14841 -- This is really an ugly test. It seems to depend on some 14842 -- accidental and undocumented property. At the very least it 14843 -- needs to be documented, but it would be better to have a 14844 -- clean way of testing if we are in a configuration file??? 14845 14846 if Present (Parent (N)) then 14847 Error_Pragma 14848 ("pragma% can only appear in a configuration pragmas file"); 14849 end if; 14850 14851 ---------------------- 14852 -- Source_Reference -- 14853 ---------------------- 14854 14855 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]); 14856 14857 -- Nothing to do, all processing completed in Par.Prag, since we need 14858 -- the information for possible parser messages that are output. 14859 14860 when Pragma_Source_Reference => 14861 GNAT_Pragma; 14862 14863 -------------------------------- 14864 -- Static_Elaboration_Desired -- 14865 -------------------------------- 14866 14867 -- pragma Static_Elaboration_Desired (DIRECT_NAME); 14868 14869 when Pragma_Static_Elaboration_Desired => 14870 GNAT_Pragma; 14871 Check_At_Most_N_Arguments (1); 14872 14873 if Is_Compilation_Unit (Current_Scope) 14874 and then Ekind (Current_Scope) = E_Package 14875 then 14876 Set_Static_Elaboration_Desired (Current_Scope, True); 14877 else 14878 Error_Pragma ("pragma% must apply to a library-level package"); 14879 end if; 14880 14881 ------------------ 14882 -- Storage_Size -- 14883 ------------------ 14884 14885 -- pragma Storage_Size (EXPRESSION); 14886 14887 when Pragma_Storage_Size => Storage_Size : declare 14888 P : constant Node_Id := Parent (N); 14889 Arg : Node_Id; 14890 14891 begin 14892 Check_No_Identifiers; 14893 Check_Arg_Count (1); 14894 14895 -- The expression must be analyzed in the special manner described 14896 -- in "Handling of Default Expressions" in sem.ads. 14897 14898 Arg := Get_Pragma_Arg (Arg1); 14899 Preanalyze_Spec_Expression (Arg, Any_Integer); 14900 14901 if not Is_Static_Expression (Arg) then 14902 Check_Restriction (Static_Storage_Size, Arg); 14903 end if; 14904 14905 if Nkind (P) /= N_Task_Definition then 14906 Pragma_Misplaced; 14907 return; 14908 14909 else 14910 if Has_Storage_Size_Pragma (P) then 14911 Error_Pragma ("duplicate pragma% not allowed"); 14912 else 14913 Set_Has_Storage_Size_Pragma (P, True); 14914 end if; 14915 14916 Record_Rep_Item (Defining_Identifier (Parent (P)), N); 14917 end if; 14918 end Storage_Size; 14919 14920 ------------------ 14921 -- Storage_Unit -- 14922 ------------------ 14923 14924 -- pragma Storage_Unit (NUMERIC_LITERAL); 14925 14926 -- Only permitted argument is System'Storage_Unit value 14927 14928 when Pragma_Storage_Unit => 14929 Check_No_Identifiers; 14930 Check_Arg_Count (1); 14931 Check_Arg_Is_Integer_Literal (Arg1); 14932 14933 if Intval (Get_Pragma_Arg (Arg1)) /= 14934 UI_From_Int (Ttypes.System_Storage_Unit) 14935 then 14936 Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit); 14937 Error_Pragma_Arg 14938 ("the only allowed argument for pragma% is ^", Arg1); 14939 end if; 14940 14941 -------------------- 14942 -- Stream_Convert -- 14943 -------------------- 14944 14945 -- pragma Stream_Convert ( 14946 -- [Entity =>] type_LOCAL_NAME, 14947 -- [Read =>] function_NAME, 14948 -- [Write =>] function NAME); 14949 14950 when Pragma_Stream_Convert => Stream_Convert : declare 14951 14952 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id); 14953 -- Check that the given argument is the name of a local function 14954 -- of one argument that is not overloaded earlier in the current 14955 -- local scope. A check is also made that the argument is a 14956 -- function with one parameter. 14957 14958 -------------------------------------- 14959 -- Check_OK_Stream_Convert_Function -- 14960 -------------------------------------- 14961 14962 procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is 14963 Ent : Entity_Id; 14964 14965 begin 14966 Check_Arg_Is_Local_Name (Arg); 14967 Ent := Entity (Get_Pragma_Arg (Arg)); 14968 14969 if Has_Homonym (Ent) then 14970 Error_Pragma_Arg 14971 ("argument for pragma% may not be overloaded", Arg); 14972 end if; 14973 14974 if Ekind (Ent) /= E_Function 14975 or else No (First_Formal (Ent)) 14976 or else Present (Next_Formal (First_Formal (Ent))) 14977 then 14978 Error_Pragma_Arg 14979 ("argument for pragma% must be" & 14980 " function of one argument", Arg); 14981 end if; 14982 end Check_OK_Stream_Convert_Function; 14983 14984 -- Start of processing for Stream_Convert 14985 14986 begin 14987 GNAT_Pragma; 14988 Check_Arg_Order ((Name_Entity, Name_Read, Name_Write)); 14989 Check_Arg_Count (3); 14990 Check_Optional_Identifier (Arg1, Name_Entity); 14991 Check_Optional_Identifier (Arg2, Name_Read); 14992 Check_Optional_Identifier (Arg3, Name_Write); 14993 Check_Arg_Is_Local_Name (Arg1); 14994 Check_OK_Stream_Convert_Function (Arg2); 14995 Check_OK_Stream_Convert_Function (Arg3); 14996 14997 declare 14998 Typ : constant Entity_Id := 14999 Underlying_Type (Entity (Get_Pragma_Arg (Arg1))); 15000 Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2)); 15001 Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3)); 15002 15003 begin 15004 Check_First_Subtype (Arg1); 15005 15006 -- Check for too early or too late. Note that we don't enforce 15007 -- the rule about primitive operations in this case, since, as 15008 -- is the case for explicit stream attributes themselves, these 15009 -- restrictions are not appropriate. Note that the chaining of 15010 -- the pragma by Rep_Item_Too_Late is actually the critical 15011 -- processing done for this pragma. 15012 15013 if Rep_Item_Too_Early (Typ, N) 15014 or else 15015 Rep_Item_Too_Late (Typ, N, FOnly => True) 15016 then 15017 return; 15018 end if; 15019 15020 -- Return if previous error 15021 15022 if Etype (Typ) = Any_Type 15023 or else 15024 Etype (Read) = Any_Type 15025 or else 15026 Etype (Write) = Any_Type 15027 then 15028 return; 15029 end if; 15030 15031 -- Error checks 15032 15033 if Underlying_Type (Etype (Read)) /= Typ then 15034 Error_Pragma_Arg 15035 ("incorrect return type for function&", Arg2); 15036 end if; 15037 15038 if Underlying_Type (Etype (First_Formal (Write))) /= Typ then 15039 Error_Pragma_Arg 15040 ("incorrect parameter type for function&", Arg3); 15041 end if; 15042 15043 if Underlying_Type (Etype (First_Formal (Read))) /= 15044 Underlying_Type (Etype (Write)) 15045 then 15046 Error_Pragma_Arg 15047 ("result type of & does not match Read parameter type", 15048 Arg3); 15049 end if; 15050 end; 15051 end Stream_Convert; 15052 15053 ------------------ 15054 -- Style_Checks -- 15055 ------------------ 15056 15057 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 15058 15059 -- This is processed by the parser since some of the style checks 15060 -- take place during source scanning and parsing. This means that 15061 -- we don't need to issue error messages here. 15062 15063 when Pragma_Style_Checks => Style_Checks : declare 15064 A : constant Node_Id := Get_Pragma_Arg (Arg1); 15065 S : String_Id; 15066 C : Char_Code; 15067 15068 begin 15069 GNAT_Pragma; 15070 Check_No_Identifiers; 15071 15072 -- Two argument form 15073 15074 if Arg_Count = 2 then 15075 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 15076 15077 declare 15078 E_Id : Node_Id; 15079 E : Entity_Id; 15080 15081 begin 15082 E_Id := Get_Pragma_Arg (Arg2); 15083 Analyze (E_Id); 15084 15085 if not Is_Entity_Name (E_Id) then 15086 Error_Pragma_Arg 15087 ("second argument of pragma% must be entity name", 15088 Arg2); 15089 end if; 15090 15091 E := Entity (E_Id); 15092 15093 if not Ignore_Style_Checks_Pragmas then 15094 if E = Any_Id then 15095 return; 15096 else 15097 loop 15098 Set_Suppress_Style_Checks 15099 (E, Chars (Get_Pragma_Arg (Arg1)) = Name_Off); 15100 exit when No (Homonym (E)); 15101 E := Homonym (E); 15102 end loop; 15103 end if; 15104 end if; 15105 end; 15106 15107 -- One argument form 15108 15109 else 15110 Check_Arg_Count (1); 15111 15112 if Nkind (A) = N_String_Literal then 15113 S := Strval (A); 15114 15115 declare 15116 Slen : constant Natural := Natural (String_Length (S)); 15117 Options : String (1 .. Slen); 15118 J : Natural; 15119 15120 begin 15121 J := 1; 15122 loop 15123 C := Get_String_Char (S, Int (J)); 15124 exit when not In_Character_Range (C); 15125 Options (J) := Get_Character (C); 15126 15127 -- If at end of string, set options. As per discussion 15128 -- above, no need to check for errors, since we issued 15129 -- them in the parser. 15130 15131 if J = Slen then 15132 if not Ignore_Style_Checks_Pragmas then 15133 Set_Style_Check_Options (Options); 15134 end if; 15135 15136 exit; 15137 end if; 15138 15139 J := J + 1; 15140 end loop; 15141 end; 15142 15143 elsif Nkind (A) = N_Identifier then 15144 if Chars (A) = Name_All_Checks then 15145 if not Ignore_Style_Checks_Pragmas then 15146 if GNAT_Mode then 15147 Set_GNAT_Style_Check_Options; 15148 else 15149 Set_Default_Style_Check_Options; 15150 end if; 15151 end if; 15152 15153 elsif Chars (A) = Name_On then 15154 if not Ignore_Style_Checks_Pragmas then 15155 Style_Check := True; 15156 end if; 15157 15158 elsif Chars (A) = Name_Off then 15159 if not Ignore_Style_Checks_Pragmas then 15160 Style_Check := False; 15161 end if; 15162 end if; 15163 end if; 15164 end if; 15165 end Style_Checks; 15166 15167 -------------- 15168 -- Subtitle -- 15169 -------------- 15170 15171 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL); 15172 15173 when Pragma_Subtitle => 15174 GNAT_Pragma; 15175 Check_Arg_Count (1); 15176 Check_Optional_Identifier (Arg1, Name_Subtitle); 15177 Check_Arg_Is_Static_Expression (Arg1, Standard_String); 15178 Store_Note (N); 15179 15180 -------------- 15181 -- Suppress -- 15182 -------------- 15183 15184 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]); 15185 15186 when Pragma_Suppress => 15187 Process_Suppress_Unsuppress (True); 15188 15189 ------------------ 15190 -- Suppress_All -- 15191 ------------------ 15192 15193 -- pragma Suppress_All; 15194 15195 -- The only check made here is that the pragma has no arguments. 15196 -- There are no placement rules, and the processing required (setting 15197 -- the Has_Pragma_Suppress_All flag in the compilation unit node was 15198 -- taken care of by the parser). Process_Compilation_Unit_Pragmas 15199 -- then creates and inserts a pragma Suppress (All_Checks). 15200 15201 when Pragma_Suppress_All => 15202 GNAT_Pragma; 15203 Check_Arg_Count (0); 15204 15205 ------------------------- 15206 -- Suppress_Debug_Info -- 15207 ------------------------- 15208 15209 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME); 15210 15211 when Pragma_Suppress_Debug_Info => 15212 GNAT_Pragma; 15213 Check_Arg_Count (1); 15214 Check_Optional_Identifier (Arg1, Name_Entity); 15215 Check_Arg_Is_Local_Name (Arg1); 15216 Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1))); 15217 15218 ---------------------------------- 15219 -- Suppress_Exception_Locations -- 15220 ---------------------------------- 15221 15222 -- pragma Suppress_Exception_Locations; 15223 15224 when Pragma_Suppress_Exception_Locations => 15225 GNAT_Pragma; 15226 Check_Arg_Count (0); 15227 Check_Valid_Configuration_Pragma; 15228 Exception_Locations_Suppressed := True; 15229 15230 ----------------------------- 15231 -- Suppress_Initialization -- 15232 ----------------------------- 15233 15234 -- pragma Suppress_Initialization ([Entity =>] type_Name); 15235 15236 when Pragma_Suppress_Initialization => Suppress_Init : declare 15237 E_Id : Node_Id; 15238 E : Entity_Id; 15239 15240 begin 15241 GNAT_Pragma; 15242 Check_Arg_Count (1); 15243 Check_Optional_Identifier (Arg1, Name_Entity); 15244 Check_Arg_Is_Local_Name (Arg1); 15245 15246 E_Id := Get_Pragma_Arg (Arg1); 15247 15248 if Etype (E_Id) = Any_Type then 15249 return; 15250 end if; 15251 15252 E := Entity (E_Id); 15253 15254 if not Is_Type (E) then 15255 Error_Pragma_Arg ("pragma% requires type or subtype", Arg1); 15256 end if; 15257 15258 if Rep_Item_Too_Early (E, N) 15259 or else 15260 Rep_Item_Too_Late (E, N, FOnly => True) 15261 then 15262 return; 15263 end if; 15264 15265 -- For incomplete/private type, set flag on full view 15266 15267 if Is_Incomplete_Or_Private_Type (E) then 15268 if No (Full_View (Base_Type (E))) then 15269 Error_Pragma_Arg 15270 ("argument of pragma% cannot be an incomplete type", Arg1); 15271 else 15272 Set_Suppress_Initialization (Full_View (Base_Type (E))); 15273 end if; 15274 15275 -- For first subtype, set flag on base type 15276 15277 elsif Is_First_Subtype (E) then 15278 Set_Suppress_Initialization (Base_Type (E)); 15279 15280 -- For other than first subtype, set flag on subtype itself 15281 15282 else 15283 Set_Suppress_Initialization (E); 15284 end if; 15285 end Suppress_Init; 15286 15287 ----------------- 15288 -- System_Name -- 15289 ----------------- 15290 15291 -- pragma System_Name (DIRECT_NAME); 15292 15293 -- Syntax check: one argument, which must be the identifier GNAT or 15294 -- the identifier GCC, no other identifiers are acceptable. 15295 15296 when Pragma_System_Name => 15297 GNAT_Pragma; 15298 Check_No_Identifiers; 15299 Check_Arg_Count (1); 15300 Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat); 15301 15302 ----------------------------- 15303 -- Task_Dispatching_Policy -- 15304 ----------------------------- 15305 15306 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER); 15307 15308 when Pragma_Task_Dispatching_Policy => declare 15309 DP : Character; 15310 15311 begin 15312 Check_Ada_83_Warning; 15313 Check_Arg_Count (1); 15314 Check_No_Identifiers; 15315 Check_Arg_Is_Task_Dispatching_Policy (Arg1); 15316 Check_Valid_Configuration_Pragma; 15317 Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); 15318 DP := Fold_Upper (Name_Buffer (1)); 15319 15320 if Task_Dispatching_Policy /= ' ' 15321 and then Task_Dispatching_Policy /= DP 15322 then 15323 Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; 15324 Error_Pragma 15325 ("task dispatching policy incompatible with policy#"); 15326 15327 -- Set new policy, but always preserve System_Location since we 15328 -- like the error message with the run time name. 15329 15330 else 15331 Task_Dispatching_Policy := DP; 15332 15333 if Task_Dispatching_Policy_Sloc /= System_Location then 15334 Task_Dispatching_Policy_Sloc := Loc; 15335 end if; 15336 end if; 15337 end; 15338 15339 --------------- 15340 -- Task_Info -- 15341 --------------- 15342 15343 -- pragma Task_Info (EXPRESSION); 15344 15345 when Pragma_Task_Info => Task_Info : declare 15346 P : constant Node_Id := Parent (N); 15347 Ent : Entity_Id; 15348 15349 begin 15350 GNAT_Pragma; 15351 15352 if Nkind (P) /= N_Task_Definition then 15353 Error_Pragma ("pragma% must appear in task definition"); 15354 end if; 15355 15356 Check_No_Identifiers; 15357 Check_Arg_Count (1); 15358 15359 Analyze_And_Resolve 15360 (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type)); 15361 15362 if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then 15363 return; 15364 end if; 15365 15366 Ent := Defining_Identifier (Parent (P)); 15367 15368 -- Check duplicate pragma before we chain the pragma in the Rep 15369 -- Item chain of Ent. 15370 15371 if Has_Rep_Pragma 15372 (Ent, Name_Task_Info, Check_Parents => False) 15373 then 15374 Error_Pragma ("duplicate pragma% not allowed"); 15375 end if; 15376 15377 Record_Rep_Item (Ent, N); 15378 end Task_Info; 15379 15380 --------------- 15381 -- Task_Name -- 15382 --------------- 15383 15384 -- pragma Task_Name (string_EXPRESSION); 15385 15386 when Pragma_Task_Name => Task_Name : declare 15387 P : constant Node_Id := Parent (N); 15388 Arg : Node_Id; 15389 Ent : Entity_Id; 15390 15391 begin 15392 Check_No_Identifiers; 15393 Check_Arg_Count (1); 15394 15395 Arg := Get_Pragma_Arg (Arg1); 15396 15397 -- The expression is used in the call to Create_Task, and must be 15398 -- expanded there, not in the context of the current spec. It must 15399 -- however be analyzed to capture global references, in case it 15400 -- appears in a generic context. 15401 15402 Preanalyze_And_Resolve (Arg, Standard_String); 15403 15404 if Nkind (P) /= N_Task_Definition then 15405 Pragma_Misplaced; 15406 end if; 15407 15408 Ent := Defining_Identifier (Parent (P)); 15409 15410 -- Check duplicate pragma before we chain the pragma in the Rep 15411 -- Item chain of Ent. 15412 15413 if Has_Rep_Pragma 15414 (Ent, Name_Task_Name, Check_Parents => False) 15415 then 15416 Error_Pragma ("duplicate pragma% not allowed"); 15417 end if; 15418 15419 Record_Rep_Item (Ent, N); 15420 end Task_Name; 15421 15422 ------------------ 15423 -- Task_Storage -- 15424 ------------------ 15425 15426 -- pragma Task_Storage ( 15427 -- [Task_Type =>] LOCAL_NAME, 15428 -- [Top_Guard =>] static_integer_EXPRESSION); 15429 15430 when Pragma_Task_Storage => Task_Storage : declare 15431 Args : Args_List (1 .. 2); 15432 Names : constant Name_List (1 .. 2) := ( 15433 Name_Task_Type, 15434 Name_Top_Guard); 15435 15436 Task_Type : Node_Id renames Args (1); 15437 Top_Guard : Node_Id renames Args (2); 15438 15439 Ent : Entity_Id; 15440 15441 begin 15442 GNAT_Pragma; 15443 Gather_Associations (Names, Args); 15444 15445 if No (Task_Type) then 15446 Error_Pragma 15447 ("missing task_type argument for pragma%"); 15448 end if; 15449 15450 Check_Arg_Is_Local_Name (Task_Type); 15451 15452 Ent := Entity (Task_Type); 15453 15454 if not Is_Task_Type (Ent) then 15455 Error_Pragma_Arg 15456 ("argument for pragma% must be task type", Task_Type); 15457 end if; 15458 15459 if No (Top_Guard) then 15460 Error_Pragma_Arg 15461 ("pragma% takes two arguments", Task_Type); 15462 else 15463 Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer); 15464 end if; 15465 15466 Check_First_Subtype (Task_Type); 15467 15468 if Rep_Item_Too_Late (Ent, N) then 15469 raise Pragma_Exit; 15470 end if; 15471 end Task_Storage; 15472 15473 --------------- 15474 -- Test_Case -- 15475 --------------- 15476 15477 -- pragma Test_Case 15478 -- ([Name =>] Static_String_EXPRESSION 15479 -- ,[Mode =>] MODE_TYPE 15480 -- [, Requires => Boolean_EXPRESSION] 15481 -- [, Ensures => Boolean_EXPRESSION]); 15482 15483 -- MODE_TYPE ::= Nominal | Robustness 15484 15485 when Pragma_Test_Case => 15486 Check_Contract_Or_Test_Case; 15487 15488 -------------------------- 15489 -- Thread_Local_Storage -- 15490 -------------------------- 15491 15492 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME); 15493 15494 when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare 15495 Id : Node_Id; 15496 E : Entity_Id; 15497 15498 begin 15499 GNAT_Pragma; 15500 Check_Arg_Count (1); 15501 Check_Optional_Identifier (Arg1, Name_Entity); 15502 Check_Arg_Is_Library_Level_Local_Name (Arg1); 15503 15504 Id := Get_Pragma_Arg (Arg1); 15505 Analyze (Id); 15506 15507 if not Is_Entity_Name (Id) 15508 or else Ekind (Entity (Id)) /= E_Variable 15509 then 15510 Error_Pragma_Arg ("local variable name required", Arg1); 15511 end if; 15512 15513 E := Entity (Id); 15514 15515 if Rep_Item_Too_Early (E, N) 15516 or else Rep_Item_Too_Late (E, N) 15517 then 15518 raise Pragma_Exit; 15519 end if; 15520 15521 Set_Has_Pragma_Thread_Local_Storage (E); 15522 Set_Has_Gigi_Rep_Item (E); 15523 end Thread_Local_Storage; 15524 15525 ---------------- 15526 -- Time_Slice -- 15527 ---------------- 15528 15529 -- pragma Time_Slice (static_duration_EXPRESSION); 15530 15531 when Pragma_Time_Slice => Time_Slice : declare 15532 Val : Ureal; 15533 Nod : Node_Id; 15534 15535 begin 15536 GNAT_Pragma; 15537 Check_Arg_Count (1); 15538 Check_No_Identifiers; 15539 Check_In_Main_Program; 15540 Check_Arg_Is_Static_Expression (Arg1, Standard_Duration); 15541 15542 if not Error_Posted (Arg1) then 15543 Nod := Next (N); 15544 while Present (Nod) loop 15545 if Nkind (Nod) = N_Pragma 15546 and then Pragma_Name (Nod) = Name_Time_Slice 15547 then 15548 Error_Msg_Name_1 := Pname; 15549 Error_Msg_N ("duplicate pragma% not permitted", Nod); 15550 end if; 15551 15552 Next (Nod); 15553 end loop; 15554 end if; 15555 15556 -- Process only if in main unit 15557 15558 if Get_Source_Unit (Loc) = Main_Unit then 15559 Opt.Time_Slice_Set := True; 15560 Val := Expr_Value_R (Get_Pragma_Arg (Arg1)); 15561 15562 if Val <= Ureal_0 then 15563 Opt.Time_Slice_Value := 0; 15564 15565 elsif Val > UR_From_Uint (UI_From_Int (1000)) then 15566 Opt.Time_Slice_Value := 1_000_000_000; 15567 15568 else 15569 Opt.Time_Slice_Value := 15570 UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000))); 15571 end if; 15572 end if; 15573 end Time_Slice; 15574 15575 ----------- 15576 -- Title -- 15577 ----------- 15578 15579 -- pragma Title (TITLING_OPTION [, TITLING OPTION]); 15580 15581 -- TITLING_OPTION ::= 15582 -- [Title =>] STRING_LITERAL 15583 -- | [Subtitle =>] STRING_LITERAL 15584 15585 when Pragma_Title => Title : declare 15586 Args : Args_List (1 .. 2); 15587 Names : constant Name_List (1 .. 2) := ( 15588 Name_Title, 15589 Name_Subtitle); 15590 15591 begin 15592 GNAT_Pragma; 15593 Gather_Associations (Names, Args); 15594 Store_Note (N); 15595 15596 for J in 1 .. 2 loop 15597 if Present (Args (J)) then 15598 Check_Arg_Is_Static_Expression (Args (J), Standard_String); 15599 end if; 15600 end loop; 15601 end Title; 15602 15603 --------------------- 15604 -- Unchecked_Union -- 15605 --------------------- 15606 15607 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) 15608 15609 when Pragma_Unchecked_Union => Unchecked_Union : declare 15610 Assoc : constant Node_Id := Arg1; 15611 Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc); 15612 Typ : Entity_Id; 15613 Tdef : Node_Id; 15614 Clist : Node_Id; 15615 Vpart : Node_Id; 15616 Comp : Node_Id; 15617 Variant : Node_Id; 15618 15619 begin 15620 Ada_2005_Pragma; 15621 Check_No_Identifiers; 15622 Check_Arg_Count (1); 15623 Check_Arg_Is_Local_Name (Arg1); 15624 15625 Find_Type (Type_Id); 15626 15627 Typ := Entity (Type_Id); 15628 15629 if Typ = Any_Type 15630 or else Rep_Item_Too_Early (Typ, N) 15631 then 15632 return; 15633 else 15634 Typ := Underlying_Type (Typ); 15635 end if; 15636 15637 if Rep_Item_Too_Late (Typ, N) then 15638 return; 15639 end if; 15640 15641 Check_First_Subtype (Arg1); 15642 15643 -- Note remaining cases are references to a type in the current 15644 -- declarative part. If we find an error, we post the error on 15645 -- the relevant type declaration at an appropriate point. 15646 15647 if not Is_Record_Type (Typ) then 15648 Error_Msg_N ("unchecked union must be record type", Typ); 15649 return; 15650 15651 elsif Is_Tagged_Type (Typ) then 15652 Error_Msg_N ("unchecked union must not be tagged", Typ); 15653 return; 15654 15655 elsif not Has_Discriminants (Typ) then 15656 Error_Msg_N 15657 ("unchecked union must have one discriminant", Typ); 15658 return; 15659 15660 -- Note: in previous versions of GNAT we used to check for limited 15661 -- types and give an error, but in fact the standard does allow 15662 -- Unchecked_Union on limited types, so this check was removed. 15663 15664 -- Similarly, GNAT used to require that all discriminants have 15665 -- default values, but this is not mandated by the RM. 15666 15667 -- Proceed with basic error checks completed 15668 15669 else 15670 Tdef := Type_Definition (Declaration_Node (Typ)); 15671 Clist := Component_List (Tdef); 15672 15673 -- Check presence of component list and variant part 15674 15675 if No (Clist) or else No (Variant_Part (Clist)) then 15676 Error_Msg_N 15677 ("unchecked union must have variant part", Tdef); 15678 return; 15679 end if; 15680 15681 -- Check components 15682 15683 Comp := First (Component_Items (Clist)); 15684 while Present (Comp) loop 15685 Check_Component (Comp, Typ); 15686 Next (Comp); 15687 end loop; 15688 15689 -- Check variant part 15690 15691 Vpart := Variant_Part (Clist); 15692 15693 Variant := First (Variants (Vpart)); 15694 while Present (Variant) loop 15695 Check_Variant (Variant, Typ); 15696 Next (Variant); 15697 end loop; 15698 end if; 15699 15700 Set_Is_Unchecked_Union (Typ); 15701 Set_Convention (Typ, Convention_C); 15702 Set_Has_Unchecked_Union (Base_Type (Typ)); 15703 Set_Is_Unchecked_Union (Base_Type (Typ)); 15704 end Unchecked_Union; 15705 15706 ------------------------ 15707 -- Unimplemented_Unit -- 15708 ------------------------ 15709 15710 -- pragma Unimplemented_Unit; 15711 15712 -- Note: this only gives an error if we are generating code, or if 15713 -- we are in a generic library unit (where the pragma appears in the 15714 -- body, not in the spec). 15715 15716 when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare 15717 Cunitent : constant Entity_Id := 15718 Cunit_Entity (Get_Source_Unit (Loc)); 15719 Ent_Kind : constant Entity_Kind := 15720 Ekind (Cunitent); 15721 15722 begin 15723 GNAT_Pragma; 15724 Check_Arg_Count (0); 15725 15726 if Operating_Mode = Generate_Code 15727 or else Ent_Kind = E_Generic_Function 15728 or else Ent_Kind = E_Generic_Procedure 15729 or else Ent_Kind = E_Generic_Package 15730 then 15731 Get_Name_String (Chars (Cunitent)); 15732 Set_Casing (Mixed_Case); 15733 Write_Str (Name_Buffer (1 .. Name_Len)); 15734 Write_Str (" is not supported in this configuration"); 15735 Write_Eol; 15736 raise Unrecoverable_Error; 15737 end if; 15738 end Unimplemented_Unit; 15739 15740 ------------------------ 15741 -- Universal_Aliasing -- 15742 ------------------------ 15743 15744 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)]; 15745 15746 when Pragma_Universal_Aliasing => Universal_Alias : declare 15747 E_Id : Entity_Id; 15748 15749 begin 15750 GNAT_Pragma; 15751 Check_Arg_Count (1); 15752 Check_Optional_Identifier (Arg2, Name_Entity); 15753 Check_Arg_Is_Local_Name (Arg1); 15754 E_Id := Entity (Get_Pragma_Arg (Arg1)); 15755 15756 if E_Id = Any_Type then 15757 return; 15758 elsif No (E_Id) or else not Is_Type (E_Id) then 15759 Error_Pragma_Arg ("pragma% requires type", Arg1); 15760 end if; 15761 15762 Set_Universal_Aliasing (Implementation_Base_Type (E_Id)); 15763 Record_Rep_Item (E_Id, N); 15764 end Universal_Alias; 15765 15766 -------------------- 15767 -- Universal_Data -- 15768 -------------------- 15769 15770 -- pragma Universal_Data [(library_unit_NAME)]; 15771 15772 when Pragma_Universal_Data => 15773 GNAT_Pragma; 15774 15775 -- If this is a configuration pragma, then set the universal 15776 -- addressing option, otherwise confirm that the pragma satisfies 15777 -- the requirements of library unit pragma placement and leave it 15778 -- to the GNAAMP back end to detect the pragma (avoids transitive 15779 -- setting of the option due to withed units). 15780 15781 if Is_Configuration_Pragma then 15782 Universal_Addressing_On_AAMP := True; 15783 else 15784 Check_Valid_Library_Unit_Pragma; 15785 end if; 15786 15787 if not AAMP_On_Target then 15788 Error_Pragma ("??pragma% ignored (applies only to AAMP)"); 15789 end if; 15790 15791 ---------------- 15792 -- Unmodified -- 15793 ---------------- 15794 15795 -- pragma Unmodified (local_Name {, local_Name}); 15796 15797 when Pragma_Unmodified => Unmodified : declare 15798 Arg_Node : Node_Id; 15799 Arg_Expr : Node_Id; 15800 Arg_Ent : Entity_Id; 15801 15802 begin 15803 GNAT_Pragma; 15804 Check_At_Least_N_Arguments (1); 15805 15806 -- Loop through arguments 15807 15808 Arg_Node := Arg1; 15809 while Present (Arg_Node) loop 15810 Check_No_Identifier (Arg_Node); 15811 15812 -- Note: the analyze call done by Check_Arg_Is_Local_Name will 15813 -- in fact generate reference, so that the entity will have a 15814 -- reference, which will inhibit any warnings about it not 15815 -- being referenced, and also properly show up in the ali file 15816 -- as a reference. But this reference is recorded before the 15817 -- Has_Pragma_Unreferenced flag is set, so that no warning is 15818 -- generated for this reference. 15819 15820 Check_Arg_Is_Local_Name (Arg_Node); 15821 Arg_Expr := Get_Pragma_Arg (Arg_Node); 15822 15823 if Is_Entity_Name (Arg_Expr) then 15824 Arg_Ent := Entity (Arg_Expr); 15825 15826 if not Is_Assignable (Arg_Ent) then 15827 Error_Pragma_Arg 15828 ("pragma% can only be applied to a variable", 15829 Arg_Expr); 15830 else 15831 Set_Has_Pragma_Unmodified (Arg_Ent); 15832 end if; 15833 end if; 15834 15835 Next (Arg_Node); 15836 end loop; 15837 end Unmodified; 15838 15839 ------------------ 15840 -- Unreferenced -- 15841 ------------------ 15842 15843 -- pragma Unreferenced (local_Name {, local_Name}); 15844 15845 -- or when used in a context clause: 15846 15847 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME} 15848 15849 when Pragma_Unreferenced => Unreferenced : declare 15850 Arg_Node : Node_Id; 15851 Arg_Expr : Node_Id; 15852 Arg_Ent : Entity_Id; 15853 Citem : Node_Id; 15854 15855 begin 15856 GNAT_Pragma; 15857 Check_At_Least_N_Arguments (1); 15858 15859 -- Check case of appearing within context clause 15860 15861 if Is_In_Context_Clause then 15862 15863 -- The arguments must all be units mentioned in a with clause 15864 -- in the same context clause. Note we already checked (in 15865 -- Par.Prag) that the arguments are either identifiers or 15866 -- selected components. 15867 15868 Arg_Node := Arg1; 15869 while Present (Arg_Node) loop 15870 Citem := First (List_Containing (N)); 15871 while Citem /= N loop 15872 if Nkind (Citem) = N_With_Clause 15873 and then 15874 Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node)) 15875 then 15876 Set_Has_Pragma_Unreferenced 15877 (Cunit_Entity 15878 (Get_Source_Unit 15879 (Library_Unit (Citem)))); 15880 Set_Unit_Name 15881 (Get_Pragma_Arg (Arg_Node), Name (Citem)); 15882 exit; 15883 end if; 15884 15885 Next (Citem); 15886 end loop; 15887 15888 if Citem = N then 15889 Error_Pragma_Arg 15890 ("argument of pragma% is not withed unit", Arg_Node); 15891 end if; 15892 15893 Next (Arg_Node); 15894 end loop; 15895 15896 -- Case of not in list of context items 15897 15898 else 15899 Arg_Node := Arg1; 15900 while Present (Arg_Node) loop 15901 Check_No_Identifier (Arg_Node); 15902 15903 -- Note: the analyze call done by Check_Arg_Is_Local_Name 15904 -- will in fact generate reference, so that the entity will 15905 -- have a reference, which will inhibit any warnings about 15906 -- it not being referenced, and also properly show up in the 15907 -- ali file as a reference. But this reference is recorded 15908 -- before the Has_Pragma_Unreferenced flag is set, so that 15909 -- no warning is generated for this reference. 15910 15911 Check_Arg_Is_Local_Name (Arg_Node); 15912 Arg_Expr := Get_Pragma_Arg (Arg_Node); 15913 15914 if Is_Entity_Name (Arg_Expr) then 15915 Arg_Ent := Entity (Arg_Expr); 15916 15917 -- If the entity is overloaded, the pragma applies to the 15918 -- most recent overloading, as documented. In this case, 15919 -- name resolution does not generate a reference, so it 15920 -- must be done here explicitly. 15921 15922 if Is_Overloaded (Arg_Expr) then 15923 Generate_Reference (Arg_Ent, N); 15924 end if; 15925 15926 Set_Has_Pragma_Unreferenced (Arg_Ent); 15927 end if; 15928 15929 Next (Arg_Node); 15930 end loop; 15931 end if; 15932 end Unreferenced; 15933 15934 -------------------------- 15935 -- Unreferenced_Objects -- 15936 -------------------------- 15937 15938 -- pragma Unreferenced_Objects (local_Name {, local_Name}); 15939 15940 when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare 15941 Arg_Node : Node_Id; 15942 Arg_Expr : Node_Id; 15943 15944 begin 15945 GNAT_Pragma; 15946 Check_At_Least_N_Arguments (1); 15947 15948 Arg_Node := Arg1; 15949 while Present (Arg_Node) loop 15950 Check_No_Identifier (Arg_Node); 15951 Check_Arg_Is_Local_Name (Arg_Node); 15952 Arg_Expr := Get_Pragma_Arg (Arg_Node); 15953 15954 if not Is_Entity_Name (Arg_Expr) 15955 or else not Is_Type (Entity (Arg_Expr)) 15956 then 15957 Error_Pragma_Arg 15958 ("argument for pragma% must be type or subtype", Arg_Node); 15959 end if; 15960 15961 Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr)); 15962 Next (Arg_Node); 15963 end loop; 15964 end Unreferenced_Objects; 15965 15966 ------------------------------ 15967 -- Unreserve_All_Interrupts -- 15968 ------------------------------ 15969 15970 -- pragma Unreserve_All_Interrupts; 15971 15972 when Pragma_Unreserve_All_Interrupts => 15973 GNAT_Pragma; 15974 Check_Arg_Count (0); 15975 15976 if In_Extended_Main_Code_Unit (Main_Unit_Entity) then 15977 Unreserve_All_Interrupts := True; 15978 end if; 15979 15980 ---------------- 15981 -- Unsuppress -- 15982 ---------------- 15983 15984 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]); 15985 15986 when Pragma_Unsuppress => 15987 Ada_2005_Pragma; 15988 Process_Suppress_Unsuppress (False); 15989 15990 ------------------- 15991 -- Use_VADS_Size -- 15992 ------------------- 15993 15994 -- pragma Use_VADS_Size; 15995 15996 when Pragma_Use_VADS_Size => 15997 GNAT_Pragma; 15998 Check_Arg_Count (0); 15999 Check_Valid_Configuration_Pragma; 16000 Use_VADS_Size := True; 16001 16002 --------------------- 16003 -- Validity_Checks -- 16004 --------------------- 16005 16006 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 16007 16008 when Pragma_Validity_Checks => Validity_Checks : declare 16009 A : constant Node_Id := Get_Pragma_Arg (Arg1); 16010 S : String_Id; 16011 C : Char_Code; 16012 16013 begin 16014 GNAT_Pragma; 16015 Check_Arg_Count (1); 16016 Check_No_Identifiers; 16017 16018 if Nkind (A) = N_String_Literal then 16019 S := Strval (A); 16020 16021 declare 16022 Slen : constant Natural := Natural (String_Length (S)); 16023 Options : String (1 .. Slen); 16024 J : Natural; 16025 16026 begin 16027 J := 1; 16028 loop 16029 C := Get_String_Char (S, Int (J)); 16030 exit when not In_Character_Range (C); 16031 Options (J) := Get_Character (C); 16032 16033 if J = Slen then 16034 Set_Validity_Check_Options (Options); 16035 exit; 16036 else 16037 J := J + 1; 16038 end if; 16039 end loop; 16040 end; 16041 16042 elsif Nkind (A) = N_Identifier then 16043 if Chars (A) = Name_All_Checks then 16044 Set_Validity_Check_Options ("a"); 16045 elsif Chars (A) = Name_On then 16046 Validity_Checks_On := True; 16047 elsif Chars (A) = Name_Off then 16048 Validity_Checks_On := False; 16049 end if; 16050 end if; 16051 end Validity_Checks; 16052 16053 -------------- 16054 -- Volatile -- 16055 -------------- 16056 16057 -- pragma Volatile (LOCAL_NAME); 16058 16059 when Pragma_Volatile => 16060 Process_Atomic_Shared_Volatile; 16061 16062 ------------------------- 16063 -- Volatile_Components -- 16064 ------------------------- 16065 16066 -- pragma Volatile_Components (array_LOCAL_NAME); 16067 16068 -- Volatile is handled by the same circuit as Atomic_Components 16069 16070 -------------- 16071 -- Warnings -- 16072 -------------- 16073 16074 -- pragma Warnings (On | Off); 16075 -- pragma Warnings (On | Off, LOCAL_NAME); 16076 -- pragma Warnings (static_string_EXPRESSION); 16077 -- pragma Warnings (On | Off, STRING_LITERAL); 16078 16079 when Pragma_Warnings => Warnings : begin 16080 GNAT_Pragma; 16081 Check_At_Least_N_Arguments (1); 16082 Check_No_Identifiers; 16083 16084 -- If debug flag -gnatd.i is set, pragma is ignored 16085 16086 if Debug_Flag_Dot_I then 16087 return; 16088 end if; 16089 16090 -- Process various forms of the pragma 16091 16092 declare 16093 Argx : constant Node_Id := Get_Pragma_Arg (Arg1); 16094 16095 begin 16096 -- One argument case 16097 16098 if Arg_Count = 1 then 16099 16100 -- On/Off one argument case was processed by parser 16101 16102 if Nkind (Argx) = N_Identifier 16103 and then 16104 (Chars (Argx) = Name_On 16105 or else 16106 Chars (Argx) = Name_Off) 16107 then 16108 null; 16109 16110 -- One argument case must be ON/OFF or static string expr 16111 16112 elsif not Is_Static_String_Expression (Arg1) then 16113 Error_Pragma_Arg 16114 ("argument of pragma% must be On/Off or " & 16115 "static string expression", Arg1); 16116 16117 -- One argument string expression case 16118 16119 else 16120 declare 16121 Lit : constant Node_Id := Expr_Value_S (Argx); 16122 Str : constant String_Id := Strval (Lit); 16123 Len : constant Nat := String_Length (Str); 16124 C : Char_Code; 16125 J : Nat; 16126 OK : Boolean; 16127 Chr : Character; 16128 16129 begin 16130 J := 1; 16131 while J <= Len loop 16132 C := Get_String_Char (Str, J); 16133 OK := In_Character_Range (C); 16134 16135 if OK then 16136 Chr := Get_Character (C); 16137 16138 -- Dash case: only -Wxxx is accepted 16139 16140 if J = 1 16141 and then J < Len 16142 and then Chr = '-' 16143 then 16144 J := J + 1; 16145 C := Get_String_Char (Str, J); 16146 Chr := Get_Character (C); 16147 exit when Chr = 'W'; 16148 OK := False; 16149 16150 -- Dot case 16151 16152 elsif J < Len and then Chr = '.' then 16153 J := J + 1; 16154 C := Get_String_Char (Str, J); 16155 Chr := Get_Character (C); 16156 16157 if not Set_Dot_Warning_Switch (Chr) then 16158 Error_Pragma_Arg 16159 ("invalid warning switch character " & 16160 '.' & Chr, Arg1); 16161 end if; 16162 16163 -- Non-Dot case 16164 16165 else 16166 OK := Set_Warning_Switch (Chr); 16167 end if; 16168 end if; 16169 16170 if not OK then 16171 Error_Pragma_Arg 16172 ("invalid warning switch character " & Chr, 16173 Arg1); 16174 end if; 16175 16176 J := J + 1; 16177 end loop; 16178 end; 16179 end if; 16180 16181 -- Two or more arguments (must be two) 16182 16183 else 16184 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); 16185 Check_At_Most_N_Arguments (2); 16186 16187 declare 16188 E_Id : Node_Id; 16189 E : Entity_Id; 16190 Err : Boolean; 16191 16192 begin 16193 E_Id := Get_Pragma_Arg (Arg2); 16194 Analyze (E_Id); 16195 16196 -- In the expansion of an inlined body, a reference to 16197 -- the formal may be wrapped in a conversion if the 16198 -- actual is a conversion. Retrieve the real entity name. 16199 16200 if (In_Instance_Body or In_Inlined_Body) 16201 and then Nkind (E_Id) = N_Unchecked_Type_Conversion 16202 then 16203 E_Id := Expression (E_Id); 16204 end if; 16205 16206 -- Entity name case 16207 16208 if Is_Entity_Name (E_Id) then 16209 E := Entity (E_Id); 16210 16211 if E = Any_Id then 16212 return; 16213 else 16214 loop 16215 Set_Warnings_Off 16216 (E, (Chars (Get_Pragma_Arg (Arg1)) = 16217 Name_Off)); 16218 16219 -- For OFF case, make entry in warnings off 16220 -- pragma table for later processing. But we do 16221 -- not do that within an instance, since these 16222 -- warnings are about what is needed in the 16223 -- template, not an instance of it. 16224 16225 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off 16226 and then Warn_On_Warnings_Off 16227 and then not In_Instance 16228 then 16229 Warnings_Off_Pragmas.Append ((N, E)); 16230 end if; 16231 16232 if Is_Enumeration_Type (E) then 16233 declare 16234 Lit : Entity_Id; 16235 begin 16236 Lit := First_Literal (E); 16237 while Present (Lit) loop 16238 Set_Warnings_Off (Lit); 16239 Next_Literal (Lit); 16240 end loop; 16241 end; 16242 end if; 16243 16244 exit when No (Homonym (E)); 16245 E := Homonym (E); 16246 end loop; 16247 end if; 16248 16249 -- Error if not entity or static string literal case 16250 16251 elsif not Is_Static_String_Expression (Arg2) then 16252 Error_Pragma_Arg 16253 ("second argument of pragma% must be entity " & 16254 "name or static string expression", Arg2); 16255 16256 -- String literal case 16257 16258 else 16259 String_To_Name_Buffer 16260 (Strval (Expr_Value_S (Get_Pragma_Arg (Arg2)))); 16261 16262 -- Note on configuration pragma case: If this is a 16263 -- configuration pragma, then for an OFF pragma, we 16264 -- just set Config True in the call, which is all 16265 -- that needs to be done. For the case of ON, this 16266 -- is normally an error, unless it is canceling the 16267 -- effect of a previous OFF pragma in the same file. 16268 -- In any other case, an error will be signalled (ON 16269 -- with no matching OFF). 16270 16271 -- Note: We set Used if we are inside a generic to 16272 -- disable the test that the non-config case actually 16273 -- cancels a warning. That's because we can't be sure 16274 -- there isn't an instantiation in some other unit 16275 -- where a warning is suppressed. 16276 16277 -- We could do a little better here by checking if the 16278 -- generic unit we are inside is public, but for now 16279 -- we don't bother with that refinement. 16280 16281 if Chars (Argx) = Name_Off then 16282 Set_Specific_Warning_Off 16283 (Loc, Name_Buffer (1 .. Name_Len), 16284 Config => Is_Configuration_Pragma, 16285 Used => Inside_A_Generic or else In_Instance); 16286 16287 elsif Chars (Argx) = Name_On then 16288 Set_Specific_Warning_On 16289 (Loc, Name_Buffer (1 .. Name_Len), Err); 16290 16291 if Err then 16292 Error_Msg 16293 ("??pragma Warnings On with no " & 16294 "matching Warnings Off", 16295 Loc); 16296 end if; 16297 end if; 16298 end if; 16299 end; 16300 end if; 16301 end; 16302 end Warnings; 16303 16304 ------------------- 16305 -- Weak_External -- 16306 ------------------- 16307 16308 -- pragma Weak_External ([Entity =>] LOCAL_NAME); 16309 16310 when Pragma_Weak_External => Weak_External : declare 16311 Ent : Entity_Id; 16312 16313 begin 16314 GNAT_Pragma; 16315 Check_Arg_Count (1); 16316 Check_Optional_Identifier (Arg1, Name_Entity); 16317 Check_Arg_Is_Library_Level_Local_Name (Arg1); 16318 Ent := Entity (Get_Pragma_Arg (Arg1)); 16319 16320 if Rep_Item_Too_Early (Ent, N) then 16321 return; 16322 else 16323 Ent := Underlying_Type (Ent); 16324 end if; 16325 16326 -- The only processing required is to link this item on to the 16327 -- list of rep items for the given entity. This is accomplished 16328 -- by the call to Rep_Item_Too_Late (when no error is detected 16329 -- and False is returned). 16330 16331 if Rep_Item_Too_Late (Ent, N) then 16332 return; 16333 else 16334 Set_Has_Gigi_Rep_Item (Ent); 16335 end if; 16336 end Weak_External; 16337 16338 ----------------------------- 16339 -- Wide_Character_Encoding -- 16340 ----------------------------- 16341 16342 -- pragma Wide_Character_Encoding (IDENTIFIER); 16343 16344 when Pragma_Wide_Character_Encoding => 16345 GNAT_Pragma; 16346 16347 -- Nothing to do, handled in parser. Note that we do not enforce 16348 -- configuration pragma placement, this pragma can appear at any 16349 -- place in the source, allowing mixed encodings within a single 16350 -- source program. 16351 16352 null; 16353 16354 -------------------- 16355 -- Unknown_Pragma -- 16356 -------------------- 16357 16358 -- Should be impossible, since the case of an unknown pragma is 16359 -- separately processed before the case statement is entered. 16360 16361 when Unknown_Pragma => 16362 raise Program_Error; 16363 end case; 16364 16365 -- AI05-0144: detect dangerous order dependence. Disabled for now, 16366 -- until AI is formally approved. 16367 16368 -- Check_Order_Dependence; 16369 16370 exception 16371 when Pragma_Exit => null; 16372 end Analyze_Pragma; 16373 16374 -------------------- 16375 -- Check_Disabled -- 16376 -------------------- 16377 16378 function Check_Disabled (Nam : Name_Id) return Boolean is 16379 PP : Node_Id; 16380 16381 begin 16382 -- Loop through entries in check policy list 16383 16384 PP := Opt.Check_Policy_List; 16385 loop 16386 -- If there are no specific entries that matched, then nothing is 16387 -- disabled, so return False. 16388 16389 if No (PP) then 16390 return False; 16391 16392 -- Here we have an entry see if it matches 16393 16394 else 16395 declare 16396 PPA : constant List_Id := Pragma_Argument_Associations (PP); 16397 begin 16398 if Nam = Chars (Get_Pragma_Arg (First (PPA))) then 16399 return Chars (Get_Pragma_Arg (Last (PPA))) = Name_Disable; 16400 else 16401 PP := Next_Pragma (PP); 16402 end if; 16403 end; 16404 end if; 16405 end loop; 16406 end Check_Disabled; 16407 16408 ------------------- 16409 -- Check_Enabled -- 16410 ------------------- 16411 16412 function Check_Enabled (Nam : Name_Id) return Boolean is 16413 PP : Node_Id; 16414 16415 begin 16416 -- Loop through entries in check policy list 16417 16418 PP := Opt.Check_Policy_List; 16419 loop 16420 -- If there are no specific entries that matched, then we let the 16421 -- setting of assertions govern. Note that this provides the needed 16422 -- compatibility with the RM for the cases of assertion, invariant, 16423 -- precondition, predicate, and postcondition. 16424 16425 if No (PP) then 16426 return Assertions_Enabled; 16427 16428 -- Here we have an entry see if it matches 16429 16430 else 16431 declare 16432 PPA : constant List_Id := Pragma_Argument_Associations (PP); 16433 16434 begin 16435 if Nam = Chars (Get_Pragma_Arg (First (PPA))) then 16436 case (Chars (Get_Pragma_Arg (Last (PPA)))) is 16437 when Name_On | Name_Check => 16438 return True; 16439 when Name_Off | Name_Ignore => 16440 return False; 16441 when others => 16442 raise Program_Error; 16443 end case; 16444 16445 else 16446 PP := Next_Pragma (PP); 16447 end if; 16448 end; 16449 end if; 16450 end loop; 16451 end Check_Enabled; 16452 16453 --------------------------------- 16454 -- Delay_Config_Pragma_Analyze -- 16455 --------------------------------- 16456 16457 function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is 16458 begin 16459 return Pragma_Name (N) = Name_Interrupt_State 16460 or else 16461 Pragma_Name (N) = Name_Priority_Specific_Dispatching; 16462 end Delay_Config_Pragma_Analyze; 16463 16464 ------------------------- 16465 -- Get_Base_Subprogram -- 16466 ------------------------- 16467 16468 function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is 16469 Result : Entity_Id; 16470 16471 begin 16472 -- Follow subprogram renaming chain 16473 16474 Result := Def_Id; 16475 16476 if Is_Subprogram (Result) 16477 and then 16478 Nkind (Parent (Declaration_Node (Result))) = 16479 N_Subprogram_Renaming_Declaration 16480 and then Present (Alias (Result)) 16481 then 16482 Result := Alias (Result); 16483 end if; 16484 16485 return Result; 16486 end Get_Base_Subprogram; 16487 16488 ---------------- 16489 -- Initialize -- 16490 ---------------- 16491 16492 procedure Initialize is 16493 begin 16494 Externals.Init; 16495 end Initialize; 16496 16497 ----------------------------- 16498 -- Is_Config_Static_String -- 16499 ----------------------------- 16500 16501 function Is_Config_Static_String (Arg : Node_Id) return Boolean is 16502 16503 function Add_Config_Static_String (Arg : Node_Id) return Boolean; 16504 -- This is an internal recursive function that is just like the outer 16505 -- function except that it adds the string to the name buffer rather 16506 -- than placing the string in the name buffer. 16507 16508 ------------------------------ 16509 -- Add_Config_Static_String -- 16510 ------------------------------ 16511 16512 function Add_Config_Static_String (Arg : Node_Id) return Boolean is 16513 N : Node_Id; 16514 C : Char_Code; 16515 16516 begin 16517 N := Arg; 16518 16519 if Nkind (N) = N_Op_Concat then 16520 if Add_Config_Static_String (Left_Opnd (N)) then 16521 N := Right_Opnd (N); 16522 else 16523 return False; 16524 end if; 16525 end if; 16526 16527 if Nkind (N) /= N_String_Literal then 16528 Error_Msg_N ("string literal expected for pragma argument", N); 16529 return False; 16530 16531 else 16532 for J in 1 .. String_Length (Strval (N)) loop 16533 C := Get_String_Char (Strval (N), J); 16534 16535 if not In_Character_Range (C) then 16536 Error_Msg 16537 ("string literal contains invalid wide character", 16538 Sloc (N) + 1 + Source_Ptr (J)); 16539 return False; 16540 end if; 16541 16542 Add_Char_To_Name_Buffer (Get_Character (C)); 16543 end loop; 16544 end if; 16545 16546 return True; 16547 end Add_Config_Static_String; 16548 16549 -- Start of processing for Is_Config_Static_String 16550 16551 begin 16552 16553 Name_Len := 0; 16554 return Add_Config_Static_String (Arg); 16555 end Is_Config_Static_String; 16556 16557 ----------------------------------------- 16558 -- Is_Non_Significant_Pragma_Reference -- 16559 ----------------------------------------- 16560 16561 -- This function makes use of the following static table which indicates 16562 -- whether appearance of some name in a given pragma is to be considered 16563 -- as a reference for the purposes of warnings about unreferenced objects. 16564 16565 -- -1 indicates that references in any argument position are significant 16566 -- 0 indicates that appearance in any argument is not significant 16567 -- +n indicates that appearance as argument n is significant, but all 16568 -- other arguments are not significant 16569 -- 99 special processing required (e.g. for pragma Check) 16570 16571 Sig_Flags : constant array (Pragma_Id) of Int := 16572 (Pragma_AST_Entry => -1, 16573 Pragma_Abort_Defer => -1, 16574 Pragma_Abstract_State => -1, 16575 Pragma_Ada_83 => -1, 16576 Pragma_Ada_95 => -1, 16577 Pragma_Ada_05 => -1, 16578 Pragma_Ada_2005 => -1, 16579 Pragma_Ada_12 => -1, 16580 Pragma_Ada_2012 => -1, 16581 Pragma_All_Calls_Remote => -1, 16582 Pragma_Annotate => -1, 16583 Pragma_Assert => -1, 16584 Pragma_Assert_And_Cut => -1, 16585 Pragma_Assertion_Policy => 0, 16586 Pragma_Assume => 0, 16587 Pragma_Assume_No_Invalid_Values => 0, 16588 Pragma_Attribute_Definition => +3, 16589 Pragma_Asynchronous => -1, 16590 Pragma_Atomic => 0, 16591 Pragma_Atomic_Components => 0, 16592 Pragma_Attach_Handler => -1, 16593 Pragma_Check => 99, 16594 Pragma_Check_Float_Overflow => 0, 16595 Pragma_Check_Name => 0, 16596 Pragma_Check_Policy => 0, 16597 Pragma_CIL_Constructor => -1, 16598 Pragma_CPP_Class => 0, 16599 Pragma_CPP_Constructor => 0, 16600 Pragma_CPP_Virtual => 0, 16601 Pragma_CPP_Vtable => 0, 16602 Pragma_CPU => -1, 16603 Pragma_C_Pass_By_Copy => 0, 16604 Pragma_Comment => 0, 16605 Pragma_Common_Object => -1, 16606 Pragma_Compile_Time_Error => -1, 16607 Pragma_Compile_Time_Warning => -1, 16608 Pragma_Compiler_Unit => 0, 16609 Pragma_Complete_Representation => 0, 16610 Pragma_Complex_Representation => 0, 16611 Pragma_Component_Alignment => -1, 16612 Pragma_Contract_Case => -1, 16613 Pragma_Contract_Cases => -1, 16614 Pragma_Controlled => 0, 16615 Pragma_Convention => 0, 16616 Pragma_Convention_Identifier => 0, 16617 Pragma_Debug => -1, 16618 Pragma_Debug_Policy => 0, 16619 Pragma_Detect_Blocking => -1, 16620 Pragma_Default_Storage_Pool => -1, 16621 Pragma_Disable_Atomic_Synchronization => -1, 16622 Pragma_Discard_Names => 0, 16623 Pragma_Dispatching_Domain => -1, 16624 Pragma_Elaborate => -1, 16625 Pragma_Elaborate_All => -1, 16626 Pragma_Elaborate_Body => -1, 16627 Pragma_Elaboration_Checks => -1, 16628 Pragma_Eliminate => -1, 16629 Pragma_Enable_Atomic_Synchronization => -1, 16630 Pragma_Export => -1, 16631 Pragma_Export_Exception => -1, 16632 Pragma_Export_Function => -1, 16633 Pragma_Export_Object => -1, 16634 Pragma_Export_Procedure => -1, 16635 Pragma_Export_Value => -1, 16636 Pragma_Export_Valued_Procedure => -1, 16637 Pragma_Extend_System => -1, 16638 Pragma_Extensions_Allowed => -1, 16639 Pragma_External => -1, 16640 Pragma_Favor_Top_Level => -1, 16641 Pragma_External_Name_Casing => -1, 16642 Pragma_Fast_Math => -1, 16643 Pragma_Finalize_Storage_Only => 0, 16644 Pragma_Float_Representation => 0, 16645 Pragma_Global => -1, 16646 Pragma_Ident => -1, 16647 Pragma_Implementation_Defined => -1, 16648 Pragma_Implemented => -1, 16649 Pragma_Implicit_Packing => 0, 16650 Pragma_Import => +2, 16651 Pragma_Import_Exception => 0, 16652 Pragma_Import_Function => 0, 16653 Pragma_Import_Object => 0, 16654 Pragma_Import_Procedure => 0, 16655 Pragma_Import_Valued_Procedure => 0, 16656 Pragma_Independent => 0, 16657 Pragma_Independent_Components => 0, 16658 Pragma_Initialize_Scalars => -1, 16659 Pragma_Inline => 0, 16660 Pragma_Inline_Always => 0, 16661 Pragma_Inline_Generic => 0, 16662 Pragma_Inspection_Point => -1, 16663 Pragma_Interface => +2, 16664 Pragma_Interface_Name => +2, 16665 Pragma_Interrupt_Handler => -1, 16666 Pragma_Interrupt_Priority => -1, 16667 Pragma_Interrupt_State => -1, 16668 Pragma_Invariant => -1, 16669 Pragma_Java_Constructor => -1, 16670 Pragma_Java_Interface => -1, 16671 Pragma_Keep_Names => 0, 16672 Pragma_License => -1, 16673 Pragma_Link_With => -1, 16674 Pragma_Linker_Alias => -1, 16675 Pragma_Linker_Constructor => -1, 16676 Pragma_Linker_Destructor => -1, 16677 Pragma_Linker_Options => -1, 16678 Pragma_Linker_Section => -1, 16679 Pragma_List => -1, 16680 Pragma_Lock_Free => -1, 16681 Pragma_Locking_Policy => -1, 16682 Pragma_Long_Float => -1, 16683 Pragma_Loop_Invariant => -1, 16684 Pragma_Loop_Optimize => -1, 16685 Pragma_Loop_Variant => -1, 16686 Pragma_Machine_Attribute => -1, 16687 Pragma_Main => -1, 16688 Pragma_Main_Storage => -1, 16689 Pragma_Memory_Size => -1, 16690 Pragma_No_Return => 0, 16691 Pragma_No_Body => 0, 16692 Pragma_No_Inline => 0, 16693 Pragma_No_Run_Time => -1, 16694 Pragma_No_Strict_Aliasing => -1, 16695 Pragma_Normalize_Scalars => -1, 16696 Pragma_Obsolescent => 0, 16697 Pragma_Optimize => -1, 16698 Pragma_Optimize_Alignment => -1, 16699 Pragma_Overflow_Mode => 0, 16700 Pragma_Overriding_Renamings => 0, 16701 Pragma_Ordered => 0, 16702 Pragma_Pack => 0, 16703 Pragma_Page => -1, 16704 Pragma_Partition_Elaboration_Policy => -1, 16705 Pragma_Passive => -1, 16706 Pragma_Preelaborable_Initialization => -1, 16707 Pragma_Polling => -1, 16708 Pragma_Persistent_BSS => 0, 16709 Pragma_Postcondition => -1, 16710 Pragma_Precondition => -1, 16711 Pragma_Predicate => -1, 16712 Pragma_Preelaborate => -1, 16713 Pragma_Preelaborate_05 => -1, 16714 Pragma_Priority => -1, 16715 Pragma_Priority_Specific_Dispatching => -1, 16716 Pragma_Profile => 0, 16717 Pragma_Profile_Warnings => 0, 16718 Pragma_Propagate_Exceptions => -1, 16719 Pragma_Psect_Object => -1, 16720 Pragma_Pure => -1, 16721 Pragma_Pure_05 => -1, 16722 Pragma_Pure_12 => -1, 16723 Pragma_Pure_Function => -1, 16724 Pragma_Queuing_Policy => -1, 16725 Pragma_Rational => -1, 16726 Pragma_Ravenscar => -1, 16727 Pragma_Relative_Deadline => -1, 16728 Pragma_Remote_Access_Type => -1, 16729 Pragma_Remote_Call_Interface => -1, 16730 Pragma_Remote_Types => -1, 16731 Pragma_Restricted_Run_Time => -1, 16732 Pragma_Restriction_Warnings => -1, 16733 Pragma_Restrictions => -1, 16734 Pragma_Reviewable => -1, 16735 Pragma_Short_Circuit_And_Or => -1, 16736 Pragma_Share_Generic => -1, 16737 Pragma_Shared => -1, 16738 Pragma_Shared_Passive => -1, 16739 Pragma_Short_Descriptors => 0, 16740 Pragma_Simple_Storage_Pool_Type => 0, 16741 Pragma_Source_File_Name => -1, 16742 Pragma_Source_File_Name_Project => -1, 16743 Pragma_Source_Reference => -1, 16744 Pragma_Storage_Size => -1, 16745 Pragma_Storage_Unit => -1, 16746 Pragma_Static_Elaboration_Desired => -1, 16747 Pragma_Stream_Convert => -1, 16748 Pragma_Style_Checks => -1, 16749 Pragma_Subtitle => -1, 16750 Pragma_Suppress => 0, 16751 Pragma_Suppress_Exception_Locations => 0, 16752 Pragma_Suppress_All => -1, 16753 Pragma_Suppress_Debug_Info => 0, 16754 Pragma_Suppress_Initialization => 0, 16755 Pragma_System_Name => -1, 16756 Pragma_Task_Dispatching_Policy => -1, 16757 Pragma_Task_Info => -1, 16758 Pragma_Task_Name => -1, 16759 Pragma_Task_Storage => 0, 16760 Pragma_Test_Case => -1, 16761 Pragma_Thread_Local_Storage => 0, 16762 Pragma_Time_Slice => -1, 16763 Pragma_Title => -1, 16764 Pragma_Unchecked_Union => 0, 16765 Pragma_Unimplemented_Unit => -1, 16766 Pragma_Universal_Aliasing => -1, 16767 Pragma_Universal_Data => -1, 16768 Pragma_Unmodified => -1, 16769 Pragma_Unreferenced => -1, 16770 Pragma_Unreferenced_Objects => -1, 16771 Pragma_Unreserve_All_Interrupts => -1, 16772 Pragma_Unsuppress => 0, 16773 Pragma_Use_VADS_Size => -1, 16774 Pragma_Validity_Checks => -1, 16775 Pragma_Volatile => 0, 16776 Pragma_Volatile_Components => 0, 16777 Pragma_Warnings => -1, 16778 Pragma_Weak_External => -1, 16779 Pragma_Wide_Character_Encoding => 0, 16780 Unknown_Pragma => 0); 16781 16782 function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is 16783 Id : Pragma_Id; 16784 P : Node_Id; 16785 C : Int; 16786 A : Node_Id; 16787 16788 begin 16789 P := Parent (N); 16790 16791 if Nkind (P) /= N_Pragma_Argument_Association then 16792 return False; 16793 16794 else 16795 Id := Get_Pragma_Id (Parent (P)); 16796 C := Sig_Flags (Id); 16797 16798 case C is 16799 when -1 => 16800 return False; 16801 16802 when 0 => 16803 return True; 16804 16805 when 99 => 16806 case Id is 16807 16808 -- For pragma Check, the first argument is not significant, 16809 -- the second and the third (if present) arguments are 16810 -- significant. 16811 16812 when Pragma_Check => 16813 return 16814 P = First (Pragma_Argument_Associations (Parent (P))); 16815 16816 when others => 16817 raise Program_Error; 16818 end case; 16819 16820 when others => 16821 A := First (Pragma_Argument_Associations (Parent (P))); 16822 for J in 1 .. C - 1 loop 16823 if No (A) then 16824 return False; 16825 end if; 16826 16827 Next (A); 16828 end loop; 16829 16830 return A = P; -- is this wrong way round ??? 16831 end case; 16832 end if; 16833 end Is_Non_Significant_Pragma_Reference; 16834 16835 ------------------------------ 16836 -- Is_Pragma_String_Literal -- 16837 ------------------------------ 16838 16839 -- This function returns true if the corresponding pragma argument is a 16840 -- static string expression. These are the only cases in which string 16841 -- literals can appear as pragma arguments. We also allow a string literal 16842 -- as the first argument to pragma Assert (although it will of course 16843 -- always generate a type error). 16844 16845 function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is 16846 Pragn : constant Node_Id := Parent (Par); 16847 Assoc : constant List_Id := Pragma_Argument_Associations (Pragn); 16848 Pname : constant Name_Id := Pragma_Name (Pragn); 16849 Argn : Natural; 16850 N : Node_Id; 16851 16852 begin 16853 Argn := 1; 16854 N := First (Assoc); 16855 loop 16856 exit when N = Par; 16857 Argn := Argn + 1; 16858 Next (N); 16859 end loop; 16860 16861 if Pname = Name_Assert then 16862 return True; 16863 16864 elsif Pname = Name_Export then 16865 return Argn > 2; 16866 16867 elsif Pname = Name_Ident then 16868 return Argn = 1; 16869 16870 elsif Pname = Name_Import then 16871 return Argn > 2; 16872 16873 elsif Pname = Name_Interface_Name then 16874 return Argn > 1; 16875 16876 elsif Pname = Name_Linker_Alias then 16877 return Argn = 2; 16878 16879 elsif Pname = Name_Linker_Section then 16880 return Argn = 2; 16881 16882 elsif Pname = Name_Machine_Attribute then 16883 return Argn = 2; 16884 16885 elsif Pname = Name_Source_File_Name then 16886 return True; 16887 16888 elsif Pname = Name_Source_Reference then 16889 return Argn = 2; 16890 16891 elsif Pname = Name_Title then 16892 return True; 16893 16894 elsif Pname = Name_Subtitle then 16895 return True; 16896 16897 else 16898 return False; 16899 end if; 16900 end Is_Pragma_String_Literal; 16901 16902 ----------------------------------------- 16903 -- Make_Aspect_For_PPC_In_Gen_Sub_Decl -- 16904 ----------------------------------------- 16905 16906 procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is 16907 Aspects : constant List_Id := New_List; 16908 Loc : constant Source_Ptr := Sloc (Decl); 16909 Or_Decl : constant Node_Id := Original_Node (Decl); 16910 16911 Original_Aspects : List_Id; 16912 -- To capture global references, a copy of the created aspects must be 16913 -- inserted in the original tree. 16914 16915 Prag : Node_Id; 16916 Prag_Arg_Ass : Node_Id; 16917 Prag_Id : Pragma_Id; 16918 16919 begin 16920 -- Check for any PPC pragmas that appear within Decl 16921 16922 Prag := Next (Decl); 16923 while Nkind (Prag) = N_Pragma loop 16924 Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag))); 16925 16926 case Prag_Id is 16927 when Pragma_Postcondition | Pragma_Precondition => 16928 Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag)); 16929 16930 -- Make an aspect from any PPC pragma 16931 16932 Append_To (Aspects, 16933 Make_Aspect_Specification (Loc, 16934 Identifier => 16935 Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))), 16936 Expression => 16937 Copy_Separate_Tree (Expression (Prag_Arg_Ass)))); 16938 16939 -- Generate the analysis information in the pragma expression 16940 -- and then set the pragma node analyzed to avoid any further 16941 -- analysis. 16942 16943 Analyze (Expression (Prag_Arg_Ass)); 16944 Set_Analyzed (Prag, True); 16945 16946 when others => null; 16947 end case; 16948 16949 Next (Prag); 16950 end loop; 16951 16952 -- Set all new aspects into the generic declaration node 16953 16954 if Is_Non_Empty_List (Aspects) then 16955 16956 -- Create the list of aspects to be inserted in the original tree 16957 16958 Original_Aspects := Copy_Separate_List (Aspects); 16959 16960 -- Check if Decl already has aspects 16961 16962 -- Attach the new lists of aspects to both the generic copy and the 16963 -- original tree. 16964 16965 if Has_Aspects (Decl) then 16966 Append_List (Aspects, Aspect_Specifications (Decl)); 16967 Append_List (Original_Aspects, Aspect_Specifications (Or_Decl)); 16968 16969 else 16970 Set_Parent (Aspects, Decl); 16971 Set_Aspect_Specifications (Decl, Aspects); 16972 Set_Parent (Original_Aspects, Or_Decl); 16973 Set_Aspect_Specifications (Or_Decl, Original_Aspects); 16974 end if; 16975 end if; 16976 end Make_Aspect_For_PPC_In_Gen_Sub_Decl; 16977 16978 ------------------------- 16979 -- Preanalyze_CTC_Args -- 16980 ------------------------- 16981 16982 procedure Preanalyze_CTC_Args (N, Arg_Req, Arg_Ens : Node_Id) is 16983 begin 16984 -- Preanalyze the boolean expressions, we treat these as spec 16985 -- expressions (i.e. similar to a default expression). 16986 16987 if Present (Arg_Req) then 16988 Preanalyze_Assert_Expression 16989 (Get_Pragma_Arg (Arg_Req), Standard_Boolean); 16990 16991 -- In ASIS mode, for a pragma generated from a source aspect, also 16992 -- analyze the original aspect expression. 16993 16994 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then 16995 Preanalyze_Assert_Expression 16996 (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean); 16997 end if; 16998 end if; 16999 17000 if Present (Arg_Ens) then 17001 Preanalyze_Assert_Expression 17002 (Get_Pragma_Arg (Arg_Ens), Standard_Boolean); 17003 17004 -- In ASIS mode, for a pragma generated from a source aspect, also 17005 -- analyze the original aspect expression. 17006 17007 if ASIS_Mode and then Present (Corresponding_Aspect (N)) then 17008 Preanalyze_Assert_Expression 17009 (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean); 17010 end if; 17011 end if; 17012 end Preanalyze_CTC_Args; 17013 17014 -------------------------------------- 17015 -- Process_Compilation_Unit_Pragmas -- 17016 -------------------------------------- 17017 17018 procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is 17019 begin 17020 -- A special check for pragma Suppress_All, a very strange DEC pragma, 17021 -- strange because it comes at the end of the unit. Rational has the 17022 -- same name for a pragma, but treats it as a program unit pragma, In 17023 -- GNAT we just decide to allow it anywhere at all. If it appeared then 17024 -- the flag Has_Pragma_Suppress_All was set on the compilation unit 17025 -- node, and we insert a pragma Suppress (All_Checks) at the start of 17026 -- the context clause to ensure the correct processing. 17027 17028 if Has_Pragma_Suppress_All (N) then 17029 Prepend_To (Context_Items (N), 17030 Make_Pragma (Sloc (N), 17031 Chars => Name_Suppress, 17032 Pragma_Argument_Associations => New_List ( 17033 Make_Pragma_Argument_Association (Sloc (N), 17034 Expression => Make_Identifier (Sloc (N), Name_All_Checks))))); 17035 end if; 17036 17037 -- Nothing else to do at the current time! 17038 17039 end Process_Compilation_Unit_Pragmas; 17040 17041 -------- 17042 -- rv -- 17043 -------- 17044 17045 procedure rv is 17046 begin 17047 null; 17048 end rv; 17049 17050 -------------------------------- 17051 -- Set_Encoded_Interface_Name -- 17052 -------------------------------- 17053 17054 procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is 17055 Str : constant String_Id := Strval (S); 17056 Len : constant Int := String_Length (Str); 17057 CC : Char_Code; 17058 C : Character; 17059 J : Int; 17060 17061 Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; 17062 17063 procedure Encode; 17064 -- Stores encoded value of character code CC. The encoding we use an 17065 -- underscore followed by four lower case hex digits. 17066 17067 ------------ 17068 -- Encode -- 17069 ------------ 17070 17071 procedure Encode is 17072 begin 17073 Store_String_Char (Get_Char_Code ('_')); 17074 Store_String_Char 17075 (Get_Char_Code (Hex (Integer (CC / 2 ** 12)))); 17076 Store_String_Char 17077 (Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#)))); 17078 Store_String_Char 17079 (Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#)))); 17080 Store_String_Char 17081 (Get_Char_Code (Hex (Integer (CC and 16#0F#)))); 17082 end Encode; 17083 17084 -- Start of processing for Set_Encoded_Interface_Name 17085 17086 begin 17087 -- If first character is asterisk, this is a link name, and we leave it 17088 -- completely unmodified. We also ignore null strings (the latter case 17089 -- happens only in error cases) and no encoding should occur for Java or 17090 -- AAMP interface names. 17091 17092 if Len = 0 17093 or else Get_String_Char (Str, 1) = Get_Char_Code ('*') 17094 or else VM_Target /= No_VM 17095 or else AAMP_On_Target 17096 then 17097 Set_Interface_Name (E, S); 17098 17099 else 17100 J := 1; 17101 loop 17102 CC := Get_String_Char (Str, J); 17103 17104 exit when not In_Character_Range (CC); 17105 17106 C := Get_Character (CC); 17107 17108 exit when C /= '_' and then C /= '$' 17109 and then C not in '0' .. '9' 17110 and then C not in 'a' .. 'z' 17111 and then C not in 'A' .. 'Z'; 17112 17113 if J = Len then 17114 Set_Interface_Name (E, S); 17115 return; 17116 17117 else 17118 J := J + 1; 17119 end if; 17120 end loop; 17121 17122 -- Here we need to encode. The encoding we use as follows: 17123 -- three underscores + four hex digits (lower case) 17124 17125 Start_String; 17126 17127 for J in 1 .. String_Length (Str) loop 17128 CC := Get_String_Char (Str, J); 17129 17130 if not In_Character_Range (CC) then 17131 Encode; 17132 else 17133 C := Get_Character (CC); 17134 17135 if C = '_' or else C = '$' 17136 or else C in '0' .. '9' 17137 or else C in 'a' .. 'z' 17138 or else C in 'A' .. 'Z' 17139 then 17140 Store_String_Char (CC); 17141 else 17142 Encode; 17143 end if; 17144 end if; 17145 end loop; 17146 17147 Set_Interface_Name (E, 17148 Make_String_Literal (Sloc (S), 17149 Strval => End_String)); 17150 end if; 17151 end Set_Encoded_Interface_Name; 17152 17153 ------------------- 17154 -- Set_Unit_Name -- 17155 ------------------- 17156 17157 procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is 17158 Pref : Node_Id; 17159 Scop : Entity_Id; 17160 17161 begin 17162 if Nkind (N) = N_Identifier 17163 and then Nkind (With_Item) = N_Identifier 17164 then 17165 Set_Entity (N, Entity (With_Item)); 17166 17167 elsif Nkind (N) = N_Selected_Component then 17168 Change_Selected_Component_To_Expanded_Name (N); 17169 Set_Entity (N, Entity (With_Item)); 17170 Set_Entity (Selector_Name (N), Entity (N)); 17171 17172 Pref := Prefix (N); 17173 Scop := Scope (Entity (N)); 17174 while Nkind (Pref) = N_Selected_Component loop 17175 Change_Selected_Component_To_Expanded_Name (Pref); 17176 Set_Entity (Selector_Name (Pref), Scop); 17177 Set_Entity (Pref, Scop); 17178 Pref := Prefix (Pref); 17179 Scop := Scope (Scop); 17180 end loop; 17181 17182 Set_Entity (Pref, Scop); 17183 end if; 17184 end Set_Unit_Name; 17185 17186end Sem_Prag; 17187