OSDN Git Service

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