re PR fortran/63674 ([F03] procedure pointer and non/pure procedure)
2014-12-14 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-14 Janus Weil <janus@gcc.gnu.org> PR fortran/63674 * gfortran.dg/proc_ptr_comp_39.f90: New. * gfortran.dg/pure_dummy_length_1.f90: Modified error message. * gfortran.dg/stfunc_6.f90: Ditto. * gfortran.dg/typebound_operator_4.f90: Ditto. From-SVN: r218717
This commit is contained in:
parent
761bd33348
commit
5930876d68
|
@ -1,3 +1,16 @@
|
||||||
|
2014-12-14 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 Tobias Burnus <burnus@net-b.de>
|
2014-12-13 Tobias Burnus <burnus@net-b.de>
|
||||||
Manuel López-Ibáñez <manu@gcc.gnu.org>
|
Manuel López-Ibáñez <manu@gcc.gnu.org>
|
||||||
|
|
||||||
|
|
|
@ -2746,6 +2746,7 @@ static int
|
||||||
pure_function (gfc_expr *e, const char **name)
|
pure_function (gfc_expr *e, const char **name)
|
||||||
{
|
{
|
||||||
int pure;
|
int pure;
|
||||||
|
gfc_component *comp;
|
||||||
|
|
||||||
*name = NULL;
|
*name = NULL;
|
||||||
|
|
||||||
|
@ -2754,7 +2755,13 @@ pure_function (gfc_expr *e, const char **name)
|
||||||
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
|
&& e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
|
||||||
return pure_stmt_function (e, e->symtree->n.sym);
|
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);
|
pure = gfc_pure (e->value.function.esym);
|
||||||
*name = e->value.function.esym->name;
|
*name = e->value.function.esym->name;
|
||||||
|
@ -2801,6 +2808,39 @@ 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
|
/* Resolve a function call, which means resolving the arguments, then figuring
|
||||||
out which entity the name refers to. */
|
out which entity the name refers to. */
|
||||||
|
|
||||||
|
@ -2809,7 +2849,6 @@ resolve_function (gfc_expr *expr)
|
||||||
{
|
{
|
||||||
gfc_actual_arglist *arg;
|
gfc_actual_arglist *arg;
|
||||||
gfc_symbol *sym;
|
gfc_symbol *sym;
|
||||||
const char *name;
|
|
||||||
bool t;
|
bool t;
|
||||||
int temp;
|
int temp;
|
||||||
procedure_type p = PROC_INTRINSIC;
|
procedure_type p = PROC_INTRINSIC;
|
||||||
|
@ -2982,33 +3021,9 @@ resolve_function (gfc_expr *expr)
|
||||||
#undef GENERIC_ID
|
#undef GENERIC_ID
|
||||||
|
|
||||||
need_full_assumed_size = temp;
|
need_full_assumed_size = temp;
|
||||||
name = NULL;
|
|
||||||
|
|
||||||
if (!pure_function (expr, &name) && name)
|
if (!check_pure_function(expr))
|
||||||
{
|
t = false;
|
||||||
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;
|
|
||||||
}
|
|
||||||
|
|
||||||
gfc_unset_implicit_pure (NULL);
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Functions without the RECURSIVE attribution are not allowed to
|
/* Functions without the RECURSIVE attribution are not allowed to
|
||||||
* call themselves. */
|
* call themselves. */
|
||||||
|
@ -3056,23 +3071,32 @@ resolve_function (gfc_expr *expr)
|
||||||
|
|
||||||
/************* Subroutine resolution *************/
|
/************* Subroutine resolution *************/
|
||||||
|
|
||||||
static void
|
static bool
|
||||||
pure_subroutine (gfc_code *c, gfc_symbol *sym)
|
pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
|
||||||
{
|
{
|
||||||
if (gfc_pure (sym))
|
if (gfc_pure (sym))
|
||||||
return;
|
return true;
|
||||||
|
|
||||||
if (forall_flag)
|
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)
|
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))
|
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);
|
gfc_unset_implicit_pure (NULL);
|
||||||
|
return true;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@ -3087,7 +3111,8 @@ resolve_generic_s0 (gfc_code *c, gfc_symbol *sym)
|
||||||
if (s != NULL)
|
if (s != NULL)
|
||||||
{
|
{
|
||||||
c->resolved_sym = s;
|
c->resolved_sym = s;
|
||||||
pure_subroutine (c, s);
|
if (!pure_subroutine (s, s->name, &c->loc))
|
||||||
|
return MATCH_ERROR;
|
||||||
return MATCH_YES;
|
return MATCH_YES;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -3190,7 +3215,8 @@ found:
|
||||||
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
|
gfc_procedure_use (sym, &c->ext.actual, &c->loc);
|
||||||
|
|
||||||
c->resolved_sym = sym;
|
c->resolved_sym = sym;
|
||||||
pure_subroutine (c, sym);
|
if (!pure_subroutine (sym, sym->name, &c->loc))
|
||||||
|
return MATCH_ERROR;
|
||||||
|
|
||||||
return MATCH_YES;
|
return MATCH_YES;
|
||||||
}
|
}
|
||||||
|
@ -3260,9 +3286,7 @@ found:
|
||||||
|
|
||||||
c->resolved_sym = sym;
|
c->resolved_sym = sym;
|
||||||
|
|
||||||
pure_subroutine (c, sym);
|
return pure_subroutine (sym, sym->name, &c->loc);
|
||||||
|
|
||||||
return true;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@ -6036,6 +6060,9 @@ resolve_ppc_call (gfc_code* c)
|
||||||
&& comp->ts.interface->formal)))
|
&& comp->ts.interface->formal)))
|
||||||
return false;
|
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);
|
gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where);
|
||||||
|
|
||||||
return true;
|
return true;
|
||||||
|
@ -6074,6 +6101,9 @@ resolve_expr_ppc (gfc_expr* e)
|
||||||
if (!update_ppc_arglist (e))
|
if (!update_ppc_arglist (e))
|
||||||
return false;
|
return false;
|
||||||
|
|
||||||
|
if (!check_pure_function(e))
|
||||||
|
return false;
|
||||||
|
|
||||||
gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
|
gfc_ppc_use (comp, &e->value.compcall.actual, &e->where);
|
||||||
|
|
||||||
return true;
|
return true;
|
||||||
|
|
|
@ -1,3 +1,11 @@
|
||||||
|
2014-12-14 Janus Weil <janus@gcc.gnu.org>
|
||||||
|
|
||||||
|
PR fortran/63674
|
||||||
|
* gfortran.dg/proc_ptr_comp_39.f90: New.
|
||||||
|
* gfortran.dg/pure_dummy_length_1.f90: Modified error message.
|
||||||
|
* gfortran.dg/stfunc_6.f90: Ditto.
|
||||||
|
* gfortran.dg/typebound_operator_4.f90: Ditto.
|
||||||
|
|
||||||
2014-12-13 Oleg Endo <olegendo@gcc.gnu.org>
|
2014-12-13 Oleg Endo <olegendo@gcc.gnu.org>
|
||||||
|
|
||||||
PR target/53513
|
PR target/53513
|
||||||
|
|
|
@ -0,0 +1,32 @@
|
||||||
|
! { dg-do compile }
|
||||||
|
!
|
||||||
|
! PR 63674: [F03] procedure pointer and non/pure procedure
|
||||||
|
!
|
||||||
|
! Contributed by Valery Weber <valeryweber@hotmail.com>
|
||||||
|
|
||||||
|
program prog
|
||||||
|
interface
|
||||||
|
integer function nf()
|
||||||
|
end function
|
||||||
|
pure integer function pf()
|
||||||
|
end function
|
||||||
|
subroutine ns()
|
||||||
|
end subroutine
|
||||||
|
pure subroutine ps()
|
||||||
|
end subroutine
|
||||||
|
end interface
|
||||||
|
type :: t
|
||||||
|
procedure(nf), nopass, pointer :: nf => NULL() ! non-pure function
|
||||||
|
procedure(pf), nopass, pointer :: pf => NULL() ! pure function
|
||||||
|
procedure(ns), nopass, pointer :: ns => NULL() ! non-pure subroutine
|
||||||
|
procedure(ps), nopass, pointer :: ps => NULL() ! pure subroutine
|
||||||
|
end type
|
||||||
|
contains
|
||||||
|
pure integer function eval(a)
|
||||||
|
type(t), intent(in) :: a
|
||||||
|
eval = a%pf()
|
||||||
|
eval = a%nf() ! { dg-error "Reference to non-PURE function" }
|
||||||
|
call a%ps()
|
||||||
|
call a%ns() ! { dg-error "is not PURE" }
|
||||||
|
end function
|
||||||
|
end
|
|
@ -24,6 +24,6 @@
|
||||||
character(*), intent(in) :: string
|
character(*), intent(in) :: string
|
||||||
integer(4), intent(in) :: ignore_case
|
integer(4), intent(in) :: ignore_case
|
||||||
integer i
|
integer i
|
||||||
if (end > impure (self)) & ! { dg-error "non-PURE procedure" }
|
if (end > impure (self)) & ! { dg-error "non-PURE function" }
|
||||||
return
|
return
|
||||||
end function
|
end function
|
||||||
|
|
|
@ -22,7 +22,7 @@
|
||||||
contains
|
contains
|
||||||
pure integer function u (x)
|
pure integer function u (x)
|
||||||
integer,intent(in) :: 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)
|
u = st2(x)
|
||||||
end function
|
end function
|
||||||
integer function v (x)
|
integer function v (x)
|
||||||
|
|
|
@ -75,8 +75,8 @@ PURE SUBROUTINE iampure2 ()
|
||||||
TYPE(myreal) :: x
|
TYPE(myreal) :: x
|
||||||
|
|
||||||
x = 0.0 ! { dg-error "is not PURE" }
|
x = 0.0 ! { dg-error "is not PURE" }
|
||||||
x = x + 42.0 ! { dg-error "to a non-PURE procedure" }
|
x = x + 42.0 ! { dg-error "non-PURE function" }
|
||||||
x = x .PLUS. 5.0 ! { dg-error "to a non-PURE procedure" }
|
x = x .PLUS. 5.0 ! { dg-error "non-PURE function" }
|
||||||
END SUBROUTINE iampure2
|
END SUBROUTINE iampure2
|
||||||
|
|
||||||
PROGRAM main
|
PROGRAM main
|
||||||
|
|
Loading…
Reference in New Issue