re PR fortran/52864 (Assignment to pointer component for INTENT(IN) dummy argument)

2012-05-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52864
        * interface.c (compare_parameter_intent): Remove.
        (check_intents): Remove call, handle CLASS pointer.
        (compare_actual_formal): Handle CLASS pointer.

2012-05-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52864
        * gfortran.dg/pointer_intent_7.f90: New.
        * gfortran.dg/pure_formal_3.f90: New.

From-SVN: r187076

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ee13c2f94f5979cf896497dd8104f7fbc93ddb46..56626518e5045e350dd051738633885e5b6bd229 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2012-05-03  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/52864
+       * interface.c (compare_parameter_intent): Remove.
+       (check_intents): Remove call, handle CLASS pointer.
+       (compare_actual_formal): Handle CLASS pointer.
+
 2012-04-30  Jan Hubicka  <jh@suse.cz>
 
        * f95-lang.c (gfc_finish): Update comments.

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 2f1d24e6e3375fade69278855ca7f2abeb6b7aea..95439c118e45f3f066df68dcc7554b934a877649 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2517,7 +2517,9 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                                 ? _("actual argument to INTENT = OUT/INOUT")
                                 : NULL);
 
-         if (f->sym->attr.pointer
+         if (((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+               && CLASS_DATA (f->sym)->attr.class_pointer)
+              || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
              && gfc_check_vardef_context (a->expr, true, false, context)
                   == FAILURE)
            return 0;
@@ -2812,25 +2814,6 @@ check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
 }
 
 
-/* Given a symbol of a formal argument list and an expression,
-   return nonzero if their intents are compatible, zero otherwise.  */
-
-static int
-compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
-{
-  if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
-    return 1;
-
-  if (actual->symtree->n.sym->attr.intent != INTENT_IN)
-    return 1;
-
-  if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
-    return 0;
-
-  return 1;
-}
-
-
 /* Given formal and actual argument lists that correspond to one
    another, check that they are compatible in the sense that intents
    are not mismatched.  */
@@ -2852,25 +2835,11 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 
       f_intent = f->sym->attr.intent;
 
-      if (!compare_parameter_intent(f->sym, a->expr))
-       {
-         gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
-                    "specifies INTENT(%s)", &a->expr->where,
-                    gfc_intent_string (f_intent));
-         return FAILURE;
-       }
-
       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
        {
-         if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
-           {
-             gfc_error ("Procedure argument at %L is local to a PURE "
-                        "procedure and is passed to an INTENT(%s) argument",
-                        &a->expr->where, gfc_intent_string (f_intent));
-             return FAILURE;
-           }
-
-         if (f->sym->attr.pointer)
+         if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+              && CLASS_DATA (f->sym)->attr.class_pointer)
+             || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
            {
              gfc_error ("Procedure argument at %L is local to a PURE "
                         "procedure and has the POINTER attribute",
@@ -2890,7 +2859,9 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
              return FAILURE;
            }
 
-         if (f->sym->attr.pointer)
+         if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
+               && CLASS_DATA (f->sym)->attr.class_pointer)
+              || (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
            {
              gfc_error ("Coindexed actual argument at %L in PURE procedure "
                         "is passed to a POINTER dummy argument",

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 1ed2b0b66e5a2e7ec8de64376495417a99a6ea66..08d19b520d74e6fe80543dd62a79f3cb9f8a3c7f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2012-05-03  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/52864
+       * gfortran.dg/pointer_intent_7.f90: New.
+       * gfortran.dg/pure_formal_3.f90: New.
+
 2012-05-02  Ulrich Weigand  <ulrich.weigand@linaro.org>
 
        * gcc.target/s390/20030123-1.c: Add missing "volatile".

diff --git a/gcc/testsuite/gfortran.dg/pointer_intent_7.f90 b/gcc/testsuite/gfortran.dg/pointer_intent_7.f90
new file mode 100644 (file)
index 0000000..c09eb2b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pointer_intent_7.f90
@@ -0,0 +1,45 @@
+! { dg-do compile }
+!
+! PR fortran/
+!
+! Contributed by Neil Carlson
+!
+! Check whether passing an intent(in) pointer
+! to an intent(inout) nonpointer is allowed
+!
+module modA
+  type :: typeA
+    integer, pointer :: ptr
+  end type
+contains
+  subroutine foo (a,b,c)
+    type(typeA), intent(in) :: a
+    type(typeA), intent(in) , pointer :: b
+    class(typeA), intent(in) , pointer :: c
+
+    call bar (a%ptr)
+    call bar2 (b)
+    call bar3 (b)
+    call bar2 (c)
+    call bar3 (c)
+    call bar2p (b) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+    call bar3p (b) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+    call bar2p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+    call bar3p (c) ! { dg-error "INTENT\\(IN\\) in pointer association context \\(actual argument to INTENT = OUT/INOUT" }
+  end subroutine
+  subroutine bar (n)
+    integer, intent(inout) :: n
+  end subroutine
+  subroutine bar2 (n)
+    type(typeA), intent(inout) :: n
+  end subroutine
+  subroutine bar3 (n)
+    class(typeA), intent(inout) :: n
+  end subroutine
+  subroutine bar2p (n)
+    type(typeA), intent(inout), pointer :: n
+  end subroutine
+  subroutine bar3p (n)
+    class(typeA), intent(inout), pointer :: n
+  end subroutine
+end module

diff --git a/gcc/testsuite/gfortran.dg/pure_formal_3.f90 b/gcc/testsuite/gfortran.dg/pure_formal_3.f90
new file mode 100644 (file)
index 0000000..5d08057
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pure_formal_3.f90
@@ -0,0 +1,28 @@
+! { dg-do compile }
+!
+! Clean up, made when working on PR fortran/52864
+!
+! Test some PURE and intent checks - related to pointers.
+module m
+  type t
+  end type t
+  integer, pointer :: x
+  class(t), pointer :: y
+end module m
+
+pure subroutine foo()
+  use m
+  call bar(x) ! { dg-error "can not appear in a variable definition context" }
+  call bar2(x) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" }
+  call bb(y) ! { dg-error "is local to a PURE procedure and has the POINTER attribute" }
+contains
+  pure subroutine bar(x)
+    integer, pointer, intent(inout) :: x
+  end subroutine
+  pure subroutine bar2(x)
+    integer, pointer :: x
+  end subroutine
+  pure subroutine bb(x)
+    class(t), pointer, intent(in) :: x 
+  end subroutine
+end subroutine