re PR fortran/40164 (Fortran 2003: "Arrays of procedure pointers" (using PPCs))

2009-05-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40164
	* primary.c (gfc_match_rvalue): Handle procedure pointer components in
	arrays.
	* resolve.c (resolve_ppc_call,resolve_expr_ppc): Resolve component and
	array references.
	(resolve_fl_derived): Procedure pointer components are not required to
	have constant array bounds in their return value.

2009-05-18  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40164
	* gfortran.dg/proc_ptr_comp_8.f90: New.

From-SVN: r147663

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f7e47fc496a07a2398206c5215f40925c22392bf..c02a3263508531d3b7c06b7820d589bf11af8b5d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,13 @@
+2009-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/40164
+       * primary.c (gfc_match_rvalue): Handle procedure pointer components in
+       arrays.
+       * resolve.c (resolve_ppc_call,resolve_expr_ppc): Resolve component and
+       array references.
+       (resolve_fl_derived): Procedure pointer components are not required to
+       have constant array bounds in their return value.
+
 2009-05-18  Janus Weil  <janus@gcc.gnu.org>
 
        * intrinsic.c (add_sym): Fix my last commit (r147655),

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 96fbddce92a75b685a0c9a70e3fd0ad9b098c988..4d39c1aa93cffd99cd9ad19db5018f88d5a119ab 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2558,7 +2558,7 @@ gfc_match_rvalue (gfc_expr **result)
       if (gfc_matching_procptr_assignment)
        {
          gfc_gobble_whitespace ();
-         if (gfc_peek_ascii_char () == '(')
+         if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
            /* Parse functions returning a procptr.  */
            goto function0;
 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d3097c4ef7f6342a2f7f042e979388d8f9fe5ac6..39eb0432af800f1e12830bd0659dd1ad450c82cc 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4840,6 +4840,9 @@ resolve_ppc_call (gfc_code* c)
   if (!comp->attr.subroutine)
     gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where);
 
+  if (resolve_ref (c->expr1) == FAILURE)
+    return FAILURE;
+
   if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
                              comp->formal == NULL) == FAILURE)
     return FAILURE;
@@ -4869,6 +4872,9 @@ resolve_expr_ppc (gfc_expr* e)
   if (!comp->attr.function)
     gfc_add_function (&comp->attr, comp->name, &e->where);
 
+  if (resolve_ref (e) == FAILURE)
+    return FAILURE;
+
   if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
                              comp->formal == NULL) == FAILURE)
     return FAILURE;
@@ -9147,7 +9153,8 @@ resolve_fl_derived (gfc_symbol *sym)
            && sym != c->ts.derived)
        add_dt_to_dt_list (c->ts.derived);
 
-      if (c->attr.pointer || c->attr.allocatable ||  c->as == NULL)
+      if (c->attr.pointer || c->attr.proc_pointer || c->attr.allocatable
+         || c->as == NULL)
        continue;
 
       for (i = 0; i < c->as->rank; i++)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 73dc40866fa6db7a42b1fcf041b5d3f854b0fe10..c900c201f7e147872d6c21090bf865e17cca4d9d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-05-18  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/40164
+       * gfortran.dg/proc_ptr_comp_8.f90: New.
+
 2009-05-18  Richard Guenther  <rguenther@suse.de>
 
        PR fortran/40168

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_8.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_8.f90
new file mode 100644 (file)
index 0000000..ed06c2b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_8.f90
@@ -0,0 +1,58 @@
+! { dg-do run }
+!
+! PR 40164: Fortran 2003: "Arrays of procedure pointers" (using PPCs)
+!
+! Original test case by Barron Bichon <barron.bichon@swri.org>
+! Adapted by Janus Weil <janus@gcc.gnu.org>
+
+PROGRAM test_prog
+
+  ABSTRACT INTERFACE
+  FUNCTION fn_template(n,x) RESULT(y)
+    INTEGER, INTENT(in) :: n
+    REAL, INTENT(in) :: x(n)
+    REAL :: y(n)
+  END FUNCTION fn_template
+  END INTERFACE
+
+  TYPE PPA
+    PROCEDURE(fn_template), POINTER, NOPASS :: f
+  END TYPE PPA
+
+ TYPE ProcPointerArray
+   PROCEDURE(add), POINTER, NOPASS :: f
+ END TYPE ProcPointerArray
+
+ TYPE (ProcPointerArray) :: f_array(3)
+ PROCEDURE(add), POINTER :: f
+ real :: r
+
+ f_array(1)%f => add
+ f => f_array(1)%f
+ f_array(2)%f => sub
+ f_array(3)%f => f_array(1)%f
+
+ r = f(1.,2.)
+ if (abs(r-3.)>1E-3) call abort()
+ r = f_array(1)%f(4.,2.)
+ if (abs(r-6.)>1E-3) call abort()
+ r = f_array(2)%f(5.,3.)
+ if (abs(r-2.)>1E-3) call abort()
+ if (abs(f_array(1)%f(1.,3.)-f_array(3)%f(2.,2.))>1E-3) call abort()
+
+CONTAINS
+
+ FUNCTION add(a,b) RESULT(sum)
+   REAL, INTENT(in) :: a, b
+   REAL :: sum
+   sum = a + b
+ END FUNCTION add
+
+ FUNCTION sub(a,b) RESULT(diff)
+   REAL, INTENT(in) :: a, b
+   REAL :: diff
+   diff = a - b
+ END FUNCTION sub
+
+END PROGRAM test_prog
+