re PR fortran/40996 ([F03] ALLOCATABLE scalars)

fortran/
2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* check.c (gfc_check_same_type_as): New function for checking
	SAME_TYPE_AS and EXTENDS_TYPE_OF.
	* decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class
	container, if the contained type has it. Add an initializer for the
	class container.
	(add_init_expr_to_sym): Handle BT_CLASS.
	(vindex_counter): New counter for setting vindices.
	(gfc_match_derived_decl): Set vindex for all derived types, not only
	those which are being extended.
	* expr.c (gfc_check_assign_symbol): Handle NULL initialization of class
	pointers.
	* gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and
	GFC_ISYM_EXTENDS_TYPE_OF.
	(gfc_type_is_extensible): New prototype.
	* intrinsic.h (gfc_check_same_type_as): New prototype.
	* intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF.
	* primary.c (gfc_expr_attr): Handle CLASS-valued functions.
	* resolve.c (resolve_structure_cons): Handle BT_CLASS.
	(type_is_extensible): Make non-static and rename to
	'gfc_type_is_extensible.
	(resolve_select_type): Renamed type_is_extensible.
	(resolve_class_assign): Handle NULL pointers.
	(resolve_fl_variable_derived): Renamed type_is_extensible.
	(resolve_fl_derived): Ditto.
	* trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL
	initialization of class pointer components.
	(gfc_conv_structure): Handle BT_CLASS.
	* trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of):
	New functions.
	(gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.h (type_selector, select_type_tmp): New global variables.
	* match.c (type_selector, select_type_tmp): New global variables,
	used for SELECT TYPE statements.
	(gfc_match_select_type): Better error handling. Remember selector.
	(gfc_match_type_is): Create temporary variable.
	* module.c (ab_attribute): New value 'AB_IS_CLASS'.
	(attr_bits): New string.
	(mio_symbol_attribute): Handle 'is_class'.
	* resolve.c (resolve_select_type): Insert pointer assignment statement,
	to assign temporary to selector.
	* symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary
	in SELECT TYPE statements.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* dump-parse-tree.c (show_code_node): Renamed 'alloc_list'.
	* gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'.
	(gfc_expr_to_initialize): New prototype.
	* match.c (alloc_opt_list): Correctly check type compatibility.
	Renamed 'alloc_list'.
	(dealloc_opt_list): Renamed 'alloc_list'.
	* resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize'
	and make it non-static.
	(resolve_allocate_expr): Set vindex for CLASS variables correctly.
	Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'.
	(resolve_allocate_deallocate): Renamed 'alloc_list'.
	(check_class_pointer_assign): Rename to 'resolve_class_assign'. Change
	argument type. Adjust to work with ordinary assignments.
	(resolve_code): Call 'resolve_class_assign' for ordinary assignments.
	Renamed 'check_class_pointer_assign'.
	* st.c (gfc_free_statement): Renamed 'alloc_list'.
	* trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle
	size determination and initialization of CLASS variables. Bugfix for
	ALLOCATE statements with default initialization and SOURCE block.
	(gfc_trans_deallocate): Renamed 'alloc_list'.

2009-09-30  Paul Thomas  <pault@gcc.gnu.org>

	* trans-expr.c (gfc_conv_procedure_call): Convert a derived
	type actual to a class object if the formal argument is a
	class.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40996
	* decl.c (build_struct): Handle allocatable scalar components.
	* expr.c (gfc_add_component_ref): Correctly set typespec of expression,
	after inserting component reference.
	* match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no
	variables are being used uninitialized.
	* primary.c (gfc_match_varspec): Handle CLASS array components.
	* resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to
	EXEC_SELECT.
	* trans-array.c (structure_alloc_comps,gfc_trans_deferred_array):
	Handle allocatable scalar components.
	* trans-expr.c (gfc_conv_component_ref): Ditto.
	* trans-types.c (gfc_get_derived_type): Ditto.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* decl.c (encapsulate_class_symbol): Modify names of class container
	components by prefixing with '$'.
	(gfc_match_end): Handle COMP_SELECT_TYPE.
	* expr.c (gfc_add_component_ref): Modify names of class container
	components by prefixing with '$'.
	* gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and
	ST_CLASS_IS.
	(gfc_case): New field 'ts'.
	(gfc_exec_op): Add EXEC_SELECT_TYPE.
	(gfc_type_is_extension_of): New prototype.
	* match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is):
	New prototypes.
	* match.c (match_derived_type_spec): New function.
	(match_type_spec): Use 'match_derived_type_spec'.
	(match_case_eos): Modify error message.
	(gfc_match_select_type): New function.
	(gfc_match_case): Modify error message.
	(gfc_match_type_is): New function.
	(gfc_match_class_is): Ditto.
	* parse.h (gfc_compile_state): Add COMP_SELECT_TYPE.
	* parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS
	statements.
	(next_statement): Handle ST_SELECT_TYPE.
	(gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS.
	(parse_select_type_block): New function.
	(parse_executable): Handle ST_SELECT_TYPE.
	* resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of
	class container components by prefixing with '$'.
	(resolve_allocate_expr): Ditto.
	(resolve_select_type): New function.
	(gfc_resolve_blocks): Handle EXEC_SELECT_TYPE.
	(check_class_pointer_assign): Modify names of class container
	components by prefixing with '$'.
	(resolve_code): Ditto.
	* st.c (gfc_free_statement): Ditto.
	* symbol.c (gfc_type_is_extension_of): New function.
	(gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix.
	* trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas <pault@gcc.gnu.org> 

	* check.c (gfc_check_move_alloc): Arguments don't have to be arrays.
	The second argument needs to be type-compatible with the first (not the
	other way around, which makes a difference for CLASS entities).
	* decl.c (encapsulate_class_symbol): New function.
	(build_sym,build_struct): Handle BT_CLASS, call
	'encapsulate_class_symbol'.
	(gfc_match_decl_type_spec): Remove warning, use BT_CLASS.
	(gfc_match_derived_decl): Set vindex;
	* expr.c (gfc_add_component_ref): New function.
	(gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol):
	Handle BT_CLASS.
	* dump-parse-tree.c (show_symbol): Print vindex.
	* gfortran.h (bt): New basic type BT_CLASS.
	(symbol_attribute): New field 'is_class'.
	(gfc_typespec): Remove field 'is_class'.
	(gfc_symbol): New field 'vindex'.
	(gfc_get_ultimate_derived_super_type): New prototype.
	(gfc_add_component_ref): Ditto.
	* interface.c (gfc_compare_derived_types): Pointer equality check
	moved here from gfc_compare_types.
	(gfc_compare_types): Handle BT_CLASS and use
	gfc_type_compatible.
	* match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call):
	Handle BT_CLASS.
	* misc.c (gfc_clear_ts): Removed is_class.
	(gfc_basic_typename,gfc_typename): Handle BT_CLASS.
	* module.c (bt_types,mio_typespec): Handle BT_CLASS.
	(mio_symbol): Handle vindex.
	* primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS.
	* resolve.c (find_array_spec,check_typebound_baseobject):
	Handle BT_CLASS.
	(resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp'
	inside 'gcc_assert'.
	(resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS.
	(check_class_pointer_assign): New function.
	(resolve_code): Handle BT_CLASS, call check_class_pointer_assign.
	(resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived,
	resolve_fl_variable): Handle BT_CLASS.
	(check_generic_tbp_ambiguity): Add special case.
	(resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS.
	* symbol.c (gfc_get_ultimate_derived_super_type): New function.
	(gfc_type_compatible): Handle BT_CLASS.
	* trans-expr.c (conv_parent_component_references): Handle CLASS
	containers.
	(gfc_conv_initializer): Handle BT_CLASS.
	* trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type):
	Handle BT_CLASS.

testsuite/
2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/same_type_as_1.f03: New test.
	* gfortran.dg/same_type_as_2.f03: Ditto.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/select_type_1.f03: Extended.
	* gfortran.dg/select_type_3.f03: New test.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/class_allocate_1.f03: New test.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/40996
	* gfortran.dg/allocatable_scalar_3.f90: New test.
	* gfortran.dg/select_type_2.f03: Ditto.
	* gfortran.dg/typebound_proc_5.f03: Changed error messages.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/block_name_2.f90: Modified error message.
	* gfortran.dg/select_6.f90: Ditto.
	* gfortran.dg/select_type_1.f03: New test.

2009-09-30  Janus Weil  <janus@gcc.gnu.org>

	* gfortran.dg/allocate_derived_1.f90: Remove -w option.
	* gfortran.dg/class_1.f03: Ditto.
	* gfortran.dg/class_2.f03: Ditto.
	* gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto.
	* gfortran.dg/typebound_call_10.f03: Ditto.
	* gfortran.dg/typebound_call_2.f03: Ditto.
	* gfortran.dg/typebound_call_3.f03: Ditto.
	* gfortran.dg/typebound_call_4.f03: Ditto.
	* gfortran.dg/typebound_call_9.f03: Ditto.
	* gfortran.dg/typebound_generic_3.f03: Ditto.
	* gfortran.dg/typebound_generic_4.f03: Ditto.
	* gfortran.dg/typebound_operator_1.f03: Ditto.
	* gfortran.dg/typebound_operator_2.f03: Ditto.
	* gfortran.dg/typebound_operator_3.f03: Ditto.
	* gfortran.dg/typebound_operator_4.f03: Ditto.
	* gfortran.dg/typebound_proc_1.f08: Ditto.
	* gfortran.dg/typebound_proc_5.f03: Ditto.
	* gfortran.dg/typebound_proc_6.f03: Ditto.

From-SVN: r152345

1 files changed, 303 insertions, 69 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3eec50e..445753e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -879,7 +879,10 @@ resolve_structure_cons (gfc_expr *expr)
 
       if (cons->expr->expr_type == EXPR_NULL
 	  && !(comp->attr.pointer || comp->attr.allocatable
-	       || comp->attr.proc_pointer))
+	       || comp->attr.proc_pointer
+	       || (comp->ts.type == BT_CLASS
+		   && (comp->ts.u.derived->components->attr.pointer
+		       || comp->ts.u.derived->components->attr.allocatable))))
 	{
 	  t = FAILURE;
 	  gfc_error ("The NULL in the derived type constructor at %L is "
@@ -3931,7 +3934,10 @@ find_array_spec (gfc_expr *e)
   gfc_symbol *derived;
   gfc_ref *ref;
 
-  as = e->symtree->n.sym->as;
+  if (e->symtree->n.sym->ts.type == BT_CLASS)
+    as = e->symtree->n.sym->ts.u.derived->components->as;
+  else
+    as = e->symtree->n.sym->as;
   derived = NULL;
 
   for (ref = e->ref; ref; ref = ref->next)
@@ -4844,7 +4850,7 @@ check_typebound_baseobject (gfc_expr* e)
   if (!base)
     return FAILURE;
 
-  gcc_assert (base->ts.type == BT_DERIVED);
+  gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
   if (base->ts.u.derived->attr.abstract)
     {
       gfc_error ("Base object for type-bound procedure call at %L is of"
@@ -5051,7 +5057,10 @@ static gfc_try
 resolve_ppc_call (gfc_code* c)
 {
   gfc_component *comp;
-  gcc_assert (gfc_is_proc_ptr_comp (c->expr1, &comp));
+  bool b;
+
+  b = gfc_is_proc_ptr_comp (c->expr1, &comp);
+  gcc_assert (b);
 
   c->resolved_sym = c->expr1->symtree->n.sym;
   c->expr1->expr_type = EXPR_VARIABLE;
@@ -5083,7 +5092,10 @@ static gfc_try
 resolve_expr_ppc (gfc_expr* e)
 {
   gfc_component *comp;
-  gcc_assert (gfc_is_proc_ptr_comp (e, &comp));
+  bool b;
+
+  b = gfc_is_proc_ptr_comp (e, &comp);
+  gcc_assert (b);
 
   /* Convert to EXPR_FUNCTION.  */
   e->expr_type = EXPR_FUNCTION;
@@ -5462,6 +5474,8 @@ resolve_deallocate_expr (gfc_expr *e)
   symbol_attribute attr;
   int allocatable, pointer, check_intent_in;
   gfc_ref *ref;
+  gfc_symbol *sym;
+  gfc_component *c;
 
   /* Check INTENT(IN), unless the object is a sub-component of a pointer.  */
   check_intent_in = 1;
@@ -5472,8 +5486,18 @@ resolve_deallocate_expr (gfc_expr *e)
   if (e->expr_type != EXPR_VARIABLE)
     goto bad;
 
-  allocatable = e->symtree->n.sym->attr.allocatable;
-  pointer = e->symtree->n.sym->attr.pointer;
+  sym = e->symtree->n.sym;
+
+  if (sym->ts.type == BT_CLASS)
+    {
+      allocatable = sym->ts.u.derived->components->attr.allocatable;
+      pointer = sym->ts.u.derived->components->attr.pointer;
+    }
+  else
+    {
+      allocatable = sym->attr.allocatable;
+      pointer = sym->attr.pointer;
+    }
   for (ref = e->ref; ref; ref = ref->next)
     {
       if (pointer)
@@ -5487,9 +5511,17 @@ resolve_deallocate_expr (gfc_expr *e)
 	  break;
 
 	case REF_COMPONENT:
-	  allocatable = (ref->u.c.component->as != NULL
-			 && ref->u.c.component->as->type == AS_DEFERRED);
-	  pointer = ref->u.c.component->attr.pointer;
+	  c = ref->u.c.component;
+	  if (c->ts.type == BT_CLASS)
+	    {
+	      allocatable = c->ts.u.derived->components->attr.allocatable;
+	      pointer = c->ts.u.derived->components->attr.pointer;
+	    }
+	  else
+	    {
+	      allocatable = c->attr.allocatable;
+	      pointer = c->attr.pointer;
+	    }
 	  break;
 
 	case REF_SUBSTRING:
@@ -5507,14 +5539,19 @@ resolve_deallocate_expr (gfc_expr *e)
 		 &e->where);
     }
 
-  if (check_intent_in
-      && e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in && sym->attr.intent == INTENT_IN)
     {
       gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
-		 e->symtree->n.sym->name, &e->where);
+		 sym->name, &e->where);
       return FAILURE;
     }
 
+  if (e->ts.type == BT_CLASS)
+    {
+      /* Only deallocate the DATA component.  */
+      gfc_add_component_ref (e, "$data");
+    }
+
   return SUCCESS;
 }
 
@@ -5541,8 +5578,8 @@ gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e)
    derived types with default initializers, and derived types with allocatable
    components that need nullification.)  */
 
-static gfc_expr *
-expr_to_initialize (gfc_expr *e)
+gfc_expr *
+gfc_expr_to_initialize (gfc_expr *e)
 {
   gfc_expr *result;
   gfc_ref *ref;
@@ -5579,9 +5616,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
   gfc_ref *ref, *ref2;
   gfc_array_ref *ar;
   gfc_code *init_st;
-  gfc_expr *init_e;
   gfc_symbol *sym;
   gfc_alloc *a;
+  gfc_component *c;
 
   /* Check INTENT(IN), unless the object is a sub-component of a pointer.  */
   check_intent_in = 1;
@@ -5593,6 +5630,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
      pointer, the next-to-last reference must be a pointer.  */
 
   ref2 = NULL;
+  if (e->symtree)
+    sym = e->symtree->n.sym;
 
   if (e->expr_type != EXPR_VARIABLE)
     {
@@ -5603,9 +5642,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
     }
   else
     {
-      allocatable = e->symtree->n.sym->attr.allocatable;
-      pointer = e->symtree->n.sym->attr.pointer;
-      dimension = e->symtree->n.sym->attr.dimension;
+      if (sym->ts.type == BT_CLASS)
+	{
+	  allocatable = sym->ts.u.derived->components->attr.allocatable;
+	  pointer = sym->ts.u.derived->components->attr.pointer;
+	  dimension = sym->ts.u.derived->components->attr.dimension;
+	}
+      else
+	{
+	  allocatable = sym->attr.allocatable;
+	  pointer = sym->attr.pointer;
+	  dimension = sym->attr.dimension;
+	}
 
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
 	{
@@ -5620,11 +5668,19 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 		break;
 
 	      case REF_COMPONENT:
-		allocatable = (ref->u.c.component->as != NULL
-			       && ref->u.c.component->as->type == AS_DEFERRED);
-
-		pointer = ref->u.c.component->attr.pointer;
-		dimension = ref->u.c.component->attr.dimension;
+		c = ref->u.c.component;
+		if (c->ts.type == BT_CLASS)
+		  {
+		    allocatable = c->ts.u.derived->components->attr.allocatable;
+		    pointer = c->ts.u.derived->components->attr.pointer;
+		    dimension = c->ts.u.derived->components->attr.dimension;
+		  }
+		else
+		  {
+		    allocatable = c->attr.allocatable;
+		    pointer = c->attr.pointer;
+		    dimension = c->attr.dimension;
+		  }
 		break;
 
 	      case REF_SUBSTRING:
@@ -5642,24 +5698,46 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       return FAILURE;
     }
 
-  if (check_intent_in
-      && e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in && sym->attr.intent == INTENT_IN)
     {
       gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
-		 e->symtree->n.sym->name, &e->where);
+		 sym->name, &e->where);
       return FAILURE;
     }
 
-  /* Add default initializer for those derived types that need them.  */
-  if (e->ts.type == BT_DERIVED && (init_e = gfc_default_initializer (&e->ts)))
+  if (e->ts.type == BT_CLASS)
     {
+      /* Initialize VINDEX for CLASS objects.  */
       init_st = gfc_get_code ();
       init_st->loc = code->loc;
-      init_st->op = EXEC_INIT_ASSIGN;
-      init_st->expr1 = expr_to_initialize (e);
-      init_st->expr2 = init_e;
+      init_st->expr1 = gfc_expr_to_initialize (e);
+      init_st->op = EXEC_ASSIGN;
+      gfc_add_component_ref (init_st->expr1, "$vindex");
+      if (code->expr3 && code->expr3->ts.type == BT_CLASS)
+	{
+	  /* vindex must be determined at run time.  */
+	  init_st->expr2 = gfc_copy_expr (code->expr3);
+	  gfc_add_component_ref (init_st->expr2, "$vindex");
+	}
+      else
+	{
+	  /* vindex is fixed at compile time.  */
+	  int vindex;
+	  if (code->expr3)
+	    vindex = code->expr3->ts.u.derived->vindex;
+	  else if (code->ext.alloc.ts.type == BT_DERIVED)
+	    vindex = code->ext.alloc.ts.u.derived->vindex;
+	  else if (e->ts.type == BT_CLASS)
+	    vindex = e->ts.u.derived->components->ts.u.derived->vindex;
+	  else
+	    vindex = e->ts.u.derived->vindex;
+	  init_st->expr2 = gfc_int_expr (vindex);
+	}
+      init_st->expr2->where = init_st->expr1->where = init_st->loc;
       init_st->next = code->next;
       code->next = init_st;
+      /* Only allocate the DATA component.  */
+      gfc_add_component_ref (e, "$data");
     }
 
   if (pointer || dimension == 0)
@@ -5706,7 +5784,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 
 check_symbols:
 
-      for (a = code->ext.alloc_list; a; a = a->next)
+      for (a = code->ext.alloc.list; a; a = a->next)
 	{
 	  sym = a->expr->symtree->n.sym;
 
@@ -5758,7 +5836,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 	gfc_error ("Stat-variable at %L must be a scalar INTEGER "
 		   "variable", &stat->where);
 
-      for (p = code->ext.alloc_list; p; p = p->next)
+      for (p = code->ext.alloc.list; p; p = p->next)
 	if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
 	  gfc_error ("Stat-variable at %L shall not be %sd within "
 		     "the same %s statement", &stat->where, fcn, fcn);
@@ -5787,7 +5865,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 	gfc_error ("Errmsg-variable at %L must be a scalar CHARACTER "
 		   "variable", &errmsg->where);
 
-      for (p = code->ext.alloc_list; p; p = p->next)
+      for (p = code->ext.alloc.list; p; p = p->next)
 	if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
 	  gfc_error ("Errmsg-variable at %L shall not be %sd within "
 		     "the same %s statement", &errmsg->where, fcn, fcn);
@@ -5795,7 +5873,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 
   /* Check that an allocate-object appears only once in the statement.  
      FIXME: Checking derived types is disabled.  */
-  for (p = code->ext.alloc_list; p; p = p->next)
+  for (p = code->ext.alloc.list; p; p = p->next)
     {
       pe = p->expr;
       if ((pe->ref && pe->ref->type != REF_COMPONENT)
@@ -5815,12 +5893,12 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 
   if (strcmp (fcn, "ALLOCATE") == 0)
     {
-      for (a = code->ext.alloc_list; a; a = a->next)
+      for (a = code->ext.alloc.list; a; a = a->next)
 	resolve_allocate_expr (a->expr, code);
     }
   else
     {
-      for (a = code->ext.alloc_list; a; a = a->next)
+      for (a = code->ext.alloc.list; a; a = a->next)
 	resolve_deallocate_expr (a->expr);
     }
 }
@@ -6346,6 +6424,116 @@ resolve_select (gfc_code *code)
 }
 
 
+/* Check if a derived type is extensible.  */
+
+bool
+gfc_type_is_extensible (gfc_symbol *sym)
+{
+  return !(sym->attr.is_bind_c || sym->attr.sequence);
+}
+
+
+/* Resolve a SELECT TYPE statement.  */
+
+static void
+resolve_select_type (gfc_code *code)
+{
+  gfc_symbol *selector_type;
+  gfc_code *body, *new_st;
+  gfc_case *c, *default_case;
+  gfc_symtree *st;
+  char name[GFC_MAX_SYMBOL_LEN];
+
+  selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+
+  /* Assume there is no DEFAULT case.  */
+  default_case = NULL;
+
+  /* Loop over TYPE IS / CLASS IS cases.  */
+  for (body = code->block; body; body = body->block)
+    {
+      c = body->ext.case_list;
+
+      /* Check F03:C815.  */
+      if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	  && !gfc_type_is_extensible (c->ts.u.derived))
+	{
+	  gfc_error ("Derived type '%s' at %L must be extensible",
+		     c->ts.u.derived->name, &c->where);
+	  continue;
+	}
+
+      /* Check F03:C816.  */
+      if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+	  && !gfc_type_is_extension_of (selector_type, c->ts.u.derived))
+	{
+	  gfc_error ("Derived type '%s' at %L must be an extension of '%s'",
+		     c->ts.u.derived->name, &c->where, selector_type->name);
+	  continue;
+	}
+
+      /* Intercept the DEFAULT case.  */
+      if (c->ts.type == BT_UNKNOWN)
+	{
+	  /* Check F03:C818.  */
+	  if (default_case != NULL)
+	    gfc_error ("The DEFAULT CASE at %L cannot be followed "
+		       "by a second DEFAULT CASE at %L",
+		       &default_case->where, &c->where);
+	  else
+	    default_case = c;
+	  continue;
+	}
+    }
+
+  /* Transform to EXEC_SELECT.  */
+  code->op = EXEC_SELECT;
+  gfc_add_component_ref (code->expr1, "$vindex");
+
+  /* Loop over TYPE IS / CLASS IS cases.  */
+  for (body = code->block; body; body = body->block)
+    {
+      c = body->ext.case_list;
+      if (c->ts.type == BT_DERIVED)
+	c->low = c->high = gfc_int_expr (c->ts.u.derived->vindex);
+      else if (c->ts.type == BT_CLASS)
+	/* Currently IS CLASS blocks are simply ignored.
+	   TODO: Implement IS CLASS.  */
+	c->unreachable = 1;
+
+      if (c->ts.type != BT_DERIVED)
+	continue;
+      /* Assign temporary to selector.  */
+      sprintf (name, "tmp$%s", c->ts.u.derived->name);
+      st = gfc_find_symtree (code->expr1->symtree->n.sym->ns->sym_root, name);
+      new_st = gfc_get_code ();
+      new_st->op = EXEC_POINTER_ASSIGN;
+      new_st->expr1 = gfc_get_variable_expr (st);
+      new_st->expr2 = gfc_get_variable_expr (code->expr1->symtree);
+      gfc_add_component_ref (new_st->expr2, "$data");
+      new_st->next = body->next;
+      body->next = new_st;
+    }
+
+  /* Eliminate dead blocks.  */
+  for (body = code; body && body->block; body = body->block)
+    {
+      if (body->block->ext.case_list->unreachable)
+	{
+	  /* Cut the unreachable block from the code chain.  */
+	  gfc_code *cd = body->block;
+	  body->block = cd->block;
+	  /* Kill the dead block, but not the blocks below it.  */
+	  cd->block = NULL;
+	  gfc_free_statements (cd);
+	}
+    }
+
+  resolve_select (code);
+
+}
+
+
 /* Resolve a transfer statement. This is making sure that:
    -- a derived type being transferred has only non-pointer components
    -- a derived type being transferred doesn't have private components, unless 
@@ -6911,6 +7099,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 	  break;
 
 	case EXEC_SELECT:
+	case EXEC_SELECT_TYPE:
 	case EXEC_FORALL:
 	case EXEC_DO:
 	case EXEC_DO_WHILE:
@@ -7102,6 +7291,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 }
 
 
+/* Check an assignment to a CLASS object (pointer or ordinary assignment).  */
+
+static void
+resolve_class_assign (gfc_code *code)
+{
+  gfc_code *assign_code = gfc_get_code ();
+
+  /* Insert an additional assignment which sets the vindex.  */
+  assign_code->next = code->next;
+  code->next = assign_code;
+  assign_code->op = EXEC_ASSIGN;
+  assign_code->expr1 = gfc_copy_expr (code->expr1);
+  gfc_add_component_ref (assign_code->expr1, "$vindex");
+  if (code->expr2->ts.type == BT_DERIVED)
+    /* vindex is constant, determined at compile time.  */
+    assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex);
+  else if (code->expr2->ts.type == BT_CLASS)
+    {
+      /* vindex must be determined at run time.  */
+      assign_code->expr2 = gfc_copy_expr (code->expr2);
+      gfc_add_component_ref (assign_code->expr2, "$vindex");
+    }
+  else if (code->expr2->expr_type == EXPR_NULL)
+    assign_code->expr2 = gfc_int_expr (0);
+  else
+    gcc_unreachable ();
+
+  /* Modify the actual pointer assignment.  */
+  gfc_add_component_ref (code->expr1, "$data");
+  if (code->expr2->ts.type == BT_CLASS)
+    gfc_add_component_ref (code->expr2, "$data");
+}
+
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -7224,6 +7447,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
+	  if (code->expr1->ts.type == BT_CLASS)
+	    resolve_class_assign (code);
+
 	  if (resolve_ordinary_assign (code, ns))
 	    {
 	      if (code->op == EXEC_COMPCALL)
@@ -7252,7 +7478,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
+	  if (code->expr1->ts.type == BT_CLASS)
+	    resolve_class_assign (code);
+
 	  gfc_check_pointer_assign (code->expr1, code->expr2);
+
 	  break;
 
 	case EXEC_ARITHMETIC_IF:
@@ -7295,6 +7525,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  resolve_select (code);
 	  break;
 
+	case EXEC_SELECT_TYPE:
+	  resolve_select_type (code);
+	  break;
+
 	case EXEC_BLOCK:
 	  gfc_resolve (code->ext.ns);
 	  break;
@@ -8023,8 +8257,8 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
     }
   else
     {
-      if (!mp_flag && !sym->attr.allocatable
-	  && !sym->attr.pointer && !sym->attr.dummy)
+      if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
+	  && !sym->attr.dummy && sym->ts.type != BT_CLASS)
 	{
 	  gfc_error ("Array '%s' at %L cannot have a deferred shape",
 		     sym->name, &sym->declared_at);
@@ -8035,22 +8269,13 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
 }
 
 
-/* Check if a derived type is extensible.  */
-
-static bool
-type_is_extensible (gfc_symbol *sym)
-{
-  return !(sym->attr.is_bind_c || sym->attr.sequence);
-}
-
-
 /* Additional checks for symbols with flavor variable and derived
    type.  To be called from resolve_fl_variable.  */
 
 static gfc_try
 resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
 {
-  gcc_assert (sym->ts.type == BT_DERIVED);
+  gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS);
 
   /* Check to see if a derived type is blocked from being host
      associated by the presence of another class I symbol in the same
@@ -8092,10 +8317,10 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
       return FAILURE;
     }
 
-  if (sym->ts.is_class)
+  if (sym->ts.type == BT_CLASS)
     {
       /* C502.  */
-      if (!type_is_extensible (sym->ts.u.derived))
+      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->name, sym->name, &sym->declared_at);
@@ -8103,7 +8328,9 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
 	}
 
       /* C509.  */
-      if (!(sym->attr.dummy || sym->attr.allocatable || sym->attr.pointer))
+      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);
@@ -8244,7 +8471,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
     }
 
 no_init_error:
-  if (sym->ts.type == BT_DERIVED)
+  if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
     return resolve_fl_variable_derived (sym, no_init_flag);
 
   return SUCCESS;
@@ -8890,6 +9117,9 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
   sym1 = t1->specific->u.specific->n.sym;
   sym2 = t2->specific->u.specific->n.sym;
 
+  if (sym1 == sym2)
+    return SUCCESS;
+
   /* Both must be SUBROUTINEs or both must be FUNCTIONs.  */
   if (sym1->attr.subroutine != sym2->attr.subroutine
       || sym1->attr.function != sym2->attr.function)
@@ -9283,21 +9513,22 @@ resolve_typebound_procedure (gfc_symtree* stree)
 
       /* Now check that the argument-type matches.  */
       gcc_assert (me_arg);
-      if (me_arg->ts.type != BT_DERIVED
-	  || me_arg->ts.u.derived != resolve_bindings_derived)
+      if (me_arg->ts.type != BT_CLASS)
 	{
-	  gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
-		     " the derived-type '%s'", me_arg->name, proc->name,
-		     me_arg->name, &where, resolve_bindings_derived->name);
+	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
+		     " at %L", proc->name, &where);
 	  goto error;
 	}
 
-      if (!me_arg->ts.is_class)
+      if (me_arg->ts.u.derived->components->ts.u.derived
+	  != resolve_bindings_derived)
 	{
-	  gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
-		     " at %L", proc->name, &where);
+	  gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+		     " the derived-type '%s'", me_arg->name, proc->name,
+		     me_arg->name, &where, resolve_bindings_derived->name);
 	  goto error;
 	}
+
     }
 
   /* If we are extending some type, check that we don't override a procedure
@@ -9475,7 +9706,7 @@ resolve_fl_derived (gfc_symbol *sym)
     return FAILURE;
 
   /* An ABSTRACT type must be extensible.  */
-  if (sym->attr.abstract && !type_is_extensible (sym))
+  if (sym->attr.abstract && !gfc_type_is_extensible (sym))
     {
       gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
 		 sym->name, &sym->declared_at);
@@ -9611,8 +9842,10 @@ resolve_fl_derived (gfc_symbol *sym)
 
 	  /* Now check that the argument-type matches.  */
 	  gcc_assert (me_arg);
-	  if (me_arg->ts.type != BT_DERIVED
-	      || me_arg->ts.u.derived != sym)
+	  if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
+	      || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
+	      || (me_arg->ts.type == BT_CLASS
+		  && me_arg->ts.u.derived->components->ts.u.derived != sym))
 	    {
 	      gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
 			 " the derived type '%s'", me_arg->name, c->name,
@@ -9649,9 +9882,9 @@ resolve_fl_derived (gfc_symbol *sym)
 	      return FAILURE;
 	    }
 
-	  if (type_is_extensible (sym) && !me_arg->ts.is_class)
+	  if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
 	    gfc_error ("Non-polymorphic passed-object dummy argument of '%s'"
-			 " at %L", c->name, &c->loc);
+		       " at %L", c->name, &c->loc);
 
 	}
 
@@ -9720,8 +9953,9 @@ resolve_fl_derived (gfc_symbol *sym)
 	}
 
       /* C437.  */
-      if (c->ts.type == BT_DERIVED && c->ts.is_class
-	  && !(c->attr.pointer || c->attr.allocatable))
+      if (c->ts.type == BT_CLASS
+	  && !(c->ts.u.derived->components->attr.pointer
+	       || c->ts.u.derived->components->attr.allocatable))
 	{
 	  gfc_error ("Component '%s' with CLASS at %L must be allocatable "
 		     "or pointer", c->name, &c->loc);