[Patch, fortran] OOP bugs - PRs 41587, 41608, 41618 and 41629

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

This patch applies various attribute checks to class objects, which
either were not previously applied or at the wrong time relative to
encapsulation.  It also fixes a bug in gfc_build_block_ns.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk?

Paul

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.

Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 152931)
--- gcc/fortran/decl.c	(working copy)
*************** build_sym (const char *name, gfc_charlen
*** 1181,1187 ****
    sym->attr.implied_index = 0;
  
    if (sym->ts.type == BT_CLASS)
!     encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
  
    return SUCCESS;
  }
--- 1181,1192 ----
    sym->attr.implied_index = 0;
  
    if (sym->ts.type == BT_CLASS)
!     {
!       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;
  }
*************** build_struct (const char *name, gfc_char
*** 1472,1477 ****
--- 1477,1483 ----
  	      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.  */
*************** build_struct (const char *name, gfc_char
*** 1554,1565 ****
  	}
      }
  
-   if (c->ts.type == BT_CLASS)
-     encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
- 
    /* Check array components.  */
    if (!c->attr.dimension)
!     return SUCCESS;
  
    if (c->attr.pointer)
      {
--- 1560,1568 ----
  	}
      }
  
    /* Check array components.  */
    if (!c->attr.dimension)
!     goto scalar;
  
    if (c->attr.pointer)
      {
*************** build_struct (const char *name, gfc_char
*** 1567,1573 ****
  	{
  	  gfc_error ("Pointer array component of structure at %C must have a "
  		     "deferred shape");
! 	  return FAILURE;
  	}
      }
    else if (c->attr.allocatable)
--- 1570,1576 ----
  	{
  	  gfc_error ("Pointer array component of structure at %C must have a "
  		     "deferred shape");
! 	  t = FAILURE;
  	}
      }
    else if (c->attr.allocatable)
*************** build_struct (const char *name, gfc_char
*** 1576,1582 ****
  	{
  	  gfc_error ("Allocatable component of structure at %C must have a "
  		     "deferred shape");
! 	  return FAILURE;
  	}
      }
    else
--- 1579,1585 ----
  	{
  	  gfc_error ("Allocatable component of structure at %C must have a "
  		     "deferred shape");
! 	  t = FAILURE;
  	}
      }
    else
*************** build_struct (const char *name, gfc_char
*** 1585,1595 ****
  	{
  	  gfc_error ("Array component of structure at %C must have an "
  		     "explicit shape");
! 	  return FAILURE;
  	}
      }
  
!   return SUCCESS;
  }
  
  
--- 1588,1602 ----
  	{
  	  gfc_error ("Array component of structure at %C must have an "
  		     "explicit shape");
! 	  t = FAILURE;
  	}
      }
  
! scalar:
!   if (c->ts.type == BT_CLASS)
!     encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
! 
!   return t;
  }
  
  
*************** gfc_match_data_decl (void)
*** 3761,3767 ****
    if (m != MATCH_YES)
      return m;
  
!   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
      {
        sym = gfc_use_derived (current_ts.u.derived);
  
--- 3768,3775 ----
    if (m != MATCH_YES)
      return m;
  
!   if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
! 	&& gfc_current_state () != COMP_DERIVED)
      {
        sym = gfc_use_derived (current_ts.u.derived);
  
*************** gfc_match_data_decl (void)
*** 3781,3787 ****
        goto cleanup;
      }
  
!   if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
        && !current_ts.u.derived->attr.zero_comp)
      {
  
--- 3789,3796 ----
        goto cleanup;
      }
  
!   if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
!       && current_ts.u.derived->components == NULL
        && !current_ts.u.derived->attr.zero_comp)
      {
  
*************** attr_decl1 (void)
*** 5694,5706 ****
  	}
      }
  
!   /* 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)
      {
!       m = MATCH_ERROR;
!       goto cleanup;
      }
  
    if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
--- 5703,5733 ----
  	}
      }
  
!   /* 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)
!     {
!       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)
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 152931)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 672,677 ****
--- 672,678 ----
    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
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 152931)
--- gcc/fortran/match.c	(working copy)
*************** gfc_match_select_type (void)
*** 4080,4085 ****
--- 4080,4086 ----
  	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
      {
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 152931)
--- gcc/fortran/parse.c	(working copy)
*************** gfc_build_block_ns (gfc_namespace *paren
*** 3069,3075 ****
  			  my_ns->proc_name->name, NULL);
        gcc_assert (t == SUCCESS);
      }
!   my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
  
    return my_ns;
  }
--- 3069,3077 ----
  			  my_ns->proc_name->name, NULL);
        gcc_assert (t == SUCCESS);
      }
! 
!   if (parent_ns->proc_name)
!     my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
  
    return my_ns;
  }
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 152931)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_fl_variable_derived (gfc_symbol 
*** 8641,8649 ****
  	}
  
        /* 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))
  	{
  	  gfc_error ("CLASS variable '%s' at %L must be dummy, allocatable "
  		     "or pointer", sym->name, &sym->declared_at);
--- 8641,8648 ----
  	}
  
        /* 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);
Index: gcc/testsuite/gfortran.dg/class_6.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_6.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_6.f03	(revision 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
Index: gcc/testsuite/gfortran.dg/class_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_7.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_7.f03	(revision 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
Index: gcc/testsuite/gfortran.dg/class_8.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_8.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_8.f03	(revision 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