-- 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);
+ procedure Preanalyze_TC_Args (N, 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).
-- Preanalyze the boolean expression, we treat this as a spec expression
-- (i.e. similar to a default expression).
- Preanalyze_Spec_Expression
- (Get_Pragma_Arg (Arg1), Standard_Boolean);
+ Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Expression (Corresponding_Aspect (N)), Standard_Boolean);
+ end if;
-- 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)
-- This procedure checks for possible duplications if this is the export
-- case, and if found, issues an appropriate error message.
+ procedure Check_Expr_Is_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty);
+ -- Check the specified expression Expr to make sure that it is a static
+ -- expression of the given type (i.e. it will be analyzed and resolved
+ -- using this type, which can be any valid argument to Resolve, e.g.
+ -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
+ -- Typ is left Empty, then any static expression is allowed.
+
procedure Check_First_Subtype (Arg : Node_Id);
-- Checks that Arg, whose expression is an entity name, references a
-- first subtype.
(Arg : Node_Id;
Typ : Entity_Id := Empty)
is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
-
begin
- if Present (Typ) then
- Analyze_And_Resolve (Argx, Typ);
- else
- Analyze_And_Resolve (Argx);
- end if;
-
- if Is_OK_Static_Expression (Argx) then
- return;
-
- elsif Etype (Argx) = Any_Type then
- raise Pragma_Exit;
-
- -- An interesting special case, if we have a string literal and we
- -- are in Ada 83 mode, then we allow it even though it will not be
- -- flagged as static. This allows the use of Ada 95 pragmas like
- -- Import in Ada 83 mode. They will of course be flagged with
- -- warnings as usual, but will not cause errors.
-
- elsif Ada_Version = Ada_83
- and then Nkind (Argx) = N_String_Literal
- then
- return;
-
- -- Static expression that raises Constraint_Error. This has already
- -- been flagged, so just exit from pragma processing.
-
- elsif Is_Static_Expression (Argx) then
- raise Pragma_Exit;
-
- -- Finally, we have a real error
-
- else
- Error_Msg_Name_1 := Pname;
-
- declare
- Msg : String :=
- "argument for pragma% must be a static expression!";
- begin
- Fix_Error (Msg);
- Flag_Non_Static_Expr (Msg, Argx);
- end;
-
- raise Pragma_Exit;
- end if;
+ Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
end Check_Arg_Is_Static_Expression;
------------------------------------------
Subtype_Indication (Component_Definition (Comp));
Typ : constant Entity_Id := Etype (Comp_Id);
- function Inside_Generic_Body (Id : Entity_Id) return Boolean;
- -- Determine whether entity Id appears inside a generic body.
- -- Shouldn't this be in a more general place ???
-
- -------------------------
- -- Inside_Generic_Body --
- -------------------------
-
- function Inside_Generic_Body (Id : Entity_Id) return Boolean is
- S : Entity_Id;
-
- begin
- S := Id;
- while Present (S) and then S /= Standard_Standard loop
- if Ekind (S) = E_Generic_Package
- and then In_Package_Body (S)
- then
- return True;
- end if;
-
- S := Scope (S);
- end loop;
-
- return False;
- end Inside_Generic_Body;
-
- -- Start of processing for Check_Component
-
begin
-- Ada 2005 (AI-216): If a component subtype is subject to a per-
-- object constraint, then the component type shall be an Unchecked_
-- the formal part of the generic unit.
elsif Ada_Version >= Ada_2012
- and then Inside_Generic_Body (UU_Typ)
+ and then In_Generic_Body (UU_Typ)
and then In_Variant_Part
and then Is_Private_Type (Typ)
and then Is_Generic_Type (Typ)
end if;
end Check_Duplicated_Export_Name;
+ -------------------------------------
+ -- Check_Expr_Is_Static_Expression --
+ -------------------------------------
+
+ procedure Check_Expr_Is_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty)
+ is
+ begin
+ if Present (Typ) then
+ Analyze_And_Resolve (Expr, Typ);
+ else
+ Analyze_And_Resolve (Expr);
+ end if;
+
+ if Is_OK_Static_Expression (Expr) then
+ return;
+
+ elsif Etype (Expr) = Any_Type then
+ raise Pragma_Exit;
+
+ -- An interesting special case, if we have a string literal and we
+ -- are in Ada 83 mode, then we allow it even though it will not be
+ -- flagged as static. This allows the use of Ada 95 pragmas like
+ -- Import in Ada 83 mode. They will of course be flagged with
+ -- warnings as usual, but will not cause errors.
+
+ elsif Ada_Version = Ada_83
+ and then Nkind (Expr) = N_String_Literal
+ then
+ return;
+
+ -- Static expression that raises Constraint_Error. This has already
+ -- been flagged, so just exit from pragma processing.
+
+ elsif Is_Static_Expression (Expr) then
+ raise Pragma_Exit;
+
+ -- Finally, we have a real error
+
+ else
+ Error_Msg_Name_1 := Pname;
+
+ declare
+ Msg : String :=
+ "argument for pragma% must be a static expression!";
+ begin
+ Fix_Error (Msg);
+ Flag_Non_Static_Expr (Msg, Expr);
+ end;
+
+ raise Pragma_Exit;
+ end if;
+ end Check_Expr_Is_Static_Expression;
+
-------------------------
-- Check_First_Subtype --
-------------------------
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
+
+ -- In ASIS mode, for a pragma generated from a source aspect,
+ -- also analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Expression (Corresponding_Aspect (N)), Standard_Boolean);
+ end if;
end if;
In_Body := True;
("second argument of pragma% must be a subprogram", Arg2);
end if;
- -- For Stdcall, a subprogram, variable or subprogram type is required
+ -- Stdcall case
- if C = Convention_Stdcall
- and then not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
- and then Ekind (E) /= E_Variable
- and then not
- (Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
- then
- Error_Pragma_Arg
- ("second argument of pragma% must be subprogram (type)",
- Arg2);
+ if C = Convention_Stdcall then
+
+ -- A dispatching call is not allowed. A dispatching subprogram
+ -- cannot be used to interface to the Win32 API, so in fact this
+ -- check does not impose any effective restriction.
+
+ if Is_Dispatching_Operation (E) then
+
+ Error_Pragma
+ ("dispatching subprograms cannot use Stdcall convention");
+
+ -- Subprogram is allowed, but not a generic subprogram, and not a
+ -- dispatching operation.
+
+ elsif not Is_Subprogram (E)
+ and then not Is_Generic_Subprogram (E)
+
+ -- A variable is OK
+
+ and then Ekind (E) /= E_Variable
+
+ -- An access to subprogram is also allowed
+
+ and then not
+ (Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+ then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be subprogram (type)",
+ Arg2);
+ end if;
end if;
if not Is_Subprogram (E)
Check_Restriction (No_Implementation_Restrictions, Arg);
end if;
+ -- Special processing for No_Elaboration_Code restriction
+
+ if R_Id = No_Elaboration_Code then
+
+ -- Restriction is only recognized within a configuration
+ -- pragma file, or within a unit of the main extended
+ -- program. Note: the test for Main_Unit is needed to
+ -- properly include the case of configuration pragma files.
+
+ if not (Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N))
+ then
+ return;
+
+ -- Don't allow in a subunit unless already specified in
+ -- body or spec.
+
+ elsif Nkind (Parent (N)) = N_Compilation_Unit
+ and then Nkind (Unit (Parent (N))) = N_Subunit
+ and then not Restriction_Active (No_Elaboration_Code)
+ then
+ Error_Msg_N
+ ("invalid specification of ""No_Elaboration_Code""",
+ N);
+ Error_Msg_N
+ ("\restriction cannot be specified in a subunit", N);
+ Error_Msg_N
+ ("\unless also specified in body or spec", N);
+ return;
+
+ -- If we have a No_Elaboration_Code pragma that we
+ -- accept, then it needs to be added to the configuration
+ -- restrcition set so that we get proper application to
+ -- other units in the main extended source as required.
+
+ else
+ Add_To_Config_Boolean_Restrictions (No_Elaboration_Code);
+ end if;
+ end if;
+
-- If this is a warning, then set the warning unless we already
-- have a real restriction active (we never want a warning to
-- override a real restriction).
-- a non-atomic variable.
if C = Atomic_Synchronization
- and then not Is_Atomic (E)
+ and then not (Is_Atomic (E) or else Has_Atomic_Components (E))
then
Error_Msg_N
- ("pragma & requires atomic variable",
+ ("pragma & requires atomic type or variable",
Pragma_Identifier (Original_Node (N)));
end if;
N_Indexed_Component,
N_Function_Call,
N_Identifier,
+ N_Expanded_Name,
N_Selected_Component)
then
-- If this pragma Debug comes from source, its argument was
-- parsed as a name form (which is syntactically identical).
+ -- In a generic context a parameterless call will be left as
+ -- an expanded name (if global) or selected_component if local.
-- Change it to a procedure call statement now.
Change_Name_To_Procedure_Call_Statement (Call);
-- pragma Long_Float (D_Float | G_Float);
- when Pragma_Long_Float =>
+ when Pragma_Long_Float => Long_Float : declare
+ begin
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then
if Opt.Float_Format_Long = 'G' then
- Error_Pragma ("G_Float previously specified");
- end if;
+ Error_Pragma_Arg
+ ("G_Float previously specified", Arg1);
- Opt.Float_Format_Long := 'D';
+ elsif Current_Sem_Unit /= Main_Unit
+ and then Opt.Float_Format_Long /= 'D'
+ then
+ Error_Pragma_Arg
+ ("main unit not compiled with pragma Long_Float (D_Float)",
+ "\pragma% must be used consistently for whole partition",
+ Arg1);
+
+ else
+ Opt.Float_Format_Long := 'D';
+ end if;
-- G_Float case (this is the default, does not need overriding)
else
if Opt.Float_Format_Long = 'D' then
Error_Pragma ("D_Float previously specified");
- end if;
- Opt.Float_Format_Long := 'G';
+ elsif Current_Sem_Unit /= Main_Unit
+ and then Opt.Float_Format_Long /= 'G'
+ then
+ Error_Pragma_Arg
+ ("main unit not compiled with pragma Long_Float (G_Float)",
+ "\pragma% must be used consistently for whole partition",
+ Arg1);
+
+ else
+ Opt.Float_Format_Long := 'G';
+ end if;
end if;
Set_Standard_Fpt_Formats;
+ end Long_Float;
-----------------------
-- Machine_Attribute --
end if;
end Pure_05;
+ -------------
+ -- Pure_12 --
+ -------------
+
+ -- pragma Pure_12 [(library_unit_NAME)];
+
+ -- This pragma is useable only in GNAT_Mode, where it is used like
+ -- pragma Pure but it is only effective in Ada 2012 mode (otherwise
+ -- it is ignored). It may be used after a pragma Preelaborate, in
+ -- which case it overrides the effect of the pragma Preelaborate.
+ -- This is used to implement AI05-0212 which recategorizes some
+ -- run-time packages in Ada 2012 mode.
+
+ when Pragma_Pure_12 => Pure_12 : declare
+ Ent : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Valid_Library_Unit_Pragma;
+
+ if not GNAT_Mode then
+ Error_Pragma ("pragma% only available in GNAT mode");
+ end if;
+
+ if Nkind (N) = N_Null_Statement then
+ return;
+ end if;
+
+ -- This is one of the few cases where we need to test the value of
+ -- Ada_Version_Explicit rather than Ada_Version (which is always
+ -- set to Ada_2012 in a predefined unit), we need to know the
+ -- explicit version set to know if this pragma is active.
+
+ if Ada_Version_Explicit >= Ada_2012 then
+ Ent := Find_Lib_Unit_Name;
+ Set_Is_Preelaborated (Ent, False);
+ Set_Is_Pure (Ent);
+ Set_Suppress_Elaboration_Warnings (Ent);
+ end if;
+ end Pure_12;
+
-------------------
-- Pure_Function --
-------------------
Check_Optional_Identifier (Arg1, Name_Name);
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Check_Expr_Is_Static_Expression
+ (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
+ end if;
+
Check_Optional_Identifier (Arg2, Name_Mode);
Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness);
end;
end if;
- -- Two or more arguments (must be two)
+ -- Two or more arguments (must be two)
else
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
-- the formal may be wrapped in a conversion if the
-- actual is a conversion. Retrieve the real entity name.
- if (In_Instance_Body
- or else In_Inlined_Body)
+ if (In_Instance_Body or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
-- In any other case, an error will be signalled (ON
-- with no matching OFF).
+ -- Note: We set Used if we are inside a generic to
+ -- disable the test that the non-config case actually
+ -- cancels a warning. That's because we can't be sure
+ -- there isn't an instantiation in some other unit
+ -- where a warning is suppressed.
+
+ -- We could do a little better here by checking if the
+ -- generic unit we are inside is public, but for now
+ -- we don't bother with that refinement.
+
if Chars (Argx) = Name_Off then
Set_Specific_Warning_Off
(Loc, Name_Buffer (1 .. Name_Len),
- Config => Is_Configuration_Pragma);
+ Config => Is_Configuration_Pragma,
+ Used => Inside_A_Generic or else In_Instance);
elsif Chars (Argx) = Name_On then
Set_Specific_Warning_On
-- 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),
+ Preanalyze_TC_Args (N,
+ 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
Pragma_Psect_Object => -1,
Pragma_Pure => -1,
Pragma_Pure_05 => -1,
+ Pragma_Pure_12 => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
-- Preanalyze_TC_Args --
------------------------
- procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id) is
+ procedure Preanalyze_TC_Args (N, 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);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
+ end if;
end if;
if Present (Arg_Ens) then
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg_Ens), Standard_Boolean);
+
+ -- In ASIS mode, for a pragma generated from a source aspect, also
+ -- analyze the original aspect expression.
+
+ if ASIS_Mode
+ and then Present (Corresponding_Aspect (N))
+ then
+ Preanalyze_Spec_Expression
+ (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
+ end if;
end if;
end Preanalyze_TC_Args;
OSDN Git Service
