OSDN Git Service

2010-10-21 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Thu, 21 Oct 2010 06:15:30 +0000 (06:15 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Thu, 21 Oct 2010 06:15:30 +0000 (06:15 +0000)
        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

gcc/fortran/ChangeLog
gcc/fortran/expr.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/ptr-func-1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/ptr-func-2.f90 [new file with mode: 0644]

index 1e10747..37f4b16 100644 (file)
@@ -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
index 5711634..ef516a4 100644 (file)
@@ -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)"
index 5abf927..e388ac1 100644 (file)
@@ -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
@@ -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
@@ -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
+