-- --
-- 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.
Pname : constant Name_Id := Pragma_Name (N);
Prag_Id : Pragma_Id;
- Sense : constant Boolean := not Aspect_Cancel (N);
- -- Sense is True if we have the normal case of a pragma that is active
- -- and turns the corresponding aspect on. It is false only for the case
- -- of a pragma coming from an aspect which is explicitly turned off by
- -- using aspect => False. If Sense is False, the effect of the pragma
- -- is to turn the corresponding aspect off.
-
Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It is
-- used when an error is detected, and no further processing is
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
+ -- 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
-- 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
-- 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 in addition, if Error_Msg_Name_1 is
- -- Name_Precondition (resp Name_Postcondition) it is replaced with
- -- Name_Pre (resp Name_Post).
+ -- 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;
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
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;
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
----------------------------
procedure Check_Duplicate_Pragma (E : Entity_Id) is
- P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N));
- Arg : Node_Id;
+ P : Node_Id;
begin
-- Nothing to do if this pragma comes from an aspect specification,
-- Otherwise current pragma may duplicate previous pragma or a
-- previously given aspect specification for the same pragma.
- if Present (P) then
-
- -- Make sure pragma is for this entity, and not for some parent
- -- entity in the case of a derived type.
+ P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
- Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (P)));
+ if Present (P) then
+ Error_Msg_Name_1 := Pragma_Name (N);
+ Error_Msg_Sloc := Sloc (P);
- if Nkind (Arg) = N_Identifier
- and then Entity (Arg) = E
+ if Nkind (P) = N_Aspect_Specification
+ or else From_Aspect_Specification (P)
then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Sloc := Sloc (P);
-
- if From_Aspect_Specification (P) then
- Error_Msg_NE ("aspect% for & previously specified#", N, E);
- else
- Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
- end if;
-
- raise Pragma_Exit;
+ 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;
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 --
---------------------------
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 --
--------------------------------------
Msg (J .. J + 5) := "aspect";
end if;
end loop;
- end if;
- 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;
+ 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;
procedure Set_Atomic (E : Entity_Id) is
begin
- Set_Is_Atomic (E, Sense);
+ Set_Is_Atomic (E);
- if Sense and then not Has_Alignment_Clause (E) then
+ if not Has_Alignment_Clause (E) then
Set_Alignment (E, Uint_0);
end if;
end Set_Atomic;
-- Attribute belongs on the base type. If the view of the type is
-- currently private, it also belongs on the underlying type.
- Set_Is_Volatile (Base_Type (E), Sense);
- Set_Is_Volatile (Underlying_Type (E), Sense);
+ Set_Is_Volatile (Base_Type (E));
+ Set_Is_Volatile (Underlying_Type (E));
- Set_Treat_As_Volatile (E, Sense);
- Set_Treat_As_Volatile (Underlying_Type (E), Sense);
+ Set_Treat_As_Volatile (E);
+ Set_Treat_As_Volatile (Underlying_Type (E));
elsif K = N_Object_Declaration
or else (K = N_Component_Declaration
end if;
if Prag_Id /= Pragma_Volatile then
- Set_Is_Atomic (E, Sense);
+ Set_Is_Atomic (E);
-- If the object declaration has an explicit initialization, a
-- temporary may have to be created to hold the expression, to
if Nkind (Parent (E)) = N_Object_Declaration
and then Present (Expression (Parent (E)))
- and then Sense
then
Set_Has_Delayed_Freeze (E);
end if;
Get_Source_File_Index (Sloc (E)) =
Get_Source_File_Index (Sloc (Underlying_Type (Etype (E))))
then
- Set_Is_Atomic (Underlying_Type (Etype (E)), Sense);
+ Set_Is_Atomic (Underlying_Type (Etype (E)));
end if;
end if;
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;
-- 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;
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;
Set_Mechanism_Value
(Formal, Expression (Massoc));
- -- Set entity on identifier for ASIS
+ -- Set entity on identifier (needed by ASIS)
Set_Entity (Choice, Formal);
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 --
---------------------------------
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);
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
-- entity (if declared in the same unit) is inlined.
if Is_Subprogram (Subp) then
-
- if not Sense then
- return;
- end if;
-
Inner_Subp := Ultimate_Alias (Inner_Subp);
if In_Same_Source_Unit (Subp, Inner_Subp) then
procedure Set_Inline_Flags (Subp : Entity_Id) is
begin
if Active then
- Set_Is_Inlined (Subp, Sense);
+ Set_Is_Inlined (Subp);
end if;
if not Has_Pragma_Inline (Subp) then
- Set_Has_Pragma_Inline (Subp, Sense);
+ Set_Has_Pragma_Inline (Subp);
Effective := True;
end if;
if Prag_Id = Pragma_Inline_Always then
- Set_Has_Pragma_Inline_Always (Subp, Sense);
+ Set_Has_Pragma_Inline_Always (Subp);
end if;
end Set_Inline_Flags;
else
Make_Inline (Subp);
+ -- For the pragma case, climb homonym chain. This is
+ -- what implements allowing the pragma in the renaming
+ -- case, with the result applying to the ancestors.
+
if not From_Aspect_Specification (N) then
while Present (Homonym (Subp))
and then Scope (Homonym (Subp)) = Current_Scope
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.
+
+ 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, as they are always
+ -- 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;
-- 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;
-- Start of processing for Process_Suppress_Unsuppress
begin
- -- Ignore pragma Suppress/Unsuppress in codepeer mode on user code:
- -- we want to generate checks for analysis purposes, as set by -gnatC
+ -- 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 and then Comes_From_Source (N) then
+ if (CodePeer_Mode or ALFA_Mode)
+ and then Comes_From_Source (N)
+ then
return;
end if;
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.
-- Now set appropriate Ada mode
- if Sense then
- Ada_Version := Ada_2005;
- else
- Ada_Version := Ada_Version_Default;
- end if;
-
+ Ada_Version := Ada_2005;
Ada_Version_Explicit := Ada_2005;
end if;
end;
-- Now set appropriate Ada mode
- if Sense then
- Ada_Version := Ada_2012;
- else
- Ada_Version := Ada_Version_Default;
- end if;
-
+ 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 := Get_Pragma_Arg (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);
("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 := Base_Type (E);
end if;
- Set_Has_Volatile_Components (E, Sense);
+ Set_Has_Volatile_Components (E);
if Prag_Id = Pragma_Atomic_Components then
- Set_Has_Atomic_Components (E, Sense);
+ Set_Has_Atomic_Components (E);
end if;
else
-- 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;
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++
-- CPP_Vtable --
----------------
- when Pragma_CPP_Vtable => CPP_Vtable : declare
- begin
- GNAT_Pragma;
+ when Pragma_CPP_Vtable => CPP_Vtable : declare
+ begin
+ GNAT_Pragma;
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
+ "no effect?", N);
+ end if;
+ end CPP_Vtable;
+
+ ---------
+ -- CPU --
+ ---------
+
+ -- pragma CPU (EXPRESSION);
+
+ when Pragma_CPU => CPU : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+
+ begin
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ -- Subprogram case
+
+ if Nkind (P) = N_Subprogram_Body then
+ Check_In_Main_Program;
+
+ Arg := Get_Pragma_Arg (Arg1);
+ Analyze_And_Resolve (Arg, Any_Integer);
+
+ -- Must be static
+
+ if not Is_Static_Expression (Arg) then
+ Flag_Non_Static_Expr
+ ("main subprogram affinity is not static!", Arg);
+ raise Pragma_Exit;
+
+ -- If constraint error, then we already signalled an error
+
+ elsif Raises_Constraint_Error (Arg) then
+ null;
+
+ -- Otherwise check in range
+
+ else
+ declare
+ CPU_Id : constant Entity_Id := RTE (RE_CPU_Range);
+ -- This is the entity System.Multiprocessors.CPU_Range;
+
+ Val : constant Uint := Expr_Value (Arg);
+
+ begin
+ if Val < Expr_Value (Type_Low_Bound (CPU_Id))
+ or else
+ Val > Expr_Value (Type_High_Bound (CPU_Id))
+ then
+ Error_Pragma_Arg
+ ("main subprogram CPU is out of range", Arg1);
+ end if;
+ end;
+ end if;
+
+ Set_Main_CPU
+ (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
+
+ -- Task case
+
+ elsif Nkind (P) = N_Task_Definition then
+ Arg := Get_Pragma_Arg (Arg1);
+
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range));
+
+ -- Anything else is incorrect
+
+ else
+ Pragma_Misplaced;
+ end if;
- if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
- "no effect?", N);
+ if Has_Pragma_CPU (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Pragma_CPU (P, True);
+
+ if Nkind (P) = N_Task_Definition then
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ end if;
end if;
- end 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 => Get_Pragma_Arg (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;
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 --
---------------
-- defined in the current declarative part, and recursively
-- to any nested scope.
- Set_Discard_Names (Current_Scope, Sense);
+ Set_Discard_Names (Current_Scope);
return;
else
(Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
or else Ekind (E) = E_Exception
then
- Set_Discard_Names (E, Sense);
+ Set_Discard_Names (E);
else
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
then
Set_Elaborate_Present (Citem, True);
Set_Unit_Name (Get_Pragma_Arg (Arg), Name (Citem));
+ Generate_Reference (Entity (Name (Citem)), Citem);
-- With the pragma present, elaboration calls on
-- subprograms from the named unit need no further
end if;
if (Present (Parameter_Types)
- or else
+ or else
Present (Result_Type))
and then
Present (Source_Location)
-- subtype), set the flag on that type.
if Is_Access_Subprogram_Type (Named_Entity) then
- if Sense then
- Set_Can_Use_Internal_Rep (Named_Entity, False);
- end if;
+ Set_Can_Use_Internal_Rep (Named_Entity, False);
-- Otherwise it's an error (name denotes the wrong sort of entity)
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;
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 --
----------------------
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;
-- 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.
+ -- so disable handling of pragma Pack in these cases.
- if CodePeer_Mode then
+ if CodePeer_Mode or ALFA_Mode then
null;
-- Don't attempt any packing for VM targets. We possibly
else
if not Ignore then
- Set_Is_Packed (Base_Type (Typ), Sense);
- Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
+ Set_Is_Packed (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
end if;
- Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
-
- -- Complete reset action for Aspect_Cancel case
-
- if Sense = False then
-
- -- Cancel size unless explicitly set
-
- if not Has_Size_Clause (Typ)
- and then not Has_Object_Size_Clause (Typ)
- then
- Set_Esize (Typ, Uint_0);
- Set_RM_Size (Typ, Uint_0);
- Set_Alignment (Typ, Uint_0);
- Set_Packed_Array_Type (Typ, Empty);
- end if;
-
- -- Reset component size unless explicitly set
-
- if not Has_Component_Size_Clause (Typ) then
- if Known_Static_Esize (Ctyp)
- and then Known_Static_RM_Size (Ctyp)
- and then Esize (Ctyp) = RM_Size (Ctyp)
- and then Addressable (Esize (Ctyp))
- then
- Set_Component_Size
- (Base_Type (Typ), Esize (Ctyp));
- else
- Set_Component_Size
- (Base_Type (Typ), Uint_0);
- end if;
- end if;
- end if;
+ Set_Has_Pragma_Pack (Base_Type (Typ));
end if;
end if;
-- Normal case of pack request active
else
- Set_Is_Packed (Base_Type (Typ), Sense);
- Set_Has_Pragma_Pack (Base_Type (Typ), Sense);
- Set_Has_Non_Standard_Rep (Base_Type (Typ), Sense);
-
- -- Complete reset action for Aspect_Cancel case
-
- if Sense = False then
-
- -- Cancel size if not explicitly given
-
- if not Has_Size_Clause (Typ)
- and then not Has_Object_Size_Clause (Typ)
- then
- Set_Esize (Typ, Uint_0);
- Set_Alignment (Typ, Uint_0);
- end if;
- end if;
+ Set_Is_Packed (Base_Type (Typ));
+ Set_Has_Pragma_Pack (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
end if;
end if;
end if;
Check_First_Subtype (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;
Check_Duplicate_Pragma (Ent);
- if Sense then
- Prag :=
- Make_Linker_Section_Pragma
- (Ent, Sloc (N), ".persistent.bss");
- Insert_After (N, Prag);
- Analyze (Prag);
- end if;
+ Prag :=
+ Make_Linker_Section_Pragma
+ (Ent, Sloc (N), ".persistent.bss");
+ Insert_After (N, Prag);
+ Analyze (Prag);
-- Case of use as configuration pragma with no arguments
-- 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 --
------------------
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, Sense);
- Set_Suppress_Elaboration_Warnings (Ent, Sense);
+ Set_Is_Preelaborated (Ent);
+ Set_Suppress_Elaboration_Warnings (Ent);
end if;
end if;
end Preelaborate;
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);
("pragma% requires a function name", Arg1);
end if;
- Set_Is_Pure (Def_Id, Sense);
+ Set_Is_Pure (Def_Id);
if not Has_Pragma_Pure_Function (Def_Id) then
- Set_Has_Pragma_Pure_Function (Def_Id, Sense);
- Effective := Sense;
+ Set_Has_Pragma_Pure_Function (Def_Id);
+ Effective := True;
end if;
exit when From_Aspect_Specification (N);
exit when No (E) or else Scope (E) /= Current_Scope;
end loop;
- if Sense and then not Effective
+ if not Effective
and then Warn_On_Redundant_Constructs
then
Error_Msg_NE
-- 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
- if not CodePeer_Mode then
- Error_Pragma
- ("misplaced pragma%, must follow compilation unit");
- end if;
- end if;
-
-------------------------
-- Suppress_Debug_Info --
-------------------------
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)), Sense);
+ Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
----------------------------------
-- Suppress_Exception_Locations --
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;
end if;
end;
- --------------
+ ---------------
-- Task_Info --
- --------------
+ ---------------
-- pragma Task_Info (EXPRESSION);
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 --
--------------------------
end loop;
end if;
- Set_Is_Unchecked_Union (Typ, Sense);
-
- if Sense then
- Set_Convention (Typ, Convention_C);
- end if;
-
- Set_Has_Unchecked_Union (Base_Type (Typ), Sense);
- Set_Is_Unchecked_Union (Base_Type (Typ), Sense);
+ 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;
------------------------
Error_Pragma_Arg ("pragma% requires type", Arg1);
end if;
- Set_Universal_Aliasing (Implementation_Base_Type (E_Id), Sense);
+ Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
end Universal_Alias;
--------------------
("pragma% can only be applied to a variable",
Arg_Expr);
else
- Set_Has_Pragma_Unmodified (Arg_Ent, Sense);
+ Set_Has_Pragma_Unmodified (Arg_Ent);
end if;
end if;
Generate_Reference (Arg_Ent, N);
end if;
- Set_Has_Pragma_Unreferenced (Arg_Ent, Sense);
+ Set_Has_Pragma_Unreferenced (Arg_Ent);
end if;
Next (Arg_Node);
("argument for pragma% must be type or subtype", Arg_Node);
end if;
- Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr), Sense);
+ Set_Has_Pragma_Unreferenced_Objects (Entity (Arg_Expr));
Next (Arg_Node);
end loop;
end Unreferenced_Objects;
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_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
