OSDN Git Service

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