OSDN Git Service

2011-12-22 Vincent Pucci <pucci@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / sem_prag.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                             S E M _ P R A G                              --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2011, 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 --  This unit contains the semantic processing for all pragmas, both language
27 --  and implementation defined. For most pragmas, the parser only does the
28 --  most basic job of checking the syntax, so Sem_Prag also contains the code
29 --  to complete the syntax checks. Certain pragmas are handled partially or
30 --  completely by the parser (see Par.Prag for further details).
31
32 with Aspects;  use Aspects;
33 with Atree;    use Atree;
34 with Casing;   use Casing;
35 with Checks;   use Checks;
36 with Csets;    use Csets;
37 with Debug;    use Debug;
38 with Einfo;    use Einfo;
39 with Elists;   use Elists;
40 with Errout;   use Errout;
41 with Exp_Dist; use Exp_Dist;
42 with Exp_Util; use Exp_Util;
43 with Freeze;   use Freeze;
44 with Lib;      use Lib;
45 with Lib.Writ; use Lib.Writ;
46 with Lib.Xref; use Lib.Xref;
47 with Namet.Sp; use Namet.Sp;
48 with Nlists;   use Nlists;
49 with Nmake;    use Nmake;
50 with Opt;      use Opt;
51 with Output;   use Output;
52 with Par_SCO;  use Par_SCO;
53 with Restrict; use Restrict;
54 with Rident;   use Rident;
55 with Rtsfind;  use Rtsfind;
56 with Sem;      use Sem;
57 with Sem_Aux;  use Sem_Aux;
58 with Sem_Ch3;  use Sem_Ch3;
59 with Sem_Ch6;  use Sem_Ch6;
60 with Sem_Ch8;  use Sem_Ch8;
61 with Sem_Ch12; use Sem_Ch12;
62 with Sem_Ch13; use Sem_Ch13;
63 with Sem_Disp; use Sem_Disp;
64 with Sem_Dist; use Sem_Dist;
65 with Sem_Elim; use Sem_Elim;
66 with Sem_Eval; use Sem_Eval;
67 with Sem_Intr; use Sem_Intr;
68 with Sem_Mech; use Sem_Mech;
69 with Sem_Res;  use Sem_Res;
70 with Sem_Type; use Sem_Type;
71 with Sem_Util; use Sem_Util;
72 with Sem_VFpt; use Sem_VFpt;
73 with Sem_Warn; use Sem_Warn;
74 with Stand;    use Stand;
75 with Sinfo;    use Sinfo;
76 with Sinfo.CN; use Sinfo.CN;
77 with Sinput;   use Sinput;
78 with Snames;   use Snames;
79 with Stringt;  use Stringt;
80 with Stylesw;  use Stylesw;
81 with Table;
82 with Targparm; use Targparm;
83 with Tbuild;   use Tbuild;
84 with Ttypes;
85 with Uintp;    use Uintp;
86 with Uname;    use Uname;
87 with Urealp;   use Urealp;
88 with Validsw;  use Validsw;
89 with Warnsw;   use Warnsw;
90
91 package body Sem_Prag is
92
93    ----------------------------------------------
94    -- Common Handling of Import-Export Pragmas --
95    ----------------------------------------------
96
97    --  In the following section, a number of Import_xxx and Export_xxx pragmas
98    --  are defined by GNAT. These are compatible with the DEC pragmas of the
99    --  same name, and all have the following common form and processing:
100
101    --  pragma Export_xxx
102    --        [Internal                 =>] LOCAL_NAME
103    --     [, [External                 =>] EXTERNAL_SYMBOL]
104    --     [, other optional parameters   ]);
105
106    --  pragma Import_xxx
107    --        [Internal                 =>] LOCAL_NAME
108    --     [, [External                 =>] EXTERNAL_SYMBOL]
109    --     [, other optional parameters   ]);
110
111    --   EXTERNAL_SYMBOL ::=
112    --     IDENTIFIER
113    --   | static_string_EXPRESSION
114
115    --  The internal LOCAL_NAME designates the entity that is imported or
116    --  exported, and must refer to an entity in the current declarative
117    --  part (as required by the rules for LOCAL_NAME).
118
119    --  The external linker name is designated by the External parameter if
120    --  given, or the Internal parameter if not (if there is no External
121    --  parameter, the External parameter is a copy of the Internal name).
122
123    --  If the External parameter is given as a string, then this string is
124    --  treated as an external name (exactly as though it had been given as an
125    --  External_Name parameter for a normal Import pragma).
126
127    --  If the External parameter is given as an identifier (or there is no
128    --  External parameter, so that the Internal identifier is used), then
129    --  the external name is the characters of the identifier, translated
130    --  to all upper case letters for OpenVMS versions of GNAT, and to all
131    --  lower case letters for all other versions
132
133    --  Note: the external name specified or implied by any of these special
134    --  Import_xxx or Export_xxx pragmas override an external or link name
135    --  specified in a previous Import or Export pragma.
136
137    --  Note: these and all other DEC-compatible GNAT pragmas allow full use of
138    --  named notation, following the standard rules for subprogram calls, i.e.
139    --  parameters can be given in any order if named notation is used, and
140    --  positional and named notation can be mixed, subject to the rule that all
141    --  positional parameters must appear first.
142
143    --  Note: All these pragmas are implemented exactly following the DEC design
144    --  and implementation and are intended to be fully compatible with the use
145    --  of these pragmas in the DEC Ada compiler.
146
147    --------------------------------------------
148    -- Checking for Duplicated External Names --
149    --------------------------------------------
150
151    --  It is suspicious if two separate Export pragmas use the same external
152    --  name. The following table is used to diagnose this situation so that
153    --  an appropriate warning can be issued.
154
155    --  The Node_Id stored is for the N_String_Literal node created to hold
156    --  the value of the external name. The Sloc of this node is used to
157    --  cross-reference the location of the duplication.
158
159    package Externals is new Table.Table (
160      Table_Component_Type => Node_Id,
161      Table_Index_Type     => Int,
162      Table_Low_Bound      => 0,
163      Table_Initial        => 100,
164      Table_Increment      => 100,
165      Table_Name           => "Name_Externals");
166
167    -------------------------------------
168    -- Local Subprograms and Variables --
169    -------------------------------------
170
171    function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
172    --  This routine is used for possible casing adjustment of an explicit
173    --  external name supplied as a string literal (the node N), according to
174    --  the casing requirement of Opt.External_Name_Casing. If this is set to
175    --  As_Is, then the string literal is returned unchanged, but if it is set
176    --  to Uppercase or Lowercase, then a new string literal with appropriate
177    --  casing is constructed.
178
179    function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
180    --  If Def_Id refers to a renamed subprogram, then the base subprogram (the
181    --  original one, following the renaming chain) is returned. Otherwise the
182    --  entity is returned unchanged. Should be in Einfo???
183
184    procedure Preanalyze_TC_Args (N, Arg_Req, Arg_Ens : Node_Id);
185    --  Preanalyze the boolean expressions in the Requires and Ensures arguments
186    --  of a Test_Case pragma if present (possibly Empty). We treat these as
187    --  spec expressions (i.e. similar to a default expression).
188
189    procedure rv;
190    --  This is a dummy function called by the processing for pragma Reviewable.
191    --  It is there for assisting front end debugging. By placing a Reviewable
192    --  pragma in the source program, a breakpoint on rv catches this place in
193    --  the source, allowing convenient stepping to the point of interest.
194
195    procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
196    --  Place semantic information on the argument of an Elaborate/Elaborate_All
197    --  pragma. Entity name for unit and its parents is taken from item in
198    --  previous with_clause that mentions the unit.
199
200    -------------------------------
201    -- Adjust_External_Name_Case --
202    -------------------------------
203
204    function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
205       CC : Char_Code;
206
207    begin
208       --  Adjust case of literal if required
209
210       if Opt.External_Name_Exp_Casing = As_Is then
211          return N;
212
213       else
214          --  Copy existing string
215
216          Start_String;
217
218          --  Set proper casing
219
220          for J in 1 .. String_Length (Strval (N)) loop
221             CC := Get_String_Char (Strval (N), J);
222
223             if Opt.External_Name_Exp_Casing = Uppercase
224               and then CC >= Get_Char_Code ('a')
225               and then CC <= Get_Char_Code ('z')
226             then
227                Store_String_Char (CC - 32);
228
229             elsif Opt.External_Name_Exp_Casing = Lowercase
230               and then CC >= Get_Char_Code ('A')
231               and then CC <= Get_Char_Code ('Z')
232             then
233                Store_String_Char (CC + 32);
234
235             else
236                Store_String_Char (CC);
237             end if;
238          end loop;
239
240          return
241            Make_String_Literal (Sloc (N),
242              Strval => End_String);
243       end if;
244    end Adjust_External_Name_Case;
245
246    ------------------------------
247    -- Analyze_PPC_In_Decl_Part --
248    ------------------------------
249
250    procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
251       Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
252
253    begin
254       --  Install formals and push subprogram spec onto scope stack so that we
255       --  can see the formals from the pragma.
256
257       Install_Formals (S);
258       Push_Scope (S);
259
260       --  Preanalyze the boolean expression, we treat this as a spec expression
261       --  (i.e. similar to a default expression).
262
263       Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean);
264
265       --  In ASIS mode, for a pragma generated from a source aspect, also
266       --  analyze the original aspect expression.
267
268       if ASIS_Mode
269         and then Present (Corresponding_Aspect (N))
270       then
271          Preanalyze_Spec_Expression
272            (Expression (Corresponding_Aspect (N)), Standard_Boolean);
273       end if;
274
275       --  For a class-wide condition, a reference to a controlling formal must
276       --  be interpreted as having the class-wide type (or an access to such)
277       --  so that the inherited condition can be properly applied to any
278       --  overriding operation (see ARM12 6.6.1 (7)).
279
280       if Class_Present (N) then
281          declare
282             T   : constant Entity_Id := Find_Dispatching_Type (S);
283
284             ACW : Entity_Id := Empty;
285             --  Access to T'class, created if there is a controlling formal
286             --  that is an access parameter.
287
288             function Get_ACW return Entity_Id;
289             --  If the expression has a reference to an controlling access
290             --  parameter, create an access to T'class for the necessary
291             --  conversions if one does not exist.
292
293             function Process (N : Node_Id) return Traverse_Result;
294             --  ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
295             --  aspect for a primitive subprogram of a tagged type T, a name
296             --  that denotes a formal parameter of type T is interpreted as
297             --  having type T'Class. Similarly, a name that denotes a formal
298             --  accessparameter of type access-to-T is interpreted as having
299             --  type access-to-T'Class. This ensures the expression is well-
300             --  defined for a primitive subprogram of a type descended from T.
301
302             -------------
303             -- Get_ACW --
304             -------------
305
306             function Get_ACW return Entity_Id is
307                Loc  : constant Source_Ptr := Sloc (N);
308                Decl : Node_Id;
309
310             begin
311                if No (ACW) then
312                   Decl := Make_Full_Type_Declaration (Loc,
313                     Defining_Identifier => Make_Temporary (Loc, 'T'),
314                     Type_Definition =>
315                        Make_Access_To_Object_Definition (Loc,
316                        Subtype_Indication =>
317                          New_Occurrence_Of (Class_Wide_Type (T), Loc),
318                        All_Present => True));
319
320                   Insert_Before (Unit_Declaration_Node (S), Decl);
321                   Analyze (Decl);
322                   ACW := Defining_Identifier (Decl);
323                   Freeze_Before (Unit_Declaration_Node (S), ACW);
324                end if;
325
326                return ACW;
327             end Get_ACW;
328
329             -------------
330             -- Process --
331             -------------
332
333             function Process (N : Node_Id) return Traverse_Result is
334                Loc : constant Source_Ptr := Sloc (N);
335                Typ : Entity_Id;
336
337             begin
338                if Is_Entity_Name (N)
339                  and then Is_Formal (Entity (N))
340                  and then Nkind (Parent (N)) /= N_Type_Conversion
341                then
342                   if Etype (Entity (N)) = T then
343                      Typ := Class_Wide_Type (T);
344
345                   elsif Is_Access_Type (Etype (Entity (N)))
346                     and then Designated_Type (Etype (Entity (N))) = T
347                   then
348                      Typ := Get_ACW;
349                   else
350                      Typ := Empty;
351                   end if;
352
353                   if Present (Typ) then
354                      Rewrite (N,
355                        Make_Type_Conversion (Loc,
356                          Subtype_Mark =>
357                            New_Occurrence_Of (Typ, Loc),
358                          Expression  => New_Occurrence_Of (Entity (N), Loc)));
359                      Set_Etype (N, Typ);
360                   end if;
361                end if;
362
363                return OK;
364             end Process;
365
366             procedure Replace_Type is new Traverse_Proc (Process);
367
368          begin
369             Replace_Type (Get_Pragma_Arg (Arg1));
370          end;
371       end if;
372
373       --  Remove the subprogram from the scope stack now that the pre-analysis
374       --  of the precondition/postcondition is done.
375
376       End_Scope;
377    end Analyze_PPC_In_Decl_Part;
378
379    --------------------
380    -- Analyze_Pragma --
381    --------------------
382
383    procedure Analyze_Pragma (N : Node_Id) is
384       Loc     : constant Source_Ptr := Sloc (N);
385       Prag_Id : Pragma_Id;
386
387       Pname : Name_Id;
388       --  Name of the source pragma, or name of the corresponding aspect for
389       --  pragmas which originate in a source aspect. In the latter case, the
390       --  name may be different from the pragma name.
391
392       Pragma_Exit : exception;
393       --  This exception is used to exit pragma processing completely. It is
394       --  used when an error is detected, and no further processing is
395       --  required. It is also used if an earlier error has left the tree in
396       --  a state where the pragma should not be processed.
397
398       Arg_Count : Nat;
399       --  Number of pragma argument associations
400
401       Arg1 : Node_Id;
402       Arg2 : Node_Id;
403       Arg3 : Node_Id;
404       Arg4 : Node_Id;
405       --  First four pragma arguments (pragma argument association nodes, or
406       --  Empty if the corresponding argument does not exist).
407
408       type Name_List is array (Natural range <>) of Name_Id;
409       type Args_List is array (Natural range <>) of Node_Id;
410       --  Types used for arguments to Check_Arg_Order and Gather_Associations
411
412       procedure Ada_2005_Pragma;
413       --  Called for pragmas defined in Ada 2005, that are not in Ada 95. In
414       --  Ada 95 mode, these are implementation defined pragmas, so should be
415       --  caught by the No_Implementation_Pragmas restriction.
416
417       procedure Ada_2012_Pragma;
418       --  Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
419       --  In Ada 95 or 05 mode, these are implementation defined pragmas, so
420       --  should be caught by the No_Implementation_Pragmas restriction.
421
422       procedure Check_Ada_83_Warning;
423       --  Issues a warning message for the current pragma if operating in Ada
424       --  83 mode (used for language pragmas that are not a standard part of
425       --  Ada 83). This procedure does not raise Error_Pragma. Also notes use
426       --  of 95 pragma.
427
428       procedure Check_Arg_Count (Required : Nat);
429       --  Check argument count for pragma is equal to given parameter. If not,
430       --  then issue an error message and raise Pragma_Exit.
431
432       --  Note: all routines whose name is Check_Arg_Is_xxx take an argument
433       --  Arg which can either be a pragma argument association, in which case
434       --  the check is applied to the expression of the association or an
435       --  expression directly.
436
437       procedure Check_Arg_Is_External_Name (Arg : Node_Id);
438       --  Check that an argument has the right form for an EXTERNAL_NAME
439       --  parameter of an extended import/export pragma. The rule is that the
440       --  name must be an identifier or string literal (in Ada 83 mode) or a
441       --  static string expression (in Ada 95 mode).
442
443       procedure Check_Arg_Is_Identifier (Arg : Node_Id);
444       --  Check the specified argument Arg to make sure that it is an
445       --  identifier. If not give error and raise Pragma_Exit.
446
447       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
448       --  Check the specified argument Arg to make sure that it is an integer
449       --  literal. If not give error and raise Pragma_Exit.
450
451       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
452       --  Check the specified argument Arg to make sure that it has the proper
453       --  syntactic form for a local name and meets the semantic requirements
454       --  for a local name. The local name is analyzed as part of the
455       --  processing for this call. In addition, the local name is required
456       --  to represent an entity at the library level.
457
458       procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
459       --  Check the specified argument Arg to make sure that it has the proper
460       --  syntactic form for a local name and meets the semantic requirements
461       --  for a local name. The local name is analyzed as part of the
462       --  processing for this call.
463
464       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
465       --  Check the specified argument Arg to make sure that it is a valid
466       --  locking policy name. If not give error and raise Pragma_Exit.
467
468       procedure Check_Arg_Is_One_Of
469         (Arg                : Node_Id;
470          N1, N2             : Name_Id);
471       procedure Check_Arg_Is_One_Of
472         (Arg                : Node_Id;
473          N1, N2, N3         : Name_Id);
474       procedure Check_Arg_Is_One_Of
475         (Arg                : Node_Id;
476          N1, N2, N3, N4, N5 : Name_Id);
477       --  Check the specified argument Arg to make sure that it is an
478       --  identifier whose name matches either N1 or N2 (or N3, N4, N5 if
479       --  present). If not then give error and raise Pragma_Exit.
480
481       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
482       --  Check the specified argument Arg to make sure that it is a valid
483       --  queuing policy name. If not give error and raise Pragma_Exit.
484
485       procedure Check_Arg_Is_Static_Expression
486         (Arg : Node_Id;
487          Typ : Entity_Id := Empty);
488       --  Check the specified argument Arg to make sure that it is a static
489       --  expression of the given type (i.e. it will be analyzed and resolved
490       --  using this type, which can be any valid argument to Resolve, e.g.
491       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
492       --  Typ is left Empty, then any static expression is allowed.
493
494       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
495       --  Check the specified argument Arg to make sure that it is a valid task
496       --  dispatching policy name. If not give error and raise Pragma_Exit.
497
498       procedure Check_Arg_Order (Names : Name_List);
499       --  Checks for an instance of two arguments with identifiers for the
500       --  current pragma which are not in the sequence indicated by Names,
501       --  and if so, generates a fatal message about bad order of arguments.
502
503       procedure Check_At_Least_N_Arguments (N : Nat);
504       --  Check there are at least N arguments present
505
506       procedure Check_At_Most_N_Arguments (N : Nat);
507       --  Check there are no more than N arguments present
508
509       procedure Check_Component
510         (Comp            : Node_Id;
511          UU_Typ          : Entity_Id;
512          In_Variant_Part : Boolean := False);
513       --  Examine an Unchecked_Union component for correct use of per-object
514       --  constrained subtypes, and for restrictions on finalizable components.
515       --  UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
516       --  should be set when Comp comes from a record variant.
517
518       procedure Check_Duplicate_Pragma (E : Entity_Id);
519       --  Check if a pragma of the same name as the current pragma is already
520       --  chained as a rep pragma to the given entity. If so give a message
521       --  about the duplicate, and then raise Pragma_Exit so does not return.
522       --  Also checks for delayed aspect specification node in the chain.
523
524       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
525       --  Nam is an N_String_Literal node containing the external name set by
526       --  an Import or Export pragma (or extended Import or Export pragma).
527       --  This procedure checks for possible duplications if this is the export
528       --  case, and if found, issues an appropriate error message.
529
530       procedure Check_Expr_Is_Static_Expression
531         (Expr : Node_Id;
532          Typ  : Entity_Id := Empty);
533       --  Check the specified expression Expr to make sure that it is a static
534       --  expression of the given type (i.e. it will be analyzed and resolved
535       --  using this type, which can be any valid argument to Resolve, e.g.
536       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
537       --  Typ is left Empty, then any static expression is allowed.
538
539       procedure Check_First_Subtype (Arg : Node_Id);
540       --  Checks that Arg, whose expression is an entity name, references a
541       --  first subtype.
542
543       procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
544       --  Checks that the given argument has an identifier, and if so, requires
545       --  it to match the given identifier name. If there is no identifier, or
546       --  a non-matching identifier, then an error message is given and
547       --  Pragma_Exit is raised.
548
549       procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
550       --  Checks that the given argument has an identifier, and if so, requires
551       --  it to match one of the given identifier names. If there is no
552       --  identifier, or a non-matching identifier, then an error message is
553       --  given and Pragma_Exit is raised.
554
555       procedure Check_In_Main_Program;
556       --  Common checks for pragmas that appear within a main program
557       --  (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
558
559       procedure Check_Interrupt_Or_Attach_Handler;
560       --  Common processing for first argument of pragma Interrupt_Handler or
561       --  pragma Attach_Handler.
562
563       procedure Check_Is_In_Decl_Part_Or_Package_Spec;
564       --  Check that pragma appears in a declarative part, or in a package
565       --  specification, i.e. that it does not occur in a statement sequence
566       --  in a body.
567
568       procedure Check_No_Identifier (Arg : Node_Id);
569       --  Checks that the given argument does not have an identifier. If
570       --  an identifier is present, then an error message is issued, and
571       --  Pragma_Exit is raised.
572
573       procedure Check_No_Identifiers;
574       --  Checks that none of the arguments to the pragma has an identifier.
575       --  If any argument has an identifier, then an error message is issued,
576       --  and Pragma_Exit is raised.
577
578       procedure Check_No_Link_Name;
579       --  Checks that no link name is specified
580
581       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
582       --  Checks if the given argument has an identifier, and if so, requires
583       --  it to match the given identifier name. If there is a non-matching
584       --  identifier, then an error message is given and Pragma_Exit is raised.
585
586       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
587       --  Checks if the given argument has an identifier, and if so, requires
588       --  it to match the given identifier name. If there is a non-matching
589       --  identifier, then an error message is given and Pragma_Exit is raised.
590       --  In this version of the procedure, the identifier name is given as
591       --  a string with lower case letters.
592
593       procedure Check_Precondition_Postcondition (In_Body : out Boolean);
594       --  Called to process a precondition or postcondition pragma. There are
595       --  three cases:
596       --
597       --    The pragma appears after a subprogram spec
598       --
599       --      If the corresponding check is not enabled, the pragma is analyzed
600       --      but otherwise ignored and control returns with In_Body set False.
601       --
602       --      If the check is enabled, then the first step is to analyze the
603       --      pragma, but this is skipped if the subprogram spec appears within
604       --      a package specification (because this is the case where we delay
605       --      analysis till the end of the spec). Then (whether or not it was
606       --      analyzed), the pragma is chained to the subprogram in question
607       --      (using Spec_PPC_List and Next_Pragma) and control returns to the
608       --      caller with In_Body set False.
609       --
610       --    The pragma appears at the start of subprogram body declarations
611       --
612       --      In this case an immediate return to the caller is made with
613       --      In_Body set True, and the pragma is NOT analyzed.
614       --
615       --    In all other cases, an error message for bad placement is given
616
617       procedure Check_Static_Constraint (Constr : Node_Id);
618       --  Constr is a constraint from an N_Subtype_Indication node from a
619       --  component constraint in an Unchecked_Union type. This routine checks
620       --  that the constraint is static as required by the restrictions for
621       --  Unchecked_Union.
622
623       procedure Check_Test_Case;
624       --  Called to process a test-case pragma. The treatment is similar to the
625       --  one for pre- and postcondition in Check_Precondition_Postcondition,
626       --  except the placement rules for the test-case pragma are stricter.
627       --  This pragma may only occur after a subprogram spec declared directly
628       --  in a package spec unit. In this case, the pragma is chained to the
629       --  subprogram in question (using Spec_TC_List and Next_Pragma) and
630       --  analysis of the pragma is delayed till the end of the spec. In
631       --  all other cases, an error message for bad placement is given.
632
633       procedure Check_Valid_Configuration_Pragma;
634       --  Legality checks for placement of a configuration pragma
635
636       procedure Check_Valid_Library_Unit_Pragma;
637       --  Legality checks for library unit pragmas. A special case arises for
638       --  pragmas in generic instances that come from copies of the original
639       --  library unit pragmas in the generic templates. In the case of other
640       --  than library level instantiations these can appear in contexts which
641       --  would normally be invalid (they only apply to the original template
642       --  and to library level instantiations), and they are simply ignored,
643       --  which is implemented by rewriting them as null statements.
644
645       procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
646       --  Check an Unchecked_Union variant for lack of nested variants and
647       --  presence of at least one component. UU_Typ is the related Unchecked_
648       --  Union type.
649
650       procedure Error_Pragma (Msg : String);
651       pragma No_Return (Error_Pragma);
652       --  Outputs error message for current pragma. The message contains a %
653       --  that will be replaced with the pragma name, and the flag is placed
654       --  on the pragma itself. Pragma_Exit is then raised.
655
656       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
657       pragma No_Return (Error_Pragma_Arg);
658       --  Outputs error message for current pragma. The message may contain
659       --  a % that will be replaced with the pragma name. The parameter Arg
660       --  may either be a pragma argument association, in which case the flag
661       --  is placed on the expression of this association, or an expression,
662       --  in which case the flag is placed directly on the expression. The
663       --  message is placed using Error_Msg_N, so the message may also contain
664       --  an & insertion character which will reference the given Arg value.
665       --  After placing the message, Pragma_Exit is raised.
666
667       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
668       pragma No_Return (Error_Pragma_Arg);
669       --  Similar to above form of Error_Pragma_Arg except that two messages
670       --  are provided, the second is a continuation comment starting with \.
671
672       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
673       pragma No_Return (Error_Pragma_Arg_Ident);
674       --  Outputs error message for current pragma. The message may contain
675       --  a % that will be replaced with the pragma name. The parameter Arg
676       --  must be a pragma argument association with a non-empty identifier
677       --  (i.e. its Chars field must be set), and the error message is placed
678       --  on the identifier. The message is placed using Error_Msg_N so
679       --  the message may also contain an & insertion character which will
680       --  reference the identifier. After placing the message, Pragma_Exit
681       --  is raised.
682
683       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
684       pragma No_Return (Error_Pragma_Ref);
685       --  Outputs error message for current pragma. The message may contain
686       --  a % that will be replaced with the pragma name. The parameter Ref
687       --  must be an entity whose name can be referenced by & and sloc by #.
688       --  After placing the message, Pragma_Exit is raised.
689
690       function Find_Lib_Unit_Name return Entity_Id;
691       --  Used for a library unit pragma to find the entity to which the
692       --  library unit pragma applies, returns the entity found.
693
694       procedure Find_Program_Unit_Name (Id : Node_Id);
695       --  If the pragma is a compilation unit pragma, the id must denote the
696       --  compilation unit in the same compilation, and the pragma must appear
697       --  in the list of preceding or trailing pragmas. If it is a program
698       --  unit pragma that is not a compilation unit pragma, then the
699       --  identifier must be visible.
700
701       function Find_Unique_Parameterless_Procedure
702         (Name : Entity_Id;
703          Arg  : Node_Id) return Entity_Id;
704       --  Used for a procedure pragma to find the unique parameterless
705       --  procedure identified by Name, returns it if it exists, otherwise
706       --  errors out and uses Arg as the pragma argument for the message.
707
708       procedure Fix_Error (Msg : in out String);
709       --  This is called prior to issuing an error message. Msg is a string
710       --  which typically contains the substring pragma. If the current pragma
711       --  comes from an aspect, each such "pragma" substring is replaced with
712       --  the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
713       --  (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
714
715       procedure Gather_Associations
716         (Names : Name_List;
717          Args  : out Args_List);
718       --  This procedure is used to gather the arguments for a pragma that
719       --  permits arbitrary ordering of parameters using the normal rules
720       --  for named and positional parameters. The Names argument is a list
721       --  of Name_Id values that corresponds to the allowed pragma argument
722       --  association identifiers in order. The result returned in Args is
723       --  a list of corresponding expressions that are the pragma arguments.
724       --  Note that this is a list of expressions, not of pragma argument
725       --  associations (Gather_Associations has completely checked all the
726       --  optional identifiers when it returns). An entry in Args is Empty
727       --  on return if the corresponding argument is not present.
728
729       procedure GNAT_Pragma;
730       --  Called for all GNAT defined pragmas to check the relevant restriction
731       --  (No_Implementation_Pragmas).
732
733       function Is_Before_First_Decl
734         (Pragma_Node : Node_Id;
735          Decls       : List_Id) return Boolean;
736       --  Return True if Pragma_Node is before the first declarative item in
737       --  Decls where Decls is the list of declarative items.
738
739       function Is_Configuration_Pragma return Boolean;
740       --  Determines if the placement of the current pragma is appropriate
741       --  for a configuration pragma.
742
743       function Is_In_Context_Clause return Boolean;
744       --  Returns True if pragma appears within the context clause of a unit,
745       --  and False for any other placement (does not generate any messages).
746
747       function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
748       --  Analyzes the argument, and determines if it is a static string
749       --  expression, returns True if so, False if non-static or not String.
750
751       procedure Pragma_Misplaced;
752       pragma No_Return (Pragma_Misplaced);
753       --  Issue fatal error message for misplaced pragma
754
755       procedure Process_Atomic_Shared_Volatile;
756       --  Common processing for pragmas Atomic, Shared, Volatile. Note that
757       --  Shared is an obsolete Ada 83 pragma, treated as being identical
758       --  in effect to pragma Atomic.
759
760       procedure Process_Compile_Time_Warning_Or_Error;
761       --  Common processing for Compile_Time_Error and Compile_Time_Warning
762
763       procedure Process_Convention
764         (C   : out Convention_Id;
765          Ent : out Entity_Id);
766       --  Common processing for Convention, Interface, Import and Export.
767       --  Checks first two arguments of pragma, and sets the appropriate
768       --  convention value in the specified entity or entities. On return
769       --  C is the convention, Ent is the referenced entity.
770
771       procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
772       --  Common processing for Disable/Enable_Atomic_Synchronization. Nam is
773       --  Name_Suppress for Disable and Name_Unsuppress for Enable.
774
775       procedure Process_Extended_Import_Export_Exception_Pragma
776         (Arg_Internal : Node_Id;
777          Arg_External : Node_Id;
778          Arg_Form     : Node_Id;
779          Arg_Code     : Node_Id);
780       --  Common processing for the pragmas Import/Export_Exception. The three
781       --  arguments correspond to the three named parameters of the pragma. An
782       --  argument is empty if the corresponding parameter is not present in
783       --  the pragma.
784
785       procedure Process_Extended_Import_Export_Object_Pragma
786         (Arg_Internal : Node_Id;
787          Arg_External : Node_Id;
788          Arg_Size     : Node_Id);
789       --  Common processing for the pragmas Import/Export_Object. The three
790       --  arguments correspond to the three named parameters of the pragmas. An
791       --  argument is empty if the corresponding parameter is not present in
792       --  the pragma.
793
794       procedure Process_Extended_Import_Export_Internal_Arg
795         (Arg_Internal : Node_Id := Empty);
796       --  Common processing for all extended Import and Export pragmas. The
797       --  argument is the pragma parameter for the Internal argument. If
798       --  Arg_Internal is empty or inappropriate, an error message is posted.
799       --  Otherwise, on normal return, the Entity_Field of Arg_Internal is
800       --  set to identify the referenced entity.
801
802       procedure Process_Extended_Import_Export_Subprogram_Pragma
803         (Arg_Internal                 : Node_Id;
804          Arg_External                 : Node_Id;
805          Arg_Parameter_Types          : Node_Id;
806          Arg_Result_Type              : Node_Id := Empty;
807          Arg_Mechanism                : Node_Id;
808          Arg_Result_Mechanism         : Node_Id := Empty;
809          Arg_First_Optional_Parameter : Node_Id := Empty);
810       --  Common processing for all extended Import and Export pragmas applying
811       --  to subprograms. The caller omits any arguments that do not apply to
812       --  the pragma in question (for example, Arg_Result_Type can be non-Empty
813       --  only in the Import_Function and Export_Function cases). The argument
814       --  names correspond to the allowed pragma association identifiers.
815
816       procedure Process_Generic_List;
817       --  Common processing for Share_Generic and Inline_Generic
818
819       procedure Process_Import_Or_Interface;
820       --  Common processing for Import of Interface
821
822       procedure Process_Import_Predefined_Type;
823       --  Processing for completing a type with pragma Import. This is used
824       --  to declare types that match predefined C types, especially for cases
825       --  without corresponding Ada predefined type.
826
827       procedure Process_Inline (Active : Boolean);
828       --  Common processing for Inline and Inline_Always. The parameter
829       --  indicates if the inline pragma is active, i.e. if it should actually
830       --  cause inlining to occur.
831
832       procedure Process_Interface_Name
833         (Subprogram_Def : Entity_Id;
834          Ext_Arg        : Node_Id;
835          Link_Arg       : Node_Id);
836       --  Given the last two arguments of pragma Import, pragma Export, or
837       --  pragma Interface_Name, performs validity checks and sets the
838       --  Interface_Name field of the given subprogram entity to the
839       --  appropriate external or link name, depending on the arguments given.
840       --  Ext_Arg is always present, but Link_Arg may be missing. Note that
841       --  Ext_Arg may represent the Link_Name if Link_Arg is missing, and
842       --  appropriate named notation is used for Ext_Arg. If neither Ext_Arg
843       --  nor Link_Arg is present, the interface name is set to the default
844       --  from the subprogram name.
845
846       procedure Process_Interrupt_Or_Attach_Handler;
847       --  Common processing for Interrupt and Attach_Handler pragmas
848
849       procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
850       --  Common processing for Restrictions and Restriction_Warnings pragmas.
851       --  Warn is True for Restriction_Warnings, or for Restrictions if the
852       --  flag Treat_Restrictions_As_Warnings is set, and False if this flag
853       --  is not set in the Restrictions case.
854
855       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
856       --  Common processing for Suppress and Unsuppress. The boolean parameter
857       --  Suppress_Case is True for the Suppress case, and False for the
858       --  Unsuppress case.
859
860       procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
861       --  This procedure sets the Is_Exported flag for the given entity,
862       --  checking that the entity was not previously imported. Arg is
863       --  the argument that specified the entity. A check is also made
864       --  for exporting inappropriate entities.
865
866       procedure Set_Extended_Import_Export_External_Name
867         (Internal_Ent : Entity_Id;
868          Arg_External : Node_Id);
869       --  Common processing for all extended import export pragmas. The first
870       --  argument, Internal_Ent, is the internal entity, which has already
871       --  been checked for validity by the caller. Arg_External is from the
872       --  Import or Export pragma, and may be null if no External parameter
873       --  was present. If Arg_External is present and is a non-null string
874       --  (a null string is treated as the default), then the Interface_Name
875       --  field of Internal_Ent is set appropriately.
876
877       procedure Set_Imported (E : Entity_Id);
878       --  This procedure sets the Is_Imported flag for the given entity,
879       --  checking that it is not previously exported or imported.
880
881       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
882       --  Mech is a parameter passing mechanism (see Import_Function syntax
883       --  for MECHANISM_NAME). This routine checks that the mechanism argument
884       --  has the right form, and if not issues an error message. If the
885       --  argument has the right form then the Mechanism field of Ent is
886       --  set appropriately.
887
888       procedure Set_Ravenscar_Profile (N : Node_Id);
889       --  Activate the set of configuration pragmas and restrictions that make
890       --  up the Ravenscar Profile. N is the corresponding pragma node, which
891       --  is used for error messages on any constructs that violate the
892       --  profile.
893
894       ---------------------
895       -- Ada_2005_Pragma --
896       ---------------------
897
898       procedure Ada_2005_Pragma is
899       begin
900          if Ada_Version <= Ada_95 then
901             Check_Restriction (No_Implementation_Pragmas, N);
902          end if;
903       end Ada_2005_Pragma;
904
905       ---------------------
906       -- Ada_2012_Pragma --
907       ---------------------
908
909       procedure Ada_2012_Pragma is
910       begin
911          if Ada_Version <= Ada_2005 then
912             Check_Restriction (No_Implementation_Pragmas, N);
913          end if;
914       end Ada_2012_Pragma;
915
916       --------------------------
917       -- Check_Ada_83_Warning --
918       --------------------------
919
920       procedure Check_Ada_83_Warning is
921       begin
922          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
923             Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
924          end if;
925       end Check_Ada_83_Warning;
926
927       ---------------------
928       -- Check_Arg_Count --
929       ---------------------
930
931       procedure Check_Arg_Count (Required : Nat) is
932       begin
933          if Arg_Count /= Required then
934             Error_Pragma ("wrong number of arguments for pragma%");
935          end if;
936       end Check_Arg_Count;
937
938       --------------------------------
939       -- Check_Arg_Is_External_Name --
940       --------------------------------
941
942       procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
943          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
944
945       begin
946          if Nkind (Argx) = N_Identifier then
947             return;
948
949          else
950             Analyze_And_Resolve (Argx, Standard_String);
951
952             if Is_OK_Static_Expression (Argx) then
953                return;
954
955             elsif Etype (Argx) = Any_Type then
956                raise Pragma_Exit;
957
958             --  An interesting special case, if we have a string literal and
959             --  we are in Ada 83 mode, then we allow it even though it will
960             --  not be flagged as static. This allows expected Ada 83 mode
961             --  use of external names which are string literals, even though
962             --  technically these are not static in Ada 83.
963
964             elsif Ada_Version = Ada_83
965               and then Nkind (Argx) = N_String_Literal
966             then
967                return;
968
969             --  Static expression that raises Constraint_Error. This has
970             --  already been flagged, so just exit from pragma processing.
971
972             elsif Is_Static_Expression (Argx) then
973                raise Pragma_Exit;
974
975             --  Here we have a real error (non-static expression)
976
977             else
978                Error_Msg_Name_1 := Pname;
979
980                declare
981                   Msg : String :=
982                           "argument for pragma% must be a identifier or "
983                           & "static string expression!";
984                begin
985                   Fix_Error (Msg);
986                   Flag_Non_Static_Expr (Msg, Argx);
987                   raise Pragma_Exit;
988                end;
989             end if;
990          end if;
991       end Check_Arg_Is_External_Name;
992
993       -----------------------------
994       -- Check_Arg_Is_Identifier --
995       -----------------------------
996
997       procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
998          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
999       begin
1000          if Nkind (Argx) /= N_Identifier then
1001             Error_Pragma_Arg
1002               ("argument for pragma% must be identifier", Argx);
1003          end if;
1004       end Check_Arg_Is_Identifier;
1005
1006       ----------------------------------
1007       -- Check_Arg_Is_Integer_Literal --
1008       ----------------------------------
1009
1010       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
1011          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1012       begin
1013          if Nkind (Argx) /= N_Integer_Literal then
1014             Error_Pragma_Arg
1015               ("argument for pragma% must be integer literal", Argx);
1016          end if;
1017       end Check_Arg_Is_Integer_Literal;
1018
1019       -------------------------------------------
1020       -- Check_Arg_Is_Library_Level_Local_Name --
1021       -------------------------------------------
1022
1023       --  LOCAL_NAME ::=
1024       --    DIRECT_NAME
1025       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1026       --  | library_unit_NAME
1027
1028       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
1029       begin
1030          Check_Arg_Is_Local_Name (Arg);
1031
1032          if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
1033            and then Comes_From_Source (N)
1034          then
1035             Error_Pragma_Arg
1036               ("argument for pragma% must be library level entity", Arg);
1037          end if;
1038       end Check_Arg_Is_Library_Level_Local_Name;
1039
1040       -----------------------------
1041       -- Check_Arg_Is_Local_Name --
1042       -----------------------------
1043
1044       --  LOCAL_NAME ::=
1045       --    DIRECT_NAME
1046       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1047       --  | library_unit_NAME
1048
1049       procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
1050          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1051
1052       begin
1053          Analyze (Argx);
1054
1055          if Nkind (Argx) not in N_Direct_Name
1056            and then (Nkind (Argx) /= N_Attribute_Reference
1057                       or else Present (Expressions (Argx))
1058                       or else Nkind (Prefix (Argx)) /= N_Identifier)
1059            and then (not Is_Entity_Name (Argx)
1060                       or else not Is_Compilation_Unit (Entity (Argx)))
1061          then
1062             Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
1063          end if;
1064
1065          --  No further check required if not an entity name
1066
1067          if not Is_Entity_Name (Argx) then
1068             null;
1069
1070          else
1071             declare
1072                OK   : Boolean;
1073                Ent  : constant Entity_Id := Entity (Argx);
1074                Scop : constant Entity_Id := Scope (Ent);
1075             begin
1076                --  Case of a pragma applied to a compilation unit: pragma must
1077                --  occur immediately after the program unit in the compilation.
1078
1079                if Is_Compilation_Unit (Ent) then
1080                   declare
1081                      Decl : constant Node_Id := Unit_Declaration_Node (Ent);
1082
1083                   begin
1084                      --  Case of pragma placed immediately after spec
1085
1086                      if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
1087                         OK := True;
1088
1089                      --  Case of pragma placed immediately after body
1090
1091                      elsif Nkind (Decl) = N_Subprogram_Declaration
1092                              and then Present (Corresponding_Body (Decl))
1093                      then
1094                         OK := Parent (N) =
1095                                 Aux_Decls_Node
1096                                   (Parent (Unit_Declaration_Node
1097                                              (Corresponding_Body (Decl))));
1098
1099                      --  All other cases are illegal
1100
1101                      else
1102                         OK := False;
1103                      end if;
1104                   end;
1105
1106                --  Special restricted placement rule from 10.2.1(11.8/2)
1107
1108                elsif Is_Generic_Formal (Ent)
1109                        and then Prag_Id = Pragma_Preelaborable_Initialization
1110                then
1111                   OK := List_Containing (N) =
1112                           Generic_Formal_Declarations
1113                             (Unit_Declaration_Node (Scop));
1114
1115                --  Default case, just check that the pragma occurs in the scope
1116                --  of the entity denoted by the name.
1117
1118                else
1119                   OK := Current_Scope = Scop;
1120                end if;
1121
1122                if not OK then
1123                   Error_Pragma_Arg
1124                     ("pragma% argument must be in same declarative part", Arg);
1125                end if;
1126             end;
1127          end if;
1128       end Check_Arg_Is_Local_Name;
1129
1130       ---------------------------------
1131       -- Check_Arg_Is_Locking_Policy --
1132       ---------------------------------
1133
1134       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
1135          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1136
1137       begin
1138          Check_Arg_Is_Identifier (Argx);
1139
1140          if not Is_Locking_Policy_Name (Chars (Argx)) then
1141             Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
1142          end if;
1143       end Check_Arg_Is_Locking_Policy;
1144
1145       -------------------------
1146       -- Check_Arg_Is_One_Of --
1147       -------------------------
1148
1149       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1150          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1151
1152       begin
1153          Check_Arg_Is_Identifier (Argx);
1154
1155          if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
1156             Error_Msg_Name_2 := N1;
1157             Error_Msg_Name_3 := N2;
1158             Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
1159          end if;
1160       end Check_Arg_Is_One_Of;
1161
1162       procedure Check_Arg_Is_One_Of
1163         (Arg        : Node_Id;
1164          N1, N2, N3 : Name_Id)
1165       is
1166          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1167
1168       begin
1169          Check_Arg_Is_Identifier (Argx);
1170
1171          if Chars (Argx) /= N1
1172            and then Chars (Argx) /= N2
1173            and then Chars (Argx) /= N3
1174          then
1175             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1176          end if;
1177       end Check_Arg_Is_One_Of;
1178
1179       procedure Check_Arg_Is_One_Of
1180         (Arg                : Node_Id;
1181          N1, N2, N3, N4, N5 : Name_Id)
1182       is
1183          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1184
1185       begin
1186          Check_Arg_Is_Identifier (Argx);
1187
1188          if Chars (Argx) /= N1
1189            and then Chars (Argx) /= N2
1190            and then Chars (Argx) /= N3
1191            and then Chars (Argx) /= N4
1192            and then Chars (Argx) /= N5
1193          then
1194             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1195          end if;
1196       end Check_Arg_Is_One_Of;
1197       ---------------------------------
1198       -- Check_Arg_Is_Queuing_Policy --
1199       ---------------------------------
1200
1201       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
1202          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1203
1204       begin
1205          Check_Arg_Is_Identifier (Argx);
1206
1207          if not Is_Queuing_Policy_Name (Chars (Argx)) then
1208             Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
1209          end if;
1210       end Check_Arg_Is_Queuing_Policy;
1211
1212       ------------------------------------
1213       -- Check_Arg_Is_Static_Expression --
1214       ------------------------------------
1215
1216       procedure Check_Arg_Is_Static_Expression
1217         (Arg : Node_Id;
1218          Typ : Entity_Id := Empty)
1219       is
1220       begin
1221          Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
1222       end Check_Arg_Is_Static_Expression;
1223
1224       ------------------------------------------
1225       -- Check_Arg_Is_Task_Dispatching_Policy --
1226       ------------------------------------------
1227
1228       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1229          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1230
1231       begin
1232          Check_Arg_Is_Identifier (Argx);
1233
1234          if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1235             Error_Pragma_Arg
1236               ("& is not a valid task dispatching policy name", Argx);
1237          end if;
1238       end Check_Arg_Is_Task_Dispatching_Policy;
1239
1240       ---------------------
1241       -- Check_Arg_Order --
1242       ---------------------
1243
1244       procedure Check_Arg_Order (Names : Name_List) is
1245          Arg : Node_Id;
1246
1247          Highest_So_Far : Natural := 0;
1248          --  Highest index in Names seen do far
1249
1250       begin
1251          Arg := Arg1;
1252          for J in 1 .. Arg_Count loop
1253             if Chars (Arg) /= No_Name then
1254                for K in Names'Range loop
1255                   if Chars (Arg) = Names (K) then
1256                      if K < Highest_So_Far then
1257                         Error_Msg_Name_1 := Pname;
1258                         Error_Msg_N
1259                           ("parameters out of order for pragma%", Arg);
1260                         Error_Msg_Name_1 := Names (K);
1261                         Error_Msg_Name_2 := Names (Highest_So_Far);
1262                         Error_Msg_N ("\% must appear before %", Arg);
1263                         raise Pragma_Exit;
1264
1265                      else
1266                         Highest_So_Far := K;
1267                      end if;
1268                   end if;
1269                end loop;
1270             end if;
1271
1272             Arg := Next (Arg);
1273          end loop;
1274       end Check_Arg_Order;
1275
1276       --------------------------------
1277       -- Check_At_Least_N_Arguments --
1278       --------------------------------
1279
1280       procedure Check_At_Least_N_Arguments (N : Nat) is
1281       begin
1282          if Arg_Count < N then
1283             Error_Pragma ("too few arguments for pragma%");
1284          end if;
1285       end Check_At_Least_N_Arguments;
1286
1287       -------------------------------
1288       -- Check_At_Most_N_Arguments --
1289       -------------------------------
1290
1291       procedure Check_At_Most_N_Arguments (N : Nat) is
1292          Arg : Node_Id;
1293       begin
1294          if Arg_Count > N then
1295             Arg := Arg1;
1296             for J in 1 .. N loop
1297                Next (Arg);
1298                Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1299             end loop;
1300          end if;
1301       end Check_At_Most_N_Arguments;
1302
1303       ---------------------
1304       -- Check_Component --
1305       ---------------------
1306
1307       procedure Check_Component
1308         (Comp            : Node_Id;
1309          UU_Typ          : Entity_Id;
1310          In_Variant_Part : Boolean := False)
1311       is
1312          Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
1313          Sindic  : constant Node_Id :=
1314                      Subtype_Indication (Component_Definition (Comp));
1315          Typ     : constant Entity_Id := Etype (Comp_Id);
1316
1317       begin
1318          --  Ada 2005 (AI-216): If a component subtype is subject to a per-
1319          --  object constraint, then the component type shall be an Unchecked_
1320          --  Union.
1321
1322          if Nkind (Sindic) = N_Subtype_Indication
1323            and then Has_Per_Object_Constraint (Comp_Id)
1324            and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1325          then
1326             Error_Msg_N
1327               ("component subtype subject to per-object constraint " &
1328                "must be an Unchecked_Union", Comp);
1329
1330          --  Ada 2012 (AI05-0026): For an unchecked union type declared within
1331          --  the body of a generic unit, or within the body of any of its
1332          --  descendant library units, no part of the type of a component
1333          --  declared in a variant_part of the unchecked union type shall be of
1334          --  a formal private type or formal private extension declared within
1335          --  the formal part of the generic unit.
1336
1337          elsif Ada_Version >= Ada_2012
1338            and then In_Generic_Body (UU_Typ)
1339            and then In_Variant_Part
1340            and then Is_Private_Type (Typ)
1341            and then Is_Generic_Type (Typ)
1342          then
1343             Error_Msg_N
1344               ("component of Unchecked_Union cannot be of generic type", Comp);
1345
1346          elsif Needs_Finalization (Typ) then
1347             Error_Msg_N
1348               ("component of Unchecked_Union cannot be controlled", Comp);
1349
1350          elsif Has_Task (Typ) then
1351             Error_Msg_N
1352               ("component of Unchecked_Union cannot have tasks", Comp);
1353          end if;
1354       end Check_Component;
1355
1356       ----------------------------
1357       -- Check_Duplicate_Pragma --
1358       ----------------------------
1359
1360       procedure Check_Duplicate_Pragma (E : Entity_Id) is
1361          P : Node_Id;
1362
1363       begin
1364          --  Nothing to do if this pragma comes from an aspect specification,
1365          --  since we could not be duplicating a pragma, and we dealt with the
1366          --  case of duplicated aspects in Analyze_Aspect_Specifications.
1367
1368          if From_Aspect_Specification (N) then
1369             return;
1370          end if;
1371
1372          --  Otherwise current pragma may duplicate previous pragma or a
1373          --  previously given aspect specification for the same pragma.
1374
1375          P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
1376
1377          if Present (P) then
1378             Error_Msg_Name_1 := Pragma_Name (N);
1379             Error_Msg_Sloc := Sloc (P);
1380
1381             if Nkind (P) = N_Aspect_Specification
1382               or else From_Aspect_Specification (P)
1383             then
1384                Error_Msg_NE ("aspect% for & previously given#", N, E);
1385             else
1386                Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
1387             end if;
1388
1389             raise Pragma_Exit;
1390          end if;
1391       end Check_Duplicate_Pragma;
1392
1393       ----------------------------------
1394       -- Check_Duplicated_Export_Name --
1395       ----------------------------------
1396
1397       procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1398          String_Val : constant String_Id := Strval (Nam);
1399
1400       begin
1401          --  We are only interested in the export case, and in the case of
1402          --  generics, it is the instance, not the template, that is the
1403          --  problem (the template will generate a warning in any case).
1404
1405          if not Inside_A_Generic
1406            and then (Prag_Id = Pragma_Export
1407                        or else
1408                      Prag_Id = Pragma_Export_Procedure
1409                        or else
1410                      Prag_Id = Pragma_Export_Valued_Procedure
1411                        or else
1412                      Prag_Id = Pragma_Export_Function)
1413          then
1414             for J in Externals.First .. Externals.Last loop
1415                if String_Equal (String_Val, Strval (Externals.Table (J))) then
1416                   Error_Msg_Sloc := Sloc (Externals.Table (J));
1417                   Error_Msg_N ("external name duplicates name given#", Nam);
1418                   exit;
1419                end if;
1420             end loop;
1421
1422             Externals.Append (Nam);
1423          end if;
1424       end Check_Duplicated_Export_Name;
1425
1426       -------------------------------------
1427       -- Check_Expr_Is_Static_Expression --
1428       -------------------------------------
1429
1430       procedure Check_Expr_Is_Static_Expression
1431         (Expr : Node_Id;
1432          Typ  : Entity_Id := Empty)
1433       is
1434       begin
1435          if Present (Typ) then
1436             Analyze_And_Resolve (Expr, Typ);
1437          else
1438             Analyze_And_Resolve (Expr);
1439          end if;
1440
1441          if Is_OK_Static_Expression (Expr) then
1442             return;
1443
1444          elsif Etype (Expr) = Any_Type then
1445             raise Pragma_Exit;
1446
1447          --  An interesting special case, if we have a string literal and we
1448          --  are in Ada 83 mode, then we allow it even though it will not be
1449          --  flagged as static. This allows the use of Ada 95 pragmas like
1450          --  Import in Ada 83 mode. They will of course be flagged with
1451          --  warnings as usual, but will not cause errors.
1452
1453          elsif Ada_Version = Ada_83
1454            and then Nkind (Expr) = N_String_Literal
1455          then
1456             return;
1457
1458          --  Static expression that raises Constraint_Error. This has already
1459          --  been flagged, so just exit from pragma processing.
1460
1461          elsif Is_Static_Expression (Expr) then
1462             raise Pragma_Exit;
1463
1464          --  Finally, we have a real error
1465
1466          else
1467             Error_Msg_Name_1 := Pname;
1468
1469             declare
1470                Msg : String :=
1471                        "argument for pragma% must be a static expression!";
1472             begin
1473                Fix_Error (Msg);
1474                Flag_Non_Static_Expr (Msg, Expr);
1475             end;
1476
1477             raise Pragma_Exit;
1478          end if;
1479       end Check_Expr_Is_Static_Expression;
1480
1481       -------------------------
1482       -- Check_First_Subtype --
1483       -------------------------
1484
1485       procedure Check_First_Subtype (Arg : Node_Id) is
1486          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1487          Ent  : constant Entity_Id := Entity (Argx);
1488
1489       begin
1490          if Is_First_Subtype (Ent) then
1491             null;
1492
1493          elsif Is_Type (Ent) then
1494             Error_Pragma_Arg
1495               ("pragma% cannot apply to subtype", Argx);
1496
1497          elsif Is_Object (Ent) then
1498             Error_Pragma_Arg
1499               ("pragma% cannot apply to object, requires a type", Argx);
1500
1501          else
1502             Error_Pragma_Arg
1503               ("pragma% cannot apply to&, requires a type", Argx);
1504          end if;
1505       end Check_First_Subtype;
1506
1507       ----------------------
1508       -- Check_Identifier --
1509       ----------------------
1510
1511       procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
1512       begin
1513          if Present (Arg)
1514            and then Nkind (Arg) = N_Pragma_Argument_Association
1515          then
1516             if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
1517                Error_Msg_Name_1 := Pname;
1518                Error_Msg_Name_2 := Id;
1519                Error_Msg_N ("pragma% argument expects identifier%", Arg);
1520                raise Pragma_Exit;
1521             end if;
1522          end if;
1523       end Check_Identifier;
1524
1525       --------------------------------
1526       -- Check_Identifier_Is_One_Of --
1527       --------------------------------
1528
1529       procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1530       begin
1531          if Present (Arg)
1532            and then Nkind (Arg) = N_Pragma_Argument_Association
1533          then
1534             if Chars (Arg) = No_Name then
1535                Error_Msg_Name_1 := Pname;
1536                Error_Msg_N ("pragma% argument expects an identifier", Arg);
1537                raise Pragma_Exit;
1538
1539             elsif Chars (Arg) /= N1
1540               and then Chars (Arg) /= N2
1541             then
1542                Error_Msg_Name_1 := Pname;
1543                Error_Msg_N ("invalid identifier for pragma% argument", Arg);
1544                raise Pragma_Exit;
1545             end if;
1546          end if;
1547       end Check_Identifier_Is_One_Of;
1548
1549       ---------------------------
1550       -- Check_In_Main_Program --
1551       ---------------------------
1552
1553       procedure Check_In_Main_Program is
1554          P : constant Node_Id := Parent (N);
1555
1556       begin
1557          --  Must be at in subprogram body
1558
1559          if Nkind (P) /= N_Subprogram_Body then
1560             Error_Pragma ("% pragma allowed only in subprogram");
1561
1562          --  Otherwise warn if obviously not main program
1563
1564          elsif Present (Parameter_Specifications (Specification (P)))
1565            or else not Is_Compilation_Unit (Defining_Entity (P))
1566          then
1567             Error_Msg_Name_1 := Pname;
1568             Error_Msg_N
1569               ("?pragma% is only effective in main program", N);
1570          end if;
1571       end Check_In_Main_Program;
1572
1573       ---------------------------------------
1574       -- Check_Interrupt_Or_Attach_Handler --
1575       ---------------------------------------
1576
1577       procedure Check_Interrupt_Or_Attach_Handler is
1578          Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
1579          Handler_Proc, Proc_Scope : Entity_Id;
1580
1581       begin
1582          Analyze (Arg1_X);
1583
1584          if Prag_Id = Pragma_Interrupt_Handler then
1585             Check_Restriction (No_Dynamic_Attachment, N);
1586          end if;
1587
1588          Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1589          Proc_Scope := Scope (Handler_Proc);
1590
1591          --  On AAMP only, a pragma Interrupt_Handler is supported for
1592          --  nonprotected parameterless procedures.
1593
1594          if not AAMP_On_Target
1595            or else Prag_Id = Pragma_Attach_Handler
1596          then
1597             if Ekind (Proc_Scope) /= E_Protected_Type then
1598                Error_Pragma_Arg
1599                  ("argument of pragma% must be protected procedure", Arg1);
1600             end if;
1601
1602             if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1603                Error_Pragma ("pragma% must be in protected definition");
1604             end if;
1605          end if;
1606
1607          if not Is_Library_Level_Entity (Proc_Scope)
1608            or else (AAMP_On_Target
1609                      and then not Is_Library_Level_Entity (Handler_Proc))
1610          then
1611             Error_Pragma_Arg
1612               ("argument for pragma% must be library level entity", Arg1);
1613          end if;
1614
1615          --  AI05-0033: A pragma cannot appear within a generic body, because
1616          --  instance can be in a nested scope. The check that protected type
1617          --  is itself a library-level declaration is done elsewhere.
1618
1619          --  Note: we omit this check in Codepeer mode to properly handle code
1620          --  prior to AI-0033 (pragmas don't matter to codepeer in any case).
1621
1622          if Inside_A_Generic then
1623             if Ekind (Scope (Current_Scope)) = E_Generic_Package
1624               and then In_Package_Body (Scope (Current_Scope))
1625               and then not CodePeer_Mode
1626             then
1627                Error_Pragma ("pragma% cannot be used inside a generic");
1628             end if;
1629          end if;
1630       end Check_Interrupt_Or_Attach_Handler;
1631
1632       -------------------------------------------
1633       -- Check_Is_In_Decl_Part_Or_Package_Spec --
1634       -------------------------------------------
1635
1636       procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1637          P : Node_Id;
1638
1639       begin
1640          P := Parent (N);
1641          loop
1642             if No (P) then
1643                exit;
1644
1645             elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1646                exit;
1647
1648             elsif Nkind_In (P, N_Package_Specification,
1649                                N_Block_Statement)
1650             then
1651                return;
1652
1653             --  Note: the following tests seem a little peculiar, because
1654             --  they test for bodies, but if we were in the statement part
1655             --  of the body, we would already have hit the handled statement
1656             --  sequence, so the only way we get here is by being in the
1657             --  declarative part of the body.
1658
1659             elsif Nkind_In (P, N_Subprogram_Body,
1660                                N_Package_Body,
1661                                N_Task_Body,
1662                                N_Entry_Body)
1663             then
1664                return;
1665             end if;
1666
1667             P := Parent (P);
1668          end loop;
1669
1670          Error_Pragma ("pragma% is not in declarative part or package spec");
1671       end Check_Is_In_Decl_Part_Or_Package_Spec;
1672
1673       -------------------------
1674       -- Check_No_Identifier --
1675       -------------------------
1676
1677       procedure Check_No_Identifier (Arg : Node_Id) is
1678       begin
1679          if Nkind (Arg) = N_Pragma_Argument_Association
1680            and then Chars (Arg) /= No_Name
1681          then
1682             Error_Pragma_Arg_Ident
1683               ("pragma% does not permit identifier& here", Arg);
1684          end if;
1685       end Check_No_Identifier;
1686
1687       --------------------------
1688       -- Check_No_Identifiers --
1689       --------------------------
1690
1691       procedure Check_No_Identifiers is
1692          Arg_Node : Node_Id;
1693       begin
1694          if Arg_Count > 0 then
1695             Arg_Node := Arg1;
1696             while Present (Arg_Node) loop
1697                Check_No_Identifier (Arg_Node);
1698                Next (Arg_Node);
1699             end loop;
1700          end if;
1701       end Check_No_Identifiers;
1702
1703       ------------------------
1704       -- Check_No_Link_Name --
1705       ------------------------
1706
1707       procedure Check_No_Link_Name is
1708       begin
1709          if Present (Arg3)
1710            and then Chars (Arg3) = Name_Link_Name
1711          then
1712             Arg4 := Arg3;
1713          end if;
1714
1715          if Present (Arg4) then
1716             Error_Pragma_Arg
1717               ("Link_Name argument not allowed for Import Intrinsic", Arg4);
1718          end if;
1719       end Check_No_Link_Name;
1720
1721       -------------------------------
1722       -- Check_Optional_Identifier --
1723       -------------------------------
1724
1725       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1726       begin
1727          if Present (Arg)
1728            and then Nkind (Arg) = N_Pragma_Argument_Association
1729            and then Chars (Arg) /= No_Name
1730          then
1731             if Chars (Arg) /= Id then
1732                Error_Msg_Name_1 := Pname;
1733                Error_Msg_Name_2 := Id;
1734                Error_Msg_N ("pragma% argument expects identifier%", Arg);
1735                raise Pragma_Exit;
1736             end if;
1737          end if;
1738       end Check_Optional_Identifier;
1739
1740       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1741       begin
1742          Name_Buffer (1 .. Id'Length) := Id;
1743          Name_Len := Id'Length;
1744          Check_Optional_Identifier (Arg, Name_Find);
1745       end Check_Optional_Identifier;
1746
1747       --------------------------------------
1748       -- Check_Precondition_Postcondition --
1749       --------------------------------------
1750
1751       procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1752          P  : Node_Id;
1753          PO : Node_Id;
1754
1755          procedure Chain_PPC (PO : Node_Id);
1756          --  If PO is an entry or a [generic] subprogram declaration node, then
1757          --  the precondition/postcondition applies to this subprogram and the
1758          --  processing for the pragma is completed. Otherwise the pragma is
1759          --  misplaced.
1760
1761          ---------------
1762          -- Chain_PPC --
1763          ---------------
1764
1765          procedure Chain_PPC (PO : Node_Id) is
1766             S   : Entity_Id;
1767             P   : Node_Id;
1768
1769          begin
1770             if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1771                if not From_Aspect_Specification (N) then
1772                   Error_Pragma
1773                     ("pragma% cannot be applied to abstract subprogram");
1774
1775                elsif Class_Present (N) then
1776                   null;
1777
1778                else
1779                   Error_Pragma
1780                     ("aspect % requires ''Class for abstract subprogram");
1781                end if;
1782
1783             --  AI05-0230: The same restriction applies to null procedures. For
1784             --  compatibility with earlier uses of the Ada pragma, apply this
1785             --  rule only to aspect specifications.
1786
1787             --  The above discrpency needs documentation. Robert is dubious
1788             --  about whether it is a good idea ???
1789
1790             elsif Nkind (PO) = N_Subprogram_Declaration
1791               and then Nkind (Specification (PO)) = N_Procedure_Specification
1792               and then Null_Present (Specification (PO))
1793               and then From_Aspect_Specification (N)
1794               and then not Class_Present (N)
1795             then
1796                Error_Pragma
1797                  ("aspect % requires ''Class for null procedure");
1798
1799             elsif not Nkind_In (PO, N_Subprogram_Declaration,
1800                                     N_Generic_Subprogram_Declaration,
1801                                     N_Entry_Declaration)
1802             then
1803                Pragma_Misplaced;
1804             end if;
1805
1806             --  Here if we have [generic] subprogram or entry declaration
1807
1808             if Nkind (PO) = N_Entry_Declaration then
1809                S := Defining_Entity (PO);
1810             else
1811                S := Defining_Unit_Name (Specification (PO));
1812             end if;
1813
1814             --  Make sure we do not have the case of a precondition pragma when
1815             --  the Pre'Class aspect is present.
1816
1817             --  We do this by looking at pragmas already chained to the entity
1818             --  since the aspect derived pragma will be put on this list first.
1819
1820             if Pragma_Name (N) = Name_Precondition then
1821                if not From_Aspect_Specification (N) then
1822                   P := Spec_PPC_List (Contract (S));
1823                   while Present (P) loop
1824                      if Pragma_Name (P) = Name_Precondition
1825                        and then From_Aspect_Specification (P)
1826                        and then Class_Present (P)
1827                      then
1828                         Error_Msg_Sloc := Sloc (P);
1829                         Error_Pragma
1830                           ("pragma% not allowed, `Pre''Class` aspect given#");
1831                      end if;
1832
1833                      P := Next_Pragma (P);
1834                   end loop;
1835                end if;
1836             end if;
1837
1838             --  Similarly check for Pre with inherited Pre'Class. Note that
1839             --  we cover the aspect case as well here.
1840
1841             if Pragma_Name (N) = Name_Precondition
1842               and then not Class_Present (N)
1843             then
1844                declare
1845                   Inherited : constant Subprogram_List :=
1846                                 Inherited_Subprograms (S);
1847                   P         : Node_Id;
1848
1849                begin
1850                   for J in Inherited'Range loop
1851                      P := Spec_PPC_List (Contract (Inherited (J)));
1852                      while Present (P) loop
1853                         if Pragma_Name (P) = Name_Precondition
1854                           and then Class_Present (P)
1855                         then
1856                            Error_Msg_Sloc := Sloc (P);
1857                            Error_Pragma
1858                              ("pragma% not allowed, `Pre''Class` "
1859                               & "aspect inherited from#");
1860                         end if;
1861
1862                         P := Next_Pragma (P);
1863                      end loop;
1864                   end loop;
1865                end;
1866             end if;
1867
1868             --  Note: we do not analyze the pragma at this point. Instead we
1869             --  delay this analysis until the end of the declarative part in
1870             --  which the pragma appears. This implements the required delay
1871             --  in this analysis, allowing forward references. The analysis
1872             --  happens at the end of Analyze_Declarations.
1873
1874             --  Chain spec PPC pragma to list for subprogram
1875
1876             Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
1877             Set_Spec_PPC_List (Contract (S), N);
1878
1879             --  Return indicating spec case
1880
1881             In_Body := False;
1882             return;
1883          end Chain_PPC;
1884
1885       --  Start of processing for Check_Precondition_Postcondition
1886
1887       begin
1888          if not Is_List_Member (N) then
1889             Pragma_Misplaced;
1890          end if;
1891
1892          --  Preanalyze message argument if present. Visibility in this
1893          --  argument is established at the point of pragma occurrence.
1894
1895          if Arg_Count = 2 then
1896             Check_Optional_Identifier (Arg2, Name_Message);
1897             Preanalyze_Spec_Expression
1898               (Get_Pragma_Arg (Arg2), Standard_String);
1899          end if;
1900
1901          --  Record if pragma is disabled
1902
1903          if Check_Enabled (Pname) then
1904             Set_SCO_Pragma_Enabled (Loc);
1905          end if;
1906
1907          --  If we are within an inlined body, the legality of the pragma
1908          --  has been checked already.
1909
1910          if In_Inlined_Body then
1911             In_Body := True;
1912             return;
1913          end if;
1914
1915          --  Search prior declarations
1916
1917          P := N;
1918          while Present (Prev (P)) loop
1919             P := Prev (P);
1920
1921             --  If the previous node is a generic subprogram, do not go to to
1922             --  the original node, which is the unanalyzed tree: we need to
1923             --  attach the pre/postconditions to the analyzed version at this
1924             --  point. They get propagated to the original tree when analyzing
1925             --  the corresponding body.
1926
1927             if Nkind (P) not in N_Generic_Declaration then
1928                PO := Original_Node (P);
1929             else
1930                PO := P;
1931             end if;
1932
1933             --  Skip past prior pragma
1934
1935             if Nkind (PO) = N_Pragma then
1936                null;
1937
1938             --  Skip stuff not coming from source
1939
1940             elsif not Comes_From_Source (PO) then
1941
1942                --  The condition may apply to a subprogram instantiation
1943
1944                if Nkind (PO) = N_Subprogram_Declaration
1945                  and then Present (Generic_Parent (Specification (PO)))
1946                then
1947                   Chain_PPC (PO);
1948                   return;
1949
1950                elsif Nkind (PO) = N_Subprogram_Declaration
1951                  and then In_Instance
1952                then
1953                   Chain_PPC (PO);
1954                   return;
1955
1956                --  For all other cases of non source code, do nothing
1957
1958                else
1959                   null;
1960                end if;
1961
1962             --  Only remaining possibility is subprogram declaration
1963
1964             else
1965                Chain_PPC (PO);
1966                return;
1967             end if;
1968          end loop;
1969
1970          --  If we fall through loop, pragma is at start of list, so see if it
1971          --  is at the start of declarations of a subprogram body.
1972
1973          if Nkind (Parent (N)) = N_Subprogram_Body
1974            and then List_Containing (N) = Declarations (Parent (N))
1975          then
1976             if Operating_Mode /= Generate_Code
1977               or else Inside_A_Generic
1978             then
1979                --  Analyze pragma expression for correctness and for ASIS use
1980
1981                Preanalyze_Spec_Expression
1982                  (Get_Pragma_Arg (Arg1), Standard_Boolean);
1983
1984                --  In ASIS mode, for a pragma generated from a source aspect,
1985                --  also analyze the original aspect expression.
1986
1987                if ASIS_Mode
1988                  and then Present (Corresponding_Aspect (N))
1989                then
1990                   Preanalyze_Spec_Expression
1991                     (Expression (Corresponding_Aspect (N)), Standard_Boolean);
1992                end if;
1993             end if;
1994
1995             In_Body := True;
1996             return;
1997
1998          --  See if it is in the pragmas after a library level subprogram
1999
2000          elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
2001
2002             --  In formal verification mode, analyze pragma expression for
2003             --  correctness, as it is not expanded later.
2004
2005             if Alfa_Mode then
2006                Analyze_PPC_In_Decl_Part
2007                  (N, Defining_Entity (Unit (Parent (Parent (N)))));
2008             end if;
2009
2010             Chain_PPC (Unit (Parent (Parent (N))));
2011             return;
2012          end if;
2013
2014          --  If we fall through, pragma was misplaced
2015
2016          Pragma_Misplaced;
2017       end Check_Precondition_Postcondition;
2018
2019       -----------------------------
2020       -- Check_Static_Constraint --
2021       -----------------------------
2022
2023       --  Note: for convenience in writing this procedure, in addition to
2024       --  the officially (i.e. by spec) allowed argument which is always a
2025       --  constraint, it also allows ranges and discriminant associations.
2026       --  Above is not clear ???
2027
2028       procedure Check_Static_Constraint (Constr : Node_Id) is
2029
2030          procedure Require_Static (E : Node_Id);
2031          --  Require given expression to be static expression
2032
2033          --------------------
2034          -- Require_Static --
2035          --------------------
2036
2037          procedure Require_Static (E : Node_Id) is
2038          begin
2039             if not Is_OK_Static_Expression (E) then
2040                Flag_Non_Static_Expr
2041                  ("non-static constraint not allowed in Unchecked_Union!", E);
2042                raise Pragma_Exit;
2043             end if;
2044          end Require_Static;
2045
2046       --  Start of processing for Check_Static_Constraint
2047
2048       begin
2049          case Nkind (Constr) is
2050             when N_Discriminant_Association =>
2051                Require_Static (Expression (Constr));
2052
2053             when N_Range =>
2054                Require_Static (Low_Bound (Constr));
2055                Require_Static (High_Bound (Constr));
2056
2057             when N_Attribute_Reference =>
2058                Require_Static (Type_Low_Bound  (Etype (Prefix (Constr))));
2059                Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
2060
2061             when N_Range_Constraint =>
2062                Check_Static_Constraint (Range_Expression (Constr));
2063
2064             when N_Index_Or_Discriminant_Constraint =>
2065                declare
2066                   IDC : Entity_Id;
2067                begin
2068                   IDC := First (Constraints (Constr));
2069                   while Present (IDC) loop
2070                      Check_Static_Constraint (IDC);
2071                      Next (IDC);
2072                   end loop;
2073                end;
2074
2075             when others =>
2076                null;
2077          end case;
2078       end Check_Static_Constraint;
2079
2080       ---------------------
2081       -- Check_Test_Case --
2082       ---------------------
2083
2084       procedure Check_Test_Case is
2085          P  : Node_Id;
2086          PO : Node_Id;
2087
2088          procedure Chain_TC (PO : Node_Id);
2089          --  If PO is a [generic] subprogram declaration node, then the
2090          --  test-case applies to this subprogram and the processing for the
2091          --  pragma is completed. Otherwise the pragma is misplaced.
2092
2093          --------------
2094          -- Chain_TC --
2095          --------------
2096
2097          procedure Chain_TC (PO : Node_Id) is
2098             S   : Entity_Id;
2099
2100          begin
2101             if Nkind (PO) = N_Abstract_Subprogram_Declaration then
2102                if From_Aspect_Specification (N) then
2103                   Error_Pragma
2104                     ("aspect% cannot be applied to abstract subprogram");
2105                else
2106                   Error_Pragma
2107                     ("pragma% cannot be applied to abstract subprogram");
2108                end if;
2109
2110             elsif Nkind (PO) = N_Entry_Declaration then
2111                if From_Aspect_Specification (N) then
2112                   Error_Pragma ("aspect% cannot be applied to entry");
2113                else
2114                   Error_Pragma ("pragma% cannot be applied to entry");
2115                end if;
2116
2117             elsif not Nkind_In (PO, N_Subprogram_Declaration,
2118                                     N_Generic_Subprogram_Declaration)
2119             then
2120                Pragma_Misplaced;
2121             end if;
2122
2123             --  Here if we have [generic] subprogram declaration
2124
2125             S := Defining_Unit_Name (Specification (PO));
2126
2127             --  Note: we do not analyze the pragma at this point. Instead we
2128             --  delay this analysis until the end of the declarative part in
2129             --  which the pragma appears. This implements the required delay
2130             --  in this analysis, allowing forward references. The analysis
2131             --  happens at the end of Analyze_Declarations.
2132
2133             --  There should not be another test case with the same name
2134             --  associated to this subprogram.
2135
2136             declare
2137                Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
2138                TC   : Node_Id;
2139
2140             begin
2141                TC := Spec_TC_List (Contract (S));
2142                while Present (TC) loop
2143
2144                   if String_Equal
2145                     (Name, Get_Name_From_Test_Case_Pragma (TC))
2146                   then
2147                      Error_Msg_Sloc := Sloc (TC);
2148
2149                      if From_Aspect_Specification (N) then
2150                         Error_Pragma ("name for aspect% is already used#");
2151                      else
2152                         Error_Pragma ("name for pragma% is already used#");
2153                      end if;
2154                   end if;
2155
2156                   TC := Next_Pragma (TC);
2157                end loop;
2158             end;
2159
2160             --  Chain spec TC pragma to list for subprogram
2161
2162             Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
2163             Set_Spec_TC_List (Contract (S), N);
2164          end Chain_TC;
2165
2166       --  Start of processing for Check_Test_Case
2167
2168       begin
2169          if not Is_List_Member (N) then
2170             Pragma_Misplaced;
2171          end if;
2172
2173          --  Test cases should only appear in package spec unit
2174
2175          if Get_Source_Unit (N) = No_Unit
2176            or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
2177                                  N_Package_Declaration,
2178                                  N_Generic_Package_Declaration)
2179          then
2180             Pragma_Misplaced;
2181          end if;
2182
2183          --  Search prior declarations
2184
2185          P := N;
2186          while Present (Prev (P)) loop
2187             P := Prev (P);
2188
2189             --  If the previous node is a generic subprogram, do not go to to
2190             --  the original node, which is the unanalyzed tree: we need to
2191             --  attach the test-case to the analyzed version at this point.
2192             --  They get propagated to the original tree when analyzing the
2193             --  corresponding body.
2194
2195             if Nkind (P) not in N_Generic_Declaration then
2196                PO := Original_Node (P);
2197             else
2198                PO := P;
2199             end if;
2200
2201             --  Skip past prior pragma
2202
2203             if Nkind (PO) = N_Pragma then
2204                null;
2205
2206             --  Skip stuff not coming from source
2207
2208             elsif not Comes_From_Source (PO) then
2209                null;
2210
2211             --  Only remaining possibility is subprogram declaration. First
2212             --  check that it is declared directly in a package declaration.
2213             --  This may be either the package declaration for the current unit
2214             --  being defined or a local package declaration.
2215
2216             elsif not Present (Parent (Parent (PO)))
2217               or else not Present (Parent (Parent (Parent (PO))))
2218               or else not Nkind_In (Parent (Parent (PO)),
2219                                     N_Package_Declaration,
2220                                     N_Generic_Package_Declaration)
2221             then
2222                Pragma_Misplaced;
2223
2224             else
2225                Chain_TC (PO);
2226                return;
2227             end if;
2228          end loop;
2229
2230          --  If we fall through, pragma was misplaced
2231
2232          Pragma_Misplaced;
2233       end Check_Test_Case;
2234
2235       --------------------------------------
2236       -- Check_Valid_Configuration_Pragma --
2237       --------------------------------------
2238
2239       --  A configuration pragma must appear in the context clause of a
2240       --  compilation unit, and only other pragmas may precede it. Note that
2241       --  the test also allows use in a configuration pragma file.
2242
2243       procedure Check_Valid_Configuration_Pragma is
2244       begin
2245          if not Is_Configuration_Pragma then
2246             Error_Pragma ("incorrect placement for configuration pragma%");
2247          end if;
2248       end Check_Valid_Configuration_Pragma;
2249
2250       -------------------------------------
2251       -- Check_Valid_Library_Unit_Pragma --
2252       -------------------------------------
2253
2254       procedure Check_Valid_Library_Unit_Pragma is
2255          Plist       : List_Id;
2256          Parent_Node : Node_Id;
2257          Unit_Name   : Entity_Id;
2258          Unit_Kind   : Node_Kind;
2259          Unit_Node   : Node_Id;
2260          Sindex      : Source_File_Index;
2261
2262       begin
2263          if not Is_List_Member (N) then
2264             Pragma_Misplaced;
2265
2266          else
2267             Plist := List_Containing (N);
2268             Parent_Node := Parent (Plist);
2269
2270             if Parent_Node = Empty then
2271                Pragma_Misplaced;
2272
2273             --  Case of pragma appearing after a compilation unit. In this case
2274             --  it must have an argument with the corresponding name and must
2275             --  be part of the following pragmas of its parent.
2276
2277             elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
2278                if Plist /= Pragmas_After (Parent_Node) then
2279                   Pragma_Misplaced;
2280
2281                elsif Arg_Count = 0 then
2282                   Error_Pragma
2283                     ("argument required if outside compilation unit");
2284
2285                else
2286                   Check_No_Identifiers;
2287                   Check_Arg_Count (1);
2288                   Unit_Node := Unit (Parent (Parent_Node));
2289                   Unit_Kind := Nkind (Unit_Node);
2290
2291                   Analyze (Get_Pragma_Arg (Arg1));
2292
2293                   if Unit_Kind = N_Generic_Subprogram_Declaration
2294                     or else Unit_Kind = N_Subprogram_Declaration
2295                   then
2296                      Unit_Name := Defining_Entity (Unit_Node);
2297
2298                   elsif Unit_Kind in N_Generic_Instantiation then
2299                      Unit_Name := Defining_Entity (Unit_Node);
2300
2301                   else
2302                      Unit_Name := Cunit_Entity (Current_Sem_Unit);
2303                   end if;
2304
2305                   if Chars (Unit_Name) /=
2306                      Chars (Entity (Get_Pragma_Arg (Arg1)))
2307                   then
2308                      Error_Pragma_Arg
2309                        ("pragma% argument is not current unit name", Arg1);
2310                   end if;
2311
2312                   if Ekind (Unit_Name) = E_Package
2313                     and then Present (Renamed_Entity (Unit_Name))
2314                   then
2315                      Error_Pragma ("pragma% not allowed for renamed package");
2316                   end if;
2317                end if;
2318
2319             --  Pragma appears other than after a compilation unit
2320
2321             else
2322                --  Here we check for the generic instantiation case and also
2323                --  for the case of processing a generic formal package. We
2324                --  detect these cases by noting that the Sloc on the node
2325                --  does not belong to the current compilation unit.
2326
2327                Sindex := Source_Index (Current_Sem_Unit);
2328
2329                if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
2330                   Rewrite (N, Make_Null_Statement (Loc));
2331                   return;
2332
2333                --  If before first declaration, the pragma applies to the
2334                --  enclosing unit, and the name if present must be this name.
2335
2336                elsif Is_Before_First_Decl (N, Plist) then
2337                   Unit_Node := Unit_Declaration_Node (Current_Scope);
2338                   Unit_Kind := Nkind (Unit_Node);
2339
2340                   if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
2341                      Pragma_Misplaced;
2342
2343                   elsif Unit_Kind = N_Subprogram_Body
2344                     and then not Acts_As_Spec (Unit_Node)
2345                   then
2346                      Pragma_Misplaced;
2347
2348                   elsif Nkind (Parent_Node) = N_Package_Body then
2349                      Pragma_Misplaced;
2350
2351                   elsif Nkind (Parent_Node) = N_Package_Specification
2352                     and then Plist = Private_Declarations (Parent_Node)
2353                   then
2354                      Pragma_Misplaced;
2355
2356                   elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
2357                            or else Nkind (Parent_Node) =
2358                                              N_Generic_Subprogram_Declaration)
2359                     and then Plist = Generic_Formal_Declarations (Parent_Node)
2360                   then
2361                      Pragma_Misplaced;
2362
2363                   elsif Arg_Count > 0 then
2364                      Analyze (Get_Pragma_Arg (Arg1));
2365
2366                      if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
2367                         Error_Pragma_Arg
2368                           ("name in pragma% must be enclosing unit", Arg1);
2369                      end if;
2370
2371                   --  It is legal to have no argument in this context
2372
2373                   else
2374                      return;
2375                   end if;
2376
2377                --  Error if not before first declaration. This is because a
2378                --  library unit pragma argument must be the name of a library
2379                --  unit (RM 10.1.5(7)), but the only names permitted in this
2380                --  context are (RM 10.1.5(6)) names of subprogram declarations,
2381                --  generic subprogram declarations or generic instantiations.
2382
2383                else
2384                   Error_Pragma
2385                     ("pragma% misplaced, must be before first declaration");
2386                end if;
2387             end if;
2388          end if;
2389       end Check_Valid_Library_Unit_Pragma;
2390
2391       -------------------
2392       -- Check_Variant --
2393       -------------------
2394
2395       procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
2396          Clist : constant Node_Id := Component_List (Variant);
2397          Comp  : Node_Id;
2398
2399       begin
2400          if not Is_Non_Empty_List (Component_Items (Clist)) then
2401             Error_Msg_N
2402               ("Unchecked_Union may not have empty component list",
2403                Variant);
2404             return;
2405          end if;
2406
2407          Comp := First (Component_Items (Clist));
2408          while Present (Comp) loop
2409             Check_Component (Comp, UU_Typ, In_Variant_Part => True);
2410             Next (Comp);
2411          end loop;
2412       end Check_Variant;
2413
2414       ------------------
2415       -- Error_Pragma --
2416       ------------------
2417
2418       procedure Error_Pragma (Msg : String) is
2419          MsgF : String := Msg;
2420       begin
2421          Error_Msg_Name_1 := Pname;
2422          Fix_Error (MsgF);
2423          Error_Msg_N (MsgF, N);
2424          raise Pragma_Exit;
2425       end Error_Pragma;
2426
2427       ----------------------
2428       -- Error_Pragma_Arg --
2429       ----------------------
2430
2431       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
2432          MsgF : String := Msg;
2433       begin
2434          Error_Msg_Name_1 := Pname;
2435          Fix_Error (MsgF);
2436          Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2437          raise Pragma_Exit;
2438       end Error_Pragma_Arg;
2439
2440       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
2441          MsgF : String := Msg1;
2442       begin
2443          Error_Msg_Name_1 := Pname;
2444          Fix_Error (MsgF);
2445          Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2446          Error_Pragma_Arg (Msg2, Arg);
2447       end Error_Pragma_Arg;
2448
2449       ----------------------------
2450       -- Error_Pragma_Arg_Ident --
2451       ----------------------------
2452
2453       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
2454          MsgF : String := Msg;
2455       begin
2456          Error_Msg_Name_1 := Pname;
2457          Fix_Error (MsgF);
2458          Error_Msg_N (MsgF, Arg);
2459          raise Pragma_Exit;
2460       end Error_Pragma_Arg_Ident;
2461
2462       ----------------------
2463       -- Error_Pragma_Ref --
2464       ----------------------
2465
2466       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
2467          MsgF : String := Msg;
2468       begin
2469          Error_Msg_Name_1 := Pname;
2470          Fix_Error (MsgF);
2471          Error_Msg_Sloc   := Sloc (Ref);
2472          Error_Msg_NE (MsgF, N, Ref);
2473          raise Pragma_Exit;
2474       end Error_Pragma_Ref;
2475
2476       ------------------------
2477       -- Find_Lib_Unit_Name --
2478       ------------------------
2479
2480       function Find_Lib_Unit_Name return Entity_Id is
2481       begin
2482          --  Return inner compilation unit entity, for case of nested
2483          --  categorization pragmas. This happens in generic unit.
2484
2485          if Nkind (Parent (N)) = N_Package_Specification
2486            and then Defining_Entity (Parent (N)) /= Current_Scope
2487          then
2488             return Defining_Entity (Parent (N));
2489          else
2490             return Current_Scope;
2491          end if;
2492       end Find_Lib_Unit_Name;
2493
2494       ----------------------------
2495       -- Find_Program_Unit_Name --
2496       ----------------------------
2497
2498       procedure Find_Program_Unit_Name (Id : Node_Id) is
2499          Unit_Name : Entity_Id;
2500          Unit_Kind : Node_Kind;
2501          P         : constant Node_Id := Parent (N);
2502
2503       begin
2504          if Nkind (P) = N_Compilation_Unit then
2505             Unit_Kind := Nkind (Unit (P));
2506
2507             if Unit_Kind = N_Subprogram_Declaration
2508               or else Unit_Kind = N_Package_Declaration
2509               or else Unit_Kind in N_Generic_Declaration
2510             then
2511                Unit_Name := Defining_Entity (Unit (P));
2512
2513                if Chars (Id) = Chars (Unit_Name) then
2514                   Set_Entity (Id, Unit_Name);
2515                   Set_Etype (Id, Etype (Unit_Name));
2516                else
2517                   Set_Etype (Id, Any_Type);
2518                   Error_Pragma
2519                     ("cannot find program unit referenced by pragma%");
2520                end if;
2521
2522             else
2523                Set_Etype (Id, Any_Type);
2524                Error_Pragma ("pragma% inapplicable to this unit");
2525             end if;
2526
2527          else
2528             Analyze (Id);
2529          end if;
2530       end Find_Program_Unit_Name;
2531
2532       -----------------------------------------
2533       -- Find_Unique_Parameterless_Procedure --
2534       -----------------------------------------
2535
2536       function Find_Unique_Parameterless_Procedure
2537         (Name : Entity_Id;
2538          Arg  : Node_Id) return Entity_Id
2539       is
2540          Proc : Entity_Id := Empty;
2541
2542       begin
2543          --  The body of this procedure needs some comments ???
2544
2545          if not Is_Entity_Name (Name) then
2546             Error_Pragma_Arg
2547               ("argument of pragma% must be entity name", Arg);
2548
2549          elsif not Is_Overloaded (Name) then
2550             Proc := Entity (Name);
2551
2552             if Ekind (Proc) /= E_Procedure
2553               or else Present (First_Formal (Proc))
2554             then
2555                Error_Pragma_Arg
2556                  ("argument of pragma% must be parameterless procedure", Arg);
2557             end if;
2558
2559          else
2560             declare
2561                Found : Boolean := False;
2562                It    : Interp;
2563                Index : Interp_Index;
2564
2565             begin
2566                Get_First_Interp (Name, Index, It);
2567                while Present (It.Nam) loop
2568                   Proc := It.Nam;
2569
2570                   if Ekind (Proc) = E_Procedure
2571                     and then No (First_Formal (Proc))
2572                   then
2573                      if not Found then
2574                         Found := True;
2575                         Set_Entity (Name, Proc);
2576                         Set_Is_Overloaded (Name, False);
2577                      else
2578                         Error_Pragma_Arg
2579                           ("ambiguous handler name for pragma% ", Arg);
2580                      end if;
2581                   end if;
2582
2583                   Get_Next_Interp (Index, It);
2584                end loop;
2585
2586                if not Found then
2587                   Error_Pragma_Arg
2588                     ("argument of pragma% must be parameterless procedure",
2589                      Arg);
2590                else
2591                   Proc := Entity (Name);
2592                end if;
2593             end;
2594          end if;
2595
2596          return Proc;
2597       end Find_Unique_Parameterless_Procedure;
2598
2599       ---------------
2600       -- Fix_Error --
2601       ---------------
2602
2603       procedure Fix_Error (Msg : in out String) is
2604       begin
2605          if From_Aspect_Specification (N) then
2606             for J in Msg'First .. Msg'Last - 5 loop
2607                if Msg (J .. J + 5) = "pragma" then
2608                   Msg (J .. J + 5) := "aspect";
2609                end if;
2610             end loop;
2611
2612             if Error_Msg_Name_1 = Name_Precondition then
2613                Error_Msg_Name_1 := Name_Pre;
2614             elsif Error_Msg_Name_1 = Name_Postcondition then
2615                Error_Msg_Name_1 := Name_Post;
2616             end if;
2617          end if;
2618       end Fix_Error;
2619
2620       -------------------------
2621       -- Gather_Associations --
2622       -------------------------
2623
2624       procedure Gather_Associations
2625         (Names : Name_List;
2626          Args  : out Args_List)
2627       is
2628          Arg : Node_Id;
2629
2630       begin
2631          --  Initialize all parameters to Empty
2632
2633          for J in Args'Range loop
2634             Args (J) := Empty;
2635          end loop;
2636
2637          --  That's all we have to do if there are no argument associations
2638
2639          if No (Pragma_Argument_Associations (N)) then
2640             return;
2641          end if;
2642
2643          --  Otherwise first deal with any positional parameters present
2644
2645          Arg := First (Pragma_Argument_Associations (N));
2646          for Index in Args'Range loop
2647             exit when No (Arg) or else Chars (Arg) /= No_Name;
2648             Args (Index) := Get_Pragma_Arg (Arg);
2649             Next (Arg);
2650          end loop;
2651
2652          --  Positional parameters all processed, if any left, then we
2653          --  have too many positional parameters.
2654
2655          if Present (Arg) and then Chars (Arg) = No_Name then
2656             Error_Pragma_Arg
2657               ("too many positional associations for pragma%", Arg);
2658          end if;
2659
2660          --  Process named parameters if any are present
2661
2662          while Present (Arg) loop
2663             if Chars (Arg) = No_Name then
2664                Error_Pragma_Arg
2665                  ("positional association cannot follow named association",
2666                   Arg);
2667
2668             else
2669                for Index in Names'Range loop
2670                   if Names (Index) = Chars (Arg) then
2671                      if Present (Args (Index)) then
2672                         Error_Pragma_Arg
2673                           ("duplicate argument association for pragma%", Arg);
2674                      else
2675                         Args (Index) := Get_Pragma_Arg (Arg);
2676                         exit;
2677                      end if;
2678                   end if;
2679
2680                   if Index = Names'Last then
2681                      Error_Msg_Name_1 := Pname;
2682                      Error_Msg_N ("pragma% does not allow & argument", Arg);
2683
2684                      --  Check for possible misspelling
2685
2686                      for Index1 in Names'Range loop
2687                         if Is_Bad_Spelling_Of
2688                              (Chars (Arg), Names (Index1))
2689                         then
2690                            Error_Msg_Name_1 := Names (Index1);
2691                            Error_Msg_N -- CODEFIX
2692                              ("\possible misspelling of%", Arg);
2693                            exit;
2694                         end if;
2695                      end loop;
2696
2697                      raise Pragma_Exit;
2698                   end if;
2699                end loop;
2700             end if;
2701
2702             Next (Arg);
2703          end loop;
2704       end Gather_Associations;
2705
2706       -----------------
2707       -- GNAT_Pragma --
2708       -----------------
2709
2710       procedure GNAT_Pragma is
2711       begin
2712          --  We need to check the No_Implementation_Pragmas restriction for
2713          --  the case of a pragma from source. Note that the case of aspects
2714          --  generating corresponding pragmas marks these pragmas as not being
2715          --  from source, so this test also catches that case.
2716
2717          if Comes_From_Source (N) then
2718             Check_Restriction (No_Implementation_Pragmas, N);
2719          end if;
2720       end GNAT_Pragma;
2721
2722       --------------------------
2723       -- Is_Before_First_Decl --
2724       --------------------------
2725
2726       function Is_Before_First_Decl
2727         (Pragma_Node : Node_Id;
2728          Decls       : List_Id) return Boolean
2729       is
2730          Item : Node_Id := First (Decls);
2731
2732       begin
2733          --  Only other pragmas can come before this pragma
2734
2735          loop
2736             if No (Item) or else Nkind (Item) /= N_Pragma then
2737                return False;
2738
2739             elsif Item = Pragma_Node then
2740                return True;
2741             end if;
2742
2743             Next (Item);
2744          end loop;
2745       end Is_Before_First_Decl;
2746
2747       -----------------------------
2748       -- Is_Configuration_Pragma --
2749       -----------------------------
2750
2751       --  A configuration pragma must appear in the context clause of a
2752       --  compilation unit, and only other pragmas may precede it. Note that
2753       --  the test below also permits use in a configuration pragma file.
2754
2755       function Is_Configuration_Pragma return Boolean is
2756          Lis : constant List_Id := List_Containing (N);
2757          Par : constant Node_Id := Parent (N);
2758          Prg : Node_Id;
2759
2760       begin
2761          --  If no parent, then we are in the configuration pragma file,
2762          --  so the placement is definitely appropriate.
2763
2764          if No (Par) then
2765             return True;
2766
2767          --  Otherwise we must be in the context clause of a compilation unit
2768          --  and the only thing allowed before us in the context list is more
2769          --  configuration pragmas.
2770
2771          elsif Nkind (Par) = N_Compilation_Unit
2772            and then Context_Items (Par) = Lis
2773          then
2774             Prg := First (Lis);
2775
2776             loop
2777                if Prg = N then
2778                   return True;
2779                elsif Nkind (Prg) /= N_Pragma then
2780                   return False;
2781                end if;
2782
2783                Next (Prg);
2784             end loop;
2785
2786          else
2787             return False;
2788          end if;
2789       end Is_Configuration_Pragma;
2790
2791       --------------------------
2792       -- Is_In_Context_Clause --
2793       --------------------------
2794
2795       function Is_In_Context_Clause return Boolean is
2796          Plist       : List_Id;
2797          Parent_Node : Node_Id;
2798
2799       begin
2800          if not Is_List_Member (N) then
2801             return False;
2802
2803          else
2804             Plist := List_Containing (N);
2805             Parent_Node := Parent (Plist);
2806
2807             if Parent_Node = Empty
2808               or else Nkind (Parent_Node) /= N_Compilation_Unit
2809               or else Context_Items (Parent_Node) /= Plist
2810             then
2811                return False;
2812             end if;
2813          end if;
2814
2815          return True;
2816       end Is_In_Context_Clause;
2817
2818       ---------------------------------
2819       -- Is_Static_String_Expression --
2820       ---------------------------------
2821
2822       function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2823          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2824
2825       begin
2826          Analyze_And_Resolve (Argx);
2827          return Is_OK_Static_Expression (Argx)
2828            and then Nkind (Argx) = N_String_Literal;
2829       end Is_Static_String_Expression;
2830
2831       ----------------------
2832       -- Pragma_Misplaced --
2833       ----------------------
2834
2835       procedure Pragma_Misplaced is
2836       begin
2837          Error_Pragma ("incorrect placement of pragma%");
2838       end Pragma_Misplaced;
2839
2840       ------------------------------------
2841       -- Process Atomic_Shared_Volatile --
2842       ------------------------------------
2843
2844       procedure Process_Atomic_Shared_Volatile is
2845          E_Id : Node_Id;
2846          E    : Entity_Id;
2847          D    : Node_Id;
2848          K    : Node_Kind;
2849          Utyp : Entity_Id;
2850
2851          procedure Set_Atomic (E : Entity_Id);
2852          --  Set given type as atomic, and if no explicit alignment was given,
2853          --  set alignment to unknown, since back end knows what the alignment
2854          --  requirements are for atomic arrays. Note: this step is necessary
2855          --  for derived types.
2856
2857          ----------------
2858          -- Set_Atomic --
2859          ----------------
2860
2861          procedure Set_Atomic (E : Entity_Id) is
2862          begin
2863             Set_Is_Atomic (E);
2864
2865             if not Has_Alignment_Clause (E) then
2866                Set_Alignment (E, Uint_0);
2867             end if;
2868          end Set_Atomic;
2869
2870       --  Start of processing for Process_Atomic_Shared_Volatile
2871
2872       begin
2873          Check_Ada_83_Warning;
2874          Check_No_Identifiers;
2875          Check_Arg_Count (1);
2876          Check_Arg_Is_Local_Name (Arg1);
2877          E_Id := Get_Pragma_Arg (Arg1);
2878
2879          if Etype (E_Id) = Any_Type then
2880             return;
2881          end if;
2882
2883          E := Entity (E_Id);
2884          D := Declaration_Node (E);
2885          K := Nkind (D);
2886
2887          --  Check duplicate before we chain ourselves!
2888
2889          Check_Duplicate_Pragma (E);
2890
2891          --  Now check appropriateness of the entity
2892
2893          if Is_Type (E) then
2894             if Rep_Item_Too_Early (E, N)
2895                  or else
2896                Rep_Item_Too_Late (E, N)
2897             then
2898                return;
2899             else
2900                Check_First_Subtype (Arg1);
2901             end if;
2902
2903             if Prag_Id /= Pragma_Volatile then
2904                Set_Atomic (E);
2905                Set_Atomic (Underlying_Type (E));
2906                Set_Atomic (Base_Type (E));
2907             end if;
2908
2909             --  Attribute belongs on the base type. If the view of the type is
2910             --  currently private, it also belongs on the underlying type.
2911
2912             Set_Is_Volatile (Base_Type (E));
2913             Set_Is_Volatile (Underlying_Type (E));
2914
2915             Set_Treat_As_Volatile (E);
2916             Set_Treat_As_Volatile (Underlying_Type (E));
2917
2918          elsif K = N_Object_Declaration
2919            or else (K = N_Component_Declaration
2920                      and then Original_Record_Component (E) = E)
2921          then
2922             if Rep_Item_Too_Late (E, N) then
2923                return;
2924             end if;
2925
2926             if Prag_Id /= Pragma_Volatile then
2927                Set_Is_Atomic (E);
2928
2929                --  If the object declaration has an explicit initialization, a
2930                --  temporary may have to be created to hold the expression, to
2931                --  ensure that access to the object remain atomic.
2932
2933                if Nkind (Parent (E)) = N_Object_Declaration
2934                  and then Present (Expression (Parent (E)))
2935                then
2936                   Set_Has_Delayed_Freeze (E);
2937                end if;
2938
2939                --  An interesting improvement here. If an object of type X is
2940                --  declared atomic, and the type X is not atomic, that's a
2941                --  pity, since it may not have appropriate alignment etc. We
2942                --  can rescue this in the special case where the object and
2943                --  type are in the same unit by just setting the type as
2944                --  atomic, so that the back end will process it as atomic.
2945
2946                Utyp := Underlying_Type (Etype (E));
2947
2948                if Present (Utyp)
2949                  and then Sloc (E) > No_Location
2950                  and then Sloc (Utyp) > No_Location
2951                  and then
2952                    Get_Source_File_Index (Sloc (E)) =
2953                    Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
2954                then
2955                   Set_Is_Atomic (Underlying_Type (Etype (E)));
2956                end if;
2957             end if;
2958
2959             Set_Is_Volatile (E);
2960             Set_Treat_As_Volatile (E);
2961
2962          else
2963             Error_Pragma_Arg
2964               ("inappropriate entity for pragma%", Arg1);
2965          end if;
2966       end Process_Atomic_Shared_Volatile;
2967
2968       -------------------------------------------
2969       -- Process_Compile_Time_Warning_Or_Error --
2970       -------------------------------------------
2971
2972       procedure Process_Compile_Time_Warning_Or_Error is
2973          Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
2974
2975       begin
2976          Check_Arg_Count (2);
2977          Check_No_Identifiers;
2978          Check_Arg_Is_Static_Expression (Arg2, Standard_String);
2979          Analyze_And_Resolve (Arg1x, Standard_Boolean);
2980
2981          if Compile_Time_Known_Value (Arg1x) then
2982             if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
2983                declare
2984                   Str   : constant String_Id :=
2985                             Strval (Get_Pragma_Arg (Arg2));
2986                   Len   : constant Int := String_Length (Str);
2987                   Cont  : Boolean;
2988                   Ptr   : Nat;
2989                   CC    : Char_Code;
2990                   C     : Character;
2991                   Cent  : constant Entity_Id :=
2992                             Cunit_Entity (Current_Sem_Unit);
2993
2994                   Force : constant Boolean :=
2995                             Prag_Id = Pragma_Compile_Time_Warning
2996                               and then
2997                                 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
2998                               and then (Ekind (Cent) /= E_Package
2999                                           or else not In_Private_Part (Cent));
3000                   --  Set True if this is the warning case, and we are in the
3001                   --  visible part of a package spec, or in a subprogram spec,
3002                   --  in which case we want to force the client to see the
3003                   --  warning, even though it is not in the main unit.
3004
3005                begin
3006                   --  Loop through segments of message separated by line feeds.
3007                   --  We output these segments as separate messages with
3008                   --  continuation marks for all but the first.
3009
3010                   Cont := False;
3011                   Ptr := 1;
3012                   loop
3013                      Error_Msg_Strlen := 0;
3014
3015                      --  Loop to copy characters from argument to error message
3016                      --  string buffer.
3017
3018                      loop
3019                         exit when Ptr > Len;
3020                         CC := Get_String_Char (Str, Ptr);
3021                         Ptr := Ptr + 1;
3022
3023                         --  Ignore wide chars ??? else store character
3024
3025                         if In_Character_Range (CC) then
3026                            C := Get_Character (CC);
3027                            exit when C = ASCII.LF;
3028                            Error_Msg_Strlen := Error_Msg_Strlen + 1;
3029                            Error_Msg_String (Error_Msg_Strlen) := C;
3030                         end if;
3031                      end loop;
3032
3033                      --  Here with one line ready to go
3034
3035                      Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
3036
3037                      --  If this is a warning in a spec, then we want clients
3038                      --  to see the warning, so mark the message with the
3039                      --  special sequence !! to force the warning. In the case
3040                      --  of a package spec, we do not force this if we are in
3041                      --  the private part of the spec.
3042
3043                      if Force then
3044                         if Cont = False then
3045                            Error_Msg_N ("<~!!", Arg1);
3046                            Cont := True;
3047                         else
3048                            Error_Msg_N ("\<~!!", Arg1);
3049                         end if;
3050
3051                      --  Error, rather than warning, or in a body, so we do not
3052                      --  need to force visibility for client (error will be
3053                      --  output in any case, and this is the situation in which
3054                      --  we do not want a client to get a warning, since the
3055                      --  warning is in the body or the spec private part).
3056
3057                      else
3058                         if Cont = False then
3059                            Error_Msg_N ("<~", Arg1);
3060                            Cont := True;
3061                         else
3062                            Error_Msg_N ("\<~", Arg1);
3063                         end if;
3064                      end if;
3065
3066                      exit when Ptr > Len;
3067                   end loop;
3068                end;
3069             end if;
3070          end if;
3071       end Process_Compile_Time_Warning_Or_Error;
3072
3073       ------------------------
3074       -- Process_Convention --
3075       ------------------------
3076
3077       procedure Process_Convention
3078         (C   : out Convention_Id;
3079          Ent : out Entity_Id)
3080       is
3081          Id        : Node_Id;
3082          E         : Entity_Id;
3083          E1        : Entity_Id;
3084          Cname     : Name_Id;
3085          Comp_Unit : Unit_Number_Type;
3086
3087          procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
3088          --  Called if we have more than one Export/Import/Convention pragma.
3089          --  This is generally illegal, but we have a special case of allowing
3090          --  Import and Interface to coexist if they specify the convention in
3091          --  a consistent manner. We are allowed to do this, since Interface is
3092          --  an implementation defined pragma, and we choose to do it since we
3093          --  know Rational allows this combination. S is the entity id of the
3094          --  subprogram in question. This procedure also sets the special flag
3095          --  Import_Interface_Present in both pragmas in the case where we do
3096          --  have matching Import and Interface pragmas.
3097
3098          procedure Set_Convention_From_Pragma (E : Entity_Id);
3099          --  Set convention in entity E, and also flag that the entity has a
3100          --  convention pragma. If entity is for a private or incomplete type,
3101          --  also set convention and flag on underlying type. This procedure
3102          --  also deals with the special case of C_Pass_By_Copy convention.
3103
3104          -------------------------------
3105          -- Diagnose_Multiple_Pragmas --
3106          -------------------------------
3107
3108          procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
3109             Pdec : constant Node_Id := Declaration_Node (S);
3110             Decl : Node_Id;
3111             Err  : Boolean;
3112
3113             function Same_Convention (Decl : Node_Id) return Boolean;
3114             --  Decl is a pragma node. This function returns True if this
3115             --  pragma has a first argument that is an identifier with a
3116             --  Chars field corresponding to the Convention_Id C.
3117
3118             function Same_Name (Decl : Node_Id) return Boolean;
3119             --  Decl is a pragma node. This function returns True if this
3120             --  pragma has a second argument that is an identifier with a
3121             --  Chars field that matches the Chars of the current subprogram.
3122
3123             ---------------------
3124             -- Same_Convention --
3125             ---------------------
3126
3127             function Same_Convention (Decl : Node_Id) return Boolean is
3128                Arg1 : constant Node_Id :=
3129                         First (Pragma_Argument_Associations (Decl));
3130
3131             begin
3132                if Present (Arg1) then
3133                   declare
3134                      Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
3135                   begin
3136                      if Nkind (Arg) = N_Identifier
3137                        and then Is_Convention_Name (Chars (Arg))
3138                        and then Get_Convention_Id (Chars (Arg)) = C
3139                      then
3140                         return True;
3141                      end if;
3142                   end;
3143                end if;
3144
3145                return False;
3146             end Same_Convention;
3147
3148             ---------------
3149             -- Same_Name --
3150             ---------------
3151
3152             function Same_Name (Decl : Node_Id) return Boolean is
3153                Arg1 : constant Node_Id :=
3154                         First (Pragma_Argument_Associations (Decl));
3155                Arg2 : Node_Id;
3156
3157             begin
3158                if No (Arg1) then
3159                   return False;
3160                end if;
3161
3162                Arg2 := Next (Arg1);
3163
3164                if No (Arg2) then
3165                   return False;
3166                end if;
3167
3168                declare
3169                   Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
3170                begin
3171                   if Nkind (Arg) = N_Identifier
3172                     and then Chars (Arg) = Chars (S)
3173                   then
3174                      return True;
3175                   end if;
3176                end;
3177
3178                return False;
3179             end Same_Name;
3180
3181          --  Start of processing for Diagnose_Multiple_Pragmas
3182
3183          begin
3184             Err := True;
3185
3186             --  Definitely give message if we have Convention/Export here
3187
3188             if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
3189                null;
3190
3191                --  If we have an Import or Export, scan back from pragma to
3192                --  find any previous pragma applying to the same procedure.
3193                --  The scan will be terminated by the start of the list, or
3194                --  hitting the subprogram declaration. This won't allow one
3195                --  pragma to appear in the public part and one in the private
3196                --  part, but that seems very unlikely in practice.
3197
3198             else
3199                Decl := Prev (N);
3200                while Present (Decl) and then Decl /= Pdec loop
3201
3202                   --  Look for pragma with same name as us
3203
3204                   if Nkind (Decl) = N_Pragma
3205                     and then Same_Name (Decl)
3206                   then
3207                      --  Give error if same as our pragma or Export/Convention
3208
3209                      if Pragma_Name (Decl) = Name_Export
3210                           or else
3211                         Pragma_Name (Decl) = Name_Convention
3212                           or else
3213                         Pragma_Name (Decl) = Pragma_Name (N)
3214                      then
3215                         exit;
3216
3217                      --  Case of Import/Interface or the other way round
3218