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.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155086 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 41 insertions, 8 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6f6cb781606..8d2be53b2cd 100644
--- a/gcc/fortran/resolve.c
+++ b/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