-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- 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- --
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-with Exp_Ch7; use Exp_Ch7;
with Exp_Dist; use Exp_Dist;
+with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Lib.Xref; use Lib.Xref;
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 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:
+ -- 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
-- original one, following the renaming chain) is returned. Otherwise the
-- entity is returned unchanged. Should be in Einfo???
- function Get_Pragma_Arg (Arg : Node_Id) return Node_Id;
- -- All the routines that check pragma arguments take either a pragma
- -- argument association (in which case the expression of the argument
- -- association is checked), or the expression directly. The function
- -- Get_Pragma_Arg is a utility used to deal with these two cases. If Arg
- -- is a pragma argument association node, then its expression is returned,
- -- otherwise Arg is returned unchanged.
+ 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.
------------------------------
procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
- Arg1 : constant Node_Id :=
- First (Pragma_Argument_Associations (N));
- Arg2 : constant Node_Id := Next (Arg1);
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
begin
-- Install formals and push subprogram spec onto scope stack so that we
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
- -- If there is a message argument, analyze it the same way
-
- if Present (Arg2) then
- Preanalyze_Spec_Expression
- (Get_Pragma_Arg (Arg2), Standard_String);
- end if;
-
-- Remove the subprogram from the scope stack now that the pre-analysis
-- of the precondition/postcondition is done.
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
+ -- 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
-- 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).
-- 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 referencing a
- -- subtype, does not reference a type that is not a first subtype.
+ -- 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).
+ -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
procedure Check_Interrupt_Or_Attach_Handler;
-- Common processing for first argument of pragma Interrupt_Handler or
-- 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 Error_Pragmas raised.
+ -- 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 Error_Pragmas raised.
+ -- 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.
-- 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.
+ -- There are three cases:
+ --
+ -- The pragma appears after a subprogram spec
+ --
+ -- 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_TC_List and
+ -- Next_Pragma).
+ --
+ -- The pragma appears at the start of subprogram body declarations
+ --
+ -- In this case an immediate return to the caller is made, and the
+ -- pragma is NOT analyzed.
+ --
+ -- 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 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);
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
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 --
--------------------------
else
Error_Msg_Name_1 := Pname;
- Flag_Non_Static_Expr
- ("argument for pragma% must be a identifier or " &
- "static string expression!", Argx);
- raise Pragma_Exit;
+
+ 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;
begin
Check_Arg_Is_Local_Name (Arg);
- if not Is_Library_Level_Entity (Entity (Expression (Arg)))
+ if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg)))
and then Comes_From_Source (N)
then
Error_Pragma_Arg
Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
end if;
- if Is_Entity_Name (Argx)
- and then Scope (Entity (Argx)) /= Current_Scope
- then
- Error_Pragma_Arg
- ("pragma% argument must be in same declarative part", Arg);
+ -- 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_Identifier (Argx);
if not Is_Locking_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg
- ("& is not a valid locking policy name", Argx);
+ Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
end if;
end Check_Arg_Is_Locking_Policy;
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);
+ Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
end if;
end Check_Arg_Is_Queuing_Policy;
else
Error_Msg_Name_1 := Pname;
- Flag_Non_Static_Expr
- ("argument for pragma% must be a static expression!", Argx);
+
+ 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;
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
+ -- 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 := Id;
+ S : Entity_Id;
begin
- while Present (S)
- and then S /= Standard_Standard
- loop
+ S := Id;
+ while Present (S) and then S /= Standard_Standard loop
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
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_First_Subtype (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Ent : constant Entity_Id := Entity (Argx);
+
begin
- if not Is_First_Subtype (Entity (Argx)) then
+ 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_Interrupt_Or_Attach_Handler is
- Arg1_X : constant Node_Id := Expression (Arg1);
+ Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1);
Handler_Proc, Proc_Scope : Entity_Id;
begin
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;
-------------------------------------------
procedure Check_No_Identifier (Arg : Node_Id) is
begin
- if Chars (Arg) /= No_Name then
+ 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 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 Chars (Arg) /= No_Name then
+ 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;
PO : Node_Id;
procedure Chain_PPC (PO : Node_Id);
- -- If PO is a subprogram declaration node (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.
+ -- 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 : Node_Id;
+ S : Entity_Id;
+ P : Node_Id;
begin
- if not Nkind_In (PO, N_Subprogram_Declaration,
- N_Generic_Subprogram_Declaration)
+ 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 subprogram or generic subprogram declaration
+ -- 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.
- S := Defining_Unit_Name (Specification (PO));
+ if Pragma_Name (N) = Name_Precondition
+ and then not Class_Present (N)
+ then
+ declare
+ Inherited : constant Subprogram_List :=
+ Inherited_Subprograms (S);
+ P : Node_Id;
- -- Analyze the pragma unless it appears within a package spec,
- -- which is the case where we delay the analysis of the PPC until
- -- the end of the package declarations (for details, see
- -- Analyze_Package_Specification.Analyze_PPCs).
+ 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;
- if not Is_Package_Or_Generic_Package (Scope (S)) then
- Analyze_PPC_In_Decl_Part (N, S);
+ 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 (S));
- Set_Spec_PPC_List (S, N);
+ Set_Next_Pragma (N, Spec_PPC_List (Contract (S)));
+ Set_Spec_PPC_List (Contract (S), N);
-- Return indicating spec case
return;
end Chain_PPC;
- -- Start of processing for Check_Precondition_Postcondition
+ -- Start of processing for Check_Precondition_Postcondition
begin
if not Is_List_Member (N) then
Pragma_Misplaced;
end if;
- -- Record if pragma is enabled
+ -- 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_Pragma_Enabled (N);
Set_SCO_Pragma_Enabled (Loc);
end if;
-- Skip stuff not coming from source
elsif not Comes_From_Source (PO) then
- null;
+
+ -- 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;
+
+ -- For all other cases of non source code, do nothing
+
+ else
+ null;
+ end if;
-- Only remaining possibility is subprogram declaration
if Operating_Mode /= Generate_Code
or else Inside_A_Generic
then
-
- -- Analyze expression in pragma, for correctness
- -- and for ASIS use.
+ -- Analyze pragma expression for correctness and for ASIS use
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
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 an entry or 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 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;
+
+ -- 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;
+
+ -- 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
+
+ else
+ Chain_TC (PO);
+ return;
+ end if;
+ end loop;
+
+ -- If we fall through loop, pragma is at start of list, so see if it
+ -- is in the pragmas after a library level subprogram.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
+ Chain_TC (Unit (Parent (Parent (N))));
+ return;
+ end if;
+
+ -- If we fall through, pragma was misplaced
+
+ Pragma_Misplaced;
+ end Check_Test_Case;
+
--------------------------------------
-- Check_Valid_Configuration_Pragma --
--------------------------------------
Unit_Node := Unit (Parent (Parent_Node));
Unit_Kind := Nkind (Unit_Node);
- Analyze (Expression (Arg1));
+ Analyze (Get_Pragma_Arg (Arg1));
if Unit_Kind = N_Generic_Subprogram_Declaration
or else Unit_Kind = N_Subprogram_Declaration
end if;
if Chars (Unit_Name) /=
- Chars (Entity (Expression (Arg1)))
+ Chars (Entity (Get_Pragma_Arg (Arg1)))
then
Error_Pragma_Arg
("pragma% argument is not current unit name", Arg1);
Pragma_Misplaced;
elsif Arg_Count > 0 then
- Analyze (Expression (Arg1));
+ Analyze (Get_Pragma_Arg (Arg1));
- if Entity (Expression (Arg1)) /= Current_Scope then
+ if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then
Error_Pragma_Arg
("name in pragma% must be enclosing unit", Arg1);
end if;
------------------
procedure Error_Pragma (Msg : String) is
+ MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Error_Msg_N (Msg, N);
+ Fix_Error (MsgF);
+ Error_Msg_N (MsgF, N);
raise Pragma_Exit;
end Error_Pragma;
----------------------
procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
+ MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
+ 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;
- Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
+ Fix_Error (MsgF);
+ Error_Msg_N (MsgF, Get_Pragma_Arg (Arg));
Error_Pragma_Arg (Msg2, Arg);
end Error_Pragma_Arg;
----------------------------
procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
+ MsgF : String := Msg;
begin
Error_Msg_Name_1 := Pname;
- Error_Msg_N (Msg, Arg);
+ Fix_Error (MsgF);
+ Error_Msg_N (MsgF, Arg);
raise Pragma_Exit;
end Error_Pragma_Arg_Ident;
----------------------
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 (Msg, N, Ref);
+ Error_Msg_NE (MsgF, N, Ref);
raise Pragma_Exit;
end Error_Pragma_Ref;
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 --
-------------------------
Arg := First (Pragma_Argument_Associations (N));
for Index in Args'Range loop
exit when No (Arg) or else Chars (Arg) /= No_Name;
- Args (Index) := Expression (Arg);
+ Args (Index) := Get_Pragma_Arg (Arg);
Next (Arg);
end loop;
Error_Pragma_Arg
("duplicate argument association for pragma%", Arg);
else
- Args (Index) := Expression (Arg);
+ Args (Index) := Get_Pragma_Arg (Arg);
exit;
end if;
end if;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
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
-- 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.
+ -- warning is in the body or the spec private part).
else
if Cont = False then
Set_Convention (E, C);
Set_Has_Convention_Pragma (E);
- if Is_Incomplete_Or_Private_Type (E) then
+ 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;
Check_At_Least_N_Arguments (2);
Check_Optional_Identifier (Arg1, Name_Convention);
Check_Arg_Is_Identifier (Arg1);
- Cname := Chars (Expression (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 (Expression (Arg1)));
+ 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
if Warn_On_Export_Import and not OpenVMS_On_Target then
Error_Msg_N
("?unrecognized convention name, C assumed",
- Expression (Arg1));
+ Get_Pragma_Arg (Arg1));
end if;
C := Convention_C;
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg2);
- Id := Expression (Arg2);
+ Id := Get_Pragma_Arg (Arg2);
Analyze (Id);
if not Is_Entity_Name (Id) then
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.
or else Rep_Item_Too_Early (E, N)
then
raise Pragma_Exit;
- else
+
+ elsif Present (Underlying_Type (E)) then
E := Underlying_Type (E);
end if;
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;
Set_Mechanism_Value
(Formal, Expression (Massoc));
- -- Set entity on identifier for ASIS
+ -- Set entity on identifier (needed by ASIS)
Set_Entity (Choice, Formal);
Arg := Arg1;
while Present (Arg) loop
- Exp := Expression (Arg);
+ Exp := Get_Pragma_Arg (Arg);
Analyze (Exp);
if not Is_Entity_Name (Exp)
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 --
---------------------------------
begin
Process_Convention (C, Def_Id);
Kill_Size_Check_Code (Def_Id);
- Note_Possible_Modification (Expression (Arg2), Sure => False);
+ Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
if Ekind_In (Def_Id, E_Variable, E_Constant) then
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.
+ -- 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.
+ -- 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;
+ -- 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).
-- Link_Name argument not allowed for intrinsic
- 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;
+ Check_No_Link_Name;
Set_Is_Intrinsic_Subprogram (Def_Id);
-- is present, then this is handled by the back end.
if No (Arg3) then
- Check_Intrinsic_Subprogram (Def_Id, Expression (Arg2));
+ Check_Intrinsic_Subprogram
+ (Def_Id, Get_Pragma_Arg (Arg2));
end if;
end if;
elsif Is_Record_Type (Def_Id)
and then C = Convention_CPP
then
- -- Types treated as CPP classes are treated as limited, but we
- -- don't require them to be declared this way. A warning is
- -- issued to encourage the user to declare them as limited.
- -- This is not an error, for compatibility reasons, because
- -- these types have been supported this way for some time.
+ -- 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 should be " &
- "explicitly declared limited?",
- Get_Pragma_Arg (Arg2));
- Error_Msg_N
- ("\type will be considered limited",
+ ("imported 'C'P'P type must be limited",
Get_Pragma_Arg (Arg2));
end if;
Set_Is_CPP_Class (Def_Id);
- Set_Is_Limited_Record (Def_Id);
-- Imported CPP types must not have discriminants (because C++
-- classes do not have discriminants).
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 or subprogram",
+ ("second argument of pragma% must be object, subprogram" &
+ " or incomplete type",
Arg2);
end if;
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
procedure Set_Inline_Flags (Subp : Entity_Id) is
begin
if Active then
- Set_Is_Inlined (Subp, True);
+ Set_Is_Inlined (Subp);
end if;
if not Has_Pragma_Inline (Subp) then
Assoc := Arg1;
while Present (Assoc) loop
- Subp_Id := Expression (Assoc);
+ Subp_Id := Get_Pragma_Arg (Assoc);
Analyze (Subp_Id);
Applies := False;
else
Make_Inline (Subp);
- while Present (Homonym (Subp))
- and then Scope (Homonym (Subp)) = Current_Scope
- loop
- Make_Inline (Homonym (Subp));
- Subp := Homonym (Subp);
- end loop;
+ -- 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.
+
+ 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;
Strval => End_String);
end if;
- Set_Encoded_Interface_Name
- (Get_Base_Subprogram (Subprogram_Def), Link_Nam);
+ -- Set the interface name. If the entity is a generic instance, use
+ -- its alias, which is the callable entity.
- -- We allow duplicated export names in CIL, as they are always
+ 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 then
+ 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;
-----------------------------------------
procedure Process_Interrupt_Or_Attach_Handler is
- Arg1_X : constant Node_Id := Expression (Arg1);
+ 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);
-- Start of processing for Process_Restrictions_Or_Restriction_Warnings
begin
+ -- Ignore all Restrictions pragma in CodePeer and ALFA modes
+
+ if CodePeer_Mode or ALFA_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 := Expression (Arg);
+ Expr := Get_Pragma_Arg (Arg);
-- Case of no restriction identifier present
-- 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)).
Check_No_Identifier (Arg1);
Check_Arg_Is_Identifier (Arg1);
- C := Get_Check_Id (Chars (Expression (Arg1)));
+ C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1)));
if C = No_Check_Id then
Error_Pragma_Arg
end if;
Check_Optional_Identifier (Arg2, Name_On);
- E_Id := Expression (Arg2);
+ E_Id := Get_Pragma_Arg (Arg2);
Analyze (E_Id);
if not Is_Entity_Name (E_Id) then
Suppress_Unsuppress_Echeck (Alias (E), C);
end if;
- -- Move to next homonym
+ -- Move to next homonym if not aspect spec case
+ exit when From_Aspect_Specification (N);
E := Homonym (E);
exit when No (E);
Error_Pragma_Arg
("cannot export entity& that was previously imported", Arg);
- elsif Present (Address_Clause (E)) then
+ 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 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)
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
if not Is_Pragma_Name (Pname) then
-- Preset arguments
- Arg1 := Empty;
- Arg2 := Empty;
- Arg3 := Empty;
- Arg4 := Empty;
+ 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
end if;
end if;
- -- Count number of arguments
-
- declare
- Arg_Node : Node_Id;
- begin
- Arg_Count := 0;
- Arg_Node := Arg1;
- while Present (Arg_Node) loop
- Arg_Count := Arg_Count + 1;
- Next (Arg_Node);
- end loop;
- end;
-
-- 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.
-- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
-- or Ada 2012 mode.
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Check_Valid_Configuration_Pragma;
end if;
-- 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_05 then
+ if Ada_Version >= Ada_2005 then
Check_Valid_Configuration_Pragma;
end if;
if Arg_Count = 1 then
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
Check_Valid_Configuration_Pragma;
- -- Now set Ada 2005 mode
+ -- Now set appropriate Ada mode
- Ada_Version := Ada_05;
- Ada_Version_Explicit := Ada_05;
+ Ada_Version := Ada_2005;
+ Ada_Version_Explicit := Ada_2005;
end if;
end;
if Arg_Count = 1 then
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
Check_Valid_Configuration_Pragma;
- -- Now set Ada 2012 mode
+ -- Now set appropriate Ada mode
- Ada_Version := Ada_12;
- Ada_Version_Explicit := Ada_12;
+ Ada_Version := Ada_2012;
+ Ada_Version_Explicit := Ada_2012;
end if;
end;
-- external tool and a tool-specific function. These arguments are
-- not analyzed.
- when Pragma_Annotate => Annotate : begin
+ 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);
- declare
- Arg : Node_Id;
- Exp : Node_Id;
+ -- Second parameter is optional, it is never analyzed
- begin
- -- Second unanalyzed parameter is optional
+ if No (Arg2) then
+ null;
- if No (Arg2) then
- null;
- else
- Arg := Next (Arg2);
- while Present (Arg) loop
- Exp := Expression (Arg);
- Analyze (Exp);
+ -- Here if we have a second parameter
- if Is_Entity_Name (Exp) then
- null;
+ else
+ -- Second parameter must be identifier
- -- For string literals, we assume Standard_String as the
- -- type, unless the string contains wide or wide_wide
- -- characters.
+ Check_Arg_Is_Identifier (Arg2);
- 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;
+ -- Process remaining parameters if any
- elsif Is_Overloaded (Exp) then
- Error_Pragma_Arg
- ("ambiguous argument for pragma%", Exp);
+ 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);
+ Resolve (Exp, Standard_String);
end if;
- Next (Arg);
- end loop;
- end if;
- end;
+ 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;
------------
Expr := Get_Pragma_Arg (Arg1);
Newa := New_List (
Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc,
- Chars => Name_Assertion)),
+ Expression => Make_Identifier (Loc, Name_Assertion)),
Make_Pragma_Argument_Association (Sloc (Expr),
Expression => Expr));
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc,
- Chars => Name_Assertion)),
+ Expression => Make_Identifier (Loc, Name_Assertion)),
Make_Pragma_Argument_Association (Loc,
Expression =>
- Make_Identifier (Sloc (Policy),
- Chars => Chars (Policy))))));
+ Make_Identifier (Sloc (Policy), Chars (Policy))))));
Set_Analyzed (N);
Set_Next_Pragma (N, Opt.Check_Policy_List);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
- if Chars (Expression (Arg1)) = Name_On then
+ if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
Assume_No_Invalid_Values := True;
else
Assume_No_Invalid_Values := False;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Local_Name (Arg1);
- Ent := Entity (Expression (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
end if;
C_Ent := Cunit_Entity (Current_Sem_Unit);
- Analyze (Expression (Arg1));
- Nm := Entity (Expression (Arg1));
+ 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)
("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
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
- Ctyp : Entity_Id;
begin
Check_Ada_83_Warning;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
E := Entity (E_Id);
+ Check_Duplicate_Pragma (E);
+
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N)
if Nkind (D) /= N_Object_Declaration then
E := Base_Type (E);
- Ctyp := Component_Type (E);
- else
- Ctyp := Component_Type (Base_Type (Etype (E)));
end if;
Set_Has_Volatile_Components (E);
if Prag_Id = Pragma_Atomic_Components then
Set_Has_Atomic_Components (E);
-
- if Is_Packed (E) then
- Set_Is_Packed (E, False);
-
- if not (Known_Static_Esize (Ctyp)
- and then Known_Static_RM_Size (Ctyp)
- and then Esize (Ctyp) = RM_Size (Ctyp))
- then
- Error_Pragma_Arg
- ("cannot pack atomic components", Arg1);
- end if;
- end if;
end if;
else
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, perform semantic checks
- -- on a copy only.
+ -- 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 (Expression (Arg2));
+ New_Copy_Tree (Get_Pragma_Arg (Arg2));
begin
Set_Parent (Temp, N);
Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
end;
else
- Analyze (Expression (Arg2));
- Resolve (Expression (Arg2), RTE (RE_Interrupt_ID));
+ Analyze (Get_Pragma_Arg (Arg2));
+ Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID));
end if;
Process_Interrupt_Or_Attach_Handler;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, "max_size");
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
Check_Arg_Is_Static_Expression (Arg, Any_Integer);
Val := Expr_Value (Arg);
-- Check --
-----------
- -- pragma Check ([Name =>] Identifier,
- -- [Check =>] Boolean_Expression
- -- [,[Message =>] String_Expression]);
+ -- pragma Check ([Name =>] IDENTIFIER,
+ -- [Check =>] Boolean_EXPRESSION
+ -- [,[Message =>] String_EXPRESSION]);
when Pragma_Check => Check : declare
Expr : Node_Id;
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
if Check_On then
- Set_Pragma_Enabled (N);
- Set_Pragma_Enabled (Original_Node (N));
Set_SCO_Pragma_Enabled (Loc);
end if;
-- compile time, and we do not want to delete this warning when we
-- delete the if statement.
- Expr := Expression (Arg2);
+ Expr := Get_Pragma_Arg (Arg2);
if Expander_Active and then not Check_On then
Eloc := Sloc (Expr);
Check_Arg_Is_Identifier (Arg1);
declare
- Nam : constant Name_Id := Chars (Expression (Arg1));
+ Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
begin
for J in Check_Names.First .. Check_Names.Last loop
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
if not Is_Entity_Name (Arg)
or else not Is_Access_Type (Entity (Arg))
Check_Optional_Identifier (Arg2, Name_Convention);
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Identifier (Arg2);
- Idnam := Chars (Expression (Arg1));
- Cname := Chars (Expression (Arg2));
+ Idnam := Chars (Get_Pragma_Arg (Arg1));
+ Cname := Chars (Get_Pragma_Arg (Arg2));
if Is_Convention_Name (Cname) then
Record_Convention_Identifier
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
Error_Pragma_Arg ("pragma% applicable to tagged types ", Arg1);
end if;
- -- Types treated as CPP classes are treated as limited, but we
- -- don't require them to be declared this way. A warning is issued
- -- to encourage the user to declare them as limited. This is not
- -- an error, for compatibility reasons, because these types have
- -- been supported this way for some time.
+ -- 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 should be " &
- "explicitly declared limited?",
- Get_Pragma_Arg (Arg1));
- Error_Msg_N
- ("\type will be considered limited",
+ ("imported 'C'P'P type must be limited",
Get_Pragma_Arg (Arg1));
end if;
Set_Is_CPP_Class (Typ);
- Set_Is_Limited_Record (Typ);
Set_Convention (Typ, Convention_CPP);
-- Imported CPP types must not have discriminants (because C++
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- Id := Expression (Arg1);
+ Id := Get_Pragma_Arg (Arg1);
Find_Program_Unit_Name (Id);
-- If we did not find the name, we are done
-- CPP_Virtual --
-----------------
- when Pragma_CPP_Virtual => CPP_Virtual : declare
- begin
- GNAT_Pragma;
+ 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));
- 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;
+ -- Anything else is incorrect
- ----------------
- -- CPP_Vtable --
- ----------------
+ else
+ Pragma_Misplaced;
+ end if;
- when Pragma_CPP_Vtable => CPP_Vtable : declare
- begin
- GNAT_Pragma;
+ if Has_Pragma_CPU (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Pragma_CPU (P, True);
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
- "no effect?", N);
+ if Nkind (P) = N_Task_Definition then
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ end if;
end if;
- end CPP_Vtable;
+ end CPU;
-----------
-- Debug --
-- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
when Pragma_Debug => Debug : declare
- Cond : Node_Id;
+ Cond : Node_Id;
+ Call : Node_Id;
begin
GNAT_Pragma;
(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 => Expression (Arg1));
+ 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% is not procedure call", Sloc (Call));
+ return;
end if;
-- Rewrite into a conditional with an appropriate condition. We
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Relocate_Node (Debug_Statement (N))))))));
+ Statements => New_List (Relocate_Node (Call)))))));
Analyze (N);
end Debug;
GNAT_Pragma;
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
- Debug_Pragmas_Enabled := Chars (Expression (Arg1)) = Name_Check;
+ Debug_Pragmas_Enabled :=
+ Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
---------------------
-- Detect_Blocking --
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 --
---------------
Check_Optional_Identifier (Arg1, Name_On);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
Citem := First (List_Containing (N));
Inner : while Citem /= N loop
if Nkind (Citem) = N_With_Clause
- and then Same_Name (Name (Citem), Expression (Arg))
+ and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
then
Set_Elaborate_Present (Citem, True);
- Set_Unit_Name (Expression (Arg), Name (Citem));
+ 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
Citem := First (List_Containing (N));
Innr : while Citem /= N loop
if Nkind (Citem) = N_With_Clause
- and then Same_Name (Name (Citem), Expression (Arg))
+ and then Same_Name (Name (Citem), Get_Pragma_Arg (Arg))
then
Set_Elaborate_All_Present (Citem, True);
- Set_Unit_Name (Expression (Arg), Name (Citem));
+ 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
end if;
if (Present (Parameter_Types)
- or else
+ or else
Present (Result_Type))
and then
Present (Source_Location)
Process_Convention (C, Def_Id);
if Ekind (Def_Id) /= E_Constant then
- Note_Possible_Modification (Expression (Arg2), Sure => False);
+ Note_Possible_Modification
+ (Get_Pragma_Arg (Arg2), Sure => False);
end if;
Process_Interface_Name (Def_Id, Arg3, Arg4);
Check_Optional_Identifier (Arg1, Name_Name);
Check_Arg_Is_Identifier (Arg1);
- Get_Name_String (Chars (Expression (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 (Expression (Arg1)) =
+ if Chars (Get_Pragma_Arg (Arg1)) =
Chars (Expression (System_Extend_Pragma_Arg))
then
null;
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
- if Chars (Expression (Arg1)) = Name_On then
+ if Chars (Get_Pragma_Arg (Arg1)) = Name_On then
Extensions_Allowed := True;
Ada_Version := Ada_Version_Type'Last;
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Process_Convention (C, Def_Id);
- Note_Possible_Modification (Expression (Arg2), Sure => False);
+ Note_Possible_Modification
+ (Get_Pragma_Arg (Arg2), Sure => False);
Process_Interface_Name (Def_Id, Arg3, Arg4);
Set_Exported (Def_Id, Arg2);
end External;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
- Named_Entity := Entity (Expression (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.
else
Error_Pragma_Arg
- ("access-to-subprogram type expected", Expression (Arg1));
+ ("access-to-subprogram type expected",
+ Get_Pragma_Arg (Arg1));
end if;
end Favor_Top_Level;
when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
Assoc : constant Node_Id := Arg1;
- Type_Id : constant Node_Id := Expression (Assoc);
+ Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
Typ : Entity_Id;
begin
Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float);
if not OpenVMS_On_Target then
- if Chars (Expression (Arg1)) = Name_VAX_Float then
+ if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then
Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
end if;
-- One argument case
if Arg_Count = 1 then
- if Chars (Expression (Arg1)) = Name_VAX_Float 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;
-- Two arguments, VAX_Float case
- if Chars (Expression (Arg1)) = Name_VAX_Float then
+ 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);
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
- Str := Expr_Value_S (Expression (Arg1));
+ Str := Expr_Value_S (Get_Pragma_Arg (Arg1));
declare
CS : Node_Id;
end;
end Ident;
- --------------------------
- -- Implemented_By_Entry --
- --------------------------
+ -----------------
+ -- Implemented --
+ -----------------
- -- pragma Implemented_By_Entry (DIRECT_NAME);
+ -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
+ -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
- when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare
- Ent : Entity_Id;
+ when Pragma_Implemented => Implemented : declare
+ Proc_Id : Entity_Id;
+ Typ : Entity_Id;
begin
- Ada_2005_Pragma;
- Check_Arg_Count (1);
+ Ada_2012_Pragma;
+ Check_Arg_Count (2);
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
- Ent := Entity (Expression (Arg1));
+ Check_Arg_Is_One_Of
+ (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+
+ -- Extract the name of the local procedure
- -- Pragma Implemented_By_Entry must be applied only to protected
- -- synchronized or task interface primitives.
+ Proc_Id := Entity (Get_Pragma_Arg (Arg1));
- if (Ekind (Ent) /= E_Function
- and then Ekind (Ent) /= E_Procedure)
- or else not Present (First_Formal (Ent))
- or else not Is_Concurrent_Interface (Etype (First_Formal (Ent)))
+ -- 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
- Error_Pragma_Arg
- ("pragma % must be applied to a concurrent interface " &
- "primitive", Arg1);
+ Typ := Etype (First_Formal (Proc_Id));
- else
- if Einfo.Implemented_By_Entry (Ent)
- and then Warn_On_Redundant_Constructs
+ 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
- Error_Pragma ("?duplicate pragma%!");
+ null;
else
- Set_Implemented_By_Entry (Ent);
+ 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;
- end Implemented_By_Entry;
- -----------------------
+ -- 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;
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 --
------------------------
Check_Valid_Configuration_Pragma;
Check_Restriction (No_Initialize_Scalars, N);
- -- Initialize_Scalars creates false positives in CodePeer,
- -- so ignore this pragma in this mode.
+ -- 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
+ and then not (CodePeer_Mode or ALFA_Mode)
then
Init_Or_Norm_Scalars := True;
Initialize_Scalars := True;
when Pragma_Inline_Always =>
GNAT_Pragma;
- -- Pragma always active unless in CodePeer mode, since this causes
- -- walk order issues.
+ -- Pragma always active unless in CodePeer or ALFA mode, since
+ -- this causes walk order issues.
- if not CodePeer_Mode then
+ if not (CodePeer_Mode or ALFA_Mode) then
Process_Inline (True);
end if;
if Arg_Count > 0 then
Arg := Arg1;
loop
- Exp := Expression (Arg);
+ Exp := Get_Pragma_Arg (Arg);
Analyze (Exp);
if not Is_Entity_Name (Exp)
((Name_Entity, Name_External_Name, Name_Link_Name));
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (3);
- Id := Expression (Arg1);
+ Id := Get_Pragma_Arg (Arg1);
Analyze (Id);
if not Is_Entity_Name (Id) then
Found := True;
end if;
+ exit when From_Aspect_Specification (N);
Hom_Id := Homonym (Hom_Id);
exit when No (Hom_Id)
Check_Ada_83_Warning;
if Arg_Count /= 0 then
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
Check_Arg_Count (1);
Check_No_Identifiers;
Pragma_Misplaced;
return;
- elsif Has_Priority_Pragma (P) then
+ elsif Has_Pragma_Priority (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
- Set_Has_Priority_Pragma (P, True);
+ Set_Has_Pragma_Priority (P, True);
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
end if;
end Interrupt_Priority;
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;
+
+ elsif not Ekind_In (Typ, E_Private_Type,
+ E_Record_Type_With_Private,
+ E_Limited_Private_Type)
+ then
+ 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 --
----------------------
when Pragma_CIL_Constructor | Pragma_Java_Constructor =>
Java_Constructor : declare
- Id : Entity_Id;
- Def_Id : Entity_Id;
- Hom_Id : Entity_Id;
- Convention : Convention_Id;
+ Convention : Convention_Id;
+ Def_Id : Entity_Id;
+ Hom_Id : Entity_Id;
+ Id : Entity_Id;
+ This_Formal : Entity_Id;
begin
GNAT_Pragma;
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- Id := Expression (Arg1);
+ Id := Get_Pragma_Arg (Arg1);
Find_Program_Unit_Name (Id);
-- If we did not find the name, we are done
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;
loop
Def_Id := Get_Base_Subprogram (Hom_Id);
- -- The constructor is required to be a function returning an
- -- access type whose designated type has convention Java/CIL.
-
- if Ekind (Def_Id) = E_Function
- and then
- (Is_Value_Type (Etype (Def_Id))
- or else
- (Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
- and then
- Atree.Convention (Etype (Def_Id)) = Convention)
- or else
- (Ekind (Etype (Def_Id)) in Access_Kind
- and then
- (Atree.Convention
- (Designated_Type (Etype (Def_Id))) = Convention
- or else
- Atree.Convention
- (Root_Type (Designated_Type (Etype (Def_Id)))) =
- Convention)))
- then
- Set_Is_Constructor (Def_Id);
- Set_Convention (Def_Id, Convention);
- Set_Is_Imported (Def_Id);
+ -- The constructor is required to be a function
- else
- if Convention = Convention_Java then
+ if Ekind (Def_Id) /= E_Function then
+ if VM_Target = JVM_Target then
Error_Pragma_Arg
("pragma% requires function returning a " &
- "'Java access type", Arg1);
+ "'Java access type", Def_Id);
else
- pragma Assert (Convention = Convention_CIL);
Error_Pragma_Arg
("pragma% requires function returning a " &
- "'C'I'L access type", Arg1);
+ "'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;
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
Check_Optional_Identifier (Arg1, Name_On);
Check_Arg_Is_Local_Name (Arg1);
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
Analyze (Arg);
if Etype (Arg) = Any_Type then
Arg_Store : declare
C : constant Char_Code := Get_Char_Code (' ');
S : constant String_Id :=
- Strval (Expr_Value_S (Expression (Arg)));
+ Strval (Expr_Value_S (Get_Pragma_Arg (Arg)));
L : constant Nat := String_Length (S);
F : Nat := 1;
-- by the call to Rep_Item_Too_Late (when no error is detected
-- and False is returned).
- if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
+ if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
return;
else
- Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+ Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
end if;
------------------------
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Local_Name (Arg1);
- Arg1_X := Expression (Arg1);
+ Arg1_X := Get_Pragma_Arg (Arg1);
Analyze (Arg1_X);
Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
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 (Expression (Arg1))));
+ 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 (Expression (Arg))));
+ Store_String_Chars
+ (Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
Arg := Next (Arg);
end loop;
-- This pragma applies only to objects
- if not Is_Object (Entity (Expression (Arg1))) then
+ if not Is_Object (Entity (Get_Pragma_Arg (Arg1))) then
Error_Pragma_Arg ("pragma% applies only to objects", Arg1);
end if;
-- by the call to Rep_Item_Too_Late (when no error is detected
-- and False is returned).
- if Rep_Item_Too_Late (Entity (Expression (Arg1)), N) then
+ if Rep_Item_Too_Late (Entity (Get_Pragma_Arg (Arg1)), N) then
return;
else
- Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+ Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
end if;
----------
Check_No_Identifiers;
Check_Arg_Is_Locking_Policy (Arg1);
Check_Valid_Configuration_Pragma;
- Get_Name_String (Chars (Expression (Arg1)));
+ Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
LP := Fold_Upper (Name_Buffer (1));
if Locking_Policy /= ' '
-- D_Float case
- if Chars (Expression (Arg1)) = Name_D_Float then
+ 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;
Check_Optional_Identifier (Arg2, Name_Attribute_Name);
Check_Arg_Is_Local_Name (Arg1);
Check_Arg_Is_Static_Expression (Arg2, Standard_String);
- Def_Id := Entity (Expression (Arg1));
+ Def_Id := Entity (Get_Pragma_Arg (Arg1));
if Is_Access_Type (Def_Id) then
Def_Id := Designated_Type (Def_Id);
if Rep_Item_Too_Late (Def_Id, N) then
return;
else
- Set_Has_Gigi_Rep_Item (Entity (Expression (Arg1)));
+ Set_Has_Gigi_Rep_Item (Entity (Get_Pragma_Arg (Arg1)));
end if;
end Machine_Attribute;
Arg := Arg1;
while Present (Arg) loop
Check_Arg_Is_Local_Name (Arg);
- Id := Expression (Arg);
+ Id := Get_Pragma_Arg (Arg);
Analyze (Id);
if not Is_Entity_Name (Id) then
Found := True;
end if;
+ exit when From_Aspect_Specification (N);
E := Homonym (E);
end loop;
else
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Entity (Expression (Arg1));
+ E_Id := Entity (Get_Pragma_Arg (Arg1));
if E_Id = Any_Type then
return;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
- -- Normalize_Scalars creates false positives in CodePeer, so
- -- ignore this pragma in this mode.
+ -- 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 then
+ if not (CodePeer_Mode or ALFA_Mode) then
Normalize_Scalars := True;
Init_Or_Norm_Scalars := True;
end if;
-- Deal with static string argument
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
- S := Strval (Expression (Arg1));
+ 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
end loop;
Obsolescent_Warnings.Append
- ((Ent => Ent, Msg => Strval (Expression (Arg1))));
+ ((Ent => Ent, Msg => Strval (Get_Pragma_Arg (Arg1))));
-- Check for Ada_05 parameter
("only allowed argument for pragma% is %", Argx);
end if;
- if Ada_Version_Explicit < Ada_05
+ if Ada_Version_Explicit < Ada_2005
or else not Warn_On_Ada_2005_Compatibility
then
Active := False;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
- Type_Id := Expression (Assoc);
+ Type_Id := Get_Pragma_Arg (Assoc);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
- Type_Id := Expression (Assoc);
+ Type_Id := Get_Pragma_Arg (Assoc);
Find_Type (Type_Id);
Typ := Entity (Type_Id);
end if;
Check_First_Subtype (Arg1);
-
- if Has_Pragma_Pack (Typ) then
- Error_Pragma ("duplicate pragma%, only one allowed");
+ Check_Duplicate_Pragma (Typ);
-- Array type
- elsif Is_Array_Type (Typ) then
+ 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 (Esize (Ctyp) = 8 or else
- Esize (Ctyp) = 16 or else
- Esize (Ctyp) = 32 or else
- Esize (Ctyp) >= 64)
+ and then Addressable (Esize (Ctyp))
then
Ignore := True;
+ end if;
- -- Pack not allowed for aliased/atomic components
-
- elsif Has_Aliased_Components (Base_Type (Typ)) then
- Error_Pragma ("cannot pack aliased components");
-
- elsif Has_Atomic_Components (Typ)
- or else Is_Atomic (Component_Type (Typ))
- then
- Error_Pragma ("cannot pack atomic components");
-
- -- Warn for cases of packing non-atomic components of atomic
+ -- Process OK pragma Pack. Note that if there is a separate
+ -- component clause present, the Pack will be cancelled. This
+ -- processing is in Freeze.
- elsif Is_Atomic (Typ) then
- Error_Msg_NE
- ("non-atomic components of type& may not be accessible "
- & "by separate tasks?", N, Typ);
- end if;
+ if not Rep_Item_Too_Late (Typ, N) then
- -- If we had an explicit component size given, then we do not
- -- let Pack override this given size. We also give a warning
- -- that Pack is being ignored unless we can tell for sure that
- -- the Pack would not have had any effect anyway.
+ -- 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 Has_Component_Size_Clause (Typ) then
- if Known_Static_RM_Size (Component_Type (Typ))
- and then
- RM_Size (Component_Type (Typ)) = Component_Size (Typ)
- then
+ if CodePeer_Mode or ALFA_Mode then
null;
- else
- Error_Pragma
- ("?pragma% ignored, explicit component size given");
- end if;
- -- If no prior array component size given, Pack is effective
+ -- 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).
- else
- if not Rep_Item_Too_Late (Typ, N) then
+ elsif VM_Target /= No_VM then
+ if not GNAT_Mode then
+ Error_Pragma
+ ("?pragma% ignored in this configuration");
+ end if;
- -- 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 this case.
+ -- Normal case where we do the pack action
- if CodePeer_Mode then
- null;
+ else
+ if not Ignore then
+ Set_Is_Packed (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
+ end if;
- -- For normal non-VM target, do the packing
+ Set_Has_Pragma_Pack (Base_Type (Typ));
+ end if;
+ end if;
- elsif VM_Target = No_VM then
- if not Ignore then
- Set_Is_Packed (Base_Type (Typ));
- Set_Has_Non_Standard_Rep (Base_Type (Typ));
- end if;
+ -- For record types, the pack is always effective
- Set_Has_Pragma_Pack (Base_Type (Typ));
+ else pragma Assert (Is_Record_Type (Typ));
+ if not Rep_Item_Too_Late (Typ, N) then
- -- If we ignore the pack for VM_Targets, then warn about
- -- this, except suppress the warning in GNAT mode.
+ -- Ignore pack request with warning in VM mode (skip warning
+ -- if we are compiling GNAT run time library).
- elsif not GNAT_Mode then
+ if VM_Target /= No_VM then
+ if not GNAT_Mode then
Error_Pragma
("?pragma% ignored in this configuration");
end if;
- end if;
- end if;
- -- For record types, the pack is always effective
+ -- Normal case of pack request active
- else pragma Assert (Is_Record_Type (Typ));
- if not Rep_Item_Too_Late (Typ, N) then
- if VM_Target = No_VM then
+ else
Set_Is_Packed (Base_Type (Typ));
Set_Has_Pragma_Pack (Base_Type (Typ));
Set_Has_Non_Standard_Rep (Base_Type (Typ));
-
- elsif not GNAT_Mode then
- Error_Pragma ("?pragma% ignored in this configuration");
end if;
end if;
end if;
-- pragma Passive [(PASSIVE_FORM)];
- -- PASSIVE_FORM ::= Semaphore | No
+ -- PASSIVE_FORM ::= Semaphore | No
when Pragma_Passive =>
GNAT_Pragma;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
Check_First_Subtype (Arg1);
- Ent := Entity (Expression (Arg1));
+ Ent := Entity (Get_Pragma_Arg (Arg1));
- if not Is_Private_Type (Ent)
- and then not Is_Protected_Type (Ent)
+ 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 or protected type",
+ ("pragma % can only be applied to private, formal derived or "
+ & "protected type",
Arg1);
end if;
-- Persistent_BSS --
--------------------
+ -- pragma Persistent_BSS [(object_NAME)];
+
when Pragma_Persistent_BSS => Persistent_BSS : declare
Decl : Node_Id;
Ent : Entity_Id;
if Arg_Count = 1 then
Check_Arg_Is_Library_Level_Local_Name (Arg1);
- if not Is_Entity_Name (Expression (Arg1))
- or else
- (Ekind (Entity (Expression (Arg1))) /= E_Variable
- and then Ekind (Entity (Expression (Arg1))) /= E_Constant)
+ 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 (Expression (Arg1));
+ Ent := Entity (Get_Pragma_Arg (Arg1));
Decl := Parent (Ent);
if Rep_Item_Too_Late (Ent, N) then
Arg1);
end if;
+ Check_Duplicate_Pragma (Ent);
+
Prag :=
Make_Linker_Section_Pragma
(Ent, Sloc (N), ".persistent.bss");
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
- Polling_Required := (Chars (Expression (Arg1)) = Name_On);
+ Polling_Required := (Chars (Get_Pragma_Arg (Arg1)) = Name_On);
-------------------
-- Postcondition --
-------------------
- -- pragma Postcondition ([Check =>] Boolean_Expression
- -- [,[Message =>] String_Expression]);
+ -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
+ -- [,[Message =>] String_EXPRESSION]);
when Pragma_Postcondition => Postcondition : declare
In_Body : Boolean;
-- Precondition --
------------------
- -- pragma Precondition ([Check =>] Boolean_Expression
- -- [,[Message =>] String_Expression]);
+ -- pragma Precondition ([Check =>] Boolean_EXPRESSION
+ -- [,[Message =>] String_EXPRESSION]);
when Pragma_Precondition => Precondition : declare
In_Body : Boolean;
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
-- analyze the condition itself in the proper context.
if In_Body then
- if Arg_Count = 2 then
- Check_Optional_Identifier (Arg3, Name_Message);
- Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
- end if;
-
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc,
- Chars => Name_Precondition)),
+ Expression => Make_Identifier (Loc, Name_Precondition)),
Make_Pragma_Argument_Association (Sloc (Arg1),
Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
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 --
------------------
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)))
+ and then Present (Generic_Parent (Pa)))
then
if not Debug_Flag_U then
Set_Is_Preelaborated (Ent);
-- 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_12 in a predefined unit), we need to know the
+ -- 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_05 then
+ if Ada_Version_Explicit >= Ada_2005 then
Ent := Find_Lib_Unit_Name;
Set_Is_Preelaborated (Ent);
Set_Suppress_Elaboration_Warnings (Ent);
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Standard_Integer);
-- Must be static
-- Task or Protected, must be of type Integer
elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
Pragma_Misplaced;
end if;
- if Has_Priority_Pragma (P) then
+ if Has_Pragma_Priority (P) then
Error_Pragma ("duplicate pragma% not allowed");
else
- Set_Has_Priority_Pragma (P, True);
+ 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);
Check_No_Identifiers;
Check_Arg_Is_Task_Dispatching_Policy (Arg1);
Check_Valid_Configuration_Pragma;
- Get_Name_String (Chars (Expression (Arg1)));
+ Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
DP := Fold_Upper (Name_Buffer (1));
- Lower_Bound := Expression (Arg2);
+ Lower_Bound := Get_Pragma_Arg (Arg2);
Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
Lower_Val := Expr_Value (Lower_Bound);
- Upper_Bound := Expression (Arg3);
+ Upper_Bound := Get_Pragma_Arg (Arg3);
Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
Upper_Val := Expr_Value (Upper_Bound);
-- 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_12 in a predefined unit), we need to know the
+ -- 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_05 then
+ if Ada_Version_Explicit >= Ada_2005 then
Ent := Find_Lib_Unit_Name;
Set_Is_Preelaborated (Ent, False);
Set_Is_Pure (Ent);
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Error_Posted (E_Id) then
return;
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;
Check_No_Identifiers;
Check_Arg_Is_Queuing_Policy (Arg1);
Check_Valid_Configuration_Pragma;
- Get_Name_String (Chars (Expression (Arg1)));
+ Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
QP := Fold_Upper (Name_Buffer (1));
if Queuing_Policy /= ' '
Check_No_Identifiers;
Check_Arg_Count (1);
- Arg := Expression (Arg1);
+ 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.
-- The expression must be analyzed in the special manner described
-- in "Handling of Default Expressions" in sem.ads.
- Arg := Expression (Arg1);
+ Arg := Get_Pragma_Arg (Arg1);
Preanalyze_Spec_Expression (Arg, Any_Integer);
if not Is_Static_Expression (Arg) then
Check_Arg_Count (1);
Check_Arg_Is_Integer_Literal (Arg1);
- if Intval (Expression (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);
begin
Check_Arg_Is_Local_Name (Arg);
- Ent := Entity (Expression (Arg));
+ Ent := Entity (Get_Pragma_Arg (Arg));
if Has_Homonym (Ent) then
Error_Pragma_Arg
declare
Typ : constant Entity_Id :=
- Underlying_Type (Entity (Expression (Arg1)));
- Read : constant Entity_Id := Entity (Expression (Arg2));
- Write : constant Entity_Id := Entity (Expression (Arg3));
+ 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);
-- we don't need to issue error messages here.
when Pragma_Style_Checks => Style_Checks : declare
- A : constant Node_Id := Expression (Arg1);
+ A : constant Node_Id := Get_Pragma_Arg (Arg1);
S : String_Id;
C : Char_Code;
E : Entity_Id;
begin
- E_Id := Expression (Arg2);
+ E_Id := Get_Pragma_Arg (Arg2);
Analyze (E_Id);
if not Is_Entity_Name (E_Id) then
else
loop
Set_Suppress_Style_Checks (E,
- (Chars (Expression (Arg1)) = Name_Off));
+ (Chars (Get_Pragma_Arg (Arg1)) = Name_Off));
exit when No (Homonym (E));
E := Homonym (E);
end loop;
-- pragma Suppress_All;
- -- The only check made here is that the pragma appears in the proper
- -- place, i.e. following a compilation unit. If indeed it appears in
- -- this context, then the parser has already inserted an equivalent
- -- pragma Suppress (All_Checks) to get the required effect.
+ -- 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);
- if Nkind (Parent (N)) /= N_Compilation_Unit_Aux
- or else not Is_List_Member (N)
- or else List_Containing (N) /= Pragmas_After (Parent (N))
- then
- Error_Pragma
- ("misplaced pragma%, must follow compilation unit");
- end if;
-
-------------------------
-- Suppress_Debug_Info --
-------------------------
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Expression (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then
return;
E := Entity (E_Id);
- if Is_Type (E) then
- 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_Init_Proc (Full_View (Base_Type (E)));
- end if;
+ 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_Init_Proc (Base_Type (E));
+ 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
- Error_Pragma_Arg
- ("pragma% requires argument that is a type name", Arg1);
+ Set_Suppress_Initialization (E);
end if;
end Suppress_Init;
Check_No_Identifiers;
Check_Arg_Is_Task_Dispatching_Policy (Arg1);
Check_Valid_Configuration_Pragma;
- Get_Name_String (Chars (Expression (Arg1)));
+ Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
DP := Fold_Upper (Name_Buffer (1));
if Task_Dispatching_Policy /= ' '
end if;
end;
- --------------
+ ---------------
-- Task_Info --
- --------------
+ ---------------
-- pragma Task_Info (EXPRESSION);
Check_No_Identifiers;
Check_Arg_Count (1);
- Analyze_And_Resolve (Expression (Arg1), RTE (RE_Task_Info_Type));
+ Analyze_And_Resolve
+ (Get_Pragma_Arg (Arg1), RTE (RE_Task_Info_Type));
- if Etype (Expression (Arg1)) = Any_Type then
+ if Etype (Get_Pragma_Arg (Arg1)) = Any_Type then
return;
end if;
Check_No_Identifiers;
Check_Arg_Count (1);
- Arg := Expression (Arg1);
+ 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
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 ::= Normal | Robustness
+
+ when Pragma_Test_Case => Test_Case : declare
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (3);
+ 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_Normal, Name_Robustness);
+
+ if Arg_Count = 4 then
+ Check_Identifier (Arg3, Name_Requires);
+ Check_Identifier (Arg4, Name_Ensures);
+ else
+ Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
+ end if;
+
+ Check_Test_Case;
+ end Test_Case;
+
--------------------------
-- Thread_Local_Storage --
--------------------------
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
- Id := Expression (Arg1);
+ Id := Get_Pragma_Arg (Arg1);
Analyze (Id);
if not Is_Entity_Name (Id)
if Get_Source_Unit (Loc) = Main_Unit then
Opt.Time_Slice_Set := True;
- Val := Expr_Value_R (Expression (Arg1));
+ Val := Expr_Value_R (Get_Pragma_Arg (Arg1));
if Val <= Ureal_0 then
Opt.Time_Slice_Value := 0;
when Pragma_Unchecked_Union => Unchecked_Union : declare
Assoc : constant Node_Id := Arg1;
- Type_Id : constant Node_Id := Expression (Assoc);
+ Type_Id : constant Node_Id := Get_Pragma_Arg (Assoc);
Typ : Entity_Id;
Discr : Entity_Id;
Tdef : Node_Id;
("Unchecked_Union discriminant must have default value",
Discr);
end if;
+
Next_Discriminant (Discr);
end loop;
end loop;
end if;
- Set_Is_Unchecked_Union (Typ, True);
- Set_Convention (Typ, Convention_C);
-
- Set_Has_Unchecked_Union (Base_Type (Typ), True);
- Set_Is_Unchecked_Union (Base_Type (Typ), True);
+ 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;
------------------------
Check_Arg_Count (1);
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Entity (Expression (Arg1));
+ E_Id := Entity (Get_Pragma_Arg (Arg1));
if E_Id = Any_Type then
return;
Citem := First (List_Containing (N));
while Citem /= N loop
if Nkind (Citem) = N_With_Clause
- and then Same_Name (Name (Citem), Expression (Arg_Node))
+ 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 (Expression (Arg_Node), Name (Citem));
+ Set_Unit_Name
+ (Get_Pragma_Arg (Arg_Node), Name (Citem));
exit;
end if;
-- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
when Pragma_Validity_Checks => Validity_Checks : declare
- A : constant Node_Id := Expression (Arg1);
+ A : constant Node_Id := Get_Pragma_Arg (Arg1);
S : String_Id;
C : Char_Code;
Err : Boolean;
begin
- E_Id := Expression (Arg2);
+ E_Id := Get_Pragma_Arg (Arg2);
Analyze (E_Id);
-- In the expansion of an inlined body, a reference to
else
loop
Set_Warnings_Off
- (E, (Chars (Expression (Arg1)) = Name_Off));
+ (E, (Chars (Get_Pragma_Arg (Arg1)) =
+ Name_Off));
- if Chars (Expression (Arg1)) = Name_Off
+ if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
and then Warn_On_Warnings_Off
then
Warnings_Off_Pragmas.Append ((N, E));
else
String_To_Name_Buffer
- (Strval (Expr_Value_S (Expression (Arg2))));
+ (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
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
- Ent := Entity (Expression (Arg1));
+ Ent := Entity (Get_Pragma_Arg (Arg1));
if Rep_Item_Too_Early (Ent, N) then
return;
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_Enabled --
-------------------
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;
- elsif
- Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
- then
- case
- Chars (Expression (Last (Pragma_Argument_Associations (PP))))
- is
- when Name_On | Name_Check =>
- return True;
- when Name_Off | Name_Ignore =>
- return False;
- when others =>
- raise Program_Error;
- end case;
+ -- Here we have an entry see if it matches
else
- PP := Next_Pragma (PP);
+ 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;
Result := Def_Id;
while Is_Subprogram (Result)
and then
- (Is_Generic_Instance (Result)
- or else Nkind (Parent (Declaration_Node (Result))) =
- N_Subprogram_Renaming_Declaration)
+ Nkind (Parent (Declaration_Node (Result))) =
+ N_Subprogram_Renaming_Declaration
and then Present (Alias (Result))
loop
Result := Alias (Result);
return Result;
end Get_Base_Subprogram;
- --------------------
- -- Get_Pragma_Arg --
- --------------------
-
- function Get_Pragma_Arg (Arg : Node_Id) return Node_Id is
- begin
- if Nkind (Arg) = N_Pragma_Argument_Association then
- return Expression (Arg);
- else
- return Arg;
- end if;
- end Get_Pragma_Arg;
-
----------------
-- Initialize --
----------------
-- whether a given pragma is significant.
-- -1 indicates that references in any argument position are significant
- -- 0 indicates that appearence in any argument is not significant
- -- +n indicates that appearence as argument n is significant, but all
+ -- 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)
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_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
+ Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
Pragma_Elaborate => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
- Pragma_Implemented_By_Entry => -1,
+ Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 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_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_Persistent_BSS => 0,
Pragma_Postcondition => -1,
Pragma_Precondition => -1,
+ Pragma_Predicate => -1,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -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,
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. If we have a pragma
- -- Suppress_All in the Pragmas_After of the current unit, then we insert
- -- a pragma Suppress (All_Checks) at the start of the context clause to
- -- ensure the correct processing.
-
- declare
- PA : constant List_Id := Pragmas_After (Aux_Decls_Node (N));
- P : Node_Id;
+ -- 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;
- begin
- if Present (PA) then
- P := First (PA);
- while Present (P) loop
- if Pragma_Name (P) = Name_Suppress_All then
- Prepend_To (Context_Items (N),
- Make_Pragma (Sloc (P),
- Chars => Name_Suppress,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Sloc (P),
- Expression =>
- Make_Identifier (Sloc (P),
- Chars => Name_All_Checks)))));
- exit;
- end if;
+ -- Nothing else to do at the current time!
- Next (P);
- end loop;
- end if;
- end;
end Process_Compilation_Unit_Pragmas;
--------
OSDN Git Service
