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 --          Copyright (C) 1992-2002 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
  33 with Fname.UF; use Fname.UF;
  34 with Osint;    use Osint;
  35 with Stringt;  use Stringt;
  36 with Stylesw;  use Stylesw;
  37 with Uintp;    use Uintp;
  38 with Uname;    use Uname;
  39
  40 separate (Par)
  41
  42 function 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 an
  74    --  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
 203 begin
 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 (GNAT) --
 358       -----------------------------
 359
 360       --  There are five forms of this pragma:
 361
 362       --  pragma Source_File_Name (
 363       --    [UNIT_NAME      =>] unit_NAME,
 364       --     BODY_FILE_NAME =>  STRING_LITERAL);
 365
 366       --  pragma Source_File_Name (
 367       --    [UNIT_NAME      =>] unit_NAME,
 368       --     SPEC_FILE_NAME =>  STRING_LITERAL);
 369
 370       --  pragma Source_File_Name (
 371       --     BODY_FILE_NAME  => STRING_LITERAL
 372       --  [, DOT_REPLACEMENT => STRING_LITERAL]
 373       --  [, CASING          => CASING_SPEC]);
 374
 375       --  pragma Source_File_Name (
 376       --     SPEC_FILE_NAME  => STRING_LITERAL
 377       --  [, DOT_REPLACEMENT => STRING_LITERAL]
 378       --  [, CASING          => CASING_SPEC]);
 379
 380       --  pragma Source_File_Name (
 381       --     SUBUNIT_FILE_NAME  => STRING_LITERAL
 382       --  [, DOT_REPLACEMENT    => STRING_LITERAL]
 383       --  [, CASING             => CASING_SPEC]);
 384
 385       --  CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
 386
 387       --  Note: we process this during parsing, since we need to have the
 388       --  source file names set well before the semantic analysis starts,
 389       --  since we load the spec and with'ed packages before analysis.
 390
 391       when Pragma_Source_File_Name => Source_File_Name : declare
 392          Unam  : Unit_Name_Type;
 393          Expr1 : Node_Id;
 394          Pat   : String_Ptr;
 395          Typ   : Character;
 396          Dot   : String_Ptr;
 397          Cas   : Casing_Type;
 398          Nast  : Nat;
 399
 400          function Get_Fname (Arg : Node_Id) return Name_Id;
 401          --  Process file name from unit name form of pragma
 402
 403          function Get_String_Argument (Arg : Node_Id) return String_Ptr;
 404          --  Process string literal value from argument
 405
 406          procedure Process_Casing (Arg : Node_Id);
 407          --  Process Casing argument of pattern form of pragma
 408
 409          procedure Process_Dot_Replacement (Arg : Node_Id);
 410          --  Process Dot_Replacement argument of patterm form of pragma
 411
 412          ---------------
 413          -- Get_Fname --
 414          ---------------
 415
 416          function Get_Fname (Arg : Node_Id) return Name_Id is
 417          begin
 418             String_To_Name_Buffer (Strval (Expression (Arg)));
 419
 420             for J in 1 .. Name_Len loop
 421                if Is_Directory_Separator (Name_Buffer (J)) then
 422                   Error_Msg
 423                     ("directory separator character not allowed",
 424                      Sloc (Expression (Arg)) + Source_Ptr (J));
 425                end if;
 426             end loop;
 427
 428             return Name_Find;
 429          end Get_Fname;
 430
 431          -------------------------
 432          -- Get_String_Argument --
 433          -------------------------
 434
 435          function Get_String_Argument (Arg : Node_Id) return String_Ptr is
 436             Str : String_Id;
 437
 438          begin
 439             if Nkind (Expression (Arg)) /= N_String_Literal
 440               and then
 441                Nkind (Expression (Arg)) /= N_Operator_Symbol
 442             then
 443                Error_Msg_N
 444                  ("argument for pragma% must be string literal", Arg);
 445                raise Error_Resync;
 446             end if;
 447
 448             Str := Strval (Expression (Arg));
 449
 450             --  Check string has no wide chars
 451
 452             for J in 1 .. String_Length (Str) loop
 453                if Get_String_Char (Str, J) > 255 then
 454                   Error_Msg
 455                     ("wide character not allowed in pattern for pragma%",
 456                      Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);
 457                end if;
 458             end loop;
 459
 460             --  Acquire string
 461
 462             String_To_Name_Buffer (Str);
 463             return new String'(Name_Buffer (1 .. Name_Len));
 464          end Get_String_Argument;
 465
 466          --------------------
 467          -- Process_Casing --
 468          --------------------
 469
 470          procedure Process_Casing (Arg : Node_Id) is
 471             Expr : constant Node_Id := Expression (Arg);
 472
 473          begin
 474             Check_Required_Identifier (Arg, Name_Casing);
 475
 476             if Nkind (Expr) = N_Identifier then
 477                if Chars (Expr) = Name_Lowercase then
 478                   Cas := All_Lower_Case;
 479                   return;
 480                elsif Chars (Expr) = Name_Uppercase then
 481                   Cas := All_Upper_Case;
 482                   return;
 483                elsif Chars (Expr) = Name_Mixedcase then
 484                   Cas := Mixed_Case;
 485                   return;
 486                end if;
 487             end if;
 488
 489             Error_Msg_N
 490               ("Casing argument for pragma% must be " &
 491                "one of Mixedcase, Lowercase, Uppercase",
 492                Arg);
 493          end Process_Casing;
 494
 495          -----------------------------
 496          -- Process_Dot_Replacement --
 497          -----------------------------
 498
 499          procedure Process_Dot_Replacement (Arg : Node_Id) is
 500          begin
 501             Check_Required_Identifier (Arg, Name_Dot_Replacement);
 502             Dot := Get_String_Argument (Arg);
 503          end Process_Dot_Replacement;
 504
 505       --  Start of processing for Source_File_Name pragma
 506
 507       begin
 508          --  We permit from 1 to 3 arguments
 509
 510          if Arg_Count not in 1 .. 3 then
 511             Check_Arg_Count (1);
 512          end if;
 513
 514          Expr1 := Expression (Arg1);
 515
 516          --  If first argument is identifier or selected component, then
 517          --  we have the specific file case of the Source_File_Name pragma,
 518          --  and the first argument is a unit name.
 519
 520          if Nkind (Expr1) = N_Identifier
 521            or else
 522              (Nkind (Expr1) = N_Selected_Component
 523                and then
 524               Nkind (Selector_Name (Expr1)) = N_Identifier)
 525          then
 526             if Nkind (Expr1) = N_Identifier
 527               and then Chars (Expr1) = Name_System
 528             then
 529                Error_Msg_N
 530                  ("pragma Source_File_Name may not be used for System", Arg1);
 531                return Error;
 532             end if;
 533
 534             Check_Arg_Count (2);
 535
 536             Check_Optional_Identifier (Arg1, Name_Unit_Name);
 537             Unam := Get_Unit_Name (Expr1);
 538
 539             Check_Arg_Is_String_Literal (Arg2);
 540
 541             if Chars (Arg2) = Name_Spec_File_Name then
 542                Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2));
 543
 544             elsif Chars (Arg2) = Name_Body_File_Name then
 545                Set_File_Name (Unam, Get_Fname (Arg2));
 546
 547             else
 548                Error_Msg_N ("pragma% argument has incorrect identifier", Arg2);
 549                return Pragma_Node;
 550             end if;
 551
 552          --  If the first argument is not an identifier, then we must have
 553          --  the pattern form of the pragma, and the first argument must be
 554          --  the pattern string with an appropriate name.
 555
 556          else
 557             if Chars (Arg1) = Name_Spec_File_Name then
 558                Typ := 's';
 559
 560             elsif Chars (Arg1) = Name_Body_File_Name then
 561                Typ := 'b';
 562
 563             elsif Chars (Arg1) = Name_Subunit_File_Name then
 564                Typ := 'u';
 565
 566             elsif Chars (Arg1) = Name_Unit_Name then
 567                Error_Msg_N
 568                  ("Unit_Name parameter for pragma% must be an identifier",
 569                   Arg1);
 570                raise Error_Resync;
 571
 572             else
 573                Error_Msg_N ("pragma% argument has incorrect identifier", Arg1);
 574                raise Error_Resync;
 575             end if;
 576
 577             Pat := Get_String_Argument (Arg1);
 578
 579             --  Check pattern has exactly one asterisk
 580
 581             Nast := 0;
 582             for J in Pat'Range loop
 583                if Pat (J) = '*' then
 584                   Nast := Nast + 1;
 585                end if;
 586             end loop;
 587
 588             if Nast /= 1 then
 589                Error_Msg_N
 590                  ("file name pattern must have exactly one * character",
 591                   Arg2);
 592                return Pragma_Node;
 593             end if;
 594
 595             --  Set defaults for Casing and Dot_Separator parameters
 596
 597             Cas := All_Lower_Case;
 598
 599             Dot := new String'(".");
 600
 601             --  Process second and third arguments if present
 602
 603             if Arg_Count > 1 then
 604                if Chars (Arg2) = Name_Casing then
 605                   Process_Casing (Arg2);
 606
 607                   if Arg_Count = 3 then
 608                      Process_Dot_Replacement (Arg3);
 609                   end if;
 610
 611                else
 612                   Process_Dot_Replacement (Arg2);
 613
 614                   if Arg_Count = 3 then
 615                      Process_Casing (Arg3);
 616                   end if;
 617                end if;
 618             end if;
 619
 620             Set_File_Name_Pattern (Pat, Typ, Dot, Cas);
 621          end if;
 622       end Source_File_Name;
 623
 624       -----------------------------
 625       -- Source_Reference (GNAT) --
 626       -----------------------------
 627
 628       --  pragma Source_Reference
 629       --    (INTEGER_LITERAL [, STRING_LITERAL] );
 630
 631       --  Processing for this pragma must be done at parse time, since error
 632       --  messages needing the proper line numbers can be generated in parse
 633       --  only mode with semantic checking turned off, and indeed we usually
 634       --  turn off semantic checking anyway if any parse errors are found.
 635
 636       when Pragma_Source_Reference => Source_Reference : declare
 637          Fname : Name_Id;
 638
 639       begin
 640          if Arg_Count /= 1 then
 641             Check_Arg_Count (2);
 642             Check_No_Identifier (Arg2);
 643          end if;
 644
 645          --  Check that this is first line of file. We skip this test if
 646          --  we are in syntax check only mode, since we may be dealing with
 647          --  multiple compilation units.
 648
 649          if Get_Physical_Line_Number (Pragma_Sloc) /= 1
 650            and then Num_SRef_Pragmas (Current_Source_File) = 0
 651            and then Operating_Mode /= Check_Syntax
 652          then
 653             Error_Msg
 654               ("first % pragma must be first line of file", Pragma_Sloc);
 655             raise Error_Resync;
 656          end if;
 657
 658          Check_No_Identifier (Arg1);
 659
 660          if Arg_Count = 1 then
 661             if Num_SRef_Pragmas (Current_Source_File) = 0 then
 662                Error_Msg
 663                  ("file name required for first % pragma in file",
 664                   Pragma_Sloc);
 665                raise Error_Resync;
 666
 667             else
 668                Fname := No_Name;
 669             end if;
 670
 671          --  File name present
 672
 673          else
 674             Check_Arg_Is_String_Literal (Arg2);
 675             String_To_Name_Buffer (Strval (Expression (Arg2)));
 676             Fname := Name_Find;
 677
 678             if Num_SRef_Pragmas (Current_Source_File) > 0 then
 679                if Fname /= Full_Ref_Name (Current_Source_File) then
 680                   Error_Msg
 681                     ("file name must be same in all % pragmas", Pragma_Sloc);
 682                   raise Error_Resync;
 683                end if;
 684             end if;
 685          end if;
 686
 687          if Nkind (Expression (Arg1)) /= N_Integer_Literal then
 688             Error_Msg
 689               ("argument for pragma% must be integer literal",
 690                 Sloc (Expression (Arg1)));
 691             raise Error_Resync;
 692
 693          --  OK, this source reference pragma is effective, however, we
 694          --  ignore it if it is not in the first unit in the multiple unit
 695          --  case. This is because the only purpose in this case is to
 696          --  provide source pragmas for subsequent use by gnatchop.
 697
 698          else
 699             if Num_Library_Units = 1 then
 700                Register_Source_Ref_Pragma
 701                  (Fname,
 702                   Strip_Directory (Fname),
 703                   UI_To_Int (Intval (Expression (Arg1))),
 704                   Get_Physical_Line_Number (Pragma_Sloc) + 1);
 705             end if;
 706          end if;
 707       end Source_Reference;
 708
 709       -------------------------
 710       -- Style_Checks (GNAT) --
 711       -------------------------
 712
 713       --  pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
 714
 715       --  This is processed by the parser since some of the style
 716       --  checks take place during source scanning and parsing.
 717
 718       when Pragma_Style_Checks => Style_Checks : declare
 719          A  : Node_Id;
 720          S  : String_Id;
 721          C  : Char_Code;
 722          OK : Boolean := True;
 723
 724       begin
 725          --  Two argument case is only for semantics
 726
 727          if Arg_Count = 2 then
 728             null;
 729
 730          else
 731             Check_Arg_Count (1);
 732             Check_No_Identifier (Arg1);
 733             A := Expression (Arg1);
 734
 735             if Nkind (A) = N_String_Literal then
 736                S   := Strval (A);
 737
 738                declare
 739                   Slen    : Natural := Natural (String_Length (S));
 740                   Options : String (1 .. Slen);
 741                   J       : Natural;
 742                   Ptr     : Natural;
 743
 744                begin
 745                   J := 1;
 746                   loop
 747                      C := Get_String_Char (S, Int (J));
 748
 749                      if not In_Character_Range (C) then
 750                         OK := False;
 751                         Ptr := J;
 752                         exit;
 753
 754                      else
 755                         Options (J) := Get_Character (C);
 756                      end if;
 757
 758                      if J = Slen then
 759                         Set_Style_Check_Options (Options, OK, Ptr);
 760                         exit;
 761
 762                      else
 763                         J := J + 1;
 764                      end if;
 765                   end loop;
 766
 767                   if not OK then
 768                      Error_Msg
 769                        ("invalid style check option",
 770                         Sloc (Expression (Arg1)) + Source_Ptr (Ptr));
 771                      raise Error_Resync;
 772                   end if;
 773                end;
 774
 775             elsif Nkind (A) /= N_Identifier then
 776                OK := False;
 777
 778             elsif Chars (A) = Name_All_Checks then
 779                Stylesw.Set_Default_Style_Check_Options;
 780
 781             elsif Chars (A) = Name_On then
 782                Style_Check := True;
 783
 784             elsif Chars (A) = Name_Off then
 785                Style_Check := False;
 786
 787             else
 788                OK := False;
 789             end if;
 790
 791             if not OK then
 792                Error_Msg ("incorrect argument for pragma%", Sloc (A));
 793                raise Error_Resync;
 794             end if;
 795          end if;
 796       end Style_Checks;
 797
 798       ---------------------
 799       -- Warnings (GNAT) --
 800       ---------------------
 801
 802       --  pragma Warnings (On | Off, [LOCAL_NAME])
 803
 804       --  The one argument case is processed by the parser, since it may
 805       --  control parser warnings as well as semantic warnings, and in any
 806       --  case we want to be absolutely sure that the range in the warnings
 807       --  table is set well before any semantic analysis is performed.
 808
 809       when Pragma_Warnings =>
 810          if Arg_Count = 1 then
 811             Check_No_Identifier (Arg1);
 812             Check_Arg_Is_On_Or_Off (Arg1);
 813
 814             if Chars (Expression (Arg1)) = Name_On then
 815                Set_Warnings_Mode_On (Pragma_Sloc);
 816             else
 817                Set_Warnings_Mode_Off (Pragma_Sloc);
 818             end if;
 819          end if;
 820
 821       -----------------------
 822       -- All Other Pragmas --
 823       -----------------------
 824
 825       --  For all other pragmas, checking and processing is handled
 826       --  entirely in Sem_Prag, and no further checking is done by Par.
 827
 828       when Pragma_Abort_Defer              |
 829            Pragma_AST_Entry                |
 830            Pragma_All_Calls_Remote         |
 831            Pragma_Annotate                 |
 832            Pragma_Assert                   |
 833            Pragma_Asynchronous             |
 834            Pragma_Atomic                   |
 835            Pragma_Atomic_Components        |
 836            Pragma_Attach_Handler           |
 837            Pragma_Convention_Identifier    |
 838            Pragma_CPP_Class                |
 839            Pragma_CPP_Constructor          |
 840            Pragma_CPP_Virtual              |
 841            Pragma_CPP_Vtable               |
 842            Pragma_C_Pass_By_Copy           |
 843            Pragma_Comment                  |
 844            Pragma_Common_Object            |
 845            Pragma_Complex_Representation   |
 846            Pragma_Component_Alignment      |
 847            Pragma_Controlled               |
 848            Pragma_Convention               |
 849            Pragma_Discard_Names            |
 850            Pragma_Eliminate                |
 851            Pragma_Elaborate                |
 852            Pragma_Elaborate_All            |
 853            Pragma_Elaborate_Body           |
 854            Pragma_Elaboration_Checks       |
 855            Pragma_Export                   |
 856            Pragma_Export_Exception         |
 857            Pragma_Export_Function          |
 858            Pragma_Export_Object            |
 859            Pragma_Export_Procedure         |
 860            Pragma_Export_Valued_Procedure  |
 861            Pragma_Extend_System            |
 862            Pragma_External                 |
 863            Pragma_External_Name_Casing     |
 864            Pragma_Finalize_Storage_Only    |
 865            Pragma_Float_Representation     |
 866            Pragma_Ident                    |
 867            Pragma_Import                   |
 868            Pragma_Import_Exception         |
 869            Pragma_Import_Function          |
 870            Pragma_Import_Object            |
 871            Pragma_Import_Procedure         |
 872            Pragma_Import_Valued_Procedure  |
 873            Pragma_Initialize_Scalars       |
 874            Pragma_Inline                   |
 875            Pragma_Inline_Always            |
 876            Pragma_Inline_Generic           |
 877            Pragma_Inspection_Point         |
 878            Pragma_Interface                |
 879            Pragma_Interface_Name           |
 880            Pragma_Interrupt_Handler        |
 881            Pragma_Interrupt_Priority       |
 882            Pragma_Java_Constructor         |
 883            Pragma_Java_Interface           |
 884            Pragma_License                  |
 885            Pragma_Link_With                |
 886            Pragma_Linker_Alias             |
 887            Pragma_Linker_Options           |
 888            Pragma_Linker_Section           |
 889            Pragma_Locking_Policy           |
 890            Pragma_Long_Float               |
 891            Pragma_Machine_Attribute        |
 892            Pragma_Main                     |
 893            Pragma_Main_Storage             |
 894            Pragma_Memory_Size              |
 895            Pragma_No_Return                |
 896            Pragma_No_Run_Time              |
 897            Pragma_Normalize_Scalars        |
 898            Pragma_Optimize                 |
 899            Pragma_Pack                     |
 900            Pragma_Passive                  |
 901            Pragma_Polling                  |
 902            Pragma_Preelaborate             |
 903            Pragma_Priority                 |
 904            Pragma_Propagate_Exceptions     |
 905            Pragma_Psect_Object             |
 906            Pragma_Pure                     |
 907            Pragma_Pure_Function            |
 908            Pragma_Queuing_Policy           |
 909            Pragma_Remote_Call_Interface    |
 910            Pragma_Remote_Types             |
 911            Pragma_Restrictions             |
 912            Pragma_Restricted_Run_Time      |
 913            Pragma_Ravenscar                |
 914            Pragma_Reviewable               |
 915            Pragma_Share_Generic            |
 916            Pragma_Shared                   |
 917            Pragma_Shared_Passive           |
 918            Pragma_Storage_Size             |
 919            Pragma_Storage_Unit             |
 920            Pragma_Stream_Convert           |
 921            Pragma_Subtitle                 |
 922            Pragma_Suppress                 |
 923            Pragma_Suppress_All             |
 924            Pragma_Suppress_Debug_Info      |
 925            Pragma_Suppress_Initialization  |
 926            Pragma_System_Name              |
 927            Pragma_Task_Dispatching_Policy  |
 928            Pragma_Task_Info                |
 929            Pragma_Task_Name                |
 930            Pragma_Task_Storage             |
 931            Pragma_Time_Slice               |
 932            Pragma_Title                    |
 933            Pragma_Unchecked_Union          |
 934            Pragma_Unimplemented_Unit       |
 935            Pragma_Universal_Data           |
 936            Pragma_Unreferenced             |
 937            Pragma_Unreserve_All_Interrupts |
 938            Pragma_Unsuppress               |
 939            Pragma_Use_VADS_Size            |
 940            Pragma_Volatile                 |
 941            Pragma_Volatile_Components      |
 942            Pragma_Weak_External            |
 943            Pragma_Validity_Checks          =>
 944          null;
 945
 946    end case;
 947
 948    return Pragma_Node;
 949
 950    --------------------
 951    -- Error Handling --
 952    --------------------
 953
 954 exception
 955    when Error_Resync =>
 956       return Error;
 957
 958 end Prag;