+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Set Inlined flag
+ on the entity of a subprogram declaration that is completed by
+ an expression function.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Is_Current_Instance): A entity given by a subtype
+ declaration can appear in an aspect specification for a dynamic
+ predicate, and a pragma for aspect Predicate_Failure.
+ * exp_util.adb (Replace_Subtype_References): Replace current
+ occurrences of the subtype to which a dynamic predicate applies,
+ byt the expression that triggers a predicate check. Needed to
+ implement new aspect Predicate_Failure.
+
2016-04-18 Arnaud Charlet <charlet@adacore.com>
* a-intsig.ads, a-intsig.adb: Removed, no longer used.
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Expr);
- Arg_List : List_Id;
- Nam : Name_Id;
+ procedure Replace_Subtype_Reference (N : Node_Id);
+ -- Replace current occurrences of the subtype to which a dynamic
+ -- predicate applies, by the expression that triggers a predicate
+ -- check. This is needed for aspect Predicate_Failure, for which
+ -- we do not generate a wrapper procedure, but simply modify the
+ -- expression for the pragma of the predicate check.
+
+ --------------------------------
+ -- Replace_Subtype_Reference --
+ --------------------------------
+
+ procedure Replace_Subtype_Reference (N : Node_Id) is
+ begin
+ Rewrite (N, New_Copy_Tree (Expr));
+
+ -- We want to treat the node as if it comes from source, so
+ -- that ASIS will not ignore it.
+
+ Set_Comes_From_Source (N, True);
+ end Replace_Subtype_Reference;
+
+ procedure Replace_Subtype_References is
+ new Replace_Type_References_Generic (Replace_Subtype_Reference);
+
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Arg_List : List_Id;
+ Fail_Expr : Node_Id;
+ Nam : Name_Id;
+
+ -- Start of processing for Make_Predicate_Check
begin
-- If predicate checks are suppressed, then return a null statement. For
Make_Pragma_Argument_Association (Loc,
Expression => Make_Predicate_Call (Typ, Expr)));
+ -- If subtype has Predicate_Failure defined, add the correponding
+ -- expression as an additional pragma parameter, after replacing
+ -- current instances with the expression being checked.
+
if Has_Aspect (Typ, Aspect_Predicate_Failure) then
+ Fail_Expr :=
+ New_Copy_Tree
+ (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure)));
+ Replace_Subtype_References (Fail_Expr, Typ);
+
Append_To (Arg_List,
Make_Pragma_Argument_Association (Loc,
- Expression =>
- New_Copy_Tree
- (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure)))));
+ Expression => Fail_Expr));
end if;
return
Set_Is_Inlined (Prev);
-- If the expression function is a completion, the previous declaration
- -- must come from source. We know already that appears in the current
+ -- must come from source. We know already that it appears in the current
-- scope. The entity itself may be internally created if within a body
-- to be inlined.
and then not Is_Formal_Subprogram (Prev)
then
Set_Has_Completion (Prev, False);
+ Set_Is_Inlined (Prev);
-- An expression function that is a completion freezes the
-- expression. This means freezing the return type, and if it is
-- Not clear that the backend can inline it in this case ???
if Has_Completion (Prev) then
- Set_Is_Inlined (Prev);
-- The formals of the expression function are body formals,
-- and do not appear in the ali file, which will only contain
and then Defining_Entity (P) = Typ
then
return True;
+
+ -- A subtype name may appear in an aspect specification for a
+ -- Predicate_Failure aspect, for which we do not construct a
+ -- wrapper procedure. The subtype will be replaced by the
+ -- expression being tested when the corresponding predicate
+ -- check is expanded.
+
+ elsif Nkind (P) = N_Aspect_Specification
+ and then Nkind (Parent (P)) = N_Subtype_Declaration
+ then
+ return True;
+
+ elsif Nkind (P) = N_Pragma
+ and then
+ Get_Pragma_Id (Pragma_Name (P)) = Pragma_Predicate_Failure
+ then
+ return True;
end if;
P := Parent (P);