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