[Patch, Fortran] PR 41177: Some corrections on base-object checks with type-bound procedures.

[Daniel Kraft <d at domob dot eu>]

Hi all,

this patch is some take in the direction of PR 41177.  It adds checks 
that the passed-object dummy argument of a type-bound procedure must be 
scalar, non-POINTER and non-ALLOCATABLE which is at the moment simply 
overlooked (thus there's some accepts-invalid here which gets fixed).

On the other hand, the actual base-objects in calls were checked to be 
scalar which is wrong.  This is only required when calling NOPASS 
procedures; I did correct this.  However, there turned unfortunatly an 
ICE up when translating such calls for non-scalar base object, thus PR 
41177 is not fully fixed and I added an additional check with a "not 
implemented" message to catch up in that case until the ICE gets fixed, too.

Still I would like to commit this patch as it is right now and think 
this will be already some step in the right direction.

Unfortunatly, the POINTER attribute on CLASS dummies gets always set in 
decl.c:encapsulate_class_symbol; I thus had to introduce a new flag 
storing the original value in this case for my check -- this is what 
Janus also suggested.  But if someone else can come up with a nicer 
solution, I'd be happy to implement it.

I'm still building the patch after a SVN update and will then regression 
test on GNU/Linux-x86-32.  Ok for trunk if no failures?

Yours,
Daniel

--
Done:  Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri

2008-11-29  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-11-29  Daniel Kraft  <d@domob.eu>

	PR fortran/41177
	* gfortran.h (struct symbol_attribute): New flag `class_pointer'.
	* decl.c (encapsulate_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.

Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 154741)
+++ gcc/fortran/decl.c	(working copy)
@@ -1075,6 +1075,7 @@ encapsulate_class_symbol (gfc_typespec *
       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;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 154741)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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.  */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 154741)
+++ gcc/fortran/resolve.c	(working copy)
@@ -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;
 }
 
@@ -9938,8 +9948,11 @@ resolve_typebound_procedure (gfc_symtree
 	  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'"
@@ -9955,7 +9968,27 @@ resolve_typebound_procedure (gfc_symtree
 		     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
Index: gcc/testsuite/gfortran.dg/typebound_proc_13.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_13.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_13.f03	(revision 0)
@@ -0,0 +1,48 @@
+! { 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" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_4.f03	(revision 154741)
+++ gcc/testsuite/gfortran.dg/typebound_call_4.f03	(working copy)
@@ -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" }