-- to complete the syntax checks. Certain pragmas are handled partially or
-- completely by the parser (see Par.Prag for further details).
+with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
with Checks; use Checks;
with Errout; use Errout;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Lib.Xref; use Lib.Xref;
-- original one, following the renaming chain) is returned. Otherwise the
-- entity is returned unchanged. Should be in Einfo???
+ procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id);
+ -- Preanalyze the boolean expressions in the Requires and Ensures arguments
+ -- of a Test_Case pragma if present (possibly Empty). We treat these as
+ -- spec expressions (i.e. similar to a default expression).
+
procedure rv;
-- This is a dummy function called by the processing for pragma Reviewable.
-- It is there for assisting front end debugging. By placing a Reviewable
-- Preanalyze the boolean expression, we treat this as a spec expression
-- (i.e. similar to a default expression).
- pragma Assert (In_Pre_Post_Expression = False);
- In_Pre_Post_Expression := True;
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
- In_Pre_Post_Expression := False;
+
+ -- For a class-wide condition, a reference to a controlling formal must
+ -- be interpreted as having the class-wide type (or an access to such)
+ -- so that the inherited condition can be properly applied to any
+ -- overriding operation (see ARM12 6.6.1 (7)).
+
+ if Class_Present (N) then
+ declare
+ T : constant Entity_Id := Find_Dispatching_Type (S);
+
+ ACW : Entity_Id := Empty;
+ -- Access to T'class, created if there is a controlling formal
+ -- that is an access parameter.
+
+ function Get_ACW return Entity_Id;
+ -- If the expression has a reference to an controlling access
+ -- parameter, create an access to T'class for the necessary
+ -- conversions if one does not exist.
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
+ -- aspect for a primitive subprogram of a tagged type T, a name
+ -- that denotes a formal parameter of type T is interpreted as
+ -- having type T'Class. Similarly, a name that denotes a formal
+ -- accessparameter of type access-to-T is interpreted as having
+ -- type access-to-T'Class. This ensures the expression is well-
+ -- defined for a primitive subprogram of a type descended from T.
+
+ -------------
+ -- Get_ACW --
+ -------------
+
+ function Get_ACW return Entity_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+ Decl : Node_Id;
+
+ begin
+ if No (ACW) then
+ Decl := Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Class_Wide_Type (T), Loc),
+ All_Present => True));
+
+ Insert_Before (Unit_Declaration_Node (S), Decl);
+ Analyze (Decl);
+ ACW := Defining_Identifier (Decl);
+ Freeze_Before (Unit_Declaration_Node (S), ACW);
+ end if;
+
+ return ACW;
+ end Get_ACW;
+
+ -------------
+ -- Process --
+ -------------
+
+ function Process (N : Node_Id) return Traverse_Result is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : Entity_Id;
+
+ begin
+ if Is_Entity_Name (N)
+ and then Is_Formal (Entity (N))
+ and then Nkind (Parent (N)) /= N_Type_Conversion
+ then
+ if Etype (Entity (N)) = T then
+ Typ := Class_Wide_Type (T);
+
+ elsif Is_Access_Type (Etype (Entity (N)))
+ and then Designated_Type (Etype (Entity (N))) = T
+ then
+ Typ := Get_ACW;
+ else
+ Typ := Empty;
+ end if;
+
+ if Present (Typ) then
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Expression => New_Occurrence_Of (Entity (N), Loc)));
+ Set_Etype (N, Typ);
+ end if;
+ end if;
+
+ return OK;
+ end Process;
+
+ procedure Replace_Type is new Traverse_Proc (Process);
+
+ begin
+ Replace_Type (Get_Pragma_Arg (Arg1));
+ end;
+ end if;
-- Remove the subprogram from the scope stack now that the pre-analysis
-- of the precondition/postcondition is done.
procedure Analyze_Pragma (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Pname : constant Name_Id := Pragma_Name (N);
Prag_Id : Pragma_Id;
+ Pname : Name_Id;
+ -- Name of the source pragma, or name of the corresponding aspect for
+ -- pragmas which originate in a source aspect. In the latter case, the
+ -- name may be different from the pragma name.
+
Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It is
-- used when an error is detected, and no further processing is
-- Check the specified argument Arg to make sure that it is a valid
-- locking policy name. If not give error and raise Pragma_Exit.
- procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
- procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3 : Name_Id);
- procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2, N3, N4 : Name_Id);
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2 : Name_Id);
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3 : Name_Id);
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
+ N1, N2, N3, N4, N5 : Name_Id);
-- Check the specified argument Arg to make sure that it is an
- -- identifier whose name matches either N1 or N2 (or N3 if present).
- -- If not then give error and raise Pragma_Exit.
+ -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
+ -- present). If not then give error and raise Pragma_Exit.
procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id);
-- Check the specified argument Arg to make sure that it is a valid
-- Checks that Arg, whose expression is an entity name, references a
-- first subtype.
+ procedure Check_Identifier (Arg : Node_Id; Id : Name_Id);
+ -- Checks that the given argument has an identifier, and if so, requires
+ -- it to match the given identifier name. If there is no identifier, or
+ -- a non-matching identifier, then an error message is given and
+ -- Pragma_Exit is raised.
+
+ procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id);
+ -- Checks that the given argument has an identifier, and if so, requires
+ -- it to match one of the given identifier names. If there is no
+ -- identifier, or a non-matching identifier, then an error message is
+ -- given and Pragma_Exit is raised.
+
procedure Check_In_Main_Program;
-- Common checks for pragmas that appear within a main program
-- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
procedure Check_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,
+ -- except the placement rules for the test-case pragma are stricter.
+ -- This pragma may only occur after a subprogram spec declared directly
+ -- in a package spec unit. In this case, the pragma is chained to the
+ -- subprogram in question (using Spec_TC_List and Next_Pragma) and
+ -- analysis of the pragma is delayed till the end of the spec. In
+ -- all other cases, an error message for bad placement is given.
+
procedure Check_Valid_Configuration_Pragma;
-- Legality checks for placement of a configuration pragma
if Is_Compilation_Unit (Ent) then
declare
Decl : constant Node_Id := Unit_Declaration_Node (Ent);
+
begin
-- Case of pragma placed immediately after spec
end Check_Arg_Is_One_Of;
procedure Check_Arg_Is_One_Of
- (Arg : Node_Id;
- N1, N2, N3, N4 : Name_Id)
+ (Arg : Node_Id;
+ N1, N2, N3, N4, N5 : Name_Id)
is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
and then Chars (Argx) /= N2
and then Chars (Argx) /= N3
and then Chars (Argx) /= N4
+ and then Chars (Argx) /= N5
then
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end 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 --
---------------------------
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 --
if Pragma_Name (N) = Name_Precondition then
if not From_Aspect_Specification (N) then
- P := Spec_PPC_List (S);
+ P := Spec_PPC_List (Contract (S));
while Present (P) loop
if Pragma_Name (P) = Name_Precondition
and then From_Aspect_Specification (P)
begin
for J in Inherited'Range loop
- P := Spec_PPC_List (Inherited (J));
+ P := Spec_PPC_List (Contract (Inherited (J)));
while Present (P) loop
if Pragma_Name (P) = Name_Precondition
and then Class_Present (P)
-- 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
(Get_Pragma_Arg (Arg2), Standard_String);
end if;
- -- Record if pragma is enabled
+ -- Record if pragma is disabled
if Check_Enabled (Pname) then
- Set_Pragma_Enabled (N);
Set_SCO_Pragma_Enabled (Loc);
end if;
Chain_PPC (PO);
return;
+ elsif Nkind (PO) = N_Subprogram_Declaration
+ and then In_Instance
+ then
+ Chain_PPC (PO);
+ return;
+
-- For all other cases of non source code, do nothing
else
-- See if it is in the pragmas after a library level subprogram
elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then
+
+ -- In formal verification mode, analyze pragma expression for
+ -- correctness, as it is not expanded later.
+
+ if Alfa_Mode then
+ Analyze_PPC_In_Decl_Part
+ (N, Defining_Entity (Unit (Parent (Parent (N)))));
+ end if;
+
Chain_PPC (Unit (Parent (Parent (N))));
return;
end if;
end case;
end Check_Static_Constraint;
+ ---------------------
+ -- Check_Test_Case --
+ ---------------------
+
+ procedure Check_Test_Case is
+ P : Node_Id;
+ PO : Node_Id;
+
+ procedure Chain_TC (PO : Node_Id);
+ -- If PO is a [generic] subprogram declaration node, then the
+ -- test-case applies to this subprogram and the processing for the
+ -- pragma is completed. Otherwise the pragma is misplaced.
+
+ --------------
+ -- Chain_TC --
+ --------------
+
+ procedure Chain_TC (PO : Node_Id) is
+ S : Entity_Id;
+
+ begin
+ if Nkind (PO) = N_Abstract_Subprogram_Declaration then
+ if From_Aspect_Specification (N) then
+ Error_Pragma
+ ("aspect% cannot be applied to abstract subprogram");
+ else
+ Error_Pragma
+ ("pragma% cannot be applied to abstract subprogram");
+ end if;
+
+ elsif Nkind (PO) = N_Entry_Declaration then
+ if From_Aspect_Specification (N) then
+ Error_Pragma ("aspect% cannot be applied to entry");
+ else
+ Error_Pragma ("pragma% cannot be applied to entry");
+ end if;
+
+ elsif not Nkind_In (PO, N_Subprogram_Declaration,
+ N_Generic_Subprogram_Declaration)
+ then
+ Pragma_Misplaced;
+ end if;
+
+ -- Here if we have [generic] subprogram declaration
+
+ S := Defining_Unit_Name (Specification (PO));
+
+ -- Note: we do not analyze the pragma at this point. Instead we
+ -- delay this analysis until the end of the declarative part in
+ -- which the pragma appears. This implements the required delay
+ -- in this analysis, allowing forward references. The analysis
+ -- happens at the end of Analyze_Declarations.
+
+ -- There should not be another test case with the same name
+ -- associated to this subprogram.
+
+ declare
+ Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N);
+ TC : Node_Id;
+
+ begin
+ TC := Spec_TC_List (Contract (S));
+ while Present (TC) loop
+
+ if String_Equal
+ (Name, Get_Name_From_Test_Case_Pragma (TC))
+ then
+ Error_Msg_Sloc := Sloc (TC);
+
+ if From_Aspect_Specification (N) then
+ Error_Pragma ("name for aspect% is already used#");
+ else
+ Error_Pragma ("name for pragma% is already used#");
+ end if;
+ end if;
+
+ TC := Next_Pragma (TC);
+ end loop;
+ end;
+
+ -- Chain spec TC pragma to list for subprogram
+
+ Set_Next_Pragma (N, Spec_TC_List (Contract (S)));
+ Set_Spec_TC_List (Contract (S), N);
+ end Chain_TC;
+
+ -- Start of processing for Check_Test_Case
+
+ begin
+ if not Is_List_Member (N) then
+ Pragma_Misplaced;
+ end if;
+
+ -- Test cases should only appear in package spec unit
+
+ if Get_Source_Unit (N) = No_Unit
+ or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))),
+ N_Package_Declaration,
+ N_Generic_Package_Declaration)
+ then
+ Pragma_Misplaced;
+ end if;
+
+ -- Search prior declarations
+
+ P := N;
+ while Present (Prev (P)) loop
+ P := Prev (P);
+
+ -- If the previous node is a generic subprogram, do not go to to
+ -- the original node, which is the unanalyzed tree: we need to
+ -- attach the test-case to the analyzed version at this point.
+ -- They get propagated to the original tree when analyzing the
+ -- corresponding body.
+
+ if Nkind (P) not in N_Generic_Declaration then
+ PO := Original_Node (P);
+ else
+ PO := P;
+ end if;
+
+ -- Skip past prior pragma
+
+ if Nkind (PO) = N_Pragma then
+ null;
+
+ -- Skip stuff not coming from source
+
+ elsif not Comes_From_Source (PO) then
+ null;
+
+ -- Only remaining possibility is subprogram declaration. First
+ -- check that it is declared directly in a package declaration.
+ -- This may be either the package declaration for the current unit
+ -- being defined or a local package declaration.
+
+ elsif not Present (Parent (Parent (PO)))
+ or else not Present (Parent (Parent (Parent (PO))))
+ or else not Nkind_In (Parent (Parent (PO)),
+ N_Package_Declaration,
+ N_Generic_Package_Declaration)
+ then
+ Pragma_Misplaced;
+
+ else
+ Chain_TC (PO);
+ return;
+ end if;
+ end loop;
+
+ -- If we fall through, pragma was misplaced
+
+ Pragma_Misplaced;
+ end Check_Test_Case;
+
--------------------------------------
-- Check_Valid_Configuration_Pragma --
--------------------------------------
then
null;
end if;
+
+ -- Inline is a program unit pragma (RM 10.1.5) and cannot
+ -- appear in a formal part to apply to a formal subprogram.
+ -- Do not apply check within an instance or a formal package
+ -- the test will have been applied to the original generic.
+
+ elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
+ and then List_Containing (Decl) = List_Containing (N)
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("Inline cannot apply to a formal subprogram", N);
end if;
end if;
-- 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.
+ -- case, with the result applying to the ancestors, and
+ -- also allows Inline to apply to all previous homonyms.
if not From_Aspect_Specification (N) then
while Present (Homonym (Subp))
(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;
elsif Id = Name_No_Dependence then
Check_Unit_Name (Expr);
+ -- Case of No_Specification_Of_Aspect => Identifier.
+
+ elsif Id = Name_No_Specification_Of_Aspect then
+ declare
+ A_Id : Aspect_Id;
+
+ begin
+ if Nkind (Expr) /= N_Identifier then
+ A_Id := No_Aspect;
+ else
+ A_Id := Get_Aspect_Id (Chars (Expr));
+ end if;
+
+ if A_Id = No_Aspect then
+ Error_Pragma_Arg ("invalid restriction name", Arg);
+ else
+ Set_Restriction_No_Specification_Of_Aspect (Expr, Warn);
+ end if;
+ end;
+
-- All other cases of restriction identifier present
else
-- 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;
-- Deal with unrecognized pragma
+ Pname := Pragma_Name (N);
+
if not Is_Pragma_Name (Pname) then
if Warn_On_Unrecognized_Pragma then
Error_Msg_Name_1 := Pname;
Prag_Id := Get_Pragma_Id (Pname);
+ if Present (Corresponding_Aspect (N)) then
+ Pname := Chars (Identifier (Corresponding_Aspect (N)));
+ end if;
+
-- Preset arguments
Arg_Count := 0;
-- 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;
------------
Rewrite (N,
Make_Pragma (Loc,
- Chars => Name_Check,
+ Chars => Name_Check,
Pragma_Argument_Associations => Newa));
Analyze (N);
end Assert;
-- Assertion_Policy --
----------------------
- -- pragma Assertion_Policy (Check | Ignore)
+ -- pragma Assertion_Policy (Check | Disable |Ignore)
when Pragma_Assertion_Policy => Assertion_Policy : declare
Policy : Node_Id;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
- Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
+ Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
-- We treat pragma Assertion_Policy as equivalent to:
-- 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_Arg_Is_Identifier (Arg1);
+ -- Completely ignore if disabled
+
+ if Check_Disabled (Chars (Get_Pragma_Arg (Arg1))) then
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ return;
+ end if;
+
-- Indicate if pragma is enabled. The Original_Node reference here
-- is to deal with pragma Assert rewritten as a Check pragma.
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
if Check_On then
- Set_Pragma_Enabled (N);
- Set_Pragma_Enabled (Original_Node (N));
Set_SCO_Pragma_Enabled (Loc);
end if;
-- [Name =>] IDENTIFIER,
-- [Policy =>] POLICY_IDENTIFIER);
- -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE
+ -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE
-- Note: this is a configuration pragma, but it is allowed to appear
-- anywhere else.
Check_Optional_Identifier (Arg1, Name_Name);
Check_Optional_Identifier (Arg2, Name_Policy);
Check_Arg_Is_One_Of
- (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore);
+ (Arg2, Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
-- A Check_Policy pragma can appear either as a configuration
-- pragma, or in a declarative part or a package spec (see RM
-- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
when Pragma_Debug => Debug : declare
- Cond : Node_Id;
+ Cond : Node_Id;
+ Call : Node_Id;
begin
GNAT_Pragma;
+ -- Skip analysis if disabled
+
+ if Debug_Pragmas_Disabled then
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ return;
+ end if;
+
Cond :=
New_Occurrence_Of
(Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active),
Loc);
+ if Debug_Pragmas_Enabled then
+ Set_SCO_Pragma_Enabled (Loc);
+ end if;
+
if Arg_Count = 2 then
Cond :=
Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Cond),
- Right_Opnd => Get_Pragma_Arg (Arg1));
+ 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;
when Pragma_Debug_Policy =>
GNAT_Pragma;
Check_Arg_Count (1);
- Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore);
+ Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore);
Debug_Pragmas_Enabled :=
Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
+ Debug_Pragmas_Disabled :=
+ Chars (Get_Pragma_Arg (Arg1)) = Name_Disable;
---------------------
-- Detect_Blocking --
end if;
end Discard_Names;
+ ------------------------
+ -- Dispatching_Domain --
+ ------------------------
+
+ -- pragma Dispatching_Domain (EXPRESSION);
+
+ when Pragma_Dispatching_Domain => Dispatching_Domain : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+
+ begin
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ -- This pragma is born obsolete, but not the aspect
+
+ if not From_Aspect_Specification (N) then
+ Check_Restriction
+ (No_Obsolescent_Features, Pragma_Identifier (N));
+ end if;
+
+ if Nkind (P) = N_Task_Definition then
+ Arg := Get_Pragma_Arg (Arg1);
+
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
+
+ -- Anything else is incorrect
+
+ else
+ Pragma_Misplaced;
+ end if;
+
+ if Has_Pragma_Dispatching_Domain (P) then
+ Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Set_Has_Pragma_Dispatching_Domain (P, True);
+
+ if Nkind (P) = N_Task_Definition then
+ Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ end if;
+ end if;
+ end Dispatching_Domain;
+
---------------
-- Elaborate --
---------------
end;
end Ident;
+ ----------------------------
+ -- Implementation_Defined --
+ ----------------------------
+
+ -- pragma Implementation_Defined (local_NAME);
+
+ -- Marks previously declared entity as implementation defined. For
+ -- an overloaded entity, applies to the most recent homonym.
+
+ -- pragma Implementation_Defined;
+
+ -- The form with no arguments appears anywhere within a scope, most
+ -- typically a package spec, and indicates that all entities that are
+ -- defined within the package spec are Implementation_Defined.
+
+ when Pragma_Implementation_Defined => Implementation_Defined : declare
+ Ent : Entity_Id;
+
+ begin
+ Check_No_Identifiers;
+
+ -- Form with no arguments
+
+ if Arg_Count = 0 then
+ Set_Is_Implementation_Defined (Current_Scope);
+
+ -- Form with one argument
+
+ else
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ Ent := Entity (Get_Pragma_Arg (Arg1));
+ Set_Is_Implementation_Defined (Ent);
+ end if;
+ end Implementation_Defined;
+
-----------------
-- Implemented --
-----------------
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 Typ = Any_Type then
return;
- elsif not Ekind_In (Typ, E_Private_Type,
- E_Record_Type_With_Private,
- E_Limited_Private_Type)
+ -- An invariant must apply to a private type, or appear in the
+ -- private part of a package spec and apply to a completion.
+
+ elsif Ekind_In (Typ, E_Private_Type,
+ E_Record_Type_With_Private,
+ E_Limited_Private_Type)
+ then
+ null;
+
+ elsif In_Private_Part (Current_Scope)
+ and then Has_Private_Declaration (Typ)
then
+ null;
+
+ elsif In_Private_Part (Current_Scope) then
+ Error_Pragma_Arg
+ ("pragma% only allowed for private type " &
+ "declared in visible part", Arg1);
+
+ else
Error_Pragma_Arg
("pragma% only allowed for private type", Arg1);
end if;
-- pragma Locking_Policy (policy_IDENTIFIER);
when Pragma_Locking_Policy => declare
- LP : Character;
-
+ subtype LP_Range is Name_Id
+ range First_Locking_Policy_Name .. Last_Locking_Policy_Name;
+ LP_Val : LP_Range;
+ LP : Character;
begin
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Locking_Policy (Arg1);
Check_Valid_Configuration_Pragma;
- Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
- LP := Fold_Upper (Name_Buffer (1));
+ LP_Val := Chars (Get_Pragma_Arg (Arg1));
+
+ case LP_Val is
+ when Name_Ceiling_Locking => LP := 'C';
+ when Name_Inheritance_Locking => LP := 'I';
+ when Name_Concurrent_Readers_Locking => LP := 'R';
+ end case;
if Locking_Policy /= ' '
and then Locking_Policy /= LP
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
-- 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;
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
+
begin
if Chars (Argx) = Name_Ravenscar then
Set_Ravenscar_Profile (N);
+
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions
- (Restricted, N, Warn => Treat_Restrictions_As_Warnings);
+ (Restricted,
+ N, Warn => Treat_Restrictions_As_Warnings);
+
+ elsif Chars (Argx) = Name_No_Implementation_Extensions then
+ Set_Profile_Restrictions
+ (No_Implementation_Extensions,
+ N, Warn => Treat_Restrictions_As_Warnings);
+
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
+
begin
if Chars (Argx) = Name_Ravenscar then
Set_Profile_Restrictions (Ravenscar, N, Warn => True);
+
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => True);
+
+ elsif Chars (Argx) = Name_No_Implementation_Extensions then
+ Set_Profile_Restrictions
+ (No_Implementation_Extensions, N, Warn => True);
+
else
Error_Pragma_Arg ("& is not a valid profile", Argx);
end if;
end 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 ::= Nominal | Robustness
+
+ when Pragma_Test_Case => Test_Case : declare
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (2);
+ Check_At_Most_N_Arguments (4);
+ Check_Arg_Order
+ ((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
+
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Check_Optional_Identifier (Arg2, Name_Mode);
+ Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
+
+ if Arg_Count = 4 then
+ Check_Identifier (Arg3, Name_Requires);
+ Check_Identifier (Arg4, Name_Ensures);
+
+ elsif Arg_Count = 3 then
+ Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures);
+ end if;
+
+ Check_Test_Case;
+ end Test_Case;
+
--------------------------
-- Thread_Local_Storage --
--------------------------
when Pragma_Exit => null;
end Analyze_Pragma;
+ -----------------------------
+ -- Analyze_TC_In_Decl_Part --
+ -----------------------------
+
+ procedure Analyze_TC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
+ begin
+ -- Install formals and push subprogram spec onto scope stack so that we
+ -- can see the formals from the pragma.
+
+ Install_Formals (S);
+ Push_Scope (S);
+
+ -- Preanalyze the boolean expressions, we treat these as spec
+ -- expressions (i.e. similar to a default expression).
+
+ Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N),
+ Get_Ensures_From_Test_Case_Pragma (N));
+
+ -- Remove the subprogram from the scope stack now that the pre-analysis
+ -- of the expressions in the test-case is done.
+
+ End_Scope;
+ end Analyze_TC_In_Decl_Part;
+
+ --------------------
+ -- Check_Disabled --
+ --------------------
+
+ function Check_Disabled (Nam : Name_Id) return Boolean is
+ PP : Node_Id;
+
+ begin
+ -- Loop through entries in check policy list
+
+ PP := Opt.Check_Policy_List;
+ loop
+ -- If there are no specific entries that matched, then nothing is
+ -- disabled, so return False.
+
+ if No (PP) then
+ return False;
+
+ -- Here we have an entry see if it matches
+
+ else
+ declare
+ PPA : constant List_Id := Pragma_Argument_Associations (PP);
+ begin
+ if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
+ return Chars (Get_Pragma_Arg (Last (PPA))) = Name_Disable;
+ else
+ PP := Next_Pragma (PP);
+ end if;
+ end;
+ end if;
+ end loop;
+ end Check_Disabled;
+
-------------------
-- Check_Enabled --
-------------------
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
+ Pragma_Dispatching_Domain => -1,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
+ Pragma_Implementation_Defined => -1,
Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_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 --
--------------------------------------
OSDN Git Service
