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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152345 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 272 insertions, 61 deletions

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 919d5d148fc..3e969e78ca2 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -29,6 +29,10 @@ along with GCC; see the file COPYING3.  If not see
 int gfc_matching_procptr_assignment = 0;
 bool gfc_matching_prefix = false;
 
+/* Used for SELECT TYPE statements.  */
+gfc_symbol *type_selector;
+gfc_symtree *select_type_tmp;
+
 /* For debugging and diagnostic purposes.  Return the textual representation
    of the intrinsic operator OP.  */
 const char *
@@ -2245,6 +2249,39 @@ gfc_free_alloc_list (gfc_alloc *p)
 }
 
 
+/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
+   an accessible derived type.  */
+
+static match
+match_derived_type_spec (gfc_typespec *ts)
+{
+  locus old_locus; 
+  gfc_symbol *derived;
+
+  old_locus = gfc_current_locus; 
+
+  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
+    {
+      if (derived->attr.flavor == FL_DERIVED)
+	{
+	  ts->type = BT_DERIVED;
+	  ts->u.derived = derived;
+	  return MATCH_YES;
+	}
+      else
+	{
+	  /* Enforce F03:C476.  */
+	  gfc_error ("'%s' at %L is not an accessible derived type",
+		     derived->name, &gfc_current_locus);
+	  return MATCH_ERROR;
+	}
+    }
+
+  gfc_current_locus = old_locus; 
+  return MATCH_NO;
+}
+
+
 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
    It only includes the intrinsic types from the Fortran 2003 standard
@@ -2256,7 +2293,6 @@ static match
 match_type_spec (gfc_typespec *ts)
 {
   match m;
-  gfc_symbol *derived;
   locus old_locus;
 
   gfc_clear_ts (ts);
@@ -2303,43 +2339,27 @@ match_type_spec (gfc_typespec *ts)
       goto kind_selector;
     }
 
-  if (gfc_match_symbol (&derived, 1) == MATCH_YES)
+  m = match_derived_type_spec (ts);
+  if (m == MATCH_YES)
     {
-      if (derived->attr.flavor == FL_DERIVED)
-	{
-	  old_locus = gfc_current_locus;
-	  if (gfc_match (" :: ") != MATCH_YES)
-	    return MATCH_ERROR;
-	  gfc_current_locus = old_locus;
-	  ts->type = BT_DERIVED;
-	  ts->u.derived = derived;
-	  /* Enfore F03:C401.  */
-	  if (derived->attr.abstract)
-	    {
-	      gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
-			 derived->name, &old_locus);
-	      return MATCH_ERROR;
-	    }
-	  return MATCH_YES;
-	}
-      else
+      old_locus = gfc_current_locus;
+      if (gfc_match (" :: ") != MATCH_YES)
+	return MATCH_ERROR;
+      gfc_current_locus = old_locus;
+      /* Enfore F03:C401.  */
+      if (ts->u.derived->attr.abstract)
 	{
-	  if (gfc_match (" :: ") == MATCH_YES)
-	    {
-	      /* Enforce F03:C476.  */
-	      gfc_error ("'%s' at %L is not an accessible derived type",
-			 derived->name, &old_locus);
-	      return MATCH_ERROR;
-	    }
-	  else
-	    {
-	      gfc_current_locus = old_locus;
-	      return MATCH_NO;
-	    }
+	  gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
+		     ts->u.derived->name, &old_locus);
+	  return MATCH_ERROR;
 	}
+      return MATCH_YES;
     }
+  else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
+    return MATCH_ERROR;
 
-  /* If a type is not matched, simply return MATCH_NO.  */ 
+  /* If a type is not matched, simply return MATCH_NO.  */
+  gfc_current_locus = old_locus;
   return MATCH_NO;
 
 kind_selector:
@@ -2429,6 +2449,7 @@ gfc_match_allocate (void)
   gfc_alloc *head, *tail;
   gfc_expr *stat, *errmsg, *tmp, *source;
   gfc_typespec ts;
+  gfc_symbol *sym;
   match m;
   locus old_locus;
   bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
@@ -2513,19 +2534,20 @@ gfc_match_allocate (void)
 	tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
 
       /* FIXME: disable the checking on derived types and arrays.  */
+      sym = tail->expr->symtree->n.sym;
       b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
 		|| tail->expr->ref->type == REF_ARRAY));
-      b2 = tail->expr->symtree->n.sym
-	   && !(tail->expr->symtree->n.sym->attr.allocatable
-		|| tail->expr->symtree->n.sym->attr.pointer
-		|| tail->expr->symtree->n.sym->attr.proc_pointer);
-      b3 = tail->expr->symtree->n.sym
-	   && tail->expr->symtree->n.sym->ns
-	   && tail->expr->symtree->n.sym->ns->proc_name
-	   && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable
-		|| tail->expr->symtree->n.sym->ns->proc_name->attr.pointer
-		|| tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer);
+      if (sym && sym->ts.type == BT_CLASS)
+	b2 = !(sym->ts.u.derived->components->attr.allocatable
+	       || sym->ts.u.derived->components->attr.pointer);
+      else
+	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		      || sym->attr.proc_pointer);
+      b3 = sym && sym->ns && sym->ns->proc_name
+	   && (sym->ns->proc_name->attr.allocatable
+		|| sym->ns->proc_name->attr.pointer
+		|| sym->ns->proc_name->attr.proc_pointer);
       if (b1 && b2 && !b3)
 	{
 	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
@@ -2616,7 +2638,7 @@ alloc_opt_list:
 
 	  gfc_resolve_expr (tmp);
 
-	  if (head->expr->ts.type != tmp->ts.type)
+	  if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
 	    {
 	      gfc_error ("Type of entity at %L is type incompatible with "
 			 "source-expr at %L", &head->expr->where, &tmp->where);
@@ -2657,7 +2679,8 @@ alloc_opt_list:
   new_st.expr1 = stat;
   new_st.expr2 = errmsg;
   new_st.expr3 = source;
-  new_st.ext.alloc_list = head;
+  new_st.ext.alloc.list = head;
+  new_st.ext.alloc.ts = ts;
 
   return MATCH_YES;
 
@@ -2754,8 +2777,9 @@ gfc_match_deallocate (void)
 {
   gfc_alloc *head, *tail;
   gfc_expr *stat, *errmsg, *tmp;
+  gfc_symbol *sym;
   match m;
-  bool saw_stat, saw_errmsg;
+  bool saw_stat, saw_errmsg, b1, b2;
 
   head = tail = NULL;
   stat = errmsg = tmp = NULL;
@@ -2783,20 +2807,25 @@ gfc_match_deallocate (void)
       if (gfc_check_do_variable (tail->expr->symtree))
 	goto cleanup;
 
-      if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
+      sym = tail->expr->symtree->n.sym;
+
+      if (gfc_pure (NULL) && gfc_impure_variable (sym))
 	{
 	  gfc_error ("Illegal allocate-object at %C for a PURE procedure");
 	  goto cleanup;
 	}
 
       /* FIXME: disable the checking on derived types.  */
-      if (!(tail->expr->ref
+      b1 = !(tail->expr->ref
 	   && (tail->expr->ref->type == REF_COMPONENT
-	       || tail->expr->ref->type == REF_ARRAY)) 
-	  && tail->expr->symtree->n.sym
-	  && !(tail->expr->symtree->n.sym->attr.allocatable
-	       || tail->expr->symtree->n.sym->attr.pointer
-	       || tail->expr->symtree->n.sym->attr.proc_pointer))
+	       || tail->expr->ref->type == REF_ARRAY));
+      if (sym && sym->ts.type == BT_CLASS)
+	b2 = !(sym->ts.u.derived->components->attr.allocatable
+	       || sym->ts.u.derived->components->attr.pointer);
+      else
+	b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+		      || sym->attr.proc_pointer);
+      if (b1 && b2)
 	{
 	  gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
 		     "or an allocatable variable");
@@ -2865,7 +2894,7 @@ dealloc_opt_list:
   new_st.op = EXEC_DEALLOCATE;
   new_st.expr1 = stat;
   new_st.expr2 = errmsg;
-  new_st.ext.alloc_list = head;
+  new_st.ext.alloc.list = head;
 
   return MATCH_YES;
 
@@ -3021,7 +3050,8 @@ gfc_match_call (void)
 
   /* If this is a variable of derived-type, it probably starts a type-bound
      procedure call.  */
-  if (sym->attr.flavor != FL_PROCEDURE && sym->ts.type == BT_DERIVED)
+  if (sym->attr.flavor != FL_PROCEDURE
+      && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
     return match_typebound_call (st);
 
   /* If it does not seem to be callable (include functions so that the
@@ -3949,10 +3979,7 @@ match_case_eos (void)
   /* If the case construct doesn't have a case-construct-name, we
      should have matched the EOS.  */
   if (!gfc_current_block ())
-    {
-      gfc_error ("Expected the name of the SELECT CASE construct at %C");
-      return MATCH_ERROR;
-    }
+    return MATCH_NO;
 
   gfc_gobble_whitespace ();
 
@@ -3962,7 +3989,7 @@ match_case_eos (void)
 
   if (strcmp (name, gfc_current_block ()->name) != 0)
     {
-      gfc_error ("Expected case name of '%s' at %C",
+      gfc_error ("Expected block name '%s' of SELECT construct at %C",
 		 gfc_current_block ()->name);
       return MATCH_ERROR;
     }
@@ -3994,6 +4021,61 @@ gfc_match_select (void)
 }
 
 
+/* Match a SELECT TYPE statement.  */
+
+match
+gfc_match_select_type (void)
+{
+  gfc_expr *expr;
+  match m;
+
+  m = gfc_match_label ();
+  if (m == MATCH_ERROR)
+    return m;
+
+  m = gfc_match (" select type ( %e ", &expr);
+  if (m != MATCH_YES)
+    return m;
+
+  /* TODO: Implement ASSOCIATE.  */
+  m = gfc_match (" => ");
+  if (m == MATCH_YES)
+    {
+      gfc_error ("Associate-name in SELECT TYPE statement at %C "
+		 "is not yet supported");
+      return MATCH_ERROR;
+    }
+
+  m = gfc_match (" )%t");
+  if (m != MATCH_YES)
+    return m;
+
+  /* Check for F03:C811.
+     TODO: Change error message once ASSOCIATE is implemented.  */
+  if (expr->expr_type != EXPR_VARIABLE || expr->ref != NULL)
+    {
+      gfc_error ("Selector must be a named variable in SELECT TYPE statement "
+		 "at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Check for F03:C813.  */
+  if (expr->ts.type != BT_CLASS)
+    {
+      gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+		 "at %C");
+      return MATCH_ERROR;
+    }
+
+  new_st.op = EXEC_SELECT_TYPE;
+  new_st.expr1 = expr;
+
+  type_selector = expr->symtree->n.sym;
+
+  return MATCH_YES;
+}
+
+
 /* Match a CASE statement.  */
 
 match
@@ -4058,13 +4140,142 @@ gfc_match_case (void)
   return MATCH_YES;
 
 syntax:
-  gfc_error ("Syntax error in CASE-specification at %C");
+  gfc_error ("Syntax error in CASE specification at %C");
 
 cleanup:
   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
   return MATCH_ERROR;
 }
 
+
+/* Match a TYPE IS statement.  */
+
+match
+gfc_match_type_is (void)
+{
+  gfc_case *c = NULL;
+  match m;
+  char name[GFC_MAX_SYMBOL_LEN];
+
+  if (gfc_current_state () != COMP_SELECT_TYPE)
+    {
+      gfc_error ("Unexpected TYPE IS statement at %C");
+      return MATCH_ERROR;
+    }
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  c = gfc_get_case ();
+  c->where = gfc_current_locus;
+
+  /* TODO: Once unlimited polymorphism is implemented, we will need to call
+     match_type_spec here.  */
+  if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  m = match_case_eos ();
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  new_st.op = EXEC_SELECT_TYPE;
+  new_st.ext.case_list = c;
+
+  /* Create temporary variable.  */
+  sprintf (name, "tmp$%s", c->ts.u.derived->name);
+  gfc_get_sym_tree (name, gfc_current_ns, &select_type_tmp, false);
+  select_type_tmp->n.sym->ts = c->ts;
+  select_type_tmp->n.sym->attr.referenced = 1;
+  select_type_tmp->n.sym->attr.pointer = 1;
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in TYPE IS specification at %C");
+
+cleanup:
+  if (c != NULL)
+    gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
+  return MATCH_ERROR;
+}
+
+
+/* Match a CLASS IS or CLASS DEFAULT statement.  */
+
+match
+gfc_match_class_is (void)
+{
+  gfc_case *c = NULL;
+  match m;
+
+  if (gfc_current_state () != COMP_SELECT_TYPE)
+    return MATCH_NO;
+
+  if (gfc_match ("% default") == MATCH_YES)
+    {
+      m = match_case_eos ();
+      if (m == MATCH_NO)
+	goto syntax;
+      if (m == MATCH_ERROR)
+	goto cleanup;
+
+      new_st.op = EXEC_SELECT_TYPE;
+      c = gfc_get_case ();
+      c->where = gfc_current_locus;
+      c->ts.type = BT_UNKNOWN;
+      new_st.ext.case_list = c;
+      return MATCH_YES;
+    }
+
+  m = gfc_match ("% is");
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  if (gfc_match_char ('(') != MATCH_YES)
+    goto syntax;
+
+  c = gfc_get_case ();
+  c->where = gfc_current_locus;
+
+  if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
+    goto cleanup;
+
+  if (c->ts.type == BT_DERIVED)
+    c->ts.type = BT_CLASS;
+
+  if (gfc_match_char (')') != MATCH_YES)
+    goto syntax;
+
+  m = match_case_eos ();
+  if (m == MATCH_NO)
+    goto syntax;
+  if (m == MATCH_ERROR)
+    goto cleanup;
+
+  new_st.op = EXEC_SELECT_TYPE;
+  new_st.ext.case_list = c;
+
+  gfc_error_now ("CLASS IS specification at %C is not yet supported");
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in CLASS IS specification at %C");
+
+cleanup:
+  if (c != NULL)
+    gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
+  return MATCH_ERROR;
+}
+
+
 /********************* WHERE subroutines ********************/
 
 /* Match the rest of a simple WHERE statement that follows an IF statement.