OSDN Git Service

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