MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
f9989b51a9
8sa1-gcc/gcc/ada/sem_prag.adb
Arnaud Charlet b3c336413b [multiple changes] 
2011-10-24  Robert Dewar  <dewar@adacore.com>

	* sem.adb (Initialize): Fix bug that blew up if called a second
	time.

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* tb-alvxw.c, tracebak.c, expect.c, initflt.c, tb-alvms.c,
	tb-ivms.c, tb-gcc.c: Update headers to GPL 3.

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Analyze_Pragma, case Debug): Give proper pragma
	name in error msg.

2011-10-24  Hristian Kirtchev  <kirtchev@adacore.com>

	* gnat_rm.texi Add an entry for restriction No_Finalization.

2011-10-24  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Insert_Freeze_Node_For_Instance):  If the
	current instance is within the one that contains the generic,
	the freeze node for the current one must appear in the current
	declarative part. Ditto if the current instance is within another
	package instance. In both of these cases the freeze node of the
	previous instance is not relevant.

2011-10-24  Gary Dismukes  <dismukes@adacore.com>

	* switch-m.adb (Normalize_Compiler_Switches): Add recognition
	of AAMP-specific switches -univ and -aamp_target.

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* a-tienau.adb (Put): Deal properly with limited line length.

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* sem_warn.adb, sem_ch12.adb: Minor reformatting.

From-SVN: r180375
2011-10-24 12:31:29 +02:00

15257 lines
521 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- 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 (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);
-- 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_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
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
if Present (Typ) then
Analyze_And_Resolve (Argx, Typ);
else
Analyze_And_Resolve (Argx);
end if;
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 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 (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;
-- 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, Argx);
end;
raise Pragma_Exit;
end if;
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);
function Inside_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body.
-- Shouldn't this be in a more general place ???
-------------------------
-- Inside_Generic_Body --
-------------------------
function Inside_Generic_Body (Id : Entity_Id) return Boolean is
S : Entity_Id;
begin
S := Id;
while Present (S) and then S /= Standard_Standard loop
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
return True;
end if;
S := Scope (S);
end loop;
return False;
end Inside_Generic_Body;
-- Start of processing for Check_Component
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 Inside_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_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);
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
Check_Restriction (No_Implementation_Pragmas, N);
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;
-- For Stdcall, a subprogram, variable or subprogram type is required
if C = Convention_Stdcall
and then not Is_Subprogram (E)
and then not Is_Generic_Subprogram (E)
and then Ekind (E) /= E_Variable
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;
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;
Check_Arg_Is_Local_Name (Arg_Internal);
end Process_Extended_Import_Export_Internal_Arg;
--------------------------------------------------
-- Process_Extended_Import_Export_Object_Pragma --
--------------------------------------------------
procedure Process_Extended_Import_Export_Object_Pragma
(Arg_Internal : Node_Id;
Arg_External : Node_Id;
Arg_Size : Node_Id)
is
Def_Id : Entity_Id;
begin
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Def_Id := Entity (Arg_Internal);
if not Ekind_In (Def_Id, E_Constant, E_Variable) then
Error_Pragma_Arg
("pragma% must designate an object", Arg_Internal);
end if;
if Has_Rep_Pragma (Def_Id, Name_Common_Object)
or else
Has_Rep_Pragma (Def_Id, Name_Psect_Object)
then
Error_Pragma_Arg
("previous Common/Psect_Object applies, pragma % not permitted",
Arg_Internal);
end if;
if Rep_Item_Too_Late (Def_Id, N) then
raise Pragma_Exit;
end if;
Set_Extended_Import_Export_External_Name (Def_Id, Arg_External);
if Present (Arg_Size) then
Check_Arg_Is_External_Name (Arg_Size);
end if;
-- Export_Object case
if Prag_Id = Pragma_Export_Object then
if not Is_Library_Level_Entity (Def_Id) then
Error_Pragma_Arg
("argument for pragma% must be library level entity",
Arg_Internal);
end if;
if Ekind (Current_Scope) = E_Generic_Package then
Error_Pragma ("pragma& cannot appear in a generic unit");
end if;
if not Size_Known_At_Compile_Time (Etype (Def_Id)) then
Error_Pragma_Arg
("exported object must have compile time known size",
Arg_Internal);
end if;
if Warn_On_Export_Import and then Is_Exported (Def_Id) then
Error_Msg_N ("?duplicate Export_Object pragma", N);
else
Set_Exported (Def_Id, Arg_Internal);
end if;
-- Import_Object case
else
if Is_Concurrent_Type (Etype (Def_Id)) then
Error_Pragma_Arg
("cannot use pragma% for task/protected object",
Arg_Internal);
end if;
if Ekind (Def_Id) = E_Constant then
Error_Pragma_Arg
("cannot import a constant", Arg_Internal);
end if;
if Warn_On_Export_Import
and then Has_Discriminants (Etype (Def_Id))
then
Error_Msg_N
("imported value must be initialized?", Arg_Internal);
end if;
if Warn_On_Export_Import
and then Is_Access_Type (Etype (Def_Id))
then
Error_Pragma_Arg
("cannot import object of an access type?", Arg_Internal);
end if;
if Warn_On_Export_Import
and then Is_Imported (Def_Id)
then
Error_Msg_N
("?duplicate Import_Object pragma", N);
-- Check for explicit initialization present. Note that an
-- initialization generated by the code generator, e.g. for an
-- access type, does not count here.
elsif Present (Expression (Parent (Def_Id)))
and then
Comes_From_Source
(Original_Node (Expression (Parent (Def_Id))))
then
Error_Msg_Sloc := Sloc (Def_Id);
Error_Pragma_Arg
("imported entities cannot be initialized (RM B.1(24))",
"\no initialization allowed for & declared#", Arg1);
else
Set_Imported (Def_Id);
Note_Possible_Modification (Arg_Internal, Sure => False);
end if;
end if;
end Process_Extended_Import_Export_Object_Pragma;
------------------------------------------------------
-- Process_Extended_Import_Export_Subprogram_Pragma --
------------------------------------------------------
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)
is
Ent : Entity_Id;
Def_Id : Entity_Id;
Hom_Id : Entity_Id;
Formal : Entity_Id;
Ambiguous : Boolean;
Match : Boolean;
Dval : Node_Id;
function Same_Base_Type
(Ptype : Node_Id;
Formal : Entity_Id) return Boolean;
-- Determines if Ptype references the type of Formal. Note that only
-- the base types need to match according to the spec. Ptype here is
-- the argument from the pragma, which is either a type name, or an
-- access attribute.
--------------------
-- Same_Base_Type --
--------------------
function Same_Base_Type
(Ptype : Node_Id;
Formal : Entity_Id) return Boolean
is
Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
Pref : Node_Id;
begin
-- Case where pragma argument is typ'Access
if Nkind (Ptype) = N_Attribute_Reference
and then Attribute_Name (Ptype) = Name_Access
then
Pref := Prefix (Ptype);
Find_Type (Pref);
if not Is_Entity_Name (Pref)
or else Entity (Pref) = Any_Type
then
raise Pragma_Exit;
end if;
-- We have a match if the corresponding argument is of an
-- anonymous access type, and its designated type matches the
-- type of the prefix of the access attribute
return Ekind (Ftyp) = E_Anonymous_Access_Type
and then Base_Type (Entity (Pref)) =
Base_Type (Etype (Designated_Type (Ftyp)));
-- Case where pragma argument is a type name
else
Find_Type (Ptype);
if not Is_Entity_Name (Ptype)
or else Entity (Ptype) = Any_Type
then
raise Pragma_Exit;
end if;
-- We have a match if the corresponding argument is of the type
-- given in the pragma (comparing base types)
return Base_Type (Entity (Ptype)) = Ftyp;
end if;
end Same_Base_Type;
-- Start of processing for
-- Process_Extended_Import_Export_Subprogram_Pragma
begin
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Ent := Empty;
Ambiguous := False;
-- Loop through homonyms (overloadings) of the entity
Hom_Id := Entity (Arg_Internal);
while Present (Hom_Id) loop
Def_Id := Get_Base_Subprogram (Hom_Id);
-- We need a subprogram in the current scope
if not Is_Subprogram (Def_Id)
or else Scope (Def_Id) /= Current_Scope
then
null;
else
Match := True;
-- Pragma cannot apply to subprogram body
if Is_Subprogram (Def_Id)
and then Nkind (Parent (Declaration_Node (Def_Id))) =
N_Subprogram_Body
then
Error_Pragma
("pragma% requires separate spec"
& " and must come before body");
end if;
-- Test result type if given, note that the result type
-- parameter can only be present for the function cases.
if Present (Arg_Result_Type)
and then not Same_Base_Type (Arg_Result_Type, Def_Id)
then
Match := False;
elsif Etype (Def_Id) /= Standard_Void_Type
and then
(Pname = Name_Export_Procedure
or else
Pname = Name_Import_Procedure)
then
Match := False;
-- Test parameter types if given. Note that this parameter
-- has not been analyzed (and must not be, since it is
-- semantic nonsense), so we get it as the parser left it.
elsif Present (Arg_Parameter_Types) then
Check_Matching_Types : declare
Formal : Entity_Id;
Ptype : Node_Id;
begin
Formal := First_Formal (Def_Id);
if Nkind (Arg_Parameter_Types) = N_Null then
if Present (Formal) then
Match := False;
end if;
-- A list of one type, e.g. (List) is parsed as
-- a parenthesized expression.
elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
and then Paren_Count (Arg_Parameter_Types) = 1
then
if No (Formal)
or else Present (Next_Formal (Formal))
then
Match := False;
else
Match :=
Same_Base_Type (Arg_Parameter_Types, Formal);
end if;
-- A list of more than one type is parsed as a aggregate
elsif Nkind (Arg_Parameter_Types) = N_Aggregate
and then Paren_Count (Arg_Parameter_Types) = 0
then
Ptype := First (Expressions (Arg_Parameter_Types));
while Present (Ptype) or else Present (Formal) loop
if No (Ptype)
or else No (Formal)
or else not Same_Base_Type (Ptype, Formal)
then
Match := False;
exit;
else
Next_Formal (Formal);
Next (Ptype);
end if;
end loop;
-- Anything else is of the wrong form
else
Error_Pragma_Arg
("wrong form for Parameter_Types parameter",
Arg_Parameter_Types);
end if;
end Check_Matching_Types;
end if;
-- Match is now False if the entry we found did not match
-- either a supplied Parameter_Types or Result_Types argument
if Match then
if No (Ent) then
Ent := Def_Id;
-- Ambiguous case, the flag Ambiguous shows if we already
-- detected this and output the initial messages.
else
if not Ambiguous then
Ambiguous := True;
Error_Msg_Name_1 := Pname;
Error_Msg_N
("pragma% does not uniquely identify subprogram!",
N);
Error_Msg_Sloc := Sloc (Ent);
Error_Msg_N ("matching subprogram #!", N);
Ent := Empty;
end if;
Error_Msg_Sloc := Sloc (Def_Id);
Error_Msg_N ("matching subprogram #!", N);
end if;
end if;
end if;
Hom_Id := Homonym (Hom_Id);
end loop;
-- See if we found an entry
if No (Ent) then
if not Ambiguous then
if Is_Generic_Subprogram (Entity (Arg_Internal)) then
Error_Pragma
("pragma% cannot be given for generic subprogram");
else
Error_Pragma
("pragma% does not identify local subprogram");
end if;
end if;
return;
end if;
-- Import pragmas must be for imported entities
if Prag_Id = Pragma_Import_Function
or else
Prag_Id = Pragma_Import_Procedure
or else
Prag_Id = Pragma_Import_Valued_Procedure
then
if not Is_Imported (Ent) then
Error_Pragma
("pragma Import or Interface must precede pragma%");
end if;
-- Here we have the Export case which can set the entity as exported
-- But does not do so if the specified external name is null, since
-- that is taken as a signal in DEC Ada 83 (with which we want to be
-- compatible) to request no external name.
elsif Nkind (Arg_External) = N_String_Literal
and then String_Length (Strval (Arg_External)) = 0
then
null;
-- In all other cases, set entity as exported
else
Set_Exported (Ent, Arg_Internal);
end if;
-- Special processing for Valued_Procedure cases
if Prag_Id = Pragma_Import_Valued_Procedure
or else
Prag_Id = Pragma_Export_Valued_Procedure
then
Formal := First_Formal (Ent);
if No (Formal) then
Error_Pragma ("at least one parameter required for pragma%");
elsif Ekind (Formal) /= E_Out_Parameter then
Error_Pragma ("first parameter must have mode out for pragma%");
else
Set_Is_Valued_Procedure (Ent);
end if;
end if;
Set_Extended_Import_Export_External_Name (Ent, Arg_External);
-- Process Result_Mechanism argument if present. We have already
-- checked that this is only allowed for the function case.
if Present (Arg_Result_Mechanism) then
Set_Mechanism_Value (Ent, Arg_Result_Mechanism);
end if;
-- Process Mechanism parameter if present. Note that this parameter
-- is not analyzed, and must not be analyzed since it is semantic
-- nonsense, so we get it in exactly as the parser left it.
if Present (Arg_Mechanism) then
declare
Formal : Entity_Id;
Massoc : Node_Id;
Mname : Node_Id;
Choice : Node_Id;
begin
-- A single mechanism association without a formal parameter
-- name is parsed as a parenthesized expression. All other
-- cases are parsed as aggregates, so we rewrite the single
-- parameter case as an aggregate for consistency.
if Nkind (Arg_Mechanism) /= N_Aggregate
and then Paren_Count (Arg_Mechanism) = 1
then
Rewrite (Arg_Mechanism,
Make_Aggregate (Sloc (Arg_Mechanism),
Expressions => New_List (
Relocate_Node (Arg_Mechanism))));
end if;
-- Case of only mechanism name given, applies to all formals
if Nkind (Arg_Mechanism) /= N_Aggregate then
Formal := First_Formal (Ent);
while Present (Formal) loop
Set_Mechanism_Value (Formal, Arg_Mechanism);
Next_Formal (Formal);
end loop;
-- Case of list of mechanism associations given
else
if Null_Record_Present (Arg_Mechanism) then
Error_Pragma_Arg
("inappropriate form for Mechanism parameter",
Arg_Mechanism);
end if;
-- Deal with positional ones first
Formal := First_Formal (Ent);
if Present (Expressions (Arg_Mechanism)) then
Mname := First (Expressions (Arg_Mechanism));
while Present (Mname) loop
if No (Formal) then
Error_Pragma_Arg
("too many mechanism associations", Mname);
end if;
Set_Mechanism_Value (Formal, Mname);
Next_Formal (Formal);
Next (Mname);
end loop;
end if;
-- Deal with named entries
if Present (Component_Associations (Arg_Mechanism)) then
Massoc := First (Component_Associations (Arg_Mechanism));
while Present (Massoc) loop
Choice := First (Choices (Massoc));
if Nkind (Choice) /= N_Identifier
or else Present (Next (Choice))
then
Error_Pragma_Arg
("incorrect form for mechanism association",
Massoc);
end if;
Formal := First_Formal (Ent);
loop
if No (Formal) then
Error_Pragma_Arg
("parameter name & not present", Choice);
end if;
if Chars (Choice) = Chars (Formal) then
Set_Mechanism_Value
(Formal, Expression (Massoc));
-- Set entity on identifier (needed by ASIS)
Set_Entity (Choice, Formal);
exit;
end if;
Next_Formal (Formal);
end loop;
Next (Massoc);
end loop;
end if;
end if;
end;
end if;
-- Process First_Optional_Parameter argument if present. We have
-- already checked that this is only allowed for the Import case.
if Present (Arg_First_Optional_Parameter) then
if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
Error_Pragma_Arg
("first optional parameter must be formal parameter name",
Arg_First_Optional_Parameter);
end if;
Formal := First_Formal (Ent);
loop
if No (Formal) then
Error_Pragma_Arg
("specified formal parameter& not found",
Arg_First_Optional_Parameter);
end if;
exit when Chars (Formal) =
Chars (Arg_First_Optional_Parameter);
Next_Formal (Formal);
end loop;
Set_First_Optional_Parameter (Ent, Formal);
-- Check specified and all remaining formals have right form
while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter then
Error_Msg_NE
("optional formal& is not of mode in!",
Arg_First_Optional_Parameter, Formal);
else
Dval := Default_Value (Formal);
if No (Dval) then
Error_Msg_NE
("optional formal& does not have default value!",
Arg_First_Optional_Parameter, Formal);
elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
null;
else
Error_Msg_FE
("default value for optional formal& is non-static!",
Arg_First_Optional_Parameter, Formal);
end if;
end if;
Set_Is_Optional_Parameter (Formal);
Next_Formal (Formal);
end loop;
end if;
end Process_Extended_Import_Export_Subprogram_Pragma;
--------------------------
-- Process_Generic_List --
--------------------------
procedure Process_Generic_List is
Arg : Node_Id;
Exp : Node_Id;
begin
Check_No_Identifiers;
Check_At_Least_N_Arguments (1);
Arg := Arg1;
while Present (Arg) loop
Exp := Get_Pragma_Arg (Arg);
Analyze (Exp);
if not Is_Entity_Name (Exp)
or else
(not Is_Generic_Instance (Entity (Exp))
and then
not Is_Generic_Unit (Entity (Exp)))
then
Error_Pragma_Arg
("pragma% argument must be name of generic unit/instance",
Arg);
end if;
Next (Arg);
end loop;
end Process_Generic_List;
------------------------------------
-- Process_Import_Predefined_Type --
------------------------------------
procedure Process_Import_Predefined_Type is
Loc : constant Source_Ptr := Sloc (N);
Elmt : Elmt_Id;
Ftyp : Node_Id := Empty;
Decl : Node_Id;
Def : Node_Id;
Nam : Name_Id;
begin
String_To_Name_Buffer (Strval (Expression (Arg3)));
Nam := Name_Find;
Elmt := First_Elmt (Predefined_Float_Types);
while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop
Next_Elmt (Elmt);
end loop;
Ftyp := Node (Elmt);
if Present (Ftyp) then
-- Don't build a derived type declaration, because predefined C
-- types have no declaration anywhere, so cannot really be named.
-- Instead build a full type declaration, starting with an
-- appropriate type definition is built
if Is_Floating_Point_Type (Ftyp) then
Def := Make_Floating_Point_Definition (Loc,
Make_Integer_Literal (Loc, Digits_Value (Ftyp)),
Make_Real_Range_Specification (Loc,
Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))),
Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp)))));
-- Should never have a predefined type we cannot handle
else
raise Program_Error;
end if;
-- Build and insert a Full_Type_Declaration, which will be
-- analyzed as soon as this list entry has been analyzed.
Decl := Make_Full_Type_Declaration (Loc,
Make_Defining_Identifier (Loc, Chars (Expression (Arg2))),
Type_Definition => Def);
Insert_After (N, Decl);
Mark_Rewrite_Insertion (Decl);
else
Error_Pragma_Arg ("no matching type found for pragma%",
Arg2);
end if;
end Process_Import_Predefined_Type;
---------------------------------
-- Process_Import_Or_Interface --
---------------------------------
procedure Process_Import_Or_Interface is
C : Convention_Id;
Def_Id : Entity_Id;
Hom_Id : Entity_Id;
begin
Process_Convention (C, Def_Id);
Kill_Size_Check_Code (Def_Id);
Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
if Ekind_In (Def_Id, E_Variable, E_Constant) then
-- We do not permit Import to apply to a renaming declaration
if Present (Renamed_Object (Def_Id)) then
Error_Pragma_Arg
("pragma% not allowed for object renaming", Arg2);
-- User initialization is not allowed for imported object, but
-- the object declaration may contain a default initialization,
-- that will be discarded. Note that an explicit initialization
-- only counts if it comes from source, otherwise it is simply
-- the code generator making an implicit initialization explicit.
elsif Present (Expression (Parent (Def_Id)))
and then Comes_From_Source (Expression (Parent (Def_Id)))
then
Error_Msg_Sloc := Sloc (Def_Id);
Error_Pragma_Arg
("no initialization allowed for declaration of& #",
"\imported entities cannot be initialized (RM B.1(24))",
Arg2);
else
Set_Imported (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
-- Note that we do not set Is_Public here. That's because we
-- only want to set it if there is no address clause, and we
-- don't know that yet, so we delay that processing till
-- freeze time.
-- pragma Import completes deferred constants
if Ekind (Def_Id) = E_Constant then
Set_Has_Completion (Def_Id);
end if;
-- It is not possible to import a constant of an unconstrained
-- array type (e.g. string) because there is no simple way to
-- write a meaningful subtype for it.
if Is_Array_Type (Etype (Def_Id))
and then not Is_Constrained (Etype (Def_Id))
then
Error_Msg_NE
("imported constant& must have a constrained subtype",
N, Def_Id);
end if;
end if;
elsif Is_Subprogram (Def_Id)
or else Is_Generic_Subprogram (Def_Id)
then
-- If the name is overloaded, pragma applies to all of the denoted
-- entities in the same declarative part.
Hom_Id := Def_Id;
while Present (Hom_Id) loop
Def_Id := Get_Base_Subprogram (Hom_Id);
-- Ignore inherited subprograms because the pragma will apply
-- to the parent operation, which is the one called.
if Is_Overloadable (Def_Id)
and then Present (Alias (Def_Id))
then
null;
-- If it is not a subprogram, it must be in an outer scope and
-- pragma does not apply.
elsif not Is_Subprogram (Def_Id)
and then not Is_Generic_Subprogram (Def_Id)
then
null;
-- The pragma does not apply to primitives of interfaces
elsif Is_Dispatching_Operation (Def_Id)
and then Present (Find_Dispatching_Type (Def_Id))
and then Is_Interface (Find_Dispatching_Type (Def_Id))
then
null;
-- Verify that the homonym is in the same declarative part (not
-- just the same scope).
elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N)
and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux
then
exit;
else
Set_Imported (Def_Id);
-- Reject an Import applied to an abstract subprogram
if Is_Subprogram (Def_Id)
and then Is_Abstract_Subprogram (Def_Id)
then
Error_Msg_Sloc := Sloc (Def_Id);
Error_Msg_NE
("cannot import abstract subprogram& declared#",
Arg2, Def_Id);
end if;
-- Special processing for Convention_Intrinsic
if C = Convention_Intrinsic then
-- Link_Name argument not allowed for intrinsic
Check_No_Link_Name;
Set_Is_Intrinsic_Subprogram (Def_Id);
-- If no external name is present, then check that this
-- is a valid intrinsic subprogram. If an external name
-- is present, then this is handled by the back end.
if No (Arg3) then
Check_Intrinsic_Subprogram
(Def_Id, Get_Pragma_Arg (Arg2));
end if;
end if;
-- All interfaced procedures need an external symbol created
-- for them since they are always referenced from another
-- object file.
Set_Is_Public (Def_Id);
-- Verify that the subprogram does not have a completion
-- through a renaming declaration. For other completions the
-- pragma appears as a too late representation.
declare
Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
begin
if Present (Decl)
and then Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
and then Nkind (Unit_Declaration_Node
(Corresponding_Body (Decl))) =
N_Subprogram_Renaming_Declaration
then
Error_Msg_Sloc := Sloc (Def_Id);
Error_Msg_NE
("cannot import&, renaming already provided for " &
"declaration #", N, Def_Id);
end if;
end;
Set_Has_Completion (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
end if;
if Is_Compilation_Unit (Hom_Id) then
-- Its possible homonyms are not affected by the pragma.
-- Such homonyms might be present in the context of other
-- units being compiled.
exit;
else
Hom_Id := Homonym (Hom_Id);
end if;
end loop;
-- When the convention is Java or CIL, we also allow Import to be
-- given for packages, generic packages, exceptions, record
-- components, and access to subprograms.
elsif (C = Convention_Java or else C = Convention_CIL)
and then
(Is_Package_Or_Generic_Package (Def_Id)
or else Ekind (Def_Id) = E_Exception
or else Ekind (Def_Id) = E_Access_Subprogram_Type
or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
then
Set_Imported (Def_Id);
Set_Is_Public (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
-- Import a CPP class
elsif Is_Record_Type (Def_Id)
and then C = Convention_CPP
then
-- Types treated as CPP classes must be declared limited (note:
-- this used to be a warning but there is no real benefit to it
-- since we did effectively intend to treat the type as limited
-- anyway).
if not Is_Limited_Type (Def_Id) then
Error_Msg_N
("imported 'C'P'P type must be limited",
Get_Pragma_Arg (Arg2));
end if;
Set_Is_CPP_Class (Def_Id);
-- Imported CPP types must not have discriminants (because C++
-- classes do not have discriminants).
if Has_Discriminants (Def_Id) then
Error_Msg_N
("imported 'C'P'P type cannot have discriminants",
First (Discriminant_Specifications
(Declaration_Node (Def_Id))));
end if;
-- Components of imported CPP types must not have default
-- expressions because the constructor (if any) is on the
-- C++ side.
declare
Tdef : constant Node_Id :=
Type_Definition (Declaration_Node (Def_Id));
Clist : Node_Id;
Comp : Node_Id;
begin
if Nkind (Tdef) = N_Record_Definition then
Clist := Component_List (Tdef);
else
pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
Clist := Component_List (Record_Extension_Part (Tdef));
end if;
if Present (Clist) then
Comp := First (Component_Items (Clist));
while Present (Comp) loop
if Present (Expression (Comp)) then
Error_Msg_N
("component of imported 'C'P'P type cannot have" &
" default expression", Expression (Comp));
end if;
Next (Comp);
end loop;
end if;
end;
elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
Check_No_Link_Name;
Check_Arg_Count (3);
Check_Arg_Is_Static_Expression (Arg3, Standard_String);
Process_Import_Predefined_Type;
else
Error_Pragma_Arg
("second argument of pragma% must be object, subprogram" &
" or incomplete type",
Arg2);
end if;
-- If this pragma applies to a compilation unit, then the unit, which
-- is a subprogram, does not require (or allow) a body. We also do
-- not need to elaborate imported procedures.
if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
declare
Cunit : constant Node_Id := Parent (Parent (N));
begin
Set_Body_Required (Cunit, False);
end;
end if;
end Process_Import_Or_Interface;
--------------------
-- Process_Inline --
--------------------
procedure Process_Inline (Active : Boolean) is
Assoc : Node_Id;
Decl : Node_Id;
Subp_Id : Node_Id;
Subp : Entity_Id;
Applies : Boolean;
Effective : Boolean := False;
-- Set True if inline has some effect, i.e. if there is at least one
-- subprogram set as inlined as a result of the use of the pragma.
procedure Make_Inline (Subp : Entity_Id);
-- Subp is the defining unit name of the subprogram declaration. Set
-- the flag, as well as the flag in the corresponding body, if there
-- is one present.
procedure Set_Inline_Flags (Subp : Entity_Id);
-- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
-- Has_Pragma_Inline_Always for the Inline_Always case.
function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
-- Returns True if it can be determined at this stage that inlining
-- is not possible, for example if the body is available and contains
-- exception handlers, we prevent inlining, since otherwise we can
-- get undefined symbols at link time. This function also emits a
-- warning if front-end inlining is enabled and the pragma appears
-- too late.
--
-- ??? is business with link symbols still valid, or does it relate
-- to front end ZCX which is being phased out ???
---------------------------
-- Inlining_Not_Possible --
---------------------------
function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Stats : Node_Id;
begin
if Nkind (Decl) = N_Subprogram_Body then
Stats := Handled_Statement_Sequence (Decl);
return Present (Exception_Handlers (Stats))
or else Present (At_End_Proc (Stats));
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
if Front_End_Inlining
and then Analyzed (Corresponding_Body (Decl))
then
Error_Msg_N ("pragma appears too late, ignored?", N);
return True;
-- If the subprogram is a renaming as body, the body is just a
-- call to the renamed subprogram, and inlining is trivially
-- possible.
elsif
Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
N_Subprogram_Renaming_Declaration
then
return False;
else
Stats :=
Handled_Statement_Sequence
(Unit_Declaration_Node (Corresponding_Body (Decl)));
return
Present (Exception_Handlers (Stats))
or else Present (At_End_Proc (Stats));
end if;
else
-- If body is not available, assume the best, the check is
-- performed again when compiling enclosing package bodies.
return False;
end if;
end Inlining_Not_Possible;
-----------------
-- Make_Inline --
-----------------
procedure Make_Inline (Subp : Entity_Id) is
Kind : constant Entity_Kind := Ekind (Subp);
Inner_Subp : Entity_Id := Subp;
begin
-- Ignore if bad type, avoid cascaded error
if Etype (Subp) = Any_Type then
Applies := True;
return;
-- Ignore if all inlining is suppressed
elsif Suppress_All_Inlining then
Applies := True;
return;
-- If inlining is not possible, for now do not treat as an error
elsif Inlining_Not_Possible (Subp) then
Applies := True;
return;
-- Here we have a candidate for inlining, but we must exclude
-- derived operations. Otherwise we would end up trying to inline
-- a phantom declaration, and the result would be to drag in a
-- body which has no direct inlining associated with it. That
-- would not only be inefficient but would also result in the
-- backend doing cross-unit inlining in cases where it was
-- definitely inappropriate to do so.
-- However, a simple Comes_From_Source test is insufficient, since
-- we do want to allow inlining of generic instances which also do
-- not come from source. We also need to recognize specs generated
-- by the front-end for bodies that carry the pragma. Finally,
-- predefined operators do not come from source but are not
-- inlineable either.
elsif Is_Generic_Instance (Subp)
or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration
then
null;
elsif not Comes_From_Source (Subp)
and then Scope (Subp) /= Standard_Standard
then
Applies := True;
return;
end if;
-- The referenced entity must either be the enclosing entity, or
-- an entity declared within the current open scope.
if Present (Scope (Subp))
and then Scope (Subp) /= Current_Scope
and then Subp /= Current_Scope
then
Error_Pragma_Arg
("argument of% must be entity in current scope", Assoc);
return;
end if;
-- Processing for procedure, operator or function. If subprogram
-- is aliased (as for an instance) indicate that the renamed
-- entity (if declared in the same unit) is inlined.
if Is_Subprogram (Subp) then
Inner_Subp := Ultimate_Alias (Inner_Subp);
if In_Same_Source_Unit (Subp, Inner_Subp) then
Set_Inline_Flags (Inner_Subp);
Decl := Parent (Parent (Inner_Subp));
if Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
Set_Inline_Flags (Corresponding_Body (Decl));
elsif Is_Generic_Instance (Subp) then
-- Indicate that the body needs to be created for
-- inlining subsequent calls. The instantiation node
-- follows the declaration of the wrapper package
-- created for it.
if Scope (Subp) /= Standard_Standard
and then
Need_Subprogram_Instance_Body
(Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
Subp)
then
null;
end if;
-- Inline is a program unit pragma (RM 10.1.5) and cannot
-- appear in a formal part to apply to a formal subprogram.
-- Do not apply check within an instance or a formal package
-- the test will have been applied to the original generic.
elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
and then List_Containing (Decl) = List_Containing (N)
and then not In_Instance
then
Error_Msg_N
("Inline cannot apply to a formal subprogram", N);
end if;
end if;
Applies := True;
-- For a generic subprogram set flag as well, for use at the point
-- of instantiation, to determine whether the body should be
-- generated.
elsif Is_Generic_Subprogram (Subp) then
Set_Inline_Flags (Subp);
Applies := True;
-- Literals are by definition inlined
elsif Kind = E_Enumeration_Literal then
null;
-- Anything else is an error
else
Error_Pragma_Arg
("expect subprogram name for pragma%", Assoc);
end if;
end Make_Inline;
----------------------
-- Set_Inline_Flags --
----------------------
procedure Set_Inline_Flags (Subp : Entity_Id) is
begin
if Active then
Set_Is_Inlined (Subp);
end if;
if not Has_Pragma_Inline (Subp) then
Set_Has_Pragma_Inline (Subp);
Effective := True;
end if;
if Prag_Id = Pragma_Inline_Always then
Set_Has_Pragma_Inline_Always (Subp);
end if;
end Set_Inline_Flags;
-- Start of processing for Process_Inline
begin
Check_No_Identifiers;
Check_At_Least_N_Arguments (1);
if Active then
Inline_Processing_Required := True;
end if;
Assoc := Arg1;
while Present (Assoc) loop
Subp_Id := Get_Pragma_Arg (Assoc);
Analyze (Subp_Id);
Applies := False;
if Is_Entity_Name (Subp_Id) then
Subp := Entity (Subp_Id);
if Subp = Any_Id then
-- If previous error, avoid cascaded errors
Applies := True;
Effective := True;
else
Make_Inline (Subp);
-- For the pragma case, climb homonym chain. This is
-- what implements allowing the pragma in the renaming
-- case, with the result applying to the ancestors, and
-- also allows Inline to apply to all previous homonyms.
if not From_Aspect_Specification (N) then
while Present (Homonym (Subp))
and then Scope (Homonym (Subp)) = Current_Scope
loop
Make_Inline (Homonym (Subp));
Subp := Homonym (Subp);
end loop;
end if;
end if;
end if;
if not Applies then
Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc);
elsif not Effective
and then Warn_On_Redundant_Constructs
and then not Suppress_All_Inlining
then
if Inlining_Not_Possible (Subp) then
Error_Msg_NE
("pragma Inline for& is ignored?", N, Entity (Subp_Id));
else
Error_Msg_NE
("pragma Inline for& is redundant?", N, Entity (Subp_Id));
end if;
end if;
Next (Assoc);
end loop;
end Process_Inline;
----------------------------
-- Process_Interface_Name --
----------------------------
procedure Process_Interface_Name
(Subprogram_Def : Entity_Id;
Ext_Arg : Node_Id;
Link_Arg : Node_Id)
is
Ext_Nam : Node_Id;
Link_Nam : Node_Id;
String_Val : String_Id;
procedure Check_Form_Of_Interface_Name
(SN : Node_Id;
Ext_Name_Case : Boolean);
-- SN is a string literal node for an interface name. This routine
-- performs some minimal checks that the name is reasonable. In
-- particular that no spaces or other obviously incorrect characters
-- appear. This is only a warning, since any characters are allowed.
-- Ext_Name_Case is True for an External_Name, False for a Link_Name.
----------------------------------
-- Check_Form_Of_Interface_Name --
----------------------------------
procedure Check_Form_Of_Interface_Name
(SN : Node_Id;
Ext_Name_Case : Boolean)
is
S : constant String_Id := Strval (Expr_Value_S (SN));
SL : constant Nat := String_Length (S);
C : Char_Code;
begin
if SL = 0 then
Error_Msg_N ("interface name cannot be null string", SN);
end if;
for J in 1 .. SL loop
C := Get_String_Char (S, J);
-- Look for dubious character and issue unconditional warning.
-- Definitely dubious if not in character range.
if not In_Character_Range (C)
-- For all cases except CLI target,
-- commas, spaces and slashes are dubious (in CLI, we use
-- commas and backslashes in external names to specify
-- assembly version and public key, while slashes and spaces
-- can be used in names to mark nested classes and
-- valuetypes).
or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
and then (Get_Character (C) = ','
or else
Get_Character (C) = '\'))
or else (VM_Target /= CLI_Target
and then (Get_Character (C) = ' '
or else
Get_Character (C) = '/'))
then
Error_Msg
("?interface name contains illegal character",
Sloc (SN) + Source_Ptr (J));
end if;
end loop;
end Check_Form_Of_Interface_Name;
-- Start of processing for Process_Interface_Name
begin
if No (Link_Arg) then
if No (Ext_Arg) then
if VM_Target = CLI_Target
and then Ekind (Subprogram_Def) = E_Package
and then Nkind (Parent (Subprogram_Def)) =
N_Package_Specification
and then Present (Generic_Parent (Parent (Subprogram_Def)))
then
Set_Interface_Name
(Subprogram_Def,
Interface_Name
(Generic_Parent (Parent (Subprogram_Def))));
end if;
return;
elsif Chars (Ext_Arg) = Name_Link_Name then
Ext_Nam := Empty;
Link_Nam := Expression (Ext_Arg);
else
Check_Optional_Identifier (Ext_Arg, Name_External_Name);
Ext_Nam := Expression (Ext_Arg);
Link_Nam := Empty;
end if;
else
Check_Optional_Identifier (Ext_Arg, Name_External_Name);
Check_Optional_Identifier (Link_Arg, Name_Link_Name);
Ext_Nam := Expression (Ext_Arg);
Link_Nam := Expression (Link_Arg);
end if;
-- Check expressions for external name and link name are static
if Present (Ext_Nam) then
Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
-- Verify that external name is not the name of a local entity,
-- which would hide the imported one and could lead to run-time
-- surprises. The problem can only arise for entities declared in
-- a package body (otherwise the external name is fully qualified
-- and will not conflict).
declare
Nam : Name_Id;
E : Entity_Id;
Par : Node_Id;
begin
if Prag_Id = Pragma_Import then
String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam)));
Nam := Name_Find;
E := Entity_Id (Get_Name_Table_Info (Nam));
if Nam /= Chars (Subprogram_Def)
and then Present (E)
and then not Is_Overloadable (E)
and then Is_Immediately_Visible (E)
and then not Is_Imported (E)
and then Ekind (Scope (E)) = E_Package
then
Par := Parent (E);
while Present (Par) loop
if Nkind (Par) = N_Package_Body then
Error_Msg_Sloc := Sloc (E);
Error_Msg_NE
("imported entity is hidden by & declared#",
Ext_Arg, E);
exit;
end if;
Par := Parent (Par);
end loop;
end if;
end if;
end;
end if;
if Present (Link_Nam) then
Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
end if;
-- If there is no link name, just set the external name
if No (Link_Nam) then
Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam));
-- For the Link_Name case, the given literal is preceded by an
-- asterisk, which indicates to GCC that the given name should be
-- taken literally, and in particular that no prepending of
-- underlines should occur, even in systems where this is the
-- normal default.
else
Start_String;
if VM_Target = No_VM then
Store_String_Char (Get_Char_Code ('*'));
end if;
String_Val := Strval (Expr_Value_S (Link_Nam));
Store_String_Chars (String_Val);
Link_Nam :=
Make_String_Literal (Sloc (Link_Nam),
Strval => End_String);
end if;
-- Set the interface name. If the entity is a generic instance, use
-- its alias, which is the callable entity.
if Is_Generic_Instance (Subprogram_Def) then
Set_Encoded_Interface_Name
(Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam);
else
Set_Encoded_Interface_Name
(Get_Base_Subprogram (Subprogram_Def), Link_Nam);
end if;
-- We allow duplicated export names in CIL/Java, as they are always
-- enclosed in a namespace that differentiates them, and overloaded
-- entities are supported by the VM.
if Convention (Subprogram_Def) /= Convention_CIL
and then
Convention (Subprogram_Def) /= Convention_Java
then
Check_Duplicated_Export_Name (Link_Nam);
end if;
end Process_Interface_Name;
-----------------------------------------
-- Process_Interrupt_Or_Attach_Handler --
-----------------------------------------
procedure Process_Interrupt_Or_Attach_Handler is
Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
Handler_Proc : constant Entity_Id := Entity (Arg1_X);
Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
begin
Set_Is_Interrupt_Handler (Handler_Proc);
-- If the pragma is not associated with a handler procedure within a
-- protected type, then it must be for a nonprotected procedure for
-- the AAMP target, in which case we don't associate a representation
-- item with the procedure's scope.
if Ekind (Proc_Scope) = E_Protected_Type then
if Prag_Id = Pragma_Interrupt_Handler
or else
Prag_Id = Pragma_Attach_Handler
then
Record_Rep_Item (Proc_Scope, N);
end if;
end if;
end Process_Interrupt_Or_Attach_Handler;
--------------------------------------------------
-- Process_Restrictions_Or_Restriction_Warnings --
--------------------------------------------------
-- Note: some of the simple identifier cases were handled in par-prag,
-- but it is harmless (and more straightforward) to simply handle all
-- cases here, even if it means we repeat a bit of work in some cases.
procedure Process_Restrictions_Or_Restriction_Warnings
(Warn : Boolean)
is
Arg : Node_Id;
R_Id : Restriction_Id;
Id : Name_Id;
Expr : Node_Id;
Val : Uint;
procedure Check_Unit_Name (N : Node_Id);
-- Checks unit name parameter for No_Dependence. Returns if it has
-- an appropriate form, otherwise raises pragma argument error.
---------------------
-- Check_Unit_Name --
---------------------
procedure Check_Unit_Name (N : Node_Id) is
begin
if Nkind (N) = N_Selected_Component then
Check_Unit_Name (Prefix (N));
Check_Unit_Name (Selector_Name (N));
elsif Nkind (N) = N_Identifier then
return;
else
Error_Pragma_Arg
("wrong form for unit name for No_Dependence", N);
end if;
end Check_Unit_Name;
-- Start of processing for Process_Restrictions_Or_Restriction_Warnings
begin
-- Ignore all Restrictions pragma in CodePeer mode
if CodePeer_Mode then
return;
end if;
Check_Ada_83_Warning;
Check_At_Least_N_Arguments (1);
Check_Valid_Configuration_Pragma;
Arg := Arg1;
while Present (Arg) loop
Id := Chars (Arg);
Expr := Get_Pragma_Arg (Arg);
-- Case of no restriction identifier present
if Id = No_Name then
if Nkind (Expr) /= N_Identifier then
Error_Pragma_Arg
("invalid form for restriction", Arg);
end if;
R_Id :=
Get_Restriction_Id
(Process_Restriction_Synonyms (Expr));
if R_Id not in All_Boolean_Restrictions then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("invalid restriction identifier&", Get_Pragma_Arg (Arg));
-- Check for possible misspelling
for J in Restriction_Id loop
declare
Rnm : constant String := Restriction_Id'Image (J);
begin
Name_Buffer (1 .. Rnm'Length) := Rnm;
Name_Len := Rnm'Length;
Set_Casing (All_Lower_Case);
if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then
Set_Casing
(Identifier_Casing (Current_Source_File));
Error_Msg_String (1 .. Rnm'Length) :=
Name_Buffer (1 .. Name_Len);
Error_Msg_Strlen := Rnm'Length;
Error_Msg_N -- CODEFIX
("\possible misspelling of ""~""",
Get_Pragma_Arg (Arg));
exit;
end if;
end;
end loop;
raise Pragma_Exit;
end if;
if Implementation_Restriction (R_Id) then
Check_Restriction (No_Implementation_Restrictions, Arg);
end if;
-- If this is a warning, then set the warning unless we already
-- have a real restriction active (we never want a warning to
-- override a real restriction).
if Warn then
if not Restriction_Active (R_Id) then
Set_Restriction (R_Id, N);
Restriction_Warnings (R_Id) := True;
end if;
-- If real restriction case, then set it and make sure that the
-- restriction warning flag is off, since a real restriction
-- always overrides a warning.
else
Set_Restriction (R_Id, N);
Restriction_Warnings (R_Id) := False;
end if;
-- Check for obsolescent restrictions in Ada 2005 mode
if not Warn
and then Ada_Version >= Ada_2005
and then (R_Id = No_Asynchronous_Control
or else
R_Id = No_Unchecked_Deallocation
or else
R_Id = No_Unchecked_Conversion)
then
Check_Restriction (No_Obsolescent_Features, N);
end if;
-- A very special case that must be processed here: pragma
-- Restrictions (No_Exceptions) turns off all run-time
-- checking. This is a bit dubious in terms of the formal
-- language definition, but it is what is intended by RM
-- H.4(12). Restriction_Warnings never affects generated code
-- so this is done only in the real restriction case.
-- Atomic_Synchronization is not a real check, so it is not
-- affected by this processing).
if R_Id = No_Exceptions and then not Warn then
for J in Scope_Suppress'Range loop
if J /= Atomic_Synchronization then
Scope_Suppress (J) := True;
end if;
end loop;
end if;
-- Case of No_Dependence => unit-name. Note that the parser
-- already made the necessary entry in the No_Dependence table.
elsif Id = Name_No_Dependence then
Check_Unit_Name (Expr);
-- Case of No_Specification_Of_Aspect => Identifier.
elsif Id = Name_No_Specification_Of_Aspect then
declare
A_Id : Aspect_Id;
begin
if Nkind (Expr) /= N_Identifier then
A_Id := No_Aspect;
else
A_Id := Get_Aspect_Id (Chars (Expr));
end if;
if A_Id = No_Aspect then
Error_Pragma_Arg ("invalid restriction name", Arg);
else
Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
end if;
end;
-- All other cases of restriction identifier present
else
R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg));
Analyze_And_Resolve (Expr, Any_Integer);
if R_Id not in All_Parameter_Restrictions then
Error_Pragma_Arg
("invalid restriction parameter identifier", Arg);
elsif not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("value must be static expression!", Expr);
raise Pragma_Exit;
elsif not Is_Integer_Type (Etype (Expr))
or else Expr_Value (Expr) < 0
then
Error_Pragma_Arg
("value must be non-negative integer", Arg);
end if;
-- Restriction pragma is active
Val := Expr_Value (Expr);
if not UI_Is_In_Int_Range (Val) then
Error_Pragma_Arg
("pragma ignored, value too large?", Arg);
end if;
-- Warning case. If the real restriction is active, then we
-- ignore the request, since warning never overrides a real
-- restriction. Otherwise we set the proper warning. Note that
-- this circuit sets the warning again if it is already set,
-- which is what we want, since the constant may have changed.
if Warn then
if not Restriction_Active (R_Id) then
Set_Restriction
(R_Id, N, Integer (UI_To_Int (Val)));
Restriction_Warnings (R_Id) := True;
end if;
-- Real restriction case, set restriction and make sure warning
-- flag is off since real restriction always overrides warning.
else
Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
Restriction_Warnings (R_Id) := False;
end if;
end if;
Next (Arg);
end loop;
end Process_Restrictions_Or_Restriction_Warnings;
---------------------------------
-- Process_Suppress_Unsuppress --
---------------------------------
-- Note: this procedure makes entries in the check suppress data
-- structures managed by Sem. See spec of package Sem for full
-- details on how we handle recording of check suppression.
procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
C : Check_Id;
E_Id : Node_Id;
E : Entity_Id;
In_Package_Spec : constant Boolean :=
Is_Package_Or_Generic_Package (Current_Scope)
and then not In_Package_Body (Current_Scope);
procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
-- Used to suppress a single check on the given entity
--------------------------------
-- Suppress_Unsuppress_Echeck --
--------------------------------
procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
begin
-- Check for error of trying to set atomic synchronization for
-- a non-atomic variable.
if C = Atomic_Synchronization
and then not Is_Atomic (E)
then
Error_Msg_N
("pragma & requires atomic variable",
Pragma_Identifier (Original_Node (N)));
end if;
Set_Checks_May_Be_Suppressed (E);
if In_Package_Spec then
Push_Global_Suppress_Stack_Entry
(Entity => E,
Check => C,
Suppress => Suppress_Case);
else
Push_Local_Suppress_Stack_Entry
(Entity => E,
Check => C,
Suppress => Suppress_Case);
end if;
-- If this is a first subtype, and the base type is distinct,
-- then also set the suppress flags on the base type.
if Is_First_Subtype (E)
and then Etype (E) /= E
then
Suppress_Unsuppress_Echeck (Etype (E), C);
end if;
end Suppress_Unsuppress_Echeck;
-- Start of processing for Process_Suppress_Unsuppress
begin
-- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on
-- user code: we want to generate checks for analysis purposes, as
-- set respectively by -gnatC and -gnatd.F
if (CodePeer_Mode or Alfa_Mode)
and then Comes_From_Source (N)
then
return;
end if;
-- Suppress/Unsuppress can appear as a configuration pragma, or in a
-- declarative part or a package spec (RM 11.5(5)).
if not Is_Configuration_Pragma then
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
Check_No_Identifier (Arg1);
Check_Arg_Is_Identifier (Arg1);
C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
if C = No_Check_Id then
Error_Pragma_Arg
("argument of pragma% is not valid check name", Arg1);
end if;
if not Suppress_Case
and then (C = All_Checks or else C = Overflow_Check)
then
Opt.Overflow_Checks_Unsuppressed := True;
end if;
if Arg_Count = 1 then
-- Make an entry in the local scope suppress table. This is the
-- table that directly shows the current value of the scope
-- suppress check for any check id value.
if C = All_Checks then
-- For All_Checks, we set all specific predefined checks with
-- the exception of Elaboration_Check, which is handled
-- specially because of not wanting All_Checks to have the
-- effect of deactivating static elaboration order processing.
-- Atomic_Synchronization is also not affected, since this is
-- not a real check.
for J in Scope_Suppress'Range loop
if J /= Elaboration_Check
and then J /= Atomic_Synchronization
then
Scope_Suppress (J) := Suppress_Case;
end if;
end loop;
-- If not All_Checks, and predefined check, then set appropriate
-- scope entry. Note that we will set Elaboration_Check if this
-- is explicitly specified. Atomic_Synchronization is allowed
-- only if internally generated and entity is atomic.
elsif C in Predefined_Check_Id
and then (not Comes_From_Source (N)
or else C /= Atomic_Synchronization)
then
Scope_Suppress (C) := Suppress_Case;
end if;
-- Also make an entry in the Local_Entity_Suppress table
Push_Local_Suppress_Stack_Entry
(Entity => Empty,
Check => C,
Suppress => Suppress_Case);
-- Case of two arguments present, where the check is suppressed for
-- a specified entity (given as the second argument of the pragma)
else
-- This is obsolescent in Ada 2005 mode
if Ada_Version >= Ada_2005 then
Check_Restriction (No_Obsolescent_Features, Arg2);
end if;
Check_Optional_Identifier (Arg2, Name_On);
E_Id := Get_Pragma_Arg (Arg2);
Analyze (E_Id);
if not Is_Entity_Name (E_Id) then
Error_Pragma_Arg
("second argument of pragma% must be entity name", Arg2);
end if;
E := Entity (E_Id);
if E = Any_Id then
return;
end if;
-- Enforce RM 11.5(7) which requires that for a pragma that
-- appears within a package spec, the named entity must be
-- within the package spec. We allow the package name itself
-- to be mentioned since that makes sense, although it is not
-- strictly allowed by 11.5(7).
if In_Package_Spec
and then E /= Current_Scope
and then Scope (E) /= Current_Scope
then
Error_Pragma_Arg
("entity in pragma% is not in package spec (RM 11.5(7))",
Arg2);
end if;
-- Loop through homonyms. As noted below, in the case of a package
-- spec, only homonyms within the package spec are considered.
loop
Suppress_Unsuppress_Echeck (E, C);
if Is_Generic_Instance (E)
and then Is_Subprogram (E)
and then Present (Alias (E))
then
Suppress_Unsuppress_Echeck (Alias (E), C);
end if;
-- Move to next homonym if not aspect spec case
exit when From_Aspect_Specification (N);
E := Homonym (E);
exit when No (E);
-- If we are within a package specification, the pragma only
-- applies to homonyms in the same scope.
exit when In_Package_Spec
and then Scope (E) /= Current_Scope;
end loop;
end if;
end Process_Suppress_Unsuppress;
------------------
-- Set_Exported --
------------------
procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
begin
if Is_Imported (E) then
Error_Pragma_Arg
("cannot export entity& that was previously imported", Arg);
elsif Present (Address_Clause (E)) and then not CodePeer_Mode then
Error_Pragma_Arg
("cannot export entity& that has an address clause", Arg);
end if;
Set_Is_Exported (E);
-- Generate a reference for entity explicitly, because the
-- identifier may be overloaded and name resolution will not
-- generate one.
Generate_Reference (E, Arg);
-- Deal with exporting non-library level entity
if not Is_Library_Level_Entity (E) then
-- Not allowed at all for subprograms
if Is_Subprogram (E) then
Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
-- Otherwise set public and statically allocated
else
Set_Is_Public (E);
Set_Is_Statically_Allocated (E);
-- Warn if the corresponding W flag is set and the pragma comes
-- from source. The latter may not be true e.g. on VMS where we
-- expand export pragmas for exception codes associated with
-- imported or exported exceptions. We do not want to generate
-- a warning for something that the user did not write.
if Warn_On_Export_Import
and then Comes_From_Source (Arg)
then
Error_Msg_NE
("?& has been made static as a result of Export", Arg, E);
Error_Msg_N
("\this usage is non-standard and non-portable", Arg);
end if;
end if;
end if;
if Warn_On_Export_Import and then Is_Type (E) then
Error_Msg_NE ("exporting a type has no effect?", Arg, E);
end if;
if Warn_On_Export_Import and Inside_A_Generic then
Error_Msg_NE
("all instances of& will have the same external name?", Arg, E);
end if;
end Set_Exported;
----------------------------------------------
-- Set_Extended_Import_Export_External_Name --
----------------------------------------------
procedure Set_Extended_Import_Export_External_Name
(Internal_Ent : Entity_Id;
Arg_External : Node_Id)
is
Old_Name : constant Node_Id := Interface_Name (Internal_Ent);
New_Name : Node_Id;
begin
if No (Arg_External) then
return;
end if;
Check_Arg_Is_External_Name (Arg_External);
if Nkind (Arg_External) = N_String_Literal then
if String_Length (Strval (Arg_External)) = 0 then
return;
else
New_Name := Adjust_External_Name_Case (Arg_External);
end if;
elsif Nkind (Arg_External) = N_Identifier then
New_Name := Get_Default_External_Name (Arg_External);
-- Check_Arg_Is_External_Name should let through only identifiers and
-- string literals or static string expressions (which are folded to
-- string literals).
else
raise Program_Error;
end if;
-- If we already have an external name set (by a prior normal Import
-- or Export pragma), then the external names must match
if Present (Interface_Name (Internal_Ent)) then
Check_Matching_Internal_Names : declare
S1 : constant String_Id := Strval (Old_Name);
S2 : constant String_Id := Strval (New_Name);
procedure Mismatch;
-- Called if names do not match
--------------
-- Mismatch --
--------------
procedure Mismatch is
begin
Error_Msg_Sloc := Sloc (Old_Name);
Error_Pragma_Arg
("external name does not match that given #",
Arg_External);
end Mismatch;
-- Start of processing for Check_Matching_Internal_Names
begin
if String_Length (S1) /= String_Length (S2) then
Mismatch;
else
for J in 1 .. String_Length (S1) loop
if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then
Mismatch;
end if;
end loop;
end if;
end Check_Matching_Internal_Names;
-- Otherwise set the given name
else
Set_Encoded_Interface_Name (Internal_Ent, New_Name);
Check_Duplicated_Export_Name (New_Name);
end if;
end Set_Extended_Import_Export_External_Name;
------------------
-- Set_Imported --
------------------
procedure Set_Imported (E : Entity_Id) is
begin
-- Error message if already imported or exported
if Is_Exported (E) or else Is_Imported (E) then
-- Error if being set Exported twice
if Is_Exported (E) then
Error_Msg_NE ("entity& was previously exported", N, E);
-- OK if Import/Interface case
elsif Import_Interface_Present (N) then
goto OK;
-- Error if being set Imported twice
else
Error_Msg_NE ("entity& was previously imported", N, E);
end if;
Error_Msg_Name_1 := Pname;
Error_Msg_N
("\(pragma% applies to all previous entities)", N);
Error_Msg_Sloc := Sloc (E);
Error_Msg_NE ("\import not allowed for& declared#", N, E);
-- Here if not previously imported or exported, OK to import
else
Set_Is_Imported (E);
-- If the entity is an object that is not at the library level,
-- then it is statically allocated. We do not worry about objects
-- with address clauses in this context since they are not really
-- imported in the linker sense.
if Is_Object (E)
and then not Is_Library_Level_Entity (E)
and then No (Address_Clause (E))
then
Set_Is_Statically_Allocated (E);
end if;
end if;
<<OK>> null;
end Set_Imported;
-------------------------
-- Set_Mechanism_Value --
-------------------------
-- Note: the mechanism name has not been analyzed (and cannot indeed be
-- analyzed, since it is semantic nonsense), so we get it in the exact
-- form created by the parser.
procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
Class : Node_Id;
Param : Node_Id;
Mech_Name_Id : Name_Id;
procedure Bad_Class;
-- Signal bad descriptor class name
procedure Bad_Mechanism;
-- Signal bad mechanism name
---------------
-- Bad_Class --
---------------
procedure Bad_Class is
begin
Error_Pragma_Arg ("unrecognized descriptor class name", Class);
end Bad_Class;
-------------------------
-- Bad_Mechanism_Value --
-------------------------
procedure Bad_Mechanism is
begin
Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name);
end Bad_Mechanism;
-- Start of processing for Set_Mechanism_Value
begin
if Mechanism (Ent) /= Default_Mechanism then
Error_Msg_NE
("mechanism for & has already been set", Mech_Name, Ent);
end if;
-- MECHANISM_NAME ::= value | reference | descriptor |
-- short_descriptor
if Nkind (Mech_Name) = N_Identifier then
if Chars (Mech_Name) = Name_Value then
Set_Mechanism (Ent, By_Copy);
return;
elsif Chars (Mech_Name) = Name_Reference then
Set_Mechanism (Ent, By_Reference);
return;
elsif Chars (Mech_Name) = Name_Descriptor then
Check_VMS (Mech_Name);
-- Descriptor => Short_Descriptor if pragma was given
if Short_Descriptors then
Set_Mechanism (Ent, By_Short_Descriptor);
else
Set_Mechanism (Ent, By_Descriptor);
end if;
return;
elsif Chars (Mech_Name) = Name_Short_Descriptor then
Check_VMS (Mech_Name);
Set_Mechanism (Ent, By_Short_Descriptor);
return;
elsif Chars (Mech_Name) = Name_Copy then
Error_Pragma_Arg
("bad mechanism name, Value assumed", Mech_Name);
else
Bad_Mechanism;
end if;
-- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
-- short_descriptor (CLASS_NAME)
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
-- Note: this form is parsed as an indexed component
elsif Nkind (Mech_Name) = N_Indexed_Component then
Class := First (Expressions (Mech_Name));
if Nkind (Prefix (Mech_Name)) /= N_Identifier
or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
or else Present (Next (Class))
then
Bad_Mechanism;
else
Mech_Name_Id := Chars (Prefix (Mech_Name));
-- Change Descriptor => Short_Descriptor if pragma was given
if Mech_Name_Id = Name_Descriptor
and then Short_Descriptors
then
Mech_Name_Id := Name_Short_Descriptor;
end if;
end if;
-- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
-- short_descriptor (Class => CLASS_NAME)
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
-- Note: this form is parsed as a function call
elsif Nkind (Mech_Name) = N_Function_Call then
Param := First (Parameter_Associations (Mech_Name));
if Nkind (Name (Mech_Name)) /= N_Identifier
or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
Chars (Name (Mech_Name)) = Name_Short_Descriptor)
or else Present (Next (Param))
or else No (Selector_Name (Param))
or else Chars (Selector_Name (Param)) /= Name_Class
then
Bad_Mechanism;
else
Class := Explicit_Actual_Parameter (Param);
Mech_Name_Id := Chars (Name (Mech_Name));
end if;
else
Bad_Mechanism;
end if;
-- Fall through here with Class set to descriptor class name
Check_VMS (Mech_Name);
if Nkind (Class) /= N_Identifier then
Bad_Class;
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Descriptor_UBS);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Descriptor_UBA);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Descriptor_S);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Descriptor_SB);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Descriptor_A);
elsif Mech_Name_Id = Name_Descriptor
and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Descriptor_NCA);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Short_Descriptor_UBS);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Short_Descriptor_UBA);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Short_Descriptor_S);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Short_Descriptor_SB);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Short_Descriptor_A);
elsif Mech_Name_Id = Name_Short_Descriptor
and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Short_Descriptor_NCA);
else
Bad_Class;
end if;
end Set_Mechanism_Value;
---------------------------
-- Set_Ravenscar_Profile --
---------------------------
-- The tasks to be done here are
-- Set required policies
-- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
-- pragma Locking_Policy (Ceiling_Locking)
-- Set Detect_Blocking mode
-- Set required restrictions (see System.Rident for detailed list)
-- Set the No_Dependence rules
-- No_Dependence => Ada.Asynchronous_Task_Control
-- No_Dependence => Ada.Calendar
-- No_Dependence => Ada.Execution_Time.Group_Budget
-- No_Dependence => Ada.Execution_Time.Timers
-- No_Dependence => Ada.Task_Attributes
-- No_Dependence => System.Multiprocessors.Dispatching_Domains
procedure Set_Ravenscar_Profile (N : Node_Id) is
Prefix_Entity : Entity_Id;
Selector_Entity : Entity_Id;
Prefix_Node : Node_Id;
Node : Node_Id;
begin
-- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
if Task_Dispatching_Policy /= ' '
and then Task_Dispatching_Policy /= 'F'
then
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
-- Set the FIFO_Within_Priorities policy, but always preserve
-- System_Location since we like the error message with the run time
-- name.
else
Task_Dispatching_Policy := 'F';
if Task_Dispatching_Policy_Sloc /= System_Location then
Task_Dispatching_Policy_Sloc := Loc;
end if;
end if;
-- pragma Locking_Policy (Ceiling_Locking)
if Locking_Policy /= ' '
and then Locking_Policy /= 'C'
then
Error_Msg_Sloc := Locking_Policy_Sloc;
Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
-- Set the Ceiling_Locking policy, but preserve System_Location since
-- we like the error message with the run time name.
else
Locking_Policy := 'C';
if Locking_Policy_Sloc /= System_Location then
Locking_Policy_Sloc := Loc;
end if;
end if;
-- pragma Detect_Blocking
Detect_Blocking := True;
-- Set the corresponding restrictions
Set_Profile_Restrictions
(Ravenscar, N, Warn => Treat_Restrictions_As_Warnings);
-- Set the No_Dependence restrictions
-- The following No_Dependence restrictions:
-- No_Dependence => Ada.Asynchronous_Task_Control
-- No_Dependence => Ada.Calendar
-- No_Dependence => Ada.Task_Attributes
-- are already set by previous call to Set_Profile_Restrictions.
-- Set the following restrictions which were added to Ada 2005:
-- No_Dependence => Ada.Execution_Time.Group_Budget
-- No_Dependence => Ada.Execution_Time.Timers
if Ada_Version >= Ada_2005 then
Name_Buffer (1 .. 3) := "ada";
Name_Len := 3;
Prefix_Entity := Make_Identifier (Loc, Name_Find);
Name_Buffer (1 .. 14) := "execution_time";
Name_Len := 14;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Prefix_Node :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Entity,
Selector_Name => Selector_Entity);
Name_Buffer (1 .. 13) := "group_budgets";
Name_Len := 13;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Node :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Node,
Selector_Name => Selector_Entity);
Set_Restriction_No_Dependence
(Unit => Node,
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
Name_Buffer (1 .. 6) := "timers";
Name_Len := 6;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Node :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Node,
Selector_Name => Selector_Entity);
Set_Restriction_No_Dependence
(Unit => Node,
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
end if;
-- Set the following restrictions which was added to Ada 2012 (see
-- AI-0171):
-- No_Dependence => System.Multiprocessors.Dispatching_Domains
if Ada_Version >= Ada_2012 then
Name_Buffer (1 .. 6) := "system";
Name_Len := 6;
Prefix_Entity := Make_Identifier (Loc, Name_Find);
Name_Buffer (1 .. 15) := "multiprocessors";
Name_Len := 15;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Prefix_Node :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Entity,
Selector_Name => Selector_Entity);
Name_Buffer (1 .. 19) := "dispatching_domains";
Name_Len := 19;
Selector_Entity := Make_Identifier (Loc, Name_Find);
Node :=
Make_Selected_Component
(Sloc => Loc,
Prefix => Prefix_Node,
Selector_Name => Selector_Entity);
Set_Restriction_No_Dependence
(Unit => Node,
Warn => Treat_Restrictions_As_Warnings,
Profile => Ravenscar);
end if;
end Set_Ravenscar_Profile;
-- Start of processing for Analyze_Pragma
begin
-- The following code is a defense against recursion. Not clear that
-- this can happen legitimately, but perhaps some error situations
-- can cause it, and we did see this recursion during testing.
if Analyzed (N) then
return;
else
Set_Analyzed (N, True);
end if;
-- Deal with unrecognized pragma
Pname := Pragma_Name (N);
if not Is_Pragma_Name (Pname) then
if Warn_On_Unrecognized_Pragma then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
for PN in First_Pragma_Name .. Last_Pragma_Name loop
if Is_Bad_Spelling_Of (Pname, PN) then
Error_Msg_Name_1 := PN;
Error_Msg_N -- CODEFIX
("\?possible misspelling of %!", Pragma_Identifier (N));
exit;
end if;
end loop;
end if;
return;
end if;
-- Here to start processing for recognized pragma
Prag_Id := Get_Pragma_Id (Pname);
if Present (Corresponding_Aspect (N)) then
Pname := Chars (Identifier (Corresponding_Aspect (N)));
end if;
-- Preset arguments
Arg_Count := 0;
Arg1 := Empty;
Arg2 := Empty;
Arg3 := Empty;
Arg4 := Empty;
if Present (Pragma_Argument_Associations (N)) then
Arg_Count := List_Length (Pragma_Argument_Associations (N));
Arg1 := First (Pragma_Argument_Associations (N));
if Present (Arg1) then
Arg2 := Next (Arg1);
if Present (Arg2) then
Arg3 := Next (Arg2);
if Present (Arg3) then
Arg4 := Next (Arg3);
end if;
end if;
end if;
end if;
-- An enumeration type defines the pragmas that are supported by the
-- implementation. Get_Pragma_Id (in package Prag) transforms a name
-- into the corresponding enumeration value for the following case.
case Prag_Id is
-----------------
-- Abort_Defer --
-----------------
-- pragma Abort_Defer;
when Pragma_Abort_Defer =>
GNAT_Pragma;
Check_Arg_Count (0);
-- The only required semantic processing is to check the
-- placement. This pragma must appear at the start of the
-- statement sequence of a handled sequence of statements.
if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
or else N /= First (Statements (Parent (N)))
then
Pragma_Misplaced;
end if;
------------
-- Ada_83 --
------------
-- pragma Ada_83;
-- Note: this pragma also has some specific processing in Par.Prag
-- because we want to set the Ada version mode during parsing.
when Pragma_Ada_83 =>
GNAT_Pragma;
Check_Arg_Count (0);
-- We really should check unconditionally for proper configuration
-- pragma placement, since we really don't want mixed Ada modes
-- within a single unit, and the GNAT reference manual has always
-- said this was a configuration pragma, but we did not check and
-- are hesitant to add the check now.
-- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
-- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
-- or Ada 2012 mode.
if Ada_Version >= Ada_2005 then
Check_Valid_Configuration_Pragma;
end if;
-- Now set Ada 83 mode
Ada_Version := Ada_83;
Ada_Version_Explicit := Ada_Version;
------------
-- Ada_95 --
------------
-- pragma Ada_95;
-- Note: this pragma also has some specific processing in Par.Prag
-- because we want to set the Ada 83 version mode during parsing.
when Pragma_Ada_95 =>
GNAT_Pragma;
Check_Arg_Count (0);
-- We really should check unconditionally for proper configuration
-- pragma placement, since we really don't want mixed Ada modes
-- within a single unit, and the GNAT reference manual has always
-- said this was a configuration pragma, but we did not check and
-- are hesitant to add the check now.
-- However, we really cannot tolerate mixing Ada 2005 with Ada 83
-- or Ada 95, so we must check if we are in Ada 2005 mode.
if Ada_Version >= Ada_2005 then
Check_Valid_Configuration_Pragma;
end if;
-- Now set Ada 95 mode
Ada_Version := Ada_95;
Ada_Version_Explicit := Ada_Version;
---------------------
-- Ada_05/Ada_2005 --
---------------------
-- pragma Ada_05;
-- pragma Ada_05 (LOCAL_NAME);
-- pragma Ada_2005;
-- pragma Ada_2005 (LOCAL_NAME):
-- Note: these pragmas also have some specific processing in Par.Prag
-- because we want to set the Ada 2005 version mode during parsing.
when Pragma_Ada_05 | Pragma_Ada_2005 => declare
E_Id : Node_Id;
begin
GNAT_Pragma;
if Arg_Count = 1 then
Check_Arg_Is_Local_Name (Arg1);
E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
end if;
Set_Is_Ada_2005_Only (Entity (E_Id));
else
Check_Arg_Count (0);
-- For Ada_2005 we unconditionally enforce the documented
-- configuration pragma placement, since we do not want to
-- tolerate mixed modes in a unit involving Ada 2005. That
-- would cause real difficulties for those cases where there
-- are incompatibilities between Ada 95 and Ada 2005.
Check_Valid_Configuration_Pragma;
-- Now set appropriate Ada mode
Ada_Version := Ada_2005;
Ada_Version_Explicit := Ada_2005;
end if;
end;
---------------------
-- Ada_12/Ada_2012 --
---------------------
-- pragma Ada_12;
-- pragma Ada_12 (LOCAL_NAME);
-- pragma Ada_2012;
-- pragma Ada_2012 (LOCAL_NAME):
-- Note: these pragmas also have some specific processing in Par.Prag
-- because we want to set the Ada 2012 version mode during parsing.
when Pragma_Ada_12 | Pragma_Ada_2012 => declare
E_Id : Node_Id;
begin
GNAT_Pragma;
if Arg_Count = 1 then
Check_Arg_Is_Local_Name (Arg1);
E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
end if;
Set_Is_Ada_2012_Only (Entity (E_Id));
else
Check_Arg_Count (0);
-- For Ada_2012 we unconditionally enforce the documented
-- configuration pragma placement, since we do not want to
-- tolerate mixed modes in a unit involving Ada 2012. That
-- would cause real difficulties for those cases where there
-- are incompatibilities between Ada 95 and Ada 2012. We could
-- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
Check_Valid_Configuration_Pragma;
-- Now set appropriate Ada mode
Ada_Version := Ada_2012;
Ada_Version_Explicit := Ada_2012;
end if;
end;
----------------------
-- All_Calls_Remote --
----------------------
-- pragma All_Calls_Remote [(library_package_NAME)];
when Pragma_All_Calls_Remote => All_Calls_Remote : declare
Lib_Entity : Entity_Id;
begin
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
if Nkind (N) = N_Null_Statement then
return;
end if;
Lib_Entity := Find_Lib_Unit_Name;
-- This pragma should only apply to a RCI unit (RM E.2.3(23))
if Present (Lib_Entity)
and then not Debug_Flag_U
then
if not Is_Remote_Call_Interface (Lib_Entity) then
Error_Pragma ("pragma% only apply to rci unit");
-- Set flag for entity of the library unit
else
Set_Has_All_Calls_Remote (Lib_Entity);
end if;
end if;
end All_Calls_Remote;
--------------
-- Annotate --
--------------
-- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
-- ARG ::= NAME | EXPRESSION
-- The first two arguments are by convention intended to refer to an
-- external tool and a tool-specific function. These arguments are
-- not analyzed.
when Pragma_Annotate => Annotate : declare
Arg : Node_Id;
Exp : Node_Id;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_Arg_Is_Identifier (Arg1);
Check_No_Identifiers;
Store_Note (N);
-- Second parameter is optional, it is never analyzed
if No (Arg2) then
null;
-- Here if we have a second parameter
else
-- Second parameter must be identifier
Check_Arg_Is_Identifier (Arg2);
-- Process remaining parameters if any
Arg := Next (Arg2);
while Present (Arg) loop
Exp := Get_Pragma_Arg (Arg);
Analyze (Exp);
if Is_Entity_Name (Exp) then
null;
-- For string literals, we assume Standard_String as the
-- type, unless the string contains wide or wide_wide
-- characters.
elsif Nkind (Exp) = N_String_Literal then
if Has_Wide_Wide_Character (Exp) then
Resolve (Exp, Standard_Wide_Wide_String);
elsif Has_Wide_Character (Exp) then
Resolve (Exp, Standard_Wide_String);
else
Resolve (Exp, Standard_String);
end if;
elsif Is_Overloaded (Exp) then
Error_Pragma_Arg
("ambiguous argument for pragma%", Exp);
else
Resolve (Exp);
end if;
Next (Arg);
end loop;
end if;
end Annotate;
------------
-- Assert --
------------
-- pragma Assert ([Check =>] Boolean_EXPRESSION
-- [, [Message =>] Static_String_EXPRESSION]);
when Pragma_Assert => Assert : declare
Expr : Node_Id;
Newa : List_Id;
begin
Ada_2005_Pragma;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
Check_Arg_Order ((Name_Check, Name_Message));
Check_Optional_Identifier (Arg1, Name_Check);
-- We treat pragma Assert as equivalent to:
-- pragma Check (Assertion, condition [, msg]);
-- So rewrite pragma in this manner, and analyze the result
Expr := Get_Pragma_Arg (Arg1);
Newa := New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Assertion)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Expr));
if Arg_Count > 1 then
Check_Optional_Identifier (Arg2, Name_Message);
Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
Append_To (Newa, Relocate_Node (Arg2));
end if;
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
Pragma_Argument_Associations => Newa));
Analyze (N);
end Assert;
----------------------
-- Assertion_Policy --
----------------------
-- pragma Assertion_Policy (Check | Disable |Ignore)
when Pragma_Assertion_Policy => Assertion_Policy : declare
Policy : Node_Id;
begin
Ada_2005_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
-- We treat pragma Assertion_Policy as equivalent to:
-- pragma Check_Policy (Assertion, policy)
-- So rewrite the pragma in that manner and link on to the chain
-- of Check_Policy pragmas, marking the pragma as analyzed.
Policy := Get_Pragma_Arg (Arg1);
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check_Policy,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Assertion)),
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_Identifier (Sloc (Policy), Chars (Policy))))));
Set_Analyzed (N);
Set_Next_Pragma (N, Opt.Check_Policy_List);
Opt.Check_Policy_List := N;
end Assertion_Policy;
------------------------------
-- Assume_No_Invalid_Values --
------------------------------
-- pragma Assume_No_Invalid_Values (On | Off);
when Pragma_Assume_No_Invalid_Values =>
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
Assume_No_Invalid_Values := True;
else
Assume_No_Invalid_Values := False;
end if;
---------------
-- AST_Entry --
---------------
-- pragma AST_Entry (entry_IDENTIFIER);
when Pragma_AST_Entry => AST_Entry : declare
Ent : Node_Id;
begin
GNAT_Pragma;
Check_VMS (N);
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Local_Name (Arg1);
Ent := Entity (Get_Pragma_Arg (Arg1));
-- Note: the implementation of the AST_Entry pragma could handle
-- the entry family case fine, but for now we are consistent with
-- the DEC rules, and do not allow the pragma, which of course
-- has the effect of also forbidding the attribute.
if Ekind (Ent) /= E_Entry then
Error_Pragma_Arg
("pragma% argument must be simple entry name", Arg1);
elsif Is_AST_Entry (Ent) then
Error_Pragma_Arg
("duplicate % pragma for entry", Arg1);
elsif Has_Homonym (Ent) then
Error_Pragma_Arg
("pragma% argument cannot specify overloaded entry", Arg1);
else
declare
FF : constant Entity_Id := First_Formal (Ent);
begin
if Present (FF) then
if Present (Next_Formal (FF)) then
Error_Pragma_Arg
("entry for pragma% can have only one argument",
Arg1);
elsif Parameter_Mode (FF) /= E_In_Parameter then
Error_Pragma_Arg
("entry parameter for pragma% must have mode IN",
Arg1);
end if;
end if;
end;
Set_Is_AST_Entry (Ent);
end if;
end AST_Entry;
------------------
-- Asynchronous --
------------------
-- pragma Asynchronous (LOCAL_NAME);
when Pragma_Asynchronous => Asynchronous : declare
Nm : Entity_Id;
C_Ent : Entity_Id;
L : List_Id;
S : Node_Id;
N : Node_Id;
Formal : Entity_Id;
procedure Process_Async_Pragma;
-- Common processing for procedure and access-to-procedure case
--------------------------
-- Process_Async_Pragma --
--------------------------
procedure Process_Async_Pragma is
begin
if No (L) then
Set_Is_Asynchronous (Nm);
return;
end if;
-- The formals should be of mode IN (RM E.4.1(6))
S := First (L);
while Present (S) loop
Formal := Defining_Identifier (S);
if Nkind (Formal) = N_Defining_Identifier
and then Ekind (Formal) /= E_In_Parameter
then
Error_Pragma_Arg
("pragma% procedure can only have IN parameter",
Arg1);
end if;
Next (S);
end loop;
Set_Is_Asynchronous (Nm);
end Process_Async_Pragma;
-- Start of processing for pragma Asynchronous
begin
Check_Ada_83_Warning;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
if Debug_Flag_U then
return;
end if;
C_Ent := Cunit_Entity (Current_Sem_Unit);
Analyze (Get_Pragma_Arg (Arg1));
Nm := Entity (Get_Pragma_Arg (Arg1));
if not Is_Remote_Call_Interface (C_Ent)
and then not Is_Remote_Types (C_Ent)
then
-- This pragma should only appear in an RCI or Remote Types
-- unit (RM E.4.1(4)).
Error_Pragma
("pragma% not in Remote_Call_Interface or " &
"Remote_Types unit");
end if;
if Ekind (Nm) = E_Procedure
and then Nkind (Parent (Nm)) = N_Procedure_Specification
then
if not Is_Remote_Call_Interface (Nm) then
Error_Pragma_Arg
("pragma% cannot be applied on non-remote procedure",
Arg1);
end if;
L := Parameter_Specifications (Parent (Nm));
Process_Async_Pragma;
return;
elsif Ekind (Nm) = E_Function then
Error_Pragma_Arg
("pragma% cannot be applied to function", Arg1);
elsif Is_Remote_Access_To_Subprogram_Type (Nm) then
if Is_Record_Type (Nm) then
-- A record type that is the Equivalent_Type for a remote
-- access-to-subprogram type.
N := Declaration_Node (Corresponding_Remote_Type (Nm));
else
-- A non-expanded RAS type (distribution is not enabled)
N := Declaration_Node (Nm);
end if;
if Nkind (N) = N_Full_Type_Declaration
and then Nkind (Type_Definition (N)) =
N_Access_Procedure_Definition
then
L := Parameter_Specifications (Type_Definition (N));
Process_Async_Pragma;
if Is_Asynchronous (Nm)
and then Expander_Active
and then Get_PCS_Name /= Name_No_DSA
then
RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm));
end if;
else
Error_Pragma_Arg
("pragma% cannot reference access-to-function type",
Arg1);
end if;
-- Only other possibility is Access-to-class-wide type
elsif Is_Access_Type (Nm)
and then Is_Class_Wide_Type (Designated_Type (Nm))
then
Check_First_Subtype (Arg1);
Set_Is_Asynchronous (Nm);
if Expander_Active then
RACW_Type_Is_Asynchronous (Nm);
end if;
else
Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
end if;
end Asynchronous;
------------
-- Atomic --
------------
-- pragma Atomic (LOCAL_NAME);
when Pragma_Atomic =>
Process_Atomic_Shared_Volatile;
-----------------------
-- Atomic_Components --
-----------------------
-- pragma Atomic_Components (array_LOCAL_NAME);
-- This processing is shared by Volatile_Components
when Pragma_Atomic_Components |
Pragma_Volatile_Components =>
Atomic_Components : declare
E_Id : Node_Id;
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
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);
Check_Duplicate_Pragma (E);
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N)
then
return;
end if;
D := Declaration_Node (E);
K := Nkind (D);
if (K = N_Full_Type_Declaration and then Is_Array_Type (E))
or else
((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
and then Nkind (D) = N_Object_Declaration
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition)
then
-- The flag is set on the object, or on the base type
if Nkind (D) /= N_Object_Declaration then
E := Base_Type (E);
end if;
Set_Has_Volatile_Components (E);
if Prag_Id = Pragma_Atomic_Components then
Set_Has_Atomic_Components (E);
end if;
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
end Atomic_Components;
--------------------
-- Attach_Handler --
--------------------
-- pragma Attach_Handler (handler_NAME, EXPRESSION);
when Pragma_Attach_Handler =>
Check_Ada_83_Warning;
Check_No_Identifiers;
Check_Arg_Count (2);
if No_Run_Time_Mode then
Error_Msg_CRT ("Attach_Handler pragma", N);
else
Check_Interrupt_Or_Attach_Handler;
-- The expression that designates the attribute may depend on a
-- discriminant, and is therefore a per- object expression, to
-- be expanded in the init proc. If expansion is enabled, then
-- perform semantic checks on a copy only.
if Expander_Active then
declare
Temp : constant Node_Id :=
New_Copy_Tree (Get_Pragma_Arg (Arg2));
begin
Set_Parent (Temp, N);
Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
end;
else
Analyze (Get_Pragma_Arg (Arg2));
Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
end if;
Process_Interrupt_Or_Attach_Handler;
end if;
--------------------
-- C_Pass_By_Copy --
--------------------
-- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare
Arg : Node_Id;
Val : Uint;
begin
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, "max_size");
Arg := Get_Pragma_Arg (Arg1);
Check_Arg_Is_Static_Expression (Arg, Any_Integer);
Val := Expr_Value (Arg);
if Val <= 0 then
Error_Pragma_Arg
("maximum size for pragma% must be positive", Arg1);
elsif UI_Is_In_Int_Range (Val) then
Default_C_Record_Mechanism := UI_To_Int (Val);
-- If a giant value is given, Int'Last will do well enough.
-- If sometime someone complains that a record larger than
-- two gigabytes is not copied, we will worry about it then!
else
Default_C_Record_Mechanism := Mechanism_Type'Last;
end if;
end C_Pass_By_Copy;
-----------
-- Check --
-----------
-- pragma Check ([Name =>] IDENTIFIER,
-- [Check =>] Boolean_EXPRESSION
-- [,[Message =>] String_EXPRESSION]);
when Pragma_Check => Check : declare
Expr : Node_Id;
Eloc : Source_Ptr;
Check_On : Boolean;
-- Set True if category of assertions referenced by Name enabled
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (3);
Check_Optional_Identifier (Arg1, Name_Name);
Check_Optional_Identifier (Arg2, Name_Check);
if Arg_Count = 3 then
Check_Optional_Identifier (Arg3, Name_Message);
Analyze_And_Resolve (Get_Pragma_Arg (Arg3), Standard_String);
end if;
Check_Arg_Is_Identifier (Arg1);
-- Completely ignore if disabled
if Check_Disabled (Chars (Get_Pragma_Arg (Arg1))) then
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
return;
end if;
-- Indicate if pragma is enabled. The Original_Node reference here
-- is to deal with pragma Assert rewritten as a Check pragma.
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
if Check_On then
Set_SCO_Pragma_Enabled (Loc);
end if;
-- If expansion is active and the check is not enabled then we
-- rewrite the Check as:
-- if False and then condition then
-- null;
-- end if;
-- The reason we do this rewriting during semantic analysis rather
-- than as part of normal expansion is that we cannot analyze and
-- expand the code for the boolean expression directly, or it may
-- cause insertion of actions that would escape the attempt to
-- suppress the check code.
-- Note that the Sloc for the if statement corresponds to the
-- argument condition, not the pragma itself. The reason for this
-- is that we may generate a warning if the condition is False at
-- compile time, and we do not want to delete this warning when we
-- delete the if statement.
Expr := Get_Pragma_Arg (Arg2);
if Expander_Active and then not Check_On then
Eloc := Sloc (Expr);
Rewrite (N,
Make_If_Statement (Eloc,
Condition =>
Make_And_Then (Eloc,
Left_Opnd => New_Occurrence_Of (Standard_False, Eloc),
Right_Opnd => Expr),
Then_Statements => New_List (
Make_Null_Statement (Eloc))));
Analyze (N);
-- Check is active
else
Analyze_And_Resolve (Expr, Any_Boolean);
end if;
end Check;
----------------
-- Check_Name --
----------------
-- pragma Check_Name (check_IDENTIFIER);
when Pragma_Check_Name =>
Check_No_Identifiers;
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_Arg_Is_Identifier (Arg1);
declare
Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
begin
for J in Check_Names.First .. Check_Names.Last loop
if Check_Names.Table (J) = Nam then
return;
end if;
end loop;
Check_Names.Append (Nam);
end;
------------------
-- Check_Policy --
------------------
-- pragma Check_Policy (
-- [Name =>] IDENTIFIER,
-- [Policy =>] POLICY_IDENTIFIER);
-- POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE
-- Note: this is a configuration pragma, but it is allowed to appear
-- anywhere else.
when Pragma_Check_Policy =>
GNAT_Pragma;
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Name);
Check_Optional_Identifier (Arg2, Name_Policy);
Check_Arg_Is_One_Of
(Arg2, Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
-- A Check_Policy pragma can appear either as a configuration
-- pragma, or in a declarative part or a package spec (see RM
-- 11.5(5) for rules for Suppress/Unsuppress which are also
-- followed for Check_Policy).
if not Is_Configuration_Pragma then
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
Set_Next_Pragma (N, Opt.Check_Policy_List);
Opt.Check_Policy_List := N;
---------------------
-- CIL_Constructor --
---------------------
-- pragma CIL_Constructor ([Entity =>] LOCAL_NAME);
-- Processing for this pragma is shared with Java_Constructor
-------------
-- Comment --
-------------
-- pragma Comment (static_string_EXPRESSION)
-- Processing for pragma Comment shares the circuitry for pragma
-- Ident. The only differences are that Ident enforces a limit of 31
-- characters on its argument, and also enforces limitations on
-- placement for DEC compatibility. Pragma Comment shares neither of
-- these restrictions.
-------------------
-- Common_Object --
-------------------
-- pragma Common_Object (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Size =>] EXTERNAL_SYMBOL]);
-- Processing for this pragma is shared with Psect_Object
------------------------
-- Compile_Time_Error --
------------------------
-- pragma Compile_Time_Error
-- (boolean_EXPRESSION, static_string_EXPRESSION);
when Pragma_Compile_Time_Error =>
GNAT_Pragma;
Process_Compile_Time_Warning_Or_Error;
--------------------------
-- Compile_Time_Warning --
--------------------------
-- pragma Compile_Time_Warning
-- (boolean_EXPRESSION, static_string_EXPRESSION);
when Pragma_Compile_Time_Warning =>
GNAT_Pragma;
Process_Compile_Time_Warning_Or_Error;
-------------------
-- Compiler_Unit --
-------------------
when Pragma_Compiler_Unit =>
GNAT_Pragma;
Check_Arg_Count (0);
Set_Is_Compiler_Unit (Get_Source_Unit (N));
-----------------------------
-- Complete_Representation --
-----------------------------
-- pragma Complete_Representation;
when Pragma_Complete_Representation =>
GNAT_Pragma;
Check_Arg_Count (0);
if Nkind (Parent (N)) /= N_Record_Representation_Clause then
Error_Pragma
("pragma & must appear within record representation clause");
end if;
----------------------------
-- Complex_Representation --
----------------------------
-- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
when Pragma_Complex_Representation => Complex_Representation : declare
E_Id : Entity_Id;
E : Entity_Id;
Ent : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
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);
if not Is_Record_Type (E) then
Error_Pragma_Arg
("argument for pragma% must be record type", Arg1);
end if;
Ent := First_Entity (E);
if No (Ent)
or else No (Next_Entity (Ent))
or else Present (Next_Entity (Next_Entity (Ent)))
or else not Is_Floating_Point_Type (Etype (Ent))
or else Etype (Ent) /= Etype (Next_Entity (Ent))
then
Error_Pragma_Arg
("record for pragma% must have two fields of the same "
& "floating-point type", Arg1);
else
Set_Has_Complex_Representation (Base_Type (E));
-- We need to treat the type has having a non-standard
-- representation, for back-end purposes, even though in
-- general a complex will have the default representation
-- of a record with two real components.
Set_Has_Non_Standard_Rep (Base_Type (E));
end if;
end Complex_Representation;
-------------------------
-- Component_Alignment --
-------------------------
-- pragma Component_Alignment (
-- [Form =>] ALIGNMENT_CHOICE
-- [, [Name =>] type_LOCAL_NAME]);
--
-- ALIGNMENT_CHOICE ::=
-- Component_Size
-- | Component_Size_4
-- | Storage_Unit
-- | Default
when Pragma_Component_Alignment => Component_AlignmentP : declare
Args : Args_List (1 .. 2);
Names : constant Name_List (1 .. 2) := (
Name_Form,
Name_Name);
Form : Node_Id renames Args (1);
Name : Node_Id renames Args (2);
Atype : Component_Alignment_Kind;
Typ : Entity_Id;
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
if No (Form) then
Error_Pragma ("missing Form argument for pragma%");
end if;
Check_Arg_Is_Identifier (Form);
-- Get proper alignment, note that Default = Component_Size on all
-- machines we have so far, and we want to set this value rather
-- than the default value to indicate that it has been explicitly
-- set (and thus will not get overridden by the default component
-- alignment for the current scope)
if Chars (Form) = Name_Component_Size then
Atype := Calign_Component_Size;
elsif Chars (Form) = Name_Component_Size_4 then
Atype := Calign_Component_Size_4;
elsif Chars (Form) = Name_Default then
Atype := Calign_Component_Size;
elsif Chars (Form) = Name_Storage_Unit then
Atype := Calign_Storage_Unit;
else
Error_Pragma_Arg
("invalid Form parameter for pragma%", Form);
end if;
-- Case with no name, supplied, affects scope table entry
if No (Name) then
Scope_Stack.Table
(Scope_Stack.Last).Component_Alignment_Default := Atype;
-- Case of name supplied
else
Check_Arg_Is_Local_Name (Name);
Find_Type (Name);
Typ := Entity (Name);
if Typ = Any_Type
or else Rep_Item_Too_Early (Typ, N)
then
return;
else
Typ := Underlying_Type (Typ);
end if;
if not Is_Record_Type (Typ)
and then not Is_Array_Type (Typ)
then
Error_Pragma_Arg
("Name parameter of pragma% must identify record or " &
"array type", Name);
end if;
-- An explicit Component_Alignment pragma overrides an
-- implicit pragma Pack, but not an explicit one.
if not Has_Pragma_Pack (Base_Type (Typ)) then
Set_Is_Packed (Base_Type (Typ), False);
Set_Component_Alignment (Base_Type (Typ), Atype);
end if;
end if;
end Component_AlignmentP;
----------------
-- Controlled --
----------------
-- pragma Controlled (first_subtype_LOCAL_NAME);
when Pragma_Controlled => Controlled : declare
Arg : Node_Id;
begin
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Arg := Get_Pragma_Arg (Arg1);
if not Is_Entity_Name (Arg)
or else not Is_Access_Type (Entity (Arg))
then
Error_Pragma_Arg ("pragma% requires access type", Arg1);
else
Set_Has_Pragma_Controlled (Base_Type (Entity (Arg)));
end if;
end Controlled;
----------------
-- Convention --
----------------
-- pragma Convention ([Convention =>] convention_IDENTIFIER,
-- [Entity =>] LOCAL_NAME);
when Pragma_Convention => Convention : declare
C : Convention_Id;
E : Entity_Id;
pragma Warnings (Off, C);
pragma Warnings (Off, E);
begin
Check_Arg_Order ((Name_Convention, Name_Entity));
Check_Ada_83_Warning;
Check_Arg_Count (2);
Process_Convention (C, E);
end Convention;
---------------------------
-- Convention_Identifier --
---------------------------
-- pragma Convention_Identifier ([Name =>] IDENTIFIER,
-- [Convention =>] convention_IDENTIFIER);
when Pragma_Convention_Identifier => Convention_Identifier : declare
Idnam : Name_Id;
Cname : Name_Id;
begin
GNAT_Pragma;
Check_Arg_Order ((Name_Name, Name_Convention));
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Name);
Check_Optional_Identifier (Arg2, Name_Convention);
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Identifier (Arg2);
Idnam := Chars (Get_Pragma_Arg (Arg1));
Cname := Chars (Get_Pragma_Arg (Arg2));
if Is_Convention_Name (Cname) then
Record_Convention_Identifier
(Idnam, Get_Convention_Id (Cname));
else
Error_Pragma_Arg
("second arg for % pragma must be convention", Arg2);
end if;
end Convention_Identifier;
---------------
-- CPP_Class --
---------------
-- pragma CPP_Class ([Entity =>] local_NAME)
when Pragma_CPP_Class => CPP_Class : declare
Arg : Node_Id;
Typ : Entity_Id;
begin
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
" by pragma import?", N);
end if;
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
return;
end if;
if not Is_Entity_Name (Arg)
or else not Is_Type (Entity (Arg))
then
Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
end if;
Typ := Entity (Arg);
if not Is_Tagged_Type (Typ) then
Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
end if;
-- Types treated as CPP classes must be declared limited (note:
-- this used to be a warning but there is no real benefit to it
-- since we did effectively intend to treat the type as limited
-- anyway).
if not Is_Limited_Type (Typ) then
Error_Msg_N
("imported 'C'P'P type must be limited",
Get_Pragma_Arg (Arg1));
end if;
Set_Is_CPP_Class (Typ);
Set_Convention (Typ, Convention_CPP);
-- Imported CPP types must not have discriminants (because C++
-- classes do not have discriminants).
if Has_Discriminants (Typ) then
Error_Msg_N
("imported 'C'P'P type cannot have discriminants",
First (Discriminant_Specifications
(Declaration_Node (Typ))));
end if;
-- Components of imported CPP types must not have default
-- expressions because the constructor (if any) is in the
-- C++ side.
if Is_Incomplete_Or_Private_Type (Typ)
and then No (Underlying_Type (Typ))
then
-- It should be an error to apply pragma CPP to a private
-- type if the underlying type is not visible (as it is
-- for any representation item). For now, for backward
-- compatibility we do nothing but we cannot check components
-- because they are not available at this stage. All this code
-- will be removed when we cleanup this obsolete GNAT pragma???
null;
else
declare
Tdef : constant Node_Id :=
Type_Definition (Declaration_Node (Typ));
Clist : Node_Id;
Comp : Node_Id;
begin
if Nkind (Tdef) = N_Record_Definition then
Clist := Component_List (Tdef);
else
pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
Clist := Component_List (Record_Extension_Part (Tdef));
end if;
if Present (Clist) then
Comp := First (Component_Items (Clist));
while Present (Comp) loop
if Present (Expression (Comp)) then
Error_Msg_N
("component of imported 'C'P'P type cannot have" &
" default expression", Expression (Comp));
end if;
Next (Comp);
end loop;
end if;
end;
end if;
end CPP_Class;
---------------------
-- CPP_Constructor --
---------------------
-- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
-- [, [External_Name =>] static_string_EXPRESSION ]
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_CPP_Constructor => CPP_Constructor : declare
Elmt : Elmt_Id;
Id : Entity_Id;
Def_Id : Entity_Id;
Tag_Typ : Entity_Id;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (3);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
Id := Get_Pragma_Arg (Arg1);
Find_Program_Unit_Name (Id);
-- If we did not find the name, we are done
if Etype (Id) = Any_Type then
return;
end if;
Def_Id := Entity (Id);
-- Check if already defined as constructor
if Is_Constructor (Def_Id) then
Error_Msg_N
("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
return;
end if;
if Ekind (Def_Id) = E_Function
and then (Is_CPP_Class (Etype (Def_Id))
or else (Is_Class_Wide_Type (Etype (Def_Id))
and then
Is_CPP_Class (Root_Type (Etype (Def_Id)))))
then
if Arg_Count >= 2 then
Set_Imported (Def_Id);
Set_Is_Public (Def_Id);
Process_Interface_Name (Def_Id, Arg2, Arg3);
end if;
Set_Has_Completion (Def_Id);
Set_Is_Constructor (Def_Id);
-- Imported C++ constructors are not dispatching primitives
-- because in C++ they don't have a dispatch table slot.
-- However, in Ada the constructor has the profile of a
-- function that returns a tagged type and therefore it has
-- been treated as a primitive operation during semantic
-- analysis. We now remove it from the list of primitive
-- operations of the type.
if Is_Tagged_Type (Etype (Def_Id))
and then not Is_Class_Wide_Type (Etype (Def_Id))
then
pragma Assert (Is_Dispatching_Operation (Def_Id));
Tag_Typ := Etype (Def_Id);
Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Elmt) and then Node (Elmt) /= Def_Id loop
Next_Elmt (Elmt);
end loop;
Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
Set_Is_Dispatching_Operation (Def_Id, False);
end if;
-- For backward compatibility, if the constructor returns a
-- class wide type, and we internally change the return type to
-- the corresponding root type.
if Is_Class_Wide_Type (Etype (Def_Id)) then
Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
end if;
else
Error_Pragma_Arg
("pragma% requires function returning a 'C'P'P_Class type",
Arg1);
end if;
end CPP_Constructor;
-----------------
-- CPP_Virtual --
-----------------
when Pragma_CPP_Virtual => CPP_Virtual : declare
begin
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
"no effect?", N);
end if;
end CPP_Virtual;
----------------
-- CPP_Vtable --
----------------
when Pragma_CPP_Vtable => CPP_Vtable : declare
begin
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
"no effect?", N);
end if;
end CPP_Vtable;
---------
-- CPU --
---------
-- pragma CPU (EXPRESSION);
when Pragma_CPU => CPU : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Ada_2012_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
-- Subprogram case
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Any_Integer);
-- Must be static
if not Is_Static_Expression (Arg) then
Flag_Non_Static_Expr
("main subprogram affinity is not static!", Arg);
raise Pragma_Exit;
-- If constraint error, then we already signalled an error
elsif Raises_Constraint_Error (Arg) then
null;
-- Otherwise check in range
else
declare
CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
-- This is the entity System.Multiprocessors.CPU_Range;
Val : constant Uint := Expr_Value (Arg);
begin
if Val < Expr_Value (Type_Low_Bound (CPU_Id))
or else
Val > Expr_Value (Type_High_Bound (CPU_Id))
then
Error_Pragma_Arg
("main subprogram CPU is out of range", Arg1);
end if;
end;
end if;
Set_Main_CPU
(Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
-- Task case
elsif Nkind (P) = N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
if Has_Pragma_CPU (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_CPU (P, True);
if Nkind (P) = N_Task_Definition then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end if;
end CPU;
-----------
-- Debug --
-----------
-- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
when Pragma_Debug => Debug : declare
Cond : Node_Id;
Call : Node_Id;
begin
GNAT_Pragma;
-- Skip analysis if disabled
if Debug_Pragmas_Disabled then
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
return;
end if;
Cond :=
New_Occurrence_Of
(Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
Loc);
if Debug_Pragmas_Enabled then
Set_SCO_Pragma_Enabled (Loc);
end if;
if Arg_Count = 2 then
Cond :=
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (Cond),
Right_Opnd => Get_Pragma_Arg (Arg1));
Call := Get_Pragma_Arg (Arg2);
else
Call := Get_Pragma_Arg (Arg1);
end if;
if Nkind_In (Call,
N_Indexed_Component,
N_Function_Call,
N_Identifier,
N_Selected_Component)
then
-- If this pragma Debug comes from source, its argument was
-- parsed as a name form (which is syntactically identical).
-- Change it to a procedure call statement now.
Change_Name_To_Procedure_Call_Statement (Call);
elsif Nkind (Call) = N_Procedure_Call_Statement then
-- Already in the form of a procedure call statement: nothing
-- to do (could happen in case of an internally generated
-- pragma Debug).
null;
else
-- All other cases: diagnose error
Error_Msg
("argument of pragma ""Debug"" is not procedure call",
Sloc (Call));
return;
end if;
-- Rewrite into a conditional with an appropriate condition. We
-- wrap the procedure call in a block so that overhead from e.g.
-- use of the secondary stack does not generate execution overhead
-- for suppressed conditions.
Rewrite (N, Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Relocate_Node (Call)))))));
Analyze (N);
end Debug;
------------------
-- Debug_Policy --
------------------
-- pragma Debug_Policy (Check | Ignore)
when Pragma_Debug_Policy =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
Debug_Pragmas_Enabled :=
Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
Debug_Pragmas_Disabled :=
Chars (Get_Pragma_Arg (Arg1)) = Name_Disable;
---------------------
-- Detect_Blocking --
---------------------
-- pragma Detect_Blocking;
when Pragma_Detect_Blocking =>
Ada_2005_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Detect_Blocking := True;
--------------------------
-- Default_Storage_Pool --
--------------------------
-- pragma Default_Storage_Pool (storage_pool_NAME | null);
when Pragma_Default_Storage_Pool =>
Ada_2012_Pragma;
Check_Arg_Count (1);
-- Default_Storage_Pool can appear as a configuration pragma, or
-- in a declarative part or a package spec.
if not Is_Configuration_Pragma then
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
-- Case of Default_Storage_Pool (null);
if Nkind (Expression (Arg1)) = N_Null then
Analyze (Expression (Arg1));
-- This is an odd case, this is not really an expression, so
-- we don't have a type for it. So just set the type to Empty.
Set_Etype (Expression (Arg1), Empty);
-- Case of Default_Storage_Pool (storage_pool_NAME);
else
-- If it's a configuration pragma, then the only allowed
-- argument is "null".
if Is_Configuration_Pragma then
Error_Pragma_Arg ("NULL expected", Arg1);
end if;
-- The expected type for a non-"null" argument is
-- Root_Storage_Pool'Class.
Analyze_And_Resolve
(Get_Pragma_Arg (Arg1),
Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
end if;
-- Finally, record the pool name (or null). Freeze.Freeze_Entity
-- for an access type will use this information to set the
-- appropriate attributes of the access type.
Default_Pool := Expression (Arg1);
---------------
-- Dimension --
---------------
when Pragma_Dimension =>
GNAT_Pragma;
Check_Arg_Count (4);
Check_No_Identifiers;
Check_Arg_Is_Local_Name (Arg1);
if not Is_Type (Arg1) then
Error_Pragma ("first argument for pragma% must be subtype");
end if;
Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
------------------------------------
-- Disable_Atomic_Synchronization --
------------------------------------
-- pragma Disable_Atomic_Synchronization [(Entity)];
when Pragma_Disable_Atomic_Synchronization =>
Process_Disable_Enable_Atomic_Sync (Name_Suppress);
-------------------
-- Discard_Names --
-------------------
-- pragma Discard_Names [([On =>] LOCAL_NAME)];
when Pragma_Discard_Names => Discard_Names : declare
E : Entity_Id;
E_Id : Entity_Id;
begin
Check_Ada_83_Warning;
-- Deal with configuration pragma case
if Arg_Count = 0 and then Is_Configuration_Pragma then
Global_Discard_Names := True;
return;
-- Otherwise, check correct appropriate context
else
Check_Is_In_Decl_Part_Or_Package_Spec;
if Arg_Count = 0 then
-- If there is no parameter, then from now on this pragma
-- applies to any enumeration, exception or tagged type
-- defined in the current declarative part, and recursively
-- to any nested scope.
Set_Discard_Names (Current_Scope);
return;
else
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_On);
Check_Arg_Is_Local_Name (Arg1);
E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
else
E := Entity (E_Id);
end if;
if (Is_First_Subtype (E)
and then
(Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
or else Ekind (E) = E_Exception
then
Set_Discard_Names (E);
else
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
end if;
end if;
end if;
end Discard_Names;
------------------------
-- Dispatching_Domain --
------------------------
-- pragma Dispatching_Domain (EXPRESSION);
when Pragma_Dispatching_Domain => Dispatching_Domain : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Ada_2012_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
-- This pragma is born obsolete, but not the aspect
if not From_Aspect_Specification (N) then
Check_Restriction
(No_Obsolescent_Features, Pragma_Identifier (N));
end if;
if Nkind (P) = N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
if Has_Pragma_Dispatching_Domain (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_Dispatching_Domain (P, True);
if Nkind (P) = N_Task_Definition then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end if;
end Dispatching_Domain;
---------------
-- Elaborate --
---------------
-- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
when Pragma_Elaborate => Elaborate : declare
Arg : Node_Id;
Citem : Node_Id;
begin
-- Pragma must be in context items list of a compilation unit
if not Is_In_Context_Clause then
Pragma_Misplaced;
end if;
-- Must be at least one argument
if Arg_Count = 0 then
Error_Pragma ("pragma% requires at least one argument");
end if;
-- In Ada 83 mode, there can be no items following it in the
-- context list except other pragmas and implicit with clauses
-- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
-- placement rule does not apply.
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Citem := Next (N);
while Present (Citem) loop
if Nkind (Citem) = N_Pragma
or else (Nkind (Citem) = N_With_Clause
and then Implicit_With (Citem))
then
null;
else
Error_Pragma
("(Ada 83) pragma% must be at end of context clause");
end if;
Next (Citem);
end loop;
end if;
-- Finally, the arguments must all be units mentioned in a with
-- clause in the same context clause. Note we already checked (in
-- Par.Prag) that the arguments are all identifiers or selected
-- components.
Arg := Arg1;
Outer : while Present (Arg) loop
Citem := First (List_Containing (N));
Inner : while Citem /= N loop
if Nkind (Citem) = N_With_Clause
and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
then
Set_Elaborate_Present (Citem, True);
Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
Generate_Reference (Entity (Name (Citem)), Citem);
-- With the pragma present, elaboration calls on
-- subprograms from the named unit need no further
-- checks, as long as the pragma appears in the current
-- compilation unit. If the pragma appears in some unit
-- in the context, there might still be a need for an
-- Elaborate_All_Desirable from the current compilation
-- to the named unit, so we keep the check enabled.
if In_Extended_Main_Source_Unit (N) then
Set_Suppress_Elaboration_Warnings
(Entity (Name (Citem)));
end if;
exit Inner;
end if;
Next (Citem);
end loop Inner;
if Citem = N then
Error_Pragma_Arg
("argument of pragma% is not with'ed unit", Arg);
end if;
Next (Arg);
end loop Outer;
-- Give a warning if operating in static mode with -gnatwl
-- (elaboration warnings enabled) switch set.
if Elab_Warnings and not Dynamic_Elaboration_Checks then
Error_Msg_N
("?use of pragma Elaborate may not be safe", N);
Error_Msg_N
("?use pragma Elaborate_All instead if possible", N);
end if;
end Elaborate;
-------------------
-- Elaborate_All --
-------------------
-- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
when Pragma_Elaborate_All => Elaborate_All : declare
Arg : Node_Id;
Citem : Node_Id;
begin
Check_Ada_83_Warning;
-- Pragma must be in context items list of a compilation unit
if not Is_In_Context_Clause then
Pragma_Misplaced;
end if;
-- Must be at least one argument
if Arg_Count = 0 then
Error_Pragma ("pragma% requires at least one argument");
end if;
-- Note: unlike pragma Elaborate, pragma Elaborate_All does not
-- have to appear at the end of the context clause, but may
-- appear mixed in with other items, even in Ada 83 mode.
-- Final check: the arguments must all be units mentioned in
-- a with clause in the same context clause. Note that we
-- already checked (in Par.Prag) that all the arguments are
-- either identifiers or selected components.
Arg := Arg1;
Outr : while Present (Arg) loop
Citem := First (List_Containing (N));
Innr : while Citem /= N loop
if Nkind (Citem) = N_With_Clause
and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
then
Set_Elaborate_All_Present (Citem, True);
Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
-- Suppress warnings and elaboration checks on the named
-- unit if the pragma is in the current compilation, as
-- for pragma Elaborate.
if In_Extended_Main_Source_Unit (N) then
Set_Suppress_Elaboration_Warnings
(Entity (Name (Citem)));
end if;
exit Innr;
end if;
Next (Citem);
end loop Innr;
if Citem = N then
Set_Error_Posted (N);
Error_Pragma_Arg
("argument of pragma% is not with'ed unit", Arg);
end if;
Next (Arg);
end loop Outr;
end Elaborate_All;
--------------------
-- Elaborate_Body --
--------------------
-- pragma Elaborate_Body [( library_unit_NAME )];
when Pragma_Elaborate_Body => Elaborate_Body : declare
Cunit_Node : Node_Id;
Cunit_Ent : Entity_Id;
begin
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
if Nkind (N) = N_Null_Statement then
return;
end if;
Cunit_Node := Cunit (Current_Sem_Unit);
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
if Nkind_In (Unit (Cunit_Node), N_Package_Body,
N_Subprogram_Body)
then
Error_Pragma ("pragma% must refer to a spec, not a body");
else
Set_Body_Required (Cunit_Node, True);
Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
-- If we are in dynamic elaboration mode, then we suppress
-- elaboration warnings for the unit, since it is definitely
-- fine NOT to do dynamic checks at the first level (and such
-- checks will be suppressed because no elaboration boolean
-- is created for Elaborate_Body packages).
-- But in the static model of elaboration, Elaborate_Body is
-- definitely NOT good enough to ensure elaboration safety on
-- its own, since the body may WITH other units that are not
-- safe from an elaboration point of view, so a client must
-- still do an Elaborate_All on such units.
-- Debug flag -gnatdD restores the old behavior of 3.13, where
-- Elaborate_Body always suppressed elab warnings.
if Dynamic_Elaboration_Checks or Debug_Flag_DD then
Set_Suppress_Elaboration_Warnings (Cunit_Ent);
end if;
end if;
end Elaborate_Body;
------------------------
-- Elaboration_Checks --
------------------------
-- pragma Elaboration_Checks (Static | Dynamic);
when Pragma_Elaboration_Checks =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Static, Name_Dynamic);
Dynamic_Elaboration_Checks :=
(Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic);
---------------
-- Eliminate --
---------------
-- pragma Eliminate (
-- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
-- [,[Entity =>] IDENTIFIER |
-- SELECTED_COMPONENT |
-- STRING_LITERAL]
-- [, OVERLOADING_RESOLUTION]);
-- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
-- SOURCE_LOCATION
-- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
-- FUNCTION_PROFILE
-- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
-- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
-- Result_Type => result_SUBTYPE_NAME]
-- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
-- SUBTYPE_NAME ::= STRING_LITERAL
-- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
-- SOURCE_TRACE ::= STRING_LITERAL
when Pragma_Eliminate => Eliminate : declare
Args : Args_List (1 .. 5);
Names : constant Name_List (1 .. 5) := (
Name_Unit_Name,
Name_Entity,
Name_Parameter_Types,
Name_Result_Type,
Name_Source_Location);
Unit_Name : Node_Id renames Args (1);
Entity : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Result_Type : Node_Id renames Args (4);
Source_Location : Node_Id renames Args (5);
begin
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Gather_Associations (Names, Args);
if No (Unit_Name) then
Error_Pragma ("missing Unit_Name argument for pragma%");
end if;
if No (Entity)
and then (Present (Parameter_Types)
or else
Present (Result_Type)
or else
Present (Source_Location))
then
Error_Pragma ("missing Entity argument for pragma%");
end if;
if (Present (Parameter_Types)
or else
Present (Result_Type))
and then
Present (Source_Location)
then
Error_Pragma
("parameter profile and source location cannot " &
"be used together in pragma%");
end if;
Process_Eliminate_Pragma
(N,
Unit_Name,
Entity,
Parameter_Types,
Result_Type,
Source_Location);
end Eliminate;
-----------------------------------
-- Enable_Atomic_Synchronization --
-----------------------------------
-- pragma Enable_Atomic_Synchronization [(Entity)];
when Pragma_Enable_Atomic_Synchronization =>
Process_Disable_Enable_Atomic_Sync (Name_Unsuppress);
------------
-- Export --
------------
-- pragma Export (
-- [ Convention =>] convention_IDENTIFIER,
-- [ Entity =>] local_NAME
-- [, [External_Name =>] static_string_EXPRESSION ]
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_Export => Export : declare
C : Convention_Id;
Def_Id : Entity_Id;
pragma Warnings (Off, C);
begin
Check_Ada_83_Warning;
Check_Arg_Order
((Name_Convention,
Name_Entity,
Name_External_Name,
Name_Link_Name));
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Process_Convention (C, Def_Id);
if Ekind (Def_Id) /= E_Constant then
Note_Possible_Modification
(Get_Pragma_Arg (Arg2), Sure => False);
end if;
Process_Interface_Name (Def_Id, Arg3, Arg4);
Set_Exported (Def_Id, Arg2);
-- If the entity is a deferred constant, propagate the information
-- to the full view, because gigi elaborates the full view only.
if Ekind (Def_Id) = E_Constant
and then Present (Full_View (Def_Id))
then
declare
Id2 : constant Entity_Id := Full_View (Def_Id);
begin
Set_Is_Exported (Id2, Is_Exported (Def_Id));
Set_First_Rep_Item (Id2, First_Rep_Item (Def_Id));
Set_Interface_Name (Id2, Einfo.Interface_Name (Def_Id));
end;
end if;
end Export;
----------------------
-- Export_Exception --
----------------------
-- pragma Export_Exception (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Form =>] Ada | VMS]
-- [, [Code =>] static_integer_EXPRESSION]);
when Pragma_Export_Exception => Export_Exception : declare
Args : Args_List (1 .. 4);
Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Form,
Name_Code);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Form : Node_Id renames Args (3);
Code : Node_Id renames Args (4);
begin
GNAT_Pragma;
if Inside_A_Generic then
Error_Pragma ("pragma% cannot be used for generic entities");
end if;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Exception_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Form => Form,
Arg_Code => Code);
if not Is_VMS_Exception (Entity (Internal)) then
Set_Exported (Entity (Internal), Internal);
end if;
end Export_Exception;
---------------------
-- Export_Function --
---------------------
-- pragma Export_Function (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Result_Type =>] TYPE_DESIGNATOR]
-- [, [Mechanism =>] MECHANISM]
-- [, [Result_Mechanism =>] MECHANISM_NAME]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
-- PARAMETER_TYPES ::=
-- null
-- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
-- TYPE_DESIGNATOR ::=
-- subtype_NAME
-- | subtype_Name ' Access
-- MECHANISM ::=
-- MECHANISM_NAME
-- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
-- MECHANISM_ASSOCIATION ::=
-- [formal_parameter_NAME =>] MECHANISM_NAME
-- MECHANISM_NAME ::=
-- Value
-- | Reference
-- | Descriptor [([Class =>] CLASS_NAME)]
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Function => Export_Function : declare
Args : Args_List (1 .. 6);
Names : constant Name_List (1 .. 6) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
Name_Result_Type,
Name_Mechanism,
Name_Result_Mechanism);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Result_Type : Node_Id renames Args (4);
Mechanism : Node_Id renames Args (5);
Result_Mechanism : Node_Id renames Args (6);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Subprogram_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
Arg_Result_Type => Result_Type,
Arg_Mechanism => Mechanism,
Arg_Result_Mechanism => Result_Mechanism);
end Export_Function;
-------------------
-- Export_Object --
-------------------
-- pragma Export_Object (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Size =>] EXTERNAL_SYMBOL]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
-- PARAMETER_TYPES ::=
-- null
-- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
-- TYPE_DESIGNATOR ::=
-- subtype_NAME
-- | subtype_Name ' Access
-- MECHANISM ::=
-- MECHANISM_NAME
-- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
-- MECHANISM_ASSOCIATION ::=
-- [formal_parameter_NAME =>] MECHANISM_NAME
-- MECHANISM_NAME ::=
-- Value
-- | Reference
-- | Descriptor [([Class =>] CLASS_NAME)]
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Object => Export_Object : declare
Args : Args_List (1 .. 3);
Names : constant Name_List (1 .. 3) := (
Name_Internal,
Name_External,
Name_Size);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Size : Node_Id renames Args (3);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Object_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Size => Size);
end Export_Object;
----------------------
-- Export_Procedure --
----------------------
-- pragma Export_Procedure (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Mechanism =>] MECHANISM]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
-- PARAMETER_TYPES ::=
-- null
-- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
-- TYPE_DESIGNATOR ::=
-- subtype_NAME
-- | subtype_Name ' Access
-- MECHANISM ::=
-- MECHANISM_NAME
-- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
-- MECHANISM_ASSOCIATION ::=
-- [formal_parameter_NAME =>] MECHANISM_NAME
-- MECHANISM_NAME ::=
-- Value
-- | Reference
-- | Descriptor [([Class =>] CLASS_NAME)]
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Procedure => Export_Procedure : declare
Args : Args_List (1 .. 4);
Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
Name_Mechanism);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Mechanism : Node_Id renames Args (4);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Subprogram_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
Arg_Mechanism => Mechanism);
end Export_Procedure;
------------------
-- Export_Value --
------------------
-- pragma Export_Value (
-- [Value =>] static_integer_EXPRESSION,
-- [Link_Name =>] static_string_EXPRESSION);
when Pragma_Export_Value =>
GNAT_Pragma;
Check_Arg_Order ((Name_Value, Name_Link_Name));
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Value);
Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
Check_Optional_Identifier (Arg2, Name_Link_Name);
Check_Arg_Is_Static_Expression (Arg2, Standard_String);
-----------------------------
-- Export_Valued_Procedure --
-----------------------------
-- pragma Export_Valued_Procedure (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL,]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Mechanism =>] MECHANISM]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
-- PARAMETER_TYPES ::=
-- null
-- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
-- TYPE_DESIGNATOR ::=
-- subtype_NAME
-- | subtype_Name ' Access
-- MECHANISM ::=
-- MECHANISM_NAME
-- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
-- MECHANISM_ASSOCIATION ::=
-- [formal_parameter_NAME =>] MECHANISM_NAME
-- MECHANISM_NAME ::=
-- Value
-- | Reference
-- | Descriptor [([Class =>] CLASS_NAME)]
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Export_Valued_Procedure =>
Export_Valued_Procedure : declare
Args : Args_List (1 .. 4);
Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
Name_Mechanism);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Mechanism : Node_Id renames Args (4);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Subprogram_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
Arg_Mechanism => Mechanism);
end Export_Valued_Procedure;
-------------------
-- Extend_System --
-------------------
-- pragma Extend_System ([Name =>] Identifier);
when Pragma_Extend_System => Extend_System : declare
begin
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Name);
Check_Arg_Is_Identifier (Arg1);
Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
if Name_Len > 4
and then Name_Buffer (1 .. 4) = "aux_"
then
if Present (System_Extend_Pragma_Arg) then
if Chars (Get_Pragma_Arg (Arg1)) =
Chars (Expression (System_Extend_Pragma_Arg))
then
null;
else
Error_Msg_Sloc := Sloc (System_Extend_Pragma_Arg);
Error_Pragma ("pragma% conflicts with that #");
end if;
else
System_Extend_Pragma_Arg := Arg1;
if not GNAT_Mode then
System_Extend_Unit := Arg1;
end if;
end if;
else
Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
end if;
end Extend_System;
------------------------
-- Extensions_Allowed --
------------------------
-- pragma Extensions_Allowed (ON | OFF);
when Pragma_Extensions_Allowed =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
Extensions_Allowed := True;
Ada_Version := Ada_Version_Type'Last;
else
Extensions_Allowed := False;
Ada_Version := Ada_Version_Explicit;
end if;
--------------
-- External --
--------------
-- pragma External (
-- [ Convention =>] convention_IDENTIFIER,
-- [ Entity =>] local_NAME
-- [, [External_Name =>] static_string_EXPRESSION ]
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_External => External : declare
Def_Id : Entity_Id;
C : Convention_Id;
pragma Warnings (Off, C);
begin
GNAT_Pragma;
Check_Arg_Order
((Name_Convention,
Name_Entity,
Name_External_Name,
Name_Link_Name));
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Process_Convention (C, Def_Id);
Note_Possible_Modification
(Get_Pragma_Arg (Arg2), Sure => False);
Process_Interface_Name (Def_Id, Arg3, Arg4);
Set_Exported (Def_Id, Arg2);
end External;
--------------------------
-- External_Name_Casing --
--------------------------
-- pragma External_Name_Casing (
-- UPPERCASE | LOWERCASE
-- [, AS_IS | UPPERCASE | LOWERCASE]);
when Pragma_External_Name_Casing => External_Name_Casing : declare
begin
GNAT_Pragma;
Check_No_Identifiers;
if Arg_Count = 2 then
Check_Arg_Is_One_Of
(Arg2, Name_As_Is, Name_Uppercase, Name_Lowercase);
case Chars (Get_Pragma_Arg (Arg2)) is
when Name_As_Is =>
Opt.External_Name_Exp_Casing := As_Is;
when Name_Uppercase =>
Opt.External_Name_Exp_Casing := Uppercase;
when Name_Lowercase =>
Opt.External_Name_Exp_Casing := Lowercase;
when others =>
null;
end case;
else
Check_Arg_Count (1);
end if;
Check_Arg_Is_One_Of (Arg1, Name_Uppercase, Name_Lowercase);
case Chars (Get_Pragma_Arg (Arg1)) is
when Name_Uppercase =>
Opt.External_Name_Imp_Casing := Uppercase;
when Name_Lowercase =>
Opt.External_Name_Imp_Casing := Lowercase;
when others =>
null;
end case;
end External_Name_Casing;
--------------------------
-- Favor_Top_Level --
--------------------------
-- pragma Favor_Top_Level (type_NAME);
when Pragma_Favor_Top_Level => Favor_Top_Level : declare
Named_Entity : Entity_Id;
begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Named_Entity := Entity (Get_Pragma_Arg (Arg1));
-- If it's an access-to-subprogram type (in particular, not a
-- subtype), set the flag on that type.
if Is_Access_Subprogram_Type (Named_Entity) then
Set_Can_Use_Internal_Rep (Named_Entity, False);
-- Otherwise it's an error (name denotes the wrong sort of entity)
else
Error_Pragma_Arg
("access-to-subprogram type expected",
Get_Pragma_Arg (Arg1));
end if;
end Favor_Top_Level;
---------------
-- Fast_Math --
---------------
-- pragma Fast_Math;
when Pragma_Fast_Math =>
GNAT_Pragma;
Check_No_Identifiers;
Check_Valid_Configuration_Pragma;
Fast_Math := True;
---------------------------
-- Finalize_Storage_Only --
---------------------------
-- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
Assoc : constant Node_Id := Arg1;
Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
Typ : Entity_Id;
begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type
or else Rep_Item_Too_Early (Typ, N)
then
return;
else
Typ := Underlying_Type (Typ);
end if;
if not Is_Controlled (Typ) then
Error_Pragma ("pragma% must specify controlled type");
end if;
Check_First_Subtype (Arg1);
if Finalize_Storage_Only (Typ) then
Error_Pragma ("duplicate pragma%, only one allowed");
elsif not Rep_Item_Too_Late (Typ, N) then
Set_Finalize_Storage_Only (Base_Type (Typ), True);
end if;
end Finalize_Storage;
--------------------------
-- Float_Representation --
--------------------------
-- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]);
-- FLOAT_REP ::= VAX_Float | IEEE_Float
when Pragma_Float_Representation => Float_Representation : declare
Argx : Node_Id;
Digs : Nat;
Ent : Entity_Id;
begin
GNAT_Pragma;
if Arg_Count = 1 then
Check_Valid_Configuration_Pragma;
else
Check_Arg_Count (2);
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg2);
end if;
Check_No_Identifier (Arg1);
Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
if not OpenVMS_On_Target then
if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
end if;
return;
end if;
-- One argument case
if Arg_Count = 1 then
if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
if Opt.Float_Format = 'I' then
Error_Pragma ("'I'E'E'E format previously specified");
end if;
Opt.Float_Format := 'V';
else
if Opt.Float_Format = 'V' then
Error_Pragma ("'V'A'X format previously specified");
end if;
Opt.Float_Format := 'I';
end if;
Set_Standard_Fpt_Formats;
-- Two argument case
else
Argx := Get_Pragma_Arg (Arg2);
if not Is_Entity_Name (Argx)
or else not Is_Floating_Point_Type (Entity (Argx))
then
Error_Pragma_Arg
("second argument of% pragma must be floating-point type",
Arg2);
end if;
Ent := Entity (Argx);
Digs := UI_To_Int (Digits_Value (Ent));
-- Two arguments, VAX_Float case
if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
case Digs is
when 6 => Set_F_Float (Ent);
when 9 => Set_D_Float (Ent);
when 15 => Set_G_Float (Ent);
when others =>
Error_Pragma_Arg
("wrong digits value, must be 6,9 or 15", Arg2);
end case;
-- Two arguments, IEEE_Float case
else
case Digs is
when 6 => Set_IEEE_Short (Ent);
when 15 => Set_IEEE_Long (Ent);
when others =>
Error_Pragma_Arg
("wrong digits value, must be 6 or 15", Arg2);
end case;
end if;
end if;
end Float_Representation;
-----------
-- Ident --
-----------
-- pragma Ident (static_string_EXPRESSION)
-- Note: pragma Comment shares this processing. Pragma Comment is
-- identical to Ident, except that the restriction of the argument to
-- 31 characters and the placement restrictions are not enforced for
-- pragma Comment.
when Pragma_Ident | Pragma_Comment => Ident : declare
Str : Node_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
Store_Note (N);
-- For pragma Ident, preserve DEC compatibility by requiring the
-- pragma to appear in a declarative part or package spec.
if Prag_Id = Pragma_Ident then
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
declare
CS : Node_Id;
GP : Node_Id;
begin
GP := Parent (Parent (N));
if Nkind_In (GP, N_Package_Declaration,
N_Generic_Package_Declaration)
then
GP := Parent (GP);
end if;
-- If we have a compilation unit, then record the ident value,
-- checking for improper duplication.
if Nkind (GP) = N_Compilation_Unit then
CS := Ident_String (Current_Sem_Unit);
if Present (CS) then
-- For Ident, we do not permit multiple instances
if Prag_Id = Pragma_Ident then
Error_Pragma ("duplicate% pragma not permitted");
-- For Comment, we concatenate the string, unless we want
-- to preserve the tree structure for ASIS.
elsif not ASIS_Mode then
Start_String (Strval (CS));
Store_String_Char (' ');
Store_String_Chars (Strval (Str));
Set_Strval (CS, End_String);
end if;
else
-- In VMS, the effect of IDENT is achieved by passing
-- --identification=name as a --for-linker switch.
if OpenVMS_On_Target then
Start_String;
Store_String_Chars
("--for-linker=--identification=");
String_To_Name_Buffer (Strval (Str));
Store_String_Chars (Name_Buffer (1 .. Name_Len));
-- Only the last processed IDENT is saved. The main
-- purpose is so an IDENT associated with a main
-- procedure will be used in preference to an IDENT
-- associated with a with'd package.
Replace_Linker_Option_String
(End_String, "--for-linker=--identification=");
end if;
Set_Ident_String (Current_Sem_Unit, Str);
end if;
-- For subunits, we just ignore the Ident, since in GNAT these
-- are not separate object files, and hence not separate units
-- in the unit table.
elsif Nkind (GP) = N_Subunit then
null;
-- Otherwise we have a misplaced pragma Ident, but we ignore
-- this if we are in an instantiation, since it comes from
-- a generic, and has no relevance to the instantiation.
elsif Prag_Id = Pragma_Ident then
if Instantiation_Location (Loc) = No_Location then
Error_Pragma ("pragma% only allowed at outer level");
end if;
end if;
end;
end Ident;
----------------------------
-- Implementation_Defined --
----------------------------
-- pragma Implementation_Defined (local_NAME);
-- Marks previously declared entity as implementation defined. For
-- an overloaded entity, applies to the most recent homonym.
-- pragma Implementation_Defined;
-- The form with no arguments appears anywhere within a scope, most
-- typically a package spec, and indicates that all entities that are
-- defined within the package spec are Implementation_Defined.
when Pragma_Implementation_Defined => Implementation_Defined : declare
Ent : Entity_Id;
begin
Check_No_Identifiers;
-- Form with no arguments
if Arg_Count = 0 then
Set_Is_Implementation_Defined (Current_Scope);
-- Form with one argument
else
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Ent := Entity (Get_Pragma_Arg (Arg1));
Set_Is_Implementation_Defined (Ent);
end if;
end Implementation_Defined;
-----------------
-- Implemented --
-----------------
-- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
-- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
when Pragma_Implemented => Implemented : declare
Proc_Id : Entity_Id;
Typ : Entity_Id;
begin
Ada_2012_Pragma;
Check_Arg_Count (2);
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
Check_Arg_Is_One_Of
(Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
-- Extract the name of the local procedure
Proc_Id := Entity (Get_Pragma_Arg (Arg1));
-- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
-- primitive procedure of a synchronized tagged type.
if Ekind (Proc_Id) = E_Procedure
and then Is_Primitive (Proc_Id)
and then Present (First_Formal (Proc_Id))
then
Typ := Etype (First_Formal (Proc_Id));
if Is_Tagged_Type (Typ)
and then
-- Check for a protected, a synchronized or a task interface
((Is_Interface (Typ)
and then Is_Synchronized_Interface (Typ))
-- Check for a protected type or a task type that implements
-- an interface.
or else
(Is_Concurrent_Record_Type (Typ)
and then Present (Interfaces (Typ)))
-- Check for a private record extension with keyword
-- "synchronized".
or else
(Ekind_In (Typ, E_Record_Type_With_Private,
E_Record_Subtype_With_Private)
and then Synchronized_Present (Parent (Typ))))
then
null;
else
Error_Pragma_Arg
("controlling formal must be of synchronized " &
"tagged type", Arg1);
return;
end if;
-- Procedures declared inside a protected type must be accepted
elsif Ekind (Proc_Id) = E_Procedure
and then Is_Protected_Type (Scope (Proc_Id))
then
null;
-- The first argument is not a primitive procedure
else
Error_Pragma_Arg
("pragma % must be applied to a primitive procedure", Arg1);
return;
end if;
-- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
-- By_Protected_Procedure to the primitive procedure of a task
-- interface.
if Chars (Arg2) = Name_By_Protected_Procedure
and then Is_Interface (Typ)
and then Is_Task_Interface (Typ)
then
Error_Pragma_Arg
("implementation kind By_Protected_Procedure cannot be " &
"applied to a task interface primitive", Arg2);
return;
end if;
Record_Rep_Item (Proc_Id, N);
end Implemented;
----------------------
-- Implicit_Packing --
----------------------
-- pragma Implicit_Packing;
when Pragma_Implicit_Packing =>
GNAT_Pragma;
Check_Arg_Count (0);
Implicit_Packing := True;
------------
-- Import --
------------
-- pragma Import (
-- [Convention =>] convention_IDENTIFIER,
-- [Entity =>] local_NAME
-- [, [External_Name =>] static_string_EXPRESSION ]
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_Import =>
Check_Ada_83_Warning;
Check_Arg_Order
((Name_Convention,
Name_Entity,
Name_External_Name,
Name_Link_Name));
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Process_Import_Or_Interface;
----------------------
-- Import_Exception --
----------------------
-- pragma Import_Exception (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Form =>] Ada | VMS]
-- [, [Code =>] static_integer_EXPRESSION]);
when Pragma_Import_Exception => Import_Exception : declare
Args : Args_List (1 .. 4);
Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Form,
Name_Code);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Form : Node_Id renames Args (3);
Code : Node_Id renames Args (4);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
if Present (External) and then Present (Code) then
Error_Pragma
("cannot give both External and Code options for pragma%");
end if;
Process_Extended_Import_Export_Exception_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Form => Form,
Arg_Code => Code);
if not Is_VMS_Exception (Entity (Internal)) then
Set_Imported (Entity (Internal));
end if;
end Import_Exception;
---------------------
-- Import_Function --
---------------------
-- pragma Import_Function (
-- [Internal =>] LOCAL_NAME,
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Result_Type =>] SUBTYPE_MARK]
-- [, [Mechanism =>] MECHANISM]
-- [, [Result_Mechanism =>] MECHANISM_NAME]
-- [, [First_Optional_Parameter =>] IDENTIFIER]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
-- PARAMETER_TYPES ::=
-- null
-- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
-- TYPE_DESIGNATOR ::=
-- subtype_NAME
-- | subtype_Name ' Access
-- MECHANISM ::=
-- MECHANISM_NAME
-- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
-- MECHANISM_ASSOCIATION ::=
-- [formal_parameter_NAME =>] MECHANISM_NAME
-- MECHANISM_NAME ::=
-- Value
-- | Reference
-- | Descriptor [([Class =>] CLASS_NAME)]
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Import_Function => Import_Function : declare
Args : Args_List (1 .. 7);
Names : constant Name_List (1 .. 7) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
Name_Result_Type,
Name_Mechanism,
Name_Result_Mechanism,
Name_First_Optional_Parameter);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Result_Type : Node_Id renames Args (4);
Mechanism : Node_Id renames Args (5);
Result_Mechanism : Node_Id renames Args (6);
First_Optional_Parameter : Node_Id renames Args (7);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Subprogram_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
Arg_Result_Type => Result_Type,
Arg_Mechanism => Mechanism,
Arg_Result_Mechanism => Result_Mechanism,
Arg_First_Optional_Parameter => First_Optional_Parameter);
end Import_Function;
-------------------
-- Import_Object --
-------------------
-- pragma Import_Object (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Size =>] EXTERNAL_SYMBOL]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
when Pragma_Import_Object => Import_Object : declare
Args : Args_List (1 .. 3);
Names : constant Name_List (1 .. 3) := (
Name_Internal,
Name_External,
Name_Size);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Size : Node_Id renames Args (3);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Object_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Size => Size);
end Import_Object;
----------------------
-- Import_Procedure --
----------------------
-- pragma Import_Procedure (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Mechanism =>] MECHANISM]
-- [, [First_Optional_Parameter =>] IDENTIFIER]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
-- PARAMETER_TYPES ::=
-- null
-- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
-- TYPE_DESIGNATOR ::=
-- subtype_NAME
-- | subtype_Name ' Access
-- MECHANISM ::=
-- MECHANISM_NAME
-- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
-- MECHANISM_ASSOCIATION ::=
-- [formal_parameter_NAME =>] MECHANISM_NAME
-- MECHANISM_NAME ::=
-- Value
-- | Reference
-- | Descriptor [([Class =>] CLASS_NAME)]
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Import_Procedure => Import_Procedure : declare
Args : Args_List (1 .. 5);
Names : constant Name_List (1 .. 5) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
Name_Mechanism,
Name_First_Optional_Parameter);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Mechanism : Node_Id renames Args (4);
First_Optional_Parameter : Node_Id renames Args (5);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Subprogram_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
Arg_Mechanism => Mechanism,
Arg_First_Optional_Parameter => First_Optional_Parameter);
end Import_Procedure;
-----------------------------
-- Import_Valued_Procedure --
-----------------------------
-- pragma Import_Valued_Procedure (
-- [Internal =>] LOCAL_NAME
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Mechanism =>] MECHANISM]
-- [, [First_Optional_Parameter =>] IDENTIFIER]);
-- EXTERNAL_SYMBOL ::=
-- IDENTIFIER
-- | static_string_EXPRESSION
-- PARAMETER_TYPES ::=
-- null
-- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
-- TYPE_DESIGNATOR ::=
-- subtype_NAME
-- | subtype_Name ' Access
-- MECHANISM ::=
-- MECHANISM_NAME
-- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
-- MECHANISM_ASSOCIATION ::=
-- [formal_parameter_NAME =>] MECHANISM_NAME
-- MECHANISM_NAME ::=
-- Value
-- | Reference
-- | Descriptor [([Class =>] CLASS_NAME)]
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
when Pragma_Import_Valued_Procedure =>
Import_Valued_Procedure : declare
Args : Args_List (1 .. 5);
Names : constant Name_List (1 .. 5) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
Name_Mechanism,
Name_First_Optional_Parameter);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
Mechanism : Node_Id renames Args (4);
First_Optional_Parameter : Node_Id renames Args (5);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Subprogram_Pragma (
Arg_Internal => Internal,
Arg_External => External,
Arg_Parameter_Types => Parameter_Types,
Arg_Mechanism => Mechanism,
Arg_First_Optional_Parameter => First_Optional_Parameter);
end Import_Valued_Procedure;
-----------------
-- Independent --
-----------------
-- pragma Independent (LOCAL_NAME);
when Pragma_Independent => Independent : declare
E_Id : Node_Id;
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
begin
Check_Ada_83_Warning;
Ada_2012_Pragma;
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);
-- Check appropriate 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;
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;
else
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
end if;
Independence_Checks.Append ((N, E));
end Independent;
----------------------------
-- Independent_Components --
----------------------------
-- pragma Atomic_Components (array_LOCAL_NAME);
-- This processing is shared by Volatile_Components
when Pragma_Independent_Components => Independent_Components : declare
E_Id : Node_Id;
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
begin
Check_Ada_83_Warning;
Ada_2012_Pragma;
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);
-- Check duplicate before we chain ourselves!
Check_Duplicate_Pragma (E);
-- Check appropriate entity
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N)
then
return;
end if;
D := Declaration_Node (E);
K := Nkind (D);
if (K = N_Full_Type_Declaration
and then (Is_Array_Type (E) or else Is_Record_Type (E)))
or else
((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
and then Nkind (D) = N_Object_Declaration
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition)
then
Independence_Checks.Append ((N, E));
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
end Independent_Components;
------------------------
-- Initialize_Scalars --
------------------------
-- pragma Initialize_Scalars;
when Pragma_Initialize_Scalars =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Check_Restriction (No_Initialize_Scalars, N);
-- Initialize_Scalars creates false positives in CodePeer, and
-- incorrect negative results in Alfa mode, so ignore this pragma
-- in these modes.
if not Restriction_Active (No_Initialize_Scalars)
and then not (CodePeer_Mode or Alfa_Mode)
then
Init_Or_Norm_Scalars := True;
Initialize_Scalars := True;
end if;
------------
-- Inline --
------------
-- pragma Inline ( NAME {, NAME} );
when Pragma_Inline =>
-- Pragma is active if inlining option is active
Process_Inline (Inline_Active);
-------------------
-- Inline_Always --
-------------------
-- pragma Inline_Always ( NAME {, NAME} );
when Pragma_Inline_Always =>
GNAT_Pragma;
-- Pragma always active unless in CodePeer or Alfa mode, since
-- this causes walk order issues.
if not (CodePeer_Mode or Alfa_Mode) then
Process_Inline (True);
end if;
--------------------
-- Inline_Generic --
--------------------
-- pragma Inline_Generic (NAME {, NAME});
when Pragma_Inline_Generic =>
GNAT_Pragma;
Process_Generic_List;
----------------------
-- Inspection_Point --
----------------------
-- pragma Inspection_Point [(object_NAME {, object_NAME})];
when Pragma_Inspection_Point => Inspection_Point : declare
Arg : Node_Id;
Exp : Node_Id;
begin
if Arg_Count > 0 then
Arg := Arg1;
loop
Exp := Get_Pragma_Arg (Arg);
Analyze (Exp);
if not Is_Entity_Name (Exp)
or else not Is_Object (Entity (Exp))
then
Error_Pragma_Arg ("object name required", Arg);
end if;
Next (Arg);
exit when No (Arg);
end loop;
end if;
end Inspection_Point;
---------------
-- Interface --
---------------
-- pragma Interface (
-- [ Convention =>] convention_IDENTIFIER,
-- [ Entity =>] local_NAME
-- [, [External_Name =>] static_string_EXPRESSION ]
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_Interface =>
GNAT_Pragma;
Check_Arg_Order
((Name_Convention,
Name_Entity,
Name_External_Name,
Name_Link_Name));
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Process_Import_Or_Interface;
-- In Ada 2005, the permission to use Interface (a reserved word)
-- as a pragma name is considered an obsolescent feature.
if Ada_Version >= Ada_2005 then
Check_Restriction
(No_Obsolescent_Features, Pragma_Identifier (N));
end if;
--------------------
-- Interface_Name --
--------------------
-- pragma Interface_Name (
-- [ Entity =>] local_NAME
-- [,[External_Name =>] static_string_EXPRESSION ]
-- [,[Link_Name =>] static_string_EXPRESSION ]);
when Pragma_Interface_Name => Interface_Name : declare
Id : Node_Id;
Def_Id : Entity_Id;
Hom_Id : Entity_Id;
Found : Boolean;
begin
GNAT_Pragma;
Check_Arg_Order
((Name_Entity, Name_External_Name, Name_Link_Name));
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (3);
Id := Get_Pragma_Arg (Arg1);
Analyze (Id);
if not Is_Entity_Name (Id) then
Error_Pragma_Arg
("first argument for pragma% must be entity name", Arg1);
elsif Etype (Id) = Any_Type then
return;
else
Def_Id := Entity (Id);
end if;
-- Special DEC-compatible processing for the object case, forces
-- object to be imported.
if Ekind (Def_Id) = E_Variable then
Kill_Size_Check_Code (Def_Id);
Note_Possible_Modification (Id, Sure => False);
-- Initialization is not allowed for imported variable
if Present (Expression (Parent (Def_Id)))
and then Comes_From_Source (Expression (Parent (Def_Id)))
then
Error_Msg_Sloc := Sloc (Def_Id);
Error_Pragma_Arg
("no initialization allowed for declaration of& #",
Arg2);
else
-- For compatibility, support VADS usage of providing both
-- pragmas Interface and Interface_Name to obtain the effect
-- of a single Import pragma.
if Is_Imported (Def_Id)
and then Present (First_Rep_Item (Def_Id))
and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
and then
Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
then
null;
else
Set_Imported (Def_Id);
end if;
Set_Is_Public (Def_Id);
Process_Interface_Name (Def_Id, Arg2, Arg3);
end if;
-- Otherwise must be subprogram
elsif not Is_Subprogram (Def_Id) then
Error_Pragma_Arg
("argument of pragma% is not subprogram", Arg1);
else
Check_At_Most_N_Arguments (3);
Hom_Id := Def_Id;
Found := False;
-- Loop through homonyms
loop
Def_Id := Get_Base_Subprogram (Hom_Id);
if Is_Imported (Def_Id) then
Process_Interface_Name (Def_Id, Arg2, Arg3);
Found := True;
end if;
exit when From_Aspect_Specification (N);
Hom_Id := Homonym (Hom_Id);
exit when No (Hom_Id)
or else Scope (Hom_Id) /= Current_Scope;
end loop;
if not Found then
Error_Pragma_Arg
("argument of pragma% is not imported subprogram",
Arg1);
end if;
end if;
end Interface_Name;
-----------------------
-- Interrupt_Handler --
-----------------------
-- pragma Interrupt_Handler (handler_NAME);
when Pragma_Interrupt_Handler =>
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_No_Identifiers;
if No_Run_Time_Mode then
Error_Msg_CRT ("Interrupt_Handler pragma", N);
else
Check_Interrupt_Or_Attach_Handler;
Process_Interrupt_Or_Attach_Handler;
end if;
------------------------
-- Interrupt_Priority --
------------------------
-- pragma Interrupt_Priority [(EXPRESSION)];
when Pragma_Interrupt_Priority => Interrupt_Priority : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Check_Ada_83_Warning;
if Arg_Count /= 0 then
Arg := Get_Pragma_Arg (Arg1);
Check_Arg_Count (1);
Check_No_Identifiers;
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
Preanalyze_Spec_Expression (Arg, RTE (RE_Interrupt_Priority));
end if;
if not Nkind_In (P, N_Task_Definition, N_Protected_Definition) then
Pragma_Misplaced;
return;
elsif Has_Pragma_Priority (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_Priority (P, True);
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end Interrupt_Priority;
---------------------
-- Interrupt_State --
---------------------
-- pragma Interrupt_State (
-- [Name =>] INTERRUPT_ID,
-- [State =>] INTERRUPT_STATE);
-- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
-- INTERRUPT_STATE => System | Runtime | User
-- Note: if the interrupt id is given as an identifier, then it must
-- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
-- given as a static integer expression which must be in the range of
-- Ada.Interrupts.Interrupt_ID.
when Pragma_Interrupt_State => Interrupt_State : declare
Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
-- This is the entity Ada.Interrupts.Interrupt_ID;
State_Type : Character;
-- Set to 's'/'r'/'u' for System/Runtime/User
IST_Num : Pos;
-- Index to entry in Interrupt_States table
Int_Val : Uint;
-- Value of interrupt
Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
-- The first argument to the pragma
Int_Ent : Entity_Id;
-- Interrupt entity in Ada.Interrupts.Names
begin
GNAT_Pragma;
Check_Arg_Order ((Name_Name, Name_State));
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Name);
Check_Optional_Identifier (Arg2, Name_State);
Check_Arg_Is_Identifier (Arg2);
-- First argument is identifier
if Nkind (Arg1X) = N_Identifier then
-- Search list of names in Ada.Interrupts.Names
Int_Ent := First_Entity (RTE (RE_Names));
loop
if No (Int_Ent) then
Error_Pragma_Arg ("invalid interrupt name", Arg1);
elsif Chars (Int_Ent) = Chars (Arg1X) then
Int_Val := Expr_Value (Constant_Value (Int_Ent));
exit;
end if;
Next_Entity (Int_Ent);
end loop;
-- First argument is not an identifier, so it must be a static
-- expression of type Ada.Interrupts.Interrupt_ID.
else
Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
Int_Val := Expr_Value (Arg1X);
if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
or else
Int_Val > Expr_Value (Type_High_Bound (Int_Id))
then
Error_Pragma_Arg
("value not in range of type " &
"""Ada.Interrupts.Interrupt_'I'D""", Arg1);
end if;
end if;
-- Check OK state
case Chars (Get_Pragma_Arg (Arg2)) is
when Name_Runtime => State_Type := 'r';
when Name_System => State_Type := 's';
when Name_User => State_Type := 'u';
when others =>
Error_Pragma_Arg ("invalid interrupt state", Arg2);
end case;
-- Check if entry is already stored
IST_Num := Interrupt_States.First;
loop
-- If entry not found, add it
if IST_Num > Interrupt_States.Last then
Interrupt_States.Append
((Interrupt_Number => UI_To_Int (Int_Val),
Interrupt_State => State_Type,
Pragma_Loc => Loc));
exit;
-- Case of entry for the same entry
elsif Int_Val = Interrupt_States.Table (IST_Num).
Interrupt_Number
then
-- If state matches, done, no need to make redundant entry
exit when
State_Type = Interrupt_States.Table (IST_Num).
Interrupt_State;
-- Otherwise if state does not match, error
Error_Msg_Sloc :=
Interrupt_States.Table (IST_Num).Pragma_Loc;
Error_Pragma_Arg
("state conflicts with that given #", Arg2);
exit;
end if;
IST_Num := IST_Num + 1;
end loop;
end Interrupt_State;
---------------
-- Invariant --
---------------
-- pragma Invariant
-- ([Entity =>] type_LOCAL_NAME,
-- [Check =>] EXPRESSION
-- [,[Message =>] String_Expression]);
when Pragma_Invariant => Invariant : declare
Type_Id : Node_Id;
Typ : Entity_Id;
Discard : Boolean;
pragma Unreferenced (Discard);
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (3);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Check);
if Arg_Count = 3 then
Check_Optional_Identifier (Arg3, Name_Message);
Check_Arg_Is_Static_Expression (Arg3, Standard_String);
end if;
Check_Arg_Is_Local_Name (Arg1);
Type_Id := Get_Pragma_Arg (Arg1);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type then
return;
-- An invariant must apply to a private type, or appear in the
-- private part of a package spec and apply to a completion.
elsif Ekind_In (Typ, E_Private_Type,
E_Record_Type_With_Private,
E_Limited_Private_Type)
then
null;
elsif In_Private_Part (Current_Scope)
and then Has_Private_Declaration (Typ)
then
null;
elsif In_Private_Part (Current_Scope) then
Error_Pragma_Arg
("pragma% only allowed for private type " &
"declared in visible part", Arg1);
else
Error_Pragma_Arg
("pragma% only allowed for private type", Arg1);
end if;
-- Note that the type has at least one invariant, and also that
-- it has inheritable invariants if we have Invariant'Class.
Set_Has_Invariants (Typ);
if Class_Present (N) then
Set_Has_Inheritable_Invariants (Typ);
end if;
-- The remaining processing is simply to link the pragma on to
-- the rep item chain, for processing when the type is frozen.
-- This is accomplished by a call to Rep_Item_Too_Late.
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
end Invariant;
----------------------
-- Java_Constructor --
----------------------
-- pragma Java_Constructor ([Entity =>] LOCAL_NAME);
-- Also handles pragma CIL_Constructor
when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
Java_Constructor : declare
Convention : Convention_Id;
Def_Id : Entity_Id;
Hom_Id : Entity_Id;
Id : Entity_Id;
This_Formal : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
Id := Get_Pragma_Arg (Arg1);
Find_Program_Unit_Name (Id);
-- If we did not find the name, we are done
if Etype (Id) = Any_Type then
return;
end if;
-- Check wrong use of pragma in wrong VM target
if VM_Target = No_VM then
return;
elsif VM_Target = CLI_Target
and then Prag_Id = Pragma_Java_Constructor
then
Error_Pragma ("must use pragma 'C'I'L_'Constructor");
elsif VM_Target = JVM_Target
and then Prag_Id = Pragma_CIL_Constructor
then
Error_Pragma ("must use pragma 'Java_'Constructor");
end if;
case Prag_Id is
when Pragma_CIL_Constructor => Convention := Convention_CIL;
when Pragma_Java_Constructor => Convention := Convention_Java;
when others => null;
end case;
Hom_Id := Entity (Id);
-- Loop through homonyms
loop
Def_Id := Get_Base_Subprogram (Hom_Id);
-- The constructor is required to be a function
if Ekind (Def_Id) /= E_Function then
if VM_Target = JVM_Target then
Error_Pragma_Arg
("pragma% requires function returning a " &
"'Java access type", Def_Id);
else
Error_Pragma_Arg
("pragma% requires function returning a " &
"'C'I'L access type", Def_Id);
end if;
end if;
-- Check arguments: For tagged type the first formal must be
-- named "this" and its type must be a named access type
-- designating a class-wide tagged type that has convention
-- CIL/Java. The first formal must also have a null default
-- value. For example:
-- type Typ is tagged ...
-- type Ref is access all Typ;
-- pragma Convention (CIL, Typ);
-- function New_Typ (This : Ref) return Ref;
-- function New_Typ (This : Ref; I : Integer) return Ref;
-- pragma Cil_Constructor (New_Typ);
-- Reason: The first formal must NOT be a primitive of the
-- tagged type.
-- This rule also applies to constructors of delegates used
-- to interface with standard target libraries. For example:
-- type Delegate is access procedure ...
-- pragma Import (CIL, Delegate, ...);
-- function new_Delegate
-- (This : Delegate := null; ... ) return Delegate;
-- For value-types this rule does not apply.
if not Is_Value_Type (Etype (Def_Id)) then
if No (First_Formal (Def_Id)) then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("% function must have parameters", Def_Id);
return;
end if;
-- In the JRE library we have several occurrences in which
-- the "this" parameter is not the first formal.
This_Formal := First_Formal (Def_Id);
-- In the JRE library we have several occurrences in which
-- the "this" parameter is not the first formal. Search for
-- it.
if VM_Target = JVM_Target then
while Present (This_Formal)
and then Get_Name_String (Chars (This_Formal)) /= "this"
loop
Next_Formal (This_Formal);
end loop;
if No (This_Formal) then
This_Formal := First_Formal (Def_Id);
end if;
end if;
-- Warning: The first parameter should be named "this".
-- We temporarily allow it because we have the following
-- case in the Java runtime (file s-osinte.ads) ???
-- function new_Thread
-- (Self_Id : System.Address) return Thread_Id;
-- pragma Java_Constructor (new_Thread);
if VM_Target = JVM_Target
and then Get_Name_String (Chars (First_Formal (Def_Id)))
= "self_id"
and then Etype (First_Formal (Def_Id)) = RTE (RE_Address)
then
null;
elsif Get_Name_String (Chars (This_Formal)) /= "this" then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("first formal of % function must be named `this`",
Parent (This_Formal));
elsif not Is_Access_Type (Etype (This_Formal)) then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("first formal of % function must be an access type",
Parameter_Type (Parent (This_Formal)));
-- For delegates the type of the first formal must be a
-- named access-to-subprogram type (see previous example)
elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
and then Ekind (Etype (This_Formal))
/= E_Access_Subprogram_Type
then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("first formal of % function must be a named access" &
" to subprogram type",
Parameter_Type (Parent (This_Formal)));
-- Warning: We should reject anonymous access types because
-- the constructor must not be handled as a primitive of the
-- tagged type. We temporarily allow it because this profile
-- is currently generated by cil2ada???
elsif Ekind (Etype (Def_Id)) /= E_Access_Subprogram_Type
and then not Ekind_In (Etype (This_Formal),
E_Access_Type,
E_General_Access_Type,
E_Anonymous_Access_Type)
then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("first formal of % function must be a named access" &
" type",
Parameter_Type (Parent (This_Formal)));
elsif Atree.Convention
(Designated_Type (Etype (This_Formal))) /= Convention
then
Error_Msg_Name_1 := Pname;
if Convention = Convention_Java then
Error_Msg_N
("pragma% requires convention 'Cil in designated" &
" type",
Parameter_Type (Parent (This_Formal)));
else
Error_Msg_N
("pragma% requires convention 'Java in designated" &
" type",
Parameter_Type (Parent (This_Formal)));
end if;
elsif No (Expression (Parent (This_Formal)))
or else Nkind (Expression (Parent (This_Formal))) /= N_Null
then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("pragma% requires first formal with default `null`",
Parameter_Type (Parent (This_Formal)));
end if;
end if;
-- Check result type: the constructor must be a function
-- returning:
-- * a value type (only allowed in the CIL compiler)
-- * an access-to-subprogram type with convention Java/CIL
-- * an access-type designating a type that has convention
-- Java/CIL.
if Is_Value_Type (Etype (Def_Id)) then
null;
-- Access-to-subprogram type with convention Java/CIL
elsif Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type then
if Atree.Convention (Etype (Def_Id)) /= Convention then
if Convention = Convention_Java then
Error_Pragma_Arg
("pragma% requires function returning a " &
"'Java access type", Arg1);
else
pragma Assert (Convention = Convention_CIL);
Error_Pragma_Arg
("pragma% requires function returning a " &
"'C'I'L access type", Arg1);
end if;
end if;
elsif Ekind (Etype (Def_Id)) in Access_Kind then
if not Ekind_In (Etype (Def_Id), E_Access_Type,
E_General_Access_Type)
or else
Atree.Convention
(Designated_Type (Etype (Def_Id))) /= Convention
then
Error_Msg_Name_1 := Pname;
if Convention = Convention_Java then
Error_Pragma_Arg
("pragma% requires function returning a named" &
"'Java access type", Arg1);
else
Error_Pragma_Arg
("pragma% requires function returning a named" &
"'C'I'L access type", Arg1);
end if;
end if;
end if;
Set_Is_Constructor (Def_Id);
Set_Convention (Def_Id, Convention);
Set_Is_Imported (Def_Id);
exit when From_Aspect_Specification (N);
Hom_Id := Homonym (Hom_Id);
exit when No (Hom_Id) or else Scope (Hom_Id) /= Current_Scope;
end loop;
end Java_Constructor;
----------------------
-- Java_Interface --
----------------------
-- pragma Java_Interface ([Entity =>] LOCAL_NAME);
when Pragma_Java_Interface => Java_Interface : declare
Arg : Node_Id;
Typ : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
return;
end if;
if not Is_Entity_Name (Arg)
or else not Is_Type (Entity (Arg))
then
Error_Pragma_Arg ("pragma% requires a type mark", Arg1);
end if;
Typ := Underlying_Type (Entity (Arg));
-- For now simply check some of the semantic constraints on the
-- type. This currently leaves out some restrictions on interface
-- types, namely that the parent type must be java.lang.Object.Typ
-- and that all primitives of the type should be declared
-- abstract. ???
if not Is_Tagged_Type (Typ) or else not Is_Abstract_Type (Typ) then
Error_Pragma_Arg ("pragma% requires an abstract "
& "tagged type", Arg1);
elsif not Has_Discriminants (Typ)
or else Ekind (Etype (First_Discriminant (Typ)))
/= E_Anonymous_Access_Type
or else
not Is_Class_Wide_Type
(Designated_Type (Etype (First_Discriminant (Typ))))
then
Error_Pragma_Arg
("type must have a class-wide access discriminant", Arg1);
end if;
end Java_Interface;
----------------
-- Keep_Names --
----------------
-- pragma Keep_Names ([On => ] local_NAME);
when Pragma_Keep_Names => Keep_Names : declare
Arg : Node_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_On);
Check_Arg_Is_Local_Name (Arg1);
Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
return;
end if;
if not Is_Entity_Name (Arg)
or else Ekind (Entity (Arg)) /= E_Enumeration_Type
then
Error_Pragma_Arg
("pragma% requires a local enumeration type", Arg1);
end if;
Set_Discard_Names (Entity (Arg), False);
end Keep_Names;
-------------
-- License --
-------------
-- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
when Pragma_License =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Valid_Configuration_Pragma;
Check_Arg_Is_Identifier (Arg1);
declare
Sind : constant Source_File_Index :=
Source_Index (Current_Sem_Unit);
begin
case Chars (Get_Pragma_Arg (Arg1)) is
when Name_GPL =>
Set_License (Sind, GPL);
when Name_Modified_GPL =>
Set_License (Sind, Modified_GPL);
when Name_Restricted =>
Set_License (Sind, Restricted);
when Name_Unrestricted =>
Set_License (Sind, Unrestricted);
when others =>
Error_Pragma_Arg ("invalid license name", Arg1);
end case;
end;
---------------
-- Link_With --
---------------
-- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
when Pragma_Link_With => Link_With : declare
Arg : Node_Id;
begin
GNAT_Pragma;
if Operating_Mode = Generate_Code
and then In_Extended_Main_Source_Unit (N)
then
Check_At_Least_N_Arguments (1);
Check_No_Identifiers;
Check_Is_In_Decl_Part_Or_Package_Spec;
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
Start_String;
Arg := Arg1;
while Present (Arg) loop
Check_Arg_Is_Static_Expression (Arg, Standard_String);
-- Store argument, converting sequences of spaces to a
-- single null character (this is one of the differences
-- in processing between Link_With and Linker_Options).
Arg_Store : declare
C : constant Char_Code := Get_Char_Code (' ');
S : constant String_Id :=
Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
L : constant Nat := String_Length (S);
F : Nat := 1;
procedure Skip_Spaces;
-- Advance F past any spaces
-----------------
-- Skip_Spaces --
-----------------
procedure Skip_Spaces is
begin
while F <= L and then Get_String_Char (S, F) = C loop
F := F + 1;
end loop;
end Skip_Spaces;
-- Start of processing for Arg_Store
begin
Skip_Spaces; -- skip leading spaces
-- Loop through characters, changing any embedded
-- sequence of spaces to a single null character (this
-- is how Link_With/Linker_Options differ)
while F <= L loop
if Get_String_Char (S, F) = C then
Skip_Spaces;
exit when F > L;
Store_String_Char (ASCII.NUL);
else
Store_String_Char (Get_String_Char (S, F));
F := F + 1;
end if;
end loop;
end Arg_Store;
Arg := Next (Arg);
if Present (Arg) then
Store_String_Char (ASCII.NUL);
end if;
end loop;
Store_Linker_Option_String (End_String);
end if;
end Link_With;
------------------
-- Linker_Alias --
------------------
-- pragma Linker_Alias (
-- [Entity =>] LOCAL_NAME
-- [Target =>] static_string_EXPRESSION);
when Pragma_Linker_Alias =>
GNAT_Pragma;
Check_Arg_Order ((Name_Entity, Name_Target));
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Target);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
Check_Arg_Is_Static_Expression (Arg2, Standard_String);
-- The only processing required is to link this item on to the
-- list of rep items for the given entity. This is accomplished
-- by the call to Rep_Item_Too_Late (when no error is detected
-- and False is returned).
if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
return;
else
Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
end if;
------------------------
-- Linker_Constructor --
------------------------
-- pragma Linker_Constructor (procedure_LOCAL_NAME);
-- Code is shared with Linker_Destructor
-----------------------
-- Linker_Destructor --
-----------------------
-- pragma Linker_Destructor (procedure_LOCAL_NAME);
when Pragma_Linker_Constructor |
Pragma_Linker_Destructor =>
Linker_Constructor : declare
Arg1_X : Node_Id;
Proc : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Local_Name (Arg1);
Arg1_X := Get_Pragma_Arg (Arg1);
Analyze (Arg1_X);
Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
if not Is_Library_Level_Entity (Proc) then
Error_Pragma_Arg
("argument for pragma% must be library level entity", Arg1);
end if;
-- The only processing required is to link this item on to the
-- list of rep items for the given entity. This is accomplished
-- by the call to Rep_Item_Too_Late (when no error is detected
-- and False is returned).
if Rep_Item_Too_Late (Proc, N) then
return;
else
Set_Has_Gigi_Rep_Item (Proc);
end if;
end Linker_Constructor;
--------------------
-- Linker_Options --
--------------------
-- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
when Pragma_Linker_Options => Linker_Options : declare
Arg : Node_Id;
begin
Check_Ada_83_Warning;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Is_In_Decl_Part_Or_Package_Spec;
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
Arg := Arg2;
while Present (Arg) loop
Check_Arg_Is_Static_Expression (Arg, Standard_String);
Store_String_Char (ASCII.NUL);
Store_String_Chars
(Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
Arg := Next (Arg);
end loop;
if Operating_Mode = Generate_Code
and then In_Extended_Main_Source_Unit (N)
then
Store_Linker_Option_String (End_String);
end if;
end Linker_Options;
--------------------
-- Linker_Section --
--------------------
-- pragma Linker_Section (
-- [Entity =>] LOCAL_NAME
-- [Section =>] static_string_EXPRESSION);
when Pragma_Linker_Section =>
GNAT_Pragma;
Check_Arg_Order ((Name_Entity, Name_Section));
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Section);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
Check_Arg_Is_Static_Expression (Arg2, Standard_String);
-- This pragma applies only to objects
if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
end if;
-- The only processing required is to link this item on to the
-- list of rep items for the given entity. This is accomplished
-- by the call to Rep_Item_Too_Late (when no error is detected
-- and False is returned).
if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
return;
else
Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
end if;
----------
-- List --
----------
-- pragma List (On | Off)
-- There is nothing to do here, since we did all the processing for
-- this pragma in Par.Prag (so that it works properly even in syntax
-- only mode).
when Pragma_List =>
null;
--------------------
-- Locking_Policy --
--------------------
-- pragma Locking_Policy (policy_IDENTIFIER);
when Pragma_Locking_Policy => declare
subtype LP_Range is Name_Id
range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
LP_Val : LP_Range;
LP : Character;
begin
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Locking_Policy (Arg1);
Check_Valid_Configuration_Pragma;
LP_Val := Chars (Get_Pragma_Arg (Arg1));
case LP_Val is
when Name_Ceiling_Locking => LP := 'C';
when Name_Inheritance_Locking => LP := 'I';
when Name_Concurrent_Readers_Locking => LP := 'R';
end case;
if Locking_Policy /= ' '
and then Locking_Policy /= LP
then
Error_Msg_Sloc := Locking_Policy_Sloc;
Error_Pragma ("locking policy incompatible with policy#");
-- Set new policy, but always preserve System_Location since we
-- like the error message with the run time name.
else
Locking_Policy := LP;
if Locking_Policy_Sloc /= System_Location then
Locking_Policy_Sloc := Loc;
end if;
end if;
end;
----------------
-- Long_Float --
----------------
-- pragma Long_Float (D_Float | G_Float);
when Pragma_Long_Float =>
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_No_Identifier (Arg1);
Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float);
if not OpenVMS_On_Target then
Error_Pragma ("?pragma% ignored (applies only to Open'V'M'S)");
end if;
-- D_Float case
if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
if Opt.Float_Format_Long = 'G' then
Error_Pragma ("G_Float previously specified");
end if;
Opt.Float_Format_Long := 'D';
-- G_Float case (this is the default, does not need overriding)
else
if Opt.Float_Format_Long = 'D' then
Error_Pragma ("D_Float previously specified");
end if;
Opt.Float_Format_Long := 'G';
end if;
Set_Standard_Fpt_Formats;
-----------------------
-- Machine_Attribute --
-----------------------
-- pragma Machine_Attribute (
-- [Entity =>] LOCAL_NAME,
-- [Attribute_Name =>] static_string_EXPRESSION
-- [, [Info =>] static_EXPRESSION] );
when Pragma_Machine_Attribute => Machine_Attribute : declare
Def_Id : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Order ((Name_Entity, Name_Attribute_Name, Name_Info));
if Arg_Count = 3 then
Check_Optional_Identifier (Arg3, Name_Info);
Check_Arg_Is_Static_Expression (Arg3);
else
Check_Arg_Count (2);
end if;
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Attribute_Name);
Check_Arg_Is_Local_Name (Arg1);
Check_Arg_Is_Static_Expression (Arg2, Standard_String);
Def_Id := Entity (Get_Pragma_Arg (Arg1));
if Is_Access_Type (Def_Id) then
Def_Id := Designated_Type (Def_Id);
end if;
if Rep_Item_Too_Early (Def_Id, N) then
return;
end if;
Def_Id := Underlying_Type (Def_Id);
-- The only processing required is to link this item on to the
-- list of rep items for the given entity. This is accomplished
-- by the call to Rep_Item_Too_Late (when no error is detected
-- and False is returned).
if Rep_Item_Too_Late (Def_Id, N) then
return;
else
Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
end if;
end Machine_Attribute;
----------
-- Main --
----------
-- pragma Main
-- (MAIN_OPTION [, MAIN_OPTION]);
-- MAIN_OPTION ::=
-- [STACK_SIZE =>] static_integer_EXPRESSION
-- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
-- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
when Pragma_Main => Main : declare
Args : Args_List (1 .. 3);
Names : constant Name_List (1 .. 3) := (
Name_Stack_Size,
Name_Task_Stack_Size_Default,
Name_Time_Slicing_Enabled);
Nod : Node_Id;
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
for J in 1 .. 2 loop
if Present (Args (J)) then
Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
end if;
end loop;
if Present (Args (3)) then
Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
end if;
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
and then Pragma_Name (Nod) = Name_Main
then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
end if;
Next (Nod);
end loop;
end Main;
------------------
-- Main_Storage --
------------------
-- pragma Main_Storage
-- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
-- MAIN_STORAGE_OPTION ::=
-- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
-- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
when Pragma_Main_Storage => Main_Storage : declare
Args : Args_List (1 .. 2);
Names : constant Name_List (1 .. 2) := (
Name_Working_Storage,
Name_Top_Guard);
Nod : Node_Id;
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
for J in 1 .. 2 loop
if Present (Args (J)) then
Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
end if;
end loop;
Check_In_Main_Program;
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
and then Pragma_Name (Nod) = Name_Main_Storage
then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
end if;
Next (Nod);
end loop;
end Main_Storage;
-----------------
-- Memory_Size --
-----------------
-- pragma Memory_Size (NUMERIC_LITERAL)
when Pragma_Memory_Size =>
GNAT_Pragma;
-- Memory size is simply ignored
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Integer_Literal (Arg1);
-------------
-- No_Body --
-------------
-- pragma No_Body;
-- The only correct use of this pragma is on its own in a file, in
-- which case it is specially processed (see Gnat1drv.Check_Bad_Body
-- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
-- check for a file containing nothing but a No_Body pragma). If we
-- attempt to process it during normal semantics processing, it means
-- it was misplaced.
when Pragma_No_Body =>
GNAT_Pragma;
Pragma_Misplaced;
---------------
-- No_Return --
---------------
-- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
when Pragma_No_Return => No_Return : declare
Id : Node_Id;
E : Entity_Id;
Found : Boolean;
Arg : Node_Id;
begin
Ada_2005_Pragma;
Check_At_Least_N_Arguments (1);
-- Loop through arguments of pragma
Arg := Arg1;
while Present (Arg) loop
Check_Arg_Is_Local_Name (Arg);
Id := Get_Pragma_Arg (Arg);
Analyze (Id);
if not Is_Entity_Name (Id) then
Error_Pragma_Arg ("entity name required", Arg);
end if;
if Etype (Id) = Any_Type then
raise Pragma_Exit;
end if;
-- Loop to find matching procedures
E := Entity (Id);
Found := False;
while Present (E)
and then Scope (E) = Current_Scope
loop
if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
Set_No_Return (E);
-- Set flag on any alias as well
if Is_Overloadable (E) and then Present (Alias (E)) then
Set_No_Return (Alias (E));
end if;
Found := True;
end if;
exit when From_Aspect_Specification (N);
E := Homonym (E);
end loop;
if not Found then
Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
end if;
Next (Arg);
end loop;
end No_Return;
-----------------
-- No_Run_Time --
-----------------
-- pragma No_Run_Time;
-- Note: this pragma is retained for backwards compatibility. See
-- body of Rtsfind for full details on its handling.
when Pragma_No_Run_Time =>
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (0);
No_Run_Time_Mode := True;
Configurable_Run_Time_Mode := True;
-- Set Duration to 32 bits if word size is 32
if Ttypes.System_Word_Size = 32 then
Duration_32_Bits_On_Target := True;
end if;
-- Set appropriate restrictions
Set_Restriction (No_Finalization, N);
Set_Restriction (No_Exception_Handlers, N);
Set_Restriction (Max_Tasks, N, 0);
Set_Restriction (No_Tasking, N);
------------------------
-- No_Strict_Aliasing --
------------------------
-- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
E_Id : Entity_Id;
begin
GNAT_Pragma;
Check_At_Most_N_Arguments (1);
if Arg_Count = 0 then
Check_Valid_Configuration_Pragma;
Opt.No_Strict_Aliasing := True;
else
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
E_Id := Entity (Get_Pragma_Arg (Arg1));
if E_Id = Any_Type then
return;
elsif No (E_Id) or else not Is_Access_Type (E_Id) then
Error_Pragma_Arg ("pragma% requires access type", Arg1);
end if;
Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
end if;
end No_Strict_Aliasing;
-----------------------
-- Normalize_Scalars --
-----------------------
-- pragma Normalize_Scalars;
when Pragma_Normalize_Scalars =>
Check_Ada_83_Warning;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
-- Normalize_Scalars creates false positives in CodePeer, and
-- incorrect negative results in Alfa mode, so ignore this pragma
-- in these modes.
if not (CodePeer_Mode or Alfa_Mode) then
Normalize_Scalars := True;
Init_Or_Norm_Scalars := True;
end if;
-----------------
-- Obsolescent --
-----------------
-- pragma Obsolescent;
-- pragma Obsolescent (
-- [Message =>] static_string_EXPRESSION
-- [,[Version =>] Ada_05]]);
-- pragma Obsolescent (
-- [Entity =>] NAME
-- [,[Message =>] static_string_EXPRESSION
-- [,[Version =>] Ada_05]] );
when Pragma_Obsolescent => Obsolescent : declare
Ename : Node_Id;
Decl : Node_Id;
procedure Set_Obsolescent (E : Entity_Id);
-- Given an entity Ent, mark it as obsolescent if appropriate
---------------------
-- Set_Obsolescent --
---------------------
procedure Set_Obsolescent (E : Entity_Id) is
Active : Boolean;
Ent : Entity_Id;
S : String_Id;
begin
Active := True;
Ent := E;
-- Entity name was given
if Present (Ename) then
-- If entity name matches, we are fine. Save entity in
-- pragma argument, for ASIS use.
if Chars (Ename) = Chars (Ent) then
Set_Entity (Ename, Ent);
Generate_Reference (Ent, Ename);
-- If entity name does not match, only possibility is an
-- enumeration literal from an enumeration type declaration.
elsif Ekind (Ent) /= E_Enumeration_Type then
Error_Pragma
("pragma % entity name does not match declaration");
else
Ent := First_Literal (E);
loop
if No (Ent) then
Error_Pragma
("pragma % entity name does not match any " &
"enumeration literal");
elsif Chars (Ent) = Chars (Ename) then
Set_Entity (Ename, Ent);
Generate_Reference (Ent, Ename);
exit;
else
Ent := Next_Literal (Ent);
end if;
end loop;
end if;
end if;
-- Ent points to entity to be marked
if Arg_Count >= 1 then
-- Deal with static string argument
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
S := Strval (Get_Pragma_Arg (Arg1));
for J in 1 .. String_Length (S) loop
if not In_Character_Range (Get_String_Char (S, J)) then
Error_Pragma_Arg
("pragma% argument does not allow wide characters",
Arg1);
end if;
end loop;
Obsolescent_Warnings.Append
((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
-- Check for Ada_05 parameter
if Arg_Count /= 1 then
Check_Arg_Count (2);
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
begin
Check_Arg_Is_Identifier (Argx);
if Chars (Argx) /= Name_Ada_05 then
Error_Msg_Name_2 := Name_Ada_05;
Error_Pragma_Arg
("only allowed argument for pragma% is %", Argx);
end if;
if Ada_Version_Explicit < Ada_2005
or else not Warn_On_Ada_2005_Compatibility
then
Active := False;
end if;
end;
end if;
end if;
-- Set flag if pragma active
if Active then
Set_Is_Obsolescent (Ent);
end if;
return;
end Set_Obsolescent;
-- Start of processing for pragma Obsolescent
begin
GNAT_Pragma;
Check_At_Most_N_Arguments (3);
-- See if first argument specifies an entity name
if Arg_Count >= 1
and then
(Chars (Arg1) = Name_Entity
or else
Nkind_In (Get_Pragma_Arg (Arg1), N_Character_Literal,
N_Identifier,
N_Operator_Symbol))
then
Ename := Get_Pragma_Arg (Arg1);
-- Eliminate first argument, so we can share processing
Arg1 := Arg2;
Arg2 := Arg3;
Arg_Count := Arg_Count - 1;
-- No Entity name argument given
else
Ename := Empty;
end if;
if Arg_Count >= 1 then
Check_Optional_Identifier (Arg1, Name_Message);
if Arg_Count = 2 then
Check_Optional_Identifier (Arg2, Name_Version);
end if;
end if;
-- Get immediately preceding declaration
Decl := Prev (N);
while Present (Decl) and then Nkind (Decl) = N_Pragma loop
Prev (Decl);
end loop;
-- Cases where we do not follow anything other than another pragma
if No (Decl) then
-- First case: library level compilation unit declaration with
-- the pragma immediately following the declaration.
if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
Set_Obsolescent
(Defining_Entity (Unit (Parent (Parent (N)))));
return;
-- Case 2: library unit placement for package
else
declare
Ent : constant Entity_Id := Find_Lib_Unit_Name;
begin
if Is_Package_Or_Generic_Package (Ent) then
Set_Obsolescent (Ent);
return;
end if;
end;
end if;
-- Cases where we must follow a declaration
else
if Nkind (Decl) not in N_Declaration
and then Nkind (Decl) not in N_Later_Decl_Item
and then Nkind (Decl) not in N_Generic_Declaration
and then Nkind (Decl) not in N_Renaming_Declaration
then
Error_Pragma
("pragma% misplaced, "
& "must immediately follow a declaration");
else
Set_Obsolescent (Defining_Entity (Decl));
return;
end if;
end if;
end Obsolescent;
--------------
-- Optimize --
--------------
-- pragma Optimize (Time | Space | Off);
-- The actual check for optimize is done in Gigi. Note that this
-- pragma does not actually change the optimization setting, it
-- simply checks that it is consistent with the pragma.
when Pragma_Optimize =>
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
------------------------
-- Optimize_Alignment --
------------------------
-- pragma Optimize_Alignment (Time | Space | Off);
when Pragma_Optimize_Alignment => Optimize_Alignment : begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Valid_Configuration_Pragma;
declare
Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
begin
case Nam is
when Name_Time =>
Opt.Optimize_Alignment := 'T';
when Name_Space =>
Opt.Optimize_Alignment := 'S';
when Name_Off =>
Opt.Optimize_Alignment := 'O';
when others =>
Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
end case;
end;
-- Set indication that mode is set locally. If we are in fact in a
-- configuration pragma file, this setting is harmless since the
-- switch will get reset anyway at the start of each unit.
Optimize_Alignment_Local := True;
end Optimize_Alignment;
-------------
-- Ordered --
-------------
-- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
when Pragma_Ordered => Ordered : declare
Assoc : constant Node_Id := Arg1;
Type_Id : Node_Id;
Typ : Entity_Id;
begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Type_Id := Get_Pragma_Arg (Assoc);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type then
return;
else
Typ := Underlying_Type (Typ);
end if;
if not Is_Enumeration_Type (Typ) then
Error_Pragma ("pragma% must specify enumeration type");
end if;
Check_First_Subtype (Arg1);
Set_Has_Pragma_Ordered (Base_Type (Typ));
end Ordered;
----------
-- Pack --
----------
-- pragma Pack (first_subtype_LOCAL_NAME);
when Pragma_Pack => Pack : declare
Assoc : constant Node_Id := Arg1;
Type_Id : Node_Id;
Typ : Entity_Id;
Ctyp : Entity_Id;
Ignore : Boolean := False;
begin
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Type_Id := Get_Pragma_Arg (Assoc);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type
or else Rep_Item_Too_Early (Typ, N)
then
return;
else
Typ := Underlying_Type (Typ);
end if;
if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
Error_Pragma ("pragma% must specify array or record type");
end if;
Check_First_Subtype (Arg1);
Check_Duplicate_Pragma (Typ);
-- Array type
if Is_Array_Type (Typ) then
Ctyp := Component_Type (Typ);
-- Ignore pack that does nothing
if Known_Static_Esize (Ctyp)
and then Known_Static_RM_Size (Ctyp)
and then Esize (Ctyp) = RM_Size (Ctyp)
and then Addressable (Esize (Ctyp))
then
Ignore := True;
end if;
-- Process OK pragma Pack. Note that if there is a separate
-- component clause present, the Pack will be cancelled. This
-- processing is in Freeze.
if not Rep_Item_Too_Late (Typ, N) then
-- In the context of static code analysis, we do not need
-- complex front-end expansions related to pragma Pack,
-- so disable handling of pragma Pack in these cases.
if CodePeer_Mode or Alfa_Mode then
null;
-- Don't attempt any packing for VM targets. We possibly
-- could deal with some cases of array bit-packing, but we
-- don't bother, since this is not a typical kind of
-- representation in the VM context anyway (and would not
-- for example work nicely with the debugger).
elsif VM_Target /= No_VM then
if not GNAT_Mode then
Error_Pragma
("?pragma% ignored in this configuration");
end if;
-- Normal case where we do the pack action
else
if not Ignore then
Set_Is_Packed (Base_Type (Typ));
Set_Has_Non_Standard_Rep (Base_Type (Typ));
end if;
Set_Has_Pragma_Pack (Base_Type (Typ));
end if;
end if;
-- For record types, the pack is always effective
else pragma Assert (Is_Record_Type (Typ));
if not Rep_Item_Too_Late (Typ, N) then
-- Ignore pack request with warning in VM mode (skip warning
-- if we are compiling GNAT run time library).
if VM_Target /= No_VM then
if not GNAT_Mode then
Error_Pragma
("?pragma% ignored in this configuration");
end if;
-- Normal case of pack request active
else
Set_Is_Packed (Base_Type (Typ));
Set_Has_Pragma_Pack (Base_Type (Typ));
Set_Has_Non_Standard_Rep (Base_Type (Typ));
end if;
end if;
end if;
end Pack;
----------
-- Page --
----------
-- pragma Page;
-- There is nothing to do here, since we did all the processing for
-- this pragma in Par.Prag (so that it works properly even in syntax
-- only mode).
when Pragma_Page =>
null;
-------------
-- Passive --
-------------
-- pragma Passive [(PASSIVE_FORM)];
-- PASSIVE_FORM ::= Semaphore | No
when Pragma_Passive =>
GNAT_Pragma;
if Nkind (Parent (N)) /= N_Task_Definition then
Error_Pragma ("pragma% must be within task definition");
end if;
if Arg_Count /= 0 then
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
end if;
----------------------------------
-- Preelaborable_Initialization --
----------------------------------
-- pragma Preelaborable_Initialization (DIRECT_NAME);
when Pragma_Preelaborable_Initialization => Preelab_Init : declare
Ent : Entity_Id;
begin
Ada_2005_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
Check_First_Subtype (Arg1);
Ent := Entity (Get_Pragma_Arg (Arg1));
if not (Is_Private_Type (Ent)
or else
Is_Protected_Type (Ent)
or else
(Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)))
then
Error_Pragma_Arg
("pragma % can only be applied to private, formal derived or "
& "protected type",
Arg1);
end if;
-- Give an error if the pragma is applied to a protected type that
-- does not qualify (due to having entries, or due to components
-- that do not qualify).
if Is_Protected_Type (Ent)
and then not Has_Preelaborable_Initialization (Ent)
then
Error_Msg_N
("protected type & does not have preelaborable " &
"initialization", Ent);
-- Otherwise mark the type as definitely having preelaborable
-- initialization.
else
Set_Known_To_Have_Preelab_Init (Ent);
end if;
if Has_Pragma_Preelab_Init (Ent)
and then Warn_On_Redundant_Constructs
then
Error_Pragma ("?duplicate pragma%!");
else
Set_Has_Pragma_Preelab_Init (Ent);
end if;
end Preelab_Init;
--------------------
-- Persistent_BSS --
--------------------
-- pragma Persistent_BSS [(object_NAME)];
when Pragma_Persistent_BSS => Persistent_BSS : declare
Decl : Node_Id;
Ent : Entity_Id;
Prag : Node_Id;
begin
GNAT_Pragma;
Check_At_Most_N_Arguments (1);
-- Case of application to specific object (one argument)
if Arg_Count = 1 then
Check_Arg_Is_Library_Level_Local_Name (Arg1);
if not Is_Entity_Name (Get_Pragma_Arg (Arg1))
or else not
Ekind_In (Entity (Get_Pragma_Arg (Arg1)), E_Variable,
E_Constant)
then
Error_Pragma_Arg ("pragma% only applies to objects", Arg1);
end if;
Ent := Entity (Get_Pragma_Arg (Arg1));
Decl := Parent (Ent);
if Rep_Item_Too_Late (Ent, N) then
return;
end if;
if Present (Expression (Decl)) then
Error_Pragma_Arg
("object for pragma% cannot have initialization", Arg1);
end if;
if not Is_Potentially_Persistent_Type (Etype (Ent)) then
Error_Pragma_Arg
("object type for pragma% is not potentially persistent",
Arg1);
end if;
Check_Duplicate_Pragma (Ent);
Prag :=
Make_Linker_Section_Pragma
(Ent, Sloc (N), ".persistent.bss");
Insert_After (N, Prag);
Analyze (Prag);
-- Case of use as configuration pragma with no arguments
else
Check_Valid_Configuration_Pragma;
Persistent_BSS_Mode := True;
end if;
end Persistent_BSS;
-------------
-- Polling --
-------------
-- pragma Polling (ON | OFF);
when Pragma_Polling =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
-------------------
-- Postcondition --
-------------------
-- pragma Postcondition ([Check =>] Boolean_EXPRESSION
-- [,[Message =>] String_EXPRESSION]);
when Pragma_Postcondition => Postcondition : declare
In_Body : Boolean;
pragma Warnings (Off, In_Body);
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
Check_Optional_Identifier (Arg1, Name_Check);
-- All we need to do here is call the common check procedure,
-- the remainder of the processing is found in Sem_Ch6/Sem_Ch7.
Check_Precondition_Postcondition (In_Body);
end Postcondition;
------------------
-- Precondition --
------------------
-- pragma Precondition ([Check =>] Boolean_EXPRESSION
-- [,[Message =>] String_EXPRESSION]);
when Pragma_Precondition => Precondition : declare
In_Body : Boolean;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
Check_Optional_Identifier (Arg1, Name_Check);
Check_Precondition_Postcondition (In_Body);
-- If in spec, nothing more to do. If in body, then we convert the
-- pragma to pragma Check (Precondition, cond [, msg]). Note we do
-- this whether or not precondition checks are enabled. That works
-- fine since pragma Check will do this check, and will also
-- analyze the condition itself in the proper context.
if In_Body then
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Precondition)),
Make_Pragma_Argument_Association (Sloc (Arg1),
Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
if Arg_Count = 2 then
Append_To (Pragma_Argument_Associations (N),
Make_Pragma_Argument_Association (Sloc (Arg2),
Expression => Relocate_Node (Get_Pragma_Arg (Arg2))));
end if;
Analyze (N);
end if;
end Precondition;
---------------
-- Predicate --
---------------
-- pragma Predicate
-- ([Entity =>] type_LOCAL_NAME,
-- [Check =>] EXPRESSION);
when Pragma_Predicate => Predicate : declare
Type_Id : Node_Id;
Typ : Entity_Id;
Discard : Boolean;
pragma Unreferenced (Discard);
begin
GNAT_Pragma;
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Check);
Check_Arg_Is_Local_Name (Arg1);
Type_Id := Get_Pragma_Arg (Arg1);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type then
return;
end if;
-- The remaining processing is simply to link the pragma on to
-- the rep item chain, for processing when the type is frozen.
-- This is accomplished by a call to Rep_Item_Too_Late. We also
-- mark the type as having predicates.
Set_Has_Predicates (Typ);
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
end Predicate;
------------------
-- Preelaborate --
------------------
-- pragma Preelaborate [(library_unit_NAME)];
-- Set the flag Is_Preelaborated of program unit name entity
when Pragma_Preelaborate => Preelaborate : declare
Pa : constant Node_Id := Parent (N);
Pk : constant Node_Kind := Nkind (Pa);
Ent : Entity_Id;
begin
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
if Nkind (N) = N_Null_Statement then
return;
end if;
Ent := Find_Lib_Unit_Name;
Check_Duplicate_Pragma (Ent);
-- This filters out pragmas inside generic parent then
-- show up inside instantiation
if Present (Ent)
and then not (Pk = N_Package_Specification
and then Present (Generic_Parent (Pa)))
then
if not Debug_Flag_U then
Set_Is_Preelaborated (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end if;
end if;
end Preelaborate;
---------------------
-- Preelaborate_05 --
---------------------
-- pragma Preelaborate_05 [(library_unit_NAME)];
-- This pragma is useable only in GNAT_Mode, where it is used like
-- pragma Preelaborate but it is only effective in Ada 2005 mode
-- (otherwise it is ignored). This is used to implement AI-362 which
-- recategorizes some run-time packages in Ada 2005 mode.
when Pragma_Preelaborate_05 => Preelaborate_05 : declare
Ent : Entity_Id;
begin
GNAT_Pragma;
Check_Valid_Library_Unit_Pragma;
if not GNAT_Mode then
Error_Pragma ("pragma% only available in GNAT mode");
end if;
if Nkind (N) = N_Null_Statement then
return;
end if;
-- This is one of the few cases where we need to test the value of
-- Ada_Version_Explicit rather than Ada_Version (which is always
-- set to Ada_2012 in a predefined unit), we need to know the
-- explicit version set to know if this pragma is active.
if Ada_Version_Explicit >= Ada_2005 then
Ent := Find_Lib_Unit_Name;
Set_Is_Preelaborated (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end if;
end Preelaborate_05;
--------------
-- Priority --
--------------
-- pragma Priority (EXPRESSION);
when Pragma_Priority => Priority : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Check_No_Identifiers;
Check_Arg_Count (1);
-- Subprogram case
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Standard_Integer);
-- Must be static
if not Is_Static_Expression (Arg) then
Flag_Non_Static_Expr
("main subprogram priority is not static!", Arg);
raise Pragma_Exit;
-- If constraint error, then we already signalled an error
elsif Raises_Constraint_Error (Arg) then
null;
-- Otherwise check in range
else
declare
Val : constant Uint := Expr_Value (Arg);
begin
if Val < 0
or else Val > Expr_Value (Expression
(Parent (RTE (RE_Max_Priority))))
then
Error_Pragma_Arg
("main subprogram priority is out of range", Arg1);
end if;
end;
end if;
Set_Main_Priority
(Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
-- Load an arbitrary entity from System.Tasking to make sure
-- this package is implicitly with'ed, since we need to have
-- the tasking run-time active for the pragma Priority to have
-- any effect.
declare
Discard : Entity_Id;
pragma Warnings (Off, Discard);
begin
Discard := RTE (RE_Task_List);
end;
-- Task or Protected, must be of type Integer
elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
Arg := Get_Pragma_Arg (Arg1);
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
-- Expressions" in sem.ads.
Preanalyze_Spec_Expression (Arg, Standard_Integer);
if not Is_Static_Expression (Arg) then
Check_Restriction (Static_Priorities, Arg);
end if;
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
if Has_Pragma_Priority (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Pragma_Priority (P, True);
if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
-- exp_ch9 should use this ???
end if;
end if;
end Priority;
-----------------------------------
-- Priority_Specific_Dispatching --
-----------------------------------
-- pragma Priority_Specific_Dispatching (
-- policy_IDENTIFIER,
-- first_priority_EXPRESSION,
-- last_priority_EXPRESSION);
when Pragma_Priority_Specific_Dispatching =>
Priority_Specific_Dispatching : declare
Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
-- This is the entity System.Any_Priority;
DP : Character;
Lower_Bound : Node_Id;
Upper_Bound : Node_Id;
Lower_Val : Uint;
Upper_Val : Uint;
begin
Ada_2005_Pragma;
Check_Arg_Count (3);
Check_No_Identifiers;
Check_Arg_Is_Task_Dispatching_Policy (Arg1);
Check_Valid_Configuration_Pragma;
Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
DP := Fold_Upper (Name_Buffer (1));
Lower_Bound := Get_Pragma_Arg (Arg2);
Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
Lower_Val := Expr_Value (Lower_Bound);
Upper_Bound := Get_Pragma_Arg (Arg3);
Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
Upper_Val := Expr_Value (Upper_Bound);
-- It is not allowed to use Task_Dispatching_Policy and
-- Priority_Specific_Dispatching in the same partition.
if Task_Dispatching_Policy /= ' ' then
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma
("pragma% incompatible with Task_Dispatching_Policy#");
-- Check lower bound in range
elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
or else
Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
then
Error_Pragma_Arg
("first_priority is out of range", Arg2);
-- Check upper bound in range
elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
or else
Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
then
Error_Pragma_Arg
("last_priority is out of range", Arg3);
-- Check that the priority range is valid
elsif Lower_Val > Upper_Val then
Error_Pragma
("last_priority_expression must be greater than" &
" or equal to first_priority_expression");
-- Store the new policy, but always preserve System_Location since
-- we like the error message with the run-time name.
else
-- Check overlapping in the priority ranges specified in other
-- Priority_Specific_Dispatching pragmas within the same
-- partition. We can only check those we know about!
for J in
Specific_Dispatching.First .. Specific_Dispatching.Last
loop
if Specific_Dispatching.Table (J).First_Priority in
UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
or else Specific_Dispatching.Table (J).Last_Priority in
UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
then
Error_Msg_Sloc :=
Specific_Dispatching.Table (J).Pragma_Loc;
Error_Pragma
("priority range overlaps with "
& "Priority_Specific_Dispatching#");
end if;
end loop;
-- The use of Priority_Specific_Dispatching is incompatible
-- with Task_Dispatching_Policy.
if Task_Dispatching_Policy /= ' ' then
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma
("Priority_Specific_Dispatching incompatible "
& "with Task_Dispatching_Policy#");
end if;
-- The use of Priority_Specific_Dispatching forces ceiling
-- locking policy.
if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
Error_Msg_Sloc := Locking_Policy_Sloc;
Error_Pragma
("Priority_Specific_Dispatching incompatible "
& "with Locking_Policy#");
-- Set the Ceiling_Locking policy, but preserve System_Location
-- since we like the error message with the run time name.
else
Locking_Policy := 'C';
if Locking_Policy_Sloc /= System_Location then
Locking_Policy_Sloc := Loc;
end if;
end if;
-- Add entry in the table
Specific_Dispatching.Append
((Dispatching_Policy => DP,
First_Priority => UI_To_Int (Lower_Val),
Last_Priority => UI_To_Int (Upper_Val),
Pragma_Loc => Loc));
end if;
end Priority_Specific_Dispatching;
-------------
-- Profile --
-------------
-- pragma Profile (profile_IDENTIFIER);
-- profile_IDENTIFIER => Restricted | Ravenscar
when Pragma_Profile =>
Ada_2005_Pragma;
Check_Arg_Count (1);
Check_Valid_Configuration_Pragma;
Check_No_Identifiers;
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
if Chars (Argx) = Name_Ravenscar then
Set_Ravenscar_Profile (N);
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions
(Restricted,
N, Warn => Treat_Restrictions_As_Warnings);
elsif Chars (Argx) = Name_No_Implementation_Extensions then
Set_Profile_Restrictions
(No_Implementation_Extensions,
N, Warn => Treat_Restrictions_As_Warnings);
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
end;
----------------------
-- Profile_Warnings --
----------------------
-- pragma Profile_Warnings (profile_IDENTIFIER);
-- profile_IDENTIFIER => Restricted | Ravenscar
when Pragma_Profile_Warnings =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Valid_Configuration_Pragma;
Check_No_Identifiers;
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
if Chars (Argx) = Name_Ravenscar then
Set_Profile_Restrictions (Ravenscar, N, Warn => True);
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => True);
elsif Chars (Argx) = Name_No_Implementation_Extensions then
Set_Profile_Restrictions
(No_Implementation_Extensions, N, Warn => True);
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
end;
--------------------------
-- Propagate_Exceptions --
--------------------------
-- pragma Propagate_Exceptions;
-- Note: this pragma is obsolete and has no effect
when Pragma_Propagate_Exceptions =>
GNAT_Pragma;
Check_Arg_Count (0);
if In_Extended_Main_Source_Unit (N) then
Propagate_Exceptions := True;
end if;
------------------
-- Psect_Object --
------------------
-- pragma Psect_Object (
-- [Internal =>] LOCAL_NAME,
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Size =>] EXTERNAL_SYMBOL]);
when Pragma_Psect_Object | Pragma_Common_Object =>
Psect_Object : declare
Args : Args_List (1 .. 3);
Names : constant Name_List (1 .. 3) := (
Name_Internal,
Name_External,
Name_Size);
Internal : Node_Id renames Args (1);
External : Node_Id renames Args (2);
Size : Node_Id renames Args (3);
Def_Id : Entity_Id;
procedure Check_Too_Long (Arg : Node_Id);
-- Posts message if the argument is an identifier with more
-- than 31 characters, or a string literal with more than
-- 31 characters, and we are operating under VMS
--------------------
-- Check_Too_Long --
--------------------
procedure Check_Too_Long (Arg : Node_Id) is
X : constant Node_Id := Original_Node (Arg);
begin
if not Nkind_In (X, N_String_Literal, N_Identifier) then
Error_Pragma_Arg
("inappropriate argument for pragma %", Arg);
end if;
if OpenVMS_On_Target then
if (Nkind (X) = N_String_Literal
and then String_Length (Strval (X)) > 31)
or else
(Nkind (X) = N_Identifier
and then Length_Of_Name (Chars (X)) > 31)
then
Error_Pragma_Arg
("argument for pragma % is longer than 31 characters",
Arg);
end if;
end if;
end Check_Too_Long;
-- Start of processing for Common_Object/Psect_Object
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Process_Extended_Import_Export_Internal_Arg (Internal);
Def_Id := Entity (Internal);
if not Ekind_In (Def_Id, E_Constant, E_Variable) then
Error_Pragma_Arg
("pragma% must designate an object", Internal);
end if;
Check_Too_Long (Internal);
if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
Error_Pragma_Arg
("cannot use pragma% for imported/exported object",
Internal);
end if;
if Is_Concurrent_Type (Etype (Internal)) then
Error_Pragma_Arg
("cannot specify pragma % for task/protected object",
Internal);
end if;
if Has_Rep_Pragma (Def_Id, Name_Common_Object)
or else
Has_Rep_Pragma (Def_Id, Name_Psect_Object)
then
Error_Msg_N ("?duplicate Common/Psect_Object pragma", N);
end if;
if Ekind (Def_Id) = E_Constant then
Error_Pragma_Arg
("cannot specify pragma % for a constant", Internal);
end if;
if Is_Record_Type (Etype (Internal)) then
declare
Ent : Entity_Id;
Decl : Entity_Id;
begin
Ent := First_Entity (Etype (Internal));
while Present (Ent) loop
Decl := Declaration_Node (Ent);
if Ekind (Ent) = E_Component
and then Nkind (Decl) = N_Component_Declaration
and then Present (Expression (Decl))
and then Warn_On_Export_Import
then
Error_Msg_N
("?object for pragma % has defaults", Internal);
exit;
else
Next_Entity (Ent);
end if;
end loop;
end;
end if;
if Present (Size) then
Check_Too_Long (Size);
end if;
if Present (External) then
Check_Arg_Is_External_Name (External);
Check_Too_Long (External);
end if;
-- If all error tests pass, link pragma on to the rep item chain
Record_Rep_Item (Def_Id, N);
end Psect_Object;
----------
-- Pure --
----------
-- pragma Pure [(library_unit_NAME)];
when Pragma_Pure => Pure : declare
Ent : Entity_Id;
begin
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
if Nkind (N) = N_Null_Statement then
return;
end if;
Ent := Find_Lib_Unit_Name;
Set_Is_Pure (Ent);
Set_Has_Pragma_Pure (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end Pure;
-------------
-- Pure_05 --
-------------
-- pragma Pure_05 [(library_unit_NAME)];
-- This pragma is useable only in GNAT_Mode, where it is used like
-- pragma Pure but it is only effective in Ada 2005 mode (otherwise
-- it is ignored). It may be used after a pragma Preelaborate, in
-- which case it overrides the effect of the pragma Preelaborate.
-- This is used to implement AI-362 which recategorizes some run-time
-- packages in Ada 2005 mode.
when Pragma_Pure_05 => Pure_05 : declare
Ent : Entity_Id;
begin
GNAT_Pragma;
Check_Valid_Library_Unit_Pragma;
if not GNAT_Mode then
Error_Pragma ("pragma% only available in GNAT mode");
end if;
if Nkind (N) = N_Null_Statement then
return;
end if;
-- This is one of the few cases where we need to test the value of
-- Ada_Version_Explicit rather than Ada_Version (which is always
-- set to Ada_2012 in a predefined unit), we need to know the
-- explicit version set to know if this pragma is active.
if Ada_Version_Explicit >= Ada_2005 then
Ent := Find_Lib_Unit_Name;
Set_Is_Preelaborated (Ent, False);
Set_Is_Pure (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
end if;
end Pure_05;
-------------------
-- Pure_Function --
-------------------
-- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
when Pragma_Pure_Function => Pure_Function : declare
E_Id : Node_Id;
E : Entity_Id;
Def_Id : Entity_Id;
Effective : Boolean := False;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
E_Id := Get_Pragma_Arg (Arg1);
if Error_Posted (E_Id) then
return;
end if;
-- Loop through homonyms (overloadings) of referenced entity
E := Entity (E_Id);
if Present (E) then
loop
Def_Id := Get_Base_Subprogram (E);
if not Ekind_In (Def_Id, E_Function,
E_Generic_Function,
E_Operator)
then
Error_Pragma_Arg
("pragma% requires a function name", Arg1);
end if;
Set_Is_Pure (Def_Id);
if not Has_Pragma_Pure_Function (Def_Id) then
Set_Has_Pragma_Pure_Function (Def_Id);
Effective := True;
end if;
exit when From_Aspect_Specification (N);
E := Homonym (E);
exit when No (E) or else Scope (E) /= Current_Scope;
end loop;
if not Effective
and then Warn_On_Redundant_Constructs
then
Error_Msg_NE
("pragma Pure_Function on& is redundant?",
N, Entity (E_Id));
end if;
end if;
end Pure_Function;
--------------------
-- Queuing_Policy --
--------------------
-- pragma Queuing_Policy (policy_IDENTIFIER);
when Pragma_Queuing_Policy => declare
QP : Character;
begin
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Queuing_Policy (Arg1);
Check_Valid_Configuration_Pragma;
Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
QP := Fold_Upper (Name_Buffer (1));
if Queuing_Policy /= ' '
and then Queuing_Policy /= QP
then
Error_Msg_Sloc := Queuing_Policy_Sloc;
Error_Pragma ("queuing policy incompatible with policy#");
-- Set new policy, but always preserve System_Location since we
-- like the error message with the run time name.
else
Queuing_Policy := QP;
if Queuing_Policy_Sloc /= System_Location then
Queuing_Policy_Sloc := Loc;
end if;
end if;
end;
-----------------------
-- Relative_Deadline --
-----------------------
-- pragma Relative_Deadline (time_span_EXPRESSION);
when Pragma_Relative_Deadline => Relative_Deadline : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Ada_2005_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Arg := Get_Pragma_Arg (Arg1);
-- The expression must be analyzed in the special manner described
-- in "Handling of Default and Per-Object Expressions" in sem.ads.
Preanalyze_Spec_Expression (Arg, RTE (RE_Time_Span));
-- Subprogram case
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
-- Tasks
elsif Nkind (P) = N_Task_Definition then
null;
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
if Has_Relative_Deadline_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Relative_Deadline_Pragma (P, True);
if Nkind (P) = N_Task_Definition then
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end if;
end Relative_Deadline;
---------------------------
-- Remote_Call_Interface --
---------------------------
-- pragma Remote_Call_Interface [(library_unit_NAME)];
when Pragma_Remote_Call_Interface => Remote_Call_Interface : declare
Cunit_Node : Node_Id;
Cunit_Ent : Entity_Id;
K : Node_Kind;
begin
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
if Nkind (N) = N_Null_Statement then
return;
end if;
Cunit_Node := Cunit (Current_Sem_Unit);
K := Nkind (Unit (Cunit_Node));
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
if K = N_Package_Declaration
or else K = N_Generic_Package_Declaration
or else K = N_Subprogram_Declaration
or else K = N_Generic_Subprogram_Declaration
or else (K = N_Subprogram_Body
and then Acts_As_Spec (Unit (Cunit_Node)))
then
null;
else
Error_Pragma (
"pragma% must apply to package or subprogram declaration");
end if;
Set_Is_Remote_Call_Interface (Cunit_Ent);
end Remote_Call_Interface;
------------------
-- Remote_Types --
------------------
-- pragma Remote_Types [(library_unit_NAME)];
when Pragma_Remote_Types => Remote_Types : declare
Cunit_Node : Node_Id;
Cunit_Ent : Entity_Id;
begin
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
if Nkind (N) = N_Null_Statement then
return;
end if;
Cunit_Node := Cunit (Current_Sem_Unit);
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
N_Generic_Package_Declaration)
then
Error_Pragma
("pragma% can only apply to a package declaration");
end if;
Set_Is_Remote_Types (Cunit_Ent);
end Remote_Types;
---------------
-- Ravenscar --
---------------
-- pragma Ravenscar;
when Pragma_Ravenscar =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Set_Ravenscar_Profile (N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
end if;
-------------------------
-- Restricted_Run_Time --
-------------------------
-- pragma Restricted_Run_Time;
when Pragma_Restricted_Run_Time =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Set_Profile_Restrictions
(Restricted, N, Warn => Treat_Restrictions_As_Warnings);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("pragma Restricted_Run_Time is an obsolescent feature?", N);
Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
end if;
------------------
-- Restrictions --
------------------
-- pragma Restrictions (RESTRICTION {, RESTRICTION});
-- RESTRICTION ::=
-- restriction_IDENTIFIER
-- | restriction_parameter_IDENTIFIER => EXPRESSION
when Pragma_Restrictions =>
Process_Restrictions_Or_Restriction_Warnings
(Warn => Treat_Restrictions_As_Warnings);
--------------------------
-- Restriction_Warnings --
--------------------------
-- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
-- RESTRICTION ::=
-- restriction_IDENTIFIER
-- | restriction_parameter_IDENTIFIER => EXPRESSION
when Pragma_Restriction_Warnings =>
GNAT_Pragma;
Process_Restrictions_Or_Restriction_Warnings (Warn => True);
----------------
-- Reviewable --
----------------
-- pragma Reviewable;
when Pragma_Reviewable =>
Check_Ada_83_Warning;
Check_Arg_Count (0);
-- Call dummy debugging function rv. This is done to assist 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.
rv;
--------------------------
-- Short_Circuit_And_Or --
--------------------------
when Pragma_Short_Circuit_And_Or =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Short_Circuit_And_Or := True;
-------------------
-- Share_Generic --
-------------------
-- pragma Share_Generic (NAME {, NAME});
when Pragma_Share_Generic =>
GNAT_Pragma;
Process_Generic_List;
------------
-- Shared --
------------
-- pragma Shared (LOCAL_NAME);
when Pragma_Shared =>
GNAT_Pragma;
Process_Atomic_Shared_Volatile;
--------------------
-- Shared_Passive --
--------------------
-- pragma Shared_Passive [(library_unit_NAME)];
-- Set the flag Is_Shared_Passive of program unit name entity
when Pragma_Shared_Passive => Shared_Passive : declare
Cunit_Node : Node_Id;
Cunit_Ent : Entity_Id;
begin
Check_Ada_83_Warning;
Check_Valid_Library_Unit_Pragma;
if Nkind (N) = N_Null_Statement then
return;
end if;
Cunit_Node := Cunit (Current_Sem_Unit);
Cunit_Ent := Cunit_Entity (Current_Sem_Unit);
if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
N_Generic_Package_Declaration)
then
Error_Pragma
("pragma% can only apply to a package declaration");
end if;
Set_Is_Shared_Passive (Cunit_Ent);
end Shared_Passive;
-----------------------
-- Short_Descriptors --
-----------------------
-- pragma Short_Descriptors;
when Pragma_Short_Descriptors =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Short_Descriptors := True;
----------------------
-- Source_File_Name --
----------------------
-- There are five forms for this pragma:
-- pragma Source_File_Name (
-- [UNIT_NAME =>] unit_NAME,
-- BODY_FILE_NAME => STRING_LITERAL
-- [, [INDEX =>] INTEGER_LITERAL]);
-- pragma Source_File_Name (
-- [UNIT_NAME =>] unit_NAME,
-- SPEC_FILE_NAME => STRING_LITERAL
-- [, [INDEX =>] INTEGER_LITERAL]);
-- pragma Source_File_Name (
-- BODY_FILE_NAME => STRING_LITERAL
-- [, DOT_REPLACEMENT => STRING_LITERAL]
-- [, CASING => CASING_SPEC]);
-- pragma Source_File_Name (
-- SPEC_FILE_NAME => STRING_LITERAL
-- [, DOT_REPLACEMENT => STRING_LITERAL]
-- [, CASING => CASING_SPEC]);
-- pragma Source_File_Name (
-- SUBUNIT_FILE_NAME => STRING_LITERAL
-- [, DOT_REPLACEMENT => STRING_LITERAL]
-- [, CASING => CASING_SPEC]);
-- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
-- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
-- Source_File_Name (SFN), however their usage is exclusive: SFN can
-- only be used when no project file is used, while SFNP can only be
-- used when a project file is used.
-- No processing here. Processing was completed during parsing, since
-- we need to have file names set as early as possible. Units are
-- loaded well before semantic processing starts.
-- The only processing we defer to this point is the check for
-- correct placement.
when Pragma_Source_File_Name =>
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
------------------------------
-- Source_File_Name_Project --
------------------------------
-- See Source_File_Name for syntax
-- No processing here. Processing was completed during parsing, since
-- we need to have file names set as early as possible. Units are
-- loaded well before semantic processing starts.
-- The only processing we defer to this point is the check for
-- correct placement.
when Pragma_Source_File_Name_Project =>
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
-- Check that a pragma Source_File_Name_Project is used only in a
-- configuration pragmas file.
-- Pragmas Source_File_Name_Project should only be generated by
-- the Project Manager in configuration pragmas files.
-- This is really an ugly test. It seems to depend on some
-- accidental and undocumented property. At the very least it
-- needs to be documented, but it would be better to have a
-- clean way of testing if we are in a configuration file???
if Present (Parent (N)) then
Error_Pragma
("pragma% can only appear in a configuration pragmas file");
end if;
----------------------
-- Source_Reference --
----------------------
-- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
-- Nothing to do, all processing completed in Par.Prag, since we need
-- the information for possible parser messages that are output.
when Pragma_Source_Reference =>
GNAT_Pragma;
--------------------------------
-- Static_Elaboration_Desired --
--------------------------------
-- pragma Static_Elaboration_Desired (DIRECT_NAME);
when Pragma_Static_Elaboration_Desired =>
GNAT_Pragma;
Check_At_Most_N_Arguments (1);
if Is_Compilation_Unit (Current_Scope)
and then Ekind (Current_Scope) = E_Package
then
Set_Static_Elaboration_Desired (Current_Scope, True);
else
Error_Pragma ("pragma% must apply to a library-level package");
end if;
------------------
-- Storage_Size --
------------------
-- pragma Storage_Size (EXPRESSION);
when Pragma_Storage_Size => Storage_Size : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Check_No_Identifiers;
Check_Arg_Count (1);
-- The expression must be analyzed in the special manner described
-- in "Handling of Default Expressions" in sem.ads.
Arg := Get_Pragma_Arg (Arg1);
Preanalyze_Spec_Expression (Arg, Any_Integer);
if not Is_Static_Expression (Arg) then
Check_Restriction (Static_Storage_Size, Arg);
end if;
if Nkind (P) /= N_Task_Definition then
Pragma_Misplaced;
return;
else
if Has_Storage_Size_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Storage_Size_Pragma (P, True);
end if;
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
-- ??? exp_ch9 should use this!
end if;
end Storage_Size;
------------------
-- Storage_Unit --
------------------
-- pragma Storage_Unit (NUMERIC_LITERAL);
-- Only permitted argument is System'Storage_Unit value
when Pragma_Storage_Unit =>
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Integer_Literal (Arg1);
if Intval (Get_Pragma_Arg (Arg1)) /=
UI_From_Int (Ttypes.System_Storage_Unit)
then
Error_Msg_Uint_1 := UI_From_Int (Ttypes.System_Storage_Unit);
Error_Pragma_Arg
("the only allowed argument for pragma% is ^", Arg1);
end if;
--------------------
-- Stream_Convert --
--------------------
-- pragma Stream_Convert (
-- [Entity =>] type_LOCAL_NAME,
-- [Read =>] function_NAME,
-- [Write =>] function NAME);
when Pragma_Stream_Convert => Stream_Convert : declare
procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
-- Check that the given argument is the name of a local function
-- of one argument that is not overloaded earlier in the current
-- local scope. A check is also made that the argument is a
-- function with one parameter.
--------------------------------------
-- Check_OK_Stream_Convert_Function --
--------------------------------------
procedure Check_OK_Stream_Convert_Function (Arg : Node_Id) is
Ent : Entity_Id;
begin
Check_Arg_Is_Local_Name (Arg);
Ent := Entity (Get_Pragma_Arg (Arg));
if Has_Homonym (Ent) then
Error_Pragma_Arg
("argument for pragma% may not be overloaded", Arg);
end if;
if Ekind (Ent) /= E_Function
or else No (First_Formal (Ent))
or else Present (Next_Formal (First_Formal (Ent)))
then
Error_Pragma_Arg
("argument for pragma% must be" &
" function of one argument", Arg);
end if;
end Check_OK_Stream_Convert_Function;
-- Start of processing for Stream_Convert
begin
GNAT_Pragma;
Check_Arg_Order ((Name_Entity, Name_Read, Name_Write));
Check_Arg_Count (3);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Read);
Check_Optional_Identifier (Arg3, Name_Write);
Check_Arg_Is_Local_Name (Arg1);
Check_OK_Stream_Convert_Function (Arg2);
Check_OK_Stream_Convert_Function (Arg3);
declare
Typ : constant Entity_Id :=
Underlying_Type (Entity (Get_Pragma_Arg (Arg1)));
Read : constant Entity_Id := Entity (Get_Pragma_Arg (Arg2));
Write : constant Entity_Id := Entity (Get_Pragma_Arg (Arg3));
begin
Check_First_Subtype (Arg1);
-- Check for too early or too late. Note that we don't enforce
-- the rule about primitive operations in this case, since, as
-- is the case for explicit stream attributes themselves, these
-- restrictions are not appropriate. Note that the chaining of
-- the pragma by Rep_Item_Too_Late is actually the critical
-- processing done for this pragma.
if Rep_Item_Too_Early (Typ, N)
or else
Rep_Item_Too_Late (Typ, N, FOnly => True)
then
return;
end if;
-- Return if previous error
if Etype (Typ) = Any_Type
or else
Etype (Read) = Any_Type
or else
Etype (Write) = Any_Type
then
return;
end if;
-- Error checks
if Underlying_Type (Etype (Read)) /= Typ then
Error_Pragma_Arg
("incorrect return type for function&", Arg2);
end if;
if Underlying_Type (Etype (First_Formal (Write))) /= Typ then
Error_Pragma_Arg
("incorrect parameter type for function&", Arg3);
end if;
if Underlying_Type (Etype (First_Formal (Read))) /=
Underlying_Type (Etype (Write))
then
Error_Pragma_Arg
("result type of & does not match Read parameter type",
Arg3);
end if;
end;
end Stream_Convert;
-------------------------
-- Style_Checks (GNAT) --
-------------------------
-- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
-- This is processed by the parser since some of the style checks
-- take place during source scanning and parsing. This means that
-- we don't need to issue error messages here.
when Pragma_Style_Checks => Style_Checks : declare
A : constant Node_Id := Get_Pragma_Arg (Arg1);
S : String_Id;
C : Char_Code;
begin
GNAT_Pragma;
Check_No_Identifiers;
-- Two argument form
if Arg_Count = 2 then
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
declare
E_Id : Node_Id;
E : Entity_Id;
begin
E_Id := Get_Pragma_Arg (Arg2);
Analyze (E_Id);
if not Is_Entity_Name (E_Id) then
Error_Pragma_Arg
("second argument of pragma% must be entity name",
Arg2);
end if;
E := Entity (E_Id);
if E = Any_Id then
return;
else
loop
Set_Suppress_Style_Checks (E,
(Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
exit when No (Homonym (E));
E := Homonym (E);
end loop;
end if;
end;
-- One argument form
else
Check_Arg_Count (1);
if Nkind (A) = N_String_Literal then
S := Strval (A);
declare
Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
J : Natural;
begin
J := 1;
loop
C := Get_String_Char (S, Int (J));
exit when not In_Character_Range (C);
Options (J) := Get_Character (C);
-- If at end of string, set options. As per discussion
-- above, no need to check for errors, since we issued
-- them in the parser.
if J = Slen then
Set_Style_Check_Options (Options);
exit;
end if;
J := J + 1;
end loop;
end;
elsif Nkind (A) = N_Identifier then
if Chars (A) = Name_All_Checks then
if GNAT_Mode then
Set_GNAT_Style_Check_Options;
else
Set_Default_Style_Check_Options;
end if;
elsif Chars (A) = Name_On then
Style_Check := True;
elsif Chars (A) = Name_Off then
Style_Check := False;
end if;
end if;
end if;
end Style_Checks;
--------------
-- Subtitle --
--------------
-- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
when Pragma_Subtitle =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Subtitle);
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
Store_Note (N);
--------------
-- Suppress --
--------------
-- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
when Pragma_Suppress =>
Process_Suppress_Unsuppress (True);
------------------
-- Suppress_All --
------------------
-- pragma Suppress_All;
-- The only check made here is that the pragma has no arguments.
-- There are no placement rules, and the processing required (setting
-- the Has_Pragma_Suppress_All flag in the compilation unit node was
-- taken care of by the parser). Process_Compilation_Unit_Pragmas
-- then creates and inserts a pragma Suppress (All_Checks).
when Pragma_Suppress_All =>
GNAT_Pragma;
Check_Arg_Count (0);
-------------------------
-- Suppress_Debug_Info --
-------------------------
-- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
when Pragma_Suppress_Debug_Info =>
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
----------------------------------
-- Suppress_Exception_Locations --
----------------------------------
-- pragma Suppress_Exception_Locations;
when Pragma_Suppress_Exception_Locations =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Exception_Locations_Suppressed := True;
-----------------------------
-- Suppress_Initialization --
-----------------------------
-- pragma Suppress_Initialization ([Entity =>] type_Name);
when Pragma_Suppress_Initialization => Suppress_Init : declare
E_Id : Node_Id;
E : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
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);
if not Is_Type (E) then
Error_Pragma_Arg ("pragma% requires type or subtype", Arg1);
end if;
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N, FOnly => True)
then
return;
end if;
-- For incomplete/private type, set flag on full view
if Is_Incomplete_Or_Private_Type (E) then
if No (Full_View (Base_Type (E))) then
Error_Pragma_Arg
("argument of pragma% cannot be an incomplete type", Arg1);
else
Set_Suppress_Initialization (Full_View (Base_Type (E)));
end if;
-- For first subtype, set flag on base type
elsif Is_First_Subtype (E) then
Set_Suppress_Initialization (Base_Type (E));
-- For other than first subtype, set flag on subtype itself
else
Set_Suppress_Initialization (E);
end if;
end Suppress_Init;
-----------------
-- System_Name --
-----------------
-- pragma System_Name (DIRECT_NAME);
-- Syntax check: one argument, which must be the identifier GNAT or
-- the identifier GCC, no other identifiers are acceptable.
when Pragma_System_Name =>
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
-----------------------------
-- Task_Dispatching_Policy --
-----------------------------
-- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
when Pragma_Task_Dispatching_Policy => declare
DP : Character;
begin
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Task_Dispatching_Policy (Arg1);
Check_Valid_Configuration_Pragma;
Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
DP := Fold_Upper (Name_Buffer (1));
if Task_Dispatching_Policy /= ' '
and then Task_Dispatching_Policy /= DP
then
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma
("task dispatching policy incompatible with policy#");
-- Set new policy, but always preserve System_Location since we
-- like the error message with the run time name.
else
Task_Dispatching_Policy := DP;
if Task_Dispatching_Policy_Sloc /= System_Location then
Task_Dispatching_Policy_Sloc := Loc;
end if;
end if;
end;
---------------
-- Task_Info --
---------------
-- pragma Task_Info (EXPRESSION);
when Pragma_Task_Info => Task_Info : declare
P : constant Node_Id := Parent (N);
begin
GNAT_Pragma;
if Nkind (P) /= N_Task_Definition then
Error_Pragma ("pragma% must appear in task definition");
end if;
Check_No_Identifiers;
Check_Arg_Count (1);
Analyze_And_Resolve
(Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
return;
end if;
if Has_Task_Info_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Task_Info_Pragma (P, True);
end if;
end Task_Info;
---------------
-- Task_Name --
---------------
-- pragma Task_Name (string_EXPRESSION);
when Pragma_Task_Name => Task_Name : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
begin
Check_No_Identifiers;
Check_Arg_Count (1);
Arg := Get_Pragma_Arg (Arg1);
-- The expression is used in the call to Create_Task, and must be
-- expanded there, not in the context of the current spec. It must
-- however be analyzed to capture global references, in case it
-- appears in a generic context.
Preanalyze_And_Resolve (Arg, Standard_String);
if Nkind (P) /= N_Task_Definition then
Pragma_Misplaced;
end if;
if Has_Task_Name_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
Set_Has_Task_Name_Pragma (P, True);
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end Task_Name;
------------------
-- Task_Storage --
------------------
-- pragma Task_Storage (
-- [Task_Type =>] LOCAL_NAME,
-- [Top_Guard =>] static_integer_EXPRESSION);
when Pragma_Task_Storage => Task_Storage : declare
Args : Args_List (1 .. 2);
Names : constant Name_List (1 .. 2) := (
Name_Task_Type,
Name_Top_Guard);
Task_Type : Node_Id renames Args (1);
Top_Guard : Node_Id renames Args (2);
Ent : Entity_Id;
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
if No (Task_Type) then
Error_Pragma
("missing task_type argument for pragma%");
end if;
Check_Arg_Is_Local_Name (Task_Type);
Ent := Entity (Task_Type);
if not Is_Task_Type (Ent) then
Error_Pragma_Arg
("argument for pragma% must be task type", Task_Type);
end if;
if No (Top_Guard) then
Error_Pragma_Arg
("pragma% takes two arguments", Task_Type);
else
Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
end if;
Check_First_Subtype (Task_Type);
if Rep_Item_Too_Late (Ent, N) then
raise Pragma_Exit;
end if;
end Task_Storage;
---------------
-- Test_Case --
---------------
-- pragma Test_Case ([Name =>] Static_String_EXPRESSION
-- ,[Mode =>] MODE_TYPE
-- [, Requires => Boolean_EXPRESSION]
-- [, Ensures => Boolean_EXPRESSION]);
-- MODE_TYPE ::= Nominal | Robustness
when Pragma_Test_Case => Test_Case : declare
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Check_Arg_Order
((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
Check_Optional_Identifier (Arg1, Name_Name);
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
Check_Optional_Identifier (Arg2, Name_Mode);
Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
if Arg_Count = 4 then
Check_Identifier (Arg3, Name_Requires);
Check_Identifier (Arg4, Name_Ensures);
elsif Arg_Count = 3 then
Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
end if;
Check_Test_Case;
end Test_Case;
--------------------------
-- Thread_Local_Storage --
--------------------------
-- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
Id : Node_Id;
E : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
Id := Get_Pragma_Arg (Arg1);
Analyze (Id);
if not Is_Entity_Name (Id)
or else Ekind (Entity (Id)) /= E_Variable
then
Error_Pragma_Arg ("local variable name required", Arg1);
end if;
E := Entity (Id);
if Rep_Item_Too_Early (E, N)
or else Rep_Item_Too_Late (E, N)
then
raise Pragma_Exit;
end if;
Set_Has_Pragma_Thread_Local_Storage (E);
Set_Has_Gigi_Rep_Item (E);
end Thread_Local_Storage;
----------------
-- Time_Slice --
----------------
-- pragma Time_Slice (static_duration_EXPRESSION);
when Pragma_Time_Slice => Time_Slice : declare
Val : Ureal;
Nod : Node_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_In_Main_Program;
Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
if not Error_Posted (Arg1) then
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
and then Pragma_Name (Nod) = Name_Time_Slice
then
Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
end if;
Next (Nod);
end loop;
end if;
-- Process only if in main unit
if Get_Source_Unit (Loc) = Main_Unit then
Opt.Time_Slice_Set := True;
Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
if Val <= Ureal_0 then
Opt.Time_Slice_Value := 0;
elsif Val > UR_From_Uint (UI_From_Int (1000)) then
Opt.Time_Slice_Value := 1_000_000_000;
else
Opt.Time_Slice_Value :=
UI_To_Int (UR_To_Uint (Val * UI_From_Int (1_000_000)));
end if;
end if;
end Time_Slice;
-----------
-- Title --
-----------
-- pragma Title (TITLING_OPTION [, TITLING OPTION]);
-- TITLING_OPTION ::=
-- [Title =>] STRING_LITERAL
-- | [Subtitle =>] STRING_LITERAL
when Pragma_Title => Title : declare
Args : Args_List (1 .. 2);
Names : constant Name_List (1 .. 2) := (
Name_Title,
Name_Subtitle);
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
Store_Note (N);
for J in 1 .. 2 loop
if Present (Args (J)) then
Check_Arg_Is_Static_Expression (Args (J), Standard_String);
end if;
end loop;
end Title;
---------------------
-- Unchecked_Union --
---------------------
-- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
when Pragma_Unchecked_Union => Unchecked_Union : declare
Assoc : constant Node_Id := Arg1;
Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
Typ : Entity_Id;
Discr : Entity_Id;
Tdef : Node_Id;
Clist : Node_Id;
Vpart : Node_Id;
Comp : Node_Id;
Variant : Node_Id;
begin
Ada_2005_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
if Typ = Any_Type
or else Rep_Item_Too_Early (Typ, N)
then
return;
else
Typ := Underlying_Type (Typ);
end if;
if Rep_Item_Too_Late (Typ, N) then
return;
end if;
Check_First_Subtype (Arg1);
-- Note remaining cases are references to a type in the current
-- declarative part. If we find an error, we post the error on
-- the relevant type declaration at an appropriate point.
if not Is_Record_Type (Typ) then
Error_Msg_N ("Unchecked_Union must be record type", Typ);
return;
elsif Is_Tagged_Type (Typ) then
Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
return;
elsif not Has_Discriminants (Typ) then
Error_Msg_N
("Unchecked_Union must have one discriminant", Typ);
return;
-- Note: in previous versions of GNAT we used to check for limited
-- types and give an error, but in fact the standard does allow
-- Unchecked_Union on limited types, so this check was removed.
-- Proceed with basic error checks completed
else
Discr := First_Discriminant (Typ);
while Present (Discr) loop
if No (Discriminant_Default_Value (Discr)) then
Error_Msg_N
("Unchecked_Union discriminant must have default value",
Discr);
end if;
Next_Discriminant (Discr);
end loop;
Tdef := Type_Definition (Declaration_Node (Typ));
Clist := Component_List (Tdef);
Comp := First (Component_Items (Clist));
while Present (Comp) loop
Check_Component (Comp, Typ);
Next (Comp);
end loop;
if No (Clist) or else No (Variant_Part (Clist)) then
Error_Msg_N
("Unchecked_Union must have variant part",
Tdef);
return;
end if;
Vpart := Variant_Part (Clist);
Variant := First (Variants (Vpart));
while Present (Variant) loop
Check_Variant (Variant, Typ);
Next (Variant);
end loop;
end if;
Set_Is_Unchecked_Union (Typ);
Set_Convention (Typ, Convention_C);
Set_Has_Unchecked_Union (Base_Type (Typ));
Set_Is_Unchecked_Union (Base_Type (Typ));
end Unchecked_Union;
------------------------
-- Unimplemented_Unit --
------------------------
-- pragma Unimplemented_Unit;
-- Note: this only gives an error if we are generating code, or if
-- we are in a generic library unit (where the pragma appears in the
-- body, not in the spec).
when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
Cunitent : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Loc));
Ent_Kind : constant Entity_Kind :=
Ekind (Cunitent);
begin
GNAT_Pragma;
Check_Arg_Count (0);
if Operating_Mode = Generate_Code
or else Ent_Kind = E_Generic_Function
or else Ent_Kind = E_Generic_Procedure
or else Ent_Kind = E_Generic_Package
then
Get_Name_String (Chars (Cunitent));
Set_Casing (Mixed_Case);
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Str (" is not supported in this configuration");
Write_Eol;
raise Unrecoverable_Error;
end if;
end Unimplemented_Unit;
------------------------
-- Universal_Aliasing --
------------------------
-- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
when Pragma_Universal_Aliasing => Universal_Alias : declare
E_Id : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
E_Id := Entity (Get_Pragma_Arg (Arg1));
if E_Id = Any_Type then
return;
elsif No (E_Id) or else not Is_Type (E_Id) then
Error_Pragma_Arg ("pragma% requires type", Arg1);
end if;
Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
end Universal_Alias;
--------------------
-- Universal_Data --
--------------------
-- pragma Universal_Data [(library_unit_NAME)];
when Pragma_Universal_Data =>
GNAT_Pragma;
-- If this is a configuration pragma, then set the universal
-- addressing option, otherwise confirm that the pragma satisfies
-- the requirements of library unit pragma placement and leave it
-- to the GNAAMP back end to detect the pragma (avoids transitive
-- setting of the option due to withed units).
if Is_Configuration_Pragma then
Universal_Addressing_On_AAMP := True;
else
Check_Valid_Library_Unit_Pragma;
end if;
if not AAMP_On_Target then
Error_Pragma ("?pragma% ignored (applies only to AAMP)");
end if;
----------------
-- Unmodified --
----------------
-- pragma Unmodified (local_Name {, local_Name});
when Pragma_Unmodified => Unmodified : declare
Arg_Node : Node_Id;
Arg_Expr : Node_Id;
Arg_Ent : Entity_Id;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
-- Loop through arguments
Arg_Node := Arg1;
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
-- Note: the analyze call done by Check_Arg_Is_Local_Name will
-- in fact generate reference, so that the entity will have a
-- reference, which will inhibit any warnings about it not
-- being referenced, and also properly show up in the ali file
-- as a reference. But this reference is recorded before the
-- Has_Pragma_Unreferenced flag is set, so that no warning is
-- generated for this reference.
Check_Arg_Is_Local_Name (Arg_Node);
Arg_Expr := Get_Pragma_Arg (Arg_Node);
if Is_Entity_Name (Arg_Expr) then
Arg_Ent := Entity (Arg_Expr);
if not Is_Assignable (Arg_Ent) then
Error_Pragma_Arg
("pragma% can only be applied to a variable",
Arg_Expr);
else
Set_Has_Pragma_Unmodified (Arg_Ent);
end if;
end if;
Next (Arg_Node);
end loop;
end Unmodified;
------------------
-- Unreferenced --
------------------
-- pragma Unreferenced (local_Name {, local_Name});
-- or when used in a context clause:
-- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
when Pragma_Unreferenced => Unreferenced : declare
Arg_Node : Node_Id;
Arg_Expr : Node_Id;
Arg_Ent : Entity_Id;
Citem : Node_Id;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
-- Check case of appearing within context clause
if Is_In_Context_Clause then
-- The arguments must all be units mentioned in a with clause
-- in the same context clause. Note we already checked (in
-- Par.Prag) that the arguments are either identifiers or
-- selected components.
Arg_Node := Arg1;
while Present (Arg_Node) loop
Citem := First (List_Containing (N));
while Citem /= N loop
if Nkind (Citem) = N_With_Clause
and then
Same_Name (Name (Citem), Get_Pragma_Arg (Arg_Node))
then
Set_Has_Pragma_Unreferenced
(Cunit_Entity
(Get_Source_Unit
(Library_Unit (Citem))));
Set_Unit_Name
(Get_Pragma_Arg (Arg_Node), Name (Citem));
exit;
end if;
Next (Citem);
end loop;
if Citem = N then
Error_Pragma_Arg
("argument of pragma% is not with'ed unit", Arg_Node);
end if;
Next (Arg_Node);
end loop;
-- Case of not in list of context items
else
Arg_Node := Arg1;
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
-- Note: the analyze call done by Check_Arg_Is_Local_Name
-- will in fact generate reference, so that the entity will
-- have a reference, which will inhibit any warnings about
-- it not being referenced, and also properly show up in the
-- ali file as a reference. But this reference is recorded
-- before the Has_Pragma_Unreferenced flag is set, so that
-- no warning is generated for this reference.
Check_Arg_Is_Local_Name (Arg_Node);
Arg_Expr := Get_Pragma_Arg (Arg_Node);
if Is_Entity_Name (Arg_Expr) then
Arg_Ent := Entity (Arg_Expr);
-- If the entity is overloaded, the pragma applies to the
-- most recent overloading, as documented. In this case,
-- name resolution does not generate a reference, so it
-- must be done here explicitly.
if Is_Overloaded (Arg_Expr) then
Generate_Reference (Arg_Ent, N);
end if;
Set_Has_Pragma_Unreferenced (Arg_Ent);
end if;
Next (Arg_Node);
end loop;
end if;
end Unreferenced;
--------------------------
-- Unreferenced_Objects --
--------------------------
-- pragma Unreferenced_Objects (local_Name {, local_Name});
when Pragma_Unreferenced_Objects => Unreferenced_Objects : declare
Arg_Node : Node_Id;
Arg_Expr : Node_Id;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Arg_Node := Arg1;
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
Check_Arg_Is_Local_Name (Arg_Node);
Arg_Expr := Get_Pragma_Arg (Arg_Node);
if not Is_Entity_Name (Arg_Expr)
or else not Is_Type (Entity (Arg_Expr))
then
Error_Pragma_Arg
("argument for pragma% must be type or subtype", Arg_Node);
end if;
Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
Next (Arg_Node);
end loop;
end Unreferenced_Objects;
------------------------------
-- Unreserve_All_Interrupts --
------------------------------
-- pragma Unreserve_All_Interrupts;
when Pragma_Unreserve_All_Interrupts =>
GNAT_Pragma;
Check_Arg_Count (0);
if In_Extended_Main_Code_Unit (Main_Unit_Entity) then
Unreserve_All_Interrupts := True;
end if;
----------------
-- Unsuppress --
----------------
-- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
when Pragma_Unsuppress =>
Ada_2005_Pragma;
Process_Suppress_Unsuppress (False);
-------------------
-- Use_VADS_Size --
-------------------
-- pragma Use_VADS_Size;
when Pragma_Use_VADS_Size =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
Use_VADS_Size := True;
---------------------
-- Validity_Checks --
---------------------
-- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
when Pragma_Validity_Checks => Validity_Checks : declare
A : constant Node_Id := Get_Pragma_Arg (Arg1);
S : String_Id;
C : Char_Code;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
if Nkind (A) = N_String_Literal then
S := Strval (A);
declare
Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
J : Natural;
begin
J := 1;
loop
C := Get_String_Char (S, Int (J));
exit when not In_Character_Range (C);
Options (J) := Get_Character (C);
if J = Slen then
Set_Validity_Check_Options (Options);
exit;
else
J := J + 1;
end if;
end loop;
end;
elsif Nkind (A) = N_Identifier then
if Chars (A) = Name_All_Checks then
Set_Validity_Check_Options ("a");
elsif Chars (A) = Name_On then
Validity_Checks_On := True;
elsif Chars (A) = Name_Off then
Validity_Checks_On := False;
end if;
end if;
end Validity_Checks;
--------------
-- Volatile --
--------------
-- pragma Volatile (LOCAL_NAME);
when Pragma_Volatile =>
Process_Atomic_Shared_Volatile;
-------------------------
-- Volatile_Components --
-------------------------
-- pragma Volatile_Components (array_LOCAL_NAME);
-- Volatile is handled by the same circuit as Atomic_Components
--------------
-- Warnings --
--------------
-- pragma Warnings (On | Off);
-- pragma Warnings (On | Off, LOCAL_NAME);
-- pragma Warnings (static_string_EXPRESSION);
-- pragma Warnings (On | Off, STRING_LITERAL);
when Pragma_Warnings => Warnings : begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_No_Identifiers;
-- If debug flag -gnatd.i is set, pragma is ignored
if Debug_Flag_Dot_I then
return;
end if;
-- Process various forms of the pragma
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
-- One argument case
if Arg_Count = 1 then
-- On/Off one argument case was processed by parser
if Nkind (Argx) = N_Identifier
and then
(Chars (Argx) = Name_On
or else
Chars (Argx) = Name_Off)
then
null;
-- One argument case must be ON/OFF or static string expr
elsif not Is_Static_String_Expression (Arg1) then
Error_Pragma_Arg
("argument of pragma% must be On/Off or " &
"static string expression", Arg1);
-- One argument string expression case
else
declare
Lit : constant Node_Id := Expr_Value_S (Argx);
Str : constant String_Id := Strval (Lit);
Len : constant Nat := String_Length (Str);
C : Char_Code;
J : Nat;
OK : Boolean;
Chr : Character;
begin
J := 1;
while J <= Len loop
C := Get_String_Char (Str, J);
OK := In_Character_Range (C);
if OK then
Chr := Get_Character (C);
-- Dot case
if J < Len and then Chr = '.' then
J := J + 1;
C := Get_String_Char (Str, J);
Chr := Get_Character (C);
if not Set_Dot_Warning_Switch (Chr) then
Error_Pragma_Arg
("invalid warning switch character " &
'.' & Chr, Arg1);
end if;
-- Non-Dot case
else
OK := Set_Warning_Switch (Chr);
end if;
end if;
if not OK then
Error_Pragma_Arg
("invalid warning switch character " & Chr,
Arg1);
end if;
J := J + 1;
end loop;
end;
end if;
-- Two or more arguments (must be two)
else
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Check_At_Most_N_Arguments (2);
declare
E_Id : Node_Id;
E : Entity_Id;
Err : Boolean;
begin
E_Id := Get_Pragma_Arg (Arg2);
Analyze (E_Id);
-- In the expansion of an inlined body, a reference to
-- the formal may be wrapped in a conversion if the
-- actual is a conversion. Retrieve the real entity name.
if (In_Instance_Body
or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
end if;
-- Entity name case
if Is_Entity_Name (E_Id) then
E := Entity (E_Id);
if E = Any_Id then
return;
else
loop
Set_Warnings_Off
(E, (Chars (Get_Pragma_Arg (Arg1)) =
Name_Off));
if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
and then Warn_On_Warnings_Off
then
Warnings_Off_Pragmas.Append ((N, E));
end if;
if Is_Enumeration_Type (E) then
declare
Lit : Entity_Id;
begin
Lit := First_Literal (E);
while Present (Lit) loop
Set_Warnings_Off (Lit);
Next_Literal (Lit);
end loop;
end;
end if;
exit when No (Homonym (E));
E := Homonym (E);
end loop;
end if;
-- Error if not entity or static string literal case
elsif not Is_Static_String_Expression (Arg2) then
Error_Pragma_Arg
("second argument of pragma% must be entity " &
"name or static string expression", Arg2);
-- String literal case
else
String_To_Name_Buffer
(Strval (Expr_Value_S (Get_Pragma_Arg (Arg2))));
-- Note on configuration pragma case: If this is a
-- configuration pragma, then for an OFF pragma, we
-- just set Config True in the call, which is all
-- that needs to be done. For the case of ON, this
-- is normally an error, unless it is canceling the
-- effect of a previous OFF pragma in the same file.
-- In any other case, an error will be signalled (ON
-- with no matching OFF).
if Chars (Argx) = Name_Off then
Set_Specific_Warning_Off
(Loc, Name_Buffer (1 .. Name_Len),
Config => Is_Configuration_Pragma);
elsif Chars (Argx) = Name_On then
Set_Specific_Warning_On
(Loc, Name_Buffer (1 .. Name_Len), Err);
if Err then
Error_Msg
("?pragma Warnings On with no " &
"matching Warnings Off",
Loc);
end if;
end if;
end if;
end;
end if;
end;
end Warnings;
-------------------
-- Weak_External --
-------------------
-- pragma Weak_External ([Entity =>] LOCAL_NAME);
when Pragma_Weak_External => Weak_External : declare
Ent : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
Ent := Entity (Get_Pragma_Arg (Arg1));
if Rep_Item_Too_Early (Ent, N) then
return;
else
Ent := Underlying_Type (Ent);
end if;
-- The only processing required is to link this item on to the
-- list of rep items for the given entity. This is accomplished
-- by the call to Rep_Item_Too_Late (when no error is detected
-- and False is returned).
if Rep_Item_Too_Late (Ent, N) then
return;
else
Set_Has_Gigi_Rep_Item (Ent);
end if;
end Weak_External;
-----------------------------
-- Wide_Character_Encoding --
-----------------------------
-- pragma Wide_Character_Encoding (IDENTIFIER);
when Pragma_Wide_Character_Encoding =>
GNAT_Pragma;
-- Nothing to do, handled in parser. Note that we do not enforce
-- configuration pragma placement, this pragma can appear at any
-- place in the source, allowing mixed encodings within a single
-- source program.
null;
--------------------
-- Unknown_Pragma --
--------------------
-- Should be impossible, since the case of an unknown pragma is
-- separately processed before the case statement is entered.
when Unknown_Pragma =>
raise Program_Error;
end case;
-- AI05-0144: detect dangerous order dependence. Disabled for now,
-- until AI is formally approved.
-- Check_Order_Dependence;
exception
when Pragma_Exit => null;
end Analyze_Pragma;
-----------------------------
-- Analyze_TC_In_Decl_Part --
-----------------------------
procedure Analyze_TC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
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 expressions, we treat these as spec
-- expressions (i.e. similar to a default expression).
Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N),
Get_Ensures_From_Test_Case_Pragma (N));
-- Remove the subprogram from the scope stack now that the pre-analysis
-- of the expressions in the test-case is done.
End_Scope;
end Analyze_TC_In_Decl_Part;
--------------------
-- Check_Disabled --
--------------------
function Check_Disabled (Nam : Name_Id) return Boolean is
PP : Node_Id;
begin
-- Loop through entries in check policy list
PP := Opt.Check_Policy_List;
loop
-- If there are no specific entries that matched, then nothing is
-- disabled, so return False.
if No (PP) then
return False;
-- Here we have an entry see if it matches
else
declare
PPA : constant List_Id := Pragma_Argument_Associations (PP);
begin
if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
return Chars (Get_Pragma_Arg (Last (PPA))) = Name_Disable;
else
PP := Next_Pragma (PP);
end if;
end;
end if;
end loop;
end Check_Disabled;
-------------------
-- Check_Enabled --
-------------------
function Check_Enabled (Nam : Name_Id) return Boolean is
PP : Node_Id;
begin
-- Loop through entries in check policy list
PP := Opt.Check_Policy_List;
loop
-- If there are no specific entries that matched, then we let the
-- setting of assertions govern. Note that this provides the needed
-- compatibility with the RM for the cases of assertion, invariant,
-- precondition, predicate, and postcondition.
if No (PP) then
return Assertions_Enabled;
-- Here we have an entry see if it matches
else
declare
PPA : constant List_Id := Pragma_Argument_Associations (PP);
begin
if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
case (Chars (Get_Pragma_Arg (Last (PPA)))) is
when Name_On | Name_Check =>
return True;
when Name_Off | Name_Ignore =>
return False;
when others =>
raise Program_Error;
end case;
else
PP := Next_Pragma (PP);
end if;
end;
end if;
end loop;
end Check_Enabled;
---------------------------------
-- Delay_Config_Pragma_Analyze --
---------------------------------
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
begin
return Pragma_Name (N) = Name_Interrupt_State
or else
Pragma_Name (N) = Name_Priority_Specific_Dispatching;
end Delay_Config_Pragma_Analyze;
-------------------------
-- Get_Base_Subprogram --
-------------------------
function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id is
Result : Entity_Id;
begin
-- Follow subprogram renaming chain
Result := Def_Id;
while Is_Subprogram (Result)
and then
Nkind (Parent (Declaration_Node (Result))) =
N_Subprogram_Renaming_Declaration
and then Present (Alias (Result))
loop
Result := Alias (Result);
end loop;
return Result;
end Get_Base_Subprogram;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Externals.Init;
end Initialize;
-----------------------------
-- Is_Config_Static_String --
-----------------------------
function Is_Config_Static_String (Arg : Node_Id) return Boolean is
function Add_Config_Static_String (Arg : Node_Id) return Boolean;
-- This is an internal recursive function that is just like the outer
-- function except that it adds the string to the name buffer rather
-- than placing the string in the name buffer.
------------------------------
-- Add_Config_Static_String --
------------------------------
function Add_Config_Static_String (Arg : Node_Id) return Boolean is
N : Node_Id;
C : Char_Code;
begin
N := Arg;
if Nkind (N) = N_Op_Concat then
if Add_Config_Static_String (Left_Opnd (N)) then
N := Right_Opnd (N);
else
return False;
end if;
end if;
if Nkind (N) /= N_String_Literal then
Error_Msg_N ("string literal expected for pragma argument", N);
return False;
else
for J in 1 .. String_Length (Strval (N)) loop
C := Get_String_Char (Strval (N), J);
if not In_Character_Range (C) then
Error_Msg
("string literal contains invalid wide character",
Sloc (N) + 1 + Source_Ptr (J));
return False;
end if;
Add_Char_To_Name_Buffer (Get_Character (C));
end loop;
end if;
return True;
end Add_Config_Static_String;
-- Start of processing for Is_Config_Static_String
begin
Name_Len := 0;
return Add_Config_Static_String (Arg);
end Is_Config_Static_String;
-----------------------------------------
-- Is_Non_Significant_Pragma_Reference --
-----------------------------------------
-- This function makes use of the following static table which indicates
-- whether a given pragma is significant.
-- -1 indicates that references in any argument position are significant
-- 0 indicates that appearance in any argument is not significant
-- +n indicates that appearance as argument n is significant, but all
-- other arguments are not significant
-- 99 special processing required (e.g. for pragma Check)
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
Pragma_Ada_12 => -1,
Pragma_Ada_2012 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Assertion_Policy => 0,
Pragma_Assume_No_Invalid_Values => 0,
Pragma_Asynchronous => -1,
Pragma_Atomic => 0,
Pragma_Atomic_Components => 0,
Pragma_Attach_Handler => -1,
Pragma_Check => 99,
Pragma_Check_Name => 0,
Pragma_Check_Policy => 0,
Pragma_CIL_Constructor => -1,
Pragma_CPP_Class => 0,
Pragma_CPP_Constructor => 0,
Pragma_CPP_Virtual => 0,
Pragma_CPP_Vtable => 0,
Pragma_CPU => -1,
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => 0,
Pragma_Common_Object => -1,
Pragma_Compile_Time_Error => -1,
Pragma_Compile_Time_Warning => -1,
Pragma_Compiler_Unit => 0,
Pragma_Complete_Representation => 0,
Pragma_Complex_Representation => 0,
Pragma_Component_Alignment => -1,
Pragma_Controlled => 0,
Pragma_Convention => 0,
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Disable_Atomic_Synchronization => -1,
Pragma_Discard_Names => 0,
Pragma_Dispatching_Domain => -1,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1,
Pragma_Elaboration_Checks => -1,
Pragma_Eliminate => -1,
Pragma_Enable_Atomic_Synchronization => -1,
Pragma_Export => -1,
Pragma_Export_Exception => -1,
Pragma_Export_Function => -1,
Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1,
Pragma_Export_Value => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
Pragma_Extensions_Allowed => -1,
Pragma_External => -1,
Pragma_Favor_Top_Level => -1,
Pragma_External_Name_Casing => -1,
Pragma_Fast_Math => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
Pragma_Implementation_Defined => -1,
Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Function => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
Pragma_Independent => 0,
Pragma_Independent_Components => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,
Pragma_Inline_Generic => 0,
Pragma_Inspection_Point => -1,
Pragma_Interface => +2,
Pragma_Interface_Name => +2,
Pragma_Interrupt_Handler => -1,
Pragma_Interrupt_Priority => -1,
Pragma_Interrupt_State => -1,
Pragma_Invariant => -1,
Pragma_Java_Constructor => -1,
Pragma_Java_Interface => -1,
Pragma_Keep_Names => 0,
Pragma_License => -1,
Pragma_Link_With => -1,
Pragma_Linker_Alias => -1,
Pragma_Linker_Constructor => -1,
Pragma_Linker_Destructor => -1,
Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1,
Pragma_List => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
Pragma_Memory_Size => -1,
Pragma_No_Return => 0,
Pragma_No_Body => 0,
Pragma_No_Run_Time => -1,
Pragma_No_Strict_Aliasing => -1,
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optimize_Alignment => -1,
Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
Pragma_Preelaborable_Initialization => -1,
Pragma_Polling => -1,
Pragma_Persistent_BSS => 0,
Pragma_Postcondition => -1,
Pragma_Precondition => -1,
Pragma_Predicate => -1,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
Pragma_Priority_Specific_Dispatching => -1,
Pragma_Profile => 0,
Pragma_Profile_Warnings => 0,
Pragma_Propagate_Exceptions => -1,
Pragma_Psect_Object => -1,
Pragma_Pure => -1,
Pragma_Pure_05 => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
Pragma_Relative_Deadline => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
Pragma_Restriction_Warnings => -1,
Pragma_Restrictions => -1,
Pragma_Reviewable => -1,
Pragma_Short_Circuit_And_Or => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Short_Descriptors => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
Pragma_Storage_Size => -1,
Pragma_Storage_Unit => -1,
Pragma_Static_Elaboration_Desired => -1,
Pragma_Stream_Convert => -1,
Pragma_Style_Checks => -1,
Pragma_Subtitle => -1,
Pragma_Suppress => 0,
Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_All => -1,
Pragma_Suppress_Debug_Info => 0,
Pragma_Suppress_Initialization => 0,
Pragma_System_Name => -1,
Pragma_Task_Dispatching_Policy => -1,
Pragma_Task_Info => -1,
Pragma_Task_Name => -1,
Pragma_Task_Storage => 0,
Pragma_Test_Case => -1,
Pragma_Thread_Local_Storage => 0,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
Pragma_Unchecked_Union => 0,
Pragma_Unimplemented_Unit => -1,
Pragma_Universal_Aliasing => -1,
Pragma_Universal_Data => -1,
Pragma_Unmodified => -1,
Pragma_Unreferenced => -1,
Pragma_Unreferenced_Objects => -1,
Pragma_Unreserve_All_Interrupts => -1,
Pragma_Unsuppress => 0,
Pragma_Use_VADS_Size => -1,
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,
Pragma_Volatile_Components => 0,
Pragma_Warnings => -1,
Pragma_Weak_External => -1,
Pragma_Wide_Character_Encoding => 0,
Unknown_Pragma => 0);
function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
Id : Pragma_Id;
P : Node_Id;
C : Int;
A : Node_Id;
begin
P := Parent (N);
if Nkind (P) /= N_Pragma_Argument_Association then
return False;
else
Id := Get_Pragma_Id (Parent (P));
C := Sig_Flags (Id);
case C is
when -1 =>
return False;
when 0 =>
return True;
when 99 =>
case Id is
-- For pragma Check, the first argument is not significant,
-- the second and the third (if present) arguments are
-- significant.
when Pragma_Check =>
return
P = First (Pragma_Argument_Associations (Parent (P)));
when others =>
raise Program_Error;
end case;
when others =>
A := First (Pragma_Argument_Associations (Parent (P)));
for J in 1 .. C - 1 loop
if No (A) then
return False;
end if;
Next (A);
end loop;
return A = P; -- is this wrong way round ???
end case;
end if;
end Is_Non_Significant_Pragma_Reference;
------------------------------
-- Is_Pragma_String_Literal --
------------------------------
-- This function returns true if the corresponding pragma argument is a
-- static string expression. These are the only cases in which string
-- literals can appear as pragma arguments. We also allow a string literal
-- as the first argument to pragma Assert (although it will of course
-- always generate a type error).
function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
Pragn : constant Node_Id := Parent (Par);
Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
Pname : constant Name_Id := Pragma_Name (Pragn);
Argn : Natural;
N : Node_Id;
begin
Argn := 1;
N := First (Assoc);
loop
exit when N = Par;
Argn := Argn + 1;
Next (N);
end loop;
if Pname = Name_Assert then
return True;
elsif Pname = Name_Export then
return Argn > 2;
elsif Pname = Name_Ident then
return Argn = 1;
elsif Pname = Name_Import then
return Argn > 2;
elsif Pname = Name_Interface_Name then
return Argn > 1;
elsif Pname = Name_Linker_Alias then
return Argn = 2;
elsif Pname = Name_Linker_Section then
return Argn = 2;
elsif Pname = Name_Machine_Attribute then
return Argn = 2;
elsif Pname = Name_Source_File_Name then
return True;
elsif Pname = Name_Source_Reference then
return Argn = 2;
elsif Pname = Name_Title then
return True;
elsif Pname = Name_Subtitle then
return True;
else
return False;
end if;
end Is_Pragma_String_Literal;
------------------------
-- Preanalyze_TC_Args --
------------------------
procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id) is
begin
-- Preanalyze the boolean expressions, we treat these as spec
-- expressions (i.e. similar to a default expression).
if Present (Arg_Req) then
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg_Req), Standard_Boolean);
end if;
if Present (Arg_Ens) then
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
end if;
end Preanalyze_TC_Args;
--------------------------------------
-- Process_Compilation_Unit_Pragmas --
--------------------------------------
procedure Process_Compilation_Unit_Pragmas (N : Node_Id) is
begin
-- A special check for pragma Suppress_All, a very strange DEC pragma,
-- strange because it comes at the end of the unit. Rational has the
-- same name for a pragma, but treats it as a program unit pragma, In
-- GNAT we just decide to allow it anywhere at all. If it appeared then
-- the flag Has_Pragma_Suppress_All was set on the compilation unit
-- node, and we insert a pragma Suppress (All_Checks) at the start of
-- the context clause to ensure the correct processing.
if Has_Pragma_Suppress_All (N) then
Prepend_To (Context_Items (N),
Make_Pragma (Sloc (N),
Chars => Name_Suppress,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (N),
Expression => Make_Identifier (Sloc (N), Name_All_Checks)))));
end if;
-- Nothing else to do at the current time!
end Process_Compilation_Unit_Pragmas;
--------
-- rv --
--------
procedure rv is
begin
null;
end rv;
--------------------------------
-- Set_Encoded_Interface_Name --
--------------------------------
procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
Str : constant String_Id := Strval (S);
Len : constant Int := String_Length (Str);
CC : Char_Code;
C : Character;
J : Int;
Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
procedure Encode;
-- Stores encoded value of character code CC. The encoding we use an
-- underscore followed by four lower case hex digits.
------------
-- Encode --
------------
procedure Encode is
begin
Store_String_Char (Get_Char_Code ('_'));
Store_String_Char
(Get_Char_Code (Hex (Integer (CC / 2 ** 12))));
Store_String_Char
(Get_Char_Code (Hex (Integer (CC / 2 ** 8 and 16#0F#))));
Store_String_Char
(Get_Char_Code (Hex (Integer (CC / 2 ** 4 and 16#0F#))));
Store_String_Char
(Get_Char_Code (Hex (Integer (CC and 16#0F#))));
end Encode;
-- Start of processing for Set_Encoded_Interface_Name
begin
-- If first character is asterisk, this is a link name, and we leave it
-- completely unmodified. We also ignore null strings (the latter case
-- happens only in error cases) and no encoding should occur for Java or
-- AAMP interface names.
if Len = 0
or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
or else VM_Target /= No_VM
or else AAMP_On_Target
then
Set_Interface_Name (E, S);
else
J := 1;
loop
CC := Get_String_Char (Str, J);
exit when not In_Character_Range (CC);
C := Get_Character (CC);
exit when C /= '_' and then C /= '$'
and then C not in '0' .. '9'
and then C not in 'a' .. 'z'
and then C not in 'A' .. 'Z';
if J = Len then
Set_Interface_Name (E, S);
return;
else
J := J + 1;
end if;
end loop;
-- Here we need to encode. The encoding we use as follows:
-- three underscores + four hex digits (lower case)
Start_String;
for J in 1 .. String_Length (Str) loop
CC := Get_String_Char (Str, J);
if not In_Character_Range (CC) then
Encode;
else
C := Get_Character (CC);
if C = '_' or else C = '$'
or else C in '0' .. '9'
or else C in 'a' .. 'z'
or else C in 'A' .. 'Z'
then
Store_String_Char (CC);
else
Encode;
end if;
end if;
end loop;
Set_Interface_Name (E,
Make_String_Literal (Sloc (S),
Strval => End_String));
end if;
end Set_Encoded_Interface_Name;
-------------------
-- Set_Unit_Name --
-------------------
procedure Set_Unit_Name (N : Node_Id; With_Item : Node_Id) is
Pref : Node_Id;
Scop : Entity_Id;
begin
if Nkind (N) = N_Identifier
and then Nkind (With_Item) = N_Identifier
then
Set_Entity (N, Entity (With_Item));
elsif Nkind (N) = N_Selected_Component then
Change_Selected_Component_To_Expanded_Name (N);
Set_Entity (N, Entity (With_Item));
Set_Entity (Selector_Name (N), Entity (N));
Pref := Prefix (N);
Scop := Scope (Entity (N));
while Nkind (Pref) = N_Selected_Component loop
Change_Selected_Component_To_Expanded_Name (Pref);
Set_Entity (Selector_Name (Pref), Scop);
Set_Entity (Pref, Scop);
Pref := Prefix (Pref);
Scop := Scope (Scop);
end loop;
Set_Entity (Pref, Scop);
end if;
end Set_Unit_Name;
end Sem_Prag;
Reference in New Issue View Git Blame Copy Permalink