OSDN Git Service

e175a7275c59257f39136214de7eb1e623473e75
[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-2012, 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          Class_Wide_Condition : 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          --  Start of processing for Class_Wide_Condition
369
370          begin
371             if not Present (T) then
372                Error_Msg_Name_1 :=
373                  Chars (Identifier (Corresponding_Aspect (N)));
374
375                Error_Msg_Name_2 := Name_Class;
376
377                Error_Msg_N
378                  ("aspect `%''%` can only be specified for a primitive " &
379                   "operation of a tagged type",
380                   Corresponding_Aspect (N));
381             end if;
382
383             Replace_Type (Get_Pragma_Arg (Arg1));
384          end Class_Wide_Condition;
385       end if;
386
387       --  Remove the subprogram from the scope stack now that the pre-analysis
388       --  of the precondition/postcondition is done.
389
390       End_Scope;
391    end Analyze_PPC_In_Decl_Part;
392
393    --------------------
394    -- Analyze_Pragma --
395    --------------------
396
397    procedure Analyze_Pragma (N : Node_Id) is
398       Loc     : constant Source_Ptr := Sloc (N);
399       Prag_Id : Pragma_Id;
400
401       Pname : Name_Id;
402       --  Name of the source pragma, or name of the corresponding aspect for
403       --  pragmas which originate in a source aspect. In the latter case, the
404       --  name may be different from the pragma name.
405
406       Pragma_Exit : exception;
407       --  This exception is used to exit pragma processing completely. It is
408       --  used when an error is detected, and no further processing is
409       --  required. It is also used if an earlier error has left the tree in
410       --  a state where the pragma should not be processed.
411
412       Arg_Count : Nat;
413       --  Number of pragma argument associations
414
415       Arg1 : Node_Id;
416       Arg2 : Node_Id;
417       Arg3 : Node_Id;
418       Arg4 : Node_Id;
419       --  First four pragma arguments (pragma argument association nodes, or
420       --  Empty if the corresponding argument does not exist).
421
422       type Name_List is array (Natural range <>) of Name_Id;
423       type Args_List is array (Natural range <>) of Node_Id;
424       --  Types used for arguments to Check_Arg_Order and Gather_Associations
425
426       procedure Ada_2005_Pragma;
427       --  Called for pragmas defined in Ada 2005, that are not in Ada 95. In
428       --  Ada 95 mode, these are implementation defined pragmas, so should be
429       --  caught by the No_Implementation_Pragmas restriction.
430
431       procedure Ada_2012_Pragma;
432       --  Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
433       --  In Ada 95 or 05 mode, these are implementation defined pragmas, so
434       --  should be caught by the No_Implementation_Pragmas restriction.
435
436       procedure Check_Ada_83_Warning;
437       --  Issues a warning message for the current pragma if operating in Ada
438       --  83 mode (used for language pragmas that are not a standard part of
439       --  Ada 83). This procedure does not raise Error_Pragma. Also notes use
440       --  of 95 pragma.
441
442       procedure Check_Arg_Count (Required : Nat);
443       --  Check argument count for pragma is equal to given parameter. If not,
444       --  then issue an error message and raise Pragma_Exit.
445
446       --  Note: all routines whose name is Check_Arg_Is_xxx take an argument
447       --  Arg which can either be a pragma argument association, in which case
448       --  the check is applied to the expression of the association or an
449       --  expression directly.
450
451       procedure Check_Arg_Is_External_Name (Arg : Node_Id);
452       --  Check that an argument has the right form for an EXTERNAL_NAME
453       --  parameter of an extended import/export pragma. The rule is that the
454       --  name must be an identifier or string literal (in Ada 83 mode) or a
455       --  static string expression (in Ada 95 mode).
456
457       procedure Check_Arg_Is_Identifier (Arg : Node_Id);
458       --  Check the specified argument Arg to make sure that it is an
459       --  identifier. If not give error and raise Pragma_Exit.
460
461       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
462       --  Check the specified argument Arg to make sure that it is an integer
463       --  literal. If not give error and raise Pragma_Exit.
464
465       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
466       --  Check the specified argument Arg to make sure that it has the proper
467       --  syntactic form for a local name and meets the semantic requirements
468       --  for a local name. The local name is analyzed as part of the
469       --  processing for this call. In addition, the local name is required
470       --  to represent an entity at the library level.
471
472       procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
473       --  Check the specified argument Arg to make sure that it has the proper
474       --  syntactic form for a local name and meets the semantic requirements
475       --  for a local name. The local name is analyzed as part of the
476       --  processing for this call.
477
478       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
479       --  Check the specified argument Arg to make sure that it is a valid
480       --  locking policy name. If not give error and raise Pragma_Exit.
481
482       procedure Check_Arg_Is_One_Of
483         (Arg                : Node_Id;
484          N1, N2             : Name_Id);
485       procedure Check_Arg_Is_One_Of
486         (Arg                : Node_Id;
487          N1, N2, N3         : Name_Id);
488       procedure Check_Arg_Is_One_Of
489         (Arg                : Node_Id;
490          N1, N2, N3, N4     : Name_Id);
491       procedure Check_Arg_Is_One_Of
492         (Arg                : Node_Id;
493          N1, N2, N3, N4, N5 : Name_Id);
494       --  Check the specified argument Arg to make sure that it is an
495       --  identifier whose name matches either N1 or N2 (or N3, N4, N5 if
496       --  present). If not then give error and raise Pragma_Exit.
497
498       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
499       --  Check the specified argument Arg to make sure that it is a valid
500       --  queuing policy name. If not give error and raise Pragma_Exit.
501
502       procedure Check_Arg_Is_Static_Expression
503         (Arg : Node_Id;
504          Typ : Entity_Id := Empty);
505       --  Check the specified argument Arg to make sure that it is a static
506       --  expression of the given type (i.e. it will be analyzed and resolved
507       --  using this type, which can be any valid argument to Resolve, e.g.
508       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
509       --  Typ is left Empty, then any static expression is allowed.
510
511       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
512       --  Check the specified argument Arg to make sure that it is a valid task
513       --  dispatching policy name. If not give error and raise Pragma_Exit.
514
515       procedure Check_Arg_Order (Names : Name_List);
516       --  Checks for an instance of two arguments with identifiers for the
517       --  current pragma which are not in the sequence indicated by Names,
518       --  and if so, generates a fatal message about bad order of arguments.
519
520       procedure Check_At_Least_N_Arguments (N : Nat);
521       --  Check there are at least N arguments present
522
523       procedure Check_At_Most_N_Arguments (N : Nat);
524       --  Check there are no more than N arguments present
525
526       procedure Check_Component
527         (Comp            : Node_Id;
528          UU_Typ          : Entity_Id;
529          In_Variant_Part : Boolean := False);
530       --  Examine an Unchecked_Union component for correct use of per-object
531       --  constrained subtypes, and for restrictions on finalizable components.
532       --  UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
533       --  should be set when Comp comes from a record variant.
534
535       procedure Check_Duplicate_Pragma (E : Entity_Id);
536       --  Check if a pragma of the same name as the current pragma is already
537       --  chained as a rep pragma to the given entity. If so give a message
538       --  about the duplicate, and then raise Pragma_Exit so does not return.
539       --  Also checks for delayed aspect specification node in the chain.
540
541       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
542       --  Nam is an N_String_Literal node containing the external name set by
543       --  an Import or Export pragma (or extended Import or Export pragma).
544       --  This procedure checks for possible duplications if this is the export
545       --  case, and if found, issues an appropriate error message.
546
547       procedure Check_Expr_Is_Static_Expression
548         (Expr : Node_Id;
549          Typ  : Entity_Id := Empty);
550       --  Check the specified expression Expr to make sure that it is a static
551       --  expression of the given type (i.e. it will be analyzed and resolved
552       --  using this type, which can be any valid argument to Resolve, e.g.
553       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
554       --  Typ is left Empty, then any static expression is allowed.
555
556       procedure Check_First_Subtype (Arg : Node_Id);
557       --  Checks that Arg, whose expression is an entity name, references a
558       --  first subtype.
559
560       procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
561       --  Checks that the given argument has an identifier, and if so, requires
562       --  it to match the given identifier name. If there is no identifier, or
563       --  a non-matching identifier, then an error message is given and
564       --  Pragma_Exit is raised.
565
566       procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
567       --  Checks that the given argument has an identifier, and if so, requires
568       --  it to match one of the given identifier names. If there is no
569       --  identifier, or a non-matching identifier, then an error message is
570       --  given and Pragma_Exit is raised.
571
572       procedure Check_In_Main_Program;
573       --  Common checks for pragmas that appear within a main program
574       --  (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
575
576       procedure Check_Interrupt_Or_Attach_Handler;
577       --  Common processing for first argument of pragma Interrupt_Handler or
578       --  pragma Attach_Handler.
579
580       procedure Check_Is_In_Decl_Part_Or_Package_Spec;
581       --  Check that pragma appears in a declarative part, or in a package
582       --  specification, i.e. that it does not occur in a statement sequence
583       --  in a body.
584
585       procedure Check_No_Identifier (Arg : Node_Id);
586       --  Checks that the given argument does not have an identifier. If
587       --  an identifier is present, then an error message is issued, and
588       --  Pragma_Exit is raised.
589
590       procedure Check_No_Identifiers;
591       --  Checks that none of the arguments to the pragma has an identifier.
592       --  If any argument has an identifier, then an error message is issued,
593       --  and Pragma_Exit is raised.
594
595       procedure Check_No_Link_Name;
596       --  Checks that no link name is specified
597
598       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
599       --  Checks if the given argument has an identifier, and if so, requires
600       --  it to match the given identifier name. If there is a non-matching
601       --  identifier, then an error message is given and Pragma_Exit is raised.
602
603       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
604       --  Checks if the given argument has an identifier, and if so, requires
605       --  it to match the given identifier name. If there is a non-matching
606       --  identifier, then an error message is given and Pragma_Exit is raised.
607       --  In this version of the procedure, the identifier name is given as
608       --  a string with lower case letters.
609
610       procedure Check_Precondition_Postcondition (In_Body : out Boolean);
611       --  Called to process a precondition or postcondition pragma. There are
612       --  three cases:
613       --
614       --    The pragma appears after a subprogram spec
615       --
616       --      If the corresponding check is not enabled, the pragma is analyzed
617       --      but otherwise ignored and control returns with In_Body set False.
618       --
619       --      If the check is enabled, then the first step is to analyze the
620       --      pragma, but this is skipped if the subprogram spec appears within
621       --      a package specification (because this is the case where we delay
622       --      analysis till the end of the spec). Then (whether or not it was
623       --      analyzed), the pragma is chained to the subprogram in question
624       --      (using Spec_PPC_List and Next_Pragma) and control returns to the
625       --      caller with In_Body set False.
626       --
627       --    The pragma appears at the start of subprogram body declarations
628       --
629       --      In this case an immediate return to the caller is made with
630       --      In_Body set True, and the pragma is NOT analyzed.
631       --
632       --    In all other cases, an error message for bad placement is given
633
634       procedure Check_Static_Constraint (Constr : Node_Id);
635       --  Constr is a constraint from an N_Subtype_Indication node from a
636       --  component constraint in an Unchecked_Union type. This routine checks
637       --  that the constraint is static as required by the restrictions for
638       --  Unchecked_Union.
639
640       procedure Check_Test_Case;
641       --  Called to process a test-case pragma. The treatment is similar to the
642       --  one for pre- and postcondition in Check_Precondition_Postcondition,
643       --  except the placement rules for the test-case pragma are stricter.
644       --  This pragma may only occur after a subprogram spec declared directly
645       --  in a package spec unit. In this case, the pragma is chained to the
646       --  subprogram in question (using Spec_TC_List and Next_Pragma) and
647       --  analysis of the pragma is delayed till the end of the spec. In
648       --  all other cases, an error message for bad placement is given.
649
650       procedure Check_Valid_Configuration_Pragma;
651       --  Legality checks for placement of a configuration pragma
652
653       procedure Check_Valid_Library_Unit_Pragma;
654       --  Legality checks for library unit pragmas. A special case arises for
655       --  pragmas in generic instances that come from copies of the original
656       --  library unit pragmas in the generic templates. In the case of other
657       --  than library level instantiations these can appear in contexts which
658       --  would normally be invalid (they only apply to the original template
659       --  and to library level instantiations), and they are simply ignored,
660       --  which is implemented by rewriting them as null statements.
661
662       procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
663       --  Check an Unchecked_Union variant for lack of nested variants and
664       --  presence of at least one component. UU_Typ is the related Unchecked_
665       --  Union type.
666
667       procedure Error_Pragma (Msg : String);
668       pragma No_Return (Error_Pragma);
669       --  Outputs error message for current pragma. The message contains a %
670       --  that will be replaced with the pragma name, and the flag is placed
671       --  on the pragma itself. Pragma_Exit is then raised.
672
673       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
674       pragma No_Return (Error_Pragma_Arg);
675       --  Outputs error message for current pragma. The message may contain
676       --  a % that will be replaced with the pragma name. The parameter Arg
677       --  may either be a pragma argument association, in which case the flag
678       --  is placed on the expression of this association, or an expression,
679       --  in which case the flag is placed directly on the expression. The
680       --  message is placed using Error_Msg_N, so the message may also contain
681       --  an & insertion character which will reference the given Arg value.
682       --  After placing the message, Pragma_Exit is raised.
683
684       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
685       pragma No_Return (Error_Pragma_Arg);
686       --  Similar to above form of Error_Pragma_Arg except that two messages
687       --  are provided, the second is a continuation comment starting with \.
688
689       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
690       pragma No_Return (Error_Pragma_Arg_Ident);
691       --  Outputs error message for current pragma. The message may contain
692       --  a % that will be replaced with the pragma name. The parameter Arg
693       --  must be a pragma argument association with a non-empty identifier
694       --  (i.e. its Chars field must be set), and the error message is placed
695       --  on the identifier. The message is placed using Error_Msg_N so
696       --  the message may also contain an & insertion character which will
697       --  reference the identifier. After placing the message, Pragma_Exit
698       --  is raised.
699
700       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
701       pragma No_Return (Error_Pragma_Ref);
702       --  Outputs error message for current pragma. The message may contain
703       --  a % that will be replaced with the pragma name. The parameter Ref
704       --  must be an entity whose name can be referenced by & and sloc by #.
705       --  After placing the message, Pragma_Exit is raised.
706
707       function Find_Lib_Unit_Name return Entity_Id;
708       --  Used for a library unit pragma to find the entity to which the
709       --  library unit pragma applies, returns the entity found.
710
711       procedure Find_Program_Unit_Name (Id : Node_Id);
712       --  If the pragma is a compilation unit pragma, the id must denote the
713       --  compilation unit in the same compilation, and the pragma must appear
714       --  in the list of preceding or trailing pragmas. If it is a program
715       --  unit pragma that is not a compilation unit pragma, then the
716       --  identifier must be visible.
717
718       function Find_Unique_Parameterless_Procedure
719         (Name : Entity_Id;
720          Arg  : Node_Id) return Entity_Id;
721       --  Used for a procedure pragma to find the unique parameterless
722       --  procedure identified by Name, returns it if it exists, otherwise
723       --  errors out and uses Arg as the pragma argument for the message.
724
725       procedure Fix_Error (Msg : in out String);
726       --  This is called prior to issuing an error message. Msg is a string
727       --  that typically contains the substring "pragma". If the current pragma
728       --  comes from an aspect, each such "pragma" substring is replaced with
729       --  the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
730       --  (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
731
732       procedure Gather_Associations
733         (Names : Name_List;
734          Args  : out Args_List);
735       --  This procedure is used to gather the arguments for a pragma that
736       --  permits arbitrary ordering of parameters using the normal rules
737       --  for named and positional parameters. The Names argument is a list
738       --  of Name_Id values that corresponds to the allowed pragma argument
739       --  association identifiers in order. The result returned in Args is
740       --  a list of corresponding expressions that are the pragma arguments.
741       --  Note that this is a list of expressions, not of pragma argument
742       --  associations (Gather_Associations has completely checked all the
743       --  optional identifiers when it returns). An entry in Args is Empty
744       --  on return if the corresponding argument is not present.
745
746       procedure GNAT_Pragma;
747       --  Called for all GNAT defined pragmas to check the relevant restriction
748       --  (No_Implementation_Pragmas).
749
750       function Is_Before_First_Decl
751         (Pragma_Node : Node_Id;
752          Decls       : List_Id) return Boolean;
753       --  Return True if Pragma_Node is before the first declarative item in
754       --  Decls where Decls is the list of declarative items.
755
756       function Is_Configuration_Pragma return Boolean;
757       --  Determines if the placement of the current pragma is appropriate
758       --  for a configuration pragma.
759
760       function Is_In_Context_Clause return Boolean;
761       --  Returns True if pragma appears within the context clause of a unit,
762       --  and False for any other placement (does not generate any messages).
763
764       function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
765       --  Analyzes the argument, and determines if it is a static string
766       --  expression, returns True if so, False if non-static or not String.
767
768       procedure Pragma_Misplaced;
769       pragma No_Return (Pragma_Misplaced);
770       --  Issue fatal error message for misplaced pragma
771
772       procedure Process_Atomic_Shared_Volatile;
773       --  Common processing for pragmas Atomic, Shared, Volatile. Note that
774       --  Shared is an obsolete Ada 83 pragma, treated as being identical
775       --  in effect to pragma Atomic.
776
777       procedure Process_Compile_Time_Warning_Or_Error;
778       --  Common processing for Compile_Time_Error and Compile_Time_Warning
779
780       procedure Process_Convention
781         (C   : out Convention_Id;
782          Ent : out Entity_Id);
783       --  Common processing for Convention, Interface, Import and Export.
784       --  Checks first two arguments of pragma, and sets the appropriate
785       --  convention value in the specified entity or entities. On return
786       --  C is the convention, Ent is the referenced entity.
787
788       procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
789       --  Common processing for Disable/Enable_Atomic_Synchronization. Nam is
790       --  Name_Suppress for Disable and Name_Unsuppress for Enable.
791
792       procedure Process_Extended_Import_Export_Exception_Pragma
793         (Arg_Internal : Node_Id;
794          Arg_External : Node_Id;
795          Arg_Form     : Node_Id;
796          Arg_Code     : Node_Id);
797       --  Common processing for the pragmas Import/Export_Exception. The three
798       --  arguments correspond to the three named parameters of the pragma. An
799       --  argument is empty if the corresponding parameter is not present in
800       --  the pragma.
801
802       procedure Process_Extended_Import_Export_Object_Pragma
803         (Arg_Internal : Node_Id;
804          Arg_External : Node_Id;
805          Arg_Size     : Node_Id);
806       --  Common processing for the pragmas Import/Export_Object. The three
807       --  arguments correspond to the three named parameters of the pragmas. An
808       --  argument is empty if the corresponding parameter is not present in
809       --  the pragma.
810
811       procedure Process_Extended_Import_Export_Internal_Arg
812         (Arg_Internal : Node_Id := Empty);
813       --  Common processing for all extended Import and Export pragmas. The
814       --  argument is the pragma parameter for the Internal argument. If
815       --  Arg_Internal is empty or inappropriate, an error message is posted.
816       --  Otherwise, on normal return, the Entity_Field of Arg_Internal is
817       --  set to identify the referenced entity.
818
819       procedure Process_Extended_Import_Export_Subprogram_Pragma
820         (Arg_Internal                 : Node_Id;
821          Arg_External                 : Node_Id;
822          Arg_Parameter_Types          : Node_Id;
823          Arg_Result_Type              : Node_Id := Empty;
824          Arg_Mechanism                : Node_Id;
825          Arg_Result_Mechanism         : Node_Id := Empty;
826          Arg_First_Optional_Parameter : Node_Id := Empty);
827       --  Common processing for all extended Import and Export pragmas applying
828       --  to subprograms. The caller omits any arguments that do not apply to
829       --  the pragma in question (for example, Arg_Result_Type can be non-Empty
830       --  only in the Import_Function and Export_Function cases). The argument
831       --  names correspond to the allowed pragma association identifiers.
832
833       procedure Process_Generic_List;
834       --  Common processing for Share_Generic and Inline_Generic
835
836       procedure Process_Import_Or_Interface;
837       --  Common processing for Import of Interface
838
839       procedure Process_Import_Predefined_Type;
840       --  Processing for completing a type with pragma Import. This is used
841       --  to declare types that match predefined C types, especially for cases
842       --  without corresponding Ada predefined type.
843
844       procedure Process_Inline (Active : Boolean);
845       --  Common processing for Inline and Inline_Always. The parameter
846       --  indicates if the inline pragma is active, i.e. if it should actually
847       --  cause inlining to occur.
848
849       procedure Process_Interface_Name
850         (Subprogram_Def : Entity_Id;
851          Ext_Arg        : Node_Id;
852          Link_Arg       : Node_Id);
853       --  Given the last two arguments of pragma Import, pragma Export, or
854       --  pragma Interface_Name, performs validity checks and sets the
855       --  Interface_Name field of the given subprogram entity to the
856       --  appropriate external or link name, depending on the arguments given.
857       --  Ext_Arg is always present, but Link_Arg may be missing. Note that
858       --  Ext_Arg may represent the Link_Name if Link_Arg is missing, and
859       --  appropriate named notation is used for Ext_Arg. If neither Ext_Arg
860       --  nor Link_Arg is present, the interface name is set to the default
861       --  from the subprogram name.
862
863       procedure Process_Interrupt_Or_Attach_Handler;
864       --  Common processing for Interrupt and Attach_Handler pragmas
865
866       procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
867       --  Common processing for Restrictions and Restriction_Warnings pragmas.
868       --  Warn is True for Restriction_Warnings, or for Restrictions if the
869       --  flag Treat_Restrictions_As_Warnings is set, and False if this flag
870       --  is not set in the Restrictions case.
871
872       procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
873       --  Common processing for Suppress and Unsuppress. The boolean parameter
874       --  Suppress_Case is True for the Suppress case, and False for the
875       --  Unsuppress case.
876
877       procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
878       --  This procedure sets the Is_Exported flag for the given entity,
879       --  checking that the entity was not previously imported. Arg is
880       --  the argument that specified the entity. A check is also made
881       --  for exporting inappropriate entities.
882
883       procedure Set_Extended_Import_Export_External_Name
884         (Internal_Ent : Entity_Id;
885          Arg_External : Node_Id);
886       --  Common processing for all extended import export pragmas. The first
887       --  argument, Internal_Ent, is the internal entity, which has already
888       --  been checked for validity by the caller. Arg_External is from the
889       --  Import or Export pragma, and may be null if no External parameter
890       --  was present. If Arg_External is present and is a non-null string
891       --  (a null string is treated as the default), then the Interface_Name
892       --  field of Internal_Ent is set appropriately.
893
894       procedure Set_Imported (E : Entity_Id);
895       --  This procedure sets the Is_Imported flag for the given entity,
896       --  checking that it is not previously exported or imported.
897
898       procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
899       --  Mech is a parameter passing mechanism (see Import_Function syntax
900       --  for MECHANISM_NAME). This routine checks that the mechanism argument
901       --  has the right form, and if not issues an error message. If the
902       --  argument has the right form then the Mechanism field of Ent is
903       --  set appropriately.
904
905       procedure Set_Ravenscar_Profile (N : Node_Id);
906       --  Activate the set of configuration pragmas and restrictions that make
907       --  up the Ravenscar Profile. N is the corresponding pragma node, which
908       --  is used for error messages on any constructs that violate the
909       --  profile.
910
911       ---------------------
912       -- Ada_2005_Pragma --
913       ---------------------
914
915       procedure Ada_2005_Pragma is
916       begin
917          if Ada_Version <= Ada_95 then
918             Check_Restriction (No_Implementation_Pragmas, N);
919          end if;
920       end Ada_2005_Pragma;
921
922       ---------------------
923       -- Ada_2012_Pragma --
924       ---------------------
925
926       procedure Ada_2012_Pragma is
927       begin
928          if Ada_Version <= Ada_2005 then
929             Check_Restriction (No_Implementation_Pragmas, N);
930          end if;
931       end Ada_2012_Pragma;
932
933       --------------------------
934       -- Check_Ada_83_Warning --
935       --------------------------
936
937       procedure Check_Ada_83_Warning is
938       begin
939          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
940             Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
941          end if;
942       end Check_Ada_83_Warning;
943
944       ---------------------
945       -- Check_Arg_Count --
946       ---------------------
947
948       procedure Check_Arg_Count (Required : Nat) is
949       begin
950          if Arg_Count /= Required then
951             Error_Pragma ("wrong number of arguments for pragma%");
952          end if;
953       end Check_Arg_Count;
954
955       --------------------------------
956       -- Check_Arg_Is_External_Name --
957       --------------------------------
958
959       procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
960          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
961
962       begin
963          if Nkind (Argx) = N_Identifier then
964             return;
965
966          else
967             Analyze_And_Resolve (Argx, Standard_String);
968
969             if Is_OK_Static_Expression (Argx) then
970                return;
971
972             elsif Etype (Argx) = Any_Type then
973                raise Pragma_Exit;
974
975             --  An interesting special case, if we have a string literal and
976             --  we are in Ada 83 mode, then we allow it even though it will
977             --  not be flagged as static. This allows expected Ada 83 mode
978             --  use of external names which are string literals, even though
979             --  technically these are not static in Ada 83.
980
981             elsif Ada_Version = Ada_83
982               and then Nkind (Argx) = N_String_Literal
983             then
984                return;
985
986             --  Static expression that raises Constraint_Error. This has
987             --  already been flagged, so just exit from pragma processing.
988
989             elsif Is_Static_Expression (Argx) then
990                raise Pragma_Exit;
991
992             --  Here we have a real error (non-static expression)
993
994             else
995                Error_Msg_Name_1 := Pname;
996
997                declare
998                   Msg : String :=
999                           "argument for pragma% must be a identifier or "
1000                           & "static string expression!";
1001                begin
1002                   Fix_Error (Msg);
1003                   Flag_Non_Static_Expr (Msg, Argx);
1004                   raise Pragma_Exit;
1005                end;
1006             end if;
1007          end if;
1008       end Check_Arg_Is_External_Name;
1009
1010       -----------------------------
1011       -- Check_Arg_Is_Identifier --
1012       -----------------------------
1013
1014       procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
1015          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1016       begin
1017          if Nkind (Argx) /= N_Identifier then
1018             Error_Pragma_Arg
1019               ("argument for pragma% must be identifier", Argx);
1020          end if;
1021       end Check_Arg_Is_Identifier;
1022
1023       ----------------------------------
1024       -- Check_Arg_Is_Integer_Literal --
1025       ----------------------------------
1026
1027       procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
1028          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1029       begin
1030          if Nkind (Argx) /= N_Integer_Literal then
1031             Error_Pragma_Arg
1032               ("argument for pragma% must be integer literal", Argx);
1033          end if;
1034       end Check_Arg_Is_Integer_Literal;
1035
1036       -------------------------------------------
1037       -- Check_Arg_Is_Library_Level_Local_Name --
1038       -------------------------------------------
1039
1040       --  LOCAL_NAME ::=
1041       --    DIRECT_NAME
1042       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1043       --  | library_unit_NAME
1044
1045       procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
1046       begin
1047          Check_Arg_Is_Local_Name (Arg);
1048
1049          if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
1050            and then Comes_From_Source (N)
1051          then
1052             Error_Pragma_Arg
1053               ("argument for pragma% must be library level entity", Arg);
1054          end if;
1055       end Check_Arg_Is_Library_Level_Local_Name;
1056
1057       -----------------------------
1058       -- Check_Arg_Is_Local_Name --
1059       -----------------------------
1060
1061       --  LOCAL_NAME ::=
1062       --    DIRECT_NAME
1063       --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
1064       --  | library_unit_NAME
1065
1066       procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
1067          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1068
1069       begin
1070          Analyze (Argx);
1071
1072          if Nkind (Argx) not in N_Direct_Name
1073            and then (Nkind (Argx) /= N_Attribute_Reference
1074                       or else Present (Expressions (Argx))
1075                       or else Nkind (Prefix (Argx)) /= N_Identifier)
1076            and then (not Is_Entity_Name (Argx)
1077                       or else not Is_Compilation_Unit (Entity (Argx)))
1078          then
1079             Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
1080          end if;
1081
1082          --  No further check required if not an entity name
1083
1084          if not Is_Entity_Name (Argx) then
1085             null;
1086
1087          else
1088             declare
1089                OK   : Boolean;
1090                Ent  : constant Entity_Id := Entity (Argx);
1091                Scop : constant Entity_Id := Scope (Ent);
1092             begin
1093                --  Case of a pragma applied to a compilation unit: pragma must
1094                --  occur immediately after the program unit in the compilation.
1095
1096                if Is_Compilation_Unit (Ent) then
1097                   declare
1098                      Decl : constant Node_Id := Unit_Declaration_Node (Ent);
1099
1100                   begin
1101                      --  Case of pragma placed immediately after spec
1102
1103                      if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
1104                         OK := True;
1105
1106                      --  Case of pragma placed immediately after body
1107
1108                      elsif Nkind (Decl) = N_Subprogram_Declaration
1109                              and then Present (Corresponding_Body (Decl))
1110                      then
1111                         OK := Parent (N) =
1112                                 Aux_Decls_Node
1113                                   (Parent (Unit_Declaration_Node
1114                                              (Corresponding_Body (Decl))));
1115
1116                      --  All other cases are illegal
1117
1118                      else
1119                         OK := False;
1120                      end if;
1121                   end;
1122
1123                --  Special restricted placement rule from 10.2.1(11.8/2)
1124
1125                elsif Is_Generic_Formal (Ent)
1126                        and then Prag_Id = Pragma_Preelaborable_Initialization
1127                then
1128                   OK := List_Containing (N) =
1129                           Generic_Formal_Declarations
1130                             (Unit_Declaration_Node (Scop));
1131
1132                --  Default case, just check that the pragma occurs in the scope
1133                --  of the entity denoted by the name.
1134
1135                else
1136                   OK := Current_Scope = Scop;
1137                end if;
1138
1139                if not OK then
1140                   Error_Pragma_Arg
1141                     ("pragma% argument must be in same declarative part", Arg);
1142                end if;
1143             end;
1144          end if;
1145       end Check_Arg_Is_Local_Name;
1146
1147       ---------------------------------
1148       -- Check_Arg_Is_Locking_Policy --
1149       ---------------------------------
1150
1151       procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
1152          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1153
1154       begin
1155          Check_Arg_Is_Identifier (Argx);
1156
1157          if not Is_Locking_Policy_Name (Chars (Argx)) then
1158             Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
1159          end if;
1160       end Check_Arg_Is_Locking_Policy;
1161
1162       -------------------------
1163       -- Check_Arg_Is_One_Of --
1164       -------------------------
1165
1166       procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1167          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1168
1169       begin
1170          Check_Arg_Is_Identifier (Argx);
1171
1172          if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
1173             Error_Msg_Name_2 := N1;
1174             Error_Msg_Name_3 := N2;
1175             Error_Pragma_Arg ("argument for pragma% must be% or%", 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 : 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          then
1192             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1193          end if;
1194       end Check_Arg_Is_One_Of;
1195
1196       procedure Check_Arg_Is_One_Of
1197         (Arg                : Node_Id;
1198          N1, N2, N3, N4     : Name_Id)
1199       is
1200          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1201
1202       begin
1203          Check_Arg_Is_Identifier (Argx);
1204
1205          if Chars (Argx) /= N1
1206            and then Chars (Argx) /= N2
1207            and then Chars (Argx) /= N3
1208            and then Chars (Argx) /= N4
1209          then
1210             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1211          end if;
1212       end Check_Arg_Is_One_Of;
1213
1214       procedure Check_Arg_Is_One_Of
1215         (Arg                : Node_Id;
1216          N1, N2, N3, N4, N5 : Name_Id)
1217       is
1218          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1219
1220       begin
1221          Check_Arg_Is_Identifier (Argx);
1222
1223          if Chars (Argx) /= N1
1224            and then Chars (Argx) /= N2
1225            and then Chars (Argx) /= N3
1226            and then Chars (Argx) /= N4
1227            and then Chars (Argx) /= N5
1228          then
1229             Error_Pragma_Arg ("invalid argument for pragma%", Argx);
1230          end if;
1231       end Check_Arg_Is_One_Of;
1232       ---------------------------------
1233       -- Check_Arg_Is_Queuing_Policy --
1234       ---------------------------------
1235
1236       procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
1237          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1238
1239       begin
1240          Check_Arg_Is_Identifier (Argx);
1241
1242          if not Is_Queuing_Policy_Name (Chars (Argx)) then
1243             Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
1244          end if;
1245       end Check_Arg_Is_Queuing_Policy;
1246
1247       ------------------------------------
1248       -- Check_Arg_Is_Static_Expression --
1249       ------------------------------------
1250
1251       procedure Check_Arg_Is_Static_Expression
1252         (Arg : Node_Id;
1253          Typ : Entity_Id := Empty)
1254       is
1255       begin
1256          Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
1257       end Check_Arg_Is_Static_Expression;
1258
1259       ------------------------------------------
1260       -- Check_Arg_Is_Task_Dispatching_Policy --
1261       ------------------------------------------
1262
1263       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
1264          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1265
1266       begin
1267          Check_Arg_Is_Identifier (Argx);
1268
1269          if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
1270             Error_Pragma_Arg
1271               ("& is not a valid task dispatching policy name", Argx);
1272          end if;
1273       end Check_Arg_Is_Task_Dispatching_Policy;
1274
1275       ---------------------
1276       -- Check_Arg_Order --
1277       ---------------------
1278
1279       procedure Check_Arg_Order (Names : Name_List) is
1280          Arg : Node_Id;
1281
1282          Highest_So_Far : Natural := 0;
1283          --  Highest index in Names seen do far
1284
1285       begin
1286          Arg := Arg1;
1287          for J in 1 .. Arg_Count loop
1288             if Chars (Arg) /= No_Name then
1289                for K in Names'Range loop
1290                   if Chars (Arg) = Names (K) then
1291                      if K < Highest_So_Far then
1292                         Error_Msg_Name_1 := Pname;
1293                         Error_Msg_N
1294                           ("parameters out of order for pragma%", Arg);
1295                         Error_Msg_Name_1 := Names (K);
1296                         Error_Msg_Name_2 := Names (Highest_So_Far);
1297                         Error_Msg_N ("\% must appear before %", Arg);
1298                         raise Pragma_Exit;
1299
1300                      else
1301                         Highest_So_Far := K;
1302                      end if;
1303                   end if;
1304                end loop;
1305             end if;
1306
1307             Arg := Next (Arg);
1308          end loop;
1309       end Check_Arg_Order;
1310
1311       --------------------------------
1312       -- Check_At_Least_N_Arguments --
1313       --------------------------------
1314
1315       procedure Check_At_Least_N_Arguments (N : Nat) is
1316       begin
1317          if Arg_Count < N then
1318             Error_Pragma ("too few arguments for pragma%");
1319          end if;
1320       end Check_At_Least_N_Arguments;
1321
1322       -------------------------------
1323       -- Check_At_Most_N_Arguments --
1324       -------------------------------
1325
1326       procedure Check_At_Most_N_Arguments (N : Nat) is
1327          Arg : Node_Id;
1328       begin
1329          if Arg_Count > N then
1330             Arg := Arg1;
1331             for J in 1 .. N loop
1332                Next (Arg);
1333                Error_Pragma_Arg ("too many arguments for pragma%", Arg);
1334             end loop;
1335          end if;
1336       end Check_At_Most_N_Arguments;
1337
1338       ---------------------
1339       -- Check_Component --
1340       ---------------------
1341
1342       procedure Check_Component
1343         (Comp            : Node_Id;
1344          UU_Typ          : Entity_Id;
1345          In_Variant_Part : Boolean := False)
1346       is
1347          Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
1348          Sindic  : constant Node_Id :=
1349                      Subtype_Indication (Component_Definition (Comp));
1350          Typ     : constant Entity_Id := Etype (Comp_Id);
1351
1352       begin
1353          --  Ada 2005 (AI-216): If a component subtype is subject to a per-
1354          --  object constraint, then the component type shall be an Unchecked_
1355          --  Union.
1356
1357          if Nkind (Sindic) = N_Subtype_Indication
1358            and then Has_Per_Object_Constraint (Comp_Id)
1359            and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
1360          then
1361             Error_Msg_N
1362               ("component subtype subject to per-object constraint " &
1363                "must be an Unchecked_Union", Comp);
1364
1365          --  Ada 2012 (AI05-0026): For an unchecked union type declared within
1366          --  the body of a generic unit, or within the body of any of its
1367          --  descendant library units, no part of the type of a component
1368          --  declared in a variant_part of the unchecked union type shall be of
1369          --  a formal private type or formal private extension declared within
1370          --  the formal part of the generic unit.
1371
1372          elsif Ada_Version >= Ada_2012
1373            and then In_Generic_Body (UU_Typ)
1374            and then In_Variant_Part
1375            and then Is_Private_Type (Typ)
1376            and then Is_Generic_Type (Typ)
1377          then
1378             Error_Msg_N
1379               ("component of Unchecked_Union cannot be of generic type", Comp);
1380
1381          elsif Needs_Finalization (Typ) then
1382             Error_Msg_N
1383               ("component of Unchecked_Union cannot be controlled", Comp);
1384
1385          elsif Has_Task (Typ) then
1386             Error_Msg_N
1387               ("component of Unchecked_Union cannot have tasks", Comp);
1388          end if;
1389       end Check_Component;
1390
1391       ----------------------------
1392       -- Check_Duplicate_Pragma --
1393       ----------------------------
1394
1395       procedure Check_Duplicate_Pragma (E : Entity_Id) is
1396          P : Node_Id;
1397
1398       begin
1399          --  Nothing to do if this pragma comes from an aspect specification,
1400          --  since we could not be duplicating a pragma, and we dealt with the
1401          --  case of duplicated aspects in Analyze_Aspect_Specifications.
1402
1403          if From_Aspect_Specification (N) then
1404             return;
1405          end if;
1406
1407          --  Otherwise current pragma may duplicate previous pragma or a
1408          --  previously given aspect specification for the same pragma.
1409
1410          P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
1411
1412          if Present (P) then
1413             Error_Msg_Name_1 := Pragma_Name (N);
1414             Error_Msg_Sloc := Sloc (P);
1415
1416             if Nkind (P) = N_Aspect_Specification
1417               or else From_Aspect_Specification (P)
1418             then
1419                Error_Msg_NE ("aspect% for & previously given#", N, E);
1420             else
1421                Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
1422             end if;
1423
1424             raise Pragma_Exit;
1425          end if;
1426       end Check_Duplicate_Pragma;
1427
1428       ----------------------------------
1429       -- Check_Duplicated_Export_Name --
1430       ----------------------------------
1431
1432       procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
1433          String_Val : constant String_Id := Strval (Nam);
1434
1435       begin
1436          --  We are only interested in the export case, and in the case of
1437          --  generics, it is the instance, not the template, that is the
1438          --  problem (the template will generate a warning in any case).
1439
1440          if not Inside_A_Generic
1441            and then (Prag_Id = Pragma_Export
1442                        or else
1443                      Prag_Id = Pragma_Export_Procedure
1444                        or else
1445                      Prag_Id = Pragma_Export_Valued_Procedure
1446                        or else
1447                      Prag_Id = Pragma_Export_Function)
1448          then
1449             for J in Externals.First .. Externals.Last loop
1450                if String_Equal (String_Val, Strval (Externals.Table (J))) then
1451                   Error_Msg_Sloc := Sloc (Externals.Table (J));
1452                   Error_Msg_N ("external name duplicates name given#", Nam);
1453                   exit;
1454                end if;
1455             end loop;
1456
1457             Externals.Append (Nam);
1458          end if;
1459       end Check_Duplicated_Export_Name;
1460
1461       -------------------------------------
1462       -- Check_Expr_Is_Static_Expression --
1463       -------------------------------------
1464
1465       procedure Check_Expr_Is_Static_Expression
1466         (Expr : Node_Id;
1467          Typ  : Entity_Id := Empty)
1468       is
1469       begin
1470          if Present (Typ) then
1471             Analyze_And_Resolve (Expr, Typ);
1472          else
1473             Analyze_And_Resolve (Expr);
1474          end if;
1475
1476          if Is_OK_Static_Expression (Expr) then
1477             return;
1478
1479          elsif Etype (Expr) = Any_Type then
1480             raise Pragma_Exit;
1481
1482          --  An interesting special case, if we have a string literal and we
1483          --  are in Ada 83 mode, then we allow it even though it will not be
1484          --  flagged as static. This allows the use of Ada 95 pragmas like
1485          --  Import in Ada 83 mode. They will of course be flagged with
1486          --  warnings as usual, but will not cause errors.
1487
1488          elsif Ada_Version = Ada_83
1489            and then Nkind (Expr) = N_String_Literal
1490          then
1491             return;
1492
1493          --  Static expression that raises Constraint_Error. This has already
1494          --  been flagged, so just exit from pragma processing.
1495
1496          elsif Is_Static_Expression (Expr) then
1497             raise Pragma_Exit;
1498
1499          --  Finally, we have a real error
1500
1501          else
1502             Error_Msg_Name_1 := Pname;
1503
1504             declare
1505                Msg : String :=
1506                        "argument for pragma% must be a static expression!";
1507             begin
1508                Fix_Error (Msg);
1509                Flag_Non_Static_Expr (Msg, Expr);
1510             end;
1511
1512             raise Pragma_Exit;
1513          end if;
1514       end Check_Expr_Is_Static_Expression;
1515
1516       -------------------------
1517       -- Check_First_Subtype --
1518       -------------------------
1519
1520       procedure Check_First_Subtype (Arg : Node_Id) is
1521          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
1522          Ent  : constant Entity_Id := Entity (Argx);
1523
1524       begin
1525          if Is_First_Subtype (Ent) then
1526             null;
1527
1528          elsif Is_Type (Ent) then
1529             Error_Pragma_Arg
1530               ("pragma% cannot apply to subtype", Argx);
1531
1532          elsif Is_Object (Ent) then
1533             Error_Pragma_Arg
1534               ("pragma% cannot apply to object, requires a type", Argx);
1535
1536          else
1537             Error_Pragma_Arg
1538               ("pragma% cannot apply to&, requires a type", Argx);
1539          end if;
1540       end Check_First_Subtype;
1541
1542       ----------------------
1543       -- Check_Identifier --
1544       ----------------------
1545
1546       procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
1547       begin
1548          if Present (Arg)
1549            and then Nkind (Arg) = N_Pragma_Argument_Association
1550          then
1551             if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
1552                Error_Msg_Name_1 := Pname;
1553                Error_Msg_Name_2 := Id;
1554                Error_Msg_N ("pragma% argument expects identifier%", Arg);
1555                raise Pragma_Exit;
1556             end if;
1557          end if;
1558       end Check_Identifier;
1559
1560       --------------------------------
1561       -- Check_Identifier_Is_One_Of --
1562       --------------------------------
1563
1564       procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
1565       begin
1566          if Present (Arg)
1567            and then Nkind (Arg) = N_Pragma_Argument_Association
1568          then
1569             if Chars (Arg) = No_Name then
1570                Error_Msg_Name_1 := Pname;
1571                Error_Msg_N ("pragma% argument expects an identifier", Arg);
1572                raise Pragma_Exit;
1573
1574             elsif Chars (Arg) /= N1
1575               and then Chars (Arg) /= N2
1576             then
1577                Error_Msg_Name_1 := Pname;
1578                Error_Msg_N ("invalid identifier for pragma% argument", Arg);
1579                raise Pragma_Exit;
1580             end if;
1581          end if;
1582       end Check_Identifier_Is_One_Of;
1583
1584       ---------------------------
1585       -- Check_In_Main_Program --
1586       ---------------------------
1587
1588       procedure Check_In_Main_Program is
1589          P : constant Node_Id := Parent (N);
1590
1591       begin
1592          --  Must be at in subprogram body
1593
1594          if Nkind (P) /= N_Subprogram_Body then
1595             Error_Pragma ("% pragma allowed only in subprogram");
1596
1597          --  Otherwise warn if obviously not main program
1598
1599          elsif Present (Parameter_Specifications (Specification (P)))
1600            or else not Is_Compilation_Unit (Defining_Entity (P))
1601          then
1602             Error_Msg_Name_1 := Pname;
1603             Error_Msg_N
1604               ("?pragma% is only effective in main program", N);
1605          end if;
1606       end Check_In_Main_Program;
1607
1608       ---------------------------------------
1609       -- Check_Interrupt_Or_Attach_Handler --
1610       ---------------------------------------
1611
1612       procedure Check_Interrupt_Or_Attach_Handler is
1613          Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
1614          Handler_Proc, Proc_Scope : Entity_Id;
1615
1616       begin
1617          Analyze (Arg1_X);
1618
1619          if Prag_Id = Pragma_Interrupt_Handler then
1620             Check_Restriction (No_Dynamic_Attachment, N);
1621          end if;
1622
1623          Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
1624          Proc_Scope := Scope (Handler_Proc);
1625
1626          --  On AAMP only, a pragma Interrupt_Handler is supported for
1627          --  nonprotected parameterless procedures.
1628
1629          if not AAMP_On_Target
1630            or else Prag_Id = Pragma_Attach_Handler
1631          then
1632             if Ekind (Proc_Scope) /= E_Protected_Type then
1633                Error_Pragma_Arg
1634                  ("argument of pragma% must be protected procedure", Arg1);
1635             end if;
1636
1637             if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
1638                Error_Pragma ("pragma% must be in protected definition");
1639             end if;
1640          end if;
1641
1642          if not Is_Library_Level_Entity (Proc_Scope)
1643            or else (AAMP_On_Target
1644                      and then not Is_Library_Level_Entity (Handler_Proc))
1645          then
1646             Error_Pragma_Arg
1647               ("argument for pragma% must be library level entity", Arg1);
1648          end if;
1649
1650          --  AI05-0033: A pragma cannot appear within a generic body, because
1651          --  instance can be in a nested scope. The check that protected type
1652          --  is itself a library-level declaration is done elsewhere.
1653
1654          --  Note: we omit this check in Codepeer mode to properly handle code
1655          --  prior to AI-0033 (pragmas don't matter to codepeer in any case).
1656
1657          if Inside_A_Generic then
1658             if Ekind (Scope (Current_Scope)) = E_Generic_Package
1659               and then In_Package_Body (Scope (Current_Scope))
1660               and then not CodePeer_Mode
1661             then
1662                Error_Pragma ("pragma% cannot be used inside a generic");
1663             end if;
1664          end if;
1665       end Check_Interrupt_Or_Attach_Handler;
1666
1667       -------------------------------------------
1668       -- Check_Is_In_Decl_Part_Or_Package_Spec --
1669       -------------------------------------------
1670
1671       procedure Check_Is_In_Decl_Part_Or_Package_Spec is
1672          P : Node_Id;
1673
1674       begin
1675          P := Parent (N);
1676          loop
1677             if No (P) then
1678                exit;
1679
1680             elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
1681                exit;
1682
1683             elsif Nkind_In (P, N_Package_Specification,
1684                                N_Block_Statement)
1685             then
1686                return;
1687
1688             --  Note: the following tests seem a little peculiar, because
1689             --  they test for bodies, but if we were in the statement part
1690             --  of the body, we would already have hit the handled statement
1691             --  sequence, so the only way we get here is by being in the
1692             --  declarative part of the body.
1693
1694             elsif Nkind_In (P, N_Subprogram_Body,
1695                                N_Package_Body,
1696                                N_Task_Body,
1697                                N_Entry_Body)
1698             then
1699                return;
1700             end if;
1701
1702             P := Parent (P);
1703          end loop;
1704
1705          Error_Pragma ("pragma% is not in declarative part or package spec");
1706       end Check_Is_In_Decl_Part_Or_Package_Spec;
1707
1708       -------------------------
1709       -- Check_No_Identifier --
1710       -------------------------
1711
1712       procedure Check_No_Identifier (Arg : Node_Id) is
1713       begin
1714          if Nkind (Arg) = N_Pragma_Argument_Association
1715            and then Chars (Arg) /= No_Name
1716          then
1717             Error_Pragma_Arg_Ident
1718               ("pragma% does not permit identifier& here", Arg);
1719          end if;
1720       end Check_No_Identifier;
1721
1722       --------------------------
1723       -- Check_No_Identifiers --
1724       --------------------------
1725
1726       procedure Check_No_Identifiers is
1727          Arg_Node : Node_Id;
1728       begin
1729          if Arg_Count > 0 then
1730             Arg_Node := Arg1;
1731             while Present (Arg_Node) loop
1732                Check_No_Identifier (Arg_Node);
1733                Next (Arg_Node);
1734             end loop;
1735          end if;
1736       end Check_No_Identifiers;
1737
1738       ------------------------
1739       -- Check_No_Link_Name --
1740       ------------------------
1741
1742       procedure Check_No_Link_Name is
1743       begin
1744          if Present (Arg3)
1745            and then Chars (Arg3) = Name_Link_Name
1746          then
1747             Arg4 := Arg3;
1748          end if;
1749
1750          if Present (Arg4) then
1751             Error_Pragma_Arg
1752               ("Link_Name argument not allowed for Import Intrinsic", Arg4);
1753          end if;
1754       end Check_No_Link_Name;
1755
1756       -------------------------------
1757       -- Check_Optional_Identifier --
1758       -------------------------------
1759
1760       procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
1761       begin
1762          if Present (Arg)
1763            and then Nkind (Arg) = N_Pragma_Argument_Association
1764            and then Chars (Arg) /= No_Name
1765          then
1766             if Chars (Arg) /= Id then
1767                Error_Msg_Name_1 := Pname;
1768                Error_Msg_Name_2 := Id;
1769                Error_Msg_N ("pragma% argument expects identifier%", Arg);
1770                raise Pragma_Exit;
1771             end if;
1772          end if;
1773       end Check_Optional_Identifier;
1774
1775       procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
1776       begin
1777          Name_Buffer (1 .. Id'Length) := Id;
1778          Name_Len := Id'Length;
1779          Check_Optional_Identifier (Arg, Name_Find);
1780       end Check_Optional_Identifier;
1781
1782       --------------------------------------
1783       -- Check_Precondition_Postcondition --
1784       --------------------------------------
1785
1786       procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
1787          P  : Node_Id;
1788          PO : Node_Id;
1789
1790          procedure Chain_PPC (PO : Node_Id);
1791          --  If PO is an entry or a [generic] subprogram declaration node, then
1792          --  the precondition/postcondition applies to this subprogram and the
1793          --  processing for the pragma is completed. Otherwise the pragma is
1794          --  misplaced.
1795
1796          ---------------
1797          -- Chain_PPC --
1798          ---------------
1799
1800          procedure Chain_PPC (PO : Node_Id) is
1801             S   : Entity_Id;
1802             P   : Node_Id;
1803
1804          begin
1805             if Nkind (PO) = N_Abstract_Subprogram_Declaration then
1806                if not From_Aspect_Specification (N) then
1807                   Error_Pragma
1808                     ("pragma% cannot be applied to abstract subprogram");
1809
1810                elsif Class_Present (N) then
1811                   null;
1812
1813                else
1814                   Error_Pragma
1815                     ("aspect % requires ''Class for abstract subprogram");
1816                end if;
1817
1818             --  AI05-0230: The same restriction applies to null procedures. For
1819             --  compatibility with earlier uses of the Ada pragma, apply this
1820             --  rule only to aspect specifications.
1821
1822             --  The above discrpency needs documentation. Robert is dubious
1823             --  about whether it is a good idea ???
1824
1825             elsif Nkind (PO) = N_Subprogram_Declaration
1826               and then Nkind (Specification (PO)) = N_Procedure_Specification
1827               and then Null_Present (Specification (PO))
1828               and then From_Aspect_Specification (N)
1829               and then not Class_Present (N)
1830             then
1831                Error_Pragma
1832                  ("aspect % requires ''Class for null procedure");
1833
1834             elsif not Nkind_In (PO, N_Subprogram_Declaration,
1835                                     N_Expression_Function,
1836                                     N_Generic_Subprogram_Declaration,
1837                                     N_Entry_Declaration)
1838             then
1839                Pragma_Misplaced;
1840             end if;
1841
1842             --  Here if we have [generic] subprogram or entry declaration
1843
1844             if Nkind (PO) = N_Entry_Declaration then
1845                S := Defining_Entity (PO);
1846             else
1847                S := Defining_Unit_Name (Specification (PO));
1848             end if;
1849
1850             --  Make sure we do not have the case of a precondition pragma when
1851             --  the Pre'Class aspect is present.
1852
1853             --  We do this by looking at pragmas already chained to the entity
1854             --  since the aspect derived pragma will be put on this list first.
1855
1856             if Pragma_Name (N) = Name_Precondition then
1857                if not From_Aspect_Specification (N) then
1858                   P := Spec_PPC_List (Contract (S));
1859                   while Present (P) loop
1860                      if Pragma_Name (P) = Name_Precondition
1861                        and then From_Aspect_Specification (P)
1862                        and then Class_Present (P)
1863                      then
1864                         Error_Msg_Sloc := Sloc (P);
1865                         Error_Pragma
1866                           ("pragma% not allowed, `Pre''Class` aspect given#");
1867                      end if;
1868
1869                      P := Next_Pragma (P);
1870                   end loop;
1871                end if;
1872             end if;
1873
1874             --  Similarly check for Pre with inherited Pre'Class. Note that
1875             --  we cover the aspect case as well here.
1876
1877             if Pragma_Name (N) = Name_Precondition
1878               and then not Class_Present (N)
1879             then
1880                declare
1881                   Inherited : constant Subprogram_List :=
1882                                 Inherited_Subprograms (S);
1883                   P         : Node_Id;
1884
1885                begin
1886                   for J in Inherited'Range loop
1887                      P := Spec_PPC_List (Contract (Inherited (J)));
1888                      while Present (P) loop
1889                         if Pragma_Name (P) = Name_Precondition
1890                           and then Class_Present (P)
1891                         then
1892                            Error_Msg_Sloc := Sloc (P);
1893                            Error_Pragma
1894                              ("pragma% not allowed, `Pre''Class` "
1895                               & "aspect inherited from#");
1896                         end if;
1897
1898                         P := Next_Pragma (P);
1899                      end loop;
1900                   end loop;
1901                end;
1902             end if;
1903
1904             --  Note: we do not analyze the pragma at this point. Instead we
1905             --  delay this analysis until the end of the declarative part in
1906             --  which the pragma appears. This implements the required delay
1907             --  in this analysis, allowing forward references. The analysis
1908             --  happens at the end of Analyze_Declarations.
1909
1910             --  Chain spec PPC pragma to list for subprogram
1911
1912             Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
1913             Set_Spec_PPC_List (Contract (S), N);
1914
1915             --  Return indicating spec case
1916
1917             In_Body := False;
1918             return;
1919          end Chain_PPC;
1920
1921       --  Start of processing for Check_Precondition_Postcondition
1922
1923       begin
1924          if not Is_List_Member (N) then
1925             Pragma_Misplaced;
1926          end if;
1927
1928          --  Preanalyze message argument if present. Visibility in this
1929          --  argument is established at the point of pragma occurrence.
1930
1931          if Arg_Count = 2 then
1932             Check_Optional_Identifier (Arg2, Name_Message);
1933             Preanalyze_Spec_Expression
1934               (Get_Pragma_Arg (Arg2), Standard_String);
1935          end if;
1936
1937          --  Record if pragma is disabled
1938
1939          if Check_Enabled (Pname) then
1940             Set_SCO_Pragma_Enabled (Loc);
1941          end if;
1942
1943          --  If we are within an inlined body, the legality of the pragma
1944          --  has been checked already.
1945
1946          if In_Inlined_Body then
1947             In_Body := True;
1948             return;
1949          end if;
1950
1951          --  Search prior declarations
1952
1953          P := N;
1954          while Present (Prev (P)) loop
1955             P := Prev (P);
1956
1957             --  If the previous node is a generic subprogram, do not go to to
1958             --  the original node, which is the unanalyzed tree: we need to
1959             --  attach the pre/postconditions to the analyzed version at this
1960             --  point. They get propagated to the original tree when analyzing
1961             --  the corresponding body.
1962
1963             if Nkind (P) not in N_Generic_Declaration then
1964                PO := Original_Node (P);
1965             else
1966                PO := P;
1967             end if;
1968
1969             --  Skip past prior pragma
1970
1971             if Nkind (PO) = N_Pragma then
1972                null;
1973
1974             --  Skip stuff not coming from source
1975
1976             elsif not Comes_From_Source (PO) then
1977
1978                --  The condition may apply to a subprogram instantiation
1979
1980                if Nkind (PO) = N_Subprogram_Declaration
1981                  and then Present (Generic_Parent (Specification (PO)))
1982                then
1983                   Chain_PPC (PO);
1984                   return;
1985
1986                elsif Nkind (PO) = N_Subprogram_Declaration
1987                  and then In_Instance
1988                then
1989                   Chain_PPC (PO);
1990                   return;
1991
1992                --  For all other cases of non source code, do nothing
1993
1994                else
1995                   null;
1996                end if;
1997
1998             --  Only remaining possibility is subprogram declaration
1999
2000             else
2001                Chain_PPC (PO);
2002                return;
2003             end if;
2004          end loop;
2005
2006          --  If we fall through loop, pragma is at start of list, so see if it
2007          --  is at the start of declarations of a subprogram body.
2008
2009          if Nkind (Parent (N)) = N_Subprogram_Body
2010            and then List_Containing (N) = Declarations (Parent (N))
2011          then
2012             if Operating_Mode /= Generate_Code
2013               or else Inside_A_Generic
2014             then
2015                --  Analyze pragma expression for correctness and for ASIS use
2016
2017                Preanalyze_Spec_Expression
2018                  (Get_Pragma_Arg (Arg1), Standard_Boolean);
2019
2020                --  In ASIS mode, for a pragma generated from a source aspect,
2021                --  also analyze the original aspect expression.
2022
2023                if ASIS_Mode
2024                  and then Present (Corresponding_Aspect (N))
2025                then
2026                   Preanalyze_Spec_Expression
2027                     (Expression (Corresponding_Aspect (N)), Standard_Boolean);
2028                end if;
2029             end if;
2030
2031             In_Body := True;
2032             return;
2033
2034          --  See if it is in the pragmas after a library level subprogram
2035
2036          elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
2037
2038             --  In formal verification mode, analyze pragma expression for
2039             --  correctness, as it is not expanded later.
2040
2041             if Alfa_Mode then
2042                Analyze_PPC_In_Decl_Part
2043                  (N, Defining_Entity (Unit (Parent (Parent (N)))));
2044             end if;
2045
2046             Chain_PPC (Unit (Parent (Parent (N))));
2047             return;
2048          end if;
2049
2050          --  If we fall through, pragma was misplaced
2051
2052          Pragma_Misplaced;
2053       end Check_Precondition_Postcondition;
2054
2055       -----------------------------
2056       -- Check_Static_Constraint --
2057       -----------------------------
2058
2059       --  Note: for convenience in writing this procedure, in addition to
2060       --  the officially (i.e. by spec) allowed argument which is always a
2061       --  constraint, it also allows ranges and discriminant associations.
2062       --  Above is not clear ???
2063
2064       procedure Check_Static_Constraint (Constr : Node_Id) is
2065
2066          procedure Require_Static (E : Node_Id);
2067          --  Require given expression to be static expression
2068
2069          --------------------
2070          -- Require_Static --
2071          --------------------
2072
2073          procedure Require_Static (E : Node_Id) is
2074          begin
2075             if not Is_OK_Static_Expression (E) then
2076                Flag_Non_Static_Expr
2077                  ("non-static constraint not allowed in Unchecked_Union!", E);
2078                raise Pragma_Exit;
2079             end if;
2080          end Require_Static;
2081
2082       --  Start of processing for Check_Static_Constraint
2083
2084       begin
2085          case Nkind (Constr) is
2086             when N_Discriminant_Association =>
2087                Require_Static (Expression (Constr));
2088
2089             when N_Range =>
2090                Require_Static (Low_Bound (Constr));
2091                Require_Static (High_Bound (Constr));
2092
2093             when N_Attribute_Reference =>
2094                Require_Static (Type_Low_Bound  (Etype (Prefix (Constr))));
2095                Require_Static (Type_High_Bound (Etype (Prefix (Constr))));
2096
2097             when N_Range_Constraint =>
2098                Check_Static_Constraint (Range_Expression (Constr));
2099
2100             when N_Index_Or_Discriminant_Constraint =>
2101                declare
2102                   IDC : Entity_Id;
2103                begin
2104                   IDC := First (Constraints (Constr));
2105                   while Present (IDC) loop
2106                      Check_Static_Constraint (IDC);
2107                      Next (IDC);
2108                   end loop;
2109                end;
2110
2111             when others =>
2112                null;
2113          end case;
2114       end Check_Static_Constraint;
2115
2116       ---------------------
2117       -- Check_Test_Case --
2118       ---------------------
2119
2120       procedure Check_Test_Case is
2121          P  : Node_Id;
2122          PO : Node_Id;
2123
2124          procedure Chain_TC (PO : Node_Id);
2125          --  If PO is a [generic] subprogram declaration node, then the
2126          --  test-case applies to this subprogram and the processing for the
2127          --  pragma is completed. Otherwise the pragma is misplaced.
2128
2129          --------------
2130          -- Chain_TC --
2131          --------------
2132
2133          procedure Chain_TC (PO : Node_Id) is
2134             S   : Entity_Id;
2135
2136          begin
2137             if Nkind (PO) = N_Abstract_Subprogram_Declaration then
2138                if From_Aspect_Specification (N) then
2139                   Error_Pragma
2140                     ("aspect% cannot be applied to abstract subprogram");
2141                else
2142                   Error_Pragma
2143                     ("pragma% cannot be applied to abstract subprogram");
2144                end if;
2145
2146             elsif Nkind (PO) = N_Entry_Declaration then
2147                if From_Aspect_Specification (N) then
2148                   Error_Pragma ("aspect% cannot be applied to entry");
2149                else
2150                   Error_Pragma ("pragma% cannot be applied to entry");
2151                end if;
2152
2153             elsif not Nkind_In (PO, N_Subprogram_Declaration,
2154                                     N_Generic_Subprogram_Declaration)
2155             then
2156                Pragma_Misplaced;
2157             end if;
2158
2159             --  Here if we have [generic] subprogram declaration
2160
2161             S := Defining_Unit_Name (Specification (PO));
2162
2163             --  Note: we do not analyze the pragma at this point. Instead we
2164             --  delay this analysis until the end of the declarative part in
2165             --  which the pragma appears. This implements the required delay
2166             --  in this analysis, allowing forward references. The analysis
2167             --  happens at the end of Analyze_Declarations.
2168
2169             --  There should not be another test case with the same name
2170             --  associated to this subprogram.
2171
2172             declare
2173                Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
2174                TC   : Node_Id;
2175
2176             begin
2177                TC := Spec_TC_List (Contract (S));
2178                while Present (TC) loop
2179
2180                   if String_Equal
2181                     (Name, Get_Name_From_Test_Case_Pragma (TC))
2182                   then
2183                      Error_Msg_Sloc := Sloc (TC);
2184
2185                      if From_Aspect_Specification (N) then
2186                         Error_Pragma ("name for aspect% is already used#");
2187                      else
2188                         Error_Pragma ("name for pragma% is already used#");
2189                      end if;
2190                   end if;
2191
2192                   TC := Next_Pragma (TC);
2193                end loop;
2194             end;
2195
2196             --  Chain spec TC pragma to list for subprogram
2197
2198             Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
2199             Set_Spec_TC_List (Contract (S), N);
2200          end Chain_TC;
2201
2202       --  Start of processing for Check_Test_Case
2203
2204       begin
2205          if not Is_List_Member (N) then
2206             Pragma_Misplaced;
2207          end if;
2208
2209          --  Test cases should only appear in package spec unit
2210
2211          if Get_Source_Unit (N) = No_Unit
2212            or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
2213                                  N_Package_Declaration,
2214                                  N_Generic_Package_Declaration)
2215          then
2216             Pragma_Misplaced;
2217          end if;
2218
2219          --  Search prior declarations
2220
2221          P := N;
2222          while Present (Prev (P)) loop
2223             P := Prev (P);
2224
2225             --  If the previous node is a generic subprogram, do not go to to
2226             --  the original node, which is the unanalyzed tree: we need to
2227             --  attach the test-case to the analyzed version at this point.
2228             --  They get propagated to the original tree when analyzing the
2229             --  corresponding body.
2230
2231             if Nkind (P) not in N_Generic_Declaration then
2232                PO := Original_Node (P);
2233             else
2234                PO := P;
2235             end if;
2236
2237             --  Skip past prior pragma
2238
2239             if Nkind (PO) = N_Pragma then
2240                null;
2241
2242             --  Skip stuff not coming from source
2243
2244             elsif not Comes_From_Source (PO) then
2245                null;
2246
2247             --  Only remaining possibility is subprogram declaration. First
2248             --  check that it is declared directly in a package declaration.
2249             --  This may be either the package declaration for the current unit
2250             --  being defined or a local package declaration.
2251
2252             elsif not Present (Parent (Parent (PO)))
2253               or else not Present (Parent (Parent (Parent (PO))))
2254               or else not Nkind_In (Parent (Parent (PO)),
2255                                     N_Package_Declaration,
2256                                     N_Generic_Package_Declaration)
2257             then
2258                Pragma_Misplaced;
2259
2260             else
2261                Chain_TC (PO);
2262                return;
2263             end if;
2264          end loop;
2265
2266          --  If we fall through, pragma was misplaced
2267
2268          Pragma_Misplaced;
2269       end Check_Test_Case;
2270
2271       --------------------------------------
2272       -- Check_Valid_Configuration_Pragma --
2273       --------------------------------------
2274
2275       --  A configuration pragma must appear in the context clause of a
2276       --  compilation unit, and only other pragmas may precede it. Note that
2277       --  the test also allows use in a configuration pragma file.
2278
2279       procedure Check_Valid_Configuration_Pragma is
2280       begin
2281          if not Is_Configuration_Pragma then
2282             Error_Pragma ("incorrect placement for configuration pragma%");
2283          end if;
2284       end Check_Valid_Configuration_Pragma;
2285
2286       -------------------------------------
2287       -- Check_Valid_Library_Unit_Pragma --
2288       -------------------------------------
2289
2290       procedure Check_Valid_Library_Unit_Pragma is
2291          Plist       : List_Id;
2292          Parent_Node : Node_Id;
2293          Unit_Name   : Entity_Id;
2294          Unit_Kind   : Node_Kind;
2295          Unit_Node   : Node_Id;
2296          Sindex      : Source_File_Index;
2297
2298       begin
2299          if not Is_List_Member (N) then
2300             Pragma_Misplaced;
2301
2302          else
2303             Plist := List_Containing (N);
2304             Parent_Node := Parent (Plist);
2305
2306             if Parent_Node = Empty then
2307                Pragma_Misplaced;
2308
2309             --  Case of pragma appearing after a compilation unit. In this case
2310             --  it must have an argument with the corresponding name and must
2311             --  be part of the following pragmas of its parent.
2312
2313             elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
2314                if Plist /= Pragmas_After (Parent_Node) then
2315                   Pragma_Misplaced;
2316
2317                elsif Arg_Count = 0 then
2318                   Error_Pragma
2319                     ("argument required if outside compilation unit");
2320
2321                else
2322                   Check_No_Identifiers;
2323                   Check_Arg_Count (1);
2324                   Unit_Node := Unit (Parent (Parent_Node));
2325                   Unit_Kind := Nkind (Unit_Node);
2326
2327                   Analyze (Get_Pragma_Arg (Arg1));
2328
2329                   if Unit_Kind = N_Generic_Subprogram_Declaration
2330                     or else Unit_Kind = N_Subprogram_Declaration
2331                   then
2332                      Unit_Name := Defining_Entity (Unit_Node);
2333
2334                   elsif Unit_Kind in N_Generic_Instantiation then
2335                      Unit_Name := Defining_Entity (Unit_Node);
2336
2337                   else
2338                      Unit_Name := Cunit_Entity (Current_Sem_Unit);
2339                   end if;
2340
2341                   if Chars (Unit_Name) /=
2342                      Chars (Entity (Get_Pragma_Arg (Arg1)))
2343                   then
2344                      Error_Pragma_Arg
2345                        ("pragma% argument is not current unit name", Arg1);
2346                   end if;
2347
2348                   if Ekind (Unit_Name) = E_Package
2349                     and then Present (Renamed_Entity (Unit_Name))
2350                   then
2351                      Error_Pragma ("pragma% not allowed for renamed package");
2352                   end if;
2353                end if;
2354
2355             --  Pragma appears other than after a compilation unit
2356
2357             else
2358                --  Here we check for the generic instantiation case and also
2359                --  for the case of processing a generic formal package. We
2360                --  detect these cases by noting that the Sloc on the node
2361                --  does not belong to the current compilation unit.
2362
2363                Sindex := Source_Index (Current_Sem_Unit);
2364
2365                if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
2366                   Rewrite (N, Make_Null_Statement (Loc));
2367                   return;
2368
2369                --  If before first declaration, the pragma applies to the
2370                --  enclosing unit, and the name if present must be this name.
2371
2372                elsif Is_Before_First_Decl (N, Plist) then
2373                   Unit_Node := Unit_Declaration_Node (Current_Scope);
2374                   Unit_Kind := Nkind (Unit_Node);
2375
2376                   if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
2377                      Pragma_Misplaced;
2378
2379                   elsif Unit_Kind = N_Subprogram_Body
2380                     and then not Acts_As_Spec (Unit_Node)
2381                   then
2382                      Pragma_Misplaced;
2383
2384                   elsif Nkind (Parent_Node) = N_Package_Body then
2385                      Pragma_Misplaced;
2386
2387                   elsif Nkind (Parent_Node) = N_Package_Specification
2388                     and then Plist = Private_Declarations (Parent_Node)
2389                   then
2390                      Pragma_Misplaced;
2391
2392                   elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
2393                            or else Nkind (Parent_Node) =
2394                                              N_Generic_Subprogram_Declaration)
2395                     and then Plist = Generic_Formal_Declarations (Parent_Node)
2396                   then
2397                      Pragma_Misplaced;
2398
2399                   elsif Arg_Count > 0 then
2400                      Analyze (Get_Pragma_Arg (Arg1));
2401
2402                      if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
2403                         Error_Pragma_Arg
2404                           ("name in pragma% must be enclosing unit", Arg1);
2405                      end if;
2406
2407                   --  It is legal to have no argument in this context
2408
2409                   else
2410                      return;
2411                   end if;
2412
2413                --  Error if not before first declaration. This is because a
2414                --  library unit pragma argument must be the name of a library
2415                --  unit (RM 10.1.5(7)), but the only names permitted in this
2416                --  context are (RM 10.1.5(6)) names of subprogram declarations,
2417                --  generic subprogram declarations or generic instantiations.
2418
2419                else
2420                   Error_Pragma
2421                     ("pragma% misplaced, must be before first declaration");
2422                end if;
2423             end if;
2424          end if;
2425       end Check_Valid_Library_Unit_Pragma;
2426
2427       -------------------
2428       -- Check_Variant --
2429       -------------------
2430
2431       procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
2432          Clist : constant Node_Id := Component_List (Variant);
2433          Comp  : Node_Id;
2434
2435       begin
2436          if not Is_Non_Empty_List (Component_Items (Clist)) then
2437             Error_Msg_N
2438               ("Unchecked_Union may not have empty component list",
2439                Variant);
2440             return;
2441          end if;
2442
2443          Comp := First (Component_Items (Clist));
2444          while Present (Comp) loop
2445             Check_Component (Comp, UU_Typ, In_Variant_Part => True);
2446             Next (Comp);
2447          end loop;
2448       end Check_Variant;
2449
2450       ------------------
2451       -- Error_Pragma --
2452       ------------------
2453
2454       procedure Error_Pragma (Msg : String) is
2455          MsgF : String := Msg;
2456       begin
2457          Error_Msg_Name_1 := Pname;
2458          Fix_Error (MsgF);
2459          Error_Msg_N (MsgF, N);
2460          raise Pragma_Exit;
2461       end Error_Pragma;
2462
2463       ----------------------
2464       -- Error_Pragma_Arg --
2465       ----------------------
2466
2467       procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
2468          MsgF : String := Msg;
2469       begin
2470          Error_Msg_Name_1 := Pname;
2471          Fix_Error (MsgF);
2472          Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2473          raise Pragma_Exit;
2474       end Error_Pragma_Arg;
2475
2476       procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
2477          MsgF : String := Msg1;
2478       begin
2479          Error_Msg_Name_1 := Pname;
2480          Fix_Error (MsgF);
2481          Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
2482          Error_Pragma_Arg (Msg2, Arg);
2483       end Error_Pragma_Arg;
2484
2485       ----------------------------
2486       -- Error_Pragma_Arg_Ident --
2487       ----------------------------
2488
2489       procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
2490          MsgF : String := Msg;
2491       begin
2492          Error_Msg_Name_1 := Pname;
2493          Fix_Error (MsgF);
2494          Error_Msg_N (MsgF, Arg);
2495          raise Pragma_Exit;
2496       end Error_Pragma_Arg_Ident;
2497
2498       ----------------------
2499       -- Error_Pragma_Ref --
2500       ----------------------
2501
2502       procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
2503          MsgF : String := Msg;
2504       begin
2505          Error_Msg_Name_1 := Pname;
2506          Fix_Error (MsgF);
2507          Error_Msg_Sloc   := Sloc (Ref);
2508          Error_Msg_NE (MsgF, N, Ref);
2509          raise Pragma_Exit;
2510       end Error_Pragma_Ref;
2511
2512       ------------------------
2513       -- Find_Lib_Unit_Name --
2514       ------------------------
2515
2516       function Find_Lib_Unit_Name return Entity_Id is
2517       begin
2518          --  Return inner compilation unit entity, for case of nested
2519          --  categorization pragmas. This happens in generic unit.
2520
2521          if Nkind (Parent (N)) = N_Package_Specification
2522            and then Defining_Entity (Parent (N)) /= Current_Scope
2523          then
2524             return Defining_Entity (Parent (N));
2525          else
2526             return Current_Scope;
2527          end if;
2528       end Find_Lib_Unit_Name;
2529
2530       ----------------------------
2531       -- Find_Program_Unit_Name --
2532       ----------------------------
2533
2534       procedure Find_Program_Unit_Name (Id : Node_Id) is
2535          Unit_Name : Entity_Id;
2536          Unit_Kind : Node_Kind;
2537          P         : constant Node_Id := Parent (N);
2538
2539       begin
2540          if Nkind (P) = N_Compilation_Unit then
2541             Unit_Kind := Nkind (Unit (P));
2542
2543             if Unit_Kind = N_Subprogram_Declaration
2544               or else Unit_Kind = N_Package_Declaration
2545               or else Unit_Kind in N_Generic_Declaration
2546             then
2547                Unit_Name := Defining_Entity (Unit (P));
2548
2549                if Chars (Id) = Chars (Unit_Name) then
2550                   Set_Entity (Id, Unit_Name);
2551                   Set_Etype (Id, Etype (Unit_Name));
2552                else
2553                   Set_Etype (Id, Any_Type);
2554                   Error_Pragma
2555                     ("cannot find program unit referenced by pragma%");
2556                end if;
2557
2558             else
2559                Set_Etype (Id, Any_Type);
2560                Error_Pragma ("pragma% inapplicable to this unit");
2561             end if;
2562
2563          else
2564             Analyze (Id);
2565          end if;
2566       end Find_Program_Unit_Name;
2567
2568       -----------------------------------------
2569       -- Find_Unique_Parameterless_Procedure --
2570       -----------------------------------------
2571
2572       function Find_Unique_Parameterless_Procedure
2573         (Name : Entity_Id;
2574          Arg  : Node_Id) return Entity_Id
2575       is
2576          Proc : Entity_Id := Empty;
2577
2578       begin
2579          --  The body of this procedure needs some comments ???
2580
2581          if not Is_Entity_Name (Name) then
2582             Error_Pragma_Arg
2583               ("argument of pragma% must be entity name", Arg);
2584
2585          elsif not Is_Overloaded (Name) then
2586             Proc := Entity (Name);
2587
2588             if Ekind (Proc) /= E_Procedure
2589               or else Present (First_Formal (Proc))
2590             then
2591                Error_Pragma_Arg
2592                  ("argument of pragma% must be parameterless procedure", Arg);
2593             end if;
2594
2595          else
2596             declare
2597                Found : Boolean := False;
2598                It    : Interp;
2599                Index : Interp_Index;
2600
2601             begin
2602                Get_First_Interp (Name, Index, It);
2603                while Present (It.Nam) loop
2604                   Proc := It.Nam;
2605
2606                   if Ekind (Proc) = E_Procedure
2607                     and then No (First_Formal (Proc))
2608                   then
2609                      if not Found then
2610                         Found := True;
2611                         Set_Entity (Name, Proc);
2612                         Set_Is_Overloaded (Name, False);
2613                      else
2614                         Error_Pragma_Arg
2615                           ("ambiguous handler name for pragma% ", Arg);
2616                      end if;
2617                   end if;
2618
2619                   Get_Next_Interp (Index, It);
2620                end loop;
2621
2622                if not Found then
2623                   Error_Pragma_Arg
2624                     ("argument of pragma% must be parameterless procedure",
2625                      Arg);
2626                else
2627                   Proc := Entity (Name);
2628                end if;
2629             end;
2630          end if;
2631
2632          return Proc;
2633       end Find_Unique_Parameterless_Procedure;
2634
2635       ---------------
2636       -- Fix_Error --
2637       ---------------
2638
2639       procedure Fix_Error (Msg : in out String) is
2640       begin
2641          if From_Aspect_Specification (N) then
2642             for J in Msg'First .. Msg'Last - 5 loop
2643                if Msg (J .. J + 5) = "pragma" then
2644                   Msg (J .. J + 5) := "aspect";
2645                end if;
2646             end loop;
2647
2648             if Error_Msg_Name_1 = Name_Precondition then
2649                Error_Msg_Name_1 := Name_Pre;
2650             elsif Error_Msg_Name_1 = Name_Postcondition then
2651                Error_Msg_Name_1 := Name_Post;
2652             end if;
2653          end if;
2654       end Fix_Error;
2655
2656       -------------------------
2657       -- Gather_Associations --
2658       -------------------------
2659
2660       procedure Gather_Associations
2661         (Names : Name_List;
2662          Args  : out Args_List)
2663       is
2664          Arg : Node_Id;
2665
2666       begin
2667          --  Initialize all parameters to Empty
2668
2669          for J in Args'Range loop
2670             Args (J) := Empty;
2671          end loop;
2672
2673          --  That's all we have to do if there are no argument associations
2674
2675          if No (Pragma_Argument_Associations (N)) then
2676             return;
2677          end if;
2678
2679          --  Otherwise first deal with any positional parameters present
2680
2681          Arg := First (Pragma_Argument_Associations (N));
2682          for Index in Args'Range loop
2683             exit when No (Arg) or else Chars (Arg) /= No_Name;
2684             Args (Index) := Get_Pragma_Arg (Arg);
2685             Next (Arg);
2686          end loop;
2687
2688          --  Positional parameters all processed, if any left, then we
2689          --  have too many positional parameters.
2690
2691          if Present (Arg) and then Chars (Arg) = No_Name then
2692             Error_Pragma_Arg
2693               ("too many positional associations for pragma%", Arg);
2694          end if;
2695
2696          --  Process named parameters if any are present
2697
2698          while Present (Arg) loop
2699             if Chars (Arg) = No_Name then
2700                Error_Pragma_Arg
2701                  ("positional association cannot follow named association",
2702                   Arg);
2703
2704             else
2705                for Index in Names'Range loop
2706                   if Names (Index) = Chars (Arg) then
2707                      if Present (Args (Index)) then
2708                         Error_Pragma_Arg
2709                           ("duplicate argument association for pragma%", Arg);
2710                      else
2711                         Args (Index) := Get_Pragma_Arg (Arg);
2712                         exit;
2713                      end if;
2714                   end if;
2715
2716                   if Index = Names'Last then
2717                      Error_Msg_Name_1 := Pname;
2718                      Error_Msg_N ("pragma% does not allow & argument", Arg);
2719
2720                      --  Check for possible misspelling
2721
2722                      for Index1 in Names'Range loop
2723                         if Is_Bad_Spelling_Of
2724                              (Chars (Arg), Names (Index1))
2725                         then
2726                            Error_Msg_Name_1 := Names (Index1);
2727                            Error_Msg_N -- CODEFIX
2728                              ("\possible misspelling of%", Arg);
2729                            exit;
2730                         end if;
2731                      end loop;
2732
2733                      raise Pragma_Exit;
2734                   end if;
2735                end loop;
2736             end if;
2737
2738             Next (Arg);
2739          end loop;
2740       end Gather_Associations;
2741
2742       -----------------
2743       -- GNAT_Pragma --
2744       -----------------
2745
2746       procedure GNAT_Pragma is
2747       begin
2748          --  We need to check the No_Implementation_Pragmas restriction for
2749          --  the case of a pragma from source. Note that the case of aspects
2750          --  generating corresponding pragmas marks these pragmas as not being
2751          --  from source, so this test also catches that case.
2752
2753          if Comes_From_Source (N) then
2754             Check_Restriction (No_Implementation_Pragmas, N);
2755          end if;
2756       end GNAT_Pragma;
2757
2758       --------------------------
2759       -- Is_Before_First_Decl --
2760       --------------------------
2761
2762       function Is_Before_First_Decl
2763         (Pragma_Node : Node_Id;
2764          Decls       : List_Id) return Boolean
2765       is
2766          Item : Node_Id := First (Decls);
2767
2768       begin
2769          --  Only other pragmas can come before this pragma
2770
2771          loop
2772             if No (Item) or else Nkind (Item) /= N_Pragma then
2773                return False;
2774
2775             elsif Item = Pragma_Node then
2776                return True;
2777             end if;
2778
2779             Next (Item);
2780          end loop;
2781       end Is_Before_First_Decl;
2782
2783       -----------------------------
2784       -- Is_Configuration_Pragma --
2785       -----------------------------
2786
2787       --  A configuration pragma must appear in the context clause of a
2788       --  compilation unit, and only other pragmas may precede it. Note that
2789       --  the test below also permits use in a configuration pragma file.
2790
2791       function Is_Configuration_Pragma return Boolean is
2792          Lis : constant List_Id := List_Containing (N);
2793          Par : constant Node_Id := Parent (N);
2794          Prg : Node_Id;
2795
2796       begin
2797          --  If no parent, then we are in the configuration pragma file,
2798          --  so the placement is definitely appropriate.
2799
2800          if No (Par) then
2801             return True;
2802
2803          --  Otherwise we must be in the context clause of a compilation unit
2804          --  and the only thing allowed before us in the context list is more
2805          --  configuration pragmas.
2806
2807          elsif Nkind (Par) = N_Compilation_Unit
2808            and then Context_Items (Par) = Lis
2809          then
2810             Prg := First (Lis);
2811
2812             loop
2813                if Prg = N then
2814                   return True;
2815                elsif Nkind (Prg) /= N_Pragma then
2816                   return False;
2817                end if;
2818
2819                Next (Prg);
2820             end loop;
2821
2822          else
2823             return False;
2824          end if;
2825       end Is_Configuration_Pragma;
2826
2827       --------------------------
2828       -- Is_In_Context_Clause --
2829       --------------------------
2830
2831       function Is_In_Context_Clause return Boolean is
2832          Plist       : List_Id;
2833          Parent_Node : Node_Id;
2834
2835       begin
2836          if not Is_List_Member (N) then
2837             return False;
2838
2839          else
2840             Plist := List_Containing (N);
2841             Parent_Node := Parent (Plist);
2842
2843             if Parent_Node = Empty
2844               or else Nkind (Parent_Node) /= N_Compilation_Unit
2845               or else Context_Items (Parent_Node) /= Plist
2846             then
2847                return False;
2848             end if;
2849          end if;
2850
2851          return True;
2852       end Is_In_Context_Clause;
2853
2854       ---------------------------------
2855       -- Is_Static_String_Expression --
2856       ---------------------------------
2857
2858       function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
2859          Argx : constant Node_Id := Get_Pragma_Arg (Arg);
2860
2861       begin
2862          Analyze_And_Resolve (Argx);
2863          return Is_OK_Static_Expression (Argx)
2864            and then Nkind (Argx) = N_String_Literal;
2865       end Is_Static_String_Expression;
2866
2867       ----------------------
2868       -- Pragma_Misplaced --
2869       ----------------------
2870
2871       procedure Pragma_Misplaced is
2872       begin
2873          Error_Pragma ("incorrect placement of pragma%");
2874       end Pragma_Misplaced;
2875
2876       ------------------------------------
2877       -- Process Atomic_Shared_Volatile --
2878       ------------------------------------
2879
2880       procedure Process_Atomic_Shared_Volatile is
2881          E_Id : Node_Id;
2882          E    : Entity_Id;
2883          D    : Node_Id;
2884          K    : Node_Kind;
2885          Utyp : Entity_Id;
2886
2887          procedure Set_Atomic (E : Entity_Id);
2888          --  Set given type as atomic, and if no explicit alignment was given,
2889          --  set alignment to unknown, since back end knows what the alignment
2890          --  requirements are for atomic arrays. Note: this step is necessary
2891          --  for derived types.
2892
2893          ----------------
2894          -- Set_Atomic --
2895          ----------------
2896
2897          procedure Set_Atomic (E : Entity_Id) is
2898          begin
2899             Set_Is_Atomic (E);
2900
2901             if not Has_Alignment_Clause (E) then
2902                Set_Alignment (E, Uint_0);
2903             end if;
2904          end Set_Atomic;
2905
2906       --  Start of processing for Process_Atomic_Shared_Volatile
2907
2908       begin
2909          Check_Ada_83_Warning;
2910          Check_No_Identifiers;
2911          Check_Arg_Count (1);
2912          Check_Arg_Is_Local_Name (Arg1);
2913          E_Id := Get_Pragma_Arg (Arg1);
2914
2915          if Etype (E_Id) = Any_Type then
2916             return;
2917          end if;
2918
2919          E := Entity (E_Id);
2920          D := Declaration_Node (E);
2921          K := Nkind (D);
2922
2923          --  Check duplicate before we chain ourselves!
2924
2925          Check_Duplicate_Pragma (E);
2926
2927          --  Now check appropriateness of the entity
2928
2929          if Is_Type (E) then
2930             if Rep_Item_Too_Early (E, N)
2931                  or else
2932                Rep_Item_Too_Late (E, N)
2933             then
2934                return;
2935             else
2936                Check_First_Subtype (Arg1);
2937             end if;
2938
2939             if Prag_Id /= Pragma_Volatile then
2940                Set_Atomic (E);
2941                Set_Atomic (Underlying_Type (E));
2942                Set_Atomic (Base_Type (E));
2943             end if;
2944
2945             --  Attribute belongs on the base type. If the view of the type is
2946             --  currently private, it also belongs on the underlying type.
2947
2948             Set_Is_Volatile (Base_Type (E));
2949             Set_Is_Volatile (Underlying_Type (E));
2950
2951             Set_Treat_As_Volatile (E);
2952             Set_Treat_As_Volatile (Underlying_Type (E));
2953
2954          elsif K = N_Object_Declaration
2955            or else (K = N_Component_Declaration
2956                      and then Original_Record_Component (E) = E)
2957          then
2958             if Rep_Item_Too_Late (E, N) then
2959                return;
2960             end if;
2961
2962             if Prag_Id /= Pragma_Volatile then
2963                Set_Is_Atomic (E);
2964
2965                --  If the object declaration has an explicit initialization, a
2966                --  temporary may have to be created to hold the expression, to
2967                --  ensure that access to the object remain atomic.
2968
2969                if Nkind (Parent (E)) = N_Object_Declaration
2970                  and then Present (Expression (Parent (E)))
2971                then
2972                   Set_Has_Delayed_Freeze (E);
2973                end if;
2974
2975                --  An interesting improvement here. If an object of composite
2976                --  type X is declared atomic, and the type X isn't, that's a
2977                --  pity, since it may not have appropriate alignment etc. We
2978                --  can rescue this in the special case where the object and
2979                --  type are in the same unit by just setting the type as
2980                --  atomic, so that the back end will process it as atomic.
2981
2982                --  Note: we used to do this for elementary types as well,
2983                --  but that turns out to be a bad idea and can have unwanted
2984                --  effects, most notably if the type is elementary, the object
2985                --  a simple component within a record, and both are in a spec:
2986                --  every object of this type in the entire program will be
2987                --  treated as atomic, thus incurring a potentially costly
2988                --  synchronization operation for every access.
2989
2990                --  Of course it would be best if the back end could just adjust
2991                --  the alignment etc for the specific object, but that's not
2992                --  something we are capable of doing at this point.
2993
2994                Utyp := Underlying_Type (Etype (E));
2995
2996                if Present (Utyp)
2997                  and then Is_Composite_Type (Utyp)
2998                  and then Sloc (E) > No_Location
2999                  and then Sloc (Utyp) > No_Location
3000                  and then
3001                    Get_Source_File_Index (Sloc (E)) =
3002                    Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
3003                then
3004                   Set_Is_Atomic (Underlying_Type (Etype (E)));
3005                end if;
3006             end if;
3007
3008             Set_Is_Volatile (E);
3009             Set_Treat_As_Volatile (E);
3010
3011          else
3012             Error_Pragma_Arg
3013               ("inappropriate entity for pragma%", Arg1);
3014          end if;
3015       end Process_Atomic_Shared_Volatile;
3016
3017       -------------------------------------------
3018       -- Process_Compile_Time_Warning_Or_Error --
3019       -------------------------------------------
3020
3021       procedure Process_Compile_Time_Warning_Or_Error is
3022          Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
3023
3024       begin
3025          Check_Arg_Count (2);
3026          Check_No_Identifiers;
3027          Check_Arg_Is_Static_Expression (Arg2, Standard_String);
3028          Analyze_And_Resolve (Arg1x, Standard_Boolean);
3029
3030          if Compile_Time_Known_Value (Arg1x) then
3031             if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
3032                declare
3033                   Str   : constant String_Id :=
3034                             Strval (Get_Pragma_Arg (Arg2));
3035                   Len   : constant Int := String_Length (Str);
3036                   Cont  : Boolean;
3037                   Ptr   : Nat;
3038                   CC    : Char_Code;
3039                   C     : Character;
3040                   Cent  : constant Entity_Id :=
3041                             Cunit_Entity (Current_Sem_Unit);
3042
3043                   Force : constant Boolean :=
3044                             Prag_Id = Pragma_Compile_Time_Warning
3045                               and then
3046                                 Is_Spec_Name (Unit_Name (Current_Sem_Unit))
3047                               and then (Ekind (Cent) /= E_Package
3048                                           or else not In_Private_Part (Cent));
3049                   --  Set True if this is the warning case, and we are in the
3050                   --  visible part of a package spec, or in a subprogram spec,
3051                   --  in which case we want to force the client to see the
3052                   --  warning, even though it is not in the main unit.
3053
3054                begin
3055                   --  Loop through segments of message separated by line feeds.
3056                   --  We output these segments as separate messages with
3057                   --  continuation marks for all but the first.
3058
3059                   Cont := False;
3060                   Ptr := 1;
3061                   loop
3062                      Error_Msg_Strlen := 0;
3063
3064                      --  Loop to copy characters from argument to error message
3065                      --  string buffer.
3066
3067                      loop
3068                         exit when Ptr > Len;
3069                         CC := Get_String_Char (Str, Ptr);
3070                         Ptr := Ptr + 1;
3071
3072                         --  Ignore wide chars ??? else store character
3073
3074                         if In_Character_Range (CC) then
3075                            C := Get_Character (CC);
3076                            exit when C = ASCII.LF;
3077                            Error_Msg_Strlen := Error_Msg_Strlen + 1;
3078                            Error_Msg_String (Error_Msg_Strlen) := C;
3079                         end if;
3080                      end loop;
3081
3082                      --  Here with one line ready to go
3083
3084                      Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
3085
3086                      --  If this is a warning in a spec, then we want clients
3087                      --  to see the warning, so mark the message with the
3088                      --  special sequence !! to force the warning. In the case
3089                      --  of a package spec, we do not force this if we are in
3090                      --  the private part of the spec.
3091
3092                      if Force then
3093                         if Cont = False then
3094                            Error_Msg_N ("<~!!", Arg1);
3095                            Cont := True;
3096                         else
3097                            Error_Msg_N ("\<~!!", Arg1);
3098                         end if;
3099
3100                      --  Error, rather than warning, or in a body, so we do not
3101                      --  need to force visibility for client (error will be
3102                      --  output in any case, and this is the situation in which
3103                      --  we do not want a client to get a warning, since the
3104                      --  warning is in the body or the spec private part).
3105
3106                      else
3107                         if Cont = False then
3108                            Error_Msg_N ("<~", Arg1);
3109                            Cont := True;
3110                         else
3111                            Error_Msg_N ("\<~", Arg1);
3112                         end if;
3113                      end if;
3114
3115                      exit when Ptr > Len;
3116                   end loop;
3117                end;
3118             end if;
3119          end if;
3120       end Process_Compile_Time_Warning_Or_Error;
3121
3122       ------------------------
3123       -- Process_Convention --
3124       ------------------------
3125
3126       procedure Process_Convention
3127         (C   : out Convention_Id;
3128          Ent : out Entity_Id)
3129       is
3130          Id        : Node_Id;
3131          E         : Entity_Id;
3132          E1        : Entity_Id;
3133          Cname     : Name_Id;
3134          Comp_Unit : Unit_Number_Type;
3135
3136          procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
3137          --  Called if we have more than one Export/Import/Convention pragma.
3138          --  This is generally illegal, but we have a special case of allowing
3139          --  Import and Interface to coexist if they specify the convention in
3140          --  a consistent manner. We are allowed to do this, since Interface is
3141          --  an implementation defined pragma, and we choose to do it since we
3142          --  know Rational allows this combination. S is the entity id of the
3143          --  subprogram in question. This procedure also sets the special flag
3144          --  Import_Interface_Present in both pragmas in the case where we do
3145          --  have matching Import and Interface pragmas.
3146
3147          procedure Set_Convention_From_Pragma (E : Entity_Id);
3148          --  Set convention in entity E, and also flag that the entity has a
3149          --  convention pragma. If entity is for a private or incomplete type,
3150          --  also set convention and flag on underlying type. This procedure
3151          --  also deals with the special case of C_Pass_By_Copy convention.
3152
3153          -------------------------------
3154          -- Diagnose_Multiple_Pragmas --
3155          -------------------------------
3156
3157          procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
3158             Pdec : constant Node_Id := Declaration_Node (S);
3159             Decl : Node_Id;
3160             Err  : Boolean;
3161
3162             function Same_Convention (Decl : Node_Id) return Boolean;
3163             --  Decl is a pragma node. This function returns True if this
3164             --  pragma has a first argument that is an identifier with a
3165             --  Chars field corresponding to the Convention_Id C.
3166
3167             function Same_Name (Decl : Node_Id) return Boolean;
3168             --  Decl is a pragma node. This function returns True if this
3169             --  pragma has a second argument that is an identifier with a
3170             --  Chars field that matches the Chars of the current subprogram.
3171
3172             ---------------------
3173             -- Same_Convention --
3174             ---------------------
3175
3176             function Same_Convention (Decl : Node_Id) return Boolean is
3177                Arg1 : constant Node_Id :=
3178                         First (Pragma_Argument_Associations (Decl));
3179
3180             begin
3181                if Present (Arg1) then
3182                   declare
3183                      Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
3184                   begin
3185                      if Nkind (Arg) = N_Identifier
3186                        and then Is_Convention_Name (Chars (Arg))
3187                        and then Get_Convention_Id (Chars (Arg)) = C
3188                      then
3189                         return True;
3190                      end if;
3191                   end;
3192                end if;
3193
3194                return False;
3195             end Same_Convention;
3196
3197             ---------------
3198             -- Same_Name --
3199             ---------------
3200
3201             function Same_Name (Decl : Node_Id) return Boolean is
3202                Arg1 : constant Node_Id :=
3203                         First (Pragma_Argument_Associations (Decl));
3204                Arg2 : Node_Id;
3205
3206             begin
3207                if No (Arg1) then
3208                   return False;
3209                end if;
3210
3211                Arg2 := Next (Arg1);
3212
3213                if No (Arg2) then
3214                   return False;
3215                end if;
3216
3217                declare
3218                   Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
3219                begin
3220                   if Nkind (Arg) = N_Identifier
3221                     and then Chars (Arg) = Chars (S)
3222                   then
3223                      return True;
3224                   end if;
3225                end;
3226
3227                return False;
3228             end Same_Name;
3229
3230          --  Start of processing for Diagnose_Multiple_Pragmas
3231
3232          begin
3233             Err := True;
3234
3235             --  Definitely give message if we have Convention/Export here
3236
3237             if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
3238                null;
3239
3240                --  If we have an Import or Export, scan back from pragma to
3241                --  find any previous pragma applying to the same procedure.
3242                --  The scan will be terminated by the start of the list, or
3243                --  hitting the subprogram declaration. This won't allow one
3244                --  pragma to appear in the public part and one in the private
3245                --  part, but that seems very unlikely in practice.
3246
3247             else
3248                Decl := Prev (N);
3249                while Present (Decl) and then Decl /= Pdec loop
3250
3251                   --  Look for pragma with same name as us
3252
3253                   if Nkind (Decl) = N_Pragma
3254                     and then Same_Name (Decl)
3255                   then
3256                      --  Give error if same as our pragma or Export/Convention
3257
3258                      if Pragma_Name (Decl) = Name_Export
3259                           or else
3260                         Pragma_Name (Decl) = Name_Convention
3261                           or else
3262                         Pragma_Name (Decl) = Pragma_Name (N)
3263                      then
3264                         exit;
3265
3266                      --  Case of Import/Interface or the other way round
3267
3268                      elsif Pragma_Name (Decl) = Name_Interface
3269                              or else
3270                            Pragma_Name (Decl) = Name_Import
3271                      then
3272                         --  Here we know that we have Import and Interface. It
3273                         --  doesn't matter which way round they are. See if
3274                         --  they specify the same convention. If so, all OK,
3275                         --  and set special flags to stop other messages
3276
3277                         if Same_Convention (Decl) then
3278                            Set_Import_Interface_Present (N);
3279                            Set_Import_Interface_Present (Decl);
3280                            Err := False;
3281
3282                         --  If different conventions, special message
3283
3284                         else
3285                            Error_Msg_Sloc := Sloc (Decl);
3286                            Error_Pragma_Arg
3287                              ("convention differs from that given#", Arg1);
3288                            return;
3289                         end if;
3290                      end if;
3291                   end if;
3292
3293                   Next (Decl);
3294                end loop;
3295             end if;
3296
3297             --  Give message if needed if we fall through those tests
3298
3299             if Err then
3300                Error_Pragma_Arg
3301                  ("at most one Convention/Export/Import pragma is allowed",
3302                   Arg2);
3303             end if;
3304          end Diagnose_Multiple_Pragmas;
3305
3306          --------------------------------
3307          -- Set_Convention_From_Pragma --
3308          --------------------------------
3309
3310          procedure Set_Convention_From_Pragma (E : Entity_Id) is
3311          begin
3312             --  Ada 2005 (AI-430): Check invalid attempt to change convention
3313             --  for an overridden dispatching operation. Technically this is
3314             --  an amendment and should only be done in Ada 2005 mode. However,
3315             --  this is clearly a mistake, since the problem that is addressed
3316             --  by this AI is that there is a clear gap in the RM!
3317
3318             if Is_Dispatching_Operation (E)
3319               and then Present (Overridden_Operation (E))
3320               and then C /= Convention (Overridden_Operation (E))
3321             then
3322                Error_Pragma_Arg
3323                  ("cannot change convention for " &
3324                   "overridden dispatching operation",
3325                   Arg1);
3326             end if;
3327
3328             --  Set the convention
3329
3330             Set_Convention (E, C);
3331             Set_Has_Convention_Pragma (E);
3332
3333             if Is_Incomplete_Or_Private_Type (E)
3334               and then Present (Underlying_Type (E))
3335             then
3336                Set_Convention            (Underlying_Type (E), C);
3337                Set_Has_Convention_Pragma (Underlying_Type (E), True);
3338             end if;
3339
3340             --  A class-wide type should inherit the convention of the specific
3341             --  root type (although this isn't specified clearly by the RM).
3342
3343             if Is_Type (E) and then Present (Class_Wide_Type (E)) then
3344                Set_Convention (Class_Wide_Type (E), C);
3345             end if;
3346
3347             --  If the entity is a record type, then check for special case of
3348             --  C_Pass_By_Copy, which is treated the same as C except that the
3349             --  special record flag is set. This convention is only permitted
3350             --  on record types (see AI95-00131).
3351
3352             if Cname = Name_C_Pass_By_Copy then
3353                if Is_Record_Type (E) then
3354                   Set_C_Pass_By_Copy (Base_Type (E));
3355                elsif Is_Incomplete_Or_Private_Type (E)
3356                  and then Is_Record_Type (Underlying_Type (E))
3357                then
3358                   Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
3359                else
3360                   Error_Pragma_Arg
3361                     ("C_Pass_By_Copy convention allowed only for record type",
3362                      Arg2);
3363                end if;
3364             end if;
3365
3366             --  If the entity is a derived boolean type, check for the special
3367             --  case of convention C, C++, or Fortran, where we consider any
3368             --  nonzero value to represent true.
3369
3370             if Is_Discrete_Type (E)
3371               and then Root_Type (Etype (E)) = Standard_Boolean
3372               and then
3373                 (C = Convention_C
3374                    or else
3375                  C = Convention_CPP
3376                    or else
3377                  C = Convention_Fortran)
3378             then
3379                Set_Nonzero_Is_True (Base_Type (E));
3380             end if;
3381          end Set_Convention_From_Pragma;
3382
3383       --  Start of processing for Process_Convention
3384
3385       begin
3386          Check_At_Least_N_Arguments (2);
3387          Check_Optional_Identifier (Arg1, Name_Convention);
3388          Check_Arg_Is_Identifier (Arg1);
3389          Cname := Chars (Get_Pragma_Arg (Arg1));
3390
3391          --  C_Pass_By_Copy is treated as a synonym for convention C (this is
3392          --  tested again below to set the critical flag).
3393
3394          if Cname = Name_C_Pass_By_Copy then
3395             C := Convention_C;
3396
3397          --  Otherwise we must have something in the standard convention list
3398
3399          elsif Is_Convention_Name (Cname) then
3400             C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));
3401
3402          --  In DEC VMS, it seems that there is an undocumented feature that
3403          --  any unrecognized convention is treated as the default, which for
3404          --  us is convention C. It does not seem so terrible to do this
3405          --  unconditionally, silently in the VMS case, and with a warning
3406          --  in the non-VMS case.
3407
3408          else
3409             if Warn_On_Export_Import and not OpenVMS_On_Target then
3410                Error_Msg_N
3411                  ("?unrecognized convention name, C assumed",
3412                   Get_Pragma_Arg (Arg1));
3413             end if;
3414
3415             C := Convention_C;
3416          end if;
3417
3418          Check_Optional_Identifier (Arg2, Name_Entity);
3419          Check_Arg_Is_Local_Name (Arg2);
3420
3421          Id := Get_Pragma_Arg (Arg2);
3422          Analyze (Id);
3423
3424          if not Is_Entity_Name (Id) then
3425             Error_Pragma_Arg ("entity name required", Arg2);
3426          end if;
3427
3428          E := Entity (Id);
3429
3430          --  Set entity to return
3431
3432          Ent := E;
3433
3434          --  Ada_Pass_By_Copy special checking
3435
3436          if C = Convention_Ada_Pass_By_Copy then
3437             if not Is_First_Subtype (E) then
3438                Error_Pragma_Arg
3439                  ("convention `Ada_Pass_By_Copy` only "
3440                   & "allowed for types", Arg2);
3441             end if;
3442
3443             if Is_By_Reference_Type (E) then
3444                Error_Pragma_Arg
3445                  ("convention `Ada_Pass_By_Copy` not allowed for "
3446                   & "by-reference type", Arg1);
3447             end if;
3448          end if;
3449
3450          --  Ada_Pass_By_Reference special checking
3451
3452          if C = Convention_Ada_Pass_By_Reference then
3453             if not Is_First_Subtype (E) then
3454                Error_Pragma_Arg
3455                  ("convention `Ada_Pass_By_Reference` only "
3456                   & "allowed for types", Arg2);
3457             end if;
3458
3459             if Is_By_Copy_Type (E) then
3460                Error_Pragma_Arg
3461                  ("convention `Ada_Pass_By_Reference` not allowed for "
3462                   & "by-copy type", Arg1);
3463             end if;
3464          end if;
3465
3466          --  Go to renamed subprogram if present, since convention applies to
3467          --  the actual renamed entity, not to the renaming entity. If the
3468          --  subprogram is inherited, go to parent subprogram.
3469
3470          if Is_Subprogram (E)
3471            and then Present (Alias (E))
3472          then
3473             if Nkind (Parent (Declaration_Node (E))) =
3474                                        N_Subprogram_Renaming_Declaration
3475             then
3476                if Scope (E) /= Scope (Alias (E)) then
3477                   Error_Pragma_Ref
3478                     ("cannot apply pragma% to non-local entity&#", E);
3479                end if;
3480
3481                E := Alias (E);
3482
3483             elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
3484                                         N_Private_Extension_Declaration)
3485               and then Scope (E) = Scope (Alias (E))
3486             then
3487                E := Alias (E);
3488
3489                --  Return the parent subprogram the entity was inherited from
3490
3491                Ent := E;
3492             end if;
3493          end if;
3494
3495          --  Check that we are not applying this to a specless body
3496
3497          if Is_Subprogram (E)
3498            and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
3499          then
3500             Error_Pragma
3501               ("pragma% requires separate spec and must come before body");
3502          end if;
3503
3504          --  Check that we are not applying this to a named constant
3505
3506          if Ekind_In (E, E_Named_Integer, E_Named_Real) then
3507             Error_Msg_Name_1 := Pname;
3508             Error_Msg_N
3509               ("cannot apply pragma% to named constant!",
3510                Get_Pragma_Arg (Arg2));
3511             Error_Pragma_Arg
3512               ("\supply appropriate type for&!", Arg2);
3513          end if;
3514
3515          if Ekind (E) = E_Enumeration_Literal then
3516             Error_Pragma ("enumeration literal not allowed for pragma%");
3517          end if;
3518
3519          --  Check for rep item appearing too early or too late
3520
3521          if Etype (E) = Any_Type
3522            or else Rep_Item_Too_Early (E, N)
3523          then
3524             raise Pragma_Exit;
3525
3526          elsif Present (Underlying_Type (E)) then
3527             E := Underlying_Type (E);
3528          end if;
3529
3530          if Rep_Item_Too_Late (E, N) then
3531             raise Pragma_Exit;
3532          end if;
3533
3534          if Has_Convention_Pragma (E) then
3535             Diagnose_Multiple_Pragmas (E);
3536
3537          elsif Convention (E) = Convention_Protected
3538            or else Ekind (Scope (E)) = E_Protected_Type
3539          then
3540             Error_Pragma_Arg
3541               ("a protected operation cannot be given a different convention",
3542                 Arg2);
3543          end if;
3544
3545          --  For Intrinsic, a subprogram is required
3546
3547          if C = Convention_Intrinsic
3548            and then not Is_Subprogram (E)
3549            and then not Is_Generic_Subprogram (E)
3550          then
3551             Error_Pragma_Arg
3552               ("second argument of pragma% must be a subprogram", Arg2);
3553          end if;
3554
3555          --  Stdcall case
3556
3557          if C = Convention_Stdcall then
3558
3559             --  A dispatching call is not allowed. A dispatching subprogram
3560             --  cannot be used to interface to the Win32 API, so in fact this
3561             --  check does not impose any effective restriction.
3562
3563             if Is_Dispatching_Operation (E) then
3564
3565                Error_Pragma
3566                  ("dispatching subprograms cannot use Stdcall convention");
3567
3568             --  Subprogram is allowed, but not a generic subprogram, and not a
3569             --  dispatching operation.
3570
3571             elsif not Is_Subprogram (E)
3572               and then not Is_Generic_Subprogram (E)
3573
3574               --  A variable is OK
3575
3576               and then Ekind (E) /= E_Variable
3577
3578               --  An access to subprogram is also allowed
3579
3580               and then not
3581                 (Is_Access_Type (E)
3582                   and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
3583             then
3584                Error_Pragma_Arg
3585                  ("second argument of pragma% must be subprogram (type)",
3586                   Arg2);
3587             end if;
3588          end if;
3589
3590          if not Is_Subprogram (E)
3591            and then not Is_Generic_Subprogram (E)
3592          then
3593             Set_Convention_From_Pragma (E);
3594
3595             if Is_Type (E) then
3596                Check_First_Subtype (Arg2);
3597                Set_Convention_From_Pragma (Base_Type (E));
3598
3599                --  For subprograms, we must set the convention on the
3600                --  internally generated directly designated type as well.
3601
3602                if Ekind (E) = E_Access_Subprogram_Type then
3603                   Set_Convention_From_Pragma (Directly_Designated_Type (E));
3604                end if;
3605             end if;
3606
3607          --  For the subprogram case, set proper convention for all homonyms
3608          --  in same scope and the same declarative part, i.e. the same
3609          --  compilation unit.
3610
3611          else
3612             Comp_Unit := Get_Source_Unit (E);
3613             Set_Convention_From_Pragma (E);
3614
3615             --  Treat a pragma Import as an implicit body, for GPS use
3616
3617             if Prag_Id = Pragma_Import then
3618                Generate_Reference (E, Id, 'b');
3619             end if;
3620
3621             --  Loop through the homonyms of the pragma argument's entity
3622
3623             E1 := Ent;
3624             loop
3625                E1 := Homonym (E1);
3626                exit when No (E1) or else Scope (E1) /= Current_Scope;
3627
3628                --  Do not set the pragma on inherited operations or on formal
3629                --  subprograms.
3630
3631                if Comes_From_Source (E1)
3632                  and then Comp_Unit = Get_Source_Unit (E1)
3633                  and then not Is_Formal_Subprogram (E1)
3634                  and then Nkind (Original_Node (Parent (E1))) /=
3635                                                     N_Full_Type_Declaration
3636                then
3637                   if Present (Alias (E1))
3638                     and then Scope (E1) /= Scope (Alias (E1))
3639                   then
3640                      Error_Pragma_Ref
3641                        ("cannot apply pragma% to non-local entity& declared#",
3642                         E1);
3643                   end if;
3644
3645                   Set_Convention_From_Pragma (E1);
3646
3647                   if Prag_Id = Pragma_Import then
3648                      Generate_Reference (E1, Id, 'b');
3649                   end if;
3650                end if;
3651
3652                --  For aspect case, do NOT apply to homonyms
3653
3654                exit when From_Aspect_Specification (N);
3655             end loop;
3656          end if;
3657       end Process_Convention;
3658
3659       ----------------------------------------
3660       -- Process_Disable_Enable_Atomic_Sync --
3661       ----------------------------------------
3662
3663       procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
3664       begin
3665          GNAT_Pragma;
3666          Check_No_Identifiers;
3667          Check_At_Most_N_Arguments (1);
3668
3669          --  Modeled internally as
3670          --    pragma Unsuppress (Atomic_Synchronization [,Entity])
3671
3672          Rewrite (N,
3673            Make_Pragma (Loc,
3674              Pragma_Identifier            =>
3675                Make_Identifier (Loc, Nam),
3676              Pragma_Argument_Associations => New_List (
3677                Make_Pragma_Argument_Association (Loc,
3678                  Expression =>
3679                    Make_Identifier (Loc, Name_Atomic_Synchronization)))));
3680
3681          if Present (Arg1) then
3682             Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
3683          end if;
3684
3685          Analyze (N);
3686       end Process_Disable_Enable_Atomic_Sync;
3687
3688       -----------------------------------------------------
3689       -- Process_Extended_Import_Export_Exception_Pragma --
3690       -----------------------------------------------------
3691
3692       procedure Process_Extended_Import_Export_Exception_Pragma
3693         (Arg_Internal : Node_Id;
3694          Arg_External : Node_Id;
3695          Arg_Form     : Node_Id;
3696          Arg_Code     : Node_Id)
3697       is
3698          Def_Id   : Entity_Id;
3699          Code_Val : Uint;
3700
3701       begin
3702          if not OpenVMS_On_Target then
3703             Error_Pragma
3704               ("?pragma% ignored (applies only to Open'V'M'S)");
3705          end if;
3706
3707          Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
3708          Def_Id := Entity (Arg_Internal);
3709
3710          if Ekind (Def_Id) /= E_Exception then
3711             Error_Pragma_Arg
3712               ("pragma% must refer to declared exception", Arg_Internal);
3713          end if;
3714
3715          Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
3716
3717          if Present (Arg_Form) then
3718             Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
3719          end if;
3720
3721          if Present (Arg_Form)
3722 &n