This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran] PR39630: Procedure Pointer Components, Part 1 (NOPASS only)


Hi all,

my patch for PPCs has been in the making for some time now, and it's
finally getting close to being committable. The most notable omission
in the patch is the PASS feature, which I decided to leave out for a
start. But there are also some other things missing (which have been
marked with TODOs in the patch):

1) PASS
2) PPC assignment checking (-> gfc_check_pointer assign)
3) copying formal args from the interface (-> resolve_fl_derived)
4) check actual args (-> resolve_ppc_call, resolve_expr_ppc)
5) include formal args in backend_decl (->gfc_get_ppc_type)

My plan would be to add these in a follow-up patch, but if someone
thinks it would be important to include any of them in this first
patch, please let me know.

In general my design goal for this patch was to have a solid
implementation of NOPASS PPCs, which makes all (basic) usage-cases
work (minus some checking). Another minimal goal was to make the
WHIZARD-2.0 code work (http://whizard.event-generator.org/), which
makes heavy use of PPCs. I think this is accomplished with the present
version of the patch (maybe someone of the WHIZARD people can confirm
this?).

Before I forget it, props go to Paul for constructing a good portion
of this patch, to Tobias for lots of testing and good advice, and to
Juergen Reuter for providing the WHIZARD 2.0 alpha source code, which
proved to be a valuable source of PPC test cases.

I hope the patch can be committed soon, unless anyone finds any
further issues. Regression-test on x86_64-unknown-linux-gnu succeeded
without any failures. Ok for trunk?

Cheers,
Janus



2009-05-04  Janus Weil  <janus@gcc.gnu.org>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/39630
	* decl.c (match_procedure_interface): New function to match the
	interface for a PROCEDURE statement.
	(match_procedure_decl): Call match_procedure_interface.
	(match_ppc_decl): New function to match the declaration of a
	procedure pointer component.
	(gfc_match_procedure):  Call match_ppc_decl.
	(match_binding_attributes): Add new argument 'ppc' and handle the
	POINTER attribute for procedure pointer components.
	(match_procedure_in_type,gfc_match_generic): Added new argument to
	match_binding_attributes.
	* expr.c (free_expr0,gfc_copy_expr,gfc_simplify_expr): Handle EXPR_PPC.
	(gfc_check_pointer_assign): Handle procedure pointer components, but no
	full checking yet.
	(is_proc_ptr_comp): New function to determine if an expression is a
	procedure pointer component.
	* gfortran.h (expr_t): Add EXPR_PPC.
	(symbol_attribute): Add new member 'proc_pointer_comp'.
	(gfc_component): Add new member 'formal'.
	(gfc_exec_op): Add EXEC_CALL_PPC.
	(gfc_get_default_type): Changed first argument.
	(is_proc_ptr_comp): Add prototype.
	(gfc_match_varspec): Add new argument.
	* interface.c (compare_actual_formal): Handle procedure pointer
	components.
	* match.c (gfc_match_pointer_assignment,match_typebound_call): Handle
	procedure pointer components.
	* module.c (mio_expr): Handle EXPR_PPC.
	* parse.c (parse_derived): Handle procedure pointer components.
	* primary.c (gfc_match_varspec): Add new argument 'ppc_arg' and handle
	procedure pointer components.
	(gfc_variable_attr): Handle procedure pointer components.
	(gfc_match_rvalue): Added new argument to gfc_match_varspec and changed
	first argument of gfc_get_default_type.
	(match_variable): Added new argument to gfc_match_varspec.
	* resolve.c (resolve_entries,set_type,resolve_fl_parameter): Changed
	first argument of gfc_get_default_type.
	(resolve_structure_cons,resolve_actual_arglist): Handle procedure
	pointer components.
	(resolve_ppc_call): New function to resolve a call to a procedure
	pointer component (subroutine).
	(resolve_expr_ppc): New function to resolve a call to a procedure
	pointer component (function).
	(gfc_resolve_expr): Handle EXPR_PPC.
	(resolve_code): Handle EXEC_CALL_PPC.
	(resolve_fl_derived): Copy the interface for a procedure pointer
	component.
	(resolve_symbol): Fix overlong line.
	* st.c (gfc_free_statement): Handle EXEC_CALL_PPC.
	* symbol.c (gfc_get_default_type): Changed first argument.
	(gfc_set_default_type): Changed first argument of gfc_get_default_type.
	(gfc_add_component): Initialize ts.type to BT_UNKNOWN.
	* trans.h (gfc_conv_function_call): Renamed.
	* trans.c (gfc_trans_code): Handle EXEC_CALL_PPC.
	* trans-expr.c (gfc_conv_component_ref): Ditto.
	(gfc_conv_function_val): Rename to 'conv_function_val', add new
	argument 'expr' and handle procedure pointer components.
	(gfc_conv_operator_assign): Renamed gfc_conv_function_val.
	(gfc_apply_interface_mapping_to_expr): Handle EXPR_PPC.
	(gfc_conv_function_call): Rename to 'gfc_conv_procedure_call', add new
	argument 'expr' and handle procedure pointer components.
	(gfc_get_proc_ptr_comp): New function to get the backend decl for a
	procedure pointer component.
	(gfc_conv_function_expr): Renamed gfc_conv_function_call.
	(gfc_conv_structure): Handle procedure pointer components.
	* trans-intrinsic.c (gfc_conv_intrinsic_funcall,
	conv_generic_with_optional_char_arg): Renamed gfc_conv_function_call.
	* trans-stmt.h (gfc_get_proc_ptr_comp): Add prototype.
	* trans-stmt.c (gfc_trans_call): Renamed gfc_conv_function_call.
	* trans-types.h (gfc_get_ppc_type): Add prototype.
	* trans-types.c (gfc_get_ppc_type): New function to build a tree node
	for a procedure pointer component.
	(gfc_get_derived_type): Handle procedure pointer components.


2009-05-04  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/39630
	* gfortran.dg/proc_decl_1.f90: Modified.
	* gfortran.dg/proc_ptr_comp_1.f90: New.
	* gfortran.dg/proc_ptr_comp_2.f90: New.
	* gfortran.dg/proc_ptr_comp_3.f90: New.
	* gfortran.dg/proc_ptr_comp_4.f90: New.
	* gfortran.dg/proc_ptr_comp_5.f90: New.
	* gfortran.dg/proc_ptr_comp_6.f90: New.
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90	(revision 147105)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90	(working copy)
@@ -47,10 +47,6 @@ program prog
   procedure(dcos) :: my1
   procedure(amax0) :: my2  ! { dg-error "not allowed in PROCEDURE statement" }
 
-  type t
-    procedure(),pointer:: p  ! { dg-error "not yet implemented" }
-  end type
-
   real f, x
   f(x) = sin(x**2)
   external oo
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 147105)
+++ gcc/fortran/interface.c	(working copy)
@@ -1864,7 +1864,8 @@ compare_actual_formal (gfc_actual_arglis
       /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
 	 is provided for a procedure pointer formal argument.  */
       if (f->sym->attr.proc_pointer
-	  && !a->expr->symtree->n.sym->attr.proc_pointer)
+	  && !(a->expr->symtree->n.sym->attr.proc_pointer
+	       || is_proc_ptr_comp (a->expr, NULL)))
 	{
 	  if (where)
 	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
@@ -1874,7 +1875,7 @@ compare_actual_formal (gfc_actual_arglis
 
       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
 	 provided for a procedure formal argument.  */
-      if (a->expr->ts.type != BT_PROCEDURE
+      if (a->expr->ts.type != BT_PROCEDURE && !is_proc_ptr_comp (a->expr, NULL)
 	  && a->expr->expr_type == EXPR_VARIABLE
 	  && f->sym->attr.flavor == FL_PROCEDURE)
 	{
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 147105)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -476,7 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc
       se->string_length = tmp;
     }
 
-  if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+  if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0
+      && c->ts.type != BT_CHARACTER)
     se->expr = build_fold_indirect_ref (se->expr);
 }
 
@@ -1487,11 +1488,13 @@ gfc_build_compare_string (tree len1, tre
 }
 
 static void
-gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 {
   tree tmp;
 
-  if (sym->attr.dummy)
+  if (is_proc_ptr_comp (expr, NULL))
+    tmp = gfc_get_proc_ptr_comp (se, expr);
+  else if (sym->attr.dummy)
     {
       tmp = gfc_get_symbol_decl (sym);
       if (sym->attr.proc_pointer)
@@ -1527,7 +1530,7 @@ gfc_conv_function_val (gfc_se * se, gfc_
 
 
 /* Translate the call for an elemental subroutine call used in an operator
-   assignment.  This is a simplified version of gfc_conv_function_call.  */
+   assignment.  This is a simplified version of gfc_conv_procedure_call.  */
 
 tree
 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
@@ -1556,7 +1559,7 @@ gfc_conv_operator_assign (gfc_se *lse, g
 
   /* Build the function call.  */
   gfc_init_se (&se, NULL);
-  gfc_conv_function_val (&se, sym);
+  conv_function_val (&se, sym, NULL);
   tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
   tmp = build_call_list (tmp, se.expr, args);
   gfc_add_expr_to_block (&block, tmp);
@@ -2133,6 +2136,7 @@ gfc_apply_interface_mapping_to_expr (gfc
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -2402,11 +2406,13 @@ conv_arglist_function (gfc_se *se, gfc_e
 
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
-   Return nonzero, if the call has alternate specifiers.  */
+   Return nonzero, if the call has alternate specifiers.
+   'expr' is only needed for procedure pointer components.  */
 
 int
-gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
-			gfc_actual_arglist * arg, tree append_args)
+gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
+			 gfc_actual_arglist * arg, gfc_expr * expr,
+			 tree append_args)
 {
   gfc_interface_mapping mapping;
   tree arglist;
@@ -2496,16 +2502,20 @@ gfc_conv_function_call (gfc_se * se, gfc
 	  gfc_add_block_to_block (&se->post, &cptrse.post);
 
 	  gfc_init_se (&fptrse, NULL);
-	  if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
-	      fptrse.want_pointer = 1;
+	  if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+	      || is_proc_ptr_comp (arg->next->expr, NULL))
+	    fptrse.want_pointer = 1;
 
 	  gfc_conv_expr (&fptrse, arg->next->expr);
 	  gfc_add_block_to_block (&se->pre, &fptrse.pre);
 	  gfc_add_block_to_block (&se->post, &fptrse.post);
 
-	  tmp = arg->next->expr->symtree->n.sym->backend_decl;
-	  se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
-				  fold_convert (TREE_TYPE (tmp), cptrse.expr));
+	  if (is_proc_ptr_comp (arg->next->expr, NULL))
+	    tmp = gfc_get_ppc_type (arg->next->expr->ref->u.c.component);
+	  else
+	    tmp = TREE_TYPE (arg->next->expr->symtree->n.sym->backend_decl);
+	  se->expr = fold_build2 (MODIFY_EXPR, tmp, fptrse.expr,
+				  fold_convert (tmp, cptrse.expr));
 
 	  return 0;
 	}
@@ -2942,7 +2952,7 @@ gfc_conv_function_call (gfc_se * se, gfc
     arglist = chainon (arglist, append_args);
 
   /* Generate the actual call.  */
-  gfc_conv_function_val (se, sym);
+  conv_function_val (se, sym, expr);
 
   /* If there are alternate return labels, function type should be
      integer.  Can't modify the type in place though, since it can be shared
@@ -2969,7 +2979,8 @@ gfc_conv_function_call (gfc_se * se, gfc
      something like
         x = f()
      where f is pointer valued, we have to dereference the result.  */
-  if (!se->want_pointer && !byref && sym->attr.pointer)
+  if (!se->want_pointer && !byref && sym->attr.pointer
+      && !is_proc_ptr_comp (expr, NULL))
     se->expr = build_fold_indirect_ref (se->expr);
 
   /* f2c calling conventions require a scalar default real function to
@@ -3346,6 +3357,19 @@ gfc_conv_statement_function (gfc_se * se
 }
 
 
+/* Return the backend_decl for a procedure pointer component.  */
+
+tree gfc_get_proc_ptr_comp (gfc_se *se, gfc_expr *e)
+{
+  gfc_se comp_se;
+  gfc_init_se (&comp_se, NULL);
+  e->expr_type = EXPR_VARIABLE;
+  gfc_conv_expr (&comp_se, e);
+  comp_se.expr = build_fold_addr_expr (comp_se.expr);
+  return gfc_evaluate_now (comp_se.expr, &se->pre);  
+}
+
+
 /* Translate a function expression.  */
 
 static void
@@ -3372,7 +3396,9 @@ gfc_conv_function_expr (gfc_se * se, gfc
   sym = expr->value.function.esym;
   if (!sym)
     sym = expr->symtree->n.sym;
-  gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
+
+  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+			  NULL_TREE);
 }
 
 
@@ -3794,7 +3820,8 @@ gfc_conv_structure (gfc_se * se, gfc_exp
         continue;
 
       val = gfc_conv_initializer (c->expr, &cm->ts,
-	  TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
+	  TREE_TYPE (cm->backend_decl), cm->attr.dimension,
+	  cm->attr.pointer || cm->attr.proc_pointer);
 
       /* Append it to the constructor list.  */
       CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 147105)
+++ gcc/fortran/symbol.c	(working copy)
@@ -219,11 +219,11 @@ gfc_merge_new_implicit (gfc_typespec *ts
 /* Given a symbol, return a pointer to the typespec for its default type.  */
 
 gfc_typespec *
-gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
+gfc_get_default_type (const char *name, gfc_namespace *ns)
 {
   char letter;
 
-  letter = sym->name[0];
+  letter = name[0];
 
   if (gfc_option.flag_allow_leading_underscore && letter == '_')
     gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
@@ -231,7 +231,7 @@ gfc_get_default_type (gfc_symbol *sym, g
 			"implicitly typed variables");
 
   if (letter < 'a' || letter > 'z')
-    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym->name);
+    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
 
   if (ns == NULL)
     ns = gfc_current_ns;
@@ -252,7 +252,7 @@ gfc_set_default_type (gfc_symbol *sym, i
   if (sym->ts.type != BT_UNKNOWN)
     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
 
-  ts = gfc_get_default_type (sym, ns);
+  ts = gfc_get_default_type (sym->name, ns);
 
   if (ts->type == BT_UNKNOWN)
     {
@@ -1779,6 +1779,7 @@ gfc_add_component (gfc_symbol *sym, cons
 
   p->name = gfc_get_string (name);
   p->loc = gfc_current_locus;
+  p->ts.type = BT_UNKNOWN;
 
   *component = p;
   return SUCCESS;
@@ -4494,3 +4495,4 @@ gfc_get_tbp_symtree (gfc_symtree **root,
 
   return result;
 }
+
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 147105)
+++ gcc/fortran/decl.c	(working copy)
@@ -4145,17 +4145,14 @@ add_hidden_procptr_result (gfc_symbol *s
 }
 
 
-/* Match a PROCEDURE declaration (R1211).  */
+/* Match the interface for a PROCEDURE declaration,
+   including brackets (R1212).  */
 
 static match
-match_procedure_decl (void)
+match_procedure_interface (gfc_symbol **proc_if)
 {
   match m;
   locus old_loc, entry_loc;
-  gfc_symbol *sym, *proc_if = NULL;
-  int num;
-  gfc_expr *initializer = NULL;
-
   old_loc = entry_loc = gfc_current_locus;
 
   gfc_clear_ts (&current_ts);
@@ -4180,45 +4177,43 @@ match_procedure_decl (void)
 
   /* Get the name of the procedure or abstract interface
   to inherit the interface from.  */
-  m = gfc_match_symbol (&proc_if, 1);
-
-  if (m == MATCH_NO)
-    goto syntax;
-  else if (m == MATCH_ERROR)
+  m = gfc_match_symbol (proc_if, 1);
+  if (m != MATCH_YES)
     return m;
 
   /* Various interface checks.  */
-  if (proc_if)
+  if (*proc_if)
     {
-      proc_if->refs++;
+      (*proc_if)->refs++;
       /* Resolve interface if possible. That way, attr.procedure is only set
 	 if it is declared by a later procedure-declaration-stmt, which is
 	 invalid per C1212.  */
-      while (proc_if->ts.interface)
-	proc_if = proc_if->ts.interface;
+      while ((*proc_if)->ts.interface)
+	*proc_if = (*proc_if)->ts.interface;
 
-      if (proc_if->generic)
+      if ((*proc_if)->generic)
 	{
-	  gfc_error ("Interface '%s' at %C may not be generic", proc_if->name);
+	  gfc_error ("Interface '%s' at %C may not be generic",
+		     (*proc_if)->name);
 	  return MATCH_ERROR;
 	}
-      if (proc_if->attr.proc == PROC_ST_FUNCTION)
+      if ((*proc_if)->attr.proc == PROC_ST_FUNCTION)
 	{
 	  gfc_error ("Interface '%s' at %C may not be a statement function",
-		    proc_if->name);
+		     (*proc_if)->name);
 	  return MATCH_ERROR;
 	}
       /* Handle intrinsic procedures.  */
-      if (!(proc_if->attr.external || proc_if->attr.use_assoc
-	    || proc_if->attr.if_source == IFSRC_IFBODY)
-	  && (gfc_is_intrinsic (proc_if, 0, gfc_current_locus)
-	      || gfc_is_intrinsic (proc_if, 1, gfc_current_locus)))
-	proc_if->attr.intrinsic = 1;
-      if (proc_if->attr.intrinsic
-	  && !gfc_intrinsic_actual_ok (proc_if->name, 0))
+      if (!((*proc_if)->attr.external || (*proc_if)->attr.use_assoc
+	    || (*proc_if)->attr.if_source == IFSRC_IFBODY)
+	  && (gfc_is_intrinsic ((*proc_if), 0, gfc_current_locus)
+	      || gfc_is_intrinsic ((*proc_if), 1, gfc_current_locus)))
+	(*proc_if)->attr.intrinsic = 1;
+      if ((*proc_if)->attr.intrinsic
+	  && !gfc_intrinsic_actual_ok ((*proc_if)->name, 0))
 	{
 	  gfc_error ("Intrinsic procedure '%s' not allowed "
-		    "in PROCEDURE statement at %C", proc_if->name);
+		    "in PROCEDURE statement at %C", (*proc_if)->name);
 	  return MATCH_ERROR;
 	}
     }
@@ -4230,7 +4225,26 @@ got_ts:
       return MATCH_NO;
     }
 
-  /* Parse attributes.  */
+  return MATCH_YES;
+}
+
+
+/* Match a PROCEDURE declaration (R1211).  */
+
+static match
+match_procedure_decl (void)
+{
+  match m;
+  gfc_symbol *sym, *proc_if = NULL;
+  int num;
+  gfc_expr *initializer = NULL;
+
+  /* Parse interface (with brackets). */
+  m = match_procedure_interface (&proc_if);
+  if (m != MATCH_YES)
+    return m;
+
+  /* Parse attributes (with colons).  */
   m = match_attr_spec();
   if (m == MATCH_ERROR)
     return MATCH_ERROR;
@@ -4360,6 +4374,138 @@ cleanup:
 }
 
 
+static match
+match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
+
+
+/* Match a procedure pointer component declaration (R445).  */
+
+static match
+match_ppc_decl (void)
+{
+  match m;
+  gfc_symbol *proc_if = NULL;
+  gfc_typespec ts;
+  int num;
+  gfc_component *c;
+  gfc_expr *initializer = NULL;
+  gfc_typebound_proc* tb;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  /* Parse interface (with brackets).  */
+  m = match_procedure_interface (&proc_if);
+  if (m != MATCH_YES)
+    goto syntax;
+
+  /* Parse attributes.  */
+  tb = XCNEW (gfc_typebound_proc);
+  tb->where = gfc_current_locus;
+  m = match_binding_attributes (tb, false, true);
+  if (m == MATCH_ERROR)
+    return m;
+
+  /* TODO: Implement PASS.  */
+  if (!tb->nopass)
+    {
+      gfc_error ("Procedure Pointer Component with PASS at %C "
+		 "not yet implemented");
+      return MATCH_ERROR;
+    }
+
+  gfc_clear_attr (&current_attr);
+  current_attr.procedure = 1;
+  current_attr.proc_pointer = 1;
+  current_attr.access = tb->access;
+  current_attr.flavor = FL_PROCEDURE;
+
+  /* Match the colons (required).  */
+  if (gfc_match (" ::") != MATCH_YES)
+    {
+      gfc_error ("Expected '::' after binding-attributes at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Check for C450.  */
+  if (!tb->nopass && proc_if == NULL)
+    {
+      gfc_error("NOPASS or explicit interface required at %C");
+      return MATCH_ERROR;
+    }
+
+  /* Match PPC names.  */
+  ts = current_ts;
+  for(num=1;;num++)
+    {
+      m = gfc_match_name (name);
+      if (m == MATCH_NO)
+	goto syntax;
+      else if (m == MATCH_ERROR)
+	return m;
+
+      if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
+	return MATCH_ERROR;
+
+      /* Add current_attr to the symbol attributes.  */
+      if (gfc_copy_attr (&c->attr, &current_attr, NULL) == FAILURE)
+	return MATCH_ERROR;
+
+      if (gfc_add_external (&c->attr, NULL) == FAILURE)
+	return MATCH_ERROR;
+
+      if (gfc_add_proc (&c->attr, name, NULL) == FAILURE)
+	return MATCH_ERROR;
+
+      /* Set interface.  */
+      if (proc_if != NULL)
+	{
+	  c->ts.interface = proc_if;
+	  c->attr.untyped = 1;
+	  c->attr.if_source = IFSRC_IFBODY;
+	}
+      else if (ts.type != BT_UNKNOWN)
+	{
+	  c->ts = ts;
+	  c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
+	  c->ts.interface->ts = ts;
+	  c->ts.interface->attr.function = 1;
+	  c->attr.function = c->ts.interface->attr.function;
+	  c->attr.if_source = IFSRC_UNKNOWN;
+	}
+
+      if (gfc_match (" =>") == MATCH_YES)
+	{
+	  m = gfc_match_null (&initializer);
+	  if (m == MATCH_NO)
+	    {
+	      gfc_error ("Pointer initialization requires a NULL() at %C");
+	      m = MATCH_ERROR;
+	    }
+	  if (gfc_pure (NULL))
+	    {
+	      gfc_error ("Initialization of pointer at %C is not allowed in "
+			 "a PURE procedure");
+	      m = MATCH_ERROR;
+	    }
+	  if (m != MATCH_YES)
+	    {
+	      gfc_free_expr (initializer);
+	      return m;
+	    }
+	  c->initializer = initializer;
+	}
+
+      if (gfc_match_eos () == MATCH_YES)
+	return MATCH_YES;
+      if (gfc_match_char (',') != MATCH_YES)
+	goto syntax;
+    }
+
+syntax:
+  gfc_error ("Syntax error in procedure pointer component at %C");
+  return MATCH_ERROR;
+}
+
+
 /* Match a PROCEDURE declaration inside an interface (R1206).  */
 
 static match
@@ -4425,9 +4571,8 @@ gfc_match_procedure (void)
       m = match_procedure_in_interface ();
       break;
     case COMP_DERIVED:
-      gfc_error ("Fortran 2003: Procedure components at %C are not yet"
-		 " implemented in gfortran");
-      return MATCH_ERROR;
+      m = match_ppc_decl ();
+      break;
     case COMP_DERIVED_CONTAINS:
       m = match_procedure_in_type ();
       break;
@@ -6830,9 +6975,10 @@ cleanup:
 /* Match binding attributes.  */
 
 static match
-match_binding_attributes (gfc_typebound_proc* ba, bool generic)
+match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
 {
   bool found_passing = false;
+  bool seen_ptr = false;
   match m;
 
   /* Intialize to defaults.  Do so even before the MATCH_NO check so that in
@@ -6907,38 +7053,6 @@ match_binding_attributes (gfc_typebound_
 	      continue;
 	    }
 
-	  /* NON_OVERRIDABLE flag.  */
-	  m = gfc_match (" non_overridable");
-	  if (m == MATCH_ERROR)
-	    goto error;
-	  if (m == MATCH_YES)
-	    {
-	      if (ba->non_overridable)
-		{
-		  gfc_error ("Duplicate NON_OVERRIDABLE at %C");
-		  goto error;
-		}
-
-	      ba->non_overridable = 1;
-	      continue;
-	    }
-
-	  /* DEFERRED flag.  */
-	  m = gfc_match (" deferred");
-	  if (m == MATCH_ERROR)
-	    goto error;
-	  if (m == MATCH_YES)
-	    {
-	      if (ba->deferred)
-		{
-		  gfc_error ("Duplicate DEFERRED at %C");
-		  goto error;
-		}
-
-	      ba->deferred = 1;
-	      continue;
-	    }
-
 	  /* PASS possibly including argument.  */
 	  m = gfc_match (" pass");
 	  if (m == MATCH_ERROR)
@@ -6966,6 +7080,60 @@ match_binding_attributes (gfc_typebound_
 	      continue;
 	    }
 
+	  if (ppc)
+	    {
+	      /* POINTER flag.  */
+	      m = gfc_match (" pointer");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (seen_ptr)
+		    {
+		      gfc_error ("Duplicate POINTER attribute at %C");
+		      goto error;
+		    }
+
+		  seen_ptr = true;
+		  /*ba->ppc = 1;*/
+        	  continue;
+		}
+	    }
+	  else
+	    {
+	      /* NON_OVERRIDABLE flag.  */
+	      m = gfc_match (" non_overridable");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (ba->non_overridable)
+		    {
+		      gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+		      goto error;
+		    }
+
+		  ba->non_overridable = 1;
+		  continue;
+		}
+
+	      /* DEFERRED flag.  */
+	      m = gfc_match (" deferred");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (ba->deferred)
+		    {
+		      gfc_error ("Duplicate DEFERRED at %C");
+		      goto error;
+		    }
+
+		  ba->deferred = 1;
+		  continue;
+		}
+	    }
+
 	}
 
       /* Nothing matching found.  */
@@ -6987,6 +7155,13 @@ match_binding_attributes (gfc_typebound_
   if (ba->access == ACCESS_UNKNOWN)
     ba->access = gfc_typebound_default_access;
 
+  if (ppc && !seen_ptr)
+    {
+      gfc_error ("POINTER attribute is required for procedure pointer component"
+                 " at %C");
+      goto error;
+    }
+
   return MATCH_YES;
 
 error:
@@ -7043,7 +7218,7 @@ match_procedure_in_type (void)
   tb->is_generic = 0;
 
   /* Match binding attributes.  */
-  m = match_binding_attributes (tb, false);
+  m = match_binding_attributes (tb, false, false);
   if (m == MATCH_ERROR)
     return m;
   seen_attrs = (m == MATCH_YES);
@@ -7192,7 +7367,7 @@ gfc_match_generic (void)
   gcc_assert (block && ns);
 
   /* See if we get an access-specifier.  */
-  m = match_binding_attributes (&tbattr, true);
+  m = match_binding_attributes (&tbattr, true, false);
   if (m == MATCH_ERROR)
     goto error;
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 147105)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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_COMPCALL
+  EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL, EXPR_PPC
 }
 expr_t;
 
@@ -698,9 +698,11 @@ typedef struct
   unsigned cray_pointer:1, cray_pointee:1;
 
   /* The symbol is a derived type with allocatable components, pointer 
-     components or private components, possibly nested.  zero_comp
-     is true if the derived type has no component at all.  */
-  unsigned alloc_comp:1, pointer_comp:1, private_comp:1, zero_comp:1;
+     components or private components, procedure pointer components,
+     possibly nested.  zero_comp is true if the derived type has no
+     component at all.  */
+  unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
+	   private_comp:1, zero_comp:1;
 
   /* The namespace where the VOLATILE attribute has been set.  */
   struct gfc_namespace *volatile_ns;
@@ -851,6 +853,8 @@ typedef struct gfc_component
   locus loc;
   struct gfc_expr *initializer;
   struct gfc_component *next;
+
+  struct gfc_formal_arglist *formal;
 }
 gfc_component;
 
@@ -1883,7 +1887,7 @@ typedef enum
   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_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
   EXEC_ALLOCATE, EXEC_DEALLOCATE,
   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
   EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
@@ -2265,7 +2269,7 @@ void gfc_set_implicit_none (void);
 void gfc_check_function_type (gfc_namespace *);
 bool gfc_is_intrinsic_typename (const char *);
 
-gfc_typespec *gfc_get_default_type (gfc_symbol *, gfc_namespace *);
+gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *);
 gfc_try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *);
 
 void gfc_set_sym_referenced (gfc_symbol *);
@@ -2484,6 +2488,8 @@ void gfc_expr_set_symbols_referenced (gf
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
 
+bool is_proc_ptr_comp (gfc_expr *, gfc_component **);
+
 /* st.c */
 extern gfc_code new_st;
 
@@ -2592,7 +2598,7 @@ void gfc_free_use_stmts (gfc_use_list *)
 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);
+match gfc_match_varspec (gfc_expr*, int, bool, bool);
 int gfc_check_digit (char, int);
 
 /* trans.c */
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 147105)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -356,8 +356,8 @@ gfc_trans_call (gfc_code * code, bool de
 
       /* Translate the call.  */
       has_alternate_specifier
-	= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual,
-				  NULL_TREE);
+	= gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
+				  code->expr, NULL_TREE);
 
       /* A subroutine without side-effect, by definition, does nothing!  */
       TREE_SIDE_EFFECTS (se.expr) = 1;
@@ -430,8 +430,8 @@ gfc_trans_call (gfc_code * code, bool de
       gfc_init_block (&block);
 
       /* Add the subroutine call to the block.  */
-      gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual,
-			      NULL_TREE);
+      gfc_conv_procedure_call (&loopse, code->resolved_sym, code->ext.actual,
+			      code->expr, NULL_TREE);
       gfc_add_expr_to_block (&loopse.pre, loopse.expr);
 
       gfc_add_block_to_block (&block, &loopse.pre);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 147105)
+++ gcc/fortran/expr.c	(working copy)
@@ -182,6 +182,7 @@ free_expr0 (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gfc_free_actual_arglist (e->value.compcall.actual);
       break;
 
@@ -507,6 +508,7 @@ gfc_copy_expr (gfc_expr *p)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       q->value.compcall.actual =
 	gfc_copy_actual_arglist (p->value.compcall.actual);
       q->value.compcall.tbp = p->value.compcall.tbp;
@@ -1728,6 +1730,7 @@ gfc_simplify_expr (gfc_expr *p, int type
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -3038,7 +3041,7 @@ gfc_check_pointer_assign (gfc_expr *lval
   symbol_attribute attr;
   gfc_ref *ref;
   int is_pure;
-  int pointer, check_intent_in;
+  int pointer, check_intent_in, proc_pointer;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
       && !lvalue->symtree->n.sym->attr.proc_pointer)
@@ -3062,8 +3065,8 @@ gfc_check_pointer_assign (gfc_expr *lval
   /* Check INTENT(IN), unless the object itself is the component or
      sub-component of a pointer.  */
   check_intent_in = 1;
-  pointer = lvalue->symtree->n.sym->attr.pointer
-	      | lvalue->symtree->n.sym->attr.proc_pointer;
+  pointer = lvalue->symtree->n.sym->attr.pointer;
+  proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
@@ -3071,7 +3074,10 @@ gfc_check_pointer_assign (gfc_expr *lval
 	check_intent_in = 0;
 
       if (ref->type == REF_COMPONENT)
-	pointer = ref->u.c.component->attr.pointer;
+	{
+	  pointer = ref->u.c.component->attr.pointer;
+	  proc_pointer = ref->u.c.component->attr.proc_pointer;
+	}
 
       if (ref->type == REF_ARRAY && ref->next == NULL)
 	{
@@ -3107,7 +3113,7 @@ gfc_check_pointer_assign (gfc_expr *lval
       return FAILURE;
     }
 
-  if (!pointer)
+  if (!pointer && !proc_pointer)
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
@@ -3129,11 +3135,12 @@ gfc_check_pointer_assign (gfc_expr *lval
     return SUCCESS;
 
   /* Checks on rvalue for procedure pointer assignments.  */
-  if (lvalue->symtree->n.sym->attr.proc_pointer)
+  if (proc_pointer)
     {
       attr = gfc_expr_attr (rvalue);
       if (!((rvalue->expr_type == EXPR_NULL)
 	    || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+	    || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
 	    || (rvalue->expr_type == EXPR_VARIABLE
 		&& attr.flavor == FL_PROCEDURE)))
 	{
@@ -3148,6 +3155,9 @@ gfc_check_pointer_assign (gfc_expr *lval
 		     rvalue->symtree->name, &rvalue->where);
 	  return FAILURE;
 	}
+      /* TODO: Enable interface check for PPCs.  */
+      if (is_proc_ptr_comp (rvalue, NULL))
+	return SUCCESS;
       if (rvalue->expr_type == EXPR_VARIABLE
 	  && !gfc_compare_interfaces (lvalue->symtree->n.sym,
 				      rvalue->symtree->n.sym, 0))
@@ -3481,6 +3491,34 @@ gfc_expr_set_symbols_referenced (gfc_exp
 }
 
 
+/* Determine if an expression is a procedure pointer component. If yes, the
+   argument 'comp' will point to the component (provided that 'comp' was
+   provided).  */
+
+bool
+is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+{
+  gfc_ref *ref;
+  bool ppc = false;
+
+  if (!expr || !expr->ref)
+    return false;
+
+  ref = expr->ref;
+  while (ref->next)
+    ref = ref->next;
+
+  if (ref->type == REF_COMPONENT)
+    {
+      ppc = ref->u.c.component->attr.proc_pointer;
+      if (ppc && comp)
+	*comp = ref->u.c.component;
+    }
+
+  return ppc;
+}
+
+
 /* Walk an expression tree and check each variable encountered for being typed.
    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
    mode as is a basic arithmetic expression using those; this is for things in
Index: gcc/fortran/trans-stmt.h
===================================================================
--- gcc/fortran/trans-stmt.h	(revision 147105)
+++ gcc/fortran/trans-stmt.h	(working copy)
@@ -29,6 +29,7 @@ tree gfc_trans_code (gfc_code *);
 tree gfc_trans_assign (gfc_code *);
 tree gfc_trans_pointer_assign (gfc_code *);
 tree gfc_trans_init_assign (gfc_code *);
+tree gfc_get_proc_ptr_comp (gfc_se *, gfc_expr *);
 
 /* trans-stmt.c */
 tree gfc_trans_cycle (gfc_code *);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 147105)
+++ gcc/fortran/module.c	(working copy)
@@ -3043,6 +3043,7 @@ mio_expr (gfc_expr **ep)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(revision 147105)
+++ gcc/fortran/trans.c	(working copy)
@@ -1115,6 +1115,10 @@ gfc_trans_code (gfc_code * code)
 	  }
 	  break;
 
+	case EXEC_CALL_PPC:
+	  res = gfc_trans_call (code, false);
+	  break;
+
 	case EXEC_ASSIGN_CALL:
 	  res = gfc_trans_call (code, true);
 	  break;
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 147105)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -1777,6 +1777,21 @@ copy_dt_decls_ifequal (gfc_symbol *from,
 }
 
 
+/* Build a tree node for a procedure pointer component.  */
+
+tree
+gfc_get_ppc_type (gfc_component* c)
+{
+  tree t;
+  if (c->attr.function)
+    t = gfc_typenode_for_spec (&c->ts);
+  else
+    t = void_type_node;
+  /* TODO: Build argument list.  */
+  return build_pointer_type (build_function_type (t, NULL_TREE));
+}
+
+
 /* Build a tree node for a derived type.  If there are equal
    derived types, with different local names, these are built
    at the same time.  If an equal derived type has been built
@@ -1823,16 +1838,9 @@ gfc_get_derived_type (gfc_symbol * deriv
   /* derived->backend_decl != 0 means we saw it before, but its
      components' backend_decl may have not been built.  */
   if (derived->backend_decl)
-    {
-      /* Its components' backend_decl have been built.  */
-      if (TYPE_FIELDS (derived->backend_decl))
-        return derived->backend_decl;
-      else
-        typenode = derived->backend_decl;
-    }
+    return derived->backend_decl;
   else
     {
-
       /* We see this derived type first time, so build the type node.  */
       typenode = make_node (RECORD_TYPE);
       TYPE_NAME (typenode) = get_identifier (derived->name);
@@ -1881,6 +1889,8 @@ gfc_get_derived_type (gfc_symbol * deriv
     {
       if (c->ts.type == BT_DERIVED)
         field_type = c->ts.derived->backend_decl;
+      else if (c->attr.proc_pointer)
+	field_type = gfc_get_ppc_type (c);
       else
 	{
 	  if (c->ts.type == BT_CHARACTER)
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 147105)
+++ gcc/fortran/trans.h	(working copy)
@@ -71,7 +71,7 @@ typedef struct gfc_se
      are NULL.  Used by intrinsic size.  */
   unsigned data_not_needed:1;
 
-  /* If set, gfc_conv_function_call does not put byref calls into se->pre.  */
+  /* If set, gfc_conv_procedure_call does not put byref calls into se->pre.  */
   unsigned no_function_call:1;
 
   /* Scalarization parameters.  */
@@ -313,9 +313,10 @@ int gfc_is_intrinsic_libcall (gfc_expr *
 /* Used to call the elemental subroutines used in operator assignments.  */
 tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *);
 
-/* Also used to CALL subroutines.  */
-int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
-			    tree);
+/* Used to call ordinary functions/subroutines
+   and procedure pointer components.  */
+int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
+			    gfc_expr *, tree);
 
 void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
 
Index: gcc/fortran/trans-types.h
===================================================================
--- gcc/fortran/trans-types.h	(revision 147105)
+++ gcc/fortran/trans-types.h	(working copy)
@@ -89,4 +89,6 @@ int gfc_is_nodesc_array (gfc_symbol *);
 /* Return the DTYPE for an array.  */
 tree gfc_get_dtype (tree);
 
+tree gfc_get_ppc_type (gfc_component *);
+
 #endif
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 147105)
+++ gcc/fortran/resolve.c	(working copy)
@@ -528,14 +528,14 @@ resolve_entries (gfc_namespace *ns)
       fas = fas ? fas : ns->entries->sym->result->as;
       fts = &ns->entries->sym->result->ts;
       if (fts->type == BT_UNKNOWN)
-	fts = gfc_get_default_type (ns->entries->sym->result, NULL);
+	fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
       for (el = ns->entries->next; el; el = el->next)
 	{
 	  ts = &el->sym->result->ts;
 	  as = el->sym->as;
 	  as = as ? as : el->sym->result->as;
 	  if (ts->type == BT_UNKNOWN)
-	    ts = gfc_get_default_type (el->sym->result, NULL);
+	    ts = gfc_get_default_type (el->sym->result->name, NULL);
 
 	  if (! gfc_compare_types (ts, fts)
 	      || (el->sym->result->attr.dimension
@@ -612,7 +612,7 @@ resolve_entries (gfc_namespace *ns)
 		{
 		  ts = &sym->ts;
 		  if (ts->type == BT_UNKNOWN)
-		    ts = gfc_get_default_type (sym, NULL);
+		    ts = gfc_get_default_type (sym->name, NULL);
 		  switch (ts->type)
 		    {
 		    case BT_INTEGER:
@@ -878,7 +878,8 @@ resolve_structure_cons (gfc_expr *expr)
 	}
 
       if (cons->expr->expr_type == EXPR_NULL
-	    && !(comp->attr.pointer || comp->attr.allocatable))
+	  && !(comp->attr.pointer || comp->attr.allocatable
+	       || comp->attr.proc_pointer))
 	{
 	  t = FAILURE;
 	  gfc_error ("The NULL in the derived type constructor at %L is "
@@ -1215,6 +1216,7 @@ resolve_actual_arglist (gfc_actual_argli
   gfc_symtree *parent_st;
   gfc_expr *e;
   int save_need_full_assumed_size;
+  gfc_component *comp;
 	
   for (; arg; arg = arg->next)
     {
@@ -1234,6 +1236,13 @@ resolve_actual_arglist (gfc_actual_argli
 	  continue;
 	}
 
+      if (is_proc_ptr_comp (e, &comp))
+	{
+	  e->ts = comp->ts;
+	  e->expr_type = EXPR_VARIABLE;
+	  goto argument_list;
+	}
+
       if (e->expr_type == EXPR_VARIABLE
 	    && e->symtree->n.sym->attr.generic
 	    && no_formal_args
@@ -1906,7 +1915,7 @@ set_type:
     expr->ts = sym->ts;
   else
     {
-      ts = gfc_get_default_type (sym, sym->ns);
+      ts = gfc_get_default_type (sym->name, sym->ns);
 
       if (ts->type == BT_UNKNOWN)
 	{
@@ -4804,6 +4813,61 @@ resolve_compcall (gfc_expr* e)
 }
 
 
+/* Resolve a CALL to a Procedure Pointer Component (Subroutine).  */
+
+static gfc_try
+resolve_ppc_call (gfc_code* c)
+{
+  gfc_component *comp;
+  gcc_assert (is_proc_ptr_comp (c->expr, &comp));
+
+  c->resolved_sym = c->expr->symtree->n.sym;
+  c->expr->expr_type = EXPR_VARIABLE;
+  c->ext.actual = c->expr->value.compcall.actual;
+
+  if (!comp->attr.subroutine)
+    gfc_add_subroutine (&comp->attr, comp->name, &c->expr->where);
+
+  if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
+			      comp->formal == NULL) == FAILURE)
+    return FAILURE;
+
+  /* TODO: Check actual arguments.
+     gfc_procedure_use (stree->n.sym, &c->expr->value.compcall.actual,
+			&c->expr->where);*/
+
+  return SUCCESS;
+}
+
+
+/* Resolve a Function Call to a Procedure Pointer Component (Function).  */
+
+static gfc_try
+resolve_expr_ppc (gfc_expr* e)
+{
+  gfc_component *comp;
+  gcc_assert (is_proc_ptr_comp (e, &comp));
+
+  /* Convert to EXPR_FUNCTION.  */
+  e->expr_type = EXPR_FUNCTION;
+  e->value.function.isym = NULL;
+  e->value.function.actual = e->value.compcall.actual;
+  e->ts = comp->ts;
+
+  if (!comp->attr.function)
+    gfc_add_function (&comp->attr, comp->name, &e->where);
+
+  if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
+			      comp->formal == NULL) == FAILURE)
+    return FAILURE;
+
+  /* TODO: Check actual arguments.
+     gfc_procedure_use (stree->n.sym, &e->value.compcall.actual, &e->where);  */
+
+  return SUCCESS;
+}
+
+
 /* 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.  */
@@ -4853,6 +4917,10 @@ gfc_resolve_expr (gfc_expr *e)
       t = SUCCESS;
       break;
 
+    case EXPR_PPC:
+      t = resolve_expr_ppc (e);
+      break;
+
     case EXPR_ARRAY:
       t = FAILURE;
       if (resolve_ref (e) == FAILURE)
@@ -6819,7 +6887,7 @@ resolve_code (gfc_code *code, gfc_namesp
 	}
 
       t = SUCCESS;
-      if (code->op != EXEC_COMPCALL)
+      if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
 	t = gfc_resolve_expr (code->expr);
       forall_flag = forall_save;
 
@@ -6931,6 +6999,10 @@ resolve_code (gfc_code *code, gfc_namesp
 	  resolve_typebound_call (code);
 	  break;
 
+	case EXEC_CALL_PPC:
+          resolve_ppc_call (code);
+	  break;
+
 	case EXEC_SELECT:
 	  /* Select is complicated. Also, a SELECT construct could be
 	     a transformed computed GOTO.  */
@@ -8906,6 +8978,78 @@ resolve_fl_derived (gfc_symbol *sym)
 
   for (c = sym->components; c != NULL; c = c->next)
     {
+      if (c->attr.proc_pointer && c->ts.interface)
+	{
+	  if (c->ts.interface->attr.procedure)
+	    gfc_error ("Interface '%s', used by procedure pointer component "
+		       "'%s' at %L, is declared in a later PROCEDURE statement",
+		       c->ts.interface->name, c->name, &c->loc);
+
+	  /* Get the attributes from the interface (now resolved).  */
+	  if (c->ts.interface->attr.if_source
+	      || c->ts.interface->attr.intrinsic)
+	    {
+	      gfc_symbol *ifc = c->ts.interface;
+
+	      if (ifc->attr.intrinsic)
+		resolve_intrinsic (ifc, &ifc->declared_at);
+
+	      if (ifc->result)
+		c->ts = ifc->result->ts;
+	      else   
+		c->ts = ifc->ts;
+	      c->ts.interface = ifc;
+	      c->attr.function = ifc->attr.function;
+	      c->attr.subroutine = ifc->attr.subroutine;
+	      /* TODO: gfc_copy_formal_args (c, ifc);  */
+
+	      c->attr.allocatable = ifc->attr.allocatable;
+	      c->attr.pointer = ifc->attr.pointer;
+	      c->attr.pure = ifc->attr.pure;
+	      c->attr.elemental = ifc->attr.elemental;
+	      c->attr.dimension = ifc->attr.dimension;
+	      c->attr.recursive = ifc->attr.recursive;
+	      c->attr.always_explicit = ifc->attr.always_explicit;
+	      /* Copy array spec.  */
+	      c->as = gfc_copy_array_spec (ifc->as);
+	      /*if (c->as)
+		{
+		  int i;
+		  for (i = 0; i < c->as->rank; i++)
+		    {
+		      gfc_expr_replace_symbols (c->as->lower[i], c);
+		      gfc_expr_replace_symbols (c->as->upper[i], c);
+		    }
+	        }*/
+	      /* Copy char length.  */
+	      if (ifc->ts.cl)
+		{
+		  c->ts.cl = gfc_get_charlen();
+	          c->ts.cl->resolved = ifc->ts.cl->resolved;
+		  c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
+		  /*gfc_expr_replace_symbols (c->ts.cl->length, c);*/
+		  /* Add charlen to namespace.  */
+		  /*if (c->formal_ns)
+		    {
+		      c->ts.cl->next = c->formal_ns->cl_list;
+		      c->formal_ns->cl_list = c->ts.cl;
+		    }*/
+		}
+	    }
+	  else if (c->ts.interface->name[0] != '\0')
+	    {
+	      gfc_error ("Interface '%s' of procedure pointer component "
+			 "'%s' at %L must be explicit", c->ts.interface->name,
+			 c->name, &c->loc);
+	      return FAILURE;
+ 	    }
+	}
+      else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
+	{
+	  c->ts = *gfc_get_default_type (c->name, NULL);
+	  c->attr.implicit_type = 1;
+	}
+
       /* Check type-spec if this is not the parent-type component.  */
       if ((!sym->attr.extension || c != sym->components)
 	  && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
@@ -9157,7 +9301,8 @@ resolve_fl_parameter (gfc_symbol *sym)
      matches the implicit type, since PARAMETER statements can precede
      IMPLICIT statements.  */
   if (sym->attr.implicit_type
-      && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
+      && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
+							     sym->ns)))
     {
       gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
 		 "later IMPLICIT type", sym->name, &sym->declared_at);
@@ -9237,7 +9382,8 @@ resolve_symbol (gfc_symbol *sym)
 		   sym->name,&sym->declared_at);
 
       /* Get the attributes from the interface (now resolved).  */
-      if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+      if (sym->ts.interface->attr.if_source
+	  || sym->ts.interface->attr.intrinsic)
 	{
 	  gfc_symbol *ifc = sym->ts.interface;
 
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c	(revision 147105)
+++ gcc/fortran/st.c	(working copy)
@@ -110,6 +110,7 @@ gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_COMPCALL:
+    case EXEC_CALL_PPC:
     case EXEC_CALL:
     case EXEC_ASSIGN_CALL:
       gfc_free_actual_arglist (p->ext.actual);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 147105)
+++ gcc/fortran/match.c	(working copy)
@@ -1336,7 +1336,8 @@ gfc_match_pointer_assignment (void)
       goto cleanup;
     }
 
-  if (lvalue->symtree->n.sym->attr.proc_pointer)
+  if (lvalue->symtree->n.sym->attr.proc_pointer
+      || is_proc_ptr_comp (lvalue, NULL))
     gfc_matching_procptr_assignment = 1;
 
   m = gfc_match (" %e%t", &rvalue);
@@ -2629,7 +2630,7 @@ match_typebound_call (gfc_symtree* varst
   base->where = gfc_current_locus;
   gfc_set_sym_referenced (varst->n.sym);
   
-  m = gfc_match_varspec (base, 0, true);
+  m = gfc_match_varspec (base, 0, true, true);
   if (m == MATCH_NO)
     gfc_error ("Expected component reference at %C");
   if (m != MATCH_YES)
@@ -2641,13 +2642,16 @@ match_typebound_call (gfc_symtree* varst
       return MATCH_ERROR;
     }
 
-  if (base->expr_type != EXPR_COMPCALL)
+  if (base->expr_type == EXPR_COMPCALL)
+    new_st.op = EXEC_COMPCALL;
+  else if (base->expr_type == EXPR_PPC)
+    new_st.op = EXEC_CALL_PPC;
+  else
     {
-      gfc_error ("Expected type-bound procedure reference at %C");
+      gfc_error ("Expected type-bound procedure or procedure pointer component "
+		 "at %C");
       return MATCH_ERROR;
     }
-
-  new_st.op = EXEC_COMPCALL;
   new_st.expr = base;
 
   return MATCH_YES;
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 147105)
+++ gcc/fortran/parse.c	(working copy)
@@ -1878,15 +1878,11 @@ parse_derived (void)
 	  unexpected_eof ();
 
 	case ST_DATA_DECL:
+	case ST_PROCEDURE:
 	  accept_statement (st);
 	  seen_component = 1;
 	  break;
 
-	case ST_PROCEDURE:
-	  gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
-	  error_flag = 1;
-	  break;
-
 	case ST_FINAL:
 	  gfc_error ("FINAL declaration at %C must be inside CONTAINS");
 	  error_flag = 1;
@@ -1993,6 +1989,12 @@ endType:
 	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
 	sym->attr.pointer_comp = 1;
 
+      /* Look for procedure pointer components.  */
+      if (c->attr.proc_pointer
+	  || (c->ts.type == BT_DERIVED
+	      && c->ts.derived->attr.proc_pointer_comp))
+	sym->attr.proc_pointer_comp = 1;
+
       /* Look for private components.  */
       if (sym->component_access == ACCESS_PRIVATE
 	  || c->attr.access == ACCESS_PRIVATE
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 147105)
+++ gcc/fortran/primary.c	(working copy)
@@ -1708,10 +1708,13 @@ extend_ref (gfc_expr *primary, gfc_ref *
    variable like member references or substrings.  If equiv_flag is
    set we only match stuff that is allowed inside an EQUIVALENCE
    statement.  sub_flag tells whether we expect a type-bound procedure found
-   to be a subroutine as part of CALL or a FUNCTION.  */
+   to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
+   components, 'ppc_arg' determines whether the PPC may be called (with an
+   argument list), or whether it may just be referred to as a pointer.  */
 
 match
-gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
+		   bool ppc_arg)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_ref *substring, *tail;
@@ -1754,7 +1757,7 @@ gfc_match_varspec (gfc_expr *primary, in
     return MATCH_YES;
 
   if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
-      && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+      && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     gfc_set_default_type (sym, 0, sym->ns);
 
   if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
@@ -1826,6 +1829,20 @@ gfc_match_varspec (gfc_expr *primary, in
 
       primary->ts = component->ts;
 
+      if (component->attr.proc_pointer && ppc_arg
+	  && !gfc_matching_procptr_assignment)
+	{
+	  primary->expr_type = EXPR_PPC;
+	  m = gfc_match_actual_arglist (component->attr.subroutine,
+					&primary->value.compcall.actual);
+	  if (m == MATCH_ERROR)
+	    return MATCH_ERROR;
+	  if (m == MATCH_NO)
+	    primary->value.compcall.actual = NULL;
+
+          break;
+	}
+
       if (component->as != NULL)
 	{
 	  tail = extend_ref (primary, tail);
@@ -1847,7 +1864,7 @@ check_substring:
   unknown = false;
   if (primary->ts.type == BT_UNKNOWN)
     {
-      if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
+      if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
        {
 	 gfc_set_default_type (sym, 0, sym->ns);
 	 primary->ts = sym->ts;
@@ -1925,7 +1942,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
   allocatable = attr.allocatable;
 
   target = attr.target;
-  if (pointer)
+  if (pointer || attr.proc_pointer)
     target = 1;
 
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
@@ -1971,7 +1988,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
 
 	pointer = ref->u.c.component->attr.pointer;
 	allocatable = ref->u.c.component->attr.allocatable;
-	if (pointer)
+	if (pointer || attr.proc_pointer)
 	  target = 1;
 
 	break;
@@ -2478,7 +2495,7 @@ gfc_match_rvalue (gfc_expr **result)
       e->expr_type = EXPR_VARIABLE;
       e->symtree = symtree;
 
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
       break;
 
     case FL_PARAMETER:
@@ -2495,7 +2512,7 @@ gfc_match_rvalue (gfc_expr **result)
 	}
 
       e->symtree = symtree;
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
 
       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
 	break;
@@ -2551,7 +2568,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e = gfc_get_expr ();
 	  e->expr_type = EXPR_VARIABLE;
 	  e->symtree = symtree;
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2578,7 +2595,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e->symtree = symtree;
 	  e->expr_type = EXPR_VARIABLE;
 
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2658,7 +2675,7 @@ gfc_match_rvalue (gfc_expr **result)
 
       if (gfc_peek_ascii_char () == '%'
 	  && sym->ts.type == BT_UNKNOWN
-	  && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
+	  && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
 	gfc_set_default_type (sym, 0, sym->ns);
 
       /* If the symbol has a dimension attribute, the expression is a
@@ -2676,7 +2693,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e = gfc_get_expr ();
 	  e->symtree = symtree;
 	  e->expr_type = EXPR_VARIABLE;
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2701,7 +2718,7 @@ gfc_match_rvalue (gfc_expr **result)
 
 	  /*FIXME:??? gfc_match_varspec does set this for us: */
 	  e->ts = sym->ts;
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2725,7 +2742,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  implicit_char = false;
 	  if (sym->ts.type == BT_UNKNOWN)
 	    {
-	      ts = gfc_get_default_type (sym,NULL);
+	      ts = gfc_get_default_type (sym->name, NULL);
 	      if (ts->type == BT_CHARACTER)
 		implicit_char = true;
 	    }
@@ -2790,7 +2807,7 @@ gfc_match_rvalue (gfc_expr **result)
       /* If our new function returns a character, array or structure
 	 type, it might have subsequent references.  */
 
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
       if (m == MATCH_NO)
 	m = MATCH_YES;
 
@@ -2963,7 +2980,7 @@ match_variable (gfc_expr **result, int e
 	
       if (gfc_peek_ascii_char () == '%'
 	  && sym->ts.type == BT_UNKNOWN
-	  && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
+	  && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
 	gfc_set_default_type (sym, 0, implicit_ns);
     }
 
@@ -2975,7 +2992,7 @@ match_variable (gfc_expr **result, int e
   expr->where = where;
 
   /* Now see if we have to do more.  */
-  m = gfc_match_varspec (expr, equiv_flag, false);
+  m = gfc_match_varspec (expr, equiv_flag, false, false);
   if (m != MATCH_YES)
     {
       gfc_free_expr (expr);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 147105)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -1702,7 +1702,8 @@ gfc_conv_intrinsic_funcall (gfc_se * se,
 	}
     }
 
-  gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
+  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+			  append_args);
   gfc_free (sym);
 }
 
@@ -2877,7 +2878,8 @@ conv_generic_with_optional_char_arg (gfc
 
   /* Build the call itself.  */
   sym = gfc_get_symbol_for_expr (expr);
-  gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
+  gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+			  append_args);
   gfc_free (sym);
 }
 
! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Basic test for PPCs with SUBROUTINE interface and NOPASS.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

  type t
    integer :: i
    procedure(sub), pointer, nopass :: ppc
    procedure(), pointer, nopass :: proc
  end type

  type, extends(t) :: t2
    procedure(), pointer, nopass :: proc2
  end type t2

  type(t) :: x
  type(t2) :: x2

  procedure(sub),pointer :: pp

  x%i = 1
  x%ppc => sub
  pp => x%ppc

  call sub(1.5)
  call pp(2.2)
  call x%ppc(3.0)

  ! calling object as argument
  x%proc => print_me
  call x%proc(x)

  ! type extension
  x%proc => hello
  call x%proc
  x2%proc => hello
  call x2%proc()
  x2%proc2 => hello
  call x2%proc2

contains

  subroutine sub(y)
    real, intent(in) :: y
    print *,"sub:",y
  end subroutine

  subroutine print_me(arg)
    type(t),intent(in) :: arg
    print *,arg%i
  end subroutine

 subroutine hello
   print *, "Hello World"
 end subroutine

end

! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Basic test for PPCs with FUNCTION interface and NOPASS.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

  type t
    procedure(fcn), pointer, nopass :: ppc
    procedure(abstr), pointer, nopass :: ppc1
    procedure(), nopass, pointer:: ptr3
    integer :: i
  end type

  abstract interface
    real function abstr(x)
      import
      real, intent(in) :: x
    end function
  end interface

  type(t) :: obj
  procedure(fcn), pointer :: f
  real :: base = 1.0

  intrinsic :: sin

! Check with interface from contained function
  obj%ppc => fcn
  print *, obj%ppc(3.0)
  call foo (obj%ppc)

! Check with abstract interface
  obj%ppc1 => obj%ppc
  print *, obj%ppc1(3.0)
  call foo (obj%ppc1)

! Check compatibility components with non-components  
  f => obj%ppc
  print *, f(3.0)
  call foo (f)

! Check with implicit interface
  obj%ptr3 => sin
  print *,obj%ptr3(3.0)

contains

  real function fcn(x)
    real, intent(in) :: x
    fcn = base * 2.0 * x
    base = fcn
  end function

  subroutine foo (arg)
    procedure (fcn), pointer :: arg
    print *, arg (6.0)
  end subroutine

end
! { dg-do compile }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Probing some error messages.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

implicit none

interface
 subroutine sub
 end subroutine
end interface

external :: aaargh

type :: t
  procedure(sub), pointer :: ptr1                ! { dg-error "not yet implemented" }
  procedure(real), pointer, nopass :: ptr2
  procedure(sub), pointer, nopass :: ptr3
  procedure(), pointer, nopass ptr4              ! { dg-error "Expected '::'" }
  procedure(), pointer, nopass, pointer :: ptr5  ! { dg-error "Duplicate" }
  procedure, pointer, nopass :: ptr6             ! { dg-error "Syntax error" }
  procedure(), pointer, nopass :: ptr7 => ptr2   ! { dg-error "requires a NULL" }
  procedure(), nopass :: ptr8                    ! { dg-error "POINTER attribute is required" }
  procedure(pp), pointer, nopass :: ptr9         ! { dg-error "declared in a later PROCEDURE statement" }
  procedure(aaargh), pointer, nopass :: ptr10    ! { dg-error "must be explicit" }
  real :: y
end type t

procedure(sub), pointer :: pp

type(t) :: x

x%ptr2 => x       ! { dg-error "Invalid procedure pointer assignment" }

x => x%ptr2       ! { dg-error "Pointer assignment to non-POINTER" }

call x%ptr2()     ! { dg-error "attribute conflicts with" }
print *,x%ptr3()  ! { dg-error "attribute conflicts with" }

call x%y          ! { dg-error "Expected type-bound procedure or procedure pointer component" }

end

! { dg-do compile }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Original code by Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
!
! Adapted by Janus Weil <janus@gcc.gnu.org>


! Test for infinte recursion in trans-types.c when a PPC interface
! refers to the original type.

module expressions

  type :: eval_node_t
     logical, pointer :: lval => null ()
     type(eval_node_t), pointer :: arg1 => null ()
     procedure(unary_log), nopass, pointer :: op1_log  => null ()
  end type eval_node_t

  abstract interface
     logical function unary_log (arg)
       import eval_node_t
       type(eval_node_t), intent(in) :: arg
     end function unary_log
  end interface

contains

  subroutine eval_node_set_op1_log (en, op)
    type(eval_node_t), intent(inout) :: en
    procedure(unary_log) :: op
    en%op1_log => op
  end subroutine eval_node_set_op1_log

  subroutine eval_node_evaluate (en)
    type(eval_node_t), intent(inout) :: en
    en%lval = en%op1_log  (en%arg1)
  end subroutine

end module


! Test for C_F_PROCPOINTER and pointers to derived types

module process_libraries

  implicit none

  type :: process_library_t
     procedure(), nopass, pointer :: write_list
  end type process_library_t

contains

  subroutine process_library_load (prc_lib)
    use iso_c_binding 
    type(process_library_t) :: prc_lib
    type(c_funptr) :: c_fptr
    call c_f_procpointer (c_fptr, prc_lib%write_list)
  end subroutine process_library_load

  subroutine process_libraries_test ()
    type(process_library_t), pointer :: prc_lib
    call prc_lib%write_list ()
  end subroutine process_libraries_test

end module process_libraries


! Test for argument resolution

module hard_interactions

  implicit none

  type :: hard_interaction_t
     procedure(), nopass, pointer :: new_event
  end type hard_interaction_t

  interface afv
     module procedure afv_1
  end interface

contains

  function afv_1 () result (a)
    real, dimension(0:3) :: a
  end function

  subroutine hard_interaction_evaluate (hi)
    type(hard_interaction_t) :: hi
    call hi%new_event (afv ())
  end subroutine

end module hard_interactions


! Test for derived types with PPC working properly as function result.

  implicit none

  type :: var_entry_t
    procedure(), nopass, pointer :: obs1_int
  end type var_entry_t
  
  type(var_entry_t), pointer :: var

  var => var_list_get_var_ptr ()

contains

  function var_list_get_var_ptr ()
    type(var_entry_t), pointer :: var_list_get_var_ptr
  end function var_list_get_var_ptr

end

! { dg-final { cleanup-modules "expressions process_libraries hard_interactions" } }

! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! Nested types / double component references.
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

abstract interface
  subroutine as
  end subroutine
  real function af()
  end function
end interface

type :: t1
  procedure(as), pointer, nopass :: s
  procedure(af), pointer, nopass :: f
end type

type :: t2
  type(t1) :: c
end type

type(t2) :: x

x%c%s => is
call x%c%s

x%c%f => if
print *,x%c%f()

contains

subroutine is
  print *,"is is"
end subroutine

real function if()
  if = 42
end function

end

! { dg-do run }
!
! PR39630: Fortran 2003: Procedure pointer components.
!
! test case taken from:
! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/4a827e8ced6efb0f/884b9eca6d7e6742?#884b9eca6d7e6742
! http://fortranwiki.org/fortran/show/proc_component_example

module proc_component_example

    type t
        real :: a
        procedure(print_int), pointer, &
            nopass :: proc
    end type t

    abstract interface

    subroutine print_int (arg, lun)
        import
        type(t), intent(in) :: arg
        integer, intent(in) :: lun
    end subroutine print_int

    end interface

contains

    subroutine print_me (arg, lun)
        type(t), intent(in) :: arg
        integer, intent(in) :: lun
        write (lun,*) arg%a
    end subroutine print_me

    subroutine print_my_square (arg, lun)
        type(t), intent(in) :: arg
        integer, intent(in) :: lun
        write (lun,*) arg%a**2
    end subroutine print_my_square

end module proc_component_example

program main

    use proc_component_example
    use iso_fortran_env, only : output_unit

    type(t) :: x

    x%a = 2.71828

    x%proc => print_me
    call x%proc(x, output_unit)
    x%proc => print_my_square
    call x%proc(x, output_unit)

end program main 

! { dg-final { cleanup-modules "proc_component_example" } }


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]