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