re PR fortran/52270 ([OOP] Polymorphic vars: wrong intent(in) check, passing nonptr...

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

        PR fortran/52270
        * expr.c (gfc_check_vardef_context): Fix check for
        intent-in polymorphic pointer .
        * interface.c (compare_parameter): Allow passing TYPE to
        intent-in polymorphic pointer.

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

        PR fortran/52270
        * gfortran.dg/class_51.f90: New.

From-SVN: r184784

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c1f959305c64cf10c23be01fdae2081f304a453b..8f7822f6c4d8764b6cd617a631ecb44384464312 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2012-03-02  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/52270
+       * expr.c (gfc_check_vardef_context): Fix check for
+       intent-in polymorphic pointer .
+       * interface.c (compare_parameter): Allow passing TYPE to
+       intent-in polymorphic pointer.
+
 2012-03-02  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/52452

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 129ece355071546683e24ec4c81551c1f65114a1..d136140876d6e5ca27c9a8c8a0fec286a428acbd 100644 (file)
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4648,7 +4648,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
      the component of sub-component of a pointer.  Obviously,
      procedure pointers are of no interest here.  */
   check_intentin = true;
-  ptr_component = sym->attr.pointer;
+  ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+                 ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
   for (ref = e->ref; ref && check_intentin; ref = ref->next)
     {
       if (ptr_component && ref->type == REF_COMPONENT)

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e1f0cb6b2f8f62e03c0ef5425b28ea3efbfe8d01..e9df662a29a254bc50534e52318b7b392f78cad3 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1579,7 +1579,9 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
 {
   symbol_attribute attr;
 
-  if (formal->attr.pointer)
+  if (formal->attr.pointer
+      || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
+         && CLASS_DATA (formal)->attr.class_pointer))
     {
       attr = gfc_expr_attr (actual);
 
@@ -1706,10 +1708,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
                   gfc_typename (&formal->ts));
       return 0;
     }
-    
-  /* F2008, 12.5.2.5.  */
+
+  /* F2008, 12.5.2.5; IR F08/0073.  */
   if (formal->ts.type == BT_CLASS
-      && (CLASS_DATA (formal)->attr.class_pointer
+      && ((CLASS_DATA (formal)->attr.class_pointer
+          && !formal->attr.intent == INTENT_IN)
           || CLASS_DATA (formal)->attr.allocatable))
     {
       if (actual->ts.type != BT_CLASS)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c8a8f758dae0ec09ba5dd54b6dbffece17b9674b..19ea2d569e08952424be14b2dc3b594c116ca245 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2012-03-02  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/52270
+       * gfortran.dg/class_51.f90: New.
+
 2012-03-02  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/52452

diff --git a/gcc/testsuite/gfortran.dg/class_51.f90 b/gcc/testsuite/gfortran.dg/class_51.f90
new file mode 100644 (file)
index 0000000..1fdad92
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_51.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/52270
+!
+! From IR F08/0073 by Malcolm Cohen
+!
+
+  Program m013
+    Type t
+      Real c
+    End Type
+    Type(t),Target :: x
+    Call sub(x)
+    Print *,x%c
+    if (x%c /= 3) call abort ()
+  Contains
+    Subroutine sub(p)
+      Class(t),Pointer,Intent(In) :: p
+      p%c = 3
+    End Subroutine
+  End Program
+
+! { dg-final { scan-tree-dump-times "sub \\(&class" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

diff --git a/gcc/testsuite/gfortran.dg/class_52.f90 b/gcc/testsuite/gfortran.dg/class_52.f90
new file mode 100644 (file)
index 0000000..42cb86d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_52.f90
@@ -0,0 +1,23 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/52270
+!
+! From IR F08/0073 by Malcolm Cohen
+!
+
+  Program m013
+    Type t
+      Real c
+    End Type
+    Type(t),Target :: x
+    Call sub(x) ! { dg-error "Fortran 2008: Non-pointer actual argument" }
+    Print *,x%c
+    if (x%c /= 3) call abort ()
+  Contains
+    Subroutine sub(p)
+      Class(t),Pointer,Intent(In) :: p
+      p%c = 3
+    End Subroutine
+  End Program
+