From: Janus Weil <janus@gcc.gnu.org>
Date: Mon, 17 May 2010 08:25:06 +0000 (+0200)
Subject: re PR fortran/44044 ([OOP] SELECT TYPE with class-valued function)
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=233961db333a77cac359e6c35eae5565703d7d78;p=gcc.git

re PR fortran/44044 ([OOP] SELECT TYPE with class-valued function)

2010-05-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44044
	* resolve.c (resolve_fl_var_and_proc): Move error messages here from ...
	(resolve_fl_variable_derived): ... this place.
	(resolve_symbol): Make sure function symbols (and their result
	variables) are not resolved twice.


2010-05-17  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/44044
	* gfortran.dg/class_20.f03: New.

From-SVN: r159476
---

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8c5d7b103e7..2bf6b659b65 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2010-05-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44044
+	* resolve.c (resolve_fl_var_and_proc): Move error messages here from ...
+	(resolve_fl_variable_derived): ... this place.
+	(resolve_symbol): Make sure function symbols (and their result
+	variables) are not resolved twice.
+
 2010-05-16  Daniel Franke  <franke.daniel@gmail.com>
 
         PR fortran/35779
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index da8d896cba5..d165bd66162 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -9143,6 +9143,29 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 	  return FAILURE;
 	 }
     }
+
+  /* Constraints on polymorphic variables.  */
+  if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym))
+    {
+      /* F03:C502.  */
+      if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
+	{
+	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
+		     sym->ts.u.derived->components->ts.u.derived->name,
+		     sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+
+      /* F03:C509.  */
+      /* Assume that use associated symbols were checked in the module ns.  */ 
+      if (!sym->attr.class_ok && !sym->attr.use_assoc)
+	{
+	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
+		     "or pointer", sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+    }
+    
   return SUCCESS;
 }
 
@@ -9194,27 +9217,6 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
 			 &sym->declared_at) == FAILURE)
     return FAILURE;
 
-  if (sym->ts.type == BT_CLASS)
-    {
-      /* C502.  */
-      if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived))
-	{
-	  gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible",
-		     sym->ts.u.derived->components->ts.u.derived->name,
-		     sym->name, &sym->declared_at);
-	  return FAILURE;
-	}
-
-      /* C509.  */
-      /* Assume that use associated symbols were checked in the module ns.  */ 
-      if (!sym->attr.class_ok && !sym->attr.use_assoc)
-	{
-	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
-		     "or pointer", sym->name, &sym->declared_at);
-	  return FAILURE;
-	}
-    }
-
   /* Assign default initializer.  */
   if (!(sym->value || sym->attr.pointer || sym->attr.allocatable)
       && (!no_init_flag || sym->attr.intent == INTENT_OUT))
@@ -11130,6 +11132,10 @@ resolve_symbol (gfc_symbol *sym)
   gfc_namespace *ns;
   gfc_component *c;
 
+  /* Avoid double resolution of function result symbols.  */
+  if ((sym->result || sym->attr.result) && (sym->ns != gfc_current_ns))
+    return;
+  
   if (sym->attr.flavor == FL_UNKNOWN)
     {
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5db30d4eb1f..b4d89e027b7 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2010-05-17  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/44044
+	* gfortran.dg/class_20.f03: New.
+
 2010-05-17  Christian Borntraeger  <borntraeger@de.ibm.com>
 
         PR 44078
diff --git a/gcc/testsuite/gfortran.dg/class_20.f03 b/gcc/testsuite/gfortran.dg/class_20.f03
new file mode 100644
index 00000000000..1428102e9ff
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_20.f03
@@ -0,0 +1,40 @@
+! { dg-do compile }
+!
+! PR 44044: [OOP] SELECT TYPE with class-valued function
+! comment #1
+!
+! Note: All three error messages are being checked for double occurrence,
+!       using the trick from PR 30612.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+
+implicit none
+
+type :: t
+end type
+
+type :: s
+  sequence
+end type
+
+contains
+
+  function fun()  ! { dg-bogus "must be dummy, allocatable or pointer.*must be dummy, allocatable or pointer" }
+    class(t) :: fun
+  end function
+ 
+  function fun2()  ! { dg-bogus "cannot have a deferred shape.*cannot have a deferred shape" }
+    integer,dimension(:) :: fun2
+  end function
+ 
+  function fun3() result(res)  ! { dg-bogus "is not extensible.*is not extensible" }
+    class(s),pointer :: res
+  end function
+
+end
+
+
+! { dg-error "must be dummy, allocatable or pointer" "" { target *-*-* } 23 }
+! { dg-error "cannot have a deferred shape"          "" { target *-*-* } 27 }
+! { dg-error "is not extensible"                     "" { target *-*-* } 31 }