mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-20 08:10:28 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/63674 ([F03] procedure pointer and non/pure procedure)

Browse Source 
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:
Janus Weil 2014-12-14 13:04:49 +01:00
parent 761bd33348
commit 5930876d68
7 changed files with 129 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -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>
Manuel López-Ibáñez <manu@gcc.gnu.org>

114
gcc/fortran/resolve.c
View File

@ -2746,6 +2746,7 @@ static int
pure_function (gfc_expr *e, const char **name)
{
int pure;
gfc_component *comp;
*name = NULL;
@ -2754,7 +2755,13 @@ 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,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
out which entity the name refers to. */
@ -2809,7 +2849,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,33 +3021,9 @@ 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;
}
gfc_unset_implicit_pure (NULL);
}
if (!check_pure_function(expr))
t = false;
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
@ -3056,23 +3071,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 +3111,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 +3215,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 +3286,7 @@ found:
c->resolved_sym = sym;
pure_subroutine (c, sym);
return true;
return pure_subroutine (sym, sym->name, &c->loc);
}
@ -6036,6 +6060,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 +6101,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;

8
gcc/testsuite/ChangeLog
View File

@ -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>
PR target/53513

32
gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90 Normal file
View File

@ -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

2
gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90
View File

@ -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

2
gcc/testsuite/gfortran.dg/stfunc_6.f90
View File

@ -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)

4
gcc/testsuite/gfortran.dg/typebound_operator_4.f03
View File

@ -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