gfortran.h (enum expr_t): New value `EXPR_COMPCALL'.

2008-08-28  Daniel Kraft  <d@domob.eu>

	* gfortran.h (enum expr_t): New value `EXPR_COMPCALL'.
	(gfc_get_typebound_proc): New macro.
	(struct gfc_expr): New union-member `compcall' for EXPR_COMPCALL.
	(enum gfc_exec_op): New value `EXEC_COMPCALL'.
	(gfc_find_typebound_proc): New argument.
	(gfc_copy_ref), (gfc_match_varspec): Made public.
	* decl.c (match_procedure_in_type): Use gfc_get_typebound_proc.
	* expr.c (free_expr0), (gfc_copy_expr): Handle EXPR_COMPCALL.
	(gfc_copy_ref): Made public and use new name.
	(simplify_const_ref): Use new name of gfc_copy_ref.
	(simplify_parameter_variable): Ditto.
	(gfc_simplify_expr): gcc_unreachable for EXPR_COMPCALL.
	* match.c (match_typebound_call): New method.
	(gfc_match_call): Allow for CALL's to typebound procedures.
	* module.c (binding_passing), (binding_overriding): New variables.
	(expr_types): Add EXPR_COMPCALL.
	(mio_expr): gcc_unreachable for EXPR_COMPCALL.
	(mio_typebound_proc), (mio_typebound_symtree): New methods.
	(mio_f2k_derived): Handle type-bound procedures.
	* primary.c (gfc_match_varspec): Made public and parse trailing
	references to type-bound procedures; new argument `sub_flag'.
	(gfc_match_rvalue): New name and argument of gfc_match_varspec.
	(match_variable): Ditto.
	* resolve.c (update_arglist_pass): New method.
	(update_compcall_arglist), (resolve_typebound_static): New methods.
	(resolve_typebound_call), (resolve_compcall): New methods.
	(gfc_resolve_expr): Handle EXPR_COMPCALL.
	(resolve_code): Handle EXEC_COMPCALL.
	(resolve_fl_derived): New argument to gfc_find_typebound_proc.
	(resolve_typebound_procedure): Ditto and removed not-implemented error.
	* st.c (gfc_free_statement): Handle EXEC_COMPCALL.
	* symbol.c (gfc_find_typebound_proc): New argument `noaccess' and
	implement access-checking.
	* trans-expr.c (gfc_apply_interface_mapping_to_expr): gcc_unreachable
	on EXPR_COMPCALL.
	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Add missing break.
	* trans-openmp.c (gfc_trans_omp_array_reduction): Add missing
	intialization of ref->type.

2008-08-28  Daniel Kraft  <d@domob.eu>

	* gfortran.dg/typebound_call_1.f03: New test.
	* gfortran.dg/typebound_call_2.f03: New test.
	* gfortran.dg/typebound_call_3.f03: New test.
	* gfortran.dg/typebound_call_4.f03: New test.
	* gfortran.dg/typebound_call_5.f03: New test.
	* gfortran.dg/typebound_call_6.f03: New test.
	* gfortran.dg/typebound_proc_1.f08: Don't expect not-implemented error.
	* gfortran.dg/typebound_proc_2.f90: Ditto.
	* gfortran.dg/typebound_proc_5.f03: Ditto.
	* gfortran.dg/typebound_proc_6.f03: Ditto.
	* gfortran.dg/typebound_proc_7.f03: Ditto.
	* gfortran.dg/typebound_proc_8.f03: Ditto.

From-SVN: r139724

13 files changed, 472 insertions, 46 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c626a65..e6b1866 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,44 @@
+2008-08-28  Daniel Kraft  <d@domob.eu>
+
+	* gfortran.h (enum expr_t): New value `EXPR_COMPCALL'.
+	(gfc_get_typebound_proc): New macro.
+	(struct gfc_expr): New union-member `compcall' for EXPR_COMPCALL.
+	(enum gfc_exec_op): New value `EXEC_COMPCALL'.
+	(gfc_find_typebound_proc): New argument.
+	(gfc_copy_ref), (gfc_match_varspec): Made public.
+	* decl.c (match_procedure_in_type): Use gfc_get_typebound_proc.
+	* expr.c (free_expr0), (gfc_copy_expr): Handle EXPR_COMPCALL.
+	(gfc_copy_ref): Made public and use new name.
+	(simplify_const_ref): Use new name of gfc_copy_ref.
+	(simplify_parameter_variable): Ditto.
+	(gfc_simplify_expr): gcc_unreachable for EXPR_COMPCALL.
+	* match.c (match_typebound_call): New method.
+	(gfc_match_call): Allow for CALL's to typebound procedures.
+	* module.c (binding_passing), (binding_overriding): New variables.
+	(expr_types): Add EXPR_COMPCALL.
+	(mio_expr): gcc_unreachable for EXPR_COMPCALL.
+	(mio_typebound_proc), (mio_typebound_symtree): New methods.
+	(mio_f2k_derived): Handle type-bound procedures.
+	* primary.c (gfc_match_varspec): Made public and parse trailing
+	references to type-bound procedures; new argument `sub_flag'.
+	(gfc_match_rvalue): New name and argument of gfc_match_varspec.
+	(match_variable): Ditto.
+	* resolve.c (update_arglist_pass): New method.
+	(update_compcall_arglist), (resolve_typebound_static): New methods.
+	(resolve_typebound_call), (resolve_compcall): New methods.
+	(gfc_resolve_expr): Handle EXPR_COMPCALL.
+	(resolve_code): Handle EXEC_COMPCALL.
+	(resolve_fl_derived): New argument to gfc_find_typebound_proc.
+	(resolve_typebound_procedure): Ditto and removed not-implemented error.
+	* st.c (gfc_free_statement): Handle EXEC_COMPCALL.
+	* symbol.c (gfc_find_typebound_proc): New argument `noaccess' and
+	implement access-checking.
+	* trans-expr.c (gfc_apply_interface_mapping_to_expr): gcc_unreachable
+	on EXPR_COMPCALL.
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Add missing break.
+	* trans-openmp.c (gfc_trans_omp_array_reduction): Add missing
+	intialization of ref->type.
+
 2008-08-28  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/37253
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 406b5af..2b50ea3 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -6888,7 +6888,7 @@ match_procedure_in_type (void)
     }
 
   /* Construct the data structure.  */
-  tb = XCNEW (gfc_typebound_proc);
+  tb = gfc_get_typebound_proc ();
   tb->where = gfc_current_locus;
 
   /* Match binding attributes.  */
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 2975975..b5a17c0 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -181,6 +181,10 @@ free_expr0 (gfc_expr *e)
       gfc_free_actual_arglist (e->value.function.actual);
       break;
 
+    case EXPR_COMPCALL:
+      gfc_free_actual_arglist (e->value.compcall.actual);
+      break;
+
     case EXPR_VARIABLE:
       break;
 
@@ -268,8 +272,8 @@ gfc_extract_int (gfc_expr *expr, int *result)
 
 /* Recursively copy a list of reference structures.  */
 
-static gfc_ref *
-copy_ref (gfc_ref *src)
+gfc_ref *
+gfc_copy_ref (gfc_ref *src)
 {
   gfc_array_ref *ar;
   gfc_ref *dest;
@@ -299,7 +303,7 @@ copy_ref (gfc_ref *src)
       break;
     }
 
-  dest->next = copy_ref (src->next);
+  dest->next = gfc_copy_ref (src->next);
 
   return dest;
 }
@@ -502,6 +506,12 @@ gfc_copy_expr (gfc_expr *p)
 	gfc_copy_actual_arglist (p->value.function.actual);
       break;
 
+    case EXPR_COMPCALL:
+      q->value.compcall.actual =
+	gfc_copy_actual_arglist (p->value.compcall.actual);
+      q->value.compcall.tbp = p->value.compcall.tbp;
+      break;
+
     case EXPR_STRUCTURE:
     case EXPR_ARRAY:
       q->value.constructor = gfc_copy_constructor (p->value.constructor);
@@ -514,7 +524,7 @@ gfc_copy_expr (gfc_expr *p)
 
   q->shape = gfc_copy_shape (p->shape, p->rank);
 
-  q->ref = copy_ref (p->ref);
+  q->ref = gfc_copy_ref (p->ref);
 
   return q;
 }
@@ -1443,7 +1453,7 @@ simplify_const_ref (gfc_expr *p)
 		  cons = p->value.constructor;
 		  for (; cons; cons = cons->next)
 		    {
-		      cons->expr->ref = copy_ref (p->ref->next);
+		      cons->expr->ref = gfc_copy_ref (p->ref->next);
 		      simplify_const_ref (cons->expr);
 		    }
 		}
@@ -1531,7 +1541,7 @@ simplify_parameter_variable (gfc_expr *p, int type)
 
   /* Do not copy subobject refs for constant.  */
   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
-    e->ref = copy_ref (p->ref);
+    e->ref = gfc_copy_ref (p->ref);
   t = gfc_simplify_expr (e, type);
 
   /* Only use the simplification if it eliminated all subobject references.  */
@@ -1670,6 +1680,10 @@ gfc_simplify_expr (gfc_expr *p, int type)
 	return FAILURE;
 
       break;
+
+    case EXPR_COMPCALL:
+      gcc_unreachable ();
+      break;
     }
 
   return SUCCESS;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b063474..386668d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -151,7 +151,7 @@ bt;
 /* Expression node types.  */
 typedef enum
 { EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE,
-  EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL
+  EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL
 }
 expr_t;
 
@@ -1003,7 +1003,7 @@ typedef struct
 
   /* Once resolved, we use the position of pass_arg in the formal arglist of
      the binding-target procedure to identify it.  The first argument has
-     number 0 here, the second 1, and so on.  */
+     number 1 here, the second 2, and so on.  */
   unsigned pass_arg_num;
 
   unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise).  */
@@ -1011,6 +1011,8 @@ typedef struct
 }
 gfc_typebound_proc;
 
+#define gfc_get_typebound_proc() XCNEW (gfc_typebound_proc)
+
 
 /* Symbol nodes.  These are important things.  They are what the
    standard refers to as "entities".  The possibly multiple names that
@@ -1447,11 +1449,13 @@ gfc_intrinsic_sym;
    EXPR_FUNCTION   Function call, symbol points to function's name
    EXPR_CONSTANT   A scalar constant: Logical, String, Real, Int or Complex
    EXPR_VARIABLE   An Lvalue with a root symbol and possible reference list
-                   which expresses structure, array and substring refs.
+		   which expresses structure, array and substring refs.
    EXPR_NULL       The NULL pointer value (which also has a basic type).
    EXPR_SUBSTRING  A substring of a constant string
    EXPR_STRUCTURE  A structure constructor
-   EXPR_ARRAY      An array constructor.  */
+   EXPR_ARRAY      An array constructor.
+   EXPR_COMPCALL   Function (or subroutine) call of a procedure pointer
+		   component or type-bound procedure.  */
 
 #include <gmp.h>
 #include <mpfr.h>
@@ -1466,7 +1470,8 @@ typedef struct gfc_expr
   int rank;
   mpz_t *shape;		/* Can be NULL if shape is unknown at compile time */
 
-  /* Nonnull for functions and structure constructors */
+  /* Nonnull for functions and structure constructors, the base object for
+     component-calls.  */
   gfc_symtree *symtree;
 
   gfc_ref *ref;
@@ -1526,6 +1531,13 @@ typedef struct gfc_expr
 
     struct
     {
+      gfc_actual_arglist* actual;
+      gfc_symtree* tbp;
+    }
+    compcall;
+
+    struct
+    {
       int length;
       gfc_char_t *string;
     }
@@ -1770,8 +1782,8 @@ gfc_forall_iterator;
 typedef enum
 {
   EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN,
-  EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY,
-  EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
+  EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
+  EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
   EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
   EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
   EXEC_ALLOCATE, EXEC_DEALLOCATE,
@@ -2261,7 +2273,7 @@ gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
-gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
 
 void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
 
@@ -2341,6 +2353,7 @@ gfc_expr *gfc_logical_expr (int, locus *);
 mpz_t *gfc_copy_shape (mpz_t *, int);
 mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
 gfc_expr *gfc_copy_expr (gfc_expr *);
+gfc_ref* gfc_copy_ref (gfc_ref*);
 
 gfc_try gfc_specification_expr (gfc_expr *);
 
@@ -2464,6 +2477,7 @@ bool gfc_check_access (gfc_access, gfc_access);
 symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
 symbol_attribute gfc_expr_attr (gfc_expr *);
 match gfc_match_rvalue (gfc_expr **);
+match gfc_match_varspec (gfc_expr*, int, bool);
 int gfc_check_digit (char, int);
 
 /* trans.c */
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index a02d1d1..0da7068 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2509,6 +2509,48 @@ done:
 }
 
 
+/* Match the call of a type-bound procedure, if CALL%var has already been 
+   matched and var found to be a derived-type variable.  */
+
+static match
+match_typebound_call (gfc_symtree* varst)
+{
+  gfc_symbol* var;
+  gfc_expr* base;
+  match m;
+
+  var = varst->n.sym;
+
+  base = gfc_get_expr ();
+  base->expr_type = EXPR_VARIABLE;
+  base->symtree = varst;
+  base->where = gfc_current_locus;
+  
+  m = gfc_match_varspec (base, 0, true);
+  if (m == MATCH_NO)
+    gfc_error ("Expected component reference at %C");
+  if (m != MATCH_YES)
+    return MATCH_ERROR;
+
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after CALL at %C");
+      return MATCH_ERROR;
+    }
+
+  if (base->expr_type != EXPR_COMPCALL)
+    {
+      gfc_error ("Expected type-bound procedure reference at %C");
+      return MATCH_ERROR;
+    }
+
+  new_st.op = EXEC_COMPCALL;
+  new_st.expr = base;
+
+  return MATCH_YES;
+}
+
+
 /* Match a CALL statement.  The tricky part here are possible
    alternate return specifiers.  We handle these by having all
    "subroutines" actually return an integer via a register that gives
@@ -2541,6 +2583,11 @@ gfc_match_call (void)
 
   sym = st->n.sym;
 
+  /* 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)
+    return match_typebound_call (st);
+
   /* If it does not seem to be callable...  */
   if (!sym->attr.generic
 	&& !sym->attr.subroutine)
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 26dc58b..4cbaaa0 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -1695,6 +1695,20 @@ static const mstring attr_bits[] =
     minit (NULL, -1)
 };
 
+/* For binding attributes.  */
+static const mstring binding_passing[] =
+{
+    minit ("PASS", 0),
+    minit ("NOPASS", 1),
+    minit (NULL, -1)
+};
+static const mstring binding_overriding[] =
+{
+    minit ("OVERRIDABLE", 0),
+    minit ("NON_OVERRIDABLE", 1),
+    minit (NULL, -1)
+};
+
 
 /* Specialization of mio_name.  */
 DECL_MIO_NAME (ab_attribute)
@@ -2762,6 +2776,7 @@ static const mstring expr_types[] = {
     minit ("STRUCTURE", EXPR_STRUCTURE),
     minit ("ARRAY", EXPR_ARRAY),
     minit ("NULL", EXPR_NULL),
+    minit ("COMPCALL", EXPR_COMPCALL),
     minit (NULL, -1)
 };
 
@@ -3025,6 +3040,10 @@ mio_expr (gfc_expr **ep)
 
     case EXPR_NULL:
       break;
+
+    case EXPR_COMPCALL:
+      gcc_unreachable ();
+      break;
     }
 
   mio_rparen ();
@@ -3181,6 +3200,54 @@ mio_namespace_ref (gfc_namespace **nsp)
 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
 
 static void
+mio_typebound_proc (gfc_typebound_proc** proc)
+{
+  int flag;
+
+  if (iomode == IO_INPUT)
+    {
+      *proc = gfc_get_typebound_proc ();
+      (*proc)->where = gfc_current_locus;
+    }
+  gcc_assert (*proc);
+
+  mio_lparen ();
+  mio_symtree_ref (&(*proc)->target);
+
+  (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
+
+  (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
+  (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
+				       binding_overriding);
+
+  if (iomode == IO_INPUT)
+    (*proc)->pass_arg = NULL;
+
+  flag = (int) (*proc)->pass_arg_num;
+  mio_integer (&flag);
+  (*proc)->pass_arg_num = (unsigned) flag;
+
+  mio_rparen ();
+}
+
+static void
+mio_typebound_symtree (gfc_symtree* st)
+{
+  if (iomode == IO_OUTPUT && !st->typebound)
+    return;
+
+  if (iomode == IO_OUTPUT)
+    {
+      mio_lparen ();
+      mio_allocated_string (st->name);
+    }
+  /* For IO_INPUT, the above is done in mio_f2k_derived.  */
+
+  mio_typebound_proc (&st->typebound);
+  mio_rparen ();
+}
+
+static void
 mio_finalizer (gfc_finalizer **f)
 {
   if (iomode == IO_OUTPUT)
@@ -3223,6 +3290,27 @@ mio_f2k_derived (gfc_namespace *f2k)
 	}
     }
   mio_rparen ();
+
+  /* Handle type-bound procedures.  */
+  mio_lparen ();
+  if (iomode == IO_OUTPUT)
+    gfc_traverse_symtree (f2k->sym_root, &mio_typebound_symtree);
+  else
+    {
+      while (peek_atom () == ATOM_LPAREN)
+	{
+	  gfc_symtree* st;
+
+	  mio_lparen (); 
+
+	  require_atom (ATOM_STRING);
+	  gfc_get_sym_tree (atom_string, f2k, &st);
+	  gfc_free (atom_string);
+
+	  mio_typebound_symtree (st);
+	}
+    }
+  mio_rparen ();
 }
 
 static void
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 5d73407..c72f430 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1676,7 +1676,7 @@ cleanup:
 }
 
 
-/* Used by match_varspec() to extend the reference list by one
+/* Used by gfc_match_varspec() to extend the reference list by one
    element.  */
 
 static gfc_ref *
@@ -1699,15 +1699,17 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
 /* Match any additional specifications associated with the current
    variable like member references or substrings.  If equiv_flag is
    set we only match stuff that is allowed inside an EQUIVALENCE
-   statement.  */
+   statement.  sub_flag tells whether we expect a type-bound procedure found
+   to be a subroutine as part of CALL or a FUNCTION.  */
 
-static match
-match_varspec (gfc_expr *primary, int equiv_flag)
+match
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_ref *substring, *tail;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
+  gfc_symtree *tbp;
   match m;
   bool unknown;
 
@@ -1751,12 +1753,60 @@ match_varspec (gfc_expr *primary, int equiv_flag)
 
   for (;;)
     {
+      gfc_try t;
+
       m = gfc_match_name (name);
       if (m == MATCH_NO)
 	gfc_error ("Expected structure component name at %C");
       if (m != MATCH_YES)
 	return MATCH_ERROR;
 
+      tbp = gfc_find_typebound_proc (sym, &t, name, false);
+      if (tbp)
+	{
+	  gfc_symbol* tbp_sym;
+
+	  if (t == FAILURE)
+	    return MATCH_ERROR;
+
+	  gcc_assert (!tail || !tail->next);
+	  gcc_assert (primary->expr_type == EXPR_VARIABLE);
+
+	  tbp_sym = tbp->typebound->target->n.sym;
+
+	  primary->expr_type = EXPR_COMPCALL;
+	  primary->value.compcall.tbp = tbp;
+	  primary->ts = tbp_sym->ts;
+
+	  m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
+					&primary->value.compcall.actual);
+	  if (m == MATCH_ERROR)
+	    return MATCH_ERROR;
+	  if (m == MATCH_NO)
+	    {
+	      if (sub_flag)
+		primary->value.compcall.actual = NULL;
+	      else
+		{
+		  gfc_error ("Expected argument list at %C");
+		  return MATCH_ERROR;
+		}
+	    }
+
+	  if (sub_flag && !tbp_sym->attr.subroutine)
+	    {
+	      gfc_error ("'%s' at %C should be a SUBROUTINE", name);
+	      return MATCH_ERROR;
+	    }
+	  if (!sub_flag && !tbp_sym->attr.function)
+	    {
+	      gfc_error ("'%s' at %C should be a FUNCTION", name);
+	      return MATCH_ERROR;
+	    }
+
+	  break;
+	}
+
       component = gfc_find_component (sym, name, false, false);
       if (component == NULL)
 	return MATCH_ERROR;
@@ -2387,7 +2437,7 @@ gfc_match_rvalue (gfc_expr **result)
       e->expr_type = EXPR_VARIABLE;
       e->symtree = symtree;
 
-      m = match_varspec (e, 0);
+      m = gfc_match_varspec (e, 0, false);
       break;
 
     case FL_PARAMETER:
@@ -2404,7 +2454,7 @@ gfc_match_rvalue (gfc_expr **result)
 	}
 
       e->symtree = symtree;
-      m = match_varspec (e, 0);
+      m = gfc_match_varspec (e, 0, false);
 
       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
 	break;
@@ -2461,7 +2511,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e = gfc_get_expr ();
 	  e->expr_type = EXPR_VARIABLE;
 	  e->symtree = symtree;
-	  m = match_varspec (e, 0);
+	  m = gfc_match_varspec (e, 0, false);
 	  break;
 	}
 
@@ -2488,7 +2538,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e->symtree = symtree;
 	  e->expr_type = EXPR_VARIABLE;
 
-	  m = match_varspec (e, 0);
+	  m = gfc_match_varspec (e, 0, false);
 	  break;
 	}
 
@@ -2584,7 +2634,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e = gfc_get_expr ();
 	  e->symtree = symtree;
 	  e->expr_type = EXPR_VARIABLE;
-	  m = match_varspec (e, 0);
+	  m = gfc_match_varspec (e, 0, false);
 	  break;
 	}
 
@@ -2607,9 +2657,9 @@ gfc_match_rvalue (gfc_expr **result)
 	      break;
 	    }
 
-	  /*FIXME:??? match_varspec does set this for us: */
+	  /*FIXME:??? gfc_match_varspec does set this for us: */
 	  e->ts = sym->ts;
-	  m = match_varspec (e, 0);
+	  m = gfc_match_varspec (e, 0, false);
 	  break;
 	}
 
@@ -2698,7 +2748,7 @@ gfc_match_rvalue (gfc_expr **result)
       /* If our new function returns a character, array or structure
 	 type, it might have subsequent references.  */
 
-      m = match_varspec (e, 0);
+      m = gfc_match_varspec (e, 0, false);
       if (m == MATCH_NO)
 	m = MATCH_YES;
 
@@ -2882,7 +2932,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
   expr->where = where;
 
   /* Now see if we have to do more.  */
-  m = match_varspec (expr, equiv_flag);
+  m = gfc_match_varspec (expr, equiv_flag, false);
   if (m != MATCH_YES)
     {
       gfc_free_expr (expr);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6bf5380..c6f59ad 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4281,6 +4281,141 @@ fixup_charlen (gfc_expr *e)
 }
 
 
+/* Update an actual argument to include the passed-object for type-bound
+   procedures at the right position.  */
+
+static gfc_actual_arglist*
+update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
+{
+  if (argpos == 1)
+    {
+      gfc_actual_arglist* result;
+
+      result = gfc_get_actual_arglist ();
+      result->expr = po;
+      result->next = lst;
+
+      return result;
+    }
+
+  gcc_assert (lst);
+  gcc_assert (argpos > 1);
+
+  lst->next = update_arglist_pass (lst->next, po, argpos - 1);
+  return lst;
+}
+
+
+/* Update the arglist of an EXPR_COMPCALL expression to include the
+   passed-object.  */
+
+static gfc_try
+update_compcall_arglist (gfc_expr* e)
+{
+  gfc_expr* po;
+  gfc_typebound_proc* tbp;
+
+  tbp = e->value.compcall.tbp->typebound;
+
+  po = gfc_get_expr ();
+  po->expr_type = EXPR_VARIABLE;
+  po->symtree = e->symtree;
+  po->ref = gfc_copy_ref (e->ref);
+
+  if (gfc_resolve_expr (po) == FAILURE)
+    return FAILURE;
+  if (po->rank > 0)
+    {
+      gfc_error ("Passed-object at %L must be scalar", &e->where);
+      return FAILURE;
+    }
+
+  if (tbp->nopass)
+    {
+      gfc_free_expr (po);
+      return SUCCESS;
+    }
+
+  gcc_assert (tbp->pass_arg_num > 0);
+  e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
+						  tbp->pass_arg_num);
+
+  return SUCCESS;
+}
+
+
+/* Resolve a call to a type-bound procedure, either function or subroutine,
+   statically from the data in an EXPR_COMPCALL expression.  The adapted
+   arglist and the target-procedure symtree are returned.  */
+
+static gfc_try
+resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
+			  gfc_actual_arglist** actual)
+{
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
+
+  /* Update the actual arglist for PASS.  */
+  if (update_compcall_arglist (e) == FAILURE)
+    return FAILURE;
+
+  *actual = e->value.compcall.actual;
+  *target = e->value.compcall.tbp->typebound->target;
+
+  gfc_free_ref_list (e->ref);
+  e->ref = NULL;
+  e->value.compcall.actual = NULL;
+
+  return SUCCESS;
+}
+
+
+/* Resolve a call to a type-bound subroutine.  */
+
+static gfc_try
+resolve_typebound_call (gfc_code* c)
+{
+  gfc_actual_arglist* newactual;
+  gfc_symtree* target;
+
+  /* Transform into an ordinary EXEC_CALL for now.  */
+
+  if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
+    return FAILURE;
+
+  c->ext.actual = newactual;
+  c->symtree = target;
+  c->op = EXEC_CALL;
+
+  gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
+  gfc_free_expr (c->expr);
+  c->expr = NULL;
+
+  return resolve_call (c);
+}
+
+
+/* Resolve a component-call expression.  */
+
+static gfc_try
+resolve_compcall (gfc_expr* e)
+{
+  gfc_actual_arglist* newactual;
+  gfc_symtree* target;
+
+  /* For now, we simply transform it into a EXPR_FUNCTION call with the same
+     arglist to the TBP's binding target.  */
+
+  if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
+    return FAILURE;
+
+  e->value.function.actual = newactual;
+  e->symtree = target;
+  e->expr_type = EXPR_FUNCTION;
+
+  return gfc_resolve_expr (e);
+}
+
+
 /* Resolve an expression.  That is, make sure that types of operands agree
    with their operators, intrinsic operators are converted to function calls
    for overloaded types and unresolved function references are resolved.  */
@@ -4317,6 +4452,10 @@ gfc_resolve_expr (gfc_expr *e)
 
       break;
 
+    case EXPR_COMPCALL:
+      t = resolve_compcall (e);
+      break;
+
     case EXPR_SUBSTRING:
       t = resolve_ref (e);
       break;
@@ -4786,7 +4925,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 		pointer = 0;
 		break;
 	    }
-       }
+	}
     }
 
   if (allocatable == 0 && pointer == 0)
@@ -6201,7 +6340,9 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	    omp_workshare_flag = omp_workshare_save;
 	}
 
-      t = gfc_resolve_expr (code->expr);
+      t = SUCCESS;
+      if (code->op != EXEC_COMPCALL)
+	t = gfc_resolve_expr (code->expr);
       forall_flag = forall_save;
 
       if (gfc_resolve_expr (code->expr2) == FAILURE)
@@ -6307,6 +6448,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  resolve_call (code);
 	  break;
 
+	case EXEC_COMPCALL:
+	  resolve_typebound_call (code);
+	  break;
+
 	case EXEC_SELECT:
 	  /* Select is complicated. Also, a SELECT construct could be
 	     a transformed computed GOTO.  */
@@ -7842,7 +7987,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	     and look for it.  */
 
 	  me_arg = NULL;
-	  stree->typebound->pass_arg_num = 0;
+	  stree->typebound->pass_arg_num = 1;
 	  for (i = proc->formal; i; i = i->next)
 	    {
 	      if (!strcmp (i->sym->name, stree->typebound->pass_arg))
@@ -7866,7 +8011,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
 	{
 	  /* Otherwise, take the first one; there should in fact be at least
 	     one.  */
-	  stree->typebound->pass_arg_num = 0;
+	  stree->typebound->pass_arg_num = 1;
 	  if (!proc->formal)
 	    {
 	      gfc_error ("Procedure '%s' with PASS at %L must have at"
@@ -7886,6 +8031,10 @@ resolve_typebound_procedure (gfc_symtree* stree)
 		     me_arg->name, &where, resolve_bindings_derived->name);
 	  goto error;
 	}
+
+      gfc_warning ("Polymorphic entities are not yet implemented,"
+		   " non-polymorphic passed-object dummy argument of '%s'"
+		   " at %L accepted", proc->name, &where);
     }
 
   /* If we are extending some type, check that we don't override a procedure
@@ -7893,7 +8042,8 @@ resolve_typebound_procedure (gfc_symtree* stree)
   if (super_type)
     {
       gfc_symtree* overridden;
-      overridden = gfc_find_typebound_proc (super_type, stree->name);
+      overridden = gfc_find_typebound_proc (super_type, NULL,
+					    stree->name, true);
 
       if (overridden && check_typebound_override (stree, overridden) == FAILURE)
 	goto error;
@@ -7918,15 +8068,6 @@ resolve_typebound_procedure (gfc_symtree* stree)
       goto error;
     }
 
-  /* FIXME: Remove once typebound-procedures are fully implemented.  */
-  {
-    /* Output the error only once so we can do reasonable testing.  */
-    static bool tbp_error = false;
-    if (!tbp_error)
-      gfc_error ("Type-bound procedures are not yet implemented at %L", &where);
-    tbp_error = true;
-  }
-
   return;
 
 error:
@@ -7984,7 +8125,8 @@ resolve_fl_derived (gfc_symbol *sym)
     {
       /* If this type is an extension, see if this component has the same name
 	 as an inherited type-bound procedure.  */
-      if (super_type && gfc_find_typebound_proc (super_type, c->name))
+      if (super_type
+	  && gfc_find_typebound_proc (super_type, NULL, c->name, true))
 	{
 	  gfc_error ("Component '%s' of '%s' at %L has the same name as an"
 		     " inherited type-bound procedure",
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 790dec6..81d861a 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -108,6 +108,8 @@ gfc_free_statement (gfc_code *p)
     case EXEC_ARITHMETIC_IF:
       break;
 
+    case EXEC_COMPCALL:
+      gfc_free_expr (p->expr);
     case EXEC_CALL:
     case EXEC_ASSIGN_CALL:
       gfc_free_actual_arglist (p->ext.actual);
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 2eed9fe..0b202eb 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4266,15 +4266,37 @@ gfc_get_derived_super_type (gfc_symbol* derived)
    through the super-types).  */
 
 gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, const char* name)
+gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+			 const char* name, bool noaccess)
 {
   gfc_symtree* res;
 
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
   /* Try to find it in the current type's namespace.  */
   gcc_assert (derived->f2k_derived);
   res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
   if (res)
-    return res->typebound ? res : NULL;
+    {
+      if (!res->typebound)
+	return NULL;
+
+      /* We found one.  */
+      if (t)
+	*t = SUCCESS;
+
+      if (!noaccess && derived->attr.use_assoc
+	  && res->typebound->access == ACCESS_PRIVATE)
+	{
+	  gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
+	  if (t)
+	    *t = FAILURE;
+	}
+
+      return res;
+    }
 
   /* Otherwise, recurse on parent type if derived is an extension.  */
   if (derived->attr.extension)
@@ -4282,7 +4304,7 @@ gfc_find_typebound_proc (gfc_symbol* derived, const char* name)
       gfc_symbol* super_type;
       super_type = gfc_get_derived_super_type (derived);
       gcc_assert (super_type);
-      return gfc_find_typebound_proc (super_type, name);
+      return gfc_find_typebound_proc (super_type, t, name, noaccess);
     }
 
   /* Nothing found.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e91434f..6c08978 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2011,6 +2011,10 @@ gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
     case EXPR_STRUCTURE:
       gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
       break;
+
+    case EXPR_COMPCALL:
+      gcc_unreachable ();
+      break;
     }
 
   return;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index bbb129d..ecb5687 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -901,6 +901,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 		  case AR_FULL:
 		    break;
 		  }
+		break;
 	      }
 	    }
 	}
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index e559a2a..11a1f40 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -498,6 +498,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
   e1->symtree = symtree1;
   e1->ts = sym->ts;
   e1->ref = ref = gfc_get_ref ();
+  ref->type = REF_ARRAY;
   ref->u.ar.where = where;
   ref->u.ar.as = sym->as;
   ref->u.ar.type = AR_FULL;