OSDN Git Service

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