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 -- Warning_As_Error -- 1093 ---------------------- 1094 1095 -- pragma Warning_As_Error (static_string_EXPRESSION); 1096 1097 -- Further processing is done in Sem_Prag 1098 1099 when Pragma_Warning_As_Error => 1100 Check_Arg_Count (1); 1101 Check_Arg_Is_String_Literal (Arg1); 1102 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1; 1103 Warnings_As_Errors (Warnings_As_Errors_Count) := 1104 new String'(Acquire_Warning_Match_String (Get_Pragma_Arg (Arg1))); 1105 1106 --------------------- 1107 -- Warnings (GNAT) -- 1108 --------------------- 1109 1110 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); 1111 1112 -- DETAILS ::= On | Off 1113 -- DETAILS ::= On | Off, local_NAME 1114 -- DETAILS ::= static_string_EXPRESSION 1115 -- DETAILS ::= On | Off, static_string_EXPRESSION 1116 1117 -- TOOL_NAME ::= GNAT | GNATProve 1118 1119 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} 1120 1121 -- Note: If the first argument matches an allowed tool name, it is 1122 -- always considered to be a tool name, even if there is a string 1123 -- variable of that name. 1124 1125 -- The one argument ON/OFF case is processed by the parser, since it may 1126 -- control parser warnings as well as semantic warnings, and in any case 1127 -- we want to be absolutely sure that the range in the warnings table is 1128 -- set well before any semantic analysis is performed. Note that we 1129 -- ignore this pragma if debug flag -gnatd.i is set. 1130 1131 -- Also note that the "one argument" case may have two or three 1132 -- arguments if the first one is a tool name, and/or the last one is a 1133 -- reason argument. 1134 1135 when Pragma_Warnings => Warnings : declare 1136 function First_Arg_Is_Matching_Tool_Name return Boolean; 1137 -- Returns True if the first argument is a tool name matching the 1138 -- current tool being run. 1139 1140 function Last_Arg return Node_Id; 1141 -- Returns the last argument 1142 1143 function Last_Arg_Is_Reason return Boolean; 1144 -- Returns True if the last argument is a reason argument 1145 1146 function Get_Reason return String_Id; 1147 -- Analyzes Reason argument and returns corresponding String_Id 1148 -- value, or null if there is no Reason argument, or if the 1149 -- argument is not of the required form. 1150 1151 ------------------------------------- 1152 -- First_Arg_Is_Matching_Tool_Name -- 1153 ------------------------------------- 1154 1155 function First_Arg_Is_Matching_Tool_Name return Boolean is 1156 begin 1157 return Nkind (Arg1) = N_Identifier 1158 1159 -- Return True if the tool name is GNAT, and we're not in 1160 -- GNATprove or CodePeer or ASIS mode... 1161 1162 and then ((Chars (Arg1) = Name_Gnat 1163 and then not 1164 (CodePeer_Mode or GNATprove_Mode or ASIS_Mode)) 1165 1166 -- or if the tool name is GNATprove, and we're in GNATprove 1167 -- mode. 1168 1169 or else 1170 (Chars (Arg1) = Name_Gnatprove 1171 and then GNATprove_Mode)); 1172 end First_Arg_Is_Matching_Tool_Name; 1173 1174 ---------------- 1175 -- Get_Reason -- 1176 ---------------- 1177 1178 function Get_Reason return String_Id is 1179 Arg : constant Node_Id := Last_Arg; 1180 begin 1181 if Last_Arg_Is_Reason then 1182 Start_String; 1183 Get_Reason_String (Expression (Arg)); 1184 return End_String; 1185 else 1186 return Null_String_Id; 1187 end if; 1188 end Get_Reason; 1189 1190 -------------- 1191 -- Last_Arg -- 1192 -------------- 1193 1194 function Last_Arg return Node_Id is 1195 Last_Arg : Node_Id; 1196 1197 begin 1198 if Arg_Count = 1 then 1199 Last_Arg := Arg1; 1200 elsif Arg_Count = 2 then 1201 Last_Arg := Arg2; 1202 elsif Arg_Count = 3 then 1203 Last_Arg := Arg3; 1204 elsif Arg_Count = 4 then 1205 Last_Arg := Next (Arg3); 1206 1207 -- Illegal case, error issued in semantic analysis 1208 1209 else 1210 Last_Arg := Empty; 1211 end if; 1212 1213 return Last_Arg; 1214 end Last_Arg; 1215 1216 ------------------------ 1217 -- Last_Arg_Is_Reason -- 1218 ------------------------ 1219 1220 function Last_Arg_Is_Reason return Boolean is 1221 Arg : constant Node_Id := Last_Arg; 1222 begin 1223 return Nkind (Arg) in N_Has_Chars 1224 and then Chars (Arg) = Name_Reason; 1225 end Last_Arg_Is_Reason; 1226 1227 The_Arg : Node_Id; -- On/Off argument 1228 Argx : Node_Id; 1229 1230 -- Start of processing for Warnings 1231 1232 begin 1233 if not Debug_Flag_Dot_I 1234 and then (Arg_Count = 1 1235 or else (Arg_Count = 2 1236 and then (First_Arg_Is_Matching_Tool_Name 1237 or else 1238 Last_Arg_Is_Reason)) 1239 or else (Arg_Count = 3 1240 and then First_Arg_Is_Matching_Tool_Name 1241 and then Last_Arg_Is_Reason)) 1242 then 1243 if First_Arg_Is_Matching_Tool_Name then 1244 The_Arg := Arg2; 1245 else 1246 The_Arg := Arg1; 1247 end if; 1248 1249 Check_No_Identifier (The_Arg); 1250 Argx := Expression (The_Arg); 1251 1252 if Nkind (Argx) = N_Identifier then 1253 if Chars (Argx) = Name_On then 1254 Set_Warnings_Mode_On (Pragma_Sloc); 1255 elsif Chars (Argx) = Name_Off then 1256 Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason); 1257 end if; 1258 end if; 1259 end if; 1260 end Warnings; 1261 1262 ----------------------------- 1263 -- Wide_Character_Encoding -- 1264 ----------------------------- 1265 1266 -- pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); 1267 1268 -- This is processed by the parser, since the scanner is affected 1269 1270 when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare 1271 A : Node_Id; 1272 1273 begin 1274 Check_Arg_Count (1); 1275 Check_No_Identifier (Arg1); 1276 A := Expression (Arg1); 1277 1278 if Nkind (A) = N_Identifier then 1279 Get_Name_String (Chars (A)); 1280 Wide_Character_Encoding_Method := 1281 Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len)); 1282 1283 elsif Nkind (A) = N_Character_Literal then 1284 declare 1285 R : constant Char_Code := 1286 Char_Code (UI_To_Int (Char_Literal_Value (A))); 1287 begin 1288 if In_Character_Range (R) then 1289 Wide_Character_Encoding_Method := 1290 Get_WC_Encoding_Method (Get_Character (R)); 1291 else 1292 raise Constraint_Error; 1293 end if; 1294 end; 1295 1296 else 1297 raise Constraint_Error; 1298 end if; 1299 1300 Upper_Half_Encoding := 1301 Wide_Character_Encoding_Method in 1302 WC_Upper_Half_Encoding_Method; 1303 1304 exception 1305 when Constraint_Error => 1306 Error_Msg_N ("invalid argument for pragma%", Arg1); 1307 end Wide_Character_Encoding; 1308 1309 ----------------------- 1310 -- All Other Pragmas -- 1311 ----------------------- 1312 1313 -- For all other pragmas, checking and processing is handled entirely in 1314 -- Sem_Prag, and no further checking is done by Par. 1315 1316 when Pragma_Abort_Defer 1317 | Pragma_Abstract_State 1318 | Pragma_Acc_Data 1319 | Pragma_Acc_Kernels 1320 | Pragma_Acc_Loop 1321 | Pragma_Acc_Parallel 1322 | Pragma_Aggregate_Individually_Assign 1323 | Pragma_Async_Readers 1324 | Pragma_Async_Writers 1325 | Pragma_Assertion_Policy 1326 | Pragma_Assume 1327 | Pragma_Assume_No_Invalid_Values 1328 | Pragma_All_Calls_Remote 1329 | Pragma_Allow_Integer_Address 1330 | Pragma_Annotate 1331 | Pragma_Assert 1332 | Pragma_Assert_And_Cut 1333 | Pragma_Asynchronous 1334 | Pragma_Atomic 1335 | Pragma_Atomic_Components 1336 | Pragma_Attach_Handler 1337 | Pragma_Attribute_Definition 1338 | Pragma_Check 1339 | Pragma_Check_Float_Overflow 1340 | Pragma_Check_Name 1341 | Pragma_Check_Policy 1342 | Pragma_Compile_Time_Error 1343 | Pragma_Compile_Time_Warning 1344 | Pragma_Constant_After_Elaboration 1345 | Pragma_Contract_Cases 1346 | Pragma_Convention_Identifier 1347 | Pragma_CPP_Class 1348 | Pragma_CPP_Constructor 1349 | Pragma_CPP_Virtual 1350 | Pragma_CPP_Vtable 1351 | Pragma_CPU 1352 | Pragma_C_Pass_By_Copy 1353 | Pragma_Comment 1354 | Pragma_Common_Object 1355 | Pragma_Complete_Representation 1356 | Pragma_Complex_Representation 1357 | Pragma_Component_Alignment 1358 | Pragma_Controlled 1359 | Pragma_Convention 1360 | Pragma_Deadline_Floor 1361 | Pragma_Debug_Policy 1362 | Pragma_Depends 1363 | Pragma_Detect_Blocking 1364 | Pragma_Default_Initial_Condition 1365 | Pragma_Default_Scalar_Storage_Order 1366 | Pragma_Default_Storage_Pool 1367 | Pragma_Disable_Atomic_Synchronization 1368 | Pragma_Discard_Names 1369 | Pragma_Dispatching_Domain 1370 | Pragma_Effective_Reads 1371 | Pragma_Effective_Writes 1372 | Pragma_Eliminate 1373 | Pragma_Elaborate 1374 | Pragma_Elaborate_All 1375 | Pragma_Elaborate_Body 1376 | Pragma_Elaboration_Checks 1377 | Pragma_Enable_Atomic_Synchronization 1378 | Pragma_Export 1379 | Pragma_Export_Function 1380 | Pragma_Export_Object 1381 | Pragma_Export_Procedure 1382 | Pragma_Export_Value 1383 | Pragma_Export_Valued_Procedure 1384 | Pragma_Extend_System 1385 | Pragma_Extensions_Visible 1386 | Pragma_External 1387 | Pragma_External_Name_Casing 1388 | Pragma_Favor_Top_Level 1389 | Pragma_Fast_Math 1390 | Pragma_Finalize_Storage_Only 1391 | Pragma_Ghost 1392 | Pragma_Global 1393 | Pragma_Ident 1394 | Pragma_Implementation_Defined 1395 | Pragma_Implemented 1396 | Pragma_Implicit_Packing 1397 | Pragma_Import 1398 | Pragma_Import_Function 1399 | Pragma_Import_Object 1400 | Pragma_Import_Procedure 1401 | Pragma_Import_Valued_Procedure 1402 | Pragma_Independent 1403 | Pragma_Independent_Components 1404 | Pragma_Initial_Condition 1405 | Pragma_Initialize_Scalars 1406 | Pragma_Initializes 1407 | Pragma_Inline 1408 | Pragma_Inline_Always 1409 | Pragma_Inline_Generic 1410 | Pragma_Inspection_Point 1411 | Pragma_Interface 1412 | Pragma_Interface_Name 1413 | Pragma_Interrupt_Handler 1414 | Pragma_Interrupt_State 1415 | Pragma_Interrupt_Priority 1416 | Pragma_Invariant 1417 | Pragma_Keep_Names 1418 | Pragma_License 1419 | Pragma_Link_With 1420 | Pragma_Linker_Alias 1421 | Pragma_Linker_Constructor 1422 | Pragma_Linker_Destructor 1423 | Pragma_Linker_Options 1424 | Pragma_Linker_Section 1425 | Pragma_Lock_Free 1426 | Pragma_Locking_Policy 1427 | Pragma_Loop_Invariant 1428 | Pragma_Loop_Optimize 1429 | Pragma_Loop_Variant 1430 | Pragma_Machine_Attribute 1431 | Pragma_Main 1432 | Pragma_Main_Storage 1433 | Pragma_Max_Entry_Queue_Depth 1434 | Pragma_Max_Entry_Queue_Length 1435 | Pragma_Max_Queue_Length 1436 | Pragma_Memory_Size 1437 | Pragma_No_Body 1438 | Pragma_No_Caching 1439 | Pragma_No_Component_Reordering 1440 | Pragma_No_Elaboration_Code_All 1441 | Pragma_No_Heap_Finalization 1442 | Pragma_No_Inline 1443 | Pragma_No_Return 1444 | Pragma_No_Run_Time 1445 | Pragma_No_Strict_Aliasing 1446 | Pragma_No_Tagged_Streams 1447 | Pragma_Normalize_Scalars 1448 | Pragma_Obsolescent 1449 | Pragma_Ordered 1450 | Pragma_Optimize 1451 | Pragma_Optimize_Alignment 1452 | Pragma_Overflow_Mode 1453 | Pragma_Overriding_Renamings 1454 | Pragma_Pack 1455 | Pragma_Part_Of 1456 | Pragma_Partition_Elaboration_Policy 1457 | Pragma_Passive 1458 | Pragma_Preelaborable_Initialization 1459 | Pragma_Polling 1460 | Pragma_Prefix_Exception_Messages 1461 | Pragma_Persistent_BSS 1462 | Pragma_Post 1463 | Pragma_Postcondition 1464 | Pragma_Post_Class 1465 | Pragma_Pre 1466 | Pragma_Precondition 1467 | Pragma_Predicate 1468 | Pragma_Predicate_Failure 1469 | Pragma_Preelaborate 1470 | Pragma_Pre_Class 1471 | Pragma_Priority 1472 | Pragma_Priority_Specific_Dispatching 1473 | Pragma_Profile 1474 | Pragma_Profile_Warnings 1475 | Pragma_Propagate_Exceptions 1476 | Pragma_Provide_Shift_Operators 1477 | Pragma_Psect_Object 1478 | Pragma_Pure 1479 | Pragma_Pure_Function 1480 | Pragma_Queuing_Policy 1481 | Pragma_Refined_Depends 1482 | Pragma_Refined_Global 1483 | Pragma_Refined_Post 1484 | Pragma_Refined_State 1485 | Pragma_Relative_Deadline 1486 | Pragma_Remote_Access_Type 1487 | Pragma_Remote_Call_Interface 1488 | Pragma_Remote_Types 1489 | Pragma_Restricted_Run_Time 1490 | Pragma_Rational 1491 | Pragma_Ravenscar 1492 | Pragma_Rename_Pragma 1493 | Pragma_Reviewable 1494 | Pragma_Secondary_Stack_Size 1495 | Pragma_Share_Generic 1496 | Pragma_Shared 1497 | Pragma_Shared_Passive 1498 | Pragma_Short_Circuit_And_Or 1499 | Pragma_Short_Descriptors 1500 | Pragma_Simple_Storage_Pool_Type 1501 | Pragma_SPARK_Mode 1502 | Pragma_Storage_Size 1503 | Pragma_Storage_Unit 1504 | Pragma_Static_Elaboration_Desired 1505 | Pragma_Stream_Convert 1506 | Pragma_Subtitle 1507 | Pragma_Suppress 1508 | Pragma_Suppress_Debug_Info 1509 | Pragma_Suppress_Exception_Locations 1510 | Pragma_Suppress_Initialization 1511 | Pragma_System_Name 1512 | Pragma_Task_Dispatching_Policy 1513 | Pragma_Task_Info 1514 | Pragma_Task_Name 1515 | Pragma_Task_Storage 1516 | Pragma_Test_Case 1517 | Pragma_Thread_Local_Storage 1518 | Pragma_Time_Slice 1519 | Pragma_Title 1520 | Pragma_Type_Invariant 1521 | Pragma_Type_Invariant_Class 1522 | Pragma_Unchecked_Union 1523 | Pragma_Unevaluated_Use_Of_Old 1524 | Pragma_Unimplemented_Unit 1525 | Pragma_Universal_Aliasing 1526 | Pragma_Universal_Data 1527 | Pragma_Unmodified 1528 | Pragma_Unreferenced 1529 | Pragma_Unreferenced_Objects 1530 | Pragma_Unreserve_All_Interrupts 1531 | Pragma_Unsuppress 1532 | Pragma_Unused 1533 | Pragma_Use_VADS_Size 1534 | Pragma_Volatile 1535 | Pragma_Volatile_Components 1536 | Pragma_Volatile_Full_Access 1537 | Pragma_Volatile_Function 1538 | Pragma_Weak_External 1539 | Pragma_Validity_Checks 1540 => 1541 null; 1542 1543 -------------------- 1544 -- Unknown_Pragma -- 1545 -------------------- 1546 1547 -- Should be impossible, since we excluded this case earlier on 1548 1549 when Unknown_Pragma => 1550 raise Program_Error; 1551 1552 end case; 1553 1554 return Pragma_Node; 1555 1556 -------------------- 1557 -- Error Handling -- 1558 -------------------- 1559 1560exception 1561 when Error_Resync => 1562 return Error; 1563 1564end Prag; 1565