===================================================================
@@ -2746,6 +2746,7 @@ static int
pure_function (gfc_expr *e, const char **name)
{
int pure;
+ gfc_component *comp;
*name = NULL;
@@ -2754,8 +2755,14 @@ pure_function (gfc_expr *e, const char **name)
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
return pure_stmt_function (e, e->symtree->n.sym);
- if (e->value.function.esym)
+ comp = gfc_get_proc_ptr_comp (e);
+ if (comp)
{
+ pure = gfc_pure (comp->ts.interface);
+ *name = comp->name;
+ }
+ else if (e->value.function.esym)
+ {
pure = gfc_pure (e->value.function.esym);
*name = e->value.function.esym->name;
}
@@ -2801,6 +2808,40 @@ pure_stmt_function (gfc_expr *e, gfc_symbol *sym)
}
+/* Check if a non-pure function function is allowed in the current context. */
+
+static bool check_pure_function (gfc_expr *e)
+{
+ const char *name = NULL;
+ if (!pure_function (e, &name) && name)
+ {
+ if (forall_flag)
+ {
+ gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+ "FORALL %s", name, &e->where,
+ forall_flag == 2 ? "mask" : "block");
+ return false;
+ }
+ else if (gfc_do_concurrent_flag)
+ {
+ gfc_error ("Reference to non-PURE function '%s' at %L inside a "
+ "DO CONCURRENT %s", name, &e->where,
+ gfc_do_concurrent_flag == 2 ? "mask" : "block");
+ return false;
+ }
+ else if (gfc_pure (NULL))
+ {
+ gfc_error ("Reference to non-PURE function '%s' at %L "
+ "within a PURE procedure", name, &e->where);
+ return false;
+ }
+
+ gfc_unset_implicit_pure (NULL);
+ }
+ return true;
+}
+
+
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
@@ -2809,7 +2850,6 @@ resolve_function (gfc_expr *expr)
{
gfc_actual_arglist *arg;
gfc_symbol *sym;
- const char *name;
bool t;
int temp;
procedure_type p = PROC_INTRINSIC;
@@ -2982,34 +3022,10 @@ resolve_function (gfc_expr *expr)
#undef GENERIC_ID
need_full_assumed_size = temp;
- name = NULL;
- if (!pure_function (expr, &name) && name)
- {
- if (forall_flag)
- {
- gfc_error ("Reference to non-PURE function %qs at %L inside a "
- "FORALL %s", name, &expr->where,
- forall_flag == 2 ? "mask" : "block");
- t = false;
- }
- else if (gfc_do_concurrent_flag)
- {
- gfc_error ("Reference to non-PURE function %qs at %L inside a "
- "DO CONCURRENT %s", name, &expr->where,
- gfc_do_concurrent_flag == 2 ? "mask" : "block");
- t = false;
- }
- else if (gfc_pure (NULL))
- {
- gfc_error ("Function reference to %qs at %L is to a non-PURE "
- "procedure within a PURE procedure", name, &expr->where);
- t = false;
- }
+ if (!check_pure_function(expr))
+ t = false;
- gfc_unset_implicit_pure (NULL);
- }
-
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
@@ -3056,23 +3072,32 @@ resolve_function (gfc_expr *expr)
/************* Subroutine resolution *************/
-static void
-pure_subroutine (gfc_code *c, gfc_symbol *sym)
+static bool
+pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
{
if (gfc_pure (sym))
- return;
+ return true;
if (forall_flag)
- gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
- sym->name, &c->loc);
+ {
+ gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE",
+ name, loc);
+ return false;
+ }
else if (gfc_do_concurrent_flag)
- gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
- "PURE", sym->name, &c->loc);
+ {
+ gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not "
+ "PURE", name, loc);
+ return false;
+ }
else if (gfc_pure (NULL))
- gfc_error ("Subroutine call to %qs at %L is not PURE", sym->name,
- &c->loc);
+ {
+ gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc);
+ return false;
+ }
gfc_unset_implicit_pure (NULL);
+ return true;
}
@@ -3087,7 +3112,8 @@ resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
if (s != NULL)
{
c->resolved_sym = s;
- pure_subroutine (c, s);
+ if (!pure_subroutine (s, s->name, &c->loc))
+ return MATCH_ERROR;
return MATCH_YES;
}
@@ -3190,7 +3216,8 @@ found:
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
c->resolved_sym = sym;
- pure_subroutine (c, sym);
+ if (!pure_subroutine (sym, sym->name, &c->loc))
+ return MATCH_ERROR;
return MATCH_YES;
}
@@ -3260,9 +3287,7 @@ found:
c->resolved_sym = sym;
- pure_subroutine (c, sym);
-
- return true;
+ return pure_subroutine (sym, sym->name, &c->loc);
}
@@ -6036,6 +6061,9 @@ resolve_ppc_call (gfc_code* c)
&& comp->ts.interface->formal)))
return false;
+ if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where))
+ return false;
+
gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
return true;
@@ -6074,6 +6102,9 @@ resolve_expr_ppc (gfc_expr* e)
if (!update_ppc_arglist (e))
return false;
+ if (!check_pure_function(e))
+ return false;
+
gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
return true;
===================================================================
@@ -24,6 +24,6 @@
character(*), intent(in) :: string
integer(4), intent(in) :: ignore_case
integer i
- if (end > impure (self)) & ! { dg-error "non-PURE procedure" }
+ if (end > impure (self)) & ! { dg-error "non-PURE function" }
return
end function
===================================================================
@@ -22,7 +22,7 @@
contains
pure integer function u (x)
integer,intent(in) :: x
- st2 (i) = i * v(i) ! { dg-error "non-PURE procedure" }
+ st2 (i) = i * v(i) ! { dg-error "non-PURE function" }
u = st2(x)
end function
integer function v (x)
===================================================================
@@ -75,8 +75,8 @@ PURE SUBROUTINE iampure2 ()
TYPE(myreal) :: x
x = 0.0 ! { dg-error "is not PURE" }
- x = x + 42.0 ! { dg-error "to a non-PURE procedure" }
- x = x .PLUS. 5.0 ! { dg-error "to a non-PURE procedure" }
+ x = x + 42.0 ! { dg-error "non-PURE function" }
+ x = x .PLUS. 5.0 ! { dg-error "non-PURE function" }
END SUBROUTINE iampure2
PROGRAM main
Hi all, it's been a while since I have contributed to this list and to gfortran, but it's good to see that you guys are still making a lot of progress with this great compiler. In any case, I recently found some time to prepare a small patch related to my old pet (procedure pointers). It adds some diagnostics for the PURE attribute. Regtested on x86_64-unknown-linux-gnu. Ok for trunk? Cheers, Janus 2014-12-13 Janus Weil <janus@gcc.gnu.org> PR fortran/63674 * resolve.c (pure_function): Treat procedure-pointer components. (check_pure_function): New function. (resolve_function): Use it. (pure_subroutine): Return a bool to indicate success and modify arguments. (resolve_generic_s0,resolve_specific_s0,resolve_unknown_s): Use return value of 'pure_subroutine'. (resolve_ppc_call): Call 'pure_subroutine'. (resolve_expr_ppc): Call 'check_pure_function'. 2014-12-13 Janus Weil <janus@gcc.gnu.org> PR fortran/63674 * gfortran.dg/proc_ptr_comp_39.f90: New.