2010-10-21 Tobias Burnus <burnus@net-b.de>

        PR fortran/46100
        * expr.c (gfc_check_vardef_context): Treat pointer functions
        as variables.

2010-10-21  Tobias Burnus  <burnus@net-b.de>

        PR fortran/46100
        * gfortran.dg/ptr-func-1.f90: New.
        * gfortran.dg/ptr-func-2.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1e10747c6f5c23f1439cd67b1379c2d8bc9ea6db..37f4b16ef8474121fb43c61c8d45259271e34b61 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2010-10-21  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/46100
+       * expr.c (gfc_check_vardef_context): Treat pointer functions
+       as variables.
+
 2010-10-20  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/46079

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 5711634466634c119675cd7aab56779f4669ded5..ef516a4442d24bd143ba3cca3185cb2ffccacdd6 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4316,7 +4316,18 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
   symbol_attribute attr;
   gfc_ref* ref;
 
-  if (e->expr_type != EXPR_VARIABLE)
+  if (!pointer && e->expr_type == EXPR_FUNCTION
+      && e->symtree->n.sym->result->attr.pointer)
+    {
+      if (!(gfc_option.allow_std & GFC_STD_F2008))
+       {
+         if (context)
+           gfc_error ("Fortran 2008: Pointer functions in variable definition"
+                      " context (%s) at %L", context, &e->where);
+         return FAILURE;
+       }
+    }
+  else if (e->expr_type != EXPR_VARIABLE)
     {
       if (context)
        gfc_error ("Non-variable expression in variable definition context (%s)"

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5abf927bf9a9d5f8f5572b82bd2d42a6ed1a4ae5..e388ac152e4cdb9b0e354c84bf87f39981991a68 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2010-10-21  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/46100
+       * gfortran.dg/ptr-func-1.f90: New.
+       * gfortran.dg/ptr-func-2.f90: New.
+
 2010-10-20  Jakub Jelinek  <jakub@redhat.com>
 
        PR tree-optimization/45919

diff --git a/gcc/testsuite/gfortran.dg/ptr-func-1.f90 b/gcc/testsuite/gfortran.dg/ptr-func-1.f90
new file mode 100644 (file)
index 0000000..b7c1fc9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr-func-1.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+!
+! PR fortran/46100
+!
+! Pointer function as definable actual argument
+! - a Fortran 2008 feature
+!
+integer, target :: tgt
+call one (two ())
+if (tgt /= 774) call abort ()
+contains
+  subroutine one (x)
+    integer, intent(inout) :: x
+    if (x /= 34) call abort ()
+    x = 774
+  end subroutine one
+  function two ()
+    integer, pointer :: two
+    two => tgt 
+    two = 34
+  end function two
+end
+

diff --git a/gcc/testsuite/gfortran.dg/ptr-func-2.f90 b/gcc/testsuite/gfortran.dg/ptr-func-2.f90
new file mode 100644 (file)
index 0000000..8275f14
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ptr-func-2.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+!
+! PR fortran/46100
+!
+! Pointer function as definable actual argument
+! - a Fortran 2008 feature
+!
+integer, target :: tgt
+call one (two ()) ! { dg-error "Fortran 2008: Pointer functions" }
+if (tgt /= 774) call abort ()
+contains
+  subroutine one (x)
+    integer, intent(inout) :: x
+    if (x /= 34) call abort ()
+    x = 774
+  end subroutine one
+  function two ()
+    integer, pointer :: two
+    two => tgt 
+    two = 34
+  end function two
+end
+