Re: [Patch, Fortran] PR 63674: procedure pointer and non/pure procedure
2014-12-15 7:34 GMT+01:00 Tobias Burnus : > Can you change "non-pure" to "impure"? That would better match the Fortran > naming, where "impure" is the default unless "pure" or "elemental" is used. > (It was added to permit "impure elemental" procedures.) Yes, sure. I have committed this change as r218738. Cheers, Janus
Re: [Patch, Fortran] PR 63674: procedure pointer and non/pure procedure
Janus Weil wrote: 2014-12-14 12:00 GMT+01:00 FX : Good point, thank you. Updated patch attached. I guess I still new formal approval by someone with reviewer status … OK Thanks, committed as r218717. Can you change "non-pure" to "impure"? That would better match the Fortran naming, where "impure" is the default unless "pure" or "elemental" is used. (It was added to permit "impure elemental" procedures.) Tobias
Re: [Patch, Fortran] PR 63674: procedure pointer and non/pure procedure
2014-12-14 12:00 GMT+01:00 FX : >> Good point, thank you. Updated patch attached. >> I guess I still new formal approval by someone with reviewer status … > > OK Thanks, committed as r218717. Cheers, Janus
Re: [Patch, Fortran] PR 63674: procedure pointer and non/pure procedure
> Good point, thank you. Updated patch attached. > I guess I still new formal approval by someone with reviewer status … OK
Re: [Patch, Fortran] PR 63674: procedure pointer and non/pure procedure
>> Regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>
> s/'%s'/%qs/g
> nowadays.
Good point, thank you. Updated patch attached.
I guess I still new formal approval by someone with reviewer status ...
Cheers,
Janus
Index: gcc/fortran/resolve.c
===
--- gcc/fortran/resolve.c (Revision 218705)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -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 %qs 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 %qs 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 %qs 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
[Patch, Fortran] PR 63674: procedure pointer and non/pure procedure
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
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
PR fortran/63674
* gfortran.dg/proc_ptr_comp_39.f90: New.
Index: gcc/fortran/resolve.c
===
--- gcc/fortran/resolve.c (Revision 218705)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -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_err
