[pf3gnuchains/gcc-fork.git] / gcc / ada / sem_prag.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S E M _ P R A G                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This unit contains the semantic processing for all pragmas, both language
--  and implementation defined. For most pragmas, the parser only does the
--  most basic job of checking the syntax, so Sem_Prag also contains the code
--  to complete the syntax checks. Certain pragmas are handled partially or
--  completely by the parser (see Par.Prag for further details).

with Aspects;  use Aspects;
with Atree;    use Atree;
with Casing;   use Casing;
with Checks;   use Checks;
with Csets;    use Csets;
with Debug;    use Debug;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Errout;   use Errout;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Freeze;   use Freeze;
with Lib;      use Lib;
with Lib.Writ; use Lib.Writ;
with Lib.Xref; use Lib.Xref;
with Namet.Sp; use Namet.Sp;
with Nlists;   use Nlists;
with Nmake;    use Nmake;
with Opt;      use Opt;
with Output;   use Output;
with Par_SCO;  use Par_SCO;
with Restrict; use Restrict;
with Rident;   use Rident;
with Rtsfind;  use Rtsfind;
with Sem;      use Sem;
with Sem_Aux;  use Sem_Aux;
with Sem_Ch3;  use Sem_Ch3;
with Sem_Ch6;  use Sem_Ch6;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Sem_Mech; use Sem_Mech;
with Sem_Res;  use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_VFpt; use Sem_VFpt;
with Sem_Warn; use Sem_Warn;
with Stand;    use Stand;
with Sinfo;    use Sinfo;
with Sinfo.CN; use Sinfo.CN;
with Sinput;   use Sinput;
with Snames;   use Snames;
with Stringt;  use Stringt;
with Stylesw;  use Stylesw;
with Table;
with Targparm; use Targparm;
with Tbuild;   use Tbuild;
with Ttypes;
with Uintp;    use Uintp;
with Uname;    use Uname;
with Urealp;   use Urealp;
with Validsw;  use Validsw;
with Warnsw;   use Warnsw;

package body Sem_Prag is

   ----------------------------------------------
   -- Common Handling of Import-Export Pragmas --
   ----------------------------------------------

   --  In the following section, a number of Import_xxx and Export_xxx pragmas
   --  are defined by GNAT. These are compatible with the DEC pragmas of the
   --  same name, and all have the following common form and processing:

   --  pragma Export_xxx
   --        [Internal                 =>] LOCAL_NAME
   --     [, [External                 =>] EXTERNAL_SYMBOL]
   --     [, other optional parameters   ]);

   --  pragma Import_xxx
   --        [Internal                 =>] LOCAL_NAME
   --     [, [External                 =>] EXTERNAL_SYMBOL]
   --     [, other optional parameters   ]);

   --   EXTERNAL_SYMBOL ::=
   --     IDENTIFIER
   --   | static_string_EXPRESSION

   --  The internal LOCAL_NAME designates the entity that is imported or
   --  exported, and must refer to an entity in the current declarative
   --  part (as required by the rules for LOCAL_NAME).

   --  The external linker name is designated by the External parameter if
   --  given, or the Internal parameter if not (if there is no External
   --  parameter, the External parameter is a copy of the Internal name).

   --  If the External parameter is given as a string, then this string is
   --  treated as an external name (exactly as though it had been given as an
   --  External_Name parameter for a normal Import pragma).

   --  If the External parameter is given as an identifier (or there is no
   --  External parameter, so that the Internal identifier is used), then
   --  the external name is the characters of the identifier, translated
   --  to all upper case letters for OpenVMS versions of GNAT, and to all
   --  lower case letters for all other versions

   --  Note: the external name specified or implied by any of these special
   --  Import_xxx or Export_xxx pragmas override an external or link name
   --  specified in a previous Import or Export pragma.

   --  Note: these and all other DEC-compatible GNAT pragmas allow full use of
   --  named notation, following the standard rules for subprogram calls, i.e.
   --  parameters can be given in any order if named notation is used, and
   --  positional and named notation can be mixed, subject to the rule that all
   --  positional parameters must appear first.

   --  Note: All these pragmas are implemented exactly following the DEC design
   --  and implementation and are intended to be fully compatible with the use
   --  of these pragmas in the DEC Ada compiler.

   --------------------------------------------
   -- Checking for Duplicated External Names --
   --------------------------------------------

   --  It is suspicious if two separate Export pragmas use the same external
   --  name. The following table is used to diagnose this situation so that
   --  an appropriate warning can be issued.

   --  The Node_Id stored is for the N_String_Literal node created to hold
   --  the value of the external name. The Sloc of this node is used to
   --  cross-reference the location of the duplication.

   package Externals is new Table.Table (
     Table_Component_Type => Node_Id,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 0,
     Table_Initial        => 100,
     Table_Increment      => 100,
     Table_Name           => "Name_Externals");

   -------------------------------------
   -- Local Subprograms and Variables --
   -------------------------------------

   function Adjust_External_Name_Case (N : Node_Id) return Node_Id;
   --  This routine is used for possible casing adjustment of an explicit
   --  external name supplied as a string literal (the node N), according to
   --  the casing requirement of Opt.External_Name_Casing. If this is set to
   --  As_Is, then the string literal is returned unchanged, but if it is set
   --  to Uppercase or Lowercase, then a new string literal with appropriate
   --  casing is constructed.

   function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
   --  If Def_Id refers to a renamed subprogram, then the base subprogram (the
   --  original one, following the renaming chain) is returned. Otherwise the
   --  entity is returned unchanged. Should be in Einfo???

   procedure Preanalyze_TC_Args (N, Arg_Req, Arg_Ens : Node_Id);
   --  Preanalyze the boolean expressions in the Requires and Ensures arguments
   --  of a Test_Case pragma if present (possibly Empty). We treat these as
   --  spec expressions (i.e. similar to a default expression).

   procedure rv;
   --  This is a dummy function called by the processing for pragma Reviewable.
   --  It is there for assisting front end debugging. By placing a Reviewable
   --  pragma in the source program, a breakpoint on rv catches this place in
   --  the source, allowing convenient stepping to the point of interest.

   procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id);
   --  Place semantic information on the argument of an Elaborate/Elaborate_All
   --  pragma. Entity name for unit and its parents is taken from item in
   --  previous with_clause that mentions the unit.

   -------------------------------
   -- Adjust_External_Name_Case --
   -------------------------------

   function Adjust_External_Name_Case (N : Node_Id) return Node_Id is
      CC : Char_Code;

   begin
      --  Adjust case of literal if required

      if Opt.External_Name_Exp_Casing = As_Is then
         return N;

      else
         --  Copy existing string

         Start_String;

         --  Set proper casing

         for J in 1 .. String_Length (Strval (N)) loop
            CC := Get_String_Char (Strval (N), J);

            if Opt.External_Name_Exp_Casing = Uppercase
              and then CC >= Get_Char_Code ('a')
              and then CC <= Get_Char_Code ('z')
            then
               Store_String_Char (CC - 32);

            elsif Opt.External_Name_Exp_Casing = Lowercase
              and then CC >= Get_Char_Code ('A')
              and then CC <= Get_Char_Code ('Z')
            then
               Store_String_Char (CC + 32);

            else
               Store_String_Char (CC);
            end if;
         end loop;

         return
           Make_String_Literal (Sloc (N),
             Strval => End_String);
      end if;
   end Adjust_External_Name_Case;

   ------------------------------
   -- Analyze_PPC_In_Decl_Part --
   ------------------------------

   procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
      Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));

   begin
      --  Install formals and push subprogram spec onto scope stack so that we
      --  can see the formals from the pragma.

      Install_Formals (S);
      Push_Scope (S);

      --  Preanalyze the boolean expression, we treat this as a spec expression
      --  (i.e. similar to a default expression).

      Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean);

      --  In ASIS mode, for a pragma generated from a source aspect, also
      --  analyze the original aspect expression.

      if ASIS_Mode
        and then Present (Corresponding_Aspect (N))
      then
         Preanalyze_Spec_Expression
           (Expression (Corresponding_Aspect (N)), Standard_Boolean);
      end if;

      --  For a class-wide condition, a reference to a controlling formal must
      --  be interpreted as having the class-wide type (or an access to such)
      --  so that the inherited condition can be properly applied to any
      --  overriding operation (see ARM12 6.6.1 (7)).

      if Class_Present (N) then
         declare
            T   : constant Entity_Id := Find_Dispatching_Type (S);

            ACW : Entity_Id := Empty;
            --  Access to T'class, created if there is a controlling formal
            --  that is an access parameter.

            function Get_ACW return Entity_Id;
            --  If the expression has a reference to an controlling access
            --  parameter, create an access to T'class for the necessary
            --  conversions if one does not exist.

            function Process (N : Node_Id) return Traverse_Result;
            --  ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
            --  aspect for a primitive subprogram of a tagged type T, a name
            --  that denotes a formal parameter of type T is interpreted as
            --  having type T'Class. Similarly, a name that denotes a formal
            --  accessparameter of type access-to-T is interpreted as having
            --  type access-to-T'Class. This ensures the expression is well-
            --  defined for a primitive subprogram of a type descended from T.

            -------------
            -- Get_ACW --
            -------------

            function Get_ACW return Entity_Id is
               Loc  : constant Source_Ptr := Sloc (N);
               Decl : Node_Id;

            begin
               if No (ACW) then
                  Decl := Make_Full_Type_Declaration (Loc,
                    Defining_Identifier => Make_Temporary (Loc, 'T'),
                    Type_Definition =>
                       Make_Access_To_Object_Definition (Loc,
                       Subtype_Indication =>
                         New_Occurrence_Of (Class_Wide_Type (T), Loc),
                       All_Present => True));

                  Insert_Before (Unit_Declaration_Node (S), Decl);
                  Analyze (Decl);
                  ACW := Defining_Identifier (Decl);
                  Freeze_Before (Unit_Declaration_Node (S), ACW);
               end if;

               return ACW;
            end Get_ACW;

            -------------
            -- Process --
            -------------

            function Process (N : Node_Id) return Traverse_Result is
               Loc : constant Source_Ptr := Sloc (N);
               Typ : Entity_Id;

            begin
               if Is_Entity_Name (N)
                 and then Is_Formal (Entity (N))
                 and then Nkind (Parent (N)) /= N_Type_Conversion
               then
                  if Etype (Entity (N)) = T then
                     Typ := Class_Wide_Type (T);

                  elsif Is_Access_Type (Etype (Entity (N)))
                    and then Designated_Type (Etype (Entity (N))) = T
                  then
                     Typ := Get_ACW;
                  else
                     Typ := Empty;
                  end if;

                  if Present (Typ) then
                     Rewrite (N,
                       Make_Type_Conversion (Loc,
                         Subtype_Mark =>
                           New_Occurrence_Of (Typ, Loc),
                         Expression  => New_Occurrence_Of (Entity (N), Loc)));
                     Set_Etype (N, Typ);
                  end if;
               end if;

               return OK;
            end Process;

            procedure Replace_Type is new Traverse_Proc (Process);

         begin
            Replace_Type (Get_Pragma_Arg (Arg1));
         end;
      end if;

      --  Remove the subprogram from the scope stack now that the pre-analysis
      --  of the precondition/postcondition is done.

      End_Scope;
   end Analyze_PPC_In_Decl_Part;

   --------------------
   -- Analyze_Pragma --
   --------------------

   procedure Analyze_Pragma (N : Node_Id) is
      Loc     : constant Source_Ptr := Sloc (N);
      Prag_Id : Pragma_Id;

      Pname : Name_Id;
      --  Name of the source pragma, or name of the corresponding aspect for
      --  pragmas which originate in a source aspect. In the latter case, the
      --  name may be different from the pragma name.

      Pragma_Exit : exception;
      --  This exception is used to exit pragma processing completely. It is
      --  used when an error is detected, and no further processing is
      --  required. It is also used if an earlier error has left the tree in
      --  a state where the pragma should not be processed.

      Arg_Count : Nat;
      --  Number of pragma argument associations

      Arg1 : Node_Id;
      Arg2 : Node_Id;
      Arg3 : Node_Id;
      Arg4 : Node_Id;
      --  First four pragma arguments (pragma argument association nodes, or
      --  Empty if the corresponding argument does not exist).

      type Name_List is array (Natural range <>) of Name_Id;
      type Args_List is array (Natural range <>) of Node_Id;
      --  Types used for arguments to Check_Arg_Order and Gather_Associations

      procedure Ada_2005_Pragma;
      --  Called for pragmas defined in Ada 2005, that are not in Ada 95. In
      --  Ada 95 mode, these are implementation defined pragmas, so should be
      --  caught by the No_Implementation_Pragmas restriction.

      procedure Ada_2012_Pragma;
      --  Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
      --  In Ada 95 or 05 mode, these are implementation defined pragmas, so
      --  should be caught by the No_Implementation_Pragmas restriction.

      procedure Check_Ada_83_Warning;
      --  Issues a warning message for the current pragma if operating in Ada
      --  83 mode (used for language pragmas that are not a standard part of
      --  Ada 83). This procedure does not raise Error_Pragma. Also notes use
      --  of 95 pragma.

      procedure Check_Arg_Count (Required : Nat);
      --  Check argument count for pragma is equal to given parameter. If not,
      --  then issue an error message and raise Pragma_Exit.

      --  Note: all routines whose name is Check_Arg_Is_xxx take an argument
      --  Arg which can either be a pragma argument association, in which case
      --  the check is applied to the expression of the association or an
      --  expression directly.

      procedure Check_Arg_Is_External_Name (Arg : Node_Id);
      --  Check that an argument has the right form for an EXTERNAL_NAME
      --  parameter of an extended import/export pragma. The rule is that the
      --  name must be an identifier or string literal (in Ada 83 mode) or a
      --  static string expression (in Ada 95 mode).

      procedure Check_Arg_Is_Identifier (Arg : Node_Id);
      --  Check the specified argument Arg to make sure that it is an
      --  identifier. If not give error and raise Pragma_Exit.

      procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id);
      --  Check the specified argument Arg to make sure that it is an integer
      --  literal. If not give error and raise Pragma_Exit.

      procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id);
      --  Check the specified argument Arg to make sure that it has the proper
      --  syntactic form for a local name and meets the semantic requirements
      --  for a local name. The local name is analyzed as part of the
      --  processing for this call. In addition, the local name is required
      --  to represent an entity at the library level.

      procedure Check_Arg_Is_Local_Name (Arg : Node_Id);
      --  Check the specified argument Arg to make sure that it has the proper
      --  syntactic form for a local name and meets the semantic requirements
      --  for a local name. The local name is analyzed as part of the
      --  processing for this call.

      procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id);
      --  Check the specified argument Arg to make sure that it is a valid
      --  locking policy name. If not give error and raise Pragma_Exit.

      procedure Check_Arg_Is_One_Of
        (Arg                : Node_Id;
         N1, N2             : Name_Id);
      procedure Check_Arg_Is_One_Of
        (Arg                : Node_Id;
         N1, N2, N3         : Name_Id);
      procedure Check_Arg_Is_One_Of
        (Arg                : Node_Id;
         N1, N2, N3, N4, N5 : Name_Id);
      --  Check the specified argument Arg to make sure that it is an
      --  identifier whose name matches either N1 or N2 (or N3, N4, N5 if
      --  present). If not then give error and raise Pragma_Exit.

      procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
      --  Check the specified argument Arg to make sure that it is a valid
      --  queuing policy name. If not give error and raise Pragma_Exit.

      procedure Check_Arg_Is_Static_Expression
        (Arg : Node_Id;
         Typ : Entity_Id := Empty);
      --  Check the specified argument Arg to make sure that it is a static
      --  expression of the given type (i.e. it will be analyzed and resolved
      --  using this type, which can be any valid argument to Resolve, e.g.
      --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
      --  Typ is left Empty, then any static expression is allowed.

      procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
      --  Check the specified argument Arg to make sure that it is a valid task
      --  dispatching policy name. If not give error and raise Pragma_Exit.

      procedure Check_Arg_Order (Names : Name_List);
      --  Checks for an instance of two arguments with identifiers for the
      --  current pragma which are not in the sequence indicated by Names,
      --  and if so, generates a fatal message about bad order of arguments.

      procedure Check_At_Least_N_Arguments (N : Nat);
      --  Check there are at least N arguments present

      procedure Check_At_Most_N_Arguments (N : Nat);
      --  Check there are no more than N arguments present

      procedure Check_Component
        (Comp            : Node_Id;
         UU_Typ          : Entity_Id;
         In_Variant_Part : Boolean := False);
      --  Examine an Unchecked_Union component for correct use of per-object
      --  constrained subtypes, and for restrictions on finalizable components.
      --  UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
      --  should be set when Comp comes from a record variant.

      procedure Check_Duplicate_Pragma (E : Entity_Id);
      --  Check if a pragma of the same name as the current pragma is already
      --  chained as a rep pragma to the given entity. If so give a message
      --  about the duplicate, and then raise Pragma_Exit so does not return.
      --  Also checks for delayed aspect specification node in the chain.

      procedure Check_Duplicated_Export_Name (Nam : Node_Id);
      --  Nam is an N_String_Literal node containing the external name set by
      --  an Import or Export pragma (or extended Import or Export pragma).
      --  This procedure checks for possible duplications if this is the export
      --  case, and if found, issues an appropriate error message.

      procedure Check_Expr_Is_Static_Expression
        (Expr : Node_Id;
         Typ  : Entity_Id := Empty);
      --  Check the specified expression Expr to make sure that it is a static
      --  expression of the given type (i.e. it will be analyzed and resolved
      --  using this type, which can be any valid argument to Resolve, e.g.
      --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
      --  Typ is left Empty, then any static expression is allowed.

      procedure Check_First_Subtype (Arg : Node_Id);
      --  Checks that Arg, whose expression is an entity name, references a
      --  first subtype.

      procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
      --  Checks that the given argument has an identifier, and if so, requires
      --  it to match the given identifier name. If there is no identifier, or
      --  a non-matching identifier, then an error message is given and
      --  Pragma_Exit is raised.

      procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
      --  Checks that the given argument has an identifier, and if so, requires
      --  it to match one of the given identifier names. If there is no
      --  identifier, or a non-matching identifier, then an error message is
      --  given and Pragma_Exit is raised.

      procedure Check_In_Main_Program;
      --  Common checks for pragmas that appear within a main program
      --  (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).

      procedure Check_Interrupt_Or_Attach_Handler;
      --  Common processing for first argument of pragma Interrupt_Handler or
      --  pragma Attach_Handler.

      procedure Check_Is_In_Decl_Part_Or_Package_Spec;
      --  Check that pragma appears in a declarative part, or in a package
      --  specification, i.e. that it does not occur in a statement sequence
      --  in a body.

      procedure Check_No_Identifier (Arg : Node_Id);
      --  Checks that the given argument does not have an identifier. If
      --  an identifier is present, then an error message is issued, and
      --  Pragma_Exit is raised.

      procedure Check_No_Identifiers;
      --  Checks that none of the arguments to the pragma has an identifier.
      --  If any argument has an identifier, then an error message is issued,
      --  and Pragma_Exit is raised.

      procedure Check_No_Link_Name;
      --  Checks that no link name is specified

      procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
      --  Checks if the given argument has an identifier, and if so, requires
      --  it to match the given identifier name. If there is a non-matching
      --  identifier, then an error message is given and Pragma_Exit is raised.

      procedure Check_Optional_Identifier (Arg : Node_Id; Id : String);
      --  Checks if the given argument has an identifier, and if so, requires
      --  it to match the given identifier name. If there is a non-matching
      --  identifier, then an error message is given and Pragma_Exit is raised.
      --  In this version of the procedure, the identifier name is given as
      --  a string with lower case letters.

      procedure Check_Precondition_Postcondition (In_Body : out Boolean);
      --  Called to process a precondition or postcondition pragma. There are
      --  three cases:
      --
      --    The pragma appears after a subprogram spec
      --
      --      If the corresponding check is not enabled, the pragma is analyzed
      --      but otherwise ignored and control returns with In_Body set False.
      --
      --      If the check is enabled, then the first step is to analyze the
      --      pragma, but this is skipped if the subprogram spec appears within
      --      a package specification (because this is the case where we delay
      --      analysis till the end of the spec). Then (whether or not it was
      --      analyzed), the pragma is chained to the subprogram in question
      --      (using Spec_PPC_List and Next_Pragma) and control returns to the
      --      caller with In_Body set False.
      --
      --    The pragma appears at the start of subprogram body declarations
      --
      --      In this case an immediate return to the caller is made with
      --      In_Body set True, and the pragma is NOT analyzed.
      --
      --    In all other cases, an error message for bad placement is given

      procedure Check_Static_Constraint (Constr : Node_Id);
      --  Constr is a constraint from an N_Subtype_Indication node from a
      --  component constraint in an Unchecked_Union type. This routine checks
      --  that the constraint is static as required by the restrictions for
      --  Unchecked_Union.

      procedure Check_Test_Case;
      --  Called to process a test-case pragma. The treatment is similar to the
      --  one for pre- and postcondition in Check_Precondition_Postcondition,
      --  except the placement rules for the test-case pragma are stricter.
      --  This pragma may only occur after a subprogram spec declared directly
      --  in a package spec unit. In this case, the pragma is chained to the
      --  subprogram in question (using Spec_TC_List and Next_Pragma) and
      --  analysis of the pragma is delayed till the end of the spec. In
      --  all other cases, an error message for bad placement is given.

      procedure Check_Valid_Configuration_Pragma;
      --  Legality checks for placement of a configuration pragma

      procedure Check_Valid_Library_Unit_Pragma;
      --  Legality checks for library unit pragmas. A special case arises for
      --  pragmas in generic instances that come from copies of the original
      --  library unit pragmas in the generic templates. In the case of other
      --  than library level instantiations these can appear in contexts which
      --  would normally be invalid (they only apply to the original template
      --  and to library level instantiations), and they are simply ignored,
      --  which is implemented by rewriting them as null statements.

      procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
      --  Check an Unchecked_Union variant for lack of nested variants and
      --  presence of at least one component. UU_Typ is the related Unchecked_
      --  Union type.

      procedure Error_Pragma (Msg : String);
      pragma No_Return (Error_Pragma);
      --  Outputs error message for current pragma. The message contains a %
      --  that will be replaced with the pragma name, and the flag is placed
      --  on the pragma itself. Pragma_Exit is then raised.

      procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id);
      pragma No_Return (Error_Pragma_Arg);
      --  Outputs error message for current pragma. The message may contain
      --  a % that will be replaced with the pragma name. The parameter Arg
      --  may either be a pragma argument association, in which case the flag
      --  is placed on the expression of this association, or an expression,
      --  in which case the flag is placed directly on the expression. The
      --  message is placed using Error_Msg_N, so the message may also contain
      --  an & insertion character which will reference the given Arg value.
      --  After placing the message, Pragma_Exit is raised.

      procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id);
      pragma No_Return (Error_Pragma_Arg);
      --  Similar to above form of Error_Pragma_Arg except that two messages
      --  are provided, the second is a continuation comment starting with \.

      procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id);
      pragma No_Return (Error_Pragma_Arg_Ident);
      --  Outputs error message for current pragma. The message may contain
      --  a % that will be replaced with the pragma name. The parameter Arg
      --  must be a pragma argument association with a non-empty identifier
      --  (i.e. its Chars field must be set), and the error message is placed
      --  on the identifier. The message is placed using Error_Msg_N so
      --  the message may also contain an & insertion character which will
      --  reference the identifier. After placing the message, Pragma_Exit
      --  is raised.

      procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
      pragma No_Return (Error_Pragma_Ref);
      --  Outputs error message for current pragma. The message may contain
      --  a % that will be replaced with the pragma name. The parameter Ref
      --  must be an entity whose name can be referenced by & and sloc by #.
      --  After placing the message, Pragma_Exit is raised.

      function Find_Lib_Unit_Name return Entity_Id;
      --  Used for a library unit pragma to find the entity to which the
      --  library unit pragma applies, returns the entity found.

      procedure Find_Program_Unit_Name (Id : Node_Id);
      --  If the pragma is a compilation unit pragma, the id must denote the
      --  compilation unit in the same compilation, and the pragma must appear
      --  in the list of preceding or trailing pragmas. If it is a program
      --  unit pragma that is not a compilation unit pragma, then the
      --  identifier must be visible.

      function Find_Unique_Parameterless_Procedure
        (Name : Entity_Id;
         Arg  : Node_Id) return Entity_Id;
      --  Used for a procedure pragma to find the unique parameterless
      --  procedure identified by Name, returns it if it exists, otherwise
      --  errors out and uses Arg as the pragma argument for the message.

      procedure Fix_Error (Msg : in out String);
      --  This is called prior to issuing an error message. Msg is a string
      --  which typically contains the substring pragma. If the current pragma
      --  comes from an aspect, each such "pragma" substring is replaced with
      --  the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
      --  (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).

      procedure Gather_Associations
        (Names : Name_List;
         Args  : out Args_List);
      --  This procedure is used to gather the arguments for a pragma that
      --  permits arbitrary ordering of parameters using the normal rules
      --  for named and positional parameters. The Names argument is a list
      --  of Name_Id values that corresponds to the allowed pragma argument
      --  association identifiers in order. The result returned in Args is
      --  a list of corresponding expressions that are the pragma arguments.
      --  Note that this is a list of expressions, not of pragma argument
      --  associations (Gather_Associations has completely checked all the
      --  optional identifiers when it returns). An entry in Args is Empty
      --  on return if the corresponding argument is not present.

      procedure GNAT_Pragma;
      --  Called for all GNAT defined pragmas to check the relevant restriction
      --  (No_Implementation_Pragmas).

      function Is_Before_First_Decl
        (Pragma_Node : Node_Id;
         Decls       : List_Id) return Boolean;
      --  Return True if Pragma_Node is before the first declarative item in
      --  Decls where Decls is the list of declarative items.

      function Is_Configuration_Pragma return Boolean;
      --  Determines if the placement of the current pragma is appropriate
      --  for a configuration pragma.

      function Is_In_Context_Clause return Boolean;
      --  Returns True if pragma appears within the context clause of a unit,
      --  and False for any other placement (does not generate any messages).

      function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
      --  Analyzes the argument, and determines if it is a static string
      --  expression, returns True if so, False if non-static or not String.

      procedure Pragma_Misplaced;
      pragma No_Return (Pragma_Misplaced);
      --  Issue fatal error message for misplaced pragma

      procedure Process_Atomic_Shared_Volatile;
      --  Common processing for pragmas Atomic, Shared, Volatile. Note that
      --  Shared is an obsolete Ada 83 pragma, treated as being identical
      --  in effect to pragma Atomic.

      procedure Process_Compile_Time_Warning_Or_Error;
      --  Common processing for Compile_Time_Error and Compile_Time_Warning

      procedure Process_Convention
        (C   : out Convention_Id;
         Ent : out Entity_Id);
      --  Common processing for Convention, Interface, Import and Export.
      --  Checks first two arguments of pragma, and sets the appropriate
      --  convention value in the specified entity or entities. On return
      --  C is the convention, Ent is the referenced entity.

      procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id);
      --  Common processing for Disable/Enable_Atomic_Synchronization. Nam is
      --  Name_Suppress for Disable and Name_Unsuppress for Enable.

      procedure Process_Extended_Import_Export_Exception_Pragma
        (Arg_Internal : Node_Id;
         Arg_External : Node_Id;
         Arg_Form     : Node_Id;
         Arg_Code     : Node_Id);
      --  Common processing for the pragmas Import/Export_Exception. The three
      --  arguments correspond to the three named parameters of the pragma. An
      --  argument is empty if the corresponding parameter is not present in
      --  the pragma.

      procedure Process_Extended_Import_Export_Object_Pragma
        (Arg_Internal : Node_Id;
         Arg_External : Node_Id;
         Arg_Size     : Node_Id);
      --  Common processing for the pragmas Import/Export_Object. The three
      --  arguments correspond to the three named parameters of the pragmas. An
      --  argument is empty if the corresponding parameter is not present in
      --  the pragma.

      procedure Process_Extended_Import_Export_Internal_Arg
        (Arg_Internal : Node_Id := Empty);
      --  Common processing for all extended Import and Export pragmas. The
      --  argument is the pragma parameter for the Internal argument. If
      --  Arg_Internal is empty or inappropriate, an error message is posted.
      --  Otherwise, on normal return, the Entity_Field of Arg_Internal is
      --  set to identify the referenced entity.

      procedure Process_Extended_Import_Export_Subprogram_Pragma
        (Arg_Internal                 : Node_Id;
         Arg_External                 : Node_Id;
         Arg_Parameter_Types          : Node_Id;
         Arg_Result_Type              : Node_Id := Empty;
         Arg_Mechanism                : Node_Id;
         Arg_Result_Mechanism         : Node_Id := Empty;
         Arg_First_Optional_Parameter : Node_Id := Empty);
      --  Common processing for all extended Import and Export pragmas applying
      --  to subprograms. The caller omits any arguments that do not apply to
      --  the pragma in question (for example, Arg_Result_Type can be non-Empty
      --  only in the Import_Function and Export_Function cases). The argument
      --  names correspond to the allowed pragma association identifiers.

      procedure Process_Generic_List;
      --  Common processing for Share_Generic and Inline_Generic

      procedure Process_Import_Or_Interface;
      --  Common processing for Import of Interface

      procedure Process_Import_Predefined_Type;
      --  Processing for completing a type with pragma Import. This is used
      --  to declare types that match predefined C types, especially for cases
      --  without corresponding Ada predefined type.

      procedure Process_Inline (Active : Boolean);
      --  Common processing for Inline and Inline_Always. The parameter
      --  indicates if the inline pragma is active, i.e. if it should actually
      --  cause inlining to occur.

      procedure Process_Interface_Name
        (Subprogram_Def : Entity_Id;
         Ext_Arg        : Node_Id;
         Link_Arg       : Node_Id);
      --  Given the last two arguments of pragma Import, pragma Export, or
      --  pragma Interface_Name, performs validity checks and sets the
      --  Interface_Name field of the given subprogram entity to the
      --  appropriate external or link name, depending on the arguments given.
      --  Ext_Arg is always present, but Link_Arg may be missing. Note that
      --  Ext_Arg may represent the Link_Name if Link_Arg is missing, and
      --  appropriate named notation is used for Ext_Arg. If neither Ext_Arg
      --  nor Link_Arg is present, the interface name is set to the default
      --  from the subprogram name.

      procedure Process_Interrupt_Or_Attach_Handler;
      --  Common processing for Interrupt and Attach_Handler pragmas

      procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
      --  Common processing for Restrictions and Restriction_Warnings pragmas.
      --  Warn is True for Restriction_Warnings, or for Restrictions if the
      --  flag Treat_Restrictions_As_Warnings is set, and False if this flag
      --  is not set in the Restrictions case.

      procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
      --  Common processing for Suppress and Unsuppress. The boolean parameter
      --  Suppress_Case is True for the Suppress case, and False for the
      --  Unsuppress case.

      procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
      --  This procedure sets the Is_Exported flag for the given entity,
      --  checking that the entity was not previously imported. Arg is
      --  the argument that specified the entity. A check is also made
      --  for exporting inappropriate entities.

      procedure Set_Extended_Import_Export_External_Name
        (Internal_Ent : Entity_Id;
         Arg_External : Node_Id);
      --  Common processing for all extended import export pragmas. The first
      --  argument, Internal_Ent, is the internal entity, which has already
      --  been checked for validity by the caller. Arg_External is from the
      --  Import or Export pragma, and may be null if no External parameter
      --  was present. If Arg_External is present and is a non-null string
      --  (a null string is treated as the default), then the Interface_Name
      --  field of Internal_Ent is set appropriately.

      procedure Set_Imported (E : Entity_Id);
      --  This procedure sets the Is_Imported flag for the given entity,
      --  checking that it is not previously exported or imported.

      procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id);
      --  Mech is a parameter passing mechanism (see Import_Function syntax
      --  for MECHANISM_NAME). This routine checks that the mechanism argument
      --  has the right form, and if not issues an error message. If the
      --  argument has the right form then the Mechanism field of Ent is
      --  set appropriately.

      procedure Set_Ravenscar_Profile (N : Node_Id);
      --  Activate the set of configuration pragmas and restrictions that make
      --  up the Ravenscar Profile. N is the corresponding pragma node, which
      --  is used for error messages on any constructs that violate the
      --  profile.

      ---------------------
      -- Ada_2005_Pragma --
      ---------------------

      procedure Ada_2005_Pragma is
      begin
         if Ada_Version <= Ada_95 then
            Check_Restriction (No_Implementation_Pragmas, N);
         end if;
      end Ada_2005_Pragma;

      ---------------------
      -- Ada_2012_Pragma --
      ---------------------

      procedure Ada_2012_Pragma is
      begin
         if Ada_Version <= Ada_2005 then
            Check_Restriction (No_Implementation_Pragmas, N);
         end if;
      end Ada_2012_Pragma;

      --------------------------
      -- Check_Ada_83_Warning --
      --------------------------

      procedure Check_Ada_83_Warning is
      begin
         if Ada_Version = Ada_83 and then Comes_From_Source (N) then
            Error_Msg_N ("(Ada 83) pragma& is non-standard?", N);
         end if;
      end Check_Ada_83_Warning;

      ---------------------
      -- Check_Arg_Count --
      ---------------------

      procedure Check_Arg_Count (Required : Nat) is
      begin
         if Arg_Count /= Required then
            Error_Pragma ("wrong number of arguments for pragma%");
         end if;
      end Check_Arg_Count;

      --------------------------------
      -- Check_Arg_Is_External_Name --
      --------------------------------

      procedure Check_Arg_Is_External_Name (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         if Nkind (Argx) = N_Identifier then
            return;

         else
            Analyze_And_Resolve (Argx, Standard_String);

            if Is_OK_Static_Expression (Argx) then
               return;

            elsif Etype (Argx) = Any_Type then
               raise Pragma_Exit;

            --  An interesting special case, if we have a string literal and
            --  we are in Ada 83 mode, then we allow it even though it will
            --  not be flagged as static. This allows expected Ada 83 mode
            --  use of external names which are string literals, even though
            --  technically these are not static in Ada 83.

            elsif Ada_Version = Ada_83
              and then Nkind (Argx) = N_String_Literal
            then
               return;

            --  Static expression that raises Constraint_Error. This has
            --  already been flagged, so just exit from pragma processing.

            elsif Is_Static_Expression (Argx) then
               raise Pragma_Exit;

            --  Here we have a real error (non-static expression)

            else
               Error_Msg_Name_1 := Pname;

               declare
                  Msg : String :=
                          "argument for pragma% must be a identifier or "
                          & "static string expression!";
               begin
                  Fix_Error (Msg);
                  Flag_Non_Static_Expr (Msg, Argx);
                  raise Pragma_Exit;
               end;
            end if;
         end if;
      end Check_Arg_Is_External_Name;

      -----------------------------
      -- Check_Arg_Is_Identifier --
      -----------------------------

      procedure Check_Arg_Is_Identifier (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
      begin
         if Nkind (Argx) /= N_Identifier then
            Error_Pragma_Arg
              ("argument for pragma% must be identifier", Argx);
         end if;
      end Check_Arg_Is_Identifier;

      ----------------------------------
      -- Check_Arg_Is_Integer_Literal --
      ----------------------------------

      procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
      begin
         if Nkind (Argx) /= N_Integer_Literal then
            Error_Pragma_Arg
              ("argument for pragma% must be integer literal", Argx);
         end if;
      end Check_Arg_Is_Integer_Literal;

      -------------------------------------------
      -- Check_Arg_Is_Library_Level_Local_Name --
      -------------------------------------------

      --  LOCAL_NAME ::=
      --    DIRECT_NAME
      --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
      --  | library_unit_NAME

      procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is
      begin
         Check_Arg_Is_Local_Name (Arg);

         if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
           and then Comes_From_Source (N)
         then
            Error_Pragma_Arg
              ("argument for pragma% must be library level entity", Arg);
         end if;
      end Check_Arg_Is_Library_Level_Local_Name;

      -----------------------------
      -- Check_Arg_Is_Local_Name --
      -----------------------------

      --  LOCAL_NAME ::=
      --    DIRECT_NAME
      --  | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
      --  | library_unit_NAME

      procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Analyze (Argx);

         if Nkind (Argx) not in N_Direct_Name
           and then (Nkind (Argx) /= N_Attribute_Reference
                      or else Present (Expressions (Argx))
                      or else Nkind (Prefix (Argx)) /= N_Identifier)
           and then (not Is_Entity_Name (Argx)
                      or else not Is_Compilation_Unit (Entity (Argx)))
         then
            Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
         end if;

         --  No further check required if not an entity name

         if not Is_Entity_Name (Argx) then
            null;

         else
            declare
               OK   : Boolean;
               Ent  : constant Entity_Id := Entity (Argx);
               Scop : constant Entity_Id := Scope (Ent);
            begin
               --  Case of a pragma applied to a compilation unit: pragma must
               --  occur immediately after the program unit in the compilation.

               if Is_Compilation_Unit (Ent) then
                  declare
                     Decl : constant Node_Id := Unit_Declaration_Node (Ent);

                  begin
                     --  Case of pragma placed immediately after spec

                     if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
                        OK := True;

                     --  Case of pragma placed immediately after body

                     elsif Nkind (Decl) = N_Subprogram_Declaration
                             and then Present (Corresponding_Body (Decl))
                     then
                        OK := Parent (N) =
                                Aux_Decls_Node
                                  (Parent (Unit_Declaration_Node
                                             (Corresponding_Body (Decl))));

                     --  All other cases are illegal

                     else
                        OK := False;
                     end if;
                  end;

               --  Special restricted placement rule from 10.2.1(11.8/2)

               elsif Is_Generic_Formal (Ent)
                       and then Prag_Id = Pragma_Preelaborable_Initialization
               then
                  OK := List_Containing (N) =
                          Generic_Formal_Declarations
                            (Unit_Declaration_Node (Scop));

               --  Default case, just check that the pragma occurs in the scope
               --  of the entity denoted by the name.

               else
                  OK := Current_Scope = Scop;
               end if;

               if not OK then
                  Error_Pragma_Arg
                    ("pragma% argument must be in same declarative part", Arg);
               end if;
            end;
         end if;
      end Check_Arg_Is_Local_Name;

      ---------------------------------
      -- Check_Arg_Is_Locking_Policy --
      ---------------------------------

      procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Check_Arg_Is_Identifier (Argx);

         if not Is_Locking_Policy_Name (Chars (Argx)) then
            Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
         end if;
      end Check_Arg_Is_Locking_Policy;

      -------------------------
      -- Check_Arg_Is_One_Of --
      -------------------------

      procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Check_Arg_Is_Identifier (Argx);

         if Chars (Argx) /= N1 and then Chars (Argx) /= N2 then
            Error_Msg_Name_2 := N1;
            Error_Msg_Name_3 := N2;
            Error_Pragma_Arg ("argument for pragma% must be% or%", Argx);
         end if;
      end Check_Arg_Is_One_Of;

      procedure Check_Arg_Is_One_Of
        (Arg        : Node_Id;
         N1, N2, N3 : Name_Id)
      is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Check_Arg_Is_Identifier (Argx);

         if Chars (Argx) /= N1
           and then Chars (Argx) /= N2
           and then Chars (Argx) /= N3
         then
            Error_Pragma_Arg ("invalid argument for pragma%", Argx);
         end if;
      end Check_Arg_Is_One_Of;

      procedure Check_Arg_Is_One_Of
        (Arg                : Node_Id;
         N1, N2, N3, N4, N5 : Name_Id)
      is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Check_Arg_Is_Identifier (Argx);

         if Chars (Argx) /= N1
           and then Chars (Argx) /= N2
           and then Chars (Argx) /= N3
           and then Chars (Argx) /= N4
           and then Chars (Argx) /= N5
         then
            Error_Pragma_Arg ("invalid argument for pragma%", Argx);
         end if;
      end Check_Arg_Is_One_Of;
      ---------------------------------
      -- Check_Arg_Is_Queuing_Policy --
      ---------------------------------

      procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Check_Arg_Is_Identifier (Argx);

         if not Is_Queuing_Policy_Name (Chars (Argx)) then
            Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
         end if;
      end Check_Arg_Is_Queuing_Policy;

      ------------------------------------
      -- Check_Arg_Is_Static_Expression --
      ------------------------------------

      procedure Check_Arg_Is_Static_Expression
        (Arg : Node_Id;
         Typ : Entity_Id := Empty)
      is
      begin
         Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
      end Check_Arg_Is_Static_Expression;

      ------------------------------------------
      -- Check_Arg_Is_Task_Dispatching_Policy --
      ------------------------------------------

      procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Check_Arg_Is_Identifier (Argx);

         if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then
            Error_Pragma_Arg
              ("& is not a valid task dispatching policy name", Argx);
         end if;
      end Check_Arg_Is_Task_Dispatching_Policy;

      ---------------------
      -- Check_Arg_Order --
      ---------------------

      procedure Check_Arg_Order (Names : Name_List) is
         Arg : Node_Id;

         Highest_So_Far : Natural := 0;
         --  Highest index in Names seen do far

      begin
         Arg := Arg1;
         for J in 1 .. Arg_Count loop
            if Chars (Arg) /= No_Name then
               for K in Names'Range loop
                  if Chars (Arg) = Names (K) then
                     if K < Highest_So_Far then
                        Error_Msg_Name_1 := Pname;
                        Error_Msg_N
                          ("parameters out of order for pragma%", Arg);
                        Error_Msg_Name_1 := Names (K);
                        Error_Msg_Name_2 := Names (Highest_So_Far);
                        Error_Msg_N ("\% must appear before %", Arg);
                        raise Pragma_Exit;

                     else
                        Highest_So_Far := K;
                     end if;
                  end if;
               end loop;
            end if;

            Arg := Next (Arg);
         end loop;
      end Check_Arg_Order;

      --------------------------------
      -- Check_At_Least_N_Arguments --
      --------------------------------

      procedure Check_At_Least_N_Arguments (N : Nat) is
      begin
         if Arg_Count < N then
            Error_Pragma ("too few arguments for pragma%");
         end if;
      end Check_At_Least_N_Arguments;

      -------------------------------
      -- Check_At_Most_N_Arguments --
      -------------------------------

      procedure Check_At_Most_N_Arguments (N : Nat) is
         Arg : Node_Id;
      begin
         if Arg_Count > N then
            Arg := Arg1;
            for J in 1 .. N loop
               Next (Arg);
               Error_Pragma_Arg ("too many arguments for pragma%", Arg);
            end loop;
         end if;
      end Check_At_Most_N_Arguments;

      ---------------------
      -- Check_Component --
      ---------------------

      procedure Check_Component
        (Comp            : Node_Id;
         UU_Typ          : Entity_Id;
         In_Variant_Part : Boolean := False)
      is
         Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
         Sindic  : constant Node_Id :=
                     Subtype_Indication (Component_Definition (Comp));
         Typ     : constant Entity_Id := Etype (Comp_Id);

      begin
         --  Ada 2005 (AI-216): If a component subtype is subject to a per-
         --  object constraint, then the component type shall be an Unchecked_
         --  Union.

         if Nkind (Sindic) = N_Subtype_Indication
           and then Has_Per_Object_Constraint (Comp_Id)
           and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
         then
            Error_Msg_N
              ("component subtype subject to per-object constraint " &
               "must be an Unchecked_Union", Comp);

         --  Ada 2012 (AI05-0026): For an unchecked union type declared within
         --  the body of a generic unit, or within the body of any of its
         --  descendant library units, no part of the type of a component
         --  declared in a variant_part of the unchecked union type shall be of
         --  a formal private type or formal private extension declared within
         --  the formal part of the generic unit.

         elsif Ada_Version >= Ada_2012
           and then In_Generic_Body (UU_Typ)
           and then In_Variant_Part
           and then Is_Private_Type (Typ)
           and then Is_Generic_Type (Typ)
         then
            Error_Msg_N
              ("component of Unchecked_Union cannot be of generic type", Comp);

         elsif Needs_Finalization (Typ) then
            Error_Msg_N
              ("component of Unchecked_Union cannot be controlled", Comp);

         elsif Has_Task (Typ) then
            Error_Msg_N
              ("component of Unchecked_Union cannot have tasks", Comp);
         end if;
      end Check_Component;

      ----------------------------
      -- Check_Duplicate_Pragma --
      ----------------------------

      procedure Check_Duplicate_Pragma (E : Entity_Id) is
         P : Node_Id;

      begin
         --  Nothing to do if this pragma comes from an aspect specification,
         --  since we could not be duplicating a pragma, and we dealt with the
         --  case of duplicated aspects in Analyze_Aspect_Specifications.

         if From_Aspect_Specification (N) then
            return;
         end if;

         --  Otherwise current pragma may duplicate previous pragma or a
         --  previously given aspect specification for the same pragma.

         P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));

         if Present (P) then
            Error_Msg_Name_1 := Pragma_Name (N);
            Error_Msg_Sloc := Sloc (P);

            if Nkind (P) = N_Aspect_Specification
              or else From_Aspect_Specification (P)
            then
               Error_Msg_NE ("aspect% for & previously given#", N, E);
            else
               Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
            end if;

            raise Pragma_Exit;
         end if;
      end Check_Duplicate_Pragma;

      ----------------------------------
      -- Check_Duplicated_Export_Name --
      ----------------------------------

      procedure Check_Duplicated_Export_Name (Nam : Node_Id) is
         String_Val : constant String_Id := Strval (Nam);

      begin
         --  We are only interested in the export case, and in the case of
         --  generics, it is the instance, not the template, that is the
         --  problem (the template will generate a warning in any case).

         if not Inside_A_Generic
           and then (Prag_Id = Pragma_Export
                       or else
                     Prag_Id = Pragma_Export_Procedure
                       or else
                     Prag_Id = Pragma_Export_Valued_Procedure
                       or else
                     Prag_Id = Pragma_Export_Function)
         then
            for J in Externals.First .. Externals.Last loop
               if String_Equal (String_Val, Strval (Externals.Table (J))) then
                  Error_Msg_Sloc := Sloc (Externals.Table (J));
                  Error_Msg_N ("external name duplicates name given#", Nam);
                  exit;
               end if;
            end loop;

            Externals.Append (Nam);
         end if;
      end Check_Duplicated_Export_Name;

      -------------------------------------
      -- Check_Expr_Is_Static_Expression --
      -------------------------------------

      procedure Check_Expr_Is_Static_Expression
        (Expr : Node_Id;
         Typ  : Entity_Id := Empty)
      is
      begin
         if Present (Typ) then
            Analyze_And_Resolve (Expr, Typ);
         else
            Analyze_And_Resolve (Expr);
         end if;

         if Is_OK_Static_Expression (Expr) then
            return;

         elsif Etype (Expr) = Any_Type then
            raise Pragma_Exit;

         --  An interesting special case, if we have a string literal and we
         --  are in Ada 83 mode, then we allow it even though it will not be
         --  flagged as static. This allows the use of Ada 95 pragmas like
         --  Import in Ada 83 mode. They will of course be flagged with
         --  warnings as usual, but will not cause errors.

         elsif Ada_Version = Ada_83
           and then Nkind (Expr) = N_String_Literal
         then
            return;

         --  Static expression that raises Constraint_Error. This has already
         --  been flagged, so just exit from pragma processing.

         elsif Is_Static_Expression (Expr) then
            raise Pragma_Exit;

         --  Finally, we have a real error

         else
            Error_Msg_Name_1 := Pname;

            declare
               Msg : String :=
                       "argument for pragma% must be a static expression!";
            begin
               Fix_Error (Msg);
               Flag_Non_Static_Expr (Msg, Expr);
            end;

            raise Pragma_Exit;
         end if;
      end Check_Expr_Is_Static_Expression;

      -------------------------
      -- Check_First_Subtype --
      -------------------------

      procedure Check_First_Subtype (Arg : Node_Id) is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
         Ent  : constant Entity_Id := Entity (Argx);

      begin
         if Is_First_Subtype (Ent) then
            null;

         elsif Is_Type (Ent) then
            Error_Pragma_Arg
              ("pragma% cannot apply to subtype", Argx);

         elsif Is_Object (Ent) then
            Error_Pragma_Arg
              ("pragma% cannot apply to object, requires a type", Argx);

         else
            Error_Pragma_Arg
              ("pragma% cannot apply to&, requires a type", Argx);
         end if;
      end Check_First_Subtype;

      ----------------------
      -- Check_Identifier --
      ----------------------

      procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is
      begin
         if Present (Arg)
           and then Nkind (Arg) = N_Pragma_Argument_Association
         then
            if Chars (Arg) = No_Name or else Chars (Arg) /= Id then
               Error_Msg_Name_1 := Pname;
               Error_Msg_Name_2 := Id;
               Error_Msg_N ("pragma% argument expects identifier%", Arg);
               raise Pragma_Exit;
            end if;
         end if;
      end Check_Identifier;

      --------------------------------
      -- Check_Identifier_Is_One_Of --
      --------------------------------

      procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is
      begin
         if Present (Arg)
           and then Nkind (Arg) = N_Pragma_Argument_Association
         then
            if Chars (Arg) = No_Name then
               Error_Msg_Name_1 := Pname;
               Error_Msg_N ("pragma% argument expects an identifier", Arg);
               raise Pragma_Exit;

            elsif Chars (Arg) /= N1
              and then Chars (Arg) /= N2
            then
               Error_Msg_Name_1 := Pname;
               Error_Msg_N ("invalid identifier for pragma% argument", Arg);
               raise Pragma_Exit;
            end if;
         end if;
      end Check_Identifier_Is_One_Of;

      ---------------------------
      -- Check_In_Main_Program --
      ---------------------------

      procedure Check_In_Main_Program is
         P : constant Node_Id := Parent (N);

      begin
         --  Must be at in subprogram body

         if Nkind (P) /= N_Subprogram_Body then
            Error_Pragma ("% pragma allowed only in subprogram");

         --  Otherwise warn if obviously not main program

         elsif Present (Parameter_Specifications (Specification (P)))
           or else not Is_Compilation_Unit (Defining_Entity (P))
         then
            Error_Msg_Name_1 := Pname;
            Error_Msg_N
              ("?pragma% is only effective in main program", N);
         end if;
      end Check_In_Main_Program;

      ---------------------------------------
      -- Check_Interrupt_Or_Attach_Handler --
      ---------------------------------------

      procedure Check_Interrupt_Or_Attach_Handler is
         Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
         Handler_Proc, Proc_Scope : Entity_Id;

      begin
         Analyze (Arg1_X);

         if Prag_Id = Pragma_Interrupt_Handler then
            Check_Restriction (No_Dynamic_Attachment, N);
         end if;

         Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
         Proc_Scope := Scope (Handler_Proc);

         --  On AAMP only, a pragma Interrupt_Handler is supported for
         --  nonprotected parameterless procedures.

         if not AAMP_On_Target
           or else Prag_Id = Pragma_Attach_Handler
         then
            if Ekind (Proc_Scope) /= E_Protected_Type then
               Error_Pragma_Arg
                 ("argument of pragma% must be protected procedure", Arg1);
            end if;

            if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then
               Error_Pragma ("pragma% must be in protected definition");
            end if;
         end if;

         if not Is_Library_Level_Entity (Proc_Scope)
           or else (AAMP_On_Target
                     and then not Is_Library_Level_Entity (Handler_Proc))
         then
            Error_Pragma_Arg
              ("argument for pragma% must be library level entity", Arg1);
         end if;

         --  AI05-0033: A pragma cannot appear within a generic body, because
         --  instance can be in a nested scope. The check that protected type
         --  is itself a library-level declaration is done elsewhere.

         --  Note: we omit this check in Codepeer mode to properly handle code
         --  prior to AI-0033 (pragmas don't matter to codepeer in any case).

         if Inside_A_Generic then
            if Ekind (Scope (Current_Scope)) = E_Generic_Package
              and then In_Package_Body (Scope (Current_Scope))
              and then not CodePeer_Mode
            then
               Error_Pragma ("pragma% cannot be used inside a generic");
            end if;
         end if;
      end Check_Interrupt_Or_Attach_Handler;

      -------------------------------------------
      -- Check_Is_In_Decl_Part_Or_Package_Spec --
      -------------------------------------------

      procedure Check_Is_In_Decl_Part_Or_Package_Spec is
         P : Node_Id;

      begin
         P := Parent (N);
         loop
            if No (P) then
               exit;

            elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
               exit;

            elsif Nkind_In (P, N_Package_Specification,
                               N_Block_Statement)
            then
               return;

            --  Note: the following tests seem a little peculiar, because
            --  they test for bodies, but if we were in the statement part
            --  of the body, we would already have hit the handled statement
            --  sequence, so the only way we get here is by being in the
            --  declarative part of the body.

            elsif Nkind_In (P, N_Subprogram_Body,
                               N_Package_Body,
                               N_Task_Body,
                               N_Entry_Body)
            then
               return;
            end if;

            P := Parent (P);
         end loop;

         Error_Pragma ("pragma% is not in declarative part or package spec");
      end Check_Is_In_Decl_Part_Or_Package_Spec;

      -------------------------
      -- Check_No_Identifier --
      -------------------------

      procedure Check_No_Identifier (Arg : Node_Id) is
      begin
         if Nkind (Arg) = N_Pragma_Argument_Association
           and then Chars (Arg) /= No_Name
         then
            Error_Pragma_Arg_Ident
              ("pragma% does not permit identifier& here", Arg);
         end if;
      end Check_No_Identifier;

      --------------------------
      -- Check_No_Identifiers --
      --------------------------

      procedure Check_No_Identifiers is
         Arg_Node : Node_Id;
      begin
         if Arg_Count > 0 then
            Arg_Node := Arg1;
            while Present (Arg_Node) loop
               Check_No_Identifier (Arg_Node);
               Next (Arg_Node);
            end loop;
         end if;
      end Check_No_Identifiers;

      ------------------------
      -- Check_No_Link_Name --
      ------------------------

      procedure Check_No_Link_Name is
      begin
         if Present (Arg3)
           and then Chars (Arg3) = Name_Link_Name
         then
            Arg4 := Arg3;
         end if;

         if Present (Arg4) then
            Error_Pragma_Arg
              ("Link_Name argument not allowed for Import Intrinsic", Arg4);
         end if;
      end Check_No_Link_Name;

      -------------------------------
      -- Check_Optional_Identifier --
      -------------------------------

      procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is
      begin
         if Present (Arg)
           and then Nkind (Arg) = N_Pragma_Argument_Association
           and then Chars (Arg) /= No_Name
         then
            if Chars (Arg) /= Id then
               Error_Msg_Name_1 := Pname;
               Error_Msg_Name_2 := Id;
               Error_Msg_N ("pragma% argument expects identifier%", Arg);
               raise Pragma_Exit;
            end if;
         end if;
      end Check_Optional_Identifier;

      procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is
      begin
         Name_Buffer (1 .. Id'Length) := Id;
         Name_Len := Id'Length;
         Check_Optional_Identifier (Arg, Name_Find);
      end Check_Optional_Identifier;

      --------------------------------------
      -- Check_Precondition_Postcondition --
      --------------------------------------

      procedure Check_Precondition_Postcondition (In_Body : out Boolean) is
         P  : Node_Id;
         PO : Node_Id;

         procedure Chain_PPC (PO : Node_Id);
         --  If PO is an entry or a [generic] subprogram declaration node, then
         --  the precondition/postcondition applies to this subprogram and the
         --  processing for the pragma is completed. Otherwise the pragma is
         --  misplaced.

         ---------------
         -- Chain_PPC --
         ---------------

         procedure Chain_PPC (PO : Node_Id) is
            S   : Entity_Id;
            P   : Node_Id;

         begin
            if Nkind (PO) = N_Abstract_Subprogram_Declaration then
               if not From_Aspect_Specification (N) then
                  Error_Pragma
                    ("pragma% cannot be applied to abstract subprogram");

               elsif Class_Present (N) then
                  null;

               else
                  Error_Pragma
                    ("aspect % requires ''Class for abstract subprogram");
               end if;

            --  AI05-0230: The same restriction applies to null procedures. For
            --  compatibility with earlier uses of the Ada pragma, apply this
            --  rule only to aspect specifications.

            --  The above discrpency needs documentation. Robert is dubious
            --  about whether it is a good idea ???

            elsif Nkind (PO) = N_Subprogram_Declaration
              and then Nkind (Specification (PO)) = N_Procedure_Specification
              and then Null_Present (Specification (PO))
              and then From_Aspect_Specification (N)
              and then not Class_Present (N)
            then
               Error_Pragma
                 ("aspect % requires ''Class for null procedure");

            elsif not Nkind_In (PO, N_Subprogram_Declaration,
                                    N_Generic_Subprogram_Declaration,
                                    N_Entry_Declaration)
            then
               Pragma_Misplaced;
            end if;

            --  Here if we have [generic] subprogram or entry declaration

            if Nkind (PO) = N_Entry_Declaration then
               S := Defining_Entity (PO);
            else
               S := Defining_Unit_Name (Specification (PO));
            end if;

            --  Make sure we do not have the case of a precondition pragma when
            --  the Pre'Class aspect is present.

            --  We do this by looking at pragmas already chained to the entity
            --  since the aspect derived pragma will be put on this list first.

            if Pragma_Name (N) = Name_Precondition then
               if not From_Aspect_Specification (N) then
                  P := Spec_PPC_List (Contract (S));
                  while Present (P) loop
                     if Pragma_Name (P) = Name_Precondition
                       and then From_Aspect_Specification (P)
                       and then Class_Present (P)
                     then
                        Error_Msg_Sloc := Sloc (P);
                        Error_Pragma
                          ("pragma% not allowed, `Pre''Class` aspect given#");
                     end if;

                     P := Next_Pragma (P);
                  end loop;
               end if;
            end if;

            --  Similarly check for Pre with inherited Pre'Class. Note that
            --  we cover the aspect case as well here.

            if Pragma_Name (N) = Name_Precondition
              and then not Class_Present (N)
            then
               declare
                  Inherited : constant Subprogram_List :=
                                Inherited_Subprograms (S);
                  P         : Node_Id;

               begin
                  for J in Inherited'Range loop
                     P := Spec_PPC_List (Contract (Inherited (J)));
                     while Present (P) loop
                        if Pragma_Name (P) = Name_Precondition
                          and then Class_Present (P)
                        then
                           Error_Msg_Sloc := Sloc (P);
                           Error_Pragma
                             ("pragma% not allowed, `Pre''Class` "
                              & "aspect inherited from#");
                        end if;

                        P := Next_Pragma (P);
                     end loop;
                  end loop;
               end;
            end if;

            --  Note: we do not analyze the pragma at this point. Instead we
            --  delay this analysis until the end of the declarative part in
            --  which the pragma appears. This implements the required delay
            --  in this analysis, allowing forward references. The analysis
            --  happens at the end of Analyze_Declarations.

            --  Chain spec PPC pragma to list for subprogram

            Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
            Set_Spec_PPC_List (Contract (S), N);

            --  Return indicating spec case

            In_Body := False;
            return;
         end Chain_PPC;

      --  Start of processing for Check_Precondition_Postcondition

      begin
         if not Is_List_Member (N) then
            Pragma_Misplaced;
         end if;

         --  Preanalyze message argument if present. Visibility in this
         --  argument is established at the point of pragma occurrence.

         if Arg_Count = 2 then
            Check_Optional_Identifier (Arg2, Name_Message);
            Preanalyze_Spec_Expression
              (Get_Pragma_Arg (Arg2), Standard_String);
         end if;

         --  Record if pragma is disabled

         if Check_Enabled (Pname) then
            Set_SCO_Pragma_Enabled (Loc);
         end if;

         --  If we are within an inlined body, the legality of the pragma
         --  has been checked already.

         if In_Inlined_Body then
            In_Body := True;
            return;
         end if;

         --  Search prior declarations

         P := N;
         while Present (Prev (P)) loop
            P := Prev (P);

            --  If the previous node is a generic subprogram, do not go to to
            --  the original node, which is the unanalyzed tree: we need to
            --  attach the pre/postconditions to the analyzed version at this
            --  point. They get propagated to the original tree when analyzing
            --  the corresponding body.

            if Nkind (P) not in N_Generic_Declaration then
               PO := Original_Node (P);
            else
               PO := P;
            end if;

            --  Skip past prior pragma

            if Nkind (PO) = N_Pragma then
               null;

            --  Skip stuff not coming from source

            elsif not Comes_From_Source (PO) then

               --  The condition may apply to a subprogram instantiation

               if Nkind (PO) = N_Subprogram_Declaration
                 and then Present (Generic_Parent (Specification (PO)))
               then
                  Chain_PPC (PO);
                  return;

               elsif Nkind (PO) = N_Subprogram_Declaration
                 and then In_Instance
               then
                  Chain_PPC (PO);
                  return;

               --  For all other cases of non source code, do nothing

               else
                  null;
               end if;

            --  Only remaining possibility is subprogram declaration

            else
               Chain_PPC (PO);
               return;
            end if;
         end loop;

         --  If we fall through loop, pragma is at start of list, so see if it
         --  is at the start of declarations of a subprogram body.

         if Nkind (Parent (N)) = N_Subprogram_Body
           and then List_Containing (N) = Declarations (Parent (N))
         then
            if Operating_Mode /= Generate_Code
              or else Inside_A_Generic
            then
               --  Analyze pragma expression for correctness and for ASIS use

               Preanalyze_Spec_Expression
                 (Get_Pragma_Arg (Arg1), Standard_Boolean);

               --  In ASIS mode, for a pragma generated from a source aspect,
               --  also analyze the original aspect expression.

               if ASIS_Mode
                 and then Present (Corresponding_Aspect (N))
               then
                  Preanalyze_Spec_Expression
                    (Expression (Corresponding_Aspect (N)), Standard_Boolean);
               end if;
            end if;

            In_Body := True;
            return;

         --  See if it is in the pragmas after a library level subprogram

         elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then

            --  In formal verification mode, analyze pragma expression for
            --  correctness, as it is not expanded later.

            if Alfa_Mode then
               Analyze_PPC_In_Decl_Part
                 (N, Defining_Entity (Unit (Parent (Parent (N)))));
            end if;

            Chain_PPC (Unit (Parent (Parent (N))));
            return;
         end if;

         --  If we fall through, pragma was misplaced

         Pragma_Misplaced;
      end Check_Precondition_Postcondition;

      -----------------------------
      -- Check_Static_Constraint --
      -----------------------------

      --  Note: for convenience in writing this procedure, in addition to
      --  the officially (i.e. by spec) allowed argument which is always a
      --  constraint, it also allows ranges and discriminant associations.
      --  Above is not clear ???

      procedure Check_Static_Constraint (Constr : Node_Id) is

         procedure Require_Static (E : Node_Id);
         --  Require given expression to be static expression

         --------------------
         -- Require_Static --
         --------------------

         procedure Require_Static (E : Node_Id) is
         begin
            if not Is_OK_Static_Expression (E) then
               Flag_Non_Static_Expr
                 ("non-static constraint not allowed in Unchecked_Union!", E);
               raise Pragma_Exit;
            end if;
         end Require_Static;

      --  Start of processing for Check_Static_Constraint

      begin
         case Nkind (Constr) is
            when N_Discriminant_Association =>
               Require_Static (Expression (Constr));

            when N_Range =>
               Require_Static (Low_Bound (Constr));
               Require_Static (High_Bound (Constr));

            when N_Attribute_Reference =>
               Require_Static (Type_Low_Bound  (Etype (Prefix (Constr))));
               Require_Static (Type_High_Bound (Etype (Prefix (Constr))));

            when N_Range_Constraint =>
               Check_Static_Constraint (Range_Expression (Constr));

            when N_Index_Or_Discriminant_Constraint =>
               declare
                  IDC : Entity_Id;
               begin
                  IDC := First (Constraints (Constr));
                  while Present (IDC) loop
                     Check_Static_Constraint (IDC);
                     Next (IDC);
                  end loop;
               end;

            when others =>
               null;
         end case;
      end Check_Static_Constraint;

      ---------------------
      -- Check_Test_Case --
      ---------------------

      procedure Check_Test_Case is
         P  : Node_Id;
         PO : Node_Id;

         procedure Chain_TC (PO : Node_Id);
         --  If PO is a [generic] subprogram declaration node, then the
         --  test-case applies to this subprogram and the processing for the
         --  pragma is completed. Otherwise the pragma is misplaced.

         --------------
         -- Chain_TC --
         --------------

         procedure Chain_TC (PO : Node_Id) is
            S   : Entity_Id;

         begin
            if Nkind (PO) = N_Abstract_Subprogram_Declaration then
               if From_Aspect_Specification (N) then
                  Error_Pragma
                    ("aspect% cannot be applied to abstract subprogram");
               else
                  Error_Pragma
                    ("pragma% cannot be applied to abstract subprogram");
               end if;

            elsif Nkind (PO) = N_Entry_Declaration then
               if From_Aspect_Specification (N) then
                  Error_Pragma ("aspect% cannot be applied to entry");
               else
                  Error_Pragma ("pragma% cannot be applied to entry");
               end if;

            elsif not Nkind_In (PO, N_Subprogram_Declaration,
                                    N_Generic_Subprogram_Declaration)
            then
               Pragma_Misplaced;
            end if;

            --  Here if we have [generic] subprogram declaration

            S := Defining_Unit_Name (Specification (PO));

            --  Note: we do not analyze the pragma at this point. Instead we
            --  delay this analysis until the end of the declarative part in
            --  which the pragma appears. This implements the required delay
            --  in this analysis, allowing forward references. The analysis
            --  happens at the end of Analyze_Declarations.

            --  There should not be another test case with the same name
            --  associated to this subprogram.

            declare
               Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
               TC   : Node_Id;

            begin
               TC := Spec_TC_List (Contract (S));
               while Present (TC) loop

                  if String_Equal
                    (Name, Get_Name_From_Test_Case_Pragma (TC))
                  then
                     Error_Msg_Sloc := Sloc (TC);

                     if From_Aspect_Specification (N) then
                        Error_Pragma ("name for aspect% is already used#");
                     else
                        Error_Pragma ("name for pragma% is already used#");
                     end if;
                  end if;

                  TC := Next_Pragma (TC);
               end loop;
            end;

            --  Chain spec TC pragma to list for subprogram

            Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
            Set_Spec_TC_List (Contract (S), N);
         end Chain_TC;

      --  Start of processing for Check_Test_Case

      begin
         if not Is_List_Member (N) then
            Pragma_Misplaced;
         end if;

         --  Test cases should only appear in package spec unit

         if Get_Source_Unit (N) = No_Unit
           or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
                                 N_Package_Declaration,
                                 N_Generic_Package_Declaration)
         then
            Pragma_Misplaced;
         end if;

         --  Search prior declarations

         P := N;
         while Present (Prev (P)) loop
            P := Prev (P);

            --  If the previous node is a generic subprogram, do not go to to
            --  the original node, which is the unanalyzed tree: we need to
            --  attach the test-case to the analyzed version at this point.
            --  They get propagated to the original tree when analyzing the
            --  corresponding body.

            if Nkind (P) not in N_Generic_Declaration then
               PO := Original_Node (P);
            else
               PO := P;
            end if;

            --  Skip past prior pragma

            if Nkind (PO) = N_Pragma then
               null;

            --  Skip stuff not coming from source

            elsif not Comes_From_Source (PO) then
               null;

            --  Only remaining possibility is subprogram declaration. First
            --  check that it is declared directly in a package declaration.
            --  This may be either the package declaration for the current unit
            --  being defined or a local package declaration.

            elsif not Present (Parent (Parent (PO)))
              or else not Present (Parent (Parent (Parent (PO))))
              or else not Nkind_In (Parent (Parent (PO)),
                                    N_Package_Declaration,
                                    N_Generic_Package_Declaration)
            then
               Pragma_Misplaced;

            else
               Chain_TC (PO);
               return;
            end if;
         end loop;

         --  If we fall through, pragma was misplaced

         Pragma_Misplaced;
      end Check_Test_Case;

      --------------------------------------
      -- Check_Valid_Configuration_Pragma --
      --------------------------------------

      --  A configuration pragma must appear in the context clause of a
      --  compilation unit, and only other pragmas may precede it. Note that
      --  the test also allows use in a configuration pragma file.

      procedure Check_Valid_Configuration_Pragma is
      begin
         if not Is_Configuration_Pragma then
            Error_Pragma ("incorrect placement for configuration pragma%");
         end if;
      end Check_Valid_Configuration_Pragma;

      -------------------------------------
      -- Check_Valid_Library_Unit_Pragma --
      -------------------------------------

      procedure Check_Valid_Library_Unit_Pragma is
         Plist       : List_Id;
         Parent_Node : Node_Id;
         Unit_Name   : Entity_Id;
         Unit_Kind   : Node_Kind;
         Unit_Node   : Node_Id;
         Sindex      : Source_File_Index;

      begin
         if not Is_List_Member (N) then
            Pragma_Misplaced;

         else
            Plist := List_Containing (N);
            Parent_Node := Parent (Plist);

            if Parent_Node = Empty then
               Pragma_Misplaced;

            --  Case of pragma appearing after a compilation unit. In this case
            --  it must have an argument with the corresponding name and must
            --  be part of the following pragmas of its parent.

            elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then
               if Plist /= Pragmas_After (Parent_Node) then
                  Pragma_Misplaced;

               elsif Arg_Count = 0 then
                  Error_Pragma
                    ("argument required if outside compilation unit");

               else
                  Check_No_Identifiers;
                  Check_Arg_Count (1);
                  Unit_Node := Unit (Parent (Parent_Node));
                  Unit_Kind := Nkind (Unit_Node);

                  Analyze (Get_Pragma_Arg (Arg1));

                  if Unit_Kind = N_Generic_Subprogram_Declaration
                    or else Unit_Kind = N_Subprogram_Declaration
                  then
                     Unit_Name := Defining_Entity (Unit_Node);

                  elsif Unit_Kind in N_Generic_Instantiation then
                     Unit_Name := Defining_Entity (Unit_Node);

                  else
                     Unit_Name := Cunit_Entity (Current_Sem_Unit);
                  end if;

                  if Chars (Unit_Name) /=
                     Chars (Entity (Get_Pragma_Arg (Arg1)))
                  then
                     Error_Pragma_Arg
                       ("pragma% argument is not current unit name", Arg1);
                  end if;

                  if Ekind (Unit_Name) = E_Package
                    and then Present (Renamed_Entity (Unit_Name))
                  then
                     Error_Pragma ("pragma% not allowed for renamed package");
                  end if;
               end if;

            --  Pragma appears other than after a compilation unit

            else
               --  Here we check for the generic instantiation case and also
               --  for the case of processing a generic formal package. We
               --  detect these cases by noting that the Sloc on the node
               --  does not belong to the current compilation unit.

               Sindex := Source_Index (Current_Sem_Unit);

               if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then
                  Rewrite (N, Make_Null_Statement (Loc));
                  return;

               --  If before first declaration, the pragma applies to the
               --  enclosing unit, and the name if present must be this name.

               elsif Is_Before_First_Decl (N, Plist) then
                  Unit_Node := Unit_Declaration_Node (Current_Scope);
                  Unit_Kind := Nkind (Unit_Node);

                  if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then
                     Pragma_Misplaced;

                  elsif Unit_Kind = N_Subprogram_Body
                    and then not Acts_As_Spec (Unit_Node)
                  then
                     Pragma_Misplaced;

                  elsif Nkind (Parent_Node) = N_Package_Body then
                     Pragma_Misplaced;

                  elsif Nkind (Parent_Node) = N_Package_Specification
                    and then Plist = Private_Declarations (Parent_Node)
                  then
                     Pragma_Misplaced;

                  elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration
                           or else Nkind (Parent_Node) =
                                             N_Generic_Subprogram_Declaration)
                    and then Plist = Generic_Formal_Declarations (Parent_Node)
                  then
                     Pragma_Misplaced;

                  elsif Arg_Count > 0 then
                     Analyze (Get_Pragma_Arg (Arg1));

                     if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
                        Error_Pragma_Arg
                          ("name in pragma% must be enclosing unit", Arg1);
                     end if;

                  --  It is legal to have no argument in this context

                  else
                     return;
                  end if;

               --  Error if not before first declaration. This is because a
               --  library unit pragma argument must be the name of a library
               --  unit (RM 10.1.5(7)), but the only names permitted in this
               --  context are (RM 10.1.5(6)) names of subprogram declarations,
               --  generic subprogram declarations or generic instantiations.

               else
                  Error_Pragma
                    ("pragma% misplaced, must be before first declaration");
               end if;
            end if;
         end if;
      end Check_Valid_Library_Unit_Pragma;

      -------------------
      -- Check_Variant --
      -------------------

      procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
         Clist : constant Node_Id := Component_List (Variant);
         Comp  : Node_Id;

      begin
         if not Is_Non_Empty_List (Component_Items (Clist)) then
            Error_Msg_N
              ("Unchecked_Union may not have empty component list",
               Variant);
            return;
         end if;

         Comp := First (Component_Items (Clist));
         while Present (Comp) loop
            Check_Component (Comp, UU_Typ, In_Variant_Part => True);
            Next (Comp);
         end loop;
      end Check_Variant;

      ------------------
      -- Error_Pragma --
      ------------------

      procedure Error_Pragma (Msg : String) is
         MsgF : String := Msg;
      begin
         Error_Msg_Name_1 := Pname;
         Fix_Error (MsgF);
         Error_Msg_N (MsgF, N);
         raise Pragma_Exit;
      end Error_Pragma;

      ----------------------
      -- Error_Pragma_Arg --
      ----------------------

      procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
         MsgF : String := Msg;
      begin
         Error_Msg_Name_1 := Pname;
         Fix_Error (MsgF);
         Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
         raise Pragma_Exit;
      end Error_Pragma_Arg;

      procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
         MsgF : String := Msg1;
      begin
         Error_Msg_Name_1 := Pname;
         Fix_Error (MsgF);
         Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
         Error_Pragma_Arg (Msg2, Arg);
      end Error_Pragma_Arg;

      ----------------------------
      -- Error_Pragma_Arg_Ident --
      ----------------------------

      procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
         MsgF : String := Msg;
      begin
         Error_Msg_Name_1 := Pname;
         Fix_Error (MsgF);
         Error_Msg_N (MsgF, Arg);
         raise Pragma_Exit;
      end Error_Pragma_Arg_Ident;

      ----------------------
      -- Error_Pragma_Ref --
      ----------------------

      procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
         MsgF : String := Msg;
      begin
         Error_Msg_Name_1 := Pname;
         Fix_Error (MsgF);
         Error_Msg_Sloc   := Sloc (Ref);
         Error_Msg_NE (MsgF, N, Ref);
         raise Pragma_Exit;
      end Error_Pragma_Ref;

      ------------------------
      -- Find_Lib_Unit_Name --
      ------------------------

      function Find_Lib_Unit_Name return Entity_Id is
      begin
         --  Return inner compilation unit entity, for case of nested
         --  categorization pragmas. This happens in generic unit.

         if Nkind (Parent (N)) = N_Package_Specification
           and then Defining_Entity (Parent (N)) /= Current_Scope
         then
            return Defining_Entity (Parent (N));
         else
            return Current_Scope;
         end if;
      end Find_Lib_Unit_Name;

      ----------------------------
      -- Find_Program_Unit_Name --
      ----------------------------

      procedure Find_Program_Unit_Name (Id : Node_Id) is
         Unit_Name : Entity_Id;
         Unit_Kind : Node_Kind;
         P         : constant Node_Id := Parent (N);

      begin
         if Nkind (P) = N_Compilation_Unit then
            Unit_Kind := Nkind (Unit (P));

            if Unit_Kind = N_Subprogram_Declaration
              or else Unit_Kind = N_Package_Declaration
              or else Unit_Kind in N_Generic_Declaration
            then
               Unit_Name := Defining_Entity (Unit (P));

               if Chars (Id) = Chars (Unit_Name) then
                  Set_Entity (Id, Unit_Name);
                  Set_Etype (Id, Etype (Unit_Name));
               else
                  Set_Etype (Id, Any_Type);
                  Error_Pragma
                    ("cannot find program unit referenced by pragma%");
               end if;

            else
               Set_Etype (Id, Any_Type);
               Error_Pragma ("pragma% inapplicable to this unit");
            end if;

         else
            Analyze (Id);
         end if;
      end Find_Program_Unit_Name;

      -----------------------------------------
      -- Find_Unique_Parameterless_Procedure --
      -----------------------------------------

      function Find_Unique_Parameterless_Procedure
        (Name : Entity_Id;
         Arg  : Node_Id) return Entity_Id
      is
         Proc : Entity_Id := Empty;

      begin
         --  The body of this procedure needs some comments ???

         if not Is_Entity_Name (Name) then
            Error_Pragma_Arg
              ("argument of pragma% must be entity name", Arg);

         elsif not Is_Overloaded (Name) then
            Proc := Entity (Name);

            if Ekind (Proc) /= E_Procedure
              or else Present (First_Formal (Proc))
            then
               Error_Pragma_Arg
                 ("argument of pragma% must be parameterless procedure", Arg);
            end if;

         else
            declare
               Found : Boolean := False;
               It    : Interp;
               Index : Interp_Index;

            begin
               Get_First_Interp (Name, Index, It);
               while Present (It.Nam) loop
                  Proc := It.Nam;

                  if Ekind (Proc) = E_Procedure
                    and then No (First_Formal (Proc))
                  then
                     if not Found then
                        Found := True;
                        Set_Entity (Name, Proc);
                        Set_Is_Overloaded (Name, False);
                     else
                        Error_Pragma_Arg
                          ("ambiguous handler name for pragma% ", Arg);
                     end if;
                  end if;

                  Get_Next_Interp (Index, It);
               end loop;

               if not Found then
                  Error_Pragma_Arg
                    ("argument of pragma% must be parameterless procedure",
                     Arg);
               else
                  Proc := Entity (Name);
               end if;
            end;
         end if;

         return Proc;
      end Find_Unique_Parameterless_Procedure;

      ---------------
      -- Fix_Error --
      ---------------

      procedure Fix_Error (Msg : in out String) is
      begin
         if From_Aspect_Specification (N) then
            for J in Msg'First .. Msg'Last - 5 loop
               if Msg (J .. J + 5) = "pragma" then
                  Msg (J .. J + 5) := "aspect";
               end if;
            end loop;

            if Error_Msg_Name_1 = Name_Precondition then
               Error_Msg_Name_1 := Name_Pre;
            elsif Error_Msg_Name_1 = Name_Postcondition then
               Error_Msg_Name_1 := Name_Post;
            end if;
         end if;
      end Fix_Error;

      -------------------------
      -- Gather_Associations --
      -------------------------

      procedure Gather_Associations
        (Names : Name_List;
         Args  : out Args_List)
      is
         Arg : Node_Id;

      begin
         --  Initialize all parameters to Empty

         for J in Args'Range loop
            Args (J) := Empty;
         end loop;

         --  That's all we have to do if there are no argument associations

         if No (Pragma_Argument_Associations (N)) then
            return;
         end if;

         --  Otherwise first deal with any positional parameters present

         Arg := First (Pragma_Argument_Associations (N));
         for Index in Args'Range loop
            exit when No (Arg) or else Chars (Arg) /= No_Name;
            Args (Index) := Get_Pragma_Arg (Arg);
            Next (Arg);
         end loop;

         --  Positional parameters all processed, if any left, then we
         --  have too many positional parameters.

         if Present (Arg) and then Chars (Arg) = No_Name then
            Error_Pragma_Arg
              ("too many positional associations for pragma%", Arg);
         end if;

         --  Process named parameters if any are present

         while Present (Arg) loop
            if Chars (Arg) = No_Name then
               Error_Pragma_Arg
                 ("positional association cannot follow named association",
                  Arg);

            else
               for Index in Names'Range loop
                  if Names (Index) = Chars (Arg) then
                     if Present (Args (Index)) then
                        Error_Pragma_Arg
                          ("duplicate argument association for pragma%", Arg);
                     else
                        Args (Index) := Get_Pragma_Arg (Arg);
                        exit;
                     end if;
                  end if;

                  if Index = Names'Last then
                     Error_Msg_Name_1 := Pname;
                     Error_Msg_N ("pragma% does not allow & argument", Arg);

                     --  Check for possible misspelling

                     for Index1 in Names'Range loop
                        if Is_Bad_Spelling_Of
                             (Chars (Arg), Names (Index1))
                        then
                           Error_Msg_Name_1 := Names (Index1);
                           Error_Msg_N -- CODEFIX
                             ("\possible misspelling of%", Arg);
                           exit;
                        end if;
                     end loop;

                     raise Pragma_Exit;
                  end if;
               end loop;
            end if;

            Next (Arg);
         end loop;
      end Gather_Associations;

      -----------------
      -- GNAT_Pragma --
      -----------------

      procedure GNAT_Pragma is
      begin
         --  We need to check the No_Implementation_Pragmas restriction for
         --  the case of a pragma from source. Note that the case of aspects
         --  generating corresponding pragmas marks these pragmas as not being
         --  from source, so this test also catches that case.

         if Comes_From_Source (N) then
            Check_Restriction (No_Implementation_Pragmas, N);
         end if;
      end GNAT_Pragma;

      --------------------------
      -- Is_Before_First_Decl --
      --------------------------

      function Is_Before_First_Decl
        (Pragma_Node : Node_Id;
         Decls       : List_Id) return Boolean
      is
         Item : Node_Id := First (Decls);

      begin
         --  Only other pragmas can come before this pragma

         loop
            if No (Item) or else Nkind (Item) /= N_Pragma then
               return False;

            elsif Item = Pragma_Node then
               return True;
            end if;

            Next (Item);
         end loop;
      end Is_Before_First_Decl;

      -----------------------------
      -- Is_Configuration_Pragma --
      -----------------------------

      --  A configuration pragma must appear in the context clause of a
      --  compilation unit, and only other pragmas may precede it. Note that
      --  the test below also permits use in a configuration pragma file.

      function Is_Configuration_Pragma return Boolean is
         Lis : constant List_Id := List_Containing (N);
         Par : constant Node_Id := Parent (N);
         Prg : Node_Id;

      begin
         --  If no parent, then we are in the configuration pragma file,
         --  so the placement is definitely appropriate.

         if No (Par) then
            return True;

         --  Otherwise we must be in the context clause of a compilation unit
         --  and the only thing allowed before us in the context list is more
         --  configuration pragmas.

         elsif Nkind (Par) = N_Compilation_Unit
           and then Context_Items (Par) = Lis
         then
            Prg := First (Lis);

            loop
               if Prg = N then
                  return True;
               elsif Nkind (Prg) /= N_Pragma then
                  return False;
               end if;

               Next (Prg);
            end loop;

         else
            return False;
         end if;
      end Is_Configuration_Pragma;

      --------------------------
      -- Is_In_Context_Clause --
      --------------------------

      function Is_In_Context_Clause return Boolean is
         Plist       : List_Id;
         Parent_Node : Node_Id;

      begin
         if not Is_List_Member (N) then
            return False;

         else
            Plist := List_Containing (N);
            Parent_Node := Parent (Plist);

            if Parent_Node = Empty
              or else Nkind (Parent_Node) /= N_Compilation_Unit
              or else Context_Items (Parent_Node) /= Plist
            then
               return False;
            end if;
         end if;

         return True;
      end Is_In_Context_Clause;

      ---------------------------------
      -- Is_Static_String_Expression --
      ---------------------------------

      function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
         Argx : constant Node_Id := Get_Pragma_Arg (Arg);

      begin
         Analyze_And_Resolve (Argx);
         return Is_OK_Static_Expression (Argx)
           and then Nkind (Argx) = N_String_Literal;
      end Is_Static_String_Expression;

      ----------------------
      -- Pragma_Misplaced --
      ----------------------

      procedure Pragma_Misplaced is
      begin
         Error_Pragma ("incorrect placement of pragma%");
      end Pragma_Misplaced;

      ------------------------------------
      -- Process Atomic_Shared_Volatile --
      ------------------------------------

      procedure Process_Atomic_Shared_Volatile is
         E_Id : Node_Id;
         E    : Entity_Id;
         D    : Node_Id;
         K    : Node_Kind;
         Utyp : Entity_Id;

         procedure Set_Atomic (E : Entity_Id);
         --  Set given type as atomic, and if no explicit alignment was given,
         --  set alignment to unknown, since back end knows what the alignment
         --  requirements are for atomic arrays. Note: this step is necessary
         --  for derived types.

         ----------------
         -- Set_Atomic --
         ----------------

         procedure Set_Atomic (E : Entity_Id) is
         begin
            Set_Is_Atomic (E);

            if not Has_Alignment_Clause (E) then
               Set_Alignment (E, Uint_0);
            end if;
         end Set_Atomic;

      --  Start of processing for Process_Atomic_Shared_Volatile

      begin
         Check_Ada_83_Warning;
         Check_No_Identifiers;
         Check_Arg_Count (1);
         Check_Arg_Is_Local_Name (Arg1);
         E_Id := Get_Pragma_Arg (Arg1);

         if Etype (E_Id) = Any_Type then
            return;
         end if;

         E := Entity (E_Id);
         D := Declaration_Node (E);
         K := Nkind (D);

         --  Check duplicate before we chain ourselves!

         Check_Duplicate_Pragma (E);

         --  Now check appropriateness of the entity

         if Is_Type (E) then
            if Rep_Item_Too_Early (E, N)
                 or else
               Rep_Item_Too_Late (E, N)
            then
               return;
            else
               Check_First_Subtype (Arg1);
            end if;

            if Prag_Id /= Pragma_Volatile then
               Set_Atomic (E);
               Set_Atomic (Underlying_Type (E));
               Set_Atomic (Base_Type (E));
            end if;

            --  Attribute belongs on the base type. If the view of the type is
            --  currently private, it also belongs on the underlying type.

            Set_Is_Volatile (Base_Type (E));
            Set_Is_Volatile (Underlying_Type (E));

            Set_Treat_As_Volatile (E);
            Set_Treat_As_Volatile (Underlying_Type (E));

         elsif K = N_Object_Declaration
           or else (K = N_Component_Declaration
                     and then Original_Record_Component (E) = E)
         then
            if Rep_Item_Too_Late (E, N) then
               return;
            end if;

            if Prag_Id /= Pragma_Volatile then
               Set_Is_Atomic (E);

               --  If the object declaration has an explicit initialization, a
               --  temporary may have to be created to hold the expression, to
               --  ensure that access to the object remain atomic.

               if Nkind (Parent (E)) = N_Object_Declaration
                 and then Present (Expression (Parent (E)))
               then
                  Set_Has_Delayed_Freeze (E);
               end if;

               --  An interesting improvement here. If an object of type X is
               --  declared atomic, and the type X is not atomic, that's a
               --  pity, since it may not have appropriate alignment etc. We
               --  can rescue this in the special case where the object and
               --  type are in the same unit by just setting the type as
               --  atomic, so that the back end will process it as atomic.

               Utyp := Underlying_Type (Etype (E));

               if Present (Utyp)
                 and then Sloc (E) > No_Location
                 and then Sloc (Utyp) > No_Location
                 and then
                   Get_Source_File_Index (Sloc (E)) =
                   Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
               then
                  Set_Is_Atomic (Underlying_Type (Etype (E)));
               end if;
            end if;

            Set_Is_Volatile (E);
            Set_Treat_As_Volatile (E);

         else
            Error_Pragma_Arg
              ("inappropriate entity for pragma%", Arg1);
         end if;
      end Process_Atomic_Shared_Volatile;

      -------------------------------------------
      -- Process_Compile_Time_Warning_Or_Error --
      -------------------------------------------

      procedure Process_Compile_Time_Warning_Or_Error is
         Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);

      begin
         Check_Arg_Count (2);
         Check_No_Identifiers;
         Check_Arg_Is_Static_Expression (Arg2, Standard_String);
         Analyze_And_Resolve (Arg1x, Standard_Boolean);

         if Compile_Time_Known_Value (Arg1x) then
            if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
               declare
                  Str   : constant String_Id :=
                            Strval (Get_Pragma_Arg (Arg2));
                  Len   : constant Int := String_Length (Str);
                  Cont  : Boolean;
                  Ptr   : Nat;
                  CC    : Char_Code;
                  C     : Character;
                  Cent  : constant Entity_Id :=
                            Cunit_Entity (Current_Sem_Unit);

                  Force : constant Boolean :=
                            Prag_Id = Pragma_Compile_Time_Warning
                              and then
                                Is_Spec_Name (Unit_Name (Current_Sem_Unit))
                              and then (Ekind (Cent) /= E_Package
                                          or else not In_Private_Part (Cent));
                  --  Set True if this is the warning case, and we are in the
                  --  visible part of a package spec, or in a subprogram spec,
                  --  in which case we want to force the client to see the
                  --  warning, even though it is not in the main unit.

               begin
                  --  Loop through segments of message separated by line feeds.
                  --  We output these segments as separate messages with
                  --  continuation marks for all but the first.

                  Cont := False;
                  Ptr := 1;
                  loop
                     Error_Msg_Strlen := 0;

                     --  Loop to copy characters from argument to error message
                     --  string buffer.

                     loop
                        exit when Ptr > Len;
                        CC := Get_String_Char (Str, Ptr);
                        Ptr := Ptr + 1;

                        --  Ignore wide chars ??? else store character

                        if In_Character_Range (CC) then
                           C := Get_Character (CC);
                           exit when C = ASCII.LF;
                           Error_Msg_Strlen := Error_Msg_Strlen + 1;
                           Error_Msg_String (Error_Msg_Strlen) := C;
                        end if;
                     end loop;

                     --  Here with one line ready to go

                     Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;

                     --  If this is a warning in a spec, then we want clients
                     --  to see the warning, so mark the message with the
                     --  special sequence !! to force the warning. In the case
                     --  of a package spec, we do not force this if we are in
                     --  the private part of the spec.

                     if Force then
                        if Cont = False then
                           Error_Msg_N ("<~!!", Arg1);
                           Cont := True;
                        else
                           Error_Msg_N ("\<~!!", Arg1);
                        end if;

                     --  Error, rather than warning, or in a body, so we do not
                     --  need to force visibility for client (error will be
                     --  output in any case, and this is the situation in which
                     --  we do not want a client to get a warning, since the
                     --  warning is in the body or the spec private part).

                     else
                        if Cont = False then
                           Error_Msg_N ("<~", Arg1);
                           Cont := True;
                        else
                           Error_Msg_N ("\<~", Arg1);
                        end if;
                     end if;

                     exit when Ptr > Len;
                  end loop;
               end;
            end if;
         end if;
      end Process_Compile_Time_Warning_Or_Error;

      ------------------------
      -- Process_Convention --
      ------------------------

      procedure Process_Convention
        (C   : out Convention_Id;
         Ent : out Entity_Id)
      is
         Id        : Node_Id;
         E         : Entity_Id;
         E1        : Entity_Id;
         Cname     : Name_Id;
         Comp_Unit : Unit_Number_Type;

         procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
         --  Called if we have more than one Export/Import/Convention pragma.
         --  This is generally illegal, but we have a special case of allowing
         --  Import and Interface to coexist if they specify the convention in
         --  a consistent manner. We are allowed to do this, since Interface is
         --  an implementation defined pragma, and we choose to do it since we
         --  know Rational allows this combination. S is the entity id of the
         --  subprogram in question. This procedure also sets the special flag
         --  Import_Interface_Present in both pragmas in the case where we do
         --  have matching Import and Interface pragmas.

         procedure Set_Convention_From_Pragma (E : Entity_Id);
         --  Set convention in entity E, and also flag that the entity has a
         --  convention pragma. If entity is for a private or incomplete type,
         --  also set convention and flag on underlying type. This procedure
         --  also deals with the special case of C_Pass_By_Copy convention.

         -------------------------------
         -- Diagnose_Multiple_Pragmas --
         -------------------------------

         procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
            Pdec : constant Node_Id := Declaration_Node (S);
            Decl : Node_Id;
            Err  : Boolean;

            function Same_Convention (Decl : Node_Id) return Boolean;
            --  Decl is a pragma node. This function returns True if this
            --  pragma has a first argument that is an identifier with a
            --  Chars field corresponding to the Convention_Id C.

            function Same_Name (Decl : Node_Id) return Boolean;
            --  Decl is a pragma node. This function returns True if this
            --  pragma has a second argument that is an identifier with a
            --  Chars field that matches the Chars of the current subprogram.

            ---------------------
            -- Same_Convention --
            ---------------------

            function Same_Convention (Decl : Node_Id) return Boolean is
               Arg1 : constant Node_Id :=
                        First (Pragma_Argument_Associations (Decl));

            begin
               if Present (Arg1) then
                  declare
                     Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
                  begin
                     if Nkind (Arg) = N_Identifier
                       and then Is_Convention_Name (Chars (Arg))
                       and then Get_Convention_Id (Chars (Arg)) = C
                     then
                        return True;
                     end if;
                  end;
               end if;

               return False;
            end Same_Convention;

            ---------------
            -- Same_Name --
            ---------------

            function Same_Name (Decl : Node_Id) return Boolean is
               Arg1 : constant Node_Id :=
                        First (Pragma_Argument_Associations (Decl));
               Arg2 : Node_Id;

            begin
               if No (Arg1) then
                  return False;
               end if;

               Arg2 := Next (Arg1);

               if No (Arg2) then
                  return False;
               end if;

               declare
                  Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
               begin
                  if Nkind (Arg) = N_Identifier
                    and then Chars (Arg) = Chars (S)
                  then
                     return True;
                  end if;
               end;

               return False;
            end Same_Name;

         --  Start of processing for Diagnose_Multiple_Pragmas

         begin
            Err := True;

            --  Definitely give message if we have Convention/Export here

            if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
               null;

               --  If we have an Import or Export, scan back from pragma to
               --  find any previous pragma applying to the same procedure.
               --  The scan will be terminated by the start of the list, or
               --  hitting the subprogram declaration. This won't allow one
               --  pragma to appear in the public part and one in the private
               --  part, but that seems very unlikely in practice.

            else
               Decl := Prev (N);
               while Present (Decl) and then Decl /= Pdec loop

                  --  Look for pragma with same name as us

                  if Nkind (Decl) = N_Pragma
                    and then Same_Name (Decl)
                  then
                     --  Give error if same as our pragma or Export/Convention

                     if Pragma_Name (Decl) = Name_Export
                          or else
                        Pragma_Name (Decl) = Name_Convention
                          or else
                        Pragma_Name (Decl) = Pragma_Name (N)
                     then
                        exit;

                     --  Case of Import/Interface or the other way round

                     elsif Pragma_Name (Decl) = Name_Interface
                             or else
                           Pragma_Name (Decl) = Name_Import
                     then
                        --  Here we know that we have Import and Interface. It
                        --  doesn't matter which way round they are. See if
                        --  they specify the same convention. If so, all OK,
                        --  and set special flags to stop other messages

                        if Same_Convention (Decl) then
                           Set_Import_Interface_Present (N);
                           Set_Import_Interface_Present (Decl);
                           Err := False;

                        --  If different conventions, special message

                        else
                           Error_Msg_Sloc := Sloc (Decl);
                           Error_Pragma_Arg
                             ("convention differs from that given#", Arg1);
                           return;
                        end if;
                     end if;
                  end if;

                  Next (Decl);
               end loop;
            end if;

            --  Give message if needed if we fall through those tests

            if Err then
               Error_Pragma_Arg
                 ("at most one Convention/Export/Import pragma is allowed",
                  Arg2);
            end if;
         end Diagnose_Multiple_Pragmas;

         --------------------------------
         -- Set_Convention_From_Pragma --
         --------------------------------

         procedure Set_Convention_From_Pragma (E : Entity_Id) is
         begin
            --  Ada 2005 (AI-430): Check invalid attempt to change convention
            --  for an overridden dispatching operation. Technically this is
            --  an amendment and should only be done in Ada 2005 mode. However,
            --  this is clearly a mistake, since the problem that is addressed
            --  by this AI is that there is a clear gap in the RM!

            if Is_Dispatching_Operation (E)
              and then Present (Overridden_Operation (E))
              and then C /= Convention (Overridden_Operation (E))
            then
               Error_Pragma_Arg
                 ("cannot change convention for " &
                  "overridden dispatching operation",
                  Arg1);
            end if;

            --  Set the convention

            Set_Convention (E, C);
            Set_Has_Convention_Pragma (E);

            if Is_Incomplete_Or_Private_Type (E)
              and then Present (Underlying_Type (E))
            then
               Set_Convention            (Underlying_Type (E), C);
               Set_Has_Convention_Pragma (Underlying_Type (E), True);
            end if;

            --  A class-wide type should inherit the convention of the specific
            --  root type (although this isn't specified clearly by the RM).

            if Is_Type (E) and then Present (Class_Wide_Type (E)) then
               Set_Convention (Class_Wide_Type (E), C);
            end if;

            --  If the entity is a record type, then check for special case of
            --  C_Pass_By_Copy, which is treated the same as C except that the
            --  special record flag is set. This convention is only permitted
            --  on record types (see AI95-00131).

            if Cname = Name_C_Pass_By_Copy then
               if Is_Record_Type (E) then
                  Set_C_Pass_By_Copy (Base_Type (E));
               elsif Is_Incomplete_Or_Private_Type (E)
                 and then Is_Record_Type (Underlying_Type (E))
               then
                  Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E)));
               else
                  Error_Pragma_Arg
                    ("C_Pass_By_Copy convention allowed only for record type",
                     Arg2);
               end if;
            end if;

            --  If the entity is a derived boolean type, check for the special
            --  case of convention C, C++, or Fortran, where we consider any
            --  nonzero value to represent true.

            if Is_Discrete_Type (E)
              and then Root_Type (Etype (E)) = Standard_Boolean
              and then
                (C = Convention_C
                   or else
                 C = Convention_CPP
                   or else
                 C = Convention_Fortran)
            then
               Set_Nonzero_Is_True (Base_Type (E));
            end if;
         end Set_Convention_From_Pragma;

      --  Start of processing for Process_Convention

      begin
         Check_At_Least_N_Arguments (2);
         Check_Optional_Identifier (Arg1, Name_Convention);
         Check_Arg_Is_Identifier (Arg1);
         Cname := Chars (Get_Pragma_Arg (Arg1));

         --  C_Pass_By_Copy is treated as a synonym for convention C (this is
         --  tested again below to set the critical flag).

         if Cname = Name_C_Pass_By_Copy then
            C := Convention_C;

         --  Otherwise we must have something in the standard convention list

         elsif Is_Convention_Name (Cname) then
            C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1)));

         --  In DEC VMS, it seems that there is an undocumented feature that
         --  any unrecognized convention is treated as the default, which for
         --  us is convention C. It does not seem so terrible to do this
         --  unconditionally, silently in the VMS case, and with a warning
         --  in the non-VMS case.

         else
            if Warn_On_Export_Import and not OpenVMS_On_Target then
               Error_Msg_N
                 ("?unrecognized convention name, C assumed",
                  Get_Pragma_Arg (Arg1));
            end if;

            C := Convention_C;
         end if;

         Check_Optional_Identifier (Arg2, Name_Entity);
         Check_Arg_Is_Local_Name (Arg2);

         Id := Get_Pragma_Arg (Arg2);
         Analyze (Id);

         if not Is_Entity_Name (Id) then
            Error_Pragma_Arg ("entity name required", Arg2);
         end if;

         E := Entity (Id);

         --  Set entity to return

         Ent := E;

         --  Ada_Pass_By_Copy special checking

         if C = Convention_Ada_Pass_By_Copy then
            if not Is_First_Subtype (E) then
               Error_Pragma_Arg
                 ("convention `Ada_Pass_By_Copy` only "
                  & "allowed for types", Arg2);
            end if;

            if Is_By_Reference_Type (E) then
               Error_Pragma_Arg
                 ("convention `Ada_Pass_By_Copy` not allowed for "
                  & "by-reference type", Arg1);
            end if;
         end if;

         --  Ada_Pass_By_Reference special checking

         if C = Convention_Ada_Pass_By_Reference then
            if not Is_First_Subtype (E) then
               Error_Pragma_Arg
                 ("convention `Ada_Pass_By_Reference` only "
                  & "allowed for types", Arg2);
            end if;

            if Is_By_Copy_Type (E) then
               Error_Pragma_Arg
                 ("convention `Ada_Pass_By_Reference` not allowed for "
                  & "by-copy type", Arg1);
            end if;
         end if;

         --  Go to renamed subprogram if present, since convention applies to
         --  the actual renamed entity, not to the renaming entity. If the
         --  subprogram is inherited, go to parent subprogram.

         if Is_Subprogram (E)
           and then Present (Alias (E))
         then
            if Nkind (Parent (Declaration_Node (E))) =
                                       N_Subprogram_Renaming_Declaration
            then
               if Scope (E) /= Scope (Alias (E)) then
                  Error_Pragma_Ref
                    ("cannot apply pragma% to non-local entity&#", E);
               end if;

               E := Alias (E);

            elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
                                        N_Private_Extension_Declaration)
              and then Scope (E) = Scope (Alias (E))
            then
               E := Alias (E);

               --  Return the parent subprogram the entity was inherited from

               Ent := E;
            end if;
         end if;

         --  Check that we are not applying this to a specless body

         if Is_Subprogram (E)
           and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body
         then
            Error_Pragma
              ("pragma% requires separate spec and must come before body");
         end if;

         --  Check that we are not applying this to a named constant

         if Ekind_In (E, E_Named_Integer, E_Named_Real) then
            Error_Msg_Name_1 := Pname;
            Error_Msg_N
              ("cannot apply pragma% to named constant!",
               Get_Pragma_Arg (Arg2));
            Error_Pragma_Arg
              ("\supply appropriate type for&!", Arg2);
         end if;

         if Ekind (E) = E_Enumeration_Literal then
            Error_Pragma ("enumeration literal not allowed for pragma%");
         end if;

         --  Check for rep item appearing too early or too late

         if Etype (E) = Any_Type
           or else Rep_Item_Too_Early (E, N)
         then
            raise Pragma_Exit;

         elsif Present (Underlying_Type (E)) then
            E := Underlying_Type (E);
         end if;

         if Rep_Item_Too_Late (E, N) then
            raise Pragma_Exit;
         end if;

         if Has_Convention_Pragma (E) then
            Diagnose_Multiple_Pragmas (E);

         elsif Convention (E) = Convention_Protected
           or else Ekind (Scope (E)) = E_Protected_Type
         then
            Error_Pragma_Arg
              ("a protected operation cannot be given a different convention",
                Arg2);
         end if;

         --  For Intrinsic, a subprogram is required

         if C = Convention_Intrinsic
           and then not Is_Subprogram (E)
           and then not Is_Generic_Subprogram (E)
         then
            Error_Pragma_Arg
              ("second argument of pragma% must be a subprogram", Arg2);
         end if;

         --  Stdcall case

         if C = Convention_Stdcall then

            --  A dispatching call is not allowed. A dispatching subprogram
            --  cannot be used to interface to the Win32 API, so in fact this
            --  check does not impose any effective restriction.

            if Is_Dispatching_Operation (E) then

               Error_Pragma
                 ("dispatching subprograms cannot use Stdcall convention");

            --  Subprogram is allowed, but not a generic subprogram, and not a
            --  dispatching operation.

            elsif not Is_Subprogram (E)
              and then not Is_Generic_Subprogram (E)

              --  A variable is OK

              and then Ekind (E) /= E_Variable

              --  An access to subprogram is also allowed

              and then not
                (Is_Access_Type (E)
                  and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
            then
               Error_Pragma_Arg
                 ("second argument of pragma% must be subprogram (type)",
                  Arg2);
            end if;
         end if;

         if not Is_Subprogram (E)
           and then not Is_Generic_Subprogram (E)
         then
            Set_Convention_From_Pragma (E);

            if Is_Type (E) then
               Check_First_Subtype (Arg2);
               Set_Convention_From_Pragma (Base_Type (E));

               --  For subprograms, we must set the convention on the
               --  internally generated directly designated type as well.

               if Ekind (E) = E_Access_Subprogram_Type then
                  Set_Convention_From_Pragma (Directly_Designated_Type (E));
               end if;
            end if;

         --  For the subprogram case, set proper convention for all homonyms
         --  in same scope and the same declarative part, i.e. the same
         --  compilation unit.

         else
            Comp_Unit := Get_Source_Unit (E);
            Set_Convention_From_Pragma (E);

            --  Treat a pragma Import as an implicit body, for GPS use

            if Prag_Id = Pragma_Import then
               Generate_Reference (E, Id, 'b');
            end if;

            --  Loop through the homonyms of the pragma argument's entity

            E1 := Ent;
            loop
               E1 := Homonym (E1);
               exit when No (E1) or else Scope (E1) /= Current_Scope;

               --  Do not set the pragma on inherited operations or on formal
               --  subprograms.

               if Comes_From_Source (E1)
                 and then Comp_Unit = Get_Source_Unit (E1)
                 and then not Is_Formal_Subprogram (E1)
                 and then Nkind (Original_Node (Parent (E1))) /=
                                                    N_Full_Type_Declaration
               then
                  if Present (Alias (E1))
                    and then Scope (E1) /= Scope (Alias (E1))
                  then
                     Error_Pragma_Ref
                       ("cannot apply pragma% to non-local entity& declared#",
                        E1);
                  end if;

                  Set_Convention_From_Pragma (E1);

                  if Prag_Id = Pragma_Import then
                     Generate_Reference (E1, Id, 'b');
                  end if;
               end if;

               --  For aspect case, do NOT apply to homonyms

               exit when From_Aspect_Specification (N);
            end loop;
         end if;
      end Process_Convention;

      ----------------------------------------
      -- Process_Disable_Enable_Atomic_Sync --
      ----------------------------------------

      procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is
      begin
         GNAT_Pragma;
         Check_No_Identifiers;
         Check_At_Most_N_Arguments (1);

         --  Modeled internally as
         --    pragma Unsuppress (Atomic_Synchronization [,Entity])

         Rewrite (N,
           Make_Pragma (Loc,
             Pragma_Identifier            =>
               Make_Identifier (Loc, Nam),
             Pragma_Argument_Associations => New_List (
               Make_Pragma_Argument_Association (Loc,
                 Expression =>
                   Make_Identifier (Loc, Name_Atomic_Synchronization)))));

         if Present (Arg1) then
            Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1));
         end if;

         Analyze (N);
      end Process_Disable_Enable_Atomic_Sync;

      -----------------------------------------------------
      -- Process_Extended_Import_Export_Exception_Pragma --
      -----------------------------------------------------

      procedure Process_Extended_Import_Export_Exception_Pragma
        (Arg_Internal : Node_Id;
         Arg_External : Node_Id;
         Arg_Form     : Node_Id;
         Arg_Code     : Node_Id)
      is
         Def_Id   : Entity_Id;
         Code_Val : Uint;

      begin
         if not OpenVMS_On_Target then
            Error_Pragma
              ("?pragma% ignored (applies only to Open'V'M'S)");
         end if;

         Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
         Def_Id := Entity (Arg_Internal);

         if Ekind (Def_Id) /= E_Exception then
            Error_Pragma_Arg
              ("pragma% must refer to declared exception", Arg_Internal);
         end if;

         Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);

         if Present (Arg_Form) then
            Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS);
         end if;

         if Present (Arg_Form)
           and then Chars (Arg_Form) = Name_Ada
         then
            null;
         else
            Set_Is_VMS_Exception (Def_Id);
            Set_Exception_Code (Def_Id, No_Uint);
         end if;

         if Present (Arg_Code) then
            if not Is_VMS_Exception (Def_Id) then
               Error_Pragma_Arg
                 ("Code option for pragma% not allowed for Ada case",
                  Arg_Code);
            end if;

            Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
            Code_Val := Expr_Value (Arg_Code);

            if not UI_Is_In_Int_Range (Code_Val) then
               Error_Pragma_Arg
                 ("Code option for pragma% must be in 32-bit range",
                  Arg_Code);

            else
               Set_Exception_Code (Def_Id, Code_Val);
            end if;
         end if;
      end Process_Extended_Import_Export_Exception_Pragma;

      -------------------------------------------------
      -- Process_Extended_Import_Export_Internal_Arg --
      -------------------------------------------------

      procedure Process_Extended_Import_Export_Internal_Arg
        (Arg_Internal : Node_Id := Empty)
      is
      begin
         if No (Arg_Internal) then
            Error_Pragma ("Internal parameter required for pragma%");
         end if;

         if Nkind (Arg_Internal) = N_Identifier then
            null;

         elsif Nkind (Arg_Internal) = N_Operator_Symbol
           and then (Prag_Id = Pragma_Import_Function
                       or else
                     Prag_Id = Pragma_Export_Function)
         then
            null;

         else
            Error_Pragma_Arg
              ("wrong form for Internal parameter for pragma%", Arg_Internal);
         end if;