re PR fortran/41608 ([OOP] ICE with CLASS and invalid code)

2009-10-17  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41608
	* decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
	and empty type errors.
	* parse.c (gfc_build_block_ns): Only set recursive if parent ns
	has a proc_name.

	PR fortran/41629
	PR fortran/41618
	PR fortran/41587
	* gfortran.h : Add class_ok bitfield to symbol_attr.
	* decl.c (build_sym): Set attr.class_ok if dummy, pointer or
	allocatable.
	(build_struct): Use gfc_try 't' to carry errors past the call
	to encapsulate_class_symbol.
	(attr_decl1): For a CLASS object, apply the new attribute to
	the data component.
	* match.c (gfc_match_select_type): Set attr.class_ok for an
	assigned selector.
	* resolve.c (resolve_fl_variable_derived): Check a CLASS object
	is dummy, pointer or allocatable by testing the class_ok and
	the use_assoc attribute.

2009-10-17  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41629
	* gfortran.dg/class_6.f90: New test.

	PR fortran/41608
	PR fortran/41587
	* gfortran.dg/class_7.f90: New test.

	PR fortran/41618
	* gfortran.dg/class_8.f90: New test.


Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r152955

10 files changed, 147 insertions, 21 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 17bbc06..24e83e6 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+2009-10-17  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41608
+	* decl.c (gfc_match_data_decl): Add BT_CLASS for undefined type
+	and empty type errors.
+	* parse.c (gfc_build_block_ns): Only set recursive if parent ns
+	has a proc_name.
+
+	PR fortran/41629
+	PR fortran/41618
+	PR fortran/41587
+	* gfortran.h : Add class_ok bitfield to symbol_attr.
+	* decl.c (build_sym): Set attr.class_ok if dummy, pointer or
+	allocatable.
+	(build_struct): Use gfc_try 't' to carry errors past the call
+	to encapsulate_class_symbol.
+	(attr_decl1): For a CLASS object, apply the new attribute to
+	the data component.
+	* match.c (gfc_match_select_type): Set attr.class_ok for an
+	assigned selector.
+	* resolve.c (resolve_fl_variable_derived): Check a CLASS object
+	is dummy, pointer or allocatable by testing the class_ok and
+	the use_assoc attribute.
+
 2009-10-16  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/41719
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2627e60..08d2bd6 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1181,7 +1181,12 @@ build_sym (const char *name, gfc_charlen *cl,
   sym->attr.implied_index = 0;
 
   if (sym->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    {
+      sym->attr.class_ok = (sym->attr.dummy
+			      || sym->attr.pointer
+			      || sym->attr.allocatable) ? 1 : 0;
+      encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
+    }
 
   return SUCCESS;
 }
@@ -1472,6 +1477,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 	      gfc_array_spec **as)
 {
   gfc_component *c;
+  gfc_try t = SUCCESS;
 
   /* F03:C438/C439. If the current symbol is of the same derived type that we're
      constructing, it must have the pointer attribute.  */
@@ -1554,12 +1560,9 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 	}
     }
 
-  if (c->ts.type == BT_CLASS)
-    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
-
   /* Check array components.  */
   if (!c->attr.dimension)
-    return SUCCESS;
+    goto scalar;
 
   if (c->attr.pointer)
     {
@@ -1567,7 +1570,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 	{
 	  gfc_error ("Pointer array component of structure at %C must have a "
 		     "deferred shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
   else if (c->attr.allocatable)
@@ -1576,7 +1579,7 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 	{
 	  gfc_error ("Allocatable component of structure at %C must have a "
 		     "deferred shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
   else
@@ -1585,11 +1588,15 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
 	{
 	  gfc_error ("Array component of structure at %C must have an "
 		     "explicit shape");
-	  return FAILURE;
+	  t = FAILURE;
 	}
     }
 
-  return SUCCESS;
+scalar:
+  if (c->ts.type == BT_CLASS)
+    encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
+
+  return t;
 }
 
 
@@ -3761,7 +3768,8 @@ gfc_match_data_decl (void)
   if (m != MATCH_YES)
     return m;
 
-  if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
+  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+	&& gfc_current_state () != COMP_DERIVED)
     {
       sym = gfc_use_derived (current_ts.u.derived);
 
@@ -3781,7 +3789,8 @@ gfc_match_data_decl (void)
       goto cleanup;
     }
 
-  if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
+  if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
+      && current_ts.u.derived->components == NULL
       && !current_ts.u.derived->attr.zero_comp)
     {
 
@@ -5694,13 +5703,31 @@ attr_decl1 (void)
 	}
     }
 
-  /* Update symbol table.  DIMENSION attribute is set
-     in gfc_set_array_spec().  */
-  if (current_attr.dimension == 0
-      && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+  /* Update symbol table.  DIMENSION attribute is set in
+     gfc_set_array_spec().  For CLASS variables, this must be applied
+     to the first component, or '$data' field.  */
+  if (sym->ts.type == BT_CLASS && sym->ts.u.derived)
     {
-      m = MATCH_ERROR;
-      goto cleanup;
+      gfc_component *comp;
+      comp = gfc_find_component (sym->ts.u.derived, "$data", true, true);
+      if (comp == NULL || gfc_copy_attr (&comp->attr, &current_attr,
+					 &var_locus) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
+      sym->attr.class_ok = (sym->attr.class_ok
+			      || current_attr.allocatable
+			      || current_attr.pointer);
+    }
+  else
+    {
+      if (current_attr.dimension == 0
+	    && gfc_copy_attr (&sym->attr, &current_attr, &var_locus) == FAILURE)
+	{
+	  m = MATCH_ERROR;
+	  goto cleanup;
+	}
     }
 
   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f6b172a..74a31d2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -672,6 +672,7 @@ typedef struct
   unsigned is_bind_c:1;		/* say if is bound to C.  */
   unsigned extension:1;		/* extends a derived type.  */
   unsigned is_class:1;		/* is a CLASS container.  */
+  unsigned class_ok:1;		/* is a CLASS object with correct attributes.  */
 
   /* These flags are both in the typespec and attribute.  The attribute
      list is what gets read from/written to a module file.  The typespec
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3542944..d75ef0e 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4080,6 +4080,7 @@ gfc_match_select_type (void)
 	return MATCH_ERROR;
       expr1->symtree->n.sym->ts = expr2->ts;
       expr1->symtree->n.sym->attr.referenced = 1;
+      expr1->symtree->n.sym->attr.class_ok = 1;
     }
   else
     {
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 49d449c..c168c52 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3069,7 +3069,9 @@ gfc_build_block_ns (gfc_namespace *parent_ns)
 			  my_ns->proc_name->name, NULL);
       gcc_assert (t == SUCCESS);
     }
-  my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+  if (parent_ns->proc_name)
+    my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
 
   return my_ns;
 }
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d76c461..285228c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8641,9 +8641,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
 	}
 
       /* C509.  */
-      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer
-	      || sym->ts.u.derived->components->attr.allocatable
-	      || sym->ts.u.derived->components->attr.pointer))
+      /* 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);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 223d170..14900619 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,16 @@
+2009-10-17  Janus Weil  <janus@gcc.gnu.org>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41629
+	* gfortran.dg/class_6.f90: New test.
+
+	PR fortran/41608
+	PR fortran/41587
+	* gfortran.dg/class_7.f90: New test.
+
+	PR fortran/41618
+	* gfortran.dg/class_8.f90: New test.
+
 2009-10-17  Richard Guenther  <rguenther@suse.de>
 
 	* gcc.dg/lto/20091017-1_0.c: New testcase.
diff --git a/gcc/testsuite/gfortran.dg/class_6.f03 b/gcc/testsuite/gfortran.dg/class_6.f03
new file mode 100644
index 0000000..2f3ff62
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_6.f03
@@ -0,0 +1,21 @@
+! { dg-do run }
+!
+! PR 41629: [OOP] gimplification error on valid code
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+  type t1
+    integer :: comp
+  end type
+
+  type(t1), target :: a
+
+  class(t1) :: x
+  pointer :: x       ! This is valid
+
+  a%comp = 3
+  x => a
+  print *,x%comp
+  if (x%comp/=3) call abort()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/class_7.f03 b/gcc/testsuite/gfortran.dg/class_7.f03
new file mode 100644
index 0000000..ed4eeba
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_7.f03
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! Test fixes for PR41587 and PR41608.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+! PR41587: used to accept the declaration of component 'foo'
+  type t0
+    integer :: j = 42
+  end type t0
+  type t
+    integer :: i
+    class(t0), allocatable :: foo(3)  ! { dg-error "deferred shape" }
+  end type t
+
+! PR41608: Would ICE on missing type decl
+  class(t1), pointer :: c  ! { dg-error "before it is defined" }
+
+  select type (c)          ! { dg-error "shall be polymorphic" }
+    type is (t1)           ! { dg-error "Unexpected" }
+  end select               ! { dg-error "Expecting END PROGRAM" }
+end
diff --git a/gcc/testsuite/gfortran.dg/class_8.f03 b/gcc/testsuite/gfortran.dg/class_8.f03
new file mode 100644
index 0000000..78f10eb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_8.f03
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! Test fixes for PR41618.
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+!
+ type t1
+   integer :: comp
+   class(t1),pointer :: cc
+ end type
+
+ class(t1) :: x ! { dg-error "must be dummy, allocatable or pointer" }
+
+ x%comp = 3
+ print *,x%comp
+
+end