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

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

6 files changed, 70 insertions, 5 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c1f9593..8f7822f 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,13 @@
 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
 	* resolve.c (resolve_intrinsic): Don't search for a
 	function if we know that it is a subroutine.
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 129ece3..d136140 100644
--- 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 e1f0cb6..e9df662 100644
--- 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 c8a8f75..19ea2d5 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 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
 	* gfortran.dg/intrinsic_8.f90: New.
 
diff --git a/gcc/testsuite/gfortran.dg/class_51.f90 b/gcc/testsuite/gfortran.dg/class_51.f90
new file mode 100644
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
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
+