gcc/ada/par-prag.adb

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