-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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- --
-- 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)
-- overriding operation (see ARM12 6.6.1 (7)).
if Class_Present (N) then
- declare
+ Class_Wide_Condition : declare
T : constant Entity_Id := Find_Dispatching_Type (S);
ACW : Entity_Id := Empty;
procedure Replace_Type is new Traverse_Proc (Process);
+ -- Start of processing for Class_Wide_Condition
+
begin
+ if not Present (T) then
+ Error_Msg_Name_1 :=
+ Chars (Identifier (Corresponding_Aspect (N)));
+
+ Error_Msg_Name_2 := Name_Class;
+
+ Error_Msg_N
+ ("aspect `%''%` can only be specified for a primitive " &
+ "operation of a tagged type",
+ Corresponding_Aspect (N));
+ end if;
+
Replace_Type (Get_Pragma_Arg (Arg1));
- end;
+ end Class_Wide_Condition;
end if;
-- Remove the subprogram from the scope stack now that the pre-analysis
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, 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, N4, N5 if
-- 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.
procedure Fix_Error (Msg : in out String);
-- This is called prior to issuing an error message. Msg is a string
- -- which typically contains the substring pragma. If the current pragma
+ -- that typically contains the substring "pragma". If the current pragma
-- comes from an aspect, each such "pragma" substring is replaced with
-- the characters "aspect", and if Error_Msg_Name_1 is Name_Precondition
-- (resp Name_Postcondition) it is changed to Name_Pre (resp Name_Post).
procedure Check_Arg_Is_One_Of
(Arg : Node_Id;
+ N1, N2, N3, N4 : Name_Id)
+ is
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+
+ begin
+ Check_Arg_Is_Identifier (Argx);
+
+ if Chars (Argx) /= N1
+ and then Chars (Argx) /= N2
+ and then Chars (Argx) /= N3
+ and then Chars (Argx) /= N4
+ then
+ Error_Pragma_Arg ("invalid argument for pragma%", Argx);
+ end if;
+ end Check_Arg_Is_One_Of;
+
+ procedure Check_Arg_Is_One_Of
+ (Arg : Node_Id;
N1, N2, N3, N4, N5 : Name_Id)
is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
(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 --
-------------------------
("aspect % requires ''Class for null procedure");
elsif not Nkind_In (PO, N_Subprogram_Declaration,
+ N_Expression_Function,
N_Generic_Subprogram_Declaration,
N_Entry_Declaration)
then
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;
procedure GNAT_Pragma is
begin
- Check_Restriction (No_Implementation_Pragmas, N);
+ -- We need to check the No_Implementation_Pragmas restriction for
+ -- the case of a pragma from source. Note that the case of aspects
+ -- generating corresponding pragmas marks these pragmas as not being
+ -- from source, so this test also catches that case.
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
end GNAT_Pragma;
--------------------------
Set_Has_Delayed_Freeze (E);
end if;
- -- An interesting improvement here. If an object of type X is
- -- declared atomic, and the type X is not atomic, that's a
+ -- An interesting improvement here. If an object of composite
+ -- type X is declared atomic, and the type X isn't, that's a
-- pity, since it may not have appropriate alignment etc. We
-- can rescue this in the special case where the object and
-- type are in the same unit by just setting the type as
-- atomic, so that the back end will process it as atomic.
+ -- Note: we used to do this for elementary types as well,
+ -- but that turns out to be a bad idea and can have unwanted
+ -- effects, most notably if the type is elementary, the object
+ -- a simple component within a record, and both are in a spec:
+ -- every object of this type in the entire program will be
+ -- treated as atomic, thus incurring a potentially costly
+ -- synchronization operation for every access.
+
+ -- Of course it would be best if the back end could just adjust
+ -- the alignment etc for the specific object, but that's not
+ -- something we are capable of doing at this point.
+
Utyp := Underlying_Type (Etype (E));
if Present (Utyp)
+ and then Is_Composite_Type (Utyp)
and then Sloc (E) > No_Location
and then Sloc (Utyp) > No_Location
and then
("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)
-- Import a CPP class
- elsif Is_Record_Type (Def_Id)
- and then C = Convention_CPP
+ elsif C = Convention_CPP
+ and then (Is_Record_Type (Def_Id)
+ or else Ekind (Def_Id) = E_Incomplete_Type)
then
+ if Ekind (Def_Id) = E_Incomplete_Type then
+ if Present (Full_View (Def_Id)) then
+ Def_Id := Full_View (Def_Id);
+
+ else
+ Error_Msg_N
+ ("cannot import 'C'P'P type before full declaration seen",
+ Get_Pragma_Arg (Arg2));
+
+ -- Although we have reported the error we decorate it as
+ -- CPP_Class to avoid reporting spurious errors
+
+ Set_Is_CPP_Class (Def_Id);
+ return;
+ end if;
+ end if;
+
-- 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
(Declaration_Node (Def_Id))));
end if;
- -- Components of imported CPP types must not have default
- -- expressions because the constructor (if any) is on the
- -- C++ side.
-
- declare
- Tdef : constant Node_Id :=
- Type_Definition (Declaration_Node (Def_Id));
- Clist : Node_Id;
- Comp : Node_Id;
-
- begin
- if Nkind (Tdef) = N_Record_Definition then
- Clist := Component_List (Tdef);
-
- else
- pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
- Clist := Component_List (Record_Extension_Part (Tdef));
- end if;
-
- if Present (Clist) then
- Comp := First (Component_Items (Clist));
- while Present (Comp) loop
- if Present (Expression (Comp)) then
- Error_Msg_N
- ("component of imported 'C'P'P type cannot have" &
- " default expression", Expression (Comp));
- end if;
+ -- Check that components of imported CPP types do not have default
+ -- expressions. For private types this check is performed when the
+ -- full view is analyzed (see Process_Full_View).
- Next (Comp);
- end loop;
- end if;
- end;
+ if not Is_Private_Type (Def_Id) then
+ Check_CPP_Type_Has_No_Defaults (Def_Id);
+ end if;
elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
Check_No_Link_Name;
else
Error_Pragma_Arg
- ("second argument of pragma% must be object, subprogram" &
- " or incomplete type",
+ ("second argument of pragma% must be object, subprogram "
+ & "or incomplete type",
Arg2);
end if;
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 type or variable",
Check_Interrupt_Or_Attach_Handler;
-- The expression that designates the attribute may depend on a
- -- discriminant, and is therefore a per- object expression, to
+ -- discriminant, and is therefore a per-object expression, to
-- be expanded in the init proc. If expansion is enabled, then
-- perform semantic checks on a copy only.
Get_Pragma_Arg (Arg1));
end if;
- Set_Is_CPP_Class (Typ);
- Set_Convention (Typ, Convention_CPP);
+ Set_Is_CPP_Class (Typ);
+ Set_Convention (Typ, Convention_CPP);
-- Imported CPP types must not have discriminants (because C++
-- classes do not have discriminants).
Set_Has_Completion (Def_Id);
Set_Is_Constructor (Def_Id);
+ Set_Convention (Def_Id, Convention_CPP);
-- Imported C++ constructors are not dispatching primitives
-- because in C++ they don't have a dispatch table slot.
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);
-- use of the secondary stack does not generate execution overhead
-- for suppressed conditions.
+ -- Normally the analysis that follows will freeze the subprogram
+ -- being called. However, if the call is to a null procedure,
+ -- we want to freeze it before creating the block, because the
+ -- analysis that follows may be done with expansion disabled, in
+ -- which case the body will not be generated, leading to spurious
+ -- errors.
+
+ if Nkind (Call) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (Call))
+ then
+ Analyze (Name (Call));
+ Freeze_Before (N, Entity (Name (Call)));
+ end if;
+
Rewrite (N, Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => New_List (
Default_Pool := Expression (Arg1);
- ---------------
- -- Dimension --
- ---------------
-
- when Pragma_Dimension =>
- GNAT_Pragma;
- Check_Arg_Count (4);
- Check_No_Identifiers;
- Check_Arg_Is_Local_Name (Arg1);
-
- if not Is_Type (Arg1) then
- Error_Pragma ("first argument for pragma% must be subtype");
- end if;
-
- Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
- Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
- Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
-
------------------------------------
-- Disable_Atomic_Synchronization --
------------------------------------
if Citem = N then
Error_Pragma_Arg
- ("argument of pragma% is not with'ed unit", Arg);
+ ("argument of pragma% is not withed unit", Arg);
end if;
Next (Arg);
if Citem = N then
Set_Error_Posted (N);
Error_Pragma_Arg
- ("argument of pragma% is not with'ed unit", Arg);
+ ("argument of pragma% is not withed unit", Arg);
end if;
Next (Arg);
-----------------
-- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
- -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
+ -- implementation_kind ::=
+ -- By_Entry | By_Protected_Procedure | By_Any | Optional
+
+ -- "By_Any" and "Optional" are treated as synonyms in order to
+ -- support Ada 2012 aspect Synchronization.
when Pragma_Implemented => Implemented : declare
Proc_Id : Entity_Id;
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
- Check_Arg_Is_One_Of
- (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+ Check_Arg_Is_One_Of (Arg2,
+ Name_By_Any,
+ Name_By_Entry,
+ Name_By_Protected_Procedure,
+ Name_Optional);
-- Extract the name of the local procedure
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 --
-------------------
end if;
end Relative_Deadline;
+ ------------------------
+ -- Remote_Access_Type --
+ ------------------------
+
+ -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
+
+ when Pragma_Remote_Access_Type => Remote_Access_Type : declare
+ E : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ E := Entity (Get_Pragma_Arg (Arg1));
+
+ if Nkind (Parent (E)) = N_Formal_Type_Declaration
+ and then Ekind (E) = E_General_Access_Type
+ and then Is_Class_Wide_Type (Directly_Designated_Type (E))
+ and then Scope (Root_Type (Directly_Designated_Type (E)))
+ = Scope (E)
+ and then Is_Valid_Remote_Object_Type
+ (Root_Type (Directly_Designated_Type (E)))
+ then
+ Set_Is_Remote_Types (E);
+
+ else
+ Error_Pragma_Arg
+ ("pragma% applies only to formal access to classwide types",
+ Arg1);
+ end if;
+ end Remote_Access_Type;
+
---------------------------
-- Remote_Call_Interface --
---------------------------
Check_Valid_Configuration_Pragma;
Short_Descriptors := True;
+ ------------------------------
+ -- Simple_Storage_Pool_Type --
+ ------------------------------
+
+ -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
+
+ when Pragma_Simple_Storage_Pool_Type =>
+ Simple_Storage_Pool_Type : declare
+ Type_Id : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Library_Level_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;
+
+ -- We require the pragma to apply to a type declared in a package
+ -- declaration, but not (immediately) within a package body.
+
+ if Ekind (Current_Scope) /= E_Package
+ or else In_Package_Body (Current_Scope)
+ then
+ Error_Pragma
+ ("pragma% can only apply to type declared immediately " &
+ "within a package declaration");
+ end if;
+
+ -- A simple storage pool type must be an immutably limited record
+ -- or private type. If the pragma is given for a private type,
+ -- the full type is similarly restricted (which is checked later
+ -- in Freeze_Entity).
+
+ if Is_Record_Type (Typ)
+ and then not Is_Immutably_Limited_Type (Typ)
+ then
+ Error_Pragma
+ ("pragma% can only apply to explicitly limited record type");
+
+ elsif Is_Private_Type (Typ) and then not Is_Limited_Type (Typ) then
+ Error_Pragma
+ ("pragma% can only apply to a private type that is limited");
+
+ elsif not Is_Record_Type (Typ)
+ and then not Is_Private_Type (Typ)
+ then
+ Error_Pragma
+ ("pragma% can only apply to limited record or private type");
+ end if;
+
+ Record_Rep_Item (Typ, N);
+ end Simple_Storage_Pool_Type;
+
----------------------
-- Source_File_Name --
----------------------
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);
if Citem = N then
Error_Pragma_Arg
- ("argument of pragma% is not with'ed unit", Arg_Node);
+ ("argument of pragma% is not withed unit", Arg_Node);
end if;
Next (Arg_Node);
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 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
-- Follow subprogram renaming chain
Result := Def_Id;
- while Is_Subprogram (Result)
+
+ if Is_Subprogram (Result)
and then
Nkind (Parent (Declaration_Node (Result))) =
N_Subprogram_Renaming_Declaration
and then Present (Alias (Result))
- loop
+ then
Result := Alias (Result);
- end loop;
+ end if;
return Result;
end Get_Base_Subprogram;
-----------------------------------------
-- This function makes use of the following static table which indicates
- -- whether a given pragma is significant.
+ -- whether appearance of some name in a given pragma is to be considered
+ -- as a reference for the purposes of warnings about unreferenced objects.
-- -1 indicates that references in any argument position are significant
-- 0 indicates that appearance in any argument is not significant
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
Pragma_Default_Storage_Pool => -1,
- Pragma_Dimension => -1,
Pragma_Disable_Atomic_Synchronization => -1,
Pragma_Discard_Names => 0,
Pragma_Dispatching_Domain => -1,
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,
Pragma_Relative_Deadline => -1,
+ Pragma_Remote_Access_Type => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Short_Descriptors => 0,
+ Pragma_Simple_Storage_Pool_Type => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
end if;
end Is_Pragma_String_Literal;
+ -----------------------------------------
+ -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
+ -----------------------------------------
+
+ procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
+ Aspects : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Or_Decl : constant Node_Id := Original_Node (Decl);
+
+ Original_Aspects : List_Id;
+ -- To capture global references, a copy of the created aspects must be
+ -- inserted in the original tree.
+
+ Prag : Node_Id;
+ Prag_Arg_Ass : Node_Id;
+ Prag_Id : Pragma_Id;
+
+ begin
+ -- Check for any PPC pragmas that appear within Decl
+
+ Prag := Next (Decl);
+ while Nkind (Prag) = N_Pragma loop
+ Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
+
+ case Prag_Id is
+ when Pragma_Postcondition | Pragma_Precondition =>
+ Prag_Arg_Ass := First (Pragma_Argument_Associations (Prag));
+
+ -- Make an aspect from any PPC pragma
+
+ Append_To (Aspects,
+ Make_Aspect_Specification (Loc,
+ Identifier =>
+ Make_Identifier (Loc, Chars (Pragma_Identifier (Prag))),
+ Expression =>
+ Copy_Separate_Tree (Expression (Prag_Arg_Ass))));
+
+ -- Generate the analysis information in the pragma expression
+ -- and then set the pragma node analyzed to avoid any further
+ -- analysis.
+
+ Analyze (Expression (Prag_Arg_Ass));
+ Set_Analyzed (Prag, True);
+
+ when others => null;
+ end case;
+
+ Next (Prag);
+ end loop;
+
+ -- Set all new aspects into the generic declaration node
+
+ if Is_Non_Empty_List (Aspects) then
+
+ -- Create the list of aspects to be inserted in the original tree
+
+ Original_Aspects := Copy_Separate_List (Aspects);
+
+ -- Check if Decl already has aspects
+
+ -- Attach the new lists of aspects to both the generic copy and the
+ -- original tree.
+
+ if Has_Aspects (Decl) then
+ Append_List (Aspects, Aspect_Specifications (Decl));
+ Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
+
+ else
+ Set_Parent (Aspects, Decl);
+ Set_Aspect_Specifications (Decl, Aspects);
+ Set_Parent (Original_Aspects, Or_Decl);
+ Set_Aspect_Specifications (Or_Decl, Original_Aspects);
+ end if;
+ end if;
+ end Make_Aspect_For_PPC_In_Gen_Sub_Decl;
+
------------------------
-- 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
