19313Ssos------------------------------------------------------------------------------ 29313Ssos-- -- 39313Ssos-- GNAT COMPILER COMPONENTS -- 49313Ssos-- -- 59313Ssos-- P A R . P R A G -- 69313Ssos-- -- 79313Ssos-- B o d y -- 89313Ssos-- -- 99313Ssos-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 109313Ssos-- -- 119313Ssos-- GNAT is free software; you can redistribute it and/or modify it under -- 129313Ssos-- terms of the GNU General Public License as published by the Free Soft- -- 139313Ssos-- ware Foundation; either version 3, or (at your option) any later ver- -- 149313Ssos-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 159313Ssos-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 169313Ssos-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 179313Ssos-- for more details. You should have received a copy of the GNU General -- 189313Ssos-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 199313Ssos-- http://www.gnu.org/licenses for a complete copy of the license. -- 209313Ssos-- -- 219313Ssos-- GNAT was originally developed by the GNAT team at New York University. -- 229313Ssos-- Extensive contributions were provided by Ada Core Technologies Inc. -- 239313Ssos-- -- 249313Ssos------------------------------------------------------------------------------ 259313Ssos 269313Ssos-- Generally the parser checks the basic syntax of pragmas, but does not 279313Ssos-- do specialized syntax checks for individual pragmas, these are deferred 2814331Speter-- to semantic analysis time (see unit Sem_Prag). There are some pragmas 299313Ssos-- which require recognition and either partial or complete processing 309313Ssos-- during parsing, and this unit performs this required processing. 319313Ssos 3212458Sbdewith Fname.UF; use Fname.UF; 339313Ssoswith Osint; use Osint; 349313Ssoswith Rident; use Rident; 359313Ssoswith Restrict; use Restrict; 369313Ssoswith Stringt; use Stringt; 3714331Speterwith Stylesw; use Stylesw; 3814331Speterwith Uintp; use Uintp; 3912458Sbdewith Uname; use Uname; 409313Ssos 4114331Speterwith System.WCh_Con; use System.WCh_Con; 429313Ssos 439313Ssosseparate (Par) 449313Ssos 459313Ssosfunction Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is 469313Ssos Prag_Name : constant Name_Id := Pragma_Name (Pragma_Node); 479313Ssos Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag_Name); 4814331Speter Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); 499313Ssos Arg_Count : Nat; 509313Ssos Arg_Node : Node_Id; 519313Ssos 529313Ssos ----------------------- 539313Ssos -- Local Subprograms -- 549313Ssos ----------------------- 5514331Speter 569313Ssos procedure Add_List_Pragma_Entry (PT : List_Pragma_Type; Loc : Source_Ptr); 579313Ssos -- Make a new entry in the List_Pragmas table if this entry is not already 589313Ssos -- in the table (it will always be the last one if there is a duplication 599313Ssos -- resulting from the use of Save/Restore_Scan_State). 609313Ssos 619313Ssos function Arg1 return Node_Id; 6214331Speter function Arg2 return Node_Id; 639313Ssos function Arg3 return Node_Id; 649313Ssos -- Obtain specified Pragma_Argument_Association. It is allowable to call 659313Ssos -- the routine for the argument one past the last present argument, but 669313Ssos -- that is the only case in which a non-present argument can be referenced. 679313Ssos 689313Ssos procedure Check_Arg_Count (Required : Int); 6914331Speter -- Check argument count for pragma = Required. If not give error and raise 709313Ssos -- Error_Resync. 719313Ssos 729313Ssos procedure Check_Arg_Is_String_Literal (Arg : Node_Id); 739313Ssos -- Check the expression of the specified argument to make sure that it 749313Ssos -- is a string literal. If not give error and raise Error_Resync. 759313Ssos 7614331Speter procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id); 779313Ssos -- Check the expression of the specified argument to make sure that it 789313Ssos -- is an identifier which is either ON or OFF, and if not, then issue 799313Ssos -- an error message and raise Error_Resync. 809313Ssos 819313Ssos procedure Check_No_Identifier (Arg : Node_Id); 829313Ssos -- Checks that the given argument does not have an identifier. If 8314331Speter -- an identifier is present, then an error message is issued, and 849313Ssos -- Error_Resync is raised. 859313Ssos 869313Ssos procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 879313Ssos -- Checks if the given argument has an identifier, and if so, requires 889313Ssos -- it to match the given identifier name. If there is a non-matching 899313Ssos -- identifier, then an error message is given and Error_Resync raised. 9014331Speter 919313Ssos procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id); 929313Ssos -- Same as Check_Optional_Identifier, except that the name is required 939313Ssos -- to be present and to match the given Id value. 949313Ssos 959313Ssos procedure Process_Restrictions_Or_Restriction_Warnings; 969313Ssos -- Common processing for Restrictions and Restriction_Warnings pragmas. 9714331Speter -- For the most part, restrictions need not be processed at parse time, 989313Ssos -- since they only affect semantic processing. This routine handles the 999313Ssos -- exceptions as follows 1009313Ssos -- 1019313Ssos -- No_Obsolescent_Features must be processed at parse time, since there 1029313Ssos -- are some obsolescent features (e.g. character replacements) which are 1039313Ssos -- handled at parse time. 10414331Speter -- 1059313Ssos -- SPARK must be processed at parse time, since this restriction controls 1069313Ssos -- whether the scanner recognizes a spark HIDE directive formatted as an 1079313Ssos -- Ada comment (and generates a Tok_SPARK_Hide token for the directive). 1089313Ssos -- 1099313Ssos -- No_Dependence must be processed at parse time, since otherwise it gets 1109313Ssos -- handled too late. 11114331Speter -- 1129313Ssos -- Note that we don't need to do full error checking for badly formed cases 1139313Ssos -- of restrictions, since these will be caught during semantic analysis. 1149313Ssos 1159313Ssos --------------------------- 1169313Ssos -- Add_List_Pragma_Entry -- 1179313Ssos --------------------------- 11814331Speter 1199313Ssos procedure Add_List_Pragma_Entry (PT : List_Pragma_Type; Loc : Source_Ptr) is 1209313Ssos begin 1219313Ssos if List_Pragmas.Last < List_Pragmas.First 1229313Ssos or else (List_Pragmas.Table (List_Pragmas.Last)) /= ((PT, Loc)) 1239313Ssos then 1249313Ssos List_Pragmas.Append ((PT, Loc)); 12514331Speter end if; 1269313Ssos end Add_List_Pragma_Entry; 1279313Ssos 1289313Ssos ---------- 1299313Ssos -- Arg1 -- 1309313Ssos ---------- 1319313Ssos 13214331Speter function Arg1 return Node_Id is 1339313Ssos begin 1349313Ssos return First (Pragma_Argument_Associations (Pragma_Node)); 1359313Ssos end Arg1; 1369313Ssos 1379313Ssos ---------- 1389313Ssos -- Arg2 -- 13914331Speter ---------- 1409313Ssos 1419313Ssos function Arg2 return Node_Id is 1429313Ssos begin 1439313Ssos return Next (Arg1); 1449313Ssos end Arg2; 1459313Ssos 14614331Speter ---------- 1479313Ssos -- Arg3 -- 1489313Ssos ---------- 1499313Ssos 1509313Ssos function Arg3 return Node_Id is 1519313Ssos begin 1529313Ssos return Next (Arg2); 15314331Speter end Arg3; 1549313Ssos 1559313Ssos --------------------- 1569313Ssos -- Check_Arg_Count -- 1579313Ssos --------------------- 1589313Ssos 1599313Ssos procedure Check_Arg_Count (Required : Int) is 16014331Speter begin 1619313Ssos if Arg_Count /= Required then 1629313Ssos Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); 1639313Ssos raise Error_Resync; 1649313Ssos end if; 1659313Ssos end Check_Arg_Count; 1669313Ssos 16714331Speter ---------------------------- 1689313Ssos -- Check_Arg_Is_On_Or_Off -- 1699313Ssos ---------------------------- 1709313Ssos 1719313Ssos procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is 1729313Ssos Argx : constant Node_Id := Expression (Arg); 1739313Ssos 17414331Speter begin 1759313Ssos if Nkind (Expression (Arg)) /= N_Identifier 1769313Ssos or else not Nam_In (Chars (Argx), Name_On, Name_Off) 1779313Ssos then 1789313Ssos Error_Msg_Name_2 := Name_On; 1799313Ssos Error_Msg_Name_3 := Name_Off; 1809313Ssos 18114331Speter Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); 1829313Ssos raise Error_Resync; 18314331Speter end if; 18414331Speter end Check_Arg_Is_On_Or_Off; 18514331Speter 1869313Ssos --------------------------------- 1879313Ssos -- Check_Arg_Is_String_Literal -- 1889313Ssos --------------------------------- 18914331Speter 1909313Ssos procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is 1919313Ssos begin 1929313Ssos if Nkind (Expression (Arg)) /= N_String_Literal then 1939313Ssos Error_Msg 1949313Ssos ("argument for pragma% must be string literal", 1959313Ssos Sloc (Expression (Arg))); 19614331Speter raise Error_Resync; 1979313Ssos end if; 1989313Ssos end Check_Arg_Is_String_Literal; 1999313Ssos 2009313Ssos ------------------------- 2019313Ssos -- Check_No_Identifier -- 2029313Ssos ------------------------- 20314331Speter 2049313Ssos procedure Check_No_Identifier (Arg : Node_Id) is 2059313Ssos begin 2069313Ssos if Chars (Arg) /= No_Name then 2079313Ssos Error_Msg_N ("pragma% does not permit named arguments", Arg); 2089313Ssos raise Error_Resync; 2099313Ssos end if; 21014331Speter end Check_No_Identifier; 2119313Ssos 2129313Ssos ------------------------------- 2139313Ssos -- Check_Optional_Identifier -- 2149313Ssos ------------------------------- 2159313Ssos 2169313Ssos procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 21714331Speter begin 2189313Ssos if Present (Arg) and then Chars (Arg) /= No_Name then 2199313Ssos if Chars (Arg) /= Id then 2209313Ssos Error_Msg_Name_2 := Id; 2219313Ssos Error_Msg_N ("pragma% argument expects identifier%", Arg); 2229313Ssos end if; 2239313Ssos end if; 22414331Speter end Check_Optional_Identifier; 2259313Ssos 2269313Ssos ------------------------------- 2279313Ssos -- Check_Required_Identifier -- 2289313Ssos ------------------------------- 2299313Ssos 2309313Ssos procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is 23114331Speter begin 2329313Ssos if Chars (Arg) /= Id then 2339313Ssos Error_Msg_Name_2 := Id; 2349313Ssos Error_Msg_N ("pragma% argument must have identifier%", Arg); 2359313Ssos end if; 2369313Ssos end Check_Required_Identifier; 2379313Ssos 23814331Speter -------------------------------------------------- 2399313Ssos -- Process_Restrictions_Or_Restriction_Warnings -- 2409313Ssos -------------------------------------------------- 2419313Ssos 2429313Ssos procedure Process_Restrictions_Or_Restriction_Warnings is 2439313Ssos Arg : Node_Id; 2449313Ssos Id : Name_Id; 24514331Speter Expr : Node_Id; 2469313Ssos 2479313Ssos begin 2489313Ssos Arg := Arg1; 2499313Ssos while Present (Arg) loop 2509313Ssos Id := Chars (Arg); 2519313Ssos Expr := Expression (Arg); 25214331Speter 2539313Ssos if Id = No_Name and then Nkind (Expr) = N_Identifier then 2549313Ssos case Chars (Expr) is 2559313Ssos when Name_No_Obsolescent_Features => 2569313Ssos Set_Restriction (No_Obsolescent_Features, Pragma_Node); 2579313Ssos Restriction_Warnings (No_Obsolescent_Features) := 2589313Ssos Prag_Id = Pragma_Restriction_Warnings; 25914331Speter 2609313Ssos when Name_SPARK | Name_SPARK_05 => 2619313Ssos Set_Restriction (SPARK_05, Pragma_Node); 2629313Ssos Restriction_Warnings (SPARK_05) := 2639313Ssos Prag_Id = Pragma_Restriction_Warnings; 2649313Ssos 2659313Ssos when others => 26614331Speter null; 2679313Ssos end case; 2689313Ssos 2699313Ssos elsif Id = Name_No_Dependence then 2709313Ssos Set_Restriction_No_Dependence 2719313Ssos (Unit => Expr, 2729313Ssos Warn => Prag_Id = Pragma_Restriction_Warnings 27314331Speter or else Treat_Restrictions_As_Warnings); 2749313Ssos end if; 2759313Ssos 2769313Ssos Next (Arg); 2779313Ssos end loop; 2789313Ssos end Process_Restrictions_Or_Restriction_Warnings; 2799313Ssos 28014331Speter-- Start of processing for Prag 2819313Ssos 2829313Ssosbegin 2839313Ssos Error_Msg_Name_1 := Prag_Name; 2849313Ssos 2859313Ssos -- Ignore unrecognized pragma. We let Sem post the warning for this, since 2869313Ssos -- it is a semantic error, not a syntactic one (we have already checked 28714331Speter -- the syntax for the unrecognized pragma as required by (RM 2.8(11)). 2889313Ssos 2899313Ssos if Prag_Id = Unknown_Pragma then 2909313Ssos return Pragma_Node; 2919313Ssos end if; 2929313Ssos 2939313Ssos -- Count number of arguments. This loop also checks if any of the arguments 29414331Speter -- are Error, indicating a syntax error as they were parsed. If so, we 2959313Ssos -- simply return, because we get into trouble with cascaded errors if we 2969313Ssos -- try to perform our error checks on junk arguments. 2979313Ssos 2989313Ssos Arg_Count := 0; 299 300 if Present (Pragma_Argument_Associations (Pragma_Node)) then 301 Arg_Node := Arg1; 302 while Arg_Node /= Empty loop 303 Arg_Count := Arg_Count + 1; 304 305 if Expression (Arg_Node) = Error then 306 return Error; 307 end if; 308 309 Next (Arg_Node); 310 end loop; 311 end if; 312 313 -- Remaining processing is pragma dependent 314 315 case Prag_Id is 316 317 ------------ 318 -- Ada_83 -- 319 ------------ 320 321 -- This pragma must be processed at parse time, since we want to set 322 -- the Ada version properly at parse time to recognize the appropriate 323 -- Ada version syntax. 324 325 when Pragma_Ada_83 => 326 Ada_Version := Ada_83; 327 Ada_Version_Explicit := Ada_83; 328 Ada_Version_Pragma := Pragma_Node; 329 330 ------------ 331 -- Ada_95 -- 332 ------------ 333 334 -- This pragma must be processed at parse time, since we want to set 335 -- the Ada version properly at parse time to recognize the appropriate 336 -- Ada version syntax. 337 338 when Pragma_Ada_95 => 339 Ada_Version := Ada_95; 340 Ada_Version_Explicit := Ada_95; 341 Ada_Version_Pragma := Pragma_Node; 342 343 --------------------- 344 -- Ada_05/Ada_2005 -- 345 --------------------- 346 347 -- These pragmas must be processed at parse time, since we want to set 348 -- the Ada version properly at parse time to recognize the appropriate 349 -- Ada version syntax. However, it is only the zero argument form that 350 -- must be processed at parse time. 351 352 when Pragma_Ada_05 | Pragma_Ada_2005 => 353 if Arg_Count = 0 then 354 Ada_Version := Ada_2005; 355 Ada_Version_Explicit := Ada_2005; 356 Ada_Version_Pragma := Pragma_Node; 357 end if; 358 359 --------------------- 360 -- Ada_12/Ada_2012 -- 361 --------------------- 362 363 -- These pragmas must be processed at parse time, since we want to set 364 -- the Ada version properly at parse time to recognize the appropriate 365 -- Ada version syntax. However, it is only the zero argument form that 366 -- must be processed at parse time. 367 368 when Pragma_Ada_12 | Pragma_Ada_2012 => 369 if Arg_Count = 0 then 370 Ada_Version := Ada_2012; 371 Ada_Version_Explicit := Ada_2012; 372 Ada_Version_Pragma := Pragma_Node; 373 end if; 374 375 --------------------------- 376 -- Compiler_Unit_Warning -- 377 --------------------------- 378 379 -- This pragma must be processed at parse time, since the resulting 380 -- status may be tested during the parsing of the program. 381 382 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning => 383 Check_Arg_Count (0); 384 385 -- Only recognized in main unit 386 387 if Current_Source_Unit = Main_Unit then 388 Compiler_Unit := True; 389 end if; 390 391 ----------- 392 -- Debug -- 393 ----------- 394 395 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); 396 397 when Pragma_Debug => 398 Check_No_Identifier (Arg1); 399 400 if Arg_Count = 2 then 401 Check_No_Identifier (Arg2); 402 else 403 Check_Arg_Count (1); 404 end if; 405 406 ------------------------------- 407 -- Extensions_Allowed (GNAT) -- 408 ------------------------------- 409 410 -- pragma Extensions_Allowed (Off | On) 411 412 -- The processing for pragma Extensions_Allowed must be done at 413 -- parse time, since extensions mode may affect what is accepted. 414 415 when Pragma_Extensions_Allowed => 416 Check_Arg_Count (1); 417 Check_No_Identifier (Arg1); 418 Check_Arg_Is_On_Or_Off (Arg1); 419 420 if Chars (Expression (Arg1)) = Name_On then 421 Extensions_Allowed := True; 422 Ada_Version := Ada_2012; 423 else 424 Extensions_Allowed := False; 425 Ada_Version := Ada_Version_Explicit; 426 end if; 427 428 ---------------- 429 -- List (2.8) -- 430 ---------------- 431 432 -- pragma List (Off | On) 433 434 -- The processing for pragma List must be done at parse time, since a 435 -- listing can be generated in parse only mode. 436 437 when Pragma_List => 438 Check_Arg_Count (1); 439 Check_No_Identifier (Arg1); 440 Check_Arg_Is_On_Or_Off (Arg1); 441 442 -- We unconditionally make a List_On entry for the pragma, so that 443 -- in the List (Off) case, the pragma will print even in a region 444 -- of code with listing turned off (this is required). 445 446 Add_List_Pragma_Entry (List_On, Sloc (Pragma_Node)); 447 448 -- Now generate the list off entry for pragma List (Off) 449 450 if Chars (Expression (Arg1)) = Name_Off then 451 Add_List_Pragma_Entry (List_Off, Semi); 452 end if; 453 454 ---------------- 455 -- Page (2.8) -- 456 ---------------- 457 458 -- pragma Page; 459 460 -- Processing for this pragma must be done at parse time, since a 461 -- listing can be generated in parse only mode with semantics off. 462 463 when Pragma_Page => 464 Check_Arg_Count (0); 465 Add_List_Pragma_Entry (Page, Semi); 466 467 ------------------ 468 -- Restrictions -- 469 ------------------ 470 471 -- pragma Restrictions (RESTRICTION {, RESTRICTION}); 472 473 -- RESTRICTION ::= 474 -- restriction_IDENTIFIER 475 -- | restriction_parameter_IDENTIFIER => EXPRESSION 476 477 -- We process the case of No_Obsolescent_Features, since this has 478 -- a syntactic effect that we need to detect at parse time (the use 479 -- of replacement characters such as colon for pound sign). 480 481 when Pragma_Restrictions => 482 Process_Restrictions_Or_Restriction_Warnings; 483 484 -------------------------- 485 -- Restriction_Warnings -- 486 -------------------------- 487 488 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); 489 490 -- RESTRICTION ::= 491 -- restriction_IDENTIFIER 492 -- | restriction_parameter_IDENTIFIER => EXPRESSION 493 494 -- See above comment for pragma Restrictions 495 496 when Pragma_Restriction_Warnings => 497 Process_Restrictions_Or_Restriction_Warnings; 498 499 ---------------------------------------------------------- 500 -- Source_File_Name and Source_File_Name_Project (GNAT) -- 501 ---------------------------------------------------------- 502 503 -- These two pragmas have the same syntax and semantics. 504 -- There are five forms of these pragmas: 505 506 -- pragma Source_File_Name[_Project] ( 507 -- [UNIT_NAME =>] unit_NAME, 508 -- BODY_FILE_NAME => STRING_LITERAL 509 -- [, [INDEX =>] INTEGER_LITERAL]); 510 511 -- pragma Source_File_Name[_Project] ( 512 -- [UNIT_NAME =>] unit_NAME, 513 -- SPEC_FILE_NAME => STRING_LITERAL 514 -- [, [INDEX =>] INTEGER_LITERAL]); 515 516 -- pragma Source_File_Name[_Project] ( 517 -- BODY_FILE_NAME => STRING_LITERAL 518 -- [, DOT_REPLACEMENT => STRING_LITERAL] 519 -- [, CASING => CASING_SPEC]); 520 521 -- pragma Source_File_Name[_Project] ( 522 -- SPEC_FILE_NAME => STRING_LITERAL 523 -- [, DOT_REPLACEMENT => STRING_LITERAL] 524 -- [, CASING => CASING_SPEC]); 525 526 -- pragma Source_File_Name[_Project] ( 527 -- SUBUNIT_FILE_NAME => STRING_LITERAL 528 -- [, DOT_REPLACEMENT => STRING_LITERAL] 529 -- [, CASING => CASING_SPEC]); 530 531 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 532 533 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 534 -- Source_File_Name (SFN), however their usage is exclusive: 535 -- SFN can only be used when no project file is used, while 536 -- SFNP can only be used when a project file is used. 537 538 -- The Project Manager produces a configuration pragmas file that 539 -- is communicated to the compiler with -gnatec switch. This file 540 -- contains only SFNP pragmas (at least two for the default naming 541 -- scheme. As this configuration pragmas file is always the first 542 -- processed by the compiler, it prevents the use of pragmas SFN in 543 -- other config files when a project file is in use. 544 545 -- Note: we process this during parsing, since we need to have the 546 -- source file names set well before the semantic analysis starts, 547 -- since we load the spec and with'ed packages before analysis. 548 549 when Pragma_Source_File_Name | Pragma_Source_File_Name_Project => 550 Source_File_Name : declare 551 Unam : Unit_Name_Type; 552 Expr1 : Node_Id; 553 Pat : String_Ptr; 554 Typ : Character; 555 Dot : String_Ptr; 556 Cas : Casing_Type; 557 Nast : Nat; 558 Expr : Node_Id; 559 Index : Nat; 560 561 function Get_Fname (Arg : Node_Id) return File_Name_Type; 562 -- Process file name from unit name form of pragma 563 564 function Get_String_Argument (Arg : Node_Id) return String_Ptr; 565 -- Process string literal value from argument 566 567 procedure Process_Casing (Arg : Node_Id); 568 -- Process Casing argument of pattern form of pragma 569 570 procedure Process_Dot_Replacement (Arg : Node_Id); 571 -- Process Dot_Replacement argument of pattern form of pragma 572 573 --------------- 574 -- Get_Fname -- 575 --------------- 576 577 function Get_Fname (Arg : Node_Id) return File_Name_Type is 578 begin 579 String_To_Name_Buffer (Strval (Expression (Arg))); 580 581 for J in 1 .. Name_Len loop 582 if Is_Directory_Separator (Name_Buffer (J)) then 583 Error_Msg 584 ("directory separator character not allowed", 585 Sloc (Expression (Arg)) + Source_Ptr (J)); 586 end if; 587 end loop; 588 589 return Name_Find; 590 end Get_Fname; 591 592 ------------------------- 593 -- Get_String_Argument -- 594 ------------------------- 595 596 function Get_String_Argument (Arg : Node_Id) return String_Ptr is 597 Str : String_Id; 598 599 begin 600 if Nkind (Expression (Arg)) /= N_String_Literal 601 and then 602 Nkind (Expression (Arg)) /= N_Operator_Symbol 603 then 604 Error_Msg_N 605 ("argument for pragma% must be string literal", Arg); 606 raise Error_Resync; 607 end if; 608 609 Str := Strval (Expression (Arg)); 610 611 -- Check string has no wide chars 612 613 for J in 1 .. String_Length (Str) loop 614 if Get_String_Char (Str, J) > 255 then 615 Error_Msg 616 ("wide character not allowed in pattern for pragma%", 617 Sloc (Expression (Arg2)) + Text_Ptr (J) - 1); 618 end if; 619 end loop; 620 621 -- Acquire string 622 623 String_To_Name_Buffer (Str); 624 return new String'(Name_Buffer (1 .. Name_Len)); 625 end Get_String_Argument; 626 627 -------------------- 628 -- Process_Casing -- 629 -------------------- 630 631 procedure Process_Casing (Arg : Node_Id) is 632 Expr : constant Node_Id := Expression (Arg); 633 634 begin 635 Check_Required_Identifier (Arg, Name_Casing); 636 637 if Nkind (Expr) = N_Identifier then 638 if Chars (Expr) = Name_Lowercase then 639 Cas := All_Lower_Case; 640 return; 641 elsif Chars (Expr) = Name_Uppercase then 642 Cas := All_Upper_Case; 643 return; 644 elsif Chars (Expr) = Name_Mixedcase then 645 Cas := Mixed_Case; 646 return; 647 end if; 648 end if; 649 650 Error_Msg_N 651 ("Casing argument for pragma% must be " & 652 "one of Mixedcase, Lowercase, Uppercase", 653 Arg); 654 end Process_Casing; 655 656 ----------------------------- 657 -- Process_Dot_Replacement -- 658 ----------------------------- 659 660 procedure Process_Dot_Replacement (Arg : Node_Id) is 661 begin 662 Check_Required_Identifier (Arg, Name_Dot_Replacement); 663 Dot := Get_String_Argument (Arg); 664 end Process_Dot_Replacement; 665 666 -- Start of processing for Source_File_Name and 667 -- Source_File_Name_Project pragmas. 668 669 begin 670 if Prag_Id = Pragma_Source_File_Name then 671 if Project_File_In_Use = In_Use then 672 Error_Msg 673 ("pragma Source_File_Name cannot be used " & 674 "with a project file", Pragma_Sloc); 675 676 else 677 Project_File_In_Use := Not_In_Use; 678 end if; 679 680 else 681 if Project_File_In_Use = Not_In_Use then 682 Error_Msg 683 ("pragma Source_File_Name_Project should only be used " & 684 "with a project file", Pragma_Sloc); 685 else 686 Project_File_In_Use := In_Use; 687 end if; 688 end if; 689 690 -- We permit from 1 to 3 arguments 691 692 if Arg_Count not in 1 .. 3 then 693 Check_Arg_Count (1); 694 end if; 695 696 Expr1 := Expression (Arg1); 697 698 -- If first argument is identifier or selected component, then 699 -- we have the specific file case of the Source_File_Name pragma, 700 -- and the first argument is a unit name. 701 702 if Nkind (Expr1) = N_Identifier 703 or else 704 (Nkind (Expr1) = N_Selected_Component 705 and then 706 Nkind (Selector_Name (Expr1)) = N_Identifier) 707 then 708 if Nkind (Expr1) = N_Identifier 709 and then Chars (Expr1) = Name_System 710 then 711 Error_Msg_N 712 ("pragma Source_File_Name may not be used for System", 713 Arg1); 714 return Error; 715 end if; 716 717 -- Process index argument if present 718 719 if Arg_Count = 3 then 720 Expr := Expression (Arg3); 721 722 if Nkind (Expr) /= N_Integer_Literal 723 or else not UI_Is_In_Int_Range (Intval (Expr)) 724 or else Intval (Expr) > 999 725 or else Intval (Expr) <= 0 726 then 727 Error_Msg 728 ("pragma% index must be integer literal" & 729 " in range 1 .. 999", Sloc (Expr)); 730 raise Error_Resync; 731 else 732 Index := UI_To_Int (Intval (Expr)); 733 end if; 734 735 -- No index argument present 736 737 else 738 Check_Arg_Count (2); 739 Index := 0; 740 end if; 741 742 Check_Optional_Identifier (Arg1, Name_Unit_Name); 743 Unam := Get_Unit_Name (Expr1); 744 745 Check_Arg_Is_String_Literal (Arg2); 746 747 if Chars (Arg2) = Name_Spec_File_Name then 748 Set_File_Name 749 (Get_Spec_Name (Unam), Get_Fname (Arg2), Index); 750 751 elsif Chars (Arg2) = Name_Body_File_Name then 752 Set_File_Name 753 (Unam, Get_Fname (Arg2), Index); 754 755 else 756 Error_Msg_N 757 ("pragma% argument has incorrect identifier", Arg2); 758 return Pragma_Node; 759 end if; 760 761 -- If the first argument is not an identifier, then we must have 762 -- the pattern form of the pragma, and the first argument must be 763 -- the pattern string with an appropriate name. 764 765 else 766 if Chars (Arg1) = Name_Spec_File_Name then 767 Typ := 's'; 768 769 elsif Chars (Arg1) = Name_Body_File_Name then 770 Typ := 'b'; 771 772 elsif Chars (Arg1) = Name_Subunit_File_Name then 773 Typ := 'u'; 774 775 elsif Chars (Arg1) = Name_Unit_Name then 776 Error_Msg_N 777 ("Unit_Name parameter for pragma% must be an identifier", 778 Arg1); 779 raise Error_Resync; 780 781 else 782 Error_Msg_N 783 ("pragma% argument has incorrect identifier", Arg1); 784 raise Error_Resync; 785 end if; 786 787 Pat := Get_String_Argument (Arg1); 788 789 -- Check pattern has exactly one asterisk 790 791 Nast := 0; 792 for J in Pat'Range loop 793 if Pat (J) = '*' then 794 Nast := Nast + 1; 795 end if; 796 end loop; 797 798 if Nast /= 1 then 799 Error_Msg_N 800 ("file name pattern must have exactly one * character", 801 Arg1); 802 return Pragma_Node; 803 end if; 804 805 -- Set defaults for Casing and Dot_Separator parameters 806 807 Cas := All_Lower_Case; 808 Dot := new String'("."); 809 810 -- Process second and third arguments if present 811 812 if Arg_Count > 1 then 813 if Chars (Arg2) = Name_Casing then 814 Process_Casing (Arg2); 815 816 if Arg_Count = 3 then 817 Process_Dot_Replacement (Arg3); 818 end if; 819 820 else 821 Process_Dot_Replacement (Arg2); 822 823 if Arg_Count = 3 then 824 Process_Casing (Arg3); 825 end if; 826 end if; 827 end if; 828 829 Set_File_Name_Pattern (Pat, Typ, Dot, Cas); 830 end if; 831 end Source_File_Name; 832 833 ----------------------------- 834 -- Source_Reference (GNAT) -- 835 ----------------------------- 836 837 -- pragma Source_Reference 838 -- (INTEGER_LITERAL [, STRING_LITERAL] ); 839 840 -- Processing for this pragma must be done at parse time, since error 841 -- messages needing the proper line numbers can be generated in parse 842 -- only mode with semantic checking turned off, and indeed we usually 843 -- turn off semantic checking anyway if any parse errors are found. 844 845 when Pragma_Source_Reference => Source_Reference : declare 846 Fname : File_Name_Type; 847 848 begin 849 if Arg_Count /= 1 then 850 Check_Arg_Count (2); 851 Check_No_Identifier (Arg2); 852 end if; 853 854 -- Check that this is first line of file. We skip this test if 855 -- we are in syntax check only mode, since we may be dealing with 856 -- multiple compilation units. 857 858 if Get_Physical_Line_Number (Pragma_Sloc) /= 1 859 and then Num_SRef_Pragmas (Current_Source_File) = 0 860 and then Operating_Mode /= Check_Syntax 861 then 862 Error_Msg -- CODEFIX 863 ("first % pragma must be first line of file", Pragma_Sloc); 864 raise Error_Resync; 865 end if; 866 867 Check_No_Identifier (Arg1); 868 869 if Arg_Count = 1 then 870 if Num_SRef_Pragmas (Current_Source_File) = 0 then 871 Error_Msg 872 ("file name required for first % pragma in file", 873 Pragma_Sloc); 874 raise Error_Resync; 875 else 876 Fname := No_File; 877 end if; 878 879 -- File name present 880 881 else 882 Check_Arg_Is_String_Literal (Arg2); 883 String_To_Name_Buffer (Strval (Expression (Arg2))); 884 Fname := Name_Find; 885 886 if Num_SRef_Pragmas (Current_Source_File) > 0 then 887 if Fname /= Full_Ref_Name (Current_Source_File) then 888 Error_Msg 889 ("file name must be same in all % pragmas", Pragma_Sloc); 890 raise Error_Resync; 891 end if; 892 end if; 893 end if; 894 895 if Nkind (Expression (Arg1)) /= N_Integer_Literal then 896 Error_Msg 897 ("argument for pragma% must be integer literal", 898 Sloc (Expression (Arg1))); 899 raise Error_Resync; 900 901 -- OK, this source reference pragma is effective, however, we 902 -- ignore it if it is not in the first unit in the multiple unit 903 -- case. This is because the only purpose in this case is to 904 -- provide source pragmas for subsequent use by gnatchop. 905 906 else 907 if Num_Library_Units = 1 then 908 Register_Source_Ref_Pragma 909 (Fname, 910 Strip_Directory (Fname), 911 UI_To_Int (Intval (Expression (Arg1))), 912 Get_Physical_Line_Number (Pragma_Sloc) + 1); 913 end if; 914 end if; 915 end Source_Reference; 916 917 ------------------------- 918 -- Style_Checks (GNAT) -- 919 ------------------------- 920 921 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 922 923 -- This is processed by the parser since some of the style 924 -- checks take place during source scanning and parsing. 925 926 when Pragma_Style_Checks => Style_Checks : declare 927 A : Node_Id; 928 S : String_Id; 929 C : Char_Code; 930 OK : Boolean := True; 931 932 begin 933 -- Two argument case is only for semantics 934 935 if Arg_Count = 2 then 936 null; 937 938 else 939 Check_Arg_Count (1); 940 Check_No_Identifier (Arg1); 941 A := Expression (Arg1); 942 943 if Nkind (A) = N_String_Literal then 944 S := Strval (A); 945 946 declare 947 Slen : constant Natural := Natural (String_Length (S)); 948 Options : String (1 .. Slen); 949 J : Natural; 950 Ptr : Natural; 951 952 begin 953 J := 1; 954 loop 955 C := Get_String_Char (S, Int (J)); 956 957 if not In_Character_Range (C) then 958 OK := False; 959 Ptr := J; 960 exit; 961 962 else 963 Options (J) := Get_Character (C); 964 end if; 965 966 if J = Slen then 967 if not Ignore_Style_Checks_Pragmas then 968 Set_Style_Check_Options (Options, OK, Ptr); 969 end if; 970 971 exit; 972 973 else 974 J := J + 1; 975 end if; 976 end loop; 977 978 if not OK then 979 Error_Msg 980 (Style_Msg_Buf (1 .. Style_Msg_Len), 981 Sloc (Expression (Arg1)) + Source_Ptr (Ptr)); 982 raise Error_Resync; 983 end if; 984 end; 985 986 elsif Nkind (A) /= N_Identifier then 987 OK := False; 988 989 elsif Chars (A) = Name_All_Checks then 990 if not Ignore_Style_Checks_Pragmas then 991 if GNAT_Mode then 992 Stylesw.Set_GNAT_Style_Check_Options; 993 else 994 Stylesw.Set_Default_Style_Check_Options; 995 end if; 996 end if; 997 998 elsif Chars (A) = Name_On then 999 if not Ignore_Style_Checks_Pragmas then 1000 Style_Check := True; 1001 end if; 1002 1003 elsif Chars (A) = Name_Off then 1004 if not Ignore_Style_Checks_Pragmas then 1005 Style_Check := False; 1006 end if; 1007 1008 else 1009 OK := False; 1010 end if; 1011 1012 if not OK then 1013 Error_Msg ("incorrect argument for pragma%", Sloc (A)); 1014 raise Error_Resync; 1015 end if; 1016 end if; 1017 end Style_Checks; 1018 1019 ------------------------- 1020 -- Suppress_All (GNAT) -- 1021 ------------------------- 1022 1023 -- pragma Suppress_All 1024 1025 -- This is a rather odd pragma, because other compilers allow it in 1026 -- strange places. DEC allows it at the end of units, and Rational 1027 -- allows it as a program unit pragma, when it would be more natural 1028 -- if it were a configuration pragma. 1029 1030 -- Since the reason we provide this pragma is for compatibility with 1031 -- these other compilers, we want to accommodate these strange placement 1032 -- rules, and the easiest thing is simply to allow it anywhere in a 1033 -- unit. If this pragma appears anywhere within a unit, then the effect 1034 -- is as though a pragma Suppress (All_Checks) had appeared as the first 1035 -- line of the current file, i.e. as the first configuration pragma in 1036 -- the current unit. 1037 1038 -- To get this effect, we set the flag Has_Pragma_Suppress_All in the 1039 -- compilation unit node for the current source file then in the last 1040 -- stage of parsing a file, if this flag is set, we materialize the 1041 -- Suppress (All_Checks) pragma, marked as not coming from Source. 1042 1043 when Pragma_Suppress_All => 1044 Set_Has_Pragma_Suppress_All (Cunit (Current_Source_Unit)); 1045 1046 --------------------- 1047 -- Warnings (GNAT) -- 1048 --------------------- 1049 1050 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]); 1051 1052 -- DETAILS ::= On | Off 1053 -- DETAILS ::= On | Off, local_NAME 1054 -- DETAILS ::= static_string_EXPRESSION 1055 -- DETAILS ::= On | Off, static_string_EXPRESSION 1056 1057 -- TOOL_NAME ::= GNAT | GNATProve 1058 1059 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL} 1060 1061 -- Note: If the first argument matches an allowed tool name, it is 1062 -- always considered to be a tool name, even if there is a string 1063 -- variable of that name. 1064 1065 -- The one argument ON/OFF case is processed by the parser, since it may 1066 -- control parser warnings as well as semantic warnings, and in any case 1067 -- we want to be absolutely sure that the range in the warnings table is 1068 -- set well before any semantic analysis is performed. Note that we 1069 -- ignore this pragma if debug flag -gnatd.i is set. 1070 1071 -- Also note that the "one argument" case may have two or three 1072 -- arguments if the first one is a tool name, and/or the last one is a 1073 -- reason argument. 1074 1075 when Pragma_Warnings => Warnings : declare 1076 function First_Arg_Is_Matching_Tool_Name return Boolean; 1077 -- Returns True if the first argument is a tool name matching the 1078 -- current tool being run. 1079 1080 function Last_Arg return Node_Id; 1081 -- Returns the last argument 1082 1083 function Last_Arg_Is_Reason return Boolean; 1084 -- Returns True if the last argument is a reason argument 1085 1086 function Get_Reason return String_Id; 1087 -- Analyzes Reason argument and returns corresponding String_Id 1088 -- value, or null if there is no Reason argument, or if the 1089 -- argument is not of the required form. 1090 1091 ------------------------------------- 1092 -- First_Arg_Is_Matching_Tool_Name -- 1093 ------------------------------------- 1094 1095 function First_Arg_Is_Matching_Tool_Name return Boolean is 1096 begin 1097 return Nkind (Arg1) = N_Identifier 1098 1099 -- Return True if the tool name is GNAT, and we're not in 1100 -- GNATprove or CodePeer or ASIS mode... 1101 1102 and then ((Chars (Arg1) = Name_Gnat 1103 and then not 1104 (CodePeer_Mode or GNATprove_Mode or ASIS_Mode)) 1105 1106 -- or if the tool name is GNATprove, and we're in GNATprove 1107 -- mode. 1108 1109 or else 1110 (Chars (Arg1) = Name_Gnatprove 1111 and then GNATprove_Mode)); 1112 end First_Arg_Is_Matching_Tool_Name; 1113 1114 ---------------- 1115 -- Get_Reason -- 1116 ---------------- 1117 1118 function Get_Reason return String_Id is 1119 Arg : constant Node_Id := Last_Arg; 1120 begin 1121 if Last_Arg_Is_Reason then 1122 Start_String; 1123 Get_Reason_String (Expression (Arg)); 1124 return End_String; 1125 else 1126 return Null_String_Id; 1127 end if; 1128 end Get_Reason; 1129 1130 -------------- 1131 -- Last_Arg -- 1132 -------------- 1133 1134 function Last_Arg return Node_Id is 1135 Last_Arg : Node_Id; 1136 1137 begin 1138 if Arg_Count = 1 then 1139 Last_Arg := Arg1; 1140 elsif Arg_Count = 2 then 1141 Last_Arg := Arg2; 1142 elsif Arg_Count = 3 then 1143 Last_Arg := Arg3; 1144 elsif Arg_Count = 4 then 1145 Last_Arg := Next (Arg3); 1146 1147 -- Illegal case, error issued in semantic analysis 1148 1149 else 1150 Last_Arg := Empty; 1151 end if; 1152 1153 return Last_Arg; 1154 end Last_Arg; 1155 1156 ------------------------ 1157 -- Last_Arg_Is_Reason -- 1158 ------------------------ 1159 1160 function Last_Arg_Is_Reason return Boolean is 1161 Arg : constant Node_Id := Last_Arg; 1162 begin 1163 return Nkind (Arg) in N_Has_Chars 1164 and then Chars (Arg) = Name_Reason; 1165 end Last_Arg_Is_Reason; 1166 1167 The_Arg : Node_Id; -- On/Off argument 1168 Argx : Node_Id; 1169 1170 -- Start of processing for Warnings 1171 1172 begin 1173 if not Debug_Flag_Dot_I 1174 and then (Arg_Count = 1 1175 or else (Arg_Count = 2 1176 and then (First_Arg_Is_Matching_Tool_Name 1177 or else 1178 Last_Arg_Is_Reason)) 1179 or else (Arg_Count = 3 1180 and then First_Arg_Is_Matching_Tool_Name 1181 and then Last_Arg_Is_Reason)) 1182 then 1183 if First_Arg_Is_Matching_Tool_Name then 1184 The_Arg := Arg2; 1185 else 1186 The_Arg := Arg1; 1187 end if; 1188 1189 Check_No_Identifier (The_Arg); 1190 Argx := Expression (The_Arg); 1191 1192 if Nkind (Argx) = N_Identifier then 1193 if Chars (Argx) = Name_On then 1194 Set_Warnings_Mode_On (Pragma_Sloc); 1195 elsif Chars (Argx) = Name_Off then 1196 Set_Warnings_Mode_Off (Pragma_Sloc, Get_Reason); 1197 end if; 1198 end if; 1199 end if; 1200 end Warnings; 1201 1202 ----------------------------- 1203 -- Wide_Character_Encoding -- 1204 ----------------------------- 1205 1206 -- pragma Wide_Character_Encoding (IDENTIFIER | CHARACTER_LITERAL); 1207 1208 -- This is processed by the parser, since the scanner is affected 1209 1210 when Pragma_Wide_Character_Encoding => Wide_Character_Encoding : declare 1211 A : Node_Id; 1212 1213 begin 1214 Check_Arg_Count (1); 1215 Check_No_Identifier (Arg1); 1216 A := Expression (Arg1); 1217 1218 if Nkind (A) = N_Identifier then 1219 Get_Name_String (Chars (A)); 1220 Wide_Character_Encoding_Method := 1221 Get_WC_Encoding_Method (Name_Buffer (1 .. Name_Len)); 1222 1223 elsif Nkind (A) = N_Character_Literal then 1224 declare 1225 R : constant Char_Code := 1226 Char_Code (UI_To_Int (Char_Literal_Value (A))); 1227 begin 1228 if In_Character_Range (R) then 1229 Wide_Character_Encoding_Method := 1230 Get_WC_Encoding_Method (Get_Character (R)); 1231 else 1232 raise Constraint_Error; 1233 end if; 1234 end; 1235 1236 else 1237 raise Constraint_Error; 1238 end if; 1239 1240 Upper_Half_Encoding := 1241 Wide_Character_Encoding_Method in 1242 WC_Upper_Half_Encoding_Method; 1243 1244 exception 1245 when Constraint_Error => 1246 Error_Msg_N ("invalid argument for pragma%", Arg1); 1247 end Wide_Character_Encoding; 1248 1249 ----------------------- 1250 -- All Other Pragmas -- 1251 ----------------------- 1252 1253 -- For all other pragmas, checking and processing is handled 1254 -- entirely in Sem_Prag, and no further checking is done by Par. 1255 1256 when Pragma_Abort_Defer | 1257 Pragma_Abstract_State | 1258 Pragma_Async_Readers | 1259 Pragma_Async_Writers | 1260 Pragma_Assertion_Policy | 1261 Pragma_Assume | 1262 Pragma_Assume_No_Invalid_Values | 1263 Pragma_All_Calls_Remote | 1264 Pragma_Allow_Integer_Address | 1265 Pragma_Annotate | 1266 Pragma_Assert | 1267 Pragma_Assert_And_Cut | 1268 Pragma_Asynchronous | 1269 Pragma_Atomic | 1270 Pragma_Atomic_Components | 1271 Pragma_Attach_Handler | 1272 Pragma_Attribute_Definition | 1273 Pragma_Check | 1274 Pragma_Check_Float_Overflow | 1275 Pragma_Check_Name | 1276 Pragma_Check_Policy | 1277 Pragma_CIL_Constructor | 1278 Pragma_Compile_Time_Error | 1279 Pragma_Compile_Time_Warning | 1280 Pragma_Contract_Cases | 1281 Pragma_Convention_Identifier | 1282 Pragma_CPP_Class | 1283 Pragma_CPP_Constructor | 1284 Pragma_CPP_Virtual | 1285 Pragma_CPP_Vtable | 1286 Pragma_CPU | 1287 Pragma_C_Pass_By_Copy | 1288 Pragma_Comment | 1289 Pragma_Common_Object | 1290 Pragma_Complete_Representation | 1291 Pragma_Complex_Representation | 1292 Pragma_Component_Alignment | 1293 Pragma_Controlled | 1294 Pragma_Convention | 1295 Pragma_Debug_Policy | 1296 Pragma_Depends | 1297 Pragma_Detect_Blocking | 1298 Pragma_Default_Initial_Condition | 1299 Pragma_Default_Scalar_Storage_Order | 1300 Pragma_Default_Storage_Pool | 1301 Pragma_Disable_Atomic_Synchronization | 1302 Pragma_Discard_Names | 1303 Pragma_Dispatching_Domain | 1304 Pragma_Effective_Reads | 1305 Pragma_Effective_Writes | 1306 Pragma_Eliminate | 1307 Pragma_Elaborate | 1308 Pragma_Elaborate_All | 1309 Pragma_Elaborate_Body | 1310 Pragma_Elaboration_Checks | 1311 Pragma_Enable_Atomic_Synchronization | 1312 Pragma_Export | 1313 Pragma_Export_Function | 1314 Pragma_Export_Object | 1315 Pragma_Export_Procedure | 1316 Pragma_Export_Value | 1317 Pragma_Export_Valued_Procedure | 1318 Pragma_Extend_System | 1319 Pragma_Extensions_Visible | 1320 Pragma_External | 1321 Pragma_External_Name_Casing | 1322 Pragma_Favor_Top_Level | 1323 Pragma_Fast_Math | 1324 Pragma_Finalize_Storage_Only | 1325 Pragma_Ghost | 1326 Pragma_Global | 1327 Pragma_Ident | 1328 Pragma_Implementation_Defined | 1329 Pragma_Implemented | 1330 Pragma_Implicit_Packing | 1331 Pragma_Import | 1332 Pragma_Import_Function | 1333 Pragma_Import_Object | 1334 Pragma_Import_Procedure | 1335 Pragma_Import_Valued_Procedure | 1336 Pragma_Independent | 1337 Pragma_Independent_Components | 1338 Pragma_Initial_Condition | 1339 Pragma_Initialize_Scalars | 1340 Pragma_Initializes | 1341 Pragma_Inline | 1342 Pragma_Inline_Always | 1343 Pragma_Inline_Generic | 1344 Pragma_Inspection_Point | 1345 Pragma_Interface | 1346 Pragma_Interface_Name | 1347 Pragma_Interrupt_Handler | 1348 Pragma_Interrupt_State | 1349 Pragma_Interrupt_Priority | 1350 Pragma_Invariant | 1351 Pragma_Java_Constructor | 1352 Pragma_Java_Interface | 1353 Pragma_Keep_Names | 1354 Pragma_License | 1355 Pragma_Link_With | 1356 Pragma_Linker_Alias | 1357 Pragma_Linker_Constructor | 1358 Pragma_Linker_Destructor | 1359 Pragma_Linker_Options | 1360 Pragma_Linker_Section | 1361 Pragma_Lock_Free | 1362 Pragma_Locking_Policy | 1363 Pragma_Loop_Invariant | 1364 Pragma_Loop_Optimize | 1365 Pragma_Loop_Variant | 1366 Pragma_Machine_Attribute | 1367 Pragma_Main | 1368 Pragma_Main_Storage | 1369 Pragma_Memory_Size | 1370 Pragma_No_Body | 1371 Pragma_No_Elaboration_Code_All | 1372 Pragma_No_Inline | 1373 Pragma_No_Return | 1374 Pragma_No_Run_Time | 1375 Pragma_No_Strict_Aliasing | 1376 Pragma_No_Tagged_Streams | 1377 Pragma_Normalize_Scalars | 1378 Pragma_Obsolescent | 1379 Pragma_Ordered | 1380 Pragma_Optimize | 1381 Pragma_Optimize_Alignment | 1382 Pragma_Overflow_Mode | 1383 Pragma_Overriding_Renamings | 1384 Pragma_Pack | 1385 Pragma_Part_Of | 1386 Pragma_Partition_Elaboration_Policy | 1387 Pragma_Passive | 1388 Pragma_Preelaborable_Initialization | 1389 Pragma_Polling | 1390 Pragma_Prefix_Exception_Messages | 1391 Pragma_Persistent_BSS | 1392 Pragma_Post | 1393 Pragma_Postcondition | 1394 Pragma_Post_Class | 1395 Pragma_Pre | 1396 Pragma_Precondition | 1397 Pragma_Predicate | 1398 Pragma_Preelaborate | 1399 Pragma_Pre_Class | 1400 Pragma_Priority | 1401 Pragma_Priority_Specific_Dispatching | 1402 Pragma_Profile | 1403 Pragma_Profile_Warnings | 1404 Pragma_Propagate_Exceptions | 1405 Pragma_Provide_Shift_Operators | 1406 Pragma_Psect_Object | 1407 Pragma_Pure | 1408 Pragma_Pure_Function | 1409 Pragma_Queuing_Policy | 1410 Pragma_Refined_Depends | 1411 Pragma_Refined_Global | 1412 Pragma_Refined_Post | 1413 Pragma_Refined_State | 1414 Pragma_Relative_Deadline | 1415 Pragma_Remote_Access_Type | 1416 Pragma_Remote_Call_Interface | 1417 Pragma_Remote_Types | 1418 Pragma_Restricted_Run_Time | 1419 Pragma_Rational | 1420 Pragma_Ravenscar | 1421 Pragma_Reviewable | 1422 Pragma_Share_Generic | 1423 Pragma_Shared | 1424 Pragma_Shared_Passive | 1425 Pragma_Short_Circuit_And_Or | 1426 Pragma_Short_Descriptors | 1427 Pragma_Simple_Storage_Pool_Type | 1428 Pragma_SPARK_Mode | 1429 Pragma_Storage_Size | 1430 Pragma_Storage_Unit | 1431 Pragma_Static_Elaboration_Desired | 1432 Pragma_Stream_Convert | 1433 Pragma_Subtitle | 1434 Pragma_Suppress | 1435 Pragma_Suppress_Debug_Info | 1436 Pragma_Suppress_Exception_Locations | 1437 Pragma_Suppress_Initialization | 1438 Pragma_System_Name | 1439 Pragma_Task_Dispatching_Policy | 1440 Pragma_Task_Info | 1441 Pragma_Task_Name | 1442 Pragma_Task_Storage | 1443 Pragma_Test_Case | 1444 Pragma_Thread_Local_Storage | 1445 Pragma_Time_Slice | 1446 Pragma_Title | 1447 Pragma_Type_Invariant | 1448 Pragma_Type_Invariant_Class | 1449 Pragma_Unchecked_Union | 1450 Pragma_Unevaluated_Use_Of_Old | 1451 Pragma_Unimplemented_Unit | 1452 Pragma_Universal_Aliasing | 1453 Pragma_Universal_Data | 1454 Pragma_Unmodified | 1455 Pragma_Unreferenced | 1456 Pragma_Unreferenced_Objects | 1457 Pragma_Unreserve_All_Interrupts | 1458 Pragma_Unsuppress | 1459 Pragma_Use_VADS_Size | 1460 Pragma_Volatile | 1461 Pragma_Volatile_Components | 1462 Pragma_Warning_As_Error | 1463 Pragma_Weak_External | 1464 Pragma_Validity_Checks => 1465 null; 1466 1467 -------------------- 1468 -- Unknown_Pragma -- 1469 -------------------- 1470 1471 -- Should be impossible, since we excluded this case earlier on 1472 1473 when Unknown_Pragma => 1474 raise Program_Error; 1475 1476 end case; 1477 1478 return Pragma_Node; 1479 1480 -------------------- 1481 -- Error Handling -- 1482 -------------------- 1483 1484exception 1485 when Error_Resync => 1486 return Error; 1487 1488end Prag; 1489