1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . P R A G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- Generally the parser checks the basic syntax of pragmas, but does not 27-- do specialized syntax checks for individual pragmas, these are deferred 28-- to semantic analysis time (see unit Sem_Prag). There are some pragmas 29-- which require recognition and either partial or complete processing 30-- during parsing, and this unit performs this required processing. 31 32with Fname.UF; use Fname.UF; 33with Osint; use Osint; 34with Rident; use Rident; 35with Restrict; use Restrict; 36with Stringt; use Stringt; 37with Stylesw; use Stylesw; 38with Uintp; use Uintp; 39with Uname; use Uname; 40 41with System.WCh_Con; use System.WCh_Con; 42 43separate (Par) 44 45function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is 46 Prag_Name : constant Name_Id := Pragma_Name_Unmapped (Pragma_Node); 47 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag_Name); 48 Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); 49 Arg_Count : Nat; 50 Arg_Node : Node_Id; 51 52 ----------------------- 53 -- Local Subprograms -- 54 ----------------------- 55 56 procedure Add_List_Pragma_Entry (PT : List_Pragma_Type; Loc : Source_Ptr); 57 -- Make a new entry in the List_Pragmas table if this entry is not already 58 -- in the table (it will always be the last one if there is a duplication 59 -- resulting from the use of Save/Restore_Scan_State). 60 61 function Arg1 return Node_Id; 62 function Arg2 return Node_Id; 63 function Arg3 return Node_Id; 64 -- Obtain specified Pragma_Argument_Association. It is allowable to call 65 -- the routine for the argument one past the last present argument, but 66 -- that is the only case in which a non-present argument can be referenced. 67 68 procedure Check_Arg_Count (Required : Int); 69 -- Check argument count for pragma = Required. If not give error and raise 70 -- Error_Resync. 71 72 procedure Check_Arg_Is_String_Literal (Arg : Node_Id); 73 -- Check the expression of the specified argument to make sure that it 74 -- is a string literal. If not give error and raise Error_Resync. 75 76 procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id); 77 -- Check the expression of the specified argument to make sure that it 78 -- is an identifier which is either ON or OFF, and if not, then issue 79 -- an error message and raise Error_Resync. 80 81 procedure Check_No_Identifier (Arg : Node_Id); 82 -- Checks that the given argument does not have an identifier. If 83 -- an identifier is present, then an error message is issued, and 84 -- Error_Resync is raised. 85 86 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 87 -- Checks if the given argument has an identifier, and if so, requires 88 -- it to match the given identifier name. If there is a non-matching 89 -- identifier, then an error message is given and Error_Resync raised. 90 91 procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id); 92 -- Same as Check_Optional_Identifier, except that the name is required 93 -- to be present and to match the given Id value. 94 95 procedure Process_Restrictions_Or_Restriction_Warnings; 96 -- Common processing for Restrictions and Restriction_Warnings pragmas. 97 -- For the most part, restrictions need not be processed at parse time, 98 -- since they only affect semantic processing. This routine handles the 99 -- exceptions as follows 100 -- 101 -- No_Obsolescent_Features must be processed at parse time, since there 102 -- are some obsolescent features (e.g. character replacements) which are 103 -- handled at parse time. 104 -- 105 -- SPARK must be processed at parse time, since this restriction controls 106 -- whether the scanner recognizes a spark HIDE directive formatted as an 107 -- Ada comment (and generates a Tok_SPARK_Hide token for the directive). 108 -- 109 -- No_Dependence must be processed at parse time, since otherwise it gets 110 -- handled too late. 111 -- 112 -- Note that we don't need to do full error checking for badly formed cases 113 -- of restrictions, since these will be caught during semantic analysis. 114 115 --------------------------- 116 -- Add_List_Pragma_Entry -- 117 --------------------------- 118 119 procedure Add_List_Pragma_Entry (PT : List_Pragma_Type; Loc : Source_Ptr) is 120 begin 121 if List_Pragmas.Last < List_Pragmas.First 122 or else (List_Pragmas.Table (List_Pragmas.Last)) /= ((PT, Loc)) 123 then 124 List_Pragmas.Append ((PT, Loc)); 125 end if; 126 end Add_List_Pragma_Entry; 127 128 ---------- 129 -- Arg1 -- 130 ---------- 131 132 function Arg1 return Node_Id is 133 begin 134 return First (Pragma_Argument_Associations (Pragma_Node)); 135 end Arg1; 136 137 ---------- 138 -- Arg2 -- 139 ---------- 140 141 function Arg2 return Node_Id is 142 begin 143 return Next (Arg1); 144 end Arg2; 145 146 ---------- 147 -- Arg3 -- 148 ---------- 149 150 function Arg3 return Node_Id is 151 begin 152 return Next (Arg2); 153 end Arg3; 154 155 --------------------- 156 -- Check_Arg_Count -- 157 --------------------- 158 159 procedure Check_Arg_Count (Required : Int) is 160 begin 161 if Arg_Count /= Required then 162 Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); 163 raise Error_Resync; 164 end if; 165 end Check_Arg_Count; 166 167 ---------------------------- 168 -- Check_Arg_Is_On_Or_Off -- 169 ---------------------------- 170 171 procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is 172 Argx : constant Node_Id := Expression (Arg); 173 174 begin 175 if Nkind (Expression (Arg)) /= N_Identifier 176 or else not Nam_In (Chars (Argx), Name_On, Name_Off) 177 then 178 Error_Msg_Name_2 := Name_On; 179 Error_Msg_Name_3 := Name_Off; 180 181 Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); 182 raise Error_Resync; 183 end if; 184 end Check_Arg_Is_On_Or_Off; 185 186 --------------------------------- 187 -- Check_Arg_Is_String_Literal -- 188 --------------------------------- 189 190 procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is 191 begin 192 if Nkind (Expression (Arg)) /= N_String_Literal then 193 Error_Msg 194 ("argument for pragma% must be string literal", 195 Sloc (Expression (Arg))); 196 raise Error_Resync; 197 end if; 198 end Check_Arg_Is_String_Literal; 199 200 ------------------------- 201 -- Check_No_Identifier -- 202 ------------------------- 203 204 procedure Check_No_Identifier (Arg : Node_Id) is 205 begin 206 if Chars (Arg) /= No_Name then 207 Error_Msg_N ("pragma% does not permit named arguments", Arg); 208 raise Error_Resync; 209 end if; 210 end Check_No_Identifier; 211 212 ------------------------------- 213 -- Check_Optional_Identifier -- 214 ------------------------------- 215 216 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 217 begin 218 if Present (Arg) and then Chars (Arg) /= No_Name then 219 if Chars (Arg) /= Id then 220 Error_Msg_Name_2 := Id; 221 Error_Msg_N ("pragma% argument expects identifier%", Arg); 222 end if; 223 end if; 224 end Check_Optional_Identifier; 225 226 ------------------------------- 227 -- Check_Required_Identifier -- 228 ------------------------------- 229 230 procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is 231 begin 232 if Chars (Arg) /= Id then 233 Error_Msg_Name_2 := Id; 234 Error_Msg_N ("pragma% argument must have identifier%", Arg); 235 end if; 236 end Check_Required_Identifier; 237 238 -------------------------------------------------- 239 -- Process_Restrictions_Or_Restriction_Warnings -- 240 -------------------------------------------------- 241 242 procedure Process_Restrictions_Or_Restriction_Warnings is 243 Arg : Node_Id; 244 Id : Name_Id; 245 Expr : Node_Id; 246 247 begin 248 Arg := Arg1; 249 while Present (Arg) loop 250 Id := Chars (Arg); 251 Expr := Expression (Arg); 252 253 if Id = No_Name and then Nkind (Expr) = N_Identifier then 254 case Chars (Expr) is 255 when Name_No_Obsolescent_Features => 256 Set_Restriction (No_Obsolescent_Features, Pragma_Node); 257 Restriction_Warnings (No_Obsolescent_Features) := 258 Prag_Id = Pragma_Restriction_Warnings; 259 260 when Name_SPARK 261 | Name_SPARK_05 262 => 263 Set_Restriction (SPARK_05, Pragma_Node); 264 Restriction_Warnings (SPARK_05) := 265 Prag_Id = Pragma_Restriction_Warnings; 266 267 when others => 268 null; 269 end case; 270 271 elsif Id = Name_No_Dependence then 272 Set_Restriction_No_Dependence 273 (Unit => Expr, 274 Warn => Prag_Id = Pragma_Restriction_Warnings 275 or else Treat_Restrictions_As_Warnings); 276 end if; 277 278 Next (Arg); 279 end loop; 280 end Process_Restrictions_Or_Restriction_Warnings; 281 282-- Start of processing for Prag 283 284begin 285 Error_Msg_Name_1 := Prag_Name; 286 287 -- Ignore unrecognized pragma. We let Sem post the warning for this, since 288 -- it is a semantic error, not a syntactic one (we have already checked 289 -- the syntax for the unrecognized pragma as required by (RM 2.8(11)). 290 291 if Prag_Id = Unknown_Pragma then 292 return Pragma_Node; 293 end if; 294 295 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma 296 -- Default_Scalar_Storage_Order if the -gnatI switch was given. 297 298 if Should_Ignore_Pragma_Par (Prag_Name) 299 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order 300 and then Ignore_Rep_Clauses) 301 then 302 return Pragma_Node; 303 end if; 304 305 -- Count number of arguments. This loop also checks if any of the arguments 306 -- are Error, indicating a syntax error as they were parsed. If so, we 307 -- simply return, because we get into trouble with cascaded errors if we 308 -- try to perform our error checks on junk arguments. 309 310 Arg_Count := 0; 311 312 if Present (Pragma_Argument_Associations (Pragma_Node)) then 313 Arg_Node := Arg1; 314 while Arg_Node /= Empty loop 315 Arg_Count := Arg_Count + 1; 316 317 if Expression (Arg_Node) = Error then 318 return Error; 319 end if; 320 321 Next (Arg_Node); 322 end loop; 323 end if; 324 325 -- Remaining processing is pragma dependent 326 327 case Prag_Id is 328 329 -- Ada version pragmas must be processed at parse time, because we want 330 -- to set the Ada version properly at parse time to recognize the 331 -- appropriate Ada version syntax. However, pragma Ada_2005 and higher 332 -- have an optional argument; it is only the zero argument form that 333 -- must be processed at parse time. 334 335 ------------ 336 -- Ada_83 -- 337 ------------ 338 339 when Pragma_Ada_83 => 340 if not Latest_Ada_Only then 341 Ada_Version := Ada_83; 342 Ada_Version_Explicit := Ada_83; 343 Ada_Version_Pragma := Pragma_Node; 344 end if; 345 346 ------------ 347 -- Ada_95 -- 348 ------------ 349 350 when Pragma_Ada_95 => 351 if not Latest_Ada_Only then 352 Ada_Version := Ada_95; 353 Ada_Version_Explicit := Ada_95; 354 Ada_Version_Pragma := Pragma_Node; 355 end if; 356 357 --------------------- 358 -- Ada_05/Ada_2005 -- 359 --------------------- 360 361 when Pragma_Ada_05 362 | Pragma_Ada_2005 363 => 364 if Arg_Count = 0 and not Latest_Ada_Only then 365 Ada_Version := Ada_2005; 366 Ada_Version_Explicit := Ada_2005; 367 Ada_Version_Pragma := Pragma_Node; 368 end if; 369 370 --------------------- 371 -- Ada_12/Ada_2012 -- 372 --------------------- 373 374 when Pragma_Ada_12 375 | Pragma_Ada_2012 376 => 377 if Arg_Count = 0 then 378 Ada_Version := Ada_2012; 379 Ada_Version_Explicit := Ada_2012; 380 Ada_Version_Pragma := Pragma_Node; 381 end if; 382 383 -------------- 384 -- Ada_2020 -- 385 -------------- 386 387 when Pragma_Ada_2020 => 388 if Arg_Count = 0 then 389 Ada_Version := Ada_2020; 390 Ada_Version_Explicit := Ada_2020; 391 Ada_Version_Pragma := Pragma_Node; 392 end if; 393 394 --------------------------- 395 -- Compiler_Unit_Warning -- 396 --------------------------- 397 398 -- This pragma must be processed at parse time, since the resulting 399 -- status may be tested during the parsing of the program. 400 401 when Pragma_Compiler_Unit 402 | Pragma_Compiler_Unit_Warning 403 => 404 Check_Arg_Count (0); 405 406 -- Only recognized in main unit 407 408 if Current_Source_Unit = Main_Unit then 409 Compiler_Unit := True; 410 end if; 411 412 ----------- 413 -- Debug -- 414 ----------- 415 416 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); 417 418 when Pragma_Debug => 419 Check_No_Identifier (Arg1); 420 421 if Arg_Count = 2 then 422 Check_No_Identifier (Arg2); 423 else 424 Check_Arg_Count (1); 425 end if; 426 427 ------------------------------- 428 -- Extensions_Allowed (GNAT) -- 429 ------------------------------- 430 431 -- pragma Extensions_Allowed (Off | On) 432 433 -- The processing for pragma Extensions_Allowed must be done at 434 -- parse time, since extensions mode may affect what is accepted. 435 436 when Pragma_Extensions_Allowed => 437 Check_Arg_Count (1); 438 Check_No_Identifier (Arg1); 439 Check_Arg_Is_On_Or_Off (Arg1); 440 441 if Chars (Expression (Arg1)) = Name_On then 442 Extensions_Allowed := True; 443 Ada_Version := Ada_2012; 444 else 445 Extensions_Allowed := False; 446 Ada_Version := Ada_Version_Explicit; 447 end if; 448 449 ------------------- 450 -- Ignore_Pragma -- 451 ------------------- 452 453 -- Processing for this pragma must be done at parse time, since we want 454 -- be able to ignore pragmas that are otherwise processed at parse time. 455 456 when Pragma_Ignore_Pragma => Ignore_Pragma : declare 457 A : Node_Id; 458 459 begin 460 Check_Arg_Count (1); 461 Check_No_Identifier (Arg1); 462 A := Expression (Arg1); 463 464 if Nkind (A) /= N_Identifier then 465 Error_Msg ("incorrect argument for pragma %", Sloc (A)); 466 else 467 Set_Name_Table_Boolean3 (Chars (A), True); 468 end if; 469 end Ignore_Pragma; 470 471 ---------------- 472 -- List (2.8) -- 473 ---------------- 474 475 -- pragma List (Off | On) 476 477 -- The processing for pragma List must be done at parse time, since a 478 -- listing can be generated in parse only mode. 479 480 when Pragma_List => 481 Check_Arg_Count (1); 482 Check_No_Identifier (Arg1); 483 Check_Arg_Is_On_Or_Off (Arg1); 484 485 -- We unconditionally make a List_On entry for the pragma, so that 486 -- in the List (Off) case, the pragma will print even in a region 487 -- of code with listing turned off (this is required). 488 489 Add_List_Pragma_Entry (List_On, Sloc (Pragma_Node)); 490 491 -- Now generate the list off entry for pragma List (Off) 492 493 if Chars (Expression (Arg1)) = Name_Off then 494 Add_List_Pragma_Entry (List_Off, Semi); 495 end if; 496 497 ---------------- 498 -- Page (2.8) -- 499 ---------------- 500 501 -- pragma Page; 502 503 -- Processing for this pragma must be done at parse time, since a 504 -- listing can be generated in parse only mode with semantics off. 505 506 when Pragma_Page => 507 Check_Arg_Count (0); 508 Add_List_Pragma_Entry (Page, Semi); 509 510 ------------------ 511 -- Restrictions -- 512 ------------------ 513 514 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 515 516 -- RESTRICTION ::= 517 -- restriction_IDENTIFIER 518 -- | restriction_parameter_IDENTIFIER => EXPRESSION 519 520 -- We process the case of No_Obsolescent_Features, since this has 521 -- a syntactic effect that we need to detect at parse time (the use 522 -- of replacement characters such as colon for pound sign). 523 524 when Pragma_Restrictions => 525 Process_Restrictions_Or_Restriction_Warnings; 526 527 -------------------------- 528 -- Restriction_Warnings -- 529 -------------------------- 530 531 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 532 533 -- RESTRICTION ::= 534 -- restriction_IDENTIFIER 535 -- | restriction_parameter_IDENTIFIER => EXPRESSION 536 537 -- See above comment for pragma Restrictions 538 539 when Pragma_Restriction_Warnings => 540 Process_Restrictions_Or_Restriction_Warnings; 541 542 ---------------------------------------------------------- 543 -- Source_File_Name and Source_File_Name_Project (GNAT) -- 544 ---------------------------------------------------------- 545 546 -- These two pragmas have the same syntax and semantics. 547 -- There are five forms of these pragmas: 548 549 -- pragma Source_File_Name[_Project] ( 550 -- [UNIT_NAME =>] unit_NAME, 551 -- BODY_FILE_NAME => STRING_LITERAL 552 -- [, [INDEX =>] INTEGER_LITERAL]); 553 554 -- pragma Source_File_Name[_Project] ( 555 -- [UNIT_NAME =>] unit_NAME, 556 -- SPEC_FILE_NAME => STRING_LITERAL 557 -- [, [INDEX =>] INTEGER_LITERAL]); 558 559 -- pragma Source_File_Name[_Project] ( 560 -- BODY_FILE_NAME => STRING_LITERAL 561 -- [, DOT_REPLACEMENT => STRING_LITERAL] 562 -- [, CASING => CASING_SPEC]); 563 564 -- pragma Source_File_Name[_Project] ( 565 -- SPEC_FILE_NAME => STRING_LITERAL 566 -- [, DOT_REPLACEMENT => STRING_LITERAL] 567 -- [, CASING => CASING_SPEC]); 568 569 -- pragma Source_File_Name[_Project] ( 570 -- SUBUNIT_FILE_NAME => STRING_LITERAL 571 -- [, DOT_REPLACEMENT => STRING_LITERAL] 572 -- [, CASING => CASING_SPEC]); 573 574 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 575 576 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 577 -- Source_File_Name (SFN), however their usage is exclusive: 578 -- SFN can only be used when no project file is used, while 579 -- SFNP can only be used when a project file is used. 580 581 -- The Project Manager produces a configuration pragmas file that 582 -- is communicated to the compiler with -gnatec switch. This file 583 -- contains only SFNP pragmas (at least two for the default naming 584 -- scheme. As this configuration pragmas file is always the first 585 -- processed by the compiler, it prevents the use of pragmas SFN in 586 -- other config files when a project file is in use. 587 588 -- Note: we process this during parsing, since we need to have the 589 -- source file names set well before the semantic analysis starts, 590 -- since we load the spec and with'ed packages before analysis. 591 592 when Pragma_Source_File_Name 593 | Pragma_Source_File_Name_Project 594 => 595 Source_File_Name : declare 596 Unam : Unit_Name_Type; 597 Expr1 : Node_Id; 598 Pat : String_Ptr; 599 Typ : Character; 600 Dot : String_Ptr; 601 Cas : Casing_Type; 602 Nast : Nat; 603 Expr : Node_Id; 604 Index : Nat; 605 606 function Get_Fname (Arg : Node_Id) return File_Name_Type; 607 -- Process file name from unit name form of pragma 608 609 function Get_String_Argument (Arg : Node_Id) return String_Ptr; 610 -- Process string literal value from argument 611 612 procedure Process_Casing (Arg : Node_Id); 613 -- Process Casing argument of pattern form of pragma 614 615 procedure Process_Dot_Replacement (Arg : Node_Id); 616 -- Process Dot_Replacement argument of pattern form of pragma 617 618 --------------- 619 -- Get_Fname -- 620 --------------- 621 622 function Get_Fname (Arg : Node_Id) return File_Name_Type is 623 begin 624 String_To_Name_Buffer (Strval (Expression (Arg))); 625 626 for J in 1 .. Name_Len loop 627 if Is_Directory_Separator (Name_Buffer (J)) then 628 Error_Msg 629 ("directory separator character not allowed", 630 Sloc (Expression (Arg)) + Source_Ptr (J)); 631 end if; 632 end loop; 633 634 return Name_Find; 635 end Get_Fname; 636 637 ------------------------- 638 -- Get_String_Argument -- 639 ------------------------- 640 641 function Get_String_Argument (Arg : Node_Id) return String_Ptr is 642 Str : String_Id; 643 644 begin 645 if Nkind (Expression (Arg)) /= N_String_Literal 646 and then 647 Nkind (Expression (Arg)) /= N_Operator_Symbol 648 then 649 Error_Msg_N 650 ("argument for pragma% must be string literal", Arg); 651 raise Error_Resync; 652 end if; 653 654 Str := Strval (Expression (Arg)); 655 656 -- Check string has no wide chars 657 658 for J in 1 .. String_Length (Str) loop 659 if Get_String_Char (Str, J) > 255 then 660 Error_Msg 661 ("wide character not allowed in pattern for pragma%", 662 Sloc (Expression (Arg2)) + Text_Ptr (J) - 1); 663 end if; 664 end loop; 665 666 -- Acquire string 667 668 String_To_Name_Buffer (Str); 669 return new String'(Name_Buffer (1 .. Name_Len)); 670 end Get_String_Argument; 671 672 -------------------- 673 -- Process_Casing -- 674 -------------------- 675 676 procedure Process_Casing (Arg : Node_Id) is 677 Expr : constant Node_Id := Expression (Arg); 678 679 begin 680 Check_Required_Identifier (Arg, Name_Casing); 681 682 if Nkind (Expr) = N_Identifier then 683 if Chars (Expr) = Name_Lowercase then 684 Cas := All_Lower_Case; 685 return; 686 elsif Chars (Expr) = Name_Uppercase then 687 Cas := All_Upper_Case; 688 return; 689 elsif Chars (Expr) = Name_Mixedcase then 690 Cas := Mixed_Case; 691 return; 692 end if; 693 end if; 694 695 Error_Msg_N 696 ("Casing argument for pragma% must be " & 697 "one of Mixedcase, Lowercase, Uppercase", 698 Arg); 699 end Process_Casing; 700 701 ----------------------------- 702 -- Process_Dot_Replacement -- 703 ----------------------------- 704 705 procedure Process_Dot_Replacement (Arg : Node_Id) is 706 begin 707 Check_Required_Identifier (Arg, Name_Dot_Replacement); 708 Dot := Get_String_Argument (Arg); 709 end Process_Dot_Replacement; 710 711 -- Start of processing for Source_File_Name and 712 -- Source_File_Name_Project pragmas. 713 714 begin 715 if Prag_Id = Pragma_Source_File_Name then 716 if Project_File_In_Use = In_Use then 717 Error_Msg 718 ("pragma Source_File_Name cannot be used " & 719 "with a project file", Pragma_Sloc); 720 721 else 722 Project_File_In_Use := Not_In_Use; 723 end if; 724 725 else 726 if Project_File_In_Use = Not_In_Use then 727 Error_Msg 728 ("pragma Source_File_Name_Project should only be used " & 729 "with a project file", Pragma_Sloc); 730 else 731 Project_File_In_Use := In_Use; 732 end if; 733 end if; 734 735 -- We permit from 1 to 3 arguments 736 737 if Arg_Count not in 1 .. 3 then 738 Check_Arg_Count (1); 739 end if; 740 741 Expr1 := Expression (Arg1); 742 743 -- If first argument is identifier or selected component, then 744 -- we have the specific file case of the Source_File_Name pragma, 745 -- and the first argument is a unit name. 746 747 if Nkind (Expr1) = N_Identifier 748 or else 749 (Nkind (Expr1) = N_Selected_Component 750 and then 751 Nkind (Selector_Name (Expr1)) = N_Identifier) 752 then 753 if Nkind (Expr1) = N_Identifier 754 and then Chars (Expr1) = Name_System 755 then 756 Error_Msg_N 757 ("pragma Source_File_Name may not be used for System", 758 Arg1); 759 return Error; 760 end if; 761 762 -- Process index argument if present 763 764 if Arg_Count = 3 then 765 Expr := Expression (Arg3); 766 767 if Nkind (Expr) /= N_Integer_Literal 768 or else not UI_Is_In_Int_Range (Intval (Expr)) 769 or else Intval (Expr) > 999 770 or else Intval (Expr) <= 0 771 then 772 Error_Msg 773 ("pragma% index must be integer literal" & 774 " in range 1 .. 999", Sloc (Expr)); 775 raise Error_Resync; 776 else 777 Index := UI_To_Int (Intval (Expr)); 778 end if; 779 780 -- No index argument present 781 782 else 783 Check_Arg_Count (2); 784 Index := 0; 785 end if; 786 787 Check_Optional_Identifier (Arg1, Name_Unit_Name); 788 Unam := Get_Unit_Name (Expr1); 789 790 Check_Arg_Is_String_Literal (Arg2); 791 792 if Chars (Arg2) = Name_Spec_File_Name then 793 Set_File_Name 794 (Get_Spec_Name (Unam), Get_Fname (Arg2), Index); 795 796 elsif Chars (Arg2) = Name_Body_File_Name then 797 Set_File_Name 798 (Unam, Get_Fname (Arg2), Index); 799 800 else 801 Error_Msg_N 802 ("pragma% argument has incorrect identifier", Arg2); 803 return Pragma_Node; 804 end if; 805 806 -- If the first argument is not an identifier, then we must have 807 -- the pattern form of the pragma, and the first argument must be 808 -- the pattern string with an appropriate name. 809 810 else 811 if Chars (Arg1) = Name_Spec_File_Name then 812 Typ := 's'; 813 814 elsif Chars (Arg1) = Name_Body_File_Name then 815 Typ := 'b'; 816 817 elsif Chars (Arg1) = Name_Subunit_File_Name then 818 Typ := 'u'; 819 820 elsif Chars (Arg1) = Name_Unit_Name then 821 Error_Msg_N 822 ("Unit_Name parameter for pragma% must be an identifier", 823 Arg1); 824 raise Error_Resync; 825 826 else 827 Error_Msg_N 828 ("pragma% argument has incorrect identifier", Arg1); 829 raise Error_Resync; 830 end if; 831 832 Pat := Get_String_Argument (Arg1); 833 834 -- Check pattern has exactly one asterisk 835 836 Nast := 0; 837 for J in Pat'Range loop 838 if Pat (J) = '*' then 839 Nast := Nast + 1; 840 end if; 841 end loop; 842 843 if Nast /= 1 then 844 Error_Msg_N 845 ("file name pattern must have exactly one * character", 846 Arg1); 847 return Pragma_Node; 848 end if; 849 850 -- Set defaults for Casing and Dot_Separator parameters 851 852 Cas := All_Lower_Case; 853 Dot := new String'("."); 854 855 -- Process second and third arguments if present 856 857 if Arg_Count > 1 then 858 if Chars (Arg2) = Name_Casing then 859 Process_Casing (Arg2); 860 861 if Arg_Count = 3 then 862 Process_Dot_Replacement (Arg3); 863 end if; 864 865 else 866 Process_Dot_Replacement (Arg2); 867 868 if Arg_Count = 3 then 869 Process_Casing (Arg3); 870 end if; 871 end if; 872 end if; 873 874 Set_File_Name_Pattern (Pat, Typ, Dot, Cas); 875 end if; 876 end Source_File_Name; 877 878 ----------------------------- 879 -- Source_Reference (GNAT) -- 880 ----------------------------- 881 882 -- pragma Source_Reference 883 -- (INTEGER_LITERAL [, STRING_LITERAL] ); 884 885 -- Processing for this pragma must be done at parse time, since error 886 -- messages needing the proper line numbers can be generated in parse 887 -- only mode with semantic checking turned off, and indeed we usually 888 -- turn off semantic checking anyway if any parse errors are found. 889 890 when Pragma_Source_Reference => Source_Reference : declare 891 Fname : File_Name_Type; 892 893 begin 894 if Arg_Count /= 1 then 895 Check_Arg_Count (2); 896 Check_No_Identifier (Arg2); 897 end if; 898 899 -- Check that this is first line of file. We skip this test if 900 -- we are in syntax check only mode, since we may be dealing with 901 -- multiple compilation units. 902 903 if Get_Physical_Line_Number (Pragma_Sloc) /= 1 904 and then Num_SRef_Pragmas (Current_Source_File) = 0 905 and then Operating_Mode /= Check_Syntax 906 then 907 Error_Msg -- CODEFIX 908 ("first % pragma must be first line of file", Pragma_Sloc); 909 raise Error_Resync; 910 end if; 911 912 Check_No_Identifier (Arg1); 913 914 if Arg_Count = 1 then 915 if Num_SRef_Pragmas (Current_Source_File) = 0 then 916 Error_Msg 917 ("file name required for first % pragma in file", 918 Pragma_Sloc); 919 raise Error_Resync; 920 else 921 Fname := No_File; 922 end if; 923 924 -- File name present 925 926 else 927 Check_Arg_Is_String_Literal (Arg2); 928 String_To_Name_Buffer (Strval (Expression (Arg2))); 929 Fname := Name_Find; 930 931 if Num_SRef_Pragmas (Current_Source_File) > 0 then 932 if Fname /= Full_Ref_Name (Current_Source_File) then 933 Error_Msg 934 ("file name must be same in all % pragmas", Pragma_Sloc); 935 raise Error_Resync; 936 end if; 937 end if; 938 end if; 939 940 if Nkind (Expression (Arg1)) /= N_Integer_Literal then 941 Error_Msg 942 ("argument for pragma% must be integer literal", 943 Sloc (Expression (Arg1))); 944 raise Error_Resync; 945 946 -- OK, this source reference pragma is effective, however, we 947 -- ignore it if it is not in the first unit in the multiple unit 948 -- case. This is because the only purpose in this case is to 949 -- provide source pragmas for subsequent use by gnatchop. 950 951 else 952 if Num_Library_Units = 1 then 953 Register_Source_Ref_Pragma 954 (Fname, 955 Strip_Directory (Fname), 956 UI_To_Int (Intval (Expression (Arg1))), 957 Get_Physical_Line_Number (Pragma_Sloc) + 1); 958 end if; 959 end if; 960 end Source_Reference; 961 962 ------------------------- 963 -- Style_Checks (GNAT) -- 964 ------------------------- 965 966 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 967 968 -- This is processed by the parser since some of the style 969 -- checks take place during source scanning and parsing. 970 971 when Pragma_Style_Checks => Style_Checks : declare 972 A : Node_Id; 973 S : String_Id; 974 C : Char_Code; 975 OK : Boolean := True; 976 977 begin 978 -- Two argument case is only for semantics 979 980 if Arg_Count = 2 then 981 null; 982 983 else 984 Check_Arg_Count (1); 985 Check_No_Identifier (Arg1); 986 A := Expression (Arg1); 987 988 if Nkind (A) = N_String_Literal then 989 S := Strval (A); 990 991 declare 992 Slen : constant Natural := Natural (String_Length (S)); 993 Options : String (1 .. Slen); 994 J : Positive; 995 Ptr : Positive; 996 997 begin 998 J := 1; 999 loop 1000 C := Get_String_Char (S, Pos (J)); 1001 1002 if not In_Character_Range (C) then 1003 OK := False; 1004 Ptr := J; 1005 exit; 1006 1007 else 1008 Options (J) := Get_Character (C); 1009 end if; 1010 1011 if J = Slen then 1012 if not Ignore_Style_Checks_Pragmas then 1013 Set_Style_Check_Options (Options, OK, Ptr); 1014 end if; 1015 1016 exit; 1017 1018 else 1019 J := J + 1; 1020 end if; 1021 end loop; 1022 1023 if not OK then 1024 Error_Msg 1025 (Style_Msg_Buf (1 .. Style_Msg_Len), 1026 Sloc (Expression (Arg1)) + Source_Ptr (Ptr)); 1027 raise Error_Resync; 1028 end if; 1029 end; 1030 1031 elsif Nkind (A) /= N_Identifier then 1032 OK := False; 1033 1034 elsif Chars (A) = Name_All_Checks then 1035 if not Ignore_Style_Checks_Pragmas then 1036 if GNAT_Mode then 1037 Stylesw.Set_GNAT_Style_Check_Options; 1038 else 1039 Stylesw.Set_Default_Style_Check_Options; 1040 end if; 1041 end if; 1042 1043 elsif Chars (A) = Name_On then 1044 if not Ignore_Style_Checks_Pragmas then 1045 Style_Check := True; 1046 end if; 1047 1048 elsif Chars (A) = Name_Off then 1049 if not Ignore_Style_Checks_Pragmas then 1050 Style_Check := False; 1051 end if; 1052 1053 else 1054 OK := False; 1055 end if; 1056 1057 if not OK then 1058 Error_Msg ("incorrect argument for pragma%", Sloc (A)); 1059 raise Error_Resync; 1060 end if; 1061 end if; 1062 end Style_Checks; 1063 1064 ------------------------- 1065 -- Suppress_All (GNAT) -- 1066 ------------------------- 1067 1068 -- pragma Suppress_All 1069 1070 -- This is a rather odd pragma, because other compilers allow it in 1071 -- strange places. DEC allows it at the end of units, and Rational 1072 -- allows it as a program unit pragma, when it would be more natural 1073 -- if it were a configuration pragma. 1074 1075 -- Since the reason we provide this pragma is for compatibility with 1076 -- these other compilers, we want to accommodate these strange placement 1077 -- rules, and the easiest thing is simply to allow it anywhere in a 1078 -- unit. If this pragma appears anywhere within a unit, then the effect 1079 -- is as though a pragma Suppress (All_Checks) had appeared as the first 1080 -- line of the current file, i.e. as the first configuration pragma in 1081 -- the current unit. 1082 1083 -- To get this effect, we set the flag Has_Pragma_Suppress_All in the 1084 -- compilation unit node for the current source file then in the last 1085 -- stage of parsing a file, if this flag is set, we materialize the 1086 -- Suppress (All_Checks) pragma, marked as not coming from Source. 1087 1088 when Pragma_Suppress_All => 1089 Set_Has_Pragma_Suppress_All (Cunit (Current_Source_Unit)); 1090 1091 --------------------- 1092 -- Warnings (GNAT) -- 1093 --------------------- 1094 1095 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); 1096 1097 -- DETAILS ::= On | Off 1098 -- DETAILS ::= On | Off, local_NAME 1099 -- DETAILS ::= static_string_EXPRESSION 1100 -- DETAILS ::= On | Off, static_string_EXPRESSION 1101 1102 -- TOOL_NAME ::= GNAT | GNATProve 1103 1104 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} 1105 1106 -- Note: If the first argument matches an allowed tool name, it is 1107 -- always considered to be a tool name, even if there is a string 1108 -- variable of that name. 1109 1110 -- The one argument ON/OFF case is processed by the parser, since it may 1111 -- control parser warnings as well as semantic warnings, and in any case 1112 -- we want to be absolutely sure that the range in the warnings table is 1113 -- set well before any semantic analysis is performed. Note that we 1114 -- ignore this pragma if debug flag -gnatd.i is set. 1115 1116 -- Also note that the "one argument" case may have two or three 1117 -- arguments if the first one is a tool name, and/or the last one is a 1118 -- reason argument. 1119 1120 when Pragma_Warnings => Warnings : declare 1121 function First_Arg_Is_Matching_Tool_Name return Boolean; 1122 -- Returns True if the first argument is a tool name matching the 1123 -- current tool being run. 1124 1125 function Last_Arg return Node_Id; 1126 -- Returns the last argument 1127 1128 function Last_Arg_Is_Reason return Boolean; 1129 -- Returns True if the last argument is a reason argument 1130 1131 function Get_Reason return String_Id; 1132 -- Analyzes Reason argument and returns corresponding String_Id 1133 -- value, or null if there is no Reason argument, or if the 1134 -- argument is not of the required form. 1135 1136 ------------------------------------- 1137 -- First_Arg_Is_Matching_Tool_Name -- 1138 ------------------------------------- 1139 1140 function First_Arg_Is_Matching_Tool_Name return Boolean is 1141 begin 1142 return Nkind (Arg1) = N_Identifier 1143 1144 -- Return True if the tool name is GNAT, and we're not in 1145 -- GNATprove or CodePeer or ASIS mode... 1146 1147 and then ((Chars (Arg1) = Name_Gnat 1148 and then not 1149 (CodePeer_Mode or GNATprove_Mode or ASIS_Mode)) 1150 1151 -- or if the tool name is GNATprove, and we're in GNATprove 1152 -- mode. 1153 1154 or else 1155 (Chars (Arg1) = Name_Gnatprove 1156 and then GNATprove_Mode)); 1157 end First_Arg_Is_Matching_Tool_Name; 1158 1159 ---------------- 1160 -- Get_Reason -- 1161 ---------------- 1162 1163 function Get_Reason return String_Id is 1164 Arg : constant Node_Id := Last_Arg; 1165 begin 1166 if Last_Arg_Is_Reason then 1167 Start_String; 1168 Get_Reason_String (Expression (Arg)); 1169 return End_String; 1170 else 1171 return Null_String_Id; 1172 end if; 1173 end Get_Reason; 1174 1175 -------------- 1176 -- Last_Arg -- 1177 -------------- 1178 1179 function Last_Arg return Node_Id is 1180 Last_Arg : Node_Id; 1181 1182 begin 1183 if Arg_Count = 1 then 1184 Last_Arg := Arg1; 1185 elsif Arg_Count = 2 then 1186 Last_Arg := Arg2; 1187 elsif Arg_Count = 3 then 1188 Last_Arg := Arg3; 1189 elsif Arg_Count = 4 then 1190 Last_Arg := Next (Arg3); 1191 1192 -- Illegal case, error issued in semantic analysis 1193 1194 else 1195 Last_Arg := Empty; 1196 end if; 1197 1198 return Last_Arg; 1199 end Last_Arg; 1200 1201 ------------------------ 1202 -- Last_Arg_Is_Reason -- 1203 ------------------------ 1204 1205 function Last_Arg_Is_Reason return Boolean is 1206 Arg : constant Node_Id := Last_Arg; 1207 begin 1208 return Nkind (Arg) in N_Has_Chars 1209 and then Chars (Arg) = Name_Reason; 1210 end Last_Arg_Is_Reason; 1211 1212 The_Arg : Node_Id; -- On/Off argument 1213 Argx : Node_Id; 1214 1215 -- Start of processing for Warnings 1216 1217 begin 1218 if not Debug_Flag_Dot_I 1219 and then (Arg_Count = 1 1220 or else (Arg_Count = 2 1221 and then (First_Arg_Is_Matching_Tool_Name 1222 or else 1223 Last_Arg_Is_Reason)) 1224 or else (Arg_Count = 3 1225 and then First_Arg_Is_Matching_Tool_Name 1226 and then Last_Arg_Is_Reason)) 1227 then 1228 if First_Arg_Is_Matching_Tool_Name then 1229 The_Arg := Arg2; 1230 else 1231 The_Arg := Arg1; 1232 end if; 1233 1234 Check_No_Identifier (The_Arg); 1235 Argx := Expression (The_Arg); 1236 1237 if Nkind (Argx) = N_Identifier then 1238 if Chars (Argx) = Name_On then 1239 Set_Warnings_Mode_On (Pragma_Sloc); 1240 elsif Chars (Argx) = Name_Off then 1241 Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason); 1242 end if; 1243 end if; 1244 end if; 1245 end Warnings; 1246 1247 ----------------------------- 1248 -- Wide_Character_Encoding -- 1249 ----------------------------- 1250 1251 -- pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); 1252 1253 -- This is processed by the parser, since the scanner is affected 1254 1255 when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare 1256 A : Node_Id; 1257 1258 begin 1259 Check_Arg_Count (1); 1260 Check_No_Identifier (Arg1); 1261 A := Expression (Arg1); 1262 1263 if Nkind (A) = N_Identifier then 1264 Get_Name_String (Chars (A)); 1265 Wide_Character_Encoding_Method := 1266 Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len)); 1267 1268 elsif Nkind (A) = N_Character_Literal then 1269 declare 1270 R : constant Char_Code := 1271 Char_Code (UI_To_Int (Char_Literal_Value (A))); 1272 begin 1273 if In_Character_Range (R) then 1274 Wide_Character_Encoding_Method := 1275 Get_WC_Encoding_Method (Get_Character (R)); 1276 else 1277 raise Constraint_Error; 1278 end if; 1279 end; 1280 1281 else 1282 raise Constraint_Error; 1283 end if; 1284 1285 Upper_Half_Encoding := 1286 Wide_Character_Encoding_Method in 1287 WC_Upper_Half_Encoding_Method; 1288 1289 exception 1290 when Constraint_Error => 1291 Error_Msg_N ("invalid argument for pragma%", Arg1); 1292 end Wide_Character_Encoding; 1293 1294 ----------------------- 1295 -- All Other Pragmas -- 1296 ----------------------- 1297 1298 -- For all other pragmas, checking and processing is handled entirely in 1299 -- Sem_Prag, and no further checking is done by Par. 1300 1301 when Pragma_Abort_Defer 1302 | Pragma_Abstract_State 1303 | Pragma_Acc_Data 1304 | Pragma_Acc_Kernels 1305 | Pragma_Acc_Loop 1306 | Pragma_Acc_Parallel 1307 | Pragma_Async_Readers 1308 | Pragma_Async_Writers 1309 | Pragma_Assertion_Policy 1310 | Pragma_Assume 1311 | Pragma_Assume_No_Invalid_Values 1312 | Pragma_All_Calls_Remote 1313 | Pragma_Allow_Integer_Address 1314 | Pragma_Annotate 1315 | Pragma_Assert 1316 | Pragma_Assert_And_Cut 1317 | Pragma_Asynchronous 1318 | Pragma_Atomic 1319 | Pragma_Atomic_Components 1320 | Pragma_Attach_Handler 1321 | Pragma_Attribute_Definition 1322 | Pragma_Check 1323 | Pragma_Check_Float_Overflow 1324 | Pragma_Check_Name 1325 | Pragma_Check_Policy 1326 | Pragma_Compile_Time_Error 1327 | Pragma_Compile_Time_Warning 1328 | Pragma_Constant_After_Elaboration 1329 | Pragma_Contract_Cases 1330 | Pragma_Convention_Identifier 1331 | Pragma_CPP_Class 1332 | Pragma_CPP_Constructor 1333 | Pragma_CPP_Virtual 1334 | Pragma_CPP_Vtable 1335 | Pragma_CPU 1336 | Pragma_C_Pass_By_Copy 1337 | Pragma_Comment 1338 | Pragma_Common_Object 1339 | Pragma_Complete_Representation 1340 | Pragma_Complex_Representation 1341 | Pragma_Component_Alignment 1342 | Pragma_Controlled 1343 | Pragma_Convention 1344 | Pragma_Deadline_Floor 1345 | Pragma_Debug_Policy 1346 | Pragma_Depends 1347 | Pragma_Detect_Blocking 1348 | Pragma_Default_Initial_Condition 1349 | Pragma_Default_Scalar_Storage_Order 1350 | Pragma_Default_Storage_Pool 1351 | Pragma_Disable_Atomic_Synchronization 1352 | Pragma_Discard_Names 1353 | Pragma_Dispatching_Domain 1354 | Pragma_Effective_Reads 1355 | Pragma_Effective_Writes 1356 | Pragma_Eliminate 1357 | Pragma_Elaborate 1358 | Pragma_Elaborate_All 1359 | Pragma_Elaborate_Body 1360 | Pragma_Elaboration_Checks 1361 | Pragma_Enable_Atomic_Synchronization 1362 | Pragma_Export 1363 | Pragma_Export_Function 1364 | Pragma_Export_Object 1365 | Pragma_Export_Procedure 1366 | Pragma_Export_Value 1367 | Pragma_Export_Valued_Procedure 1368 | Pragma_Extend_System 1369 | Pragma_Extensions_Visible 1370 | Pragma_External 1371 | Pragma_External_Name_Casing 1372 | Pragma_Favor_Top_Level 1373 | Pragma_Fast_Math 1374 | Pragma_Finalize_Storage_Only 1375 | Pragma_Ghost 1376 | Pragma_Global 1377 | Pragma_Ident 1378 | Pragma_Implementation_Defined 1379 | Pragma_Implemented 1380 | Pragma_Implicit_Packing 1381 | Pragma_Import 1382 | Pragma_Import_Function 1383 | Pragma_Import_Object 1384 | Pragma_Import_Procedure 1385 | Pragma_Import_Valued_Procedure 1386 | Pragma_Independent 1387 | Pragma_Independent_Components 1388 | Pragma_Initial_Condition 1389 | Pragma_Initialize_Scalars 1390 | Pragma_Initializes 1391 | Pragma_Inline 1392 | Pragma_Inline_Always 1393 | Pragma_Inline_Generic 1394 | Pragma_Inspection_Point 1395 | Pragma_Interface 1396 | Pragma_Interface_Name 1397 | Pragma_Interrupt_Handler 1398 | Pragma_Interrupt_State 1399 | Pragma_Interrupt_Priority 1400 | Pragma_Invariant 1401 | Pragma_Keep_Names 1402 | Pragma_License 1403 | Pragma_Link_With 1404 | Pragma_Linker_Alias 1405 | Pragma_Linker_Constructor 1406 | Pragma_Linker_Destructor 1407 | Pragma_Linker_Options 1408 | Pragma_Linker_Section 1409 | Pragma_Lock_Free 1410 | Pragma_Locking_Policy 1411 | Pragma_Loop_Invariant 1412 | Pragma_Loop_Optimize 1413 | Pragma_Loop_Variant 1414 | Pragma_Machine_Attribute 1415 | Pragma_Main 1416 | Pragma_Main_Storage 1417 | Pragma_Max_Entry_Queue_Depth 1418 | Pragma_Max_Queue_Length 1419 | Pragma_Memory_Size 1420 | Pragma_No_Body 1421 | Pragma_No_Component_Reordering 1422 | Pragma_No_Elaboration_Code_All 1423 | Pragma_No_Heap_Finalization 1424 | Pragma_No_Inline 1425 | Pragma_No_Return 1426 | Pragma_No_Run_Time 1427 | Pragma_No_Strict_Aliasing 1428 | Pragma_No_Tagged_Streams 1429 | Pragma_Normalize_Scalars 1430 | Pragma_Obsolescent 1431 | Pragma_Ordered 1432 | Pragma_Optimize 1433 | Pragma_Optimize_Alignment 1434 | Pragma_Overflow_Mode 1435 | Pragma_Overriding_Renamings 1436 | Pragma_Pack 1437 | Pragma_Part_Of 1438 | Pragma_Partition_Elaboration_Policy 1439 | Pragma_Passive 1440 | Pragma_Preelaborable_Initialization 1441 | Pragma_Polling 1442 | Pragma_Prefix_Exception_Messages 1443 | Pragma_Persistent_BSS 1444 | Pragma_Post 1445 | Pragma_Postcondition 1446 | Pragma_Post_Class 1447 | Pragma_Pre 1448 | Pragma_Precondition 1449 | Pragma_Predicate 1450 | Pragma_Predicate_Failure 1451 | Pragma_Preelaborate 1452 | Pragma_Pre_Class 1453 | Pragma_Priority 1454 | Pragma_Priority_Specific_Dispatching 1455 | Pragma_Profile 1456 | Pragma_Profile_Warnings 1457 | Pragma_Propagate_Exceptions 1458 | Pragma_Provide_Shift_Operators 1459 | Pragma_Psect_Object 1460 | Pragma_Pure 1461 | Pragma_Pure_Function 1462 | Pragma_Queuing_Policy 1463 | Pragma_Refined_Depends 1464 | Pragma_Refined_Global 1465 | Pragma_Refined_Post 1466 | Pragma_Refined_State 1467 | Pragma_Relative_Deadline 1468 | Pragma_Remote_Access_Type 1469 | Pragma_Remote_Call_Interface 1470 | Pragma_Remote_Types 1471 | Pragma_Restricted_Run_Time 1472 | Pragma_Rational 1473 | Pragma_Ravenscar 1474 | Pragma_Rename_Pragma 1475 | Pragma_Reviewable 1476 | Pragma_Secondary_Stack_Size 1477 | Pragma_Share_Generic 1478 | Pragma_Shared 1479 | Pragma_Shared_Passive 1480 | Pragma_Short_Circuit_And_Or 1481 | Pragma_Short_Descriptors 1482 | Pragma_Simple_Storage_Pool_Type 1483 | Pragma_SPARK_Mode 1484 | Pragma_Storage_Size 1485 | Pragma_Storage_Unit 1486 | Pragma_Static_Elaboration_Desired 1487 | Pragma_Stream_Convert 1488 | Pragma_Subtitle 1489 | Pragma_Suppress 1490 | Pragma_Suppress_Debug_Info 1491 | Pragma_Suppress_Exception_Locations 1492 | Pragma_Suppress_Initialization 1493 | Pragma_System_Name 1494 | Pragma_Task_Dispatching_Policy 1495 | Pragma_Task_Info 1496 | Pragma_Task_Name 1497 | Pragma_Task_Storage 1498 | Pragma_Test_Case 1499 | Pragma_Thread_Local_Storage 1500 | Pragma_Time_Slice 1501 | Pragma_Title 1502 | Pragma_Type_Invariant 1503 | Pragma_Type_Invariant_Class 1504 | Pragma_Unchecked_Union 1505 | Pragma_Unevaluated_Use_Of_Old 1506 | Pragma_Unimplemented_Unit 1507 | Pragma_Universal_Aliasing 1508 | Pragma_Universal_Data 1509 | Pragma_Unmodified 1510 | Pragma_Unreferenced 1511 | Pragma_Unreferenced_Objects 1512 | Pragma_Unreserve_All_Interrupts 1513 | Pragma_Unsuppress 1514 | Pragma_Unused 1515 | Pragma_Use_VADS_Size 1516 | Pragma_Volatile 1517 | Pragma_Volatile_Components 1518 | Pragma_Volatile_Full_Access 1519 | Pragma_Volatile_Function 1520 | Pragma_Warning_As_Error 1521 | Pragma_Weak_External 1522 | Pragma_Validity_Checks 1523 => 1524 null; 1525 1526 -------------------- 1527 -- Unknown_Pragma -- 1528 -------------------- 1529 1530 -- Should be impossible, since we excluded this case earlier on 1531 1532 when Unknown_Pragma => 1533 raise Program_Error; 1534 1535 end case; 1536 1537 return Pragma_Node; 1538 1539 -------------------- 1540 -- Error Handling -- 1541 -------------------- 1542 1543exception 1544 when Error_Resync => 1545 return Error; 1546 1547end Prag; 1548