-- --
-- 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 Uname; use Uname;
with Urealp; use Urealp;
with Validsw; use Validsw;
+with Warnsw; use Warnsw;
package body Sem_Prag is
-- 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
-- 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.
+ -- 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
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end Check_Arg_Is_One_Of;
+
---------------------------------
-- Check_Arg_Is_Queuing_Policy --
---------------------------------
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 --
("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)
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;
-- 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
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 --
--------------------------------------
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.
procedure Process_Import_Predefined_Type is
Loc : constant Source_Ptr := Sloc (N);
- Ftyp : Node_Id := First (Predefined_Float_Types);
+ 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;
- while Present (Ftyp) and then Chars (Ftyp) /= Nam loop
- Next (Ftyp);
+ 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
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
- -- Should never have a predefined type we cannot handle
raise Program_Error;
end if;
elsif Is_Record_Type (Def_Id)
and then C = Convention_CPP
then
- -- Types treated as CPP classes are treated as limited, but we
- -- don't require them to be declared this way. A warning is issued
- -- to encourage the user to declare them as limited. This is not
- -- an error, for compatibility reasons, because these types have
- -- been supported this way for some time.
+ -- Types treated as CPP classes must be declared limited (note:
+ -- this used to be a warning but there is no real benefit to it
+ -- since we did effectively intend to treat the type as limited
+ -- anyway).
if not Is_Limited_Type (Def_Id) then
Error_Msg_N
- ("imported 'C'P'P type should be " &
- "explicitly declared limited?",
- Get_Pragma_Arg (Arg2));
- Error_Msg_N
- ("\type will be considered limited",
+ ("imported 'C'P'P type must be limited",
Get_Pragma_Arg (Arg2));
end if;
Set_Is_CPP_Class (Def_Id);
- Set_Is_Limited_Record (Def_Id);
-- Imported CPP types must not have discriminants (because C++
-- classes do not have discriminants).
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 mode
+ -- Ignore all Restrictions pragma in CodePeer and ALFA modes
- if CodePeer_Mode then
+ if CodePeer_Mode or ALFA_Mode then
return;
end if;
-- 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;
-- 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;
------------
("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
-- 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++
-- 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;
Debug_Pragmas_Enabled :=
Chars (Get_Pragma_Arg (Arg1)) = Name_Check;
- -----------------------------
- -- Default_Component_Value --
- -----------------------------
-
- when Pragma_Default_Component_Value => declare
- Arg : Node_Id;
- E : Entity_Id;
-
- begin
- GNAT_Pragma;
- Check_Arg_Count (2);
- Check_Arg_Is_Local_Name (Arg1);
-
- Arg := Get_Pragma_Arg (Arg1);
- Analyze (Arg);
-
- if Etype (Arg) = Any_Type then
- return;
- end if;
-
- if not Is_Entity_Name (Arg)
- or else not Is_Array_Type (Entity (Arg))
- then
- Error_Pragma_Arg ("pragma% requires an array type", Arg1);
- end if;
-
- Check_First_Subtype (Arg1);
-
- E := Entity (Arg);
- Check_Duplicate_Pragma (E);
-
- -- Check for rep item too early or too late, but skip this if
- -- the pragma comes from the corresponding aspect, since we do
- -- not need the checks, and more importantly, the pragma is on
- -- the rep item chain alreay, and must not be put there twice!
-
- if not From_Aspect_Specification (N) then
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
- then
- return;
- end if;
- end if;
-
- -- Analyze the default value
-
- Arg := Get_Pragma_Arg (Arg2);
- Analyze_And_Resolve (Arg, Component_Type (E));
-
- if not Is_OK_Static_Expression (Arg) then
- Flag_Non_Static_Expr
- ("non-static expression not allowed for " &
- "Default_Component_Value",
- Arg2);
- raise Pragma_Exit;
- end if;
-
- -- Set the flag on the root type and then check for Rep_Item too
- -- early or too late, the latter call chains the pragma onto the
- -- Rep_Item chain.
-
- Set_Has_Default_Component_Value (Base_Type (E));
- end;
-
- -------------------
- -- Default_Value --
- -------------------
-
- when Pragma_Default_Value => declare
- Arg : Node_Id;
- E : Entity_Id;
-
- begin
- -- Error checks
-
- GNAT_Pragma;
- Check_Arg_Count (2);
- Check_Arg_Is_Local_Name (Arg1);
-
- Arg := Get_Pragma_Arg (Arg1);
- Analyze (Arg);
-
- if Etype (Arg) = Any_Type then
- return;
- end if;
-
- if not Is_Entity_Name (Arg)
- or else not Is_Scalar_Type (Entity (Arg))
- then
- Error_Pragma_Arg ("pragma% requires a scalar type", Arg1);
- end if;
-
- Check_First_Subtype (Arg1);
-
- E := Entity (Arg);
- Check_Duplicate_Pragma (E);
-
- -- Check for rep item too early or too late, but skip this if
- -- the pragma comes from the corresponding aspect, since we do
- -- not need the checks, and more importantly, the pragma is on
- -- the rep item chain alreay, and must not be put there twice!
-
- if not From_Aspect_Specification (N) then
- if Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
- then
- return;
- end if;
- end if;
-
- -- Analyze the default value. Note that we must do that after
- -- checking for Rep_Item_Too_Late since this resolution will
- -- freeze the type involved.
-
- Arg := Get_Pragma_Arg (Arg2);
- Analyze_And_Resolve (Arg, E);
-
- if not Is_OK_Static_Expression (Arg) then
- Flag_Non_Static_Expr
- ("non-static expression not allowed for Default_Value",
- Arg2);
- raise Pragma_Exit;
- end if;
-
- -- Set the flag on the root type and then check for Rep_Item too
- -- early or too late, the latter call chains the pragma onto the
- -- Rep_Item chain.
-
- Set_Has_Default_Value (Base_Type (E));
- end;
-
---------------------
-- Detect_Blocking --
---------------------
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)
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;
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;
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 --
--------------------------
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 --
-------------------
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);
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
- Pragma_Default_Value => -1,
- Pragma_Default_Component_Value => -1,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
Pragma_Dimension => -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 --
--------------------------------------
OSDN Git Service
