2009-10-09 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 152583 after the LTO merge
	inside trunk.

	[during merge with trunk 152583 the version information from GCC
	is used, not the checksum of the executable!]
	* gcc/melt-runtime.h (melt_gccversionstr): added extern declaration.
	* gcc/melt-runtime.c: Moved the #include before everything else.
	Updated comment NOTE about gengtype - which is now compatible
	with the trunk's.
	(melt_gccversionstr): added declaration.
	(load_checked_dynamic_module_index): use a gcc version string in
	modules, not a checksum of the executable.
	(melt_really_initialize): get a second argument for the gcc
	version string. Initialize melt_gccversionstr with it.
	(plugin_init): Build the gccversionstr out of gcc_version
	structure.
	(melt_initialize): calls melt_really_initialize with
	version_string.
	(melt_output_cfile_decl_impl): generates a genversionstr_melt
	instead of a genchecksum_melt.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@152591 138bc75d-0d04-0410-961f-82ee72b054a4

14 files changed, 710 insertions, 94 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 55386acffe0..9fac2a77322 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,81 @@
+2009-10-07  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
+
+	* arith.c (arith_power): Use mpc_pow_z.
+	* gfortran.h (HAVE_mpc_pow_z): Define.
+
+2009-10-07  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41615
+	* resolve.c (resolve_contained_fntype): Clarify error message for
+	invalid assumed-length character result on module procedures.
+
+2009-10-07  Janus Weil  <janus@gcc.gnu.org>
+
+	* expr.c (gfc_check_pointer_assign): Do the correct type checking when
+	CLASS variables are involved.
+	* match.c (gfc_match_select_type): Parse associate-name in SELECT TYPE
+	statements, and set up a local namespace for the SELECT TYPE block.
+	* parse.h (gfc_build_block_ns): New prototype.
+	* parse.c (parse_select_type_block): Return from local namespace to its
+	parent after SELECT TYPE block.
+	(gfc_build_block_ns): New function for setting up the local namespace
+	for a BLOCK construct.
+	(parse_block_construct): Use gfc_build_block_ns.
+	* resolve.c (resolve_select_type): Insert assignment for the selector
+	variable, in case an associate-name is given, and put the SELECT TYPE
+	statement inside a BLOCK.
+	(resolve_code): Call resolve_class_assign after checking the assignment.
+	* symbol.c (gfc_find_sym_tree): Moved some code here from
+	gfc_get_ha_sym_tree.
+	(gfc_get_ha_sym_tree): Moved some code to gfc_find_sym_tree.
+
+2009-10-07  Paul Thomas <pault@gcc.gnu.org>
+
+        PR fortran/41613
+        * resolve.c (check_class_members): Reset compcall.assign.
+
+2009-10-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (select_class_proc): New function.
+	(conv_function_val): Deal with class methods and call above.
+	* symbol.c (gfc_type_compatible): Treat case where both ts1 and
+	ts2 are BT_CLASS.
+	gfortran.h : Add structure gfc_class_esym_list and include in
+	the structure gfc_expr.
+	* module.c (load_derived_extensions): New function.
+	(read_module): Call above.
+	(write_dt_extensions): New function.
+	(write_derived_extensions): New function.
+	(write_module): Use the above.
+	* resolve.c (resolve_typebound_call): Add a function expression
+	for class methods.  This carries the chain of symbols for the
+	dynamic dispatch in select_class_proc.
+	(resolve_compcall): Add second, boolean argument to indicate if
+	a function is being handled.
+	(check_members): New function.
+	(check_class_members): New function.
+	(resolve_class_compcall): New function.
+	(resolve_class_typebound_call): New function.
+	(gfc_resolve_expr): Call above for component calls.. 
+
+2009-10-05  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/41403
+	* trans-stmt.c (gfc_trans_goto): Ignore statement list on assigned goto
+	if it is present.
+
+2009-10-03  Richard Guenther  <rguenther@suse.de>
+
+	* options.c (gfc_post_options): Handle -flto and -fwhopr.
+
+2009-10-02  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/41479
+	* trans-decl.c (gfc_init_default_dt): Check for presence of
+	the argument only if it is optional or in entry master.
+	(init_intent_out_dt): Ditto; call gfc_init_default_dt
+	for all derived types with initializers.
+
 2009-10-01  Kaveh R. Ghazi  <ghazi@caip.rutgers.edu>
 
 	PR fortran/33197
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index dddf7e003ce..82a43ad7178 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -1111,7 +1111,10 @@ arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
 
 	    case BT_COMPLEX:
 	      {
-#ifdef HAVE_mpc_pow
+#ifdef HAVE_mpc_pow_z
+		mpc_pow_z (result->value.complex, op1->value.complex,
+			   op2->value.integer, GFC_MPC_RND_MODE);
+#elif defined(HAVE_mpc_pow)
 		mpc_t apower;
 		gfc_set_model (mpc_realref (op1->value.complex));
 		mpc_init2 (apower, mpfr_get_default_prec());
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 32aa68265bb..cbd3172b454 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3277,8 +3277,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return SUCCESS;
     }
 
-  if (lvalue->ts.type != BT_CLASS && lvalue->symtree->n.sym->ts.type != BT_CLASS
-	&& !gfc_compare_types (&lvalue->ts, &rvalue->ts))
+  if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
       gfc_error ("Different types in pointer assignment at %L; attempted "
 		 "assignment of %s to %s", &lvalue->where, 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b40f01ba4bf..d6ad992dda7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1594,6 +1594,17 @@ typedef struct gfc_intrinsic_sym
 gfc_intrinsic_sym;
 
 
+typedef struct gfc_class_esym_list
+{
+  gfc_symbol *derived;
+  gfc_symbol *esym;
+  gfc_symbol *class_object;
+  struct gfc_class_esym_list *next;
+}
+gfc_class_esym_list;
+
+#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
+
 /* Expression nodes.  The expression node types deserve explanations,
    since the last couple can be easily misconstrued:
 
@@ -1618,6 +1629,7 @@ gfc_intrinsic_sym;
 # endif
 # if MPC_VERSION >= MPC_VERSION_NUM(0,7,1)
 #  define HAVE_mpc_arc
+#  define HAVE_mpc_pow_z
 # endif
 #else
 #define mpc_realref(X) ((X).r)
@@ -1705,6 +1717,7 @@ typedef struct gfc_expr
       const char *name;	/* Points to the ultimate name of the function */
       gfc_intrinsic_sym *isym;
       gfc_symbol *esym;
+      gfc_class_esym_list *class_esym;
     }
     function;
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 3e969e78ca2..d2c3ef021f4 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4026,41 +4026,51 @@ gfc_match_select (void)
 match
 gfc_match_select_type (void)
 {
-  gfc_expr *expr;
+  gfc_expr *expr1, *expr2 = NULL;
   match m;
+  char name[GFC_MAX_SYMBOL_LEN];
 
   m = gfc_match_label ();
   if (m == MATCH_ERROR)
     return m;
 
-  m = gfc_match (" select type ( %e ", &expr);
+  m = gfc_match (" select type ( ");
   if (m != MATCH_YES)
     return m;
 
-  /* TODO: Implement ASSOCIATE.  */
-  m = gfc_match (" => ");
+  gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
+
+  m = gfc_match (" %n => %e", name, &expr2);
   if (m == MATCH_YES)
     {
-      gfc_error ("Associate-name in SELECT TYPE statement at %C "
-		 "is not yet supported");
-      return MATCH_ERROR;
+      expr1 = gfc_get_expr();
+      expr1->expr_type = EXPR_VARIABLE;
+      if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+	return MATCH_ERROR;
+      expr1->symtree->n.sym->ts = expr2->ts;
+      expr1->symtree->n.sym->attr.referenced = 1;
+    }
+  else
+    {
+      m = gfc_match (" %e ", &expr1);
+      if (m != MATCH_YES)
+	return m;
     }
 
   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)
+  /* Check for F03:C811.  */
+  if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
     {
-      gfc_error ("Selector must be a named variable in SELECT TYPE statement "
-		 "at %C");
+      gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
+		 "use associate-name=>");
       return MATCH_ERROR;
     }
 
   /* Check for F03:C813.  */
-  if (expr->ts.type != BT_CLASS)
+  if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
     {
       gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
 		 "at %C");
@@ -4068,9 +4078,11 @@ gfc_match_select_type (void)
     }
 
   new_st.op = EXEC_SELECT_TYPE;
-  new_st.expr1 = expr;
+  new_st.expr1 = expr1;
+  new_st.expr2 = expr2;
+  new_st.ext.ns = gfc_current_ns;
 
-  type_selector = expr->symtree->n.sym;
+  type_selector = expr1->symtree->n.sym;
 
   return MATCH_YES;
 }
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1769eada5fe..2112d3e82b1 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3972,6 +3972,61 @@ load_equiv (void)
 }
 
 
+/* This function loads the sym_root of f2k_derived with the extensions to
+   the derived type.  */
+static void
+load_derived_extensions (void)
+{
+  int symbol, nuse, j;
+  gfc_symbol *derived;
+  gfc_symbol *dt;
+  gfc_symtree *st;
+  pointer_info *info;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char module[GFC_MAX_SYMBOL_LEN + 1];
+  const char *p;
+
+  mio_lparen ();
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      mio_lparen ();
+      mio_integer (&symbol);
+      info = get_integer (symbol);
+      derived = info->u.rsym.sym;
+
+      gcc_assert (derived->attr.flavor == FL_DERIVED);
+      if (derived->f2k_derived == NULL)
+	derived->f2k_derived = gfc_get_namespace (NULL, 0);
+
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  mio_lparen ();
+	  mio_internal_string (name);
+	  mio_internal_string (module);
+
+          /* Only use one use name to find the symbol.  */
+	  nuse = number_use_names (name, false);
+	  j = 1;
+	  p = find_use_name_n (name, &j, false);
+	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+	  dt = st->n.sym;
+	  st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+	  if (st == NULL)
+	    {
+	      /* Only use the real name in f2k_derived to ensure a single
+		 symtree.  */
+	      st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
+	      st->n.sym = dt;
+	      st->n.sym->refs++;
+	    }
+	  mio_rparen ();
+	}
+      mio_rparen ();
+    }
+  mio_rparen ();
+}
+
+
 /* Recursive function to traverse the pointer_info tree and load a
    needed symbol.  We return nonzero if we load a symbol and stop the
    traversal, because the act of loading can alter the tree.  */
@@ -4113,7 +4168,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
 static void
 read_module (void)
 {
-  module_locus operator_interfaces, user_operators;
+  module_locus operator_interfaces, user_operators, extensions;
   const char *p;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   int i;
@@ -4130,10 +4185,13 @@ read_module (void)
   skip_list ();
   skip_list ();
 
-  /* Skip commons and equivalences for now.  */
+  /* Skip commons, equivalences and derived type extensions for now.  */
   skip_list ();
   skip_list ();
 
+  get_module_locus (&extensions);
+  skip_list ();
+
   mio_lparen ();
 
   /* Create the fixup nodes for all the symbols.  */
@@ -4386,6 +4444,11 @@ read_module (void)
 
   gfc_check_interfaces (gfc_current_ns);
 
+  /* Now we should be in a position to fill f2k_derived with derived type
+     extensions, since everything has been loaded.  */
+  set_module_locus (&extensions);
+  load_derived_extensions ();
+
   /* Clean up symbol nodes that were never loaded, create references
      to hidden symbols.  */
 
@@ -4594,6 +4657,36 @@ write_equiv (void)
 }
 
 
+/* Write derived type extensions to the module.  */
+
+static void
+write_dt_extensions (gfc_symtree *st)
+{
+  mio_lparen ();
+  mio_pool_string (&st->n.sym->name);
+  if (st->n.sym->module != NULL)
+    mio_pool_string (&st->n.sym->module);
+  else
+    mio_internal_string (module_name);
+  mio_rparen ();
+}
+
+static void
+write_derived_extensions (gfc_symtree *st)
+{
+  if (!((st->n.sym->attr.flavor == FL_DERIVED)
+	  && (st->n.sym->f2k_derived != NULL)
+	  && (st->n.sym->f2k_derived->sym_root != NULL)))
+    return;
+
+  mio_lparen ();
+  mio_symbol_ref (&(st->n.sym));
+  gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
+			write_dt_extensions);
+  mio_rparen ();
+}
+
+
 /* Write a symbol to the module.  */
 
 static void
@@ -4820,6 +4913,13 @@ write_module (void)
   write_char ('\n');
   write_char ('\n');
 
+  mio_lparen ();
+  gfc_traverse_symtree (gfc_current_ns->sym_root,
+			write_derived_extensions);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
   /* Write symbol information.  First we traverse all symbols in the
      primary namespace, writing those that need to be written.
      Sometimes writing one symbol will cause another to need to be
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index 3e20f8e45d4..d2c6d9ba849 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -242,6 +242,28 @@ gfc_post_options (const char **pfilename)
   if (flag_whole_program)
     gfc_option.flag_whole_file = 1;
 
+  if (flag_lto || flag_whopr)
+    {
+#ifdef ENABLE_LTO
+      flag_generate_lto = 1;
+
+      /* When generating IL, do not operate in whole-program mode.
+	 Otherwise, symbols will be privatized too early, causing link
+	 errors later.  */
+      flag_whole_program = 0;
+
+      /* But do enable whole-file mode.  */
+      gfc_option.flag_whole_file = 1;
+#else
+      error ("LTO support has not been enabled in this configuration");
+#endif
+    }
+
+  /* Reconcile -flto and -fwhopr.  Set additional flags as appropriate and
+     check option consistency.  */
+  if (flag_lto && flag_whopr)
+    error ("-flto and -fwhopr are mutually exclusive");
+
   /* -fbounds-check is equivalent to -fcheck=bounds */
   if (flag_bounds_check)
     gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 13199c91bb0..770c7efe9f6 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -2909,12 +2909,8 @@ parse_select_type_block (void)
       if (st == ST_NONE)
 	unexpected_eof ();
       if (st == ST_END_SELECT)
-	{
-	  /* Empty SELECT CASE is OK.  */
-	  accept_statement (st);
-	  pop_state ();
-	  return;
-	}
+	/* Empty SELECT CASE is OK.  */
+	goto done;
       if (st == ST_TYPE_IS || st == ST_CLASS_IS)
 	break;
 
@@ -2959,8 +2955,10 @@ parse_select_type_block (void)
     }
   while (st != ST_END_SELECT);
 
+done:
   pop_state ();
   accept_statement (st);
+  gfc_current_ns = gfc_current_ns->parent;
 }
 
 
@@ -3033,18 +3031,13 @@ check_do_closure (void)
 static void parse_progunit (gfc_statement);
 
 
-/* Parse a BLOCK construct.  */
+/* Set up the local namespace for a BLOCK construct.  */
 
-static void
-parse_block_construct (void)
+gfc_namespace*
+gfc_build_block_ns (gfc_namespace *parent_ns)
 {
-  gfc_namespace* parent_ns;
   gfc_namespace* my_ns;
-  gfc_state_data s;
 
-  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
-
-  parent_ns = gfc_current_ns;
   my_ns = gfc_get_namespace (parent_ns, 1);
   my_ns->construct_entities = 1;
 
@@ -3066,6 +3059,22 @@ parse_block_construct (void)
     }
   my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
 
+  return my_ns;
+}
+
+
+/* Parse a BLOCK construct.  */
+
+static void
+parse_block_construct (void)
+{
+  gfc_namespace* my_ns;
+  gfc_state_data s;
+
+  gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+
+  my_ns = gfc_build_block_ns (gfc_current_ns);
+
   new_st.op = EXEC_BLOCK;
   new_st.ext.ns = my_ns;
   accept_statement (ST_BLOCK);
@@ -3075,7 +3084,7 @@ parse_block_construct (void)
 
   parse_progunit (ST_NONE);
 
-  gfc_current_ns = parent_ns;
+  gfc_current_ns = gfc_current_ns->parent;
   pop_state ();
 }
 
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index 2b926618d28..e0a2969c2a3 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -70,4 +70,5 @@ match gfc_match_enumerator_def (void);
 void gfc_free_enum_history (void);
 extern bool gfc_matching_function;
 match gfc_match_prefix (gfc_typespec *);
+gfc_namespace* gfc_build_block_ns (gfc_namespace *);
 #endif  /* GFC_PARSE_H  */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bb803b3475c..1aee540969c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -367,15 +367,26 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
   /* Fortran 95 Draft Standard, page 51, Section 5.1.1.5, on the Character 
      type, lists the only ways a character length value of * can be used:
      dummy arguments of procedures, named constants, and function results
-     in external functions.  Internal function results are not on that list;
-     ergo, not permitted.  */
+     in external functions.  Internal function results and results of module
+     procedures are not on this list, ergo, not permitted.  */
 
   if (sym->result->ts.type == BT_CHARACTER)
     {
       gfc_charlen *cl = sym->result->ts.u.cl;
       if (!cl || !cl->length)
-	gfc_error ("Character-valued internal function '%s' at %L must "
-		   "not be assumed length", sym->name, &sym->declared_at);
+	{
+	  /* See if this is a module-procedure and adapt error message
+	     accordingly.  */
+	  bool module_proc;
+	  gcc_assert (ns->parent && ns->parent->proc_name);
+	  module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE);
+
+	  gfc_error ("Character-valued %s '%s' at %L must not be"
+		     " assumed length",
+		     module_proc ? _("module procedure")
+				 : _("internal function"),
+		     sym->name, &sym->declared_at);
+	}
     }
 }
 
@@ -4997,28 +5008,42 @@ resolve_typebound_call (gfc_code* c)
   c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
 
   gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
+
   gfc_free_expr (c->expr1);
-  c->expr1 = NULL;
+  c->expr1 = gfc_get_expr ();
+  c->expr1->expr_type = EXPR_FUNCTION;
+  c->expr1->symtree = target;
+  c->expr1->where = c->loc;
 
   return resolve_call (c);
 }
 
 
-/* Resolve a component-call expression.  */
-
+/* Resolve a component-call expression.  This originally was intended
+   only to see functions.  However, it is convenient to use it in 
+   resolving subroutine class methods, since we do not have to add a
+   gfc_code each time. */
 static gfc_try
-resolve_compcall (gfc_expr* e)
+resolve_compcall (gfc_expr* e, bool fcn)
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 
   /* Check that's really a FUNCTION.  */
-  if (!e->value.compcall.tbp->function)
+  if (fcn && !e->value.compcall.tbp->function)
     {
       gfc_error ("'%s' at %L should be a FUNCTION",
 		 e->value.compcall.name, &e->where);
       return FAILURE;
     }
+  else if (!fcn && !e->value.compcall.tbp->subroutine)
+    {
+      /* To resolve class member calls, we borrow this bit
+         of code to select the specific procedures.  */
+      gfc_error ("'%s' at %L should be a SUBROUTINE",
+		 e->value.compcall.name, &e->where);
+      return FAILURE;
+    }
 
   /* These must not be assign-calls!  */
   gcc_assert (!e->value.compcall.assign);
@@ -5043,12 +5068,212 @@ resolve_compcall (gfc_expr* e)
   e->value.function.actual = newactual;
   e->value.function.name = e->value.compcall.name;
   e->value.function.esym = target->n.sym;
+  e->value.function.class_esym = NULL;
   e->value.function.isym = NULL;
   e->symtree = target;
   e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 
-  return gfc_resolve_expr (e);
+  /* Resolution is not necessary if this is a class subroutine; this
+     function only has to identify the specific proc. Resolution of
+     the call will be done next in resolve_typebound_call.  */
+  return fcn ? gfc_resolve_expr (e) : SUCCESS;
+}
+
+
+/* Resolve a typebound call for the members in a class.  This group of
+   functions implements dynamic dispatch in the provisional version
+   of f03 OOP.  As soon as vtables are in place and contain pointers
+   to methods, this will no longer be necessary.  */
+static gfc_expr *list_e;
+static void check_class_members (gfc_symbol *);
+static gfc_try class_try;
+static bool fcn_flag;
+static gfc_symbol *class_object;
+
+
+static void
+check_members (gfc_symbol *derived)
+{
+  if (derived->attr.flavor == FL_DERIVED)
+    check_class_members (derived);
+}
+
+
+static void 
+check_class_members (gfc_symbol *derived)
+{
+  gfc_symbol* tbp_sym;
+  gfc_expr *e;
+  gfc_symtree *tbp;
+  gfc_class_esym_list *etmp;
+
+  e = gfc_copy_expr (list_e);
+
+  tbp = gfc_find_typebound_proc (derived, &class_try,
+				 e->value.compcall.name,
+				 false, &e->where);
+
+  if (tbp == NULL)
+    {
+      gfc_error ("no typebound available procedure named '%s' at %L",
+		 e->value.compcall.name, &e->where);
+      return;
+    }
+
+  if (tbp->n.tb->is_generic)
+    {
+      tbp_sym = NULL;
+
+      /* If we have to match a passed class member, force the actual
+	 expression to have the correct type.  */
+      if (!tbp->n.tb->nopass)
+	{
+	  if (e->value.compcall.base_object == NULL)
+	    e->value.compcall.base_object =
+			extract_compcall_passed_object (e);
+
+          e->value.compcall.base_object->ts.type = BT_DERIVED;
+          e->value.compcall.base_object->ts.u.derived = derived;
+	}
+    }
+  else
+    tbp_sym = tbp->n.tb->u.specific->n.sym;
+
+  e->value.compcall.tbp = tbp->n.tb;
+  e->value.compcall.name = tbp->name;
+
+  /* Let the original expresssion catch the assertion in
+     resolve_compcall, since this flag does not appear to be reset or
+     copied in some systems.  */
+  e->value.compcall.assign = 0;
+
+  /* Do the renaming, PASSing, generic => specific and other
+     good things for each class member.  */
+  class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
+				? class_try : FAILURE;
+
+  /* Now transfer the found symbol to the esym list.  */
+  if (class_try == SUCCESS)
+    {
+      etmp = list_e->value.function.class_esym;
+      list_e->value.function.class_esym
+		= gfc_get_class_esym_list();
+      list_e->value.function.class_esym->next = etmp;
+      list_e->value.function.class_esym->derived = derived;
+      list_e->value.function.class_esym->class_object
+		= class_object;
+      list_e->value.function.class_esym->esym
+		= e->value.function.esym;
+    }
+
+  gfc_free_expr (e);
+  
+  /* Burrow down into grandchildren types.  */
+  if (derived->f2k_derived)
+    gfc_traverse_ns (derived->f2k_derived, check_members);
+}
+
+
+/* Eliminate esym_lists where all the members point to the
+   typebound procedure of the declared type; ie. one where
+   type selection has no effect..  */
+static void
+resolve_class_esym (gfc_expr *e)
+{
+  gfc_class_esym_list *p, *q;
+  bool empty = true;
+
+  gcc_assert (e && e->expr_type == EXPR_FUNCTION);
+
+  p = e->value.function.class_esym;
+  if (p == NULL)
+    return;
+
+  for (; p; p = p->next)
+    empty = empty && (e->value.function.esym == p->esym);
+
+  if (empty)
+    {
+      p = e->value.function.class_esym;
+      for (; p; p = q)
+	{
+	  q = p->next;
+	  gfc_free (p);
+	}
+      e->value.function.class_esym = NULL;
+   }
+}
+
+
+/* Resolve a CLASS typebound function, or 'method'.  */
+static gfc_try
+resolve_class_compcall (gfc_expr* e)
+{
+  gfc_symbol *derived;
+
+  class_object = e->symtree->n.sym;
+
+  /* Get the CLASS type.  */
+  derived = e->symtree->n.sym->ts.u.derived;
+
+  /* Get the data component, which is of the declared type.  */
+  derived = derived->components->ts.u.derived;
+
+  /* Resolve the function call for each member of the class.  */
+  class_try = SUCCESS;
+  fcn_flag = true;
+  list_e = gfc_copy_expr (e);
+  check_class_members (derived);
+
+  class_try = (resolve_compcall (e, true) == SUCCESS)
+		 ? class_try : FAILURE;
+
+  /* Transfer the class list to the original expression.  Note that
+     the class_esym list is cleaned up in trans-expr.c, as the calls
+     are translated.  */
+  e->value.function.class_esym = list_e->value.function.class_esym;
+  list_e->value.function.class_esym = NULL;
+  gfc_free_expr (list_e);
+
+  resolve_class_esym (e);
+
+  return class_try;
+}
+
+/* Resolve a CLASS typebound subroutine, or 'method'.  */
+static gfc_try
+resolve_class_typebound_call (gfc_code *code)
+{
+  gfc_symbol *derived;
+
+  class_object = code->expr1->symtree->n.sym;
+
+  /* Get the CLASS type.  */
+  derived = code->expr1->symtree->n.sym->ts.u.derived;
+
+  /* Get the data component, which is of the declared type.  */
+  derived = derived->components->ts.u.derived;
+
+  class_try = SUCCESS;
+  fcn_flag = false;
+  list_e = gfc_copy_expr (code->expr1);
+  check_class_members (derived);
+
+  class_try = (resolve_typebound_call (code) == SUCCESS)
+		 ? class_try : FAILURE;
+
+  /* Transfer the class list to the original expression.  Note that
+     the class_esym list is cleaned up in trans-expr.c, as the calls
+     are translated.  */
+  code->expr1->value.function.class_esym
+			= list_e->value.function.class_esym;
+  list_e->value.function.class_esym = NULL;
+  gfc_free_expr (list_e);
+
+  resolve_class_esym (code->expr1);
+
+  return class_try;
 }
 
 
@@ -5162,7 +5387,10 @@ gfc_resolve_expr (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
-      t = resolve_compcall (e);
+      if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+	t = resolve_class_compcall (e);
+      else
+	t = resolve_compcall (e, true);
       break;
 
     case EXPR_SUBSTRING:
@@ -6444,8 +6672,15 @@ resolve_select_type (gfc_code *code)
   gfc_case *c, *default_case;
   gfc_symtree *st;
   char name[GFC_MAX_SYMBOL_LEN];
+  gfc_namespace *ns;
+
+  ns = code->ext.ns;
+  gfc_resolve (ns);
 
-  selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
+  if (code->expr2)
+    selector_type = code->expr2->ts.u.derived->components->ts.u.derived;
+  else
+    selector_type = code->expr1->ts.u.derived->components->ts.u.derived;
 
   /* Assume there is no DEFAULT case.  */
   default_case = NULL;
@@ -6487,6 +6722,32 @@ resolve_select_type (gfc_code *code)
 	}
     }
 
+  if (code->expr2)
+    {
+      /* Insert assignment for selector variable.  */
+      new_st = gfc_get_code ();
+      new_st->op = EXEC_ASSIGN;
+      new_st->expr1 = gfc_copy_expr (code->expr1);
+      new_st->expr2 = gfc_copy_expr (code->expr2);
+      ns->code = new_st;
+    }
+
+  /* Put SELECT TYPE statement inside a BLOCK.  */
+  new_st = gfc_get_code ();
+  new_st->op = code->op;
+  new_st->expr1 = code->expr1;
+  new_st->expr2 = code->expr2;
+  new_st->block = code->block;
+  if (!ns->code)
+    ns->code = new_st;
+  else
+    ns->code->next = new_st;
+  code->op = EXEC_BLOCK;
+  code->expr1 = code->expr2 =  NULL;
+  code->block = NULL;
+
+  code = new_st;
+
   /* Transform to EXEC_SELECT.  */
   code->op = EXEC_SELECT;
   gfc_add_component_ref (code->expr1, "$vindex");
@@ -6506,7 +6767,7 @@ resolve_select_type (gfc_code *code)
 	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);
+      st = gfc_find_symtree (ns->sym_root, name);
       new_st = gfc_get_code ();
       new_st->op = EXEC_POINTER_ASSIGN;
       new_st->expr1 = gfc_get_variable_expr (st);
@@ -7452,9 +7713,6 @@ 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)
@@ -7463,6 +7721,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 		goto call;
 	    }
 
+	  if (code->expr1->ts.type == BT_CLASS)
+	    resolve_class_assign (code);
+
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
@@ -7483,11 +7744,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  if (t == FAILURE)
 	    break;
 
+	  gfc_check_pointer_assign (code->expr1, code->expr2);
+
 	  if (code->expr1->ts.type == BT_CLASS)
 	    resolve_class_assign (code);
 
-	  gfc_check_pointer_assign (code->expr1, code->expr2);
-
 	  break;
 
 	case EXEC_ARITHMETIC_IF:
@@ -7517,7 +7778,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 
 	case EXEC_COMPCALL:
 	compcall:
-	  resolve_typebound_call (code);
+	  if (code->expr1->symtree
+		&& code->expr1->symtree->n.sym->ts.type == BT_CLASS)
+	    resolve_class_typebound_call (code);
+	  else
+	    resolve_typebound_call (code);
 	  break;
 
 	case EXEC_CALL_PPC:
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 39285b16fea..befa90b8c49 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2479,6 +2479,12 @@ gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
       st = gfc_find_symtree (ns->sym_root, name);
       if (st != NULL)
 	{
+	  /* Special case: If we're in a SELECT TYPE block,
+	    replace the selector variable by a temporary.  */
+	  if (gfc_current_state () == COMP_SELECT_TYPE
+	      && st && st->n.sym == type_selector)
+	    st = select_type_tmp;
+
 	  *result = st;
 	  /* Ambiguous generic interfaces are permitted, as long
 	     as the specific interfaces are different.  */
@@ -2645,12 +2651,6 @@ gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
 
   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
 
-  /* Special case: If we're in a SELECT TYPE block,
-     replace the selector variable by a temporary.  */
-  if (gfc_current_state () == COMP_SELECT_TYPE
-      && st && st->n.sym == type_selector)
-    st = select_type_tmp;
-
   if (st != NULL)
     {
       save_symbol_data (st->n.sym);
@@ -4579,9 +4579,12 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
   if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
       && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
     {
-      if (ts1->type == BT_CLASS)
+      if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
 	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
 					 ts2->u.derived);
+      else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
+	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+					 ts2->u.derived->components->ts.u.derived);
       else if (ts2->type != BT_CLASS)
 	return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
       else
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 3d6a5e2221c..ee38efbe27c 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2991,7 +2991,8 @@ gfc_init_default_dt (gfc_symbol * sym, tree body)
   gfc_set_sym_referenced (sym);
   e = gfc_lval_expr_from_sym (sym);
   tmp = gfc_trans_assignment (e, sym->value, false);
-  if (sym->attr.dummy)
+  if (sym->attr.dummy && (sym->attr.optional
+			  || sym->ns->proc_name->attr.entry_master))
     {
       present = gfc_conv_expr_present (sym);
       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
@@ -3023,21 +3024,23 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)
 	&& !f->sym->attr.pointer
 	&& f->sym->ts.type == BT_DERIVED)
       {
-	if (f->sym->ts.u.derived->attr.alloc_comp)
+	if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
 	  {
 	    tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
 					     f->sym->backend_decl,
 					     f->sym->as ? f->sym->as->rank : 0);
 
-	    present = gfc_conv_expr_present (f->sym);
-	    tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
-			  tmp, build_empty_stmt (input_location));
+	    if (f->sym->attr.optional
+		|| f->sym->ns->proc_name->attr.entry_master)
+	      {
+		present = gfc_conv_expr_present (f->sym);
+		tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+			      tmp, build_empty_stmt (input_location));
+	      }
 
 	    gfc_add_expr_to_block (&fnblock, tmp);
 	  }
-
-	if (!f->sym->ts.u.derived->attr.alloc_comp
-	      && f->sym->value)
+       else if (f->sym->value)
 	  body = gfc_init_default_dt (f->sym, body);
       }
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index eb741f8231f..77953c8e15f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1523,11 +1523,135 @@ get_proc_ptr_comp (gfc_expr *e)
 }
 
 
+/* Select a class typebound procedure at runtime.  */
+static void
+select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
+		   tree declared, locus *where)
+{
+  tree end_label;
+  tree label;
+  tree tmp;
+  tree vindex;
+  stmtblock_t body;
+  gfc_class_esym_list *next_elist, *tmp_elist;
+
+  /* Calculate the switch expression: class_object.vindex.  */
+  gcc_assert (elist->class_object->ts.type == BT_CLASS);
+  tmp = elist->class_object->ts.u.derived->components->next->backend_decl;
+  vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+			elist->class_object->backend_decl,
+			tmp, NULL_TREE);
+  vindex = gfc_evaluate_now (vindex, &se->pre);
+
+  /* Fix the function type to be that of the declared type.  */
+  declared = gfc_create_var (TREE_TYPE (declared), "method");
+
+  end_label = gfc_build_label_decl (NULL_TREE);
+
+  gfc_init_block (&body);
+
+  /* Go through the list of extensions.  */
+  for (; elist; elist = next_elist)
+    {
+      /* This case has already been added.  */
+      if (elist->derived == NULL)
+	goto free_elist;
+
+      /* Run through the chain picking up all the cases that call the
+	 same procedure.  */
+      tmp_elist = elist;
+      for (; elist; elist = elist->next)
+	{
+	  tree cval;
+
+	  if (elist->esym != tmp_elist->esym)
+	    continue;
+
+	  cval = build_int_cst (TREE_TYPE (vindex),
+				elist->derived->vindex);
+	  /* Build a label for the vindex value.  */
+	  label = gfc_build_label_decl (NULL_TREE);
+	  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+			     cval, NULL_TREE, label);
+	  gfc_add_expr_to_block (&body, tmp);
+
+	  /* Null the reference the derived type so that this case is
+	     not used again.  */
+	  elist->derived = NULL;
+	}
+
+      elist = tmp_elist;
+
+      /* Get a pointer to the procedure,  */
+      tmp = gfc_get_symbol_decl (elist->esym);
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      /* Assign the pointer to the appropriate procedure.  */
+      gfc_add_modify (&body, declared,
+		      fold_convert (TREE_TYPE (declared), tmp));
+
+      /* Break to the end of the construct.  */
+      tmp = build1_v (GOTO_EXPR, end_label);
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Free the elists as we go; freeing them in gfc_free_expr causes
+	 segfaults because it occurs too early and too often.  */
+    free_elist:
+      next_elist = elist->next;
+      gfc_free (elist);
+      elist = NULL;
+    }
+
+  /* Default is an error.  */
+  label = gfc_build_label_decl (NULL_TREE);
+  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+		     NULL_TREE, NULL_TREE, label);
+  gfc_add_expr_to_block (&body, tmp);
+  tmp = gfc_trans_runtime_error (true, where,
+		"internal error: bad vindex in dynamic dispatch");
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Write the switch expression.  */
+  tmp = gfc_finish_block (&body);
+  tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  tmp = build1_v (LABEL_EXPR, end_label);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = declared;
+  return;
+}
+
+
 static void
 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 {
   tree tmp;
 
+  if (expr && expr->symtree
+	&& expr->value.function.class_esym)
+    {
+      if (!sym->backend_decl)
+	sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+      tmp = sym->backend_decl;
+
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      select_class_proc (se, expr->value.function.class_esym,
+			 tmp, &expr->where);
+      return;
+    }
+
   if (gfc_is_proc_ptr_comp (expr, NULL))
     tmp = get_proc_ptr_comp (expr);
   else if (sym->attr.dummy)
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 9d3197d11bc..05ed23e4c05 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -159,31 +159,15 @@ gfc_trans_goto (gfc_code * code)
 
   assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
 
-  code = code->block;
-  if (code == NULL)
-    {
-      target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
-      gfc_add_expr_to_block (&se.pre, target);
-      return gfc_finish_block (&se.pre);
-    }
-
-  /* Check the label list.  */
-  do
-    {
-      target = gfc_get_label_decl (code->label1);
-      tmp = gfc_build_addr_expr (pvoid_type_node, target);
-      tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
-      tmp = build3_v (COND_EXPR, tmp,
-		      fold_build1 (GOTO_EXPR, void_type_node, target),
-		      build_empty_stmt (input_location));
-      gfc_add_expr_to_block (&se.pre, tmp);
-      code = code->block;
-    }
-  while (code != NULL);
-  gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc,
-			   "Assigned label is not in the list");
-
-  return gfc_finish_block (&se.pre); 
+  /* We're going to ignore a label list.  It does not really change the
+     statement's semantics (because it is just a further restriction on
+     what's legal code); before, we were comparing label addresses here, but
+     that's a very fragile business and may break with optimization.  So
+     just ignore it.  */
+
+  target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
+  gfc_add_expr_to_block (&se.pre, target);
+  return gfc_finish_block (&se.pre);
 }