re PR fortran/36704 (Procedure pointer as function result)

2008-12-02  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	PR fortran/38290
	* decl.c (match_result): Result may be a standard variable or a
	procedure pointer.
	* expr.c (gfc_check_pointer_assign): Additional checks for procedure
	pointer assignments.
	* primary.c (gfc_match_rvalue): Bugfix for procedure pointer
	assignments.
	* resolve.c (resolve_function): Check for attr.subroutine.
	* symbol.c (check_conflict): Addtional checks for RESULT statements.
	* trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure
	pointers as function result.

2008-12-02  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/36704
	PR fortran/38290
	* gfortran.dg/entry_7.f90: Modified.
	* gfortran.dg/proc_ptr_2.f90: Extended.
	* gfortran.dg/proc_ptr_3.f90: Modified.
	* gfortran.dg/proc_ptr_11.f90: New.
	* gfortran.dg/proc_ptr_12.f90: New.
	* gfortran.dg/result_1.f90: New.

From-SVN: r142351

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 732b0f7a497e094b70c14153979d9ea97d511feb..d3ae07fe2736b42f61005140dafd73431561345a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2008-12-02  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/36704
+       PR fortran/38290
+       * decl.c (match_result): Result may be a standard variable or a
+       procedure pointer.
+       * expr.c (gfc_check_pointer_assign): Additional checks for procedure
+       pointer assignments.
+       * primary.c (gfc_match_rvalue): Bugfix for procedure pointer
+       assignments.
+       * resolve.c (resolve_function): Check for attr.subroutine.
+       * symbol.c (check_conflict): Addtional checks for RESULT statements.
+       * trans-types.c (gfc_sym_type,gfc_get_function_type): Support procedure
+       pointers as function result.
+
 2008-12-01  Mikael Morin  <mikael.morin@tele2.fr>
 
        PR fortran/38252

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 14ccb6081a86b3ae61082f3f24bad81e80cf45f0..f6677fe42e02ec15406ff6f2adbe06f7f019dae6 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3974,8 +3974,7 @@ match_result (gfc_symbol *function, gfc_symbol **result)
   if (gfc_get_symbol (name, NULL, &r))
     return MATCH_ERROR;
 
-  if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
-      || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
+  if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
     return MATCH_ERROR;
 
   *result = r;

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 4017cf91f331157f2fbeef0d995bc34d8da56f03..b94e5ac0b87e00951cd5d3e8b65aadc6e811b6ee 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3112,9 +3112,30 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
     return SUCCESS;
 
-  /* TODO checks on rvalue for a procedure pointer assignment.  */
+  /* Checks on rvalue for procedure pointer assignments.  */
   if (lvalue->symtree->n.sym->attr.proc_pointer)
-    return SUCCESS;
+    {
+      attr = gfc_expr_attr (rvalue);
+      if (!((rvalue->expr_type == EXPR_NULL)
+           || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+           || (rvalue->expr_type == EXPR_VARIABLE
+               && attr.flavor == FL_PROCEDURE)))
+       {
+         gfc_error ("Invalid procedure pointer assignment at %L",
+                    &rvalue->where);
+         return FAILURE;
+       }
+      if (rvalue->expr_type == EXPR_VARIABLE
+         && lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
+         && !gfc_compare_interfaces (lvalue->symtree->n.sym,
+                                     rvalue->symtree->n.sym, 0))
+       {
+         gfc_error ("Interfaces don't match "
+                    "in procedure pointer assignment at %L", &rvalue->where);
+         return FAILURE;
+       }
+      return SUCCESS;
+    }
 
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index f3e1b038918a76acbec3f1be028eded25b06ca3d..032fa9024b49b6d4b462dff404b2f353d3c39462 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2509,11 +2509,10 @@ gfc_match_rvalue (gfc_expr **result)
       if (gfc_matching_procptr_assignment)
        {
          gfc_gobble_whitespace ();
-         if (sym->attr.function && gfc_peek_ascii_char () == '(')
+         if (gfc_peek_ascii_char () == '(')
            /* Parse functions returning a procptr.  */
            goto function0;
 
-         if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
          if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
              || gfc_is_intrinsic (sym, 1, gfc_current_locus))
            sym->attr.intrinsic = 1;

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6ccbe12859ad89f0783675730e38b3ce2f0beef1..0b6fe4c13a9895805622922b7df3cb5c6c2f1d23 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2327,7 +2327,7 @@ resolve_function (gfc_expr *expr)
       return FAILURE;
     }
 
-  if (sym && sym->attr.flavor == FL_VARIABLE)
+  if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine))
     {
       gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
       return FAILURE;

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 4e81b89e2b042c3efdadc0f84021ca780ba476b9..7c79ef80afa86042609d0725bb9081cc328ec9f4 100644 (file)
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -618,7 +618,10 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       break;
 
     case FL_VARIABLE:
+      break;
+
     case FL_NAMELIST:
+      conf2 (result);
       break;
 
     case FL_PROCEDURE:
@@ -672,6 +675,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (function);
       conf2 (subroutine);
       conf2 (threadprivate);
+      conf2 (result);
 
       if (attr->intent != INTENT_UNKNOWN)
        {
@@ -698,6 +702,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       conf2 (threadprivate);
       conf2 (value);
       conf2 (is_bind_c);
+      conf2 (result);
       break;
 
     default:

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index de629646ec8703113b01b88c660a7edb38aeee8c..e1ff5aadde59404a4af6c07c11a67d246ecb405a 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1613,8 +1613,8 @@ gfc_sym_type (gfc_symbol * sym)
   tree type;
   int byref;
 
-  /* Procedure Pointers inside COMMON blocks.  */
-  if (sym->attr.proc_pointer && sym->attr.in_common)
+  /* Procedure Pointers inside COMMON blocks or as function result.  */
+  if (sym->attr.proc_pointer && (sym->attr.in_common || sym->attr.result))
     {
       /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type.  */
       sym->attr.proc_pointer = 0;
@@ -2143,6 +2143,9 @@ gfc_get_function_type (gfc_symbol * sym)
       type = gfc_typenode_for_spec (&sym->ts);
       sym->ts.kind = gfc_default_real_kind;
     }
+  else if (sym->result && sym->result->attr.proc_pointer)
+    /* Procedure pointer return values.  */
+    type = gfc_sym_type (sym->result);
   else
     type = gfc_sym_type (sym);
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index ad317b7820ab6f9de73776f6eb9285dbaedb927e..f64db4d4cf750247484bd79b690d6d41a6086641 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2008-12-02  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/36704
+       PR fortran/38290
+       * gfortran.dg/entry_7.f90: Modified.
+       * gfortran.dg/proc_ptr_2.f90: Extended.
+       * gfortran.dg/proc_ptr_3.f90: Modified.
+       * gfortran.dg/proc_ptr_11.f90: New.
+       * gfortran.dg/proc_ptr_12.f90: New.
+       * gfortran.dg/result_1.f90: New.
+
 2008-12-02  Jakub Jelinek  <jakub@redhat.com>
 
        PR middle-end/38343

diff --git a/gcc/testsuite/gfortran.dg/entry_7.f90 b/gcc/testsuite/gfortran.dg/entry_7.f90
index fbe4b8e2af15dbbe5edcefaf5aaac6b93b0119aa..529409845519daed74a34925efc932aa2b212e7f 100644 (file)
--- a/gcc/testsuite/gfortran.dg/entry_7.f90
+++ b/gcc/testsuite/gfortran.dg/entry_7.f90
@@ -9,7 +9,7 @@
 MODULE TT
 CONTAINS
   FUNCTION K(I) RESULT(J)
-    ENTRY J() ! { dg-error "conflicts with PROCEDURE attribute" }
+    ENTRY J() ! { dg-error "conflicts with RESULT attribute" }
   END FUNCTION K
 
   integer function foo ()

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
new file mode 100644 (file)
index 0000000..a5cdbb5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+!
+! PR 38290: Procedure pointer assignment checking.
+!
+! Test case found at http://de.wikibooks.org/wiki/Fortran:_Fortran_2003:_Zeiger
+! Adapted by Janus Weil <janus@gcc.gnu.org>
+
+program bsp
+  implicit none   
+
+  abstract interface
+    subroutine up()
+    end subroutine up
+  end interface
+
+  procedure( up ) , pointer :: pptr
+
+  pptr => add   ! { dg-error "Interfaces don't match" }
+
+  print *, pptr()   ! { dg-error "is not a function" }
+
+  contains
+
+    function add( a, b )
+      integer               :: add
+      integer, intent( in ) :: a, b
+      add = a + b
+    end function add
+
+end program bsp 

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_12.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_12.f90
new file mode 100644 (file)
index 0000000..325703f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_12.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+!
+! PR 36704: Procedure pointer as function result
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+procedure(integer),pointer :: p
+p => foo()
+if (p(-1)/=1) call abort
+contains
+  function foo() result(bar)
+    procedure(integer),pointer :: bar
+    bar => iabs
+  end function
+end

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
index d19b81d6e472b9db9297ecc797ca76c7944f123a..6224dc5980ba2c86ff6b3e96d3485c48e3df6f71 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
@@ -6,8 +6,11 @@
 
 PROCEDURE(REAL), POINTER :: ptr
 PROCEDURE(REAL), SAVE    :: noptr    ! { dg-error "attribute conflicts with" }
+REAL :: x
 
-ptr => cos(4.0)        ! { dg-error "Invalid character" }
+ptr => cos(4.0)        ! { dg-error "Invalid procedure pointer assignment" }
+ptr => x               ! { dg-error "Invalid procedure pointer assignment" }
+ptr => sin(x)          ! { dg-error "Invalid procedure pointer assignment" }
 
 ALLOCATE(ptr)          ! { dg-error "must be ALLOCATABLE" }
 

diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
index 34d4f1625fb6523c5c4b33152ca1904eebfcf311..5c4233d60e4a3519d3d6c06ba4e0775c108fb888 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
@@ -6,14 +6,12 @@
 
 real function e1(x)
   real :: x
-  print *,'e1!',x
   e1 = x * 3.0
 end function
 
 subroutine e2(a,b)
   real, intent(inout) :: a
   real, intent(in) :: b
-  print *,'e2!',a,b
   a = a + b
 end subroutine
 
@@ -29,7 +27,15 @@ interface
   end subroutine sp
 end interface
 
-external :: e1,e2
+external :: e1
+
+interface
+  subroutine e2(a,b)
+    real, intent(inout) :: a
+    real, intent(in) :: b
+  end subroutine e2
+end interface
+
 real :: c = 1.2
 
 fp => e1

diff --git a/gcc/testsuite/gfortran.dg/result_1.f90 b/gcc/testsuite/gfortran.dg/result_1.f90
new file mode 100644 (file)
index 0000000..162ffaf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/result_1.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+!
+! PR 36704: Procedure pointer as function result
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+function f() result(r)
+real, parameter :: r = 5.0    ! { dg-error "attribute conflicts" }
+end function 
+
+function g() result(s)
+real :: a,b,c
+namelist /s/ a,b,c    ! { dg-error "attribute conflicts" }
+end function
+
+function h() result(t)
+type t    ! { dg-error "attribute conflicts" }
+end function