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-2021, 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_N ("wrong number of arguments for pragma%", Pragma_Node); 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_N ("argument for pragma% must be% or%", 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_N 193 ("argument for pragma% must be string literal", 194 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_2022 -- 389 -------------- 390 391 when Pragma_Ada_2022 => 392 if Arg_Count = 0 then 393 Ada_Version := Ada_2022; 394 Ada_Version_Explicit := Ada_2022; 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 Ada_Version := Ada_With_Extensions; 447 else 448 Ada_Version := Ada_Version_Explicit; 449 end if; 450 451 ------------------- 452 -- Ignore_Pragma -- 453 ------------------- 454 455 -- Processing for this pragma must be done at parse time, since we want 456 -- be able to ignore pragmas that are otherwise processed at parse time. 457 458 when Pragma_Ignore_Pragma => Ignore_Pragma : declare 459 A : Node_Id; 460 461 begin 462 Check_Arg_Count (1); 463 Check_No_Identifier (Arg1); 464 A := Expression (Arg1); 465 466 if Nkind (A) /= N_Identifier then 467 Error_Msg_N ("incorrect argument for pragma %", A); 468 else 469 Set_Name_Table_Boolean3 (Chars (A), True); 470 end if; 471 end Ignore_Pragma; 472 473 ---------------- 474 -- List (2.8) -- 475 ---------------- 476 477 -- pragma List (Off | On) 478 479 -- The processing for pragma List must be done at parse time, since a 480 -- listing can be generated in parse only mode. 481 482 when Pragma_List => 483 Check_Arg_Count (1); 484 Check_No_Identifier (Arg1); 485 Check_Arg_Is_On_Or_Off (Arg1); 486 487 -- We unconditionally make a List_On entry for the pragma, so that 488 -- in the List (Off) case, the pragma will print even in a region 489 -- of code with listing turned off (this is required). 490 491 Add_List_Pragma_Entry (List_On, Sloc (Pragma_Node)); 492 493 -- Now generate the list off entry for pragma List (Off) 494 495 if Chars (Expression (Arg1)) = Name_Off then 496 Add_List_Pragma_Entry (List_Off, Semi); 497 end if; 498 499 ---------------- 500 -- Page (2.8) -- 501 ---------------- 502 503 -- pragma Page; 504 505 -- Processing for this pragma must be done at parse time, since a 506 -- listing can be generated in parse only mode with semantics off. 507 508 when Pragma_Page => 509 Check_Arg_Count (0); 510 Add_List_Pragma_Entry (Page, Semi); 511 512 ------------------ 513 -- Restrictions -- 514 ------------------ 515 516 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 517 518 -- RESTRICTION ::= 519 -- restriction_IDENTIFIER 520 -- | restriction_parameter_IDENTIFIER => EXPRESSION 521 522 -- We process the case of No_Obsolescent_Features, since this has 523 -- a syntactic effect that we need to detect at parse time (the use 524 -- of replacement characters such as colon for pound sign). 525 526 when Pragma_Restrictions => 527 Process_Restrictions_Or_Restriction_Warnings; 528 529 -------------------------- 530 -- Restriction_Warnings -- 531 -------------------------- 532 533 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 534 535 -- RESTRICTION ::= 536 -- restriction_IDENTIFIER 537 -- | restriction_parameter_IDENTIFIER => EXPRESSION 538 539 -- See above comment for pragma Restrictions 540 541 when Pragma_Restriction_Warnings => 542 Process_Restrictions_Or_Restriction_Warnings; 543 544 ---------------------------------------------------------- 545 -- Source_File_Name and Source_File_Name_Project (GNAT) -- 546 ---------------------------------------------------------- 547 548 -- These two pragmas have the same syntax and semantics. 549 -- There are five forms of these pragmas: 550 551 -- pragma Source_File_Name[_Project] ( 552 -- [UNIT_NAME =>] unit_NAME, 553 -- BODY_FILE_NAME => STRING_LITERAL 554 -- [, [INDEX =>] INTEGER_LITERAL]); 555 556 -- pragma Source_File_Name[_Project] ( 557 -- [UNIT_NAME =>] unit_NAME, 558 -- SPEC_FILE_NAME => STRING_LITERAL 559 -- [, [INDEX =>] INTEGER_LITERAL]); 560 561 -- pragma Source_File_Name[_Project] ( 562 -- BODY_FILE_NAME => STRING_LITERAL 563 -- [, DOT_REPLACEMENT => STRING_LITERAL] 564 -- [, CASING => CASING_SPEC]); 565 566 -- pragma Source_File_Name[_Project] ( 567 -- SPEC_FILE_NAME => STRING_LITERAL 568 -- [, DOT_REPLACEMENT => STRING_LITERAL] 569 -- [, CASING => CASING_SPEC]); 570 571 -- pragma Source_File_Name[_Project] ( 572 -- SUBUNIT_FILE_NAME => STRING_LITERAL 573 -- [, DOT_REPLACEMENT => STRING_LITERAL] 574 -- [, CASING => CASING_SPEC]); 575 576 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 577 578 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 579 -- Source_File_Name (SFN), however their usage is exclusive: 580 -- SFN can only be used when no project file is used, while 581 -- SFNP can only be used when a project file is used. 582 583 -- The Project Manager produces a configuration pragmas file that 584 -- is communicated to the compiler with -gnatec switch. This file 585 -- contains only SFNP pragmas (at least two for the default naming 586 -- scheme. As this configuration pragmas file is always the first 587 -- processed by the compiler, it prevents the use of pragmas SFN in 588 -- other config files when a project file is in use. 589 590 -- Note: we process this during parsing, since we need to have the 591 -- source file names set well before the semantic analysis starts, 592 -- since we load the spec and with'ed packages before analysis. 593 594 when Pragma_Source_File_Name 595 | Pragma_Source_File_Name_Project 596 => 597 Source_File_Name : declare 598 Unam : Unit_Name_Type; 599 Expr1 : Node_Id; 600 Pat : String_Ptr; 601 Typ : Character; 602 Dot : String_Ptr; 603 Cas : Casing_Type; 604 Nast : Nat; 605 Expr : Node_Id; 606 Index : Nat; 607 608 function Get_Fname (Arg : Node_Id) return File_Name_Type; 609 -- Process file name from unit name form of pragma 610 611 function Get_String_Argument (Arg : Node_Id) return String_Ptr; 612 -- Process string literal value from argument 613 614 procedure Process_Casing (Arg : Node_Id); 615 -- Process Casing argument of pattern form of pragma 616 617 procedure Process_Dot_Replacement (Arg : Node_Id); 618 -- Process Dot_Replacement argument of pattern form of pragma 619 620 --------------- 621 -- Get_Fname -- 622 --------------- 623 624 function Get_Fname (Arg : Node_Id) return File_Name_Type is 625 begin 626 String_To_Name_Buffer (Strval (Expression (Arg))); 627 628 for J in 1 .. Name_Len loop 629 if Is_Directory_Separator (Name_Buffer (J)) then 630 Error_Msg 631 ("directory separator character not allowed", 632 Sloc (Expression (Arg)) + Source_Ptr (J)); 633 end if; 634 end loop; 635 636 return Name_Find; 637 end Get_Fname; 638 639 ------------------------- 640 -- Get_String_Argument -- 641 ------------------------- 642 643 function Get_String_Argument (Arg : Node_Id) return String_Ptr is 644 Str : String_Id; 645 646 begin 647 if Nkind (Expression (Arg)) /= N_String_Literal 648 and then 649 Nkind (Expression (Arg)) /= N_Operator_Symbol 650 then 651 Error_Msg_N 652 ("argument for pragma% must be string literal", Arg); 653 raise Error_Resync; 654 end if; 655 656 Str := Strval (Expression (Arg)); 657 658 -- Check string has no wide chars 659 660 for J in 1 .. String_Length (Str) loop 661 if Get_String_Char (Str, J) > 255 then 662 Error_Msg 663 ("wide character not allowed in pattern for pragma%", 664 Sloc (Expression (Arg2)) + Text_Ptr (J) - 1); 665 end if; 666 end loop; 667 668 -- Acquire string 669 670 String_To_Name_Buffer (Str); 671 return new String'(Name_Buffer (1 .. Name_Len)); 672 end Get_String_Argument; 673 674 -------------------- 675 -- Process_Casing -- 676 -------------------- 677 678 procedure Process_Casing (Arg : Node_Id) is 679 Expr : constant Node_Id := Expression (Arg); 680 681 begin 682 Check_Required_Identifier (Arg, Name_Casing); 683 684 if Nkind (Expr) = N_Identifier then 685 if Chars (Expr) = Name_Lowercase then 686 Cas := All_Lower_Case; 687 return; 688 elsif Chars (Expr) = Name_Uppercase then 689 Cas := All_Upper_Case; 690 return; 691 elsif Chars (Expr) = Name_Mixedcase then 692 Cas := Mixed_Case; 693 return; 694 end if; 695 end if; 696 697 Error_Msg_N 698 ("Casing argument for pragma% must be " & 699 "one of Mixedcase, Lowercase, Uppercase", 700 Arg); 701 end Process_Casing; 702 703 ----------------------------- 704 -- Process_Dot_Replacement -- 705 ----------------------------- 706 707 procedure Process_Dot_Replacement (Arg : Node_Id) is 708 begin 709 Check_Required_Identifier (Arg, Name_Dot_Replacement); 710 Dot := Get_String_Argument (Arg); 711 end Process_Dot_Replacement; 712 713 -- Start of processing for Source_File_Name and 714 -- Source_File_Name_Project pragmas. 715 716 begin 717 if Prag_Id = Pragma_Source_File_Name then 718 if Project_File_In_Use = In_Use then 719 Error_Msg_N 720 ("pragma Source_File_Name cannot be used " & 721 "with a project file", Pragma_Node); 722 723 else 724 Project_File_In_Use := Not_In_Use; 725 end if; 726 727 else 728 if Project_File_In_Use = Not_In_Use then 729 Error_Msg_N 730 ("pragma Source_File_Name_Project should only be used " & 731 "with a project file", Pragma_Node); 732 else 733 Project_File_In_Use := In_Use; 734 end if; 735 end if; 736 737 -- We permit from 1 to 3 arguments 738 739 if Arg_Count not in 1 .. 3 then 740 Check_Arg_Count (1); 741 end if; 742 743 Expr1 := Expression (Arg1); 744 745 -- If first argument is identifier or selected component, then 746 -- we have the specific file case of the Source_File_Name pragma, 747 -- and the first argument is a unit name. 748 749 if Nkind (Expr1) = N_Identifier 750 or else 751 (Nkind (Expr1) = N_Selected_Component 752 and then 753 Nkind (Selector_Name (Expr1)) = N_Identifier) 754 then 755 if Nkind (Expr1) = N_Identifier 756 and then Chars (Expr1) = Name_System 757 then 758 Error_Msg_N 759 ("pragma Source_File_Name may not be used for System", 760 Arg1); 761 return Error; 762 end if; 763 764 -- Process index argument if present 765 766 if Arg_Count = 3 then 767 Expr := Expression (Arg3); 768 769 if Nkind (Expr) /= N_Integer_Literal 770 or else not UI_Is_In_Int_Range (Intval (Expr)) 771 or else Intval (Expr) > 999 772 or else Intval (Expr) <= 0 773 then 774 Error_Msg_N 775 ("pragma% index must be integer literal" & 776 " in range 1 .. 999", Expr); 777 raise Error_Resync; 778 else 779 Index := UI_To_Int (Intval (Expr)); 780 end if; 781 782 -- No index argument present 783 784 else 785 Check_Arg_Count (2); 786 Index := 0; 787 end if; 788 789 Check_Optional_Identifier (Arg1, Name_Unit_Name); 790 Unam := Get_Unit_Name (Expr1); 791 792 Check_Arg_Is_String_Literal (Arg2); 793 794 if Chars (Arg2) = Name_Spec_File_Name then 795 Set_File_Name 796 (Get_Spec_Name (Unam), Get_Fname (Arg2), Index); 797 798 elsif Chars (Arg2) = Name_Body_File_Name then 799 Set_File_Name 800 (Unam, Get_Fname (Arg2), Index); 801 802 else 803 Error_Msg_N 804 ("pragma% argument has incorrect identifier", Arg2); 805 return Pragma_Node; 806 end if; 807 808 -- If the first argument is not an identifier, then we must have 809 -- the pattern form of the pragma, and the first argument must be 810 -- the pattern string with an appropriate name. 811 812 else 813 if Chars (Arg1) = Name_Spec_File_Name then 814 Typ := 's'; 815 816 elsif Chars (Arg1) = Name_Body_File_Name then 817 Typ := 'b'; 818 819 elsif Chars (Arg1) = Name_Subunit_File_Name then 820 Typ := 'u'; 821 822 elsif Chars (Arg1) = Name_Unit_Name then 823 Error_Msg_N 824 ("Unit_Name parameter for pragma% must be an identifier", 825 Arg1); 826 raise Error_Resync; 827 828 else 829 Error_Msg_N 830 ("pragma% argument has incorrect identifier", Arg1); 831 raise Error_Resync; 832 end if; 833 834 Pat := Get_String_Argument (Arg1); 835 836 -- Check pattern has exactly one asterisk 837 838 Nast := 0; 839 for J in Pat'Range loop 840 if Pat (J) = '*' then 841 Nast := Nast + 1; 842 end if; 843 end loop; 844 845 if Nast /= 1 then 846 Error_Msg_N 847 ("file name pattern must have exactly one * character", 848 Arg1); 849 return Pragma_Node; 850 end if; 851 852 -- Set defaults for Casing and Dot_Separator parameters 853 854 Cas := All_Lower_Case; 855 Dot := new String'("."); 856 857 -- Process second and third arguments if present 858 859 if Arg_Count > 1 then 860 if Chars (Arg2) = Name_Casing then 861 Process_Casing (Arg2); 862 863 if Arg_Count = 3 then 864 Process_Dot_Replacement (Arg3); 865 end if; 866 867 else 868 Process_Dot_Replacement (Arg2); 869 870 if Arg_Count = 3 then 871 Process_Casing (Arg3); 872 end if; 873 end if; 874 end if; 875 876 Set_File_Name_Pattern (Pat, Typ, Dot, Cas); 877 end if; 878 end Source_File_Name; 879 880 ----------------------------- 881 -- Source_Reference (GNAT) -- 882 ----------------------------- 883 884 -- pragma Source_Reference 885 -- (INTEGER_LITERAL [, STRING_LITERAL] ); 886 887 -- Processing for this pragma must be done at parse time, since error 888 -- messages needing the proper line numbers can be generated in parse 889 -- only mode with semantic checking turned off, and indeed we usually 890 -- turn off semantic checking anyway if any parse errors are found. 891 892 when Pragma_Source_Reference => Source_Reference : declare 893 Fname : File_Name_Type; 894 895 begin 896 if Arg_Count /= 1 then 897 Check_Arg_Count (2); 898 Check_No_Identifier (Arg2); 899 end if; 900 901 -- Check that this is first line of file. We skip this test if 902 -- we are in syntax check only mode, since we may be dealing with 903 -- multiple compilation units. 904 905 if Get_Physical_Line_Number (Pragma_Sloc) /= 1 906 and then Num_SRef_Pragmas (Current_Source_File) = 0 907 and then Operating_Mode /= Check_Syntax 908 then 909 Error_Msg_N -- CODEFIX 910 ("first % pragma must be first line of file", Pragma_Node); 911 raise Error_Resync; 912 end if; 913 914 Check_No_Identifier (Arg1); 915 916 if Arg_Count = 1 then 917 if Num_SRef_Pragmas (Current_Source_File) = 0 then 918 Error_Msg_N 919 ("file name required for first % pragma in file", 920 Pragma_Node); 921 raise Error_Resync; 922 else 923 Fname := No_File; 924 end if; 925 926 -- File name present 927 928 else 929 Check_Arg_Is_String_Literal (Arg2); 930 String_To_Name_Buffer (Strval (Expression (Arg2))); 931 Fname := Name_Find; 932 933 if Num_SRef_Pragmas (Current_Source_File) > 0 then 934 if Fname /= Full_Ref_Name (Current_Source_File) then 935 Error_Msg_N 936 ("file name must be same in all % pragmas", Pragma_Node); 937 raise Error_Resync; 938 end if; 939 end if; 940 end if; 941 942 if Nkind (Expression (Arg1)) /= N_Integer_Literal then 943 Error_Msg_N 944 ("argument for pragma% must be integer literal", 945 Expression (Arg1)); 946 raise Error_Resync; 947 948 -- OK, this source reference pragma is effective, however, we 949 -- ignore it if it is not in the first unit in the multiple unit 950 -- case. This is because the only purpose in this case is to 951 -- provide source pragmas for subsequent use by gnatchop. 952 953 else 954 if Num_Library_Units = 1 then 955 Register_Source_Ref_Pragma 956 (Fname, 957 Strip_Directory (Fname), 958 UI_To_Int (Intval (Expression (Arg1))), 959 Get_Physical_Line_Number (Pragma_Sloc) + 1); 960 end if; 961 end if; 962 end Source_Reference; 963 964 ------------------------- 965 -- Style_Checks (GNAT) -- 966 ------------------------- 967 968 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 969 970 -- This is processed by the parser since some of the style 971 -- checks take place during source scanning and parsing. 972 973 when Pragma_Style_Checks => Style_Checks : declare 974 A : Node_Id; 975 S : String_Id; 976 C : Char_Code; 977 OK : Boolean := True; 978 979 begin 980 -- Two argument case is only for semantics 981 982 if Arg_Count = 2 then 983 null; 984 985 else 986 Check_Arg_Count (1); 987 Check_No_Identifier (Arg1); 988 A := Expression (Arg1); 989 990 if Nkind (A) = N_String_Literal then 991 S := Strval (A); 992 993 declare 994 Slen : constant Natural := Natural (String_Length (S)); 995 Options : String (1 .. Slen); 996 J : Positive; 997 Ptr : Positive; 998 999 begin 1000 J := 1; 1001 loop 1002 C := Get_String_Char (S, Pos (J)); 1003 1004 if not In_Character_Range (C) then 1005 OK := False; 1006 Ptr := J; 1007 exit; 1008 1009 else 1010 Options (J) := Get_Character (C); 1011 end if; 1012 1013 if J = Slen then 1014 if not Ignore_Style_Checks_Pragmas then 1015 Set_Style_Check_Options (Options, OK, Ptr); 1016 end if; 1017 1018 exit; 1019 1020 else 1021 J := J + 1; 1022 end if; 1023 end loop; 1024 1025 if not OK then 1026 Error_Msg 1027 (Style_Msg_Buf (1 .. Style_Msg_Len), 1028 Sloc (Expression (Arg1)) + Source_Ptr (Ptr)); 1029 raise Error_Resync; 1030 end if; 1031 end; 1032 1033 elsif Nkind (A) /= N_Identifier then 1034 OK := False; 1035 1036 elsif Chars (A) = Name_All_Checks then 1037 if not Ignore_Style_Checks_Pragmas then 1038 if GNAT_Mode then 1039 Stylesw.Set_GNAT_Style_Check_Options; 1040 else 1041 Stylesw.Set_Default_Style_Check_Options; 1042 end if; 1043 end if; 1044 1045 elsif Chars (A) = Name_On then 1046 if not Ignore_Style_Checks_Pragmas then 1047 Style_Check := True; 1048 end if; 1049 1050 elsif Chars (A) = Name_Off then 1051 if not Ignore_Style_Checks_Pragmas then 1052 Style_Check := False; 1053 end if; 1054 1055 else 1056 OK := False; 1057 end if; 1058 1059 if not OK then 1060 Error_Msg_N ("incorrect argument for pragma%", A); 1061 raise Error_Resync; 1062 end if; 1063 end if; 1064 end Style_Checks; 1065 1066 ------------------------- 1067 -- Suppress_All (GNAT) -- 1068 ------------------------- 1069 1070 -- pragma Suppress_All 1071 1072 -- This is a rather odd pragma, because other compilers allow it in 1073 -- strange places. DEC allows it at the end of units, and Rational 1074 -- allows it as a program unit pragma, when it would be more natural 1075 -- if it were a configuration pragma. 1076 1077 -- Since the reason we provide this pragma is for compatibility with 1078 -- these other compilers, we want to accommodate these strange placement 1079 -- rules, and the easiest thing is simply to allow it anywhere in a 1080 -- unit. If this pragma appears anywhere within a unit, then the effect 1081 -- is as though a pragma Suppress (All_Checks) had appeared as the first 1082 -- line of the current file, i.e. as the first configuration pragma in 1083 -- the current unit. 1084 1085 -- To get this effect, we set the flag Has_Pragma_Suppress_All in the 1086 -- compilation unit node for the current source file then in the last 1087 -- stage of parsing a file, if this flag is set, we materialize the 1088 -- Suppress (All_Checks) pragma, marked as not coming from Source. 1089 1090 when Pragma_Suppress_All => 1091 Set_Has_Pragma_Suppress_All (Cunit (Current_Source_Unit)); 1092 1093 ---------------------- 1094 -- Warning_As_Error -- 1095 ---------------------- 1096 1097 -- pragma Warning_As_Error (static_string_EXPRESSION); 1098 1099 -- Further processing is done in Sem_Prag 1100 1101 when Pragma_Warning_As_Error => 1102 Check_Arg_Count (1); 1103 Check_Arg_Is_String_Literal (Arg1); 1104 Warnings_As_Errors_Count := Warnings_As_Errors_Count + 1; 1105 Warnings_As_Errors (Warnings_As_Errors_Count) := 1106 new String'(Acquire_Warning_Match_String (Get_Pragma_Arg (Arg1))); 1107 1108 --------------------- 1109 -- Warnings (GNAT) -- 1110 --------------------- 1111 1112 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); 1113 1114 -- DETAILS ::= On | Off 1115 -- DETAILS ::= On | Off, local_NAME 1116 -- DETAILS ::= static_string_EXPRESSION 1117 -- DETAILS ::= On | Off, static_string_EXPRESSION 1118 1119 -- TOOL_NAME ::= GNAT | GNATprove 1120 1121 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} 1122 1123 -- Note: If the first argument matches an allowed tool name, it is 1124 -- always considered to be a tool name, even if there is a string 1125 -- variable of that name. 1126 1127 -- The one argument ON/OFF case is processed by the parser, since it may 1128 -- control parser warnings as well as semantic warnings, and in any case 1129 -- we want to be absolutely sure that the range in the warnings table is 1130 -- set well before any semantic analysis is performed. Note that we 1131 -- ignore this pragma if debug flag -gnatd.i is set. 1132 1133 -- Also note that the "one argument" case may have two or three 1134 -- arguments if the first one is a tool name, and/or the last one is a 1135 -- reason argument. 1136 1137 when Pragma_Warnings => Warnings : declare 1138 function First_Arg_Is_Matching_Tool_Name return Boolean; 1139 -- Returns True if the first argument is a tool name matching the 1140 -- current tool being run. 1141 1142 function Last_Arg return Node_Id; 1143 -- Returns the last argument 1144 1145 function Last_Arg_Is_Reason return Boolean; 1146 -- Returns True if the last argument is a reason argument 1147 1148 function Get_Reason return String_Id; 1149 -- Analyzes Reason argument and returns corresponding String_Id 1150 -- value, or null if there is no Reason argument, or if the 1151 -- argument is not of the required form. 1152 1153 ------------------------------------- 1154 -- First_Arg_Is_Matching_Tool_Name -- 1155 ------------------------------------- 1156 1157 function First_Arg_Is_Matching_Tool_Name return Boolean is 1158 begin 1159 return Nkind (Arg1) = N_Identifier 1160 1161 -- Return True if the tool name is GNAT, and we're not in 1162 -- GNATprove or CodePeer mode... 1163 1164 and then ((Chars (Arg1) = Name_Gnat 1165 and then not 1166 (CodePeer_Mode or GNATprove_Mode)) 1167 1168 -- or if the tool name is GNATprove, and we're in GNATprove 1169 -- mode. 1170 1171 or else 1172 (Chars (Arg1) = Name_Gnatprove 1173 and then GNATprove_Mode)); 1174 end First_Arg_Is_Matching_Tool_Name; 1175 1176 ---------------- 1177 -- Get_Reason -- 1178 ---------------- 1179 1180 function Get_Reason return String_Id is 1181 Arg : constant Node_Id := Last_Arg; 1182 begin 1183 if Last_Arg_Is_Reason then 1184 Start_String; 1185 Get_Reason_String (Expression (Arg)); 1186 return End_String; 1187 else 1188 return Null_String_Id; 1189 end if; 1190 end Get_Reason; 1191 1192 -------------- 1193 -- Last_Arg -- 1194 -------------- 1195 1196 function Last_Arg return Node_Id is 1197 Last_Arg : Node_Id; 1198 1199 begin 1200 if Arg_Count = 1 then 1201 Last_Arg := Arg1; 1202 elsif Arg_Count = 2 then 1203 Last_Arg := Arg2; 1204 elsif Arg_Count = 3 then 1205 Last_Arg := Arg3; 1206 elsif Arg_Count = 4 then 1207 Last_Arg := Next (Arg3); 1208 1209 -- Illegal case, error issued in semantic analysis 1210 1211 else 1212 Last_Arg := Empty; 1213 end if; 1214 1215 return Last_Arg; 1216 end Last_Arg; 1217 1218 ------------------------ 1219 -- Last_Arg_Is_Reason -- 1220 ------------------------ 1221 1222 function Last_Arg_Is_Reason return Boolean is 1223 Arg : constant Node_Id := Last_Arg; 1224 begin 1225 return Nkind (Arg) in N_Has_Chars 1226 and then Chars (Arg) = Name_Reason; 1227 end Last_Arg_Is_Reason; 1228 1229 The_Arg : Node_Id; -- On/Off argument 1230 Argx : Node_Id; 1231 1232 -- Start of processing for Warnings 1233 1234 begin 1235 if not Debug_Flag_Dot_I 1236 and then (Arg_Count = 1 1237 or else (Arg_Count = 2 1238 and then (First_Arg_Is_Matching_Tool_Name 1239 or else 1240 Last_Arg_Is_Reason)) 1241 or else (Arg_Count = 3 1242 and then First_Arg_Is_Matching_Tool_Name 1243 and then Last_Arg_Is_Reason)) 1244 then 1245 if First_Arg_Is_Matching_Tool_Name then 1246 The_Arg := Arg2; 1247 else 1248 The_Arg := Arg1; 1249 end if; 1250 1251 Check_No_Identifier (The_Arg); 1252 Argx := Expression (The_Arg); 1253 1254 if Nkind (Argx) = N_Identifier then 1255 if Chars (Argx) = Name_On then 1256 Set_Warnings_Mode_On (Pragma_Sloc); 1257 elsif Chars (Argx) = Name_Off then 1258 Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason); 1259 end if; 1260 end if; 1261 end if; 1262 end Warnings; 1263 1264 ----------------------------- 1265 -- Wide_Character_Encoding -- 1266 ----------------------------- 1267 1268 -- pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); 1269 1270 -- This is processed by the parser, since the scanner is affected 1271 1272 when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare 1273 A : Node_Id; 1274 1275 begin 1276 Check_Arg_Count (1); 1277 Check_No_Identifier (Arg1); 1278 A := Expression (Arg1); 1279 1280 if Nkind (A) = N_Identifier then 1281 Get_Name_String (Chars (A)); 1282 Wide_Character_Encoding_Method := 1283 Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len)); 1284 1285 elsif Nkind (A) = N_Character_Literal then 1286 declare 1287 R : constant Char_Code := 1288 Char_Code (UI_To_Int (Char_Literal_Value (A))); 1289 begin 1290 if In_Character_Range (R) then 1291 Wide_Character_Encoding_Method := 1292 Get_WC_Encoding_Method (Get_Character (R)); 1293 else 1294 raise Constraint_Error; 1295 end if; 1296 end; 1297 1298 else 1299 raise Constraint_Error; 1300 end if; 1301 1302 Upper_Half_Encoding := 1303 Wide_Character_Encoding_Method in 1304 WC_Upper_Half_Encoding_Method; 1305 1306 exception 1307 when Constraint_Error => 1308 Error_Msg_N ("invalid argument for pragma%", Arg1); 1309 end Wide_Character_Encoding; 1310 1311 ----------------------- 1312 -- All Other Pragmas -- 1313 ----------------------- 1314 1315 -- For all other pragmas, checking and processing is handled entirely in 1316 -- Sem_Prag, and no further checking is done by Par. 1317 1318 when Pragma_Abort_Defer 1319 | Pragma_Abstract_State 1320 | Pragma_Aggregate_Individually_Assign 1321 | Pragma_All_Calls_Remote 1322 | Pragma_Allow_Integer_Address 1323 | Pragma_Annotate 1324 | Pragma_Assert 1325 | Pragma_Assert_And_Cut 1326 | Pragma_Assertion_Policy 1327 | Pragma_Assume 1328 | Pragma_Assume_No_Invalid_Values 1329 | Pragma_Async_Readers 1330 | Pragma_Async_Writers 1331 | Pragma_Asynchronous 1332 | Pragma_Atomic 1333 | Pragma_Atomic_Components 1334 | Pragma_Attach_Handler 1335 | Pragma_Attribute_Definition 1336 | Pragma_CPP_Class 1337 | Pragma_CPP_Constructor 1338 | Pragma_CPP_Virtual 1339 | Pragma_CPP_Vtable 1340 | Pragma_CPU 1341 | Pragma_CUDA_Device 1342 | Pragma_CUDA_Execute 1343 | Pragma_CUDA_Global 1344 | Pragma_C_Pass_By_Copy 1345 | Pragma_Check 1346 | Pragma_Check_Float_Overflow 1347 | Pragma_Check_Name 1348 | Pragma_Check_Policy 1349 | Pragma_Comment 1350 | Pragma_Common_Object 1351 | Pragma_Compile_Time_Error 1352 | Pragma_Compile_Time_Warning 1353 | Pragma_Complete_Representation 1354 | Pragma_Complex_Representation 1355 | Pragma_Component_Alignment 1356 | Pragma_Constant_After_Elaboration 1357 | Pragma_Contract_Cases 1358 | Pragma_Controlled 1359 | Pragma_Convention 1360 | Pragma_Convention_Identifier 1361 | Pragma_Deadline_Floor 1362 | Pragma_Debug_Policy 1363 | Pragma_Default_Initial_Condition 1364 | Pragma_Default_Scalar_Storage_Order 1365 | Pragma_Default_Storage_Pool 1366 | Pragma_Depends 1367 | Pragma_Detect_Blocking 1368 | Pragma_Disable_Atomic_Synchronization 1369 | Pragma_Discard_Names 1370 | Pragma_Dispatching_Domain 1371 | Pragma_Effective_Reads 1372 | Pragma_Effective_Writes 1373 | Pragma_Elaborate 1374 | Pragma_Elaborate_All 1375 | Pragma_Elaborate_Body 1376 | Pragma_Elaboration_Checks 1377 | Pragma_Eliminate 1378 | Pragma_Enable_Atomic_Synchronization 1379 | Pragma_Export 1380 | Pragma_Export_Function 1381 | Pragma_Export_Object 1382 | Pragma_Export_Procedure 1383 | Pragma_Export_Valued_Procedure 1384 | Pragma_Extend_System 1385 | Pragma_Extensions_Visible 1386 | Pragma_External 1387 | Pragma_External_Name_Casing 1388 | Pragma_Fast_Math 1389 | Pragma_Favor_Top_Level 1390 | Pragma_Finalize_Storage_Only 1391 | Pragma_Ghost 1392 | Pragma_Global 1393 | Pragma_GNAT_Annotate 1394 | Pragma_Ident 1395 | Pragma_Implementation_Defined 1396 | Pragma_Implemented 1397 | Pragma_Implicit_Packing 1398 | Pragma_Import 1399 | Pragma_Import_Function 1400 | Pragma_Import_Object 1401 | Pragma_Import_Procedure 1402 | Pragma_Import_Valued_Procedure 1403 | Pragma_Independent 1404 | Pragma_Independent_Components 1405 | Pragma_Initial_Condition 1406 | Pragma_Initialize_Scalars 1407 | Pragma_Initializes 1408 | Pragma_Inline 1409 | Pragma_Inline_Always 1410 | Pragma_Inline_Generic 1411 | Pragma_Inspection_Point 1412 | Pragma_Interface 1413 | Pragma_Interface_Name 1414 | Pragma_Interrupt_Handler 1415 | Pragma_Interrupt_Priority 1416 | Pragma_Interrupt_State 1417 | Pragma_Invariant 1418 | Pragma_Keep_Names 1419 | Pragma_License 1420 | Pragma_Link_With 1421 | Pragma_Linker_Alias 1422 | Pragma_Linker_Constructor 1423 | Pragma_Linker_Destructor 1424 | Pragma_Linker_Options 1425 | Pragma_Linker_Section 1426 | Pragma_Lock_Free 1427 | Pragma_Locking_Policy 1428 | Pragma_Loop_Invariant 1429 | Pragma_Loop_Optimize 1430 | Pragma_Loop_Variant 1431 | Pragma_Machine_Attribute 1432 | Pragma_Main 1433 | Pragma_Main_Storage 1434 | Pragma_Max_Entry_Queue_Depth 1435 | Pragma_Max_Entry_Queue_Length 1436 | Pragma_Max_Queue_Length 1437 | Pragma_Memory_Size 1438 | Pragma_No_Body 1439 | Pragma_No_Caching 1440 | Pragma_No_Component_Reordering 1441 | Pragma_No_Elaboration_Code_All 1442 | Pragma_No_Heap_Finalization 1443 | Pragma_No_Inline 1444 | Pragma_No_Return 1445 | Pragma_No_Run_Time 1446 | Pragma_No_Strict_Aliasing 1447 | Pragma_No_Tagged_Streams 1448 | Pragma_Normalize_Scalars 1449 | Pragma_Obsolescent 1450 | Pragma_Optimize 1451 | Pragma_Optimize_Alignment 1452 | Pragma_Ordered 1453 | Pragma_Overflow_Mode 1454 | Pragma_Overriding_Renamings 1455 | Pragma_Pack 1456 | Pragma_Part_Of 1457 | Pragma_Partition_Elaboration_Policy 1458 | Pragma_Passive 1459 | Pragma_Persistent_BSS 1460 | Pragma_Post 1461 | Pragma_Post_Class 1462 | Pragma_Postcondition 1463 | Pragma_Pre 1464 | Pragma_Pre_Class 1465 | Pragma_Precondition 1466 | Pragma_Predicate 1467 | Pragma_Predicate_Failure 1468 | Pragma_Preelaborable_Initialization 1469 | Pragma_Preelaborate 1470 | Pragma_Prefix_Exception_Messages 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_Rational 1482 | Pragma_Ravenscar 1483 | Pragma_Refined_Depends 1484 | Pragma_Refined_Global 1485 | Pragma_Refined_Post 1486 | Pragma_Refined_State 1487 | Pragma_Relative_Deadline 1488 | Pragma_Remote_Access_Type 1489 | Pragma_Remote_Call_Interface 1490 | Pragma_Remote_Types 1491 | Pragma_Rename_Pragma 1492 | Pragma_Restricted_Run_Time 1493 | Pragma_Reviewable 1494 | Pragma_SPARK_Mode 1495 | Pragma_Secondary_Stack_Size 1496 | Pragma_Share_Generic 1497 | Pragma_Shared 1498 | Pragma_Shared_Passive 1499 | Pragma_Short_Circuit_And_Or 1500 | Pragma_Short_Descriptors 1501 | Pragma_Simple_Storage_Pool_Type 1502 | Pragma_Static_Elaboration_Desired 1503 | Pragma_Storage_Size 1504 | Pragma_Storage_Unit 1505 | Pragma_Stream_Convert 1506 | Pragma_Subtitle 1507 | Pragma_Subprogram_Variant 1508 | Pragma_Suppress 1509 | Pragma_Suppress_Debug_Info 1510 | Pragma_Suppress_Exception_Locations 1511 | Pragma_Suppress_Initialization 1512 | Pragma_System_Name 1513 | Pragma_Task_Dispatching_Policy 1514 | Pragma_Task_Info 1515 | Pragma_Task_Name 1516 | Pragma_Task_Storage 1517 | Pragma_Test_Case 1518 | Pragma_Thread_Local_Storage 1519 | Pragma_Time_Slice 1520 | Pragma_Title 1521 | Pragma_Type_Invariant 1522 | Pragma_Type_Invariant_Class 1523 | Pragma_Unchecked_Union 1524 | Pragma_Unevaluated_Use_Of_Old 1525 | Pragma_Unimplemented_Unit 1526 | Pragma_Universal_Aliasing 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_Validity_Checks 1535 | Pragma_Volatile 1536 | Pragma_Volatile_Components 1537 | Pragma_Volatile_Full_Access 1538 | Pragma_Volatile_Function 1539 | Pragma_Weak_External 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