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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27-- Generally the parser checks the basic syntax of pragmas, but does not 28-- do specialized syntax checks for individual pragmas, these are deferred 29-- to semantic analysis time (see unit Sem_Prag). There are some pragmas 30-- which require recognition and either partial or complete processing 31-- during parsing, and this unit performs this required processing. 32 33with Fname.UF; use Fname.UF; 34with Osint; use Osint; 35with Stringt; use Stringt; 36with Stylesw; use Stylesw; 37with Uintp; use Uintp; 38with Uname; use Uname; 39 40separate (Par) 41 42function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is 43 Pragma_Name : constant Name_Id := Chars (Pragma_Node); 44 Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node); 45 Arg_Count : Nat; 46 Arg_Node : Node_Id; 47 48 ----------------------- 49 -- Local Subprograms -- 50 ----------------------- 51 52 function Arg1 return Node_Id; 53 function Arg2 return Node_Id; 54 function Arg3 return Node_Id; 55 -- Obtain specified Pragma_Argument_Association. It is allowable to call 56 -- the routine for the argument one past the last present argument, but 57 -- that is the only case in which a non-present argument can be referenced. 58 59 procedure Check_Arg_Count (Required : Int); 60 -- Check argument count for pragma = Required. 61 -- If not give error and raise Error_Resync. 62 63 procedure Check_Arg_Is_String_Literal (Arg : Node_Id); 64 -- Check the expression of the specified argument to make sure that it 65 -- is a string literal. If not give error and raise Error_Resync. 66 67 procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id); 68 -- Check the expression of the specified argument to make sure that it 69 -- is an identifier which is either ON or OFF, and if not, then issue 70 -- an error message and raise Error_Resync. 71 72 procedure Check_No_Identifier (Arg : Node_Id); 73 -- Checks that the given argument does not have an identifier. If 74 -- an identifier is present, then an error message is issued, and 75 -- Error_Resync is raised. 76 77 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); 78 -- Checks if the given argument has an identifier, and if so, requires 79 -- it to match the given identifier name. If there is a non-matching 80 -- identifier, then an error message is given and Error_Resync raised. 81 82 procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id); 83 -- Same as Check_Optional_Identifier, except that the name is required 84 -- to be present and to match the given Id value. 85 86 ---------- 87 -- Arg1 -- 88 ---------- 89 90 function Arg1 return Node_Id is 91 begin 92 return First (Pragma_Argument_Associations (Pragma_Node)); 93 end Arg1; 94 95 ---------- 96 -- Arg2 -- 97 ---------- 98 99 function Arg2 return Node_Id is 100 begin 101 return Next (Arg1); 102 end Arg2; 103 104 ---------- 105 -- Arg3 -- 106 ---------- 107 108 function Arg3 return Node_Id is 109 begin 110 return Next (Arg2); 111 end Arg3; 112 113 --------------------- 114 -- Check_Arg_Count -- 115 --------------------- 116 117 procedure Check_Arg_Count (Required : Int) is 118 begin 119 if Arg_Count /= Required then 120 Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); 121 raise Error_Resync; 122 end if; 123 end Check_Arg_Count; 124 125 ---------------------------- 126 -- Check_Arg_Is_On_Or_Off -- 127 ---------------------------- 128 129 procedure Check_Arg_Is_On_Or_Off (Arg : Node_Id) is 130 Argx : constant Node_Id := Expression (Arg); 131 132 begin 133 if Nkind (Expression (Arg)) /= N_Identifier 134 or else (Chars (Argx) /= Name_On 135 and then 136 Chars (Argx) /= Name_Off) 137 then 138 Error_Msg_Name_2 := Name_On; 139 Error_Msg_Name_3 := Name_Off; 140 141 Error_Msg 142 ("argument for pragma% must be% or%", Sloc (Argx)); 143 raise Error_Resync; 144 end if; 145 end Check_Arg_Is_On_Or_Off; 146 147 --------------------------------- 148 -- Check_Arg_Is_String_Literal -- 149 --------------------------------- 150 151 procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is 152 begin 153 if Nkind (Expression (Arg)) /= N_String_Literal then 154 Error_Msg 155 ("argument for pragma% must be string literal", 156 Sloc (Expression (Arg))); 157 raise Error_Resync; 158 end if; 159 end Check_Arg_Is_String_Literal; 160 161 ------------------------- 162 -- Check_No_Identifier -- 163 ------------------------- 164 165 procedure Check_No_Identifier (Arg : Node_Id) is 166 begin 167 if Chars (Arg) /= No_Name then 168 Error_Msg_N ("pragma% does not permit named arguments", Arg); 169 raise Error_Resync; 170 end if; 171 end Check_No_Identifier; 172 173 ------------------------------- 174 -- Check_Optional_Identifier -- 175 ------------------------------- 176 177 procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is 178 begin 179 if Present (Arg) and then Chars (Arg) /= No_Name then 180 if Chars (Arg) /= Id then 181 Error_Msg_Name_2 := Id; 182 Error_Msg_N ("pragma% argument expects identifier%", Arg); 183 end if; 184 end if; 185 end Check_Optional_Identifier; 186 187 ------------------------------- 188 -- Check_Required_Identifier -- 189 ------------------------------- 190 191 procedure Check_Required_Identifier (Arg : Node_Id; Id : Name_Id) is 192 begin 193 if Chars (Arg) /= Id then 194 Error_Msg_Name_2 := Id; 195 Error_Msg_N ("pragma% argument must have identifier%", Arg); 196 end if; 197 end Check_Required_Identifier; 198 199 ---------- 200 -- Prag -- 201 ---------- 202 203begin 204 Error_Msg_Name_1 := Pragma_Name; 205 206 -- Ignore unrecognized pragma. We let Sem post the warning for this, since 207 -- it is a semantic error, not a syntactic one (we have already checked 208 -- the syntax for the unrecognized pragma as required by (RM 2.8(11)). 209 210 if not Is_Pragma_Name (Chars (Pragma_Node)) then 211 return Pragma_Node; 212 end if; 213 214 -- Count number of arguments. This loop also checks if any of the arguments 215 -- are Error, indicating a syntax error as they were parsed. If so, we 216 -- simply return, because we get into trouble with cascaded errors if we 217 -- try to perform our error checks on junk arguments. 218 219 Arg_Count := 0; 220 221 if Present (Pragma_Argument_Associations (Pragma_Node)) then 222 Arg_Node := Arg1; 223 224 while Arg_Node /= Empty loop 225 Arg_Count := Arg_Count + 1; 226 227 if Expression (Arg_Node) = Error then 228 return Error; 229 end if; 230 231 Next (Arg_Node); 232 end loop; 233 end if; 234 235 -- Remaining processing is pragma dependent 236 237 case Get_Pragma_Id (Pragma_Name) is 238 239 ------------ 240 -- Ada_83 -- 241 ------------ 242 243 -- This pragma must be processed at parse time, since we want to set 244 -- the Ada 83 and Ada 95 switches properly at parse time to recognize 245 -- Ada 83 syntax or Ada 95 syntax as appropriate. 246 247 when Pragma_Ada_83 => 248 Ada_83 := True; 249 Ada_95 := False; 250 251 ------------ 252 -- Ada_95 -- 253 ------------ 254 255 -- This pragma must be processed at parse time, since we want to set 256 -- the Ada 83 and Ada_95 switches properly at parse time to recognize 257 -- Ada 83 syntax or Ada 95 syntax as appropriate. 258 259 when Pragma_Ada_95 => 260 Ada_83 := False; 261 Ada_95 := True; 262 263 ----------- 264 -- Debug -- 265 ----------- 266 267 -- pragma Debug (PROCEDURE_CALL_STATEMENT); 268 269 -- This has to be processed by the parser because of the very peculiar 270 -- form of the second parameter, which is syntactically from a formal 271 -- point of view a function call (since it must be an expression), but 272 -- semantically we treat it as a procedure call (which has exactly the 273 -- same syntactic form, so that's why we can get away with this!) 274 275 when Pragma_Debug => 276 Check_Arg_Count (1); 277 Check_No_Identifier (Arg1); 278 279 declare 280 Expr : constant Node_Id := New_Copy (Expression (Arg1)); 281 282 begin 283 if Nkind (Expr) /= N_Indexed_Component 284 and then Nkind (Expr) /= N_Function_Call 285 and then Nkind (Expr) /= N_Identifier 286 and then Nkind (Expr) /= N_Selected_Component 287 then 288 Error_Msg 289 ("argument of pragma% is not procedure call", Sloc (Expr)); 290 raise Error_Resync; 291 else 292 Set_Debug_Statement 293 (Pragma_Node, P_Statement_Name (Expr)); 294 end if; 295 end; 296 297 ------------------------------- 298 -- Extensions_Allowed (GNAT) -- 299 ------------------------------- 300 301 -- pragma Extensions_Allowed (Off | On) 302 303 -- The processing for pragma Extensions_Allowed must be done at 304 -- parse time, since extensions mode may affect what is accepted. 305 306 when Pragma_Extensions_Allowed => 307 Check_Arg_Count (1); 308 Check_No_Identifier (Arg1); 309 Check_Arg_Is_On_Or_Off (Arg1); 310 Opt.Extensions_Allowed := (Chars (Expression (Arg1)) = Name_On); 311 312 ---------------- 313 -- List (2.8) -- 314 ---------------- 315 316 -- pragma List (Off | On) 317 318 -- The processing for pragma List must be done at parse time, 319 -- since a listing can be generated in parse only mode. 320 321 when Pragma_List => 322 Check_Arg_Count (1); 323 Check_No_Identifier (Arg1); 324 Check_Arg_Is_On_Or_Off (Arg1); 325 326 -- We unconditionally make a List_On entry for the pragma, so that 327 -- in the List (Off) case, the pragma will print even in a region 328 -- of code with listing turned off (this is required!) 329 330 List_Pragmas.Increment_Last; 331 List_Pragmas.Table (List_Pragmas.Last) := 332 (Ptyp => List_On, Ploc => Sloc (Pragma_Node)); 333 334 -- Now generate the list off entry for pragma List (Off) 335 336 if Chars (Expression (Arg1)) = Name_Off then 337 List_Pragmas.Increment_Last; 338 List_Pragmas.Table (List_Pragmas.Last) := 339 (Ptyp => List_Off, Ploc => Semi); 340 end if; 341 342 ---------------- 343 -- Page (2.8) -- 344 ---------------- 345 346 -- pragma Page; 347 348 -- Processing for this pragma must be done at parse time, since a 349 -- listing can be generated in parse only mode with semantics off. 350 351 when Pragma_Page => 352 Check_Arg_Count (0); 353 List_Pragmas.Increment_Last; 354 List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi); 355 356 ---------------------------------------------------------- 357 -- Source_File_Name and Source_File_Name_Project (GNAT) -- 358 ---------------------------------------------------------- 359 360 -- These two pragmas have the same syntax and semantics. 361 -- There are five forms of these pragmas: 362 363 -- pragma Source_File_Name ( 364 -- [UNIT_NAME =>] unit_NAME, 365 -- BODY_FILE_NAME => STRING_LITERAL); 366 367 -- pragma Source_File_Name ( 368 -- [UNIT_NAME =>] unit_NAME, 369 -- SPEC_FILE_NAME => STRING_LITERAL); 370 371 -- pragma Source_File_Name ( 372 -- BODY_FILE_NAME => STRING_LITERAL 373 -- [, DOT_REPLACEMENT => STRING_LITERAL] 374 -- [, CASING => CASING_SPEC]); 375 376 -- pragma Source_File_Name ( 377 -- SPEC_FILE_NAME => STRING_LITERAL 378 -- [, DOT_REPLACEMENT => STRING_LITERAL] 379 -- [, CASING => CASING_SPEC]); 380 381 -- pragma Source_File_Name ( 382 -- SUBUNIT_FILE_NAME => STRING_LITERAL 383 -- [, DOT_REPLACEMENT => STRING_LITERAL] 384 -- [, CASING => CASING_SPEC]); 385 386 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase 387 388 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma 389 -- Source_File_Name (SFN), however their usage is exclusive: 390 -- SFN can only be used when no project file is used, while 391 -- SFNP can only be used when a project file is used. 392 393 -- The Project Manager produces a configuration pragmas file that 394 -- is communicated to the compiler with -gnatec switch. This file 395 -- contains only SFNP pragmas (at least two for the default naming 396 -- scheme. As this configuration pragmas file is always the first 397 -- processed by the compiler, it prevents the use of pragmas SFN in 398 -- other config files when a project file is in use. 399 400 -- Note: we process this during parsing, since we need to have the 401 -- source file names set well before the semantic analysis starts, 402 -- since we load the spec and with'ed packages before analysis. 403 404 when Pragma_Source_File_Name | Pragma_Source_File_Name_Project => 405 Source_File_Name : declare 406 Unam : Unit_Name_Type; 407 Expr1 : Node_Id; 408 Pat : String_Ptr; 409 Typ : Character; 410 Dot : String_Ptr; 411 Cas : Casing_Type; 412 Nast : Nat; 413 414 function Get_Fname (Arg : Node_Id) return Name_Id; 415 -- Process file name from unit name form of pragma 416 417 function Get_String_Argument (Arg : Node_Id) return String_Ptr; 418 -- Process string literal value from argument 419 420 procedure Process_Casing (Arg : Node_Id); 421 -- Process Casing argument of pattern form of pragma 422 423 procedure Process_Dot_Replacement (Arg : Node_Id); 424 -- Process Dot_Replacement argument of patterm form of pragma 425 426 --------------- 427 -- Get_Fname -- 428 --------------- 429 430 function Get_Fname (Arg : Node_Id) return Name_Id is 431 begin 432 String_To_Name_Buffer (Strval (Expression (Arg))); 433 434 for J in 1 .. Name_Len loop 435 if Is_Directory_Separator (Name_Buffer (J)) then 436 Error_Msg 437 ("directory separator character not allowed", 438 Sloc (Expression (Arg)) + Source_Ptr (J)); 439 end if; 440 end loop; 441 442 return Name_Find; 443 end Get_Fname; 444 445 ------------------------- 446 -- Get_String_Argument -- 447 ------------------------- 448 449 function Get_String_Argument (Arg : Node_Id) return String_Ptr is 450 Str : String_Id; 451 452 begin 453 if Nkind (Expression (Arg)) /= N_String_Literal 454 and then 455 Nkind (Expression (Arg)) /= N_Operator_Symbol 456 then 457 Error_Msg_N 458 ("argument for pragma% must be string literal", Arg); 459 raise Error_Resync; 460 end if; 461 462 Str := Strval (Expression (Arg)); 463 464 -- Check string has no wide chars 465 466 for J in 1 .. String_Length (Str) loop 467 if Get_String_Char (Str, J) > 255 then 468 Error_Msg 469 ("wide character not allowed in pattern for pragma%", 470 Sloc (Expression (Arg2)) + Text_Ptr (J) - 1); 471 end if; 472 end loop; 473 474 -- Acquire string 475 476 String_To_Name_Buffer (Str); 477 return new String'(Name_Buffer (1 .. Name_Len)); 478 end Get_String_Argument; 479 480 -------------------- 481 -- Process_Casing -- 482 -------------------- 483 484 procedure Process_Casing (Arg : Node_Id) is 485 Expr : constant Node_Id := Expression (Arg); 486 487 begin 488 Check_Required_Identifier (Arg, Name_Casing); 489 490 if Nkind (Expr) = N_Identifier then 491 if Chars (Expr) = Name_Lowercase then 492 Cas := All_Lower_Case; 493 return; 494 elsif Chars (Expr) = Name_Uppercase then 495 Cas := All_Upper_Case; 496 return; 497 elsif Chars (Expr) = Name_Mixedcase then 498 Cas := Mixed_Case; 499 return; 500 end if; 501 end if; 502 503 Error_Msg_N 504 ("Casing argument for pragma% must be " & 505 "one of Mixedcase, Lowercase, Uppercase", 506 Arg); 507 end Process_Casing; 508 509 ----------------------------- 510 -- Process_Dot_Replacement -- 511 ----------------------------- 512 513 procedure Process_Dot_Replacement (Arg : Node_Id) is 514 begin 515 Check_Required_Identifier (Arg, Name_Dot_Replacement); 516 Dot := Get_String_Argument (Arg); 517 end Process_Dot_Replacement; 518 519 -- Start of processing for Source_File_Name and 520 -- Source_File_Name_Project pragmas. 521 522 begin 523 524 if Get_Pragma_Id (Pragma_Name) = Pragma_Source_File_Name then 525 if Project_File_In_Use = In_Use then 526 Error_Msg 527 ("pragma Source_File_Name cannot be used " & 528 "with a project file", Pragma_Sloc); 529 530 else 531 Project_File_In_Use := Not_In_Use; 532 end if; 533 534 else 535 if Project_File_In_Use = Not_In_Use then 536 Error_Msg 537 ("pragma Source_File_Name_Project should only be used " & 538 "with a project file", Pragma_Sloc); 539 540 else 541 Project_File_In_Use := In_Use; 542 end if; 543 end if; 544 545 -- We permit from 1 to 3 arguments 546 547 if Arg_Count not in 1 .. 3 then 548 Check_Arg_Count (1); 549 end if; 550 551 Expr1 := Expression (Arg1); 552 553 -- If first argument is identifier or selected component, then 554 -- we have the specific file case of the Source_File_Name pragma, 555 -- and the first argument is a unit name. 556 557 if Nkind (Expr1) = N_Identifier 558 or else 559 (Nkind (Expr1) = N_Selected_Component 560 and then 561 Nkind (Selector_Name (Expr1)) = N_Identifier) 562 then 563 if Nkind (Expr1) = N_Identifier 564 and then Chars (Expr1) = Name_System 565 then 566 Error_Msg_N 567 ("pragma Source_File_Name may not be used for System", 568 Arg1); 569 return Error; 570 end if; 571 572 Check_Arg_Count (2); 573 574 Check_Optional_Identifier (Arg1, Name_Unit_Name); 575 Unam := Get_Unit_Name (Expr1); 576 577 Check_Arg_Is_String_Literal (Arg2); 578 579 if Chars (Arg2) = Name_Spec_File_Name then 580 Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2)); 581 582 elsif Chars (Arg2) = Name_Body_File_Name then 583 Set_File_Name (Unam, Get_Fname (Arg2)); 584 585 else 586 Error_Msg_N 587 ("pragma% argument has incorrect identifier", Arg2); 588 return Pragma_Node; 589 end if; 590 591 -- If the first argument is not an identifier, then we must have 592 -- the pattern form of the pragma, and the first argument must be 593 -- the pattern string with an appropriate name. 594 595 else 596 if Chars (Arg1) = Name_Spec_File_Name then 597 Typ := 's'; 598 599 elsif Chars (Arg1) = Name_Body_File_Name then 600 Typ := 'b'; 601 602 elsif Chars (Arg1) = Name_Subunit_File_Name then 603 Typ := 'u'; 604 605 elsif Chars (Arg1) = Name_Unit_Name then 606 Error_Msg_N 607 ("Unit_Name parameter for pragma% must be an identifier", 608 Arg1); 609 raise Error_Resync; 610 611 else 612 Error_Msg_N 613 ("pragma% argument has incorrect identifier", Arg1); 614 raise Error_Resync; 615 end if; 616 617 Pat := Get_String_Argument (Arg1); 618 619 -- Check pattern has exactly one asterisk 620 621 Nast := 0; 622 for J in Pat'Range loop 623 if Pat (J) = '*' then 624 Nast := Nast + 1; 625 end if; 626 end loop; 627 628 if Nast /= 1 then 629 Error_Msg_N 630 ("file name pattern must have exactly one * character", 631 Arg2); 632 return Pragma_Node; 633 end if; 634 635 -- Set defaults for Casing and Dot_Separator parameters 636 637 Cas := All_Lower_Case; 638 639 Dot := new String'("."); 640 641 -- Process second and third arguments if present 642 643 if Arg_Count > 1 then 644 if Chars (Arg2) = Name_Casing then 645 Process_Casing (Arg2); 646 647 if Arg_Count = 3 then 648 Process_Dot_Replacement (Arg3); 649 end if; 650 651 else 652 Process_Dot_Replacement (Arg2); 653 654 if Arg_Count = 3 then 655 Process_Casing (Arg3); 656 end if; 657 end if; 658 end if; 659 660 Set_File_Name_Pattern (Pat, Typ, Dot, Cas); 661 end if; 662 end Source_File_Name; 663 664 ----------------------------- 665 -- Source_Reference (GNAT) -- 666 ----------------------------- 667 668 -- pragma Source_Reference 669 -- (INTEGER_LITERAL [, STRING_LITERAL] ); 670 671 -- Processing for this pragma must be done at parse time, since error 672 -- messages needing the proper line numbers can be generated in parse 673 -- only mode with semantic checking turned off, and indeed we usually 674 -- turn off semantic checking anyway if any parse errors are found. 675 676 when Pragma_Source_Reference => Source_Reference : declare 677 Fname : Name_Id; 678 679 begin 680 if Arg_Count /= 1 then 681 Check_Arg_Count (2); 682 Check_No_Identifier (Arg2); 683 end if; 684 685 -- Check that this is first line of file. We skip this test if 686 -- we are in syntax check only mode, since we may be dealing with 687 -- multiple compilation units. 688 689 if Get_Physical_Line_Number (Pragma_Sloc) /= 1 690 and then Num_SRef_Pragmas (Current_Source_File) = 0 691 and then Operating_Mode /= Check_Syntax 692 then 693 Error_Msg 694 ("first % pragma must be first line of file", Pragma_Sloc); 695 raise Error_Resync; 696 end if; 697 698 Check_No_Identifier (Arg1); 699 700 if Arg_Count = 1 then 701 if Num_SRef_Pragmas (Current_Source_File) = 0 then 702 Error_Msg 703 ("file name required for first % pragma in file", 704 Pragma_Sloc); 705 raise Error_Resync; 706 707 else 708 Fname := No_Name; 709 end if; 710 711 -- File name present 712 713 else 714 Check_Arg_Is_String_Literal (Arg2); 715 String_To_Name_Buffer (Strval (Expression (Arg2))); 716 Fname := Name_Find; 717 718 if Num_SRef_Pragmas (Current_Source_File) > 0 then 719 if Fname /= Full_Ref_Name (Current_Source_File) then 720 Error_Msg 721 ("file name must be same in all % pragmas", Pragma_Sloc); 722 raise Error_Resync; 723 end if; 724 end if; 725 end if; 726 727 if Nkind (Expression (Arg1)) /= N_Integer_Literal then 728 Error_Msg 729 ("argument for pragma% must be integer literal", 730 Sloc (Expression (Arg1))); 731 raise Error_Resync; 732 733 -- OK, this source reference pragma is effective, however, we 734 -- ignore it if it is not in the first unit in the multiple unit 735 -- case. This is because the only purpose in this case is to 736 -- provide source pragmas for subsequent use by gnatchop. 737 738 else 739 if Num_Library_Units = 1 then 740 Register_Source_Ref_Pragma 741 (Fname, 742 Strip_Directory (Fname), 743 UI_To_Int (Intval (Expression (Arg1))), 744 Get_Physical_Line_Number (Pragma_Sloc) + 1); 745 end if; 746 end if; 747 end Source_Reference; 748 749 ------------------------- 750 -- Style_Checks (GNAT) -- 751 ------------------------- 752 753 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL); 754 755 -- This is processed by the parser since some of the style 756 -- checks take place during source scanning and parsing. 757 758 when Pragma_Style_Checks => Style_Checks : declare 759 A : Node_Id; 760 S : String_Id; 761 C : Char_Code; 762 OK : Boolean := True; 763 764 begin 765 -- Two argument case is only for semantics 766 767 if Arg_Count = 2 then 768 null; 769 770 else 771 Check_Arg_Count (1); 772 Check_No_Identifier (Arg1); 773 A := Expression (Arg1); 774 775 if Nkind (A) = N_String_Literal then 776 S := Strval (A); 777 778 declare 779 Slen : constant Natural := Natural (String_Length (S)); 780 Options : String (1 .. Slen); 781 J : Natural; 782 Ptr : Natural; 783 784 begin 785 J := 1; 786 loop 787 C := Get_String_Char (S, Int (J)); 788 789 if not In_Character_Range (C) then 790 OK := False; 791 Ptr := J; 792 exit; 793 794 else 795 Options (J) := Get_Character (C); 796 end if; 797 798 if J = Slen then 799 Set_Style_Check_Options (Options, OK, Ptr); 800 exit; 801 802 else 803 J := J + 1; 804 end if; 805 end loop; 806 807 if not OK then 808 Error_Msg 809 ("invalid style check option", 810 Sloc (Expression (Arg1)) + Source_Ptr (Ptr)); 811 raise Error_Resync; 812 end if; 813 end; 814 815 elsif Nkind (A) /= N_Identifier then 816 OK := False; 817 818 elsif Chars (A) = Name_All_Checks then 819 Stylesw.Set_Default_Style_Check_Options; 820 821 elsif Chars (A) = Name_On then 822 Style_Check := True; 823 824 elsif Chars (A) = Name_Off then 825 Style_Check := False; 826 827 else 828 OK := False; 829 end if; 830 831 if not OK then 832 Error_Msg ("incorrect argument for pragma%", Sloc (A)); 833 raise Error_Resync; 834 end if; 835 end if; 836 end Style_Checks; 837 838 --------------------- 839 -- Warnings (GNAT) -- 840 --------------------- 841 842 -- pragma Warnings (On | Off, [LOCAL_NAME]) 843 844 -- The one argument case is processed by the parser, since it may 845 -- control parser warnings as well as semantic warnings, and in any 846 -- case we want to be absolutely sure that the range in the warnings 847 -- table is set well before any semantic analysis is performed. 848 849 when Pragma_Warnings => 850 if Arg_Count = 1 then 851 Check_No_Identifier (Arg1); 852 Check_Arg_Is_On_Or_Off (Arg1); 853 854 if Chars (Expression (Arg1)) = Name_On then 855 Set_Warnings_Mode_On (Pragma_Sloc); 856 else 857 Set_Warnings_Mode_Off (Pragma_Sloc); 858 end if; 859 end if; 860 861 ----------------------- 862 -- All Other Pragmas -- 863 ----------------------- 864 865 -- For all other pragmas, checking and processing is handled 866 -- entirely in Sem_Prag, and no further checking is done by Par. 867 868 when Pragma_Abort_Defer | 869 Pragma_AST_Entry | 870 Pragma_All_Calls_Remote | 871 Pragma_Annotate | 872 Pragma_Assert | 873 Pragma_Asynchronous | 874 Pragma_Atomic | 875 Pragma_Atomic_Components | 876 Pragma_Attach_Handler | 877 Pragma_Compile_Time_Warning | 878 Pragma_Convention_Identifier | 879 Pragma_CPP_Class | 880 Pragma_CPP_Constructor | 881 Pragma_CPP_Virtual | 882 Pragma_CPP_Vtable | 883 Pragma_C_Pass_By_Copy | 884 Pragma_Comment | 885 Pragma_Common_Object | 886 Pragma_Complex_Representation | 887 Pragma_Component_Alignment | 888 Pragma_Controlled | 889 Pragma_Convention | 890 Pragma_Discard_Names | 891 Pragma_Eliminate | 892 Pragma_Elaborate | 893 Pragma_Elaborate_All | 894 Pragma_Elaborate_Body | 895 Pragma_Elaboration_Checks | 896 Pragma_Explicit_Overriding | 897 Pragma_Export | 898 Pragma_Export_Exception | 899 Pragma_Export_Function | 900 Pragma_Export_Object | 901 Pragma_Export_Procedure | 902 Pragma_Export_Value | 903 Pragma_Export_Valued_Procedure | 904 Pragma_Extend_System | 905 Pragma_External | 906 Pragma_External_Name_Casing | 907 Pragma_Finalize_Storage_Only | 908 Pragma_Float_Representation | 909 Pragma_Ident | 910 Pragma_Import | 911 Pragma_Import_Exception | 912 Pragma_Import_Function | 913 Pragma_Import_Object | 914 Pragma_Import_Procedure | 915 Pragma_Import_Valued_Procedure | 916 Pragma_Initialize_Scalars | 917 Pragma_Inline | 918 Pragma_Inline_Always | 919 Pragma_Inline_Generic | 920 Pragma_Inspection_Point | 921 Pragma_Interface | 922 Pragma_Interface_Name | 923 Pragma_Interrupt_Handler | 924 Pragma_Interrupt_State | 925 Pragma_Interrupt_Priority | 926 Pragma_Java_Constructor | 927 Pragma_Java_Interface | 928 Pragma_Keep_Names | 929 Pragma_License | 930 Pragma_Link_With | 931 Pragma_Linker_Alias | 932 Pragma_Linker_Options | 933 Pragma_Linker_Section | 934 Pragma_Locking_Policy | 935 Pragma_Long_Float | 936 Pragma_Machine_Attribute | 937 Pragma_Main | 938 Pragma_Main_Storage | 939 Pragma_Memory_Size | 940 Pragma_No_Return | 941 Pragma_Obsolescent | 942 Pragma_No_Run_Time | 943 Pragma_Normalize_Scalars | 944 Pragma_Optimize | 945 Pragma_Optional_Overriding | 946 Pragma_Overriding | 947 Pragma_Pack | 948 Pragma_Passive | 949 Pragma_Polling | 950 Pragma_Persistent_Data | 951 Pragma_Persistent_Object | 952 Pragma_Preelaborate | 953 Pragma_Priority | 954 Pragma_Propagate_Exceptions | 955 Pragma_Psect_Object | 956 Pragma_Pure | 957 Pragma_Pure_Function | 958 Pragma_Queuing_Policy | 959 Pragma_Remote_Call_Interface | 960 Pragma_Remote_Types | 961 Pragma_Restrictions | 962 Pragma_Restriction_Warnings | 963 Pragma_Restricted_Run_Time | 964 Pragma_Ravenscar | 965 Pragma_Reviewable | 966 Pragma_Share_Generic | 967 Pragma_Shared | 968 Pragma_Shared_Passive | 969 Pragma_Storage_Size | 970 Pragma_Storage_Unit | 971 Pragma_Stream_Convert | 972 Pragma_Subtitle | 973 Pragma_Suppress | 974 Pragma_Suppress_All | 975 Pragma_Suppress_Debug_Info | 976 Pragma_Suppress_Exception_Locations | 977 Pragma_Suppress_Initialization | 978 Pragma_System_Name | 979 Pragma_Task_Dispatching_Policy | 980 Pragma_Task_Info | 981 Pragma_Task_Name | 982 Pragma_Task_Storage | 983 Pragma_Thread_Body | 984 Pragma_Time_Slice | 985 Pragma_Title | 986 Pragma_Unchecked_Union | 987 Pragma_Unimplemented_Unit | 988 Pragma_Universal_Data | 989 Pragma_Unreferenced | 990 Pragma_Unreserve_All_Interrupts | 991 Pragma_Unsuppress | 992 Pragma_Use_VADS_Size | 993 Pragma_Volatile | 994 Pragma_Volatile_Components | 995 Pragma_Weak_External | 996 Pragma_Validity_Checks => 997 null; 998 999 -------------------- 1000 -- Unknown_Pragma -- 1001 -------------------- 1002 1003 -- Should be impossible, since we excluded this case earlier on 1004 1005 when Unknown_Pragma => 1006 raise Program_Error; 1007 1008 end case; 1009 1010 return Pragma_Node; 1011 1012 -------------------- 1013 -- Error Handling -- 1014 -------------------- 1015 1016exception 1017 when Error_Resync => 1018 return Error; 1019 1020end Prag; 1021