re PR fortran/41177 (Wrong base-object checks for type-bound procedures)

2008-12-08  Daniel Kraft  <d@domob.eu>

	PR fortran/41177
	* gfortran.dg/typebound_proc_4.f03: Remove check for wrong error.
	* gfortran.dg/typebound_proc_13.f03: New test.

2008-12-08  Daniel Kraft  <d@domob.eu>

	PR fortran/41177
	* gfortran.h (struct symbol_attribute): New flag `class_pointer'.
	* symbol.c (gfc_build_class_symbol): Set the new flag.
	* resolve.c (update_compcall_arglist): Remove wrong check for
	non-scalar base-object.
	(check_typebound_baseobject): Add the correct version here as well
	as some 'not implemented' message check in the old case.
	(resolve_typebound_procedure): Check that the passed-object dummy
	argument is scalar, non-pointer and non-allocatable as it should be.

From-SVN: r155086

gcc/fortran/ChangeLog

+2008-12-08  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41177
+	* gfortran.h (struct symbol_attribute): New flag `class_pointer'.
+	* symbol.c (gfc_build_class_symbol): Set the new flag.
+	* resolve.c (update_compcall_arglist): Remove wrong check for
+	non-scalar base-object.
+	(check_typebound_baseobject): Add the correct version here as well
+	as some 'not implemented' message check in the old case.
+	(resolve_typebound_procedure): Check that the passed-object dummy
+	argument is scalar, non-pointer and non-allocatable as it should be.
+
 2009-12-08  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/40961

gcc/fortran/gfortran.h

@@ -654,6 +654,11 @@ typedef struct
     dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
     implied_index:1, subref_array_pointer:1, proc_pointer:1;
 
+  /* For CLASS containers, the pointer attribute is sometimes set internally
+     even though it was not directly specified.  In this case, keep the
+     "real" (original) value here.  */
+  unsigned class_pointer:1;
+
   ENUM_BITFIELD (save_state) save:2;
 
   unsigned data:1,		/* Symbol is named in a DATA statement.  */

gcc/fortran/resolve.c

@@ -4781,12 +4781,6 @@ update_compcall_arglist (gfc_expr* e)
   if (!po)
     return FAILURE;
 
-  if (po->rank > 0)
-    {
-      gfc_error ("Passed-object at %L must be scalar", &e->where);
-      return FAILURE;
-    }
-
   if (tbp->nopass || e->value.compcall.ignore_pass)
     {
       gfc_free_expr (po);
@@ -4889,6 +4883,22 @@ check_typebound_baseobject (gfc_expr* e)
       return FAILURE;
     }
 
+  /* If the procedure called is NOPASS, the base object must be scalar.  */
+  if (e->value.compcall.tbp->nopass && base->rank > 0)
+    {
+      gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
+		 " be scalar", &e->where);
+      return FAILURE;
+    }
+
+  /* FIXME: Remove once PR 41177 (this problem) is fixed completely.  */
+  if (base->rank > 0)
+    {
+      gfc_error ("Non-scalar base object at %L currently not implemented",
+		 &e->where);
+      return FAILURE;
+    }
+
   return SUCCESS;
 }
 
@@ -10038,8 +10048,11 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	  me_arg = proc->formal->sym;
 	}
 
-      /* Now check that the argument-type matches.  */
+      /* Now check that the argument-type matches and the passed-object
+	 dummy argument is generally fine.  */
+
       gcc_assert (me_arg);
+
       if (me_arg->ts.type != BT_CLASS)
 	{
 	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
@@ -10055,7 +10068,27 @@ resolve_typebound_procedure (gfc_symtree* stree)
 		     me_arg->name, &where, resolve_bindings_derived->name);
 	  goto error;
 	}
-
+  
+      gcc_assert (me_arg->ts.type == BT_CLASS);
+      if (me_arg->ts.u.derived->components->as
+	  && me_arg->ts.u.derived->components->as->rank > 0)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must be"
+		     " scalar", proc->name, &where);
+	  goto error;
+	}
+      if (me_arg->ts.u.derived->components->attr.allocatable)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must not"
+		     " be ALLOCATABLE", proc->name, &where);
+	  goto error;
+	}
+      if (me_arg->ts.u.derived->components->attr.class_pointer)
+	{
+	  gfc_error ("Passed-object dummy argument of '%s' at %L must not"
+		     " be POINTER", proc->name, &where);
+	  goto error;
+	}
     }
 
   /* If we are extending some type, check that we don't override a procedure

gcc/fortran/symbol.c

@@ -4681,6 +4681,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->ts.type = BT_DERIVED;
       c->attr.access = ACCESS_PRIVATE;
       c->ts.u.derived = ts->u.derived;
+      c->attr.class_pointer = attr->pointer;
       c->attr.pointer = attr->pointer || attr->dummy;
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;

gcc/testsuite/ChangeLog

+2008-12-08  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41177
+	* gfortran.dg/typebound_proc_4.f03: Remove check for wrong error.
+	* gfortran.dg/typebound_proc_13.f03: New test.
+
 2009-12-08  Olga Golovanevsky  <olga@il.ibm.com>
 	    Jakub Jelinek <jakub@redhat.com>	
 

gcc/testsuite/gfortran.dg/typebound_call_4.f03

@@ -37,10 +37,6 @@ CONTAINS
     CALL arr(1)%myobj%proc ()
     WRITE (*,*) arr(2)%myobj%func ()
 
-    ! Base-object must be scalar.
-    CALL arr(:)%myobj%proc () ! { dg-error "scalar" }
-    WRITE (*,*) arr(:)%myobj%func () ! { dg-error "scalar" }
-
     ! Can't CALL a function or take the result of a SUBROUTINE.
     CALL arr(1)%myobj%func () ! { dg-error "SUBROUTINE" }
     WRITE (*,*) arr(2)%myobj%proc () ! { dg-error "FUNCTION" }

gcc/testsuite/gfortran.dg/typebound_proc_13.f03

+! { dg-do compile }
+
+! PR fortran/41177
+! Test for additional errors with type-bound procedure bindings.
+! Namely that non-scalar base objects are rejected for TBP calls which are
+! NOPASS, and that passed-object dummy arguments must be scalar, non-POINTER
+! and non-ALLOCATABLE.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE t
+  CONTAINS
+    PROCEDURE, NOPASS :: myproc
+  END TYPE t
+
+  TYPE t2
+  CONTAINS
+    PROCEDURE, PASS :: nonscalar ! { dg-error "must be scalar" }
+    PROCEDURE, PASS :: is_pointer ! { dg-error "must not be POINTER" }
+    PROCEDURE, PASS :: is_allocatable ! { dg-error "must not be ALLOCATABLE" }
+  END TYPE t2
+
+CONTAINS
+
+  SUBROUTINE myproc ()
+  END SUBROUTINE myproc
+
+  SUBROUTINE nonscalar (me)
+    CLASS(t2), INTENT(IN) :: me(:)
+  END SUBROUTINE nonscalar
+
+  SUBROUTINE is_pointer (me)
+    CLASS(t2), POINTER, INTENT(IN) :: me
+  END SUBROUTINE is_pointer
+
+  SUBROUTINE is_allocatable (me)
+    CLASS(t2), ALLOCATABLE, INTENT(IN) :: me
+  END SUBROUTINE is_allocatable
+
+  SUBROUTINE test ()
+    TYPE(t) :: arr(2)
+    CALL arr%myproc () ! { dg-error "must be scalar" }
+  END SUBROUTINE test
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }