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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@218717 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4d99f18..24bddef 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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>
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d47bb7b..6a0a869 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a4e64b0..3d96f34 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90
new file mode 100644 (file)
index 0000000..cc4096a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_39.f90
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90 b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90
index c1bc172..b3e75a4 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90
+++ b/gcc/testsuite/gfortran.dg/pure_dummy_length_1.f90
@@ -24,6 +24,6 @@
          character(*), intent(in) :: string\r
          integer(4), intent(in) :: ignore_case\r
          integer i\r
-         if (end > impure (self)) & ! { dg-error "non-PURE procedure" }\r
+         if (end > impure (self)) & ! { dg-error "non-PURE function" }\r
            return\r
    end function\r

diff --git a/gcc/testsuite/gfortran.dg/stfunc_6.f90 b/gcc/testsuite/gfortran.dg/stfunc_6.f90
index 482d125..413e583 100644 (file)
--- a/gcc/testsuite/gfortran.dg/stfunc_6.f90
+++ b/gcc/testsuite/gfortran.dg/stfunc_6.f90
@@ -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)

diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03
index 6ede14e..0a8415f 100644 (file)
--- a/gcc/testsuite/gfortran.dg/typebound_operator_4.f03
+++ b/gcc/testsuite/gfortran.dg/typebound_operator_4.f03
@@ -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