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

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

gcc/fortran/ChangeLog

 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.

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)

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);
 
@@ -1707,9 +1709,10 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       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)

gcc/testsuite/ChangeLog

 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.
 

gcc/testsuite/gfortran.dg/class_51.f90

+! { 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" } }

gcc/testsuite/gfortran.dg/class_52.f90

+! { 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
+