Re: Procedure Pointer Components

["Janus Weil" <jaydub66 at googlemail dot com>]

Hi all,

here is an updated version of my procedure pointer components patch.
Unfortunately it still does not really handle actual calls to PPCs. To
implement this, I think it would be best to put PPCs into the
f2k_derived namespace (everything else would be really messy). Unless
anyone comes up with an argument why I should not do this, I will try
to implement it now and hope the patch can still make it into 4.4
somehow.

Cheers,
Janus

Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90	(revision 139797)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90	(working copy)
@@ -41,7 +41,7 @@ program prog
   procedure(amax0) :: my2  ! { dg-error "not allowed in PROCEDURE statement" }
 
   type t
-    procedure(),pointer:: p  ! { dg-error "not yet implemented" }
+    procedure(),pointer,nopass:: ppc
   end type
 
   real f, x
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 139797)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2013,6 +2013,7 @@ gfc_apply_interface_mapping_to_expr (gfc
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -3916,8 +3917,8 @@ gfc_trans_pointer_assignment (gfc_expr *
       rse.want_pointer = 1;
       gfc_conv_expr (&rse, expr2);
 
-      if (expr1->symtree->n.sym->attr.proc_pointer
-	  && expr1->symtree->n.sym->attr.dummy)
+      if (is_proc_ptr_comp (expr1) || (expr1->symtree->n.sym->attr.proc_pointer
+	  && expr1->symtree->n.sym->attr.dummy))
 	lse.expr = build_fold_indirect_ref (lse.expr);
 
       gfc_add_block_to_block (&block, &lse.pre);
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 139797)
+++ gcc/fortran/decl.c	(working copy)
@@ -1435,7 +1435,7 @@ build_struct (const char *name, gfc_char
 	  gfc_constructor *ctor = c->initializer->value.constructor;
 
 	  bool first = true;
-	  int first_len;
+	  int first_len = -1;
 
 	  has_ts = (c->initializer->ts.cl
 		    && c->initializer->ts.cl->length_from_typespec);
@@ -4081,6 +4081,177 @@ gfc_match_suffix (gfc_symbol *sym, gfc_s
 }
 
 
+/* Match binding attributes for type-bound procedures (ppc=false)
+   or procedure pointer components (ppc=true).  */
+
+static match
+match_binding_attributes (gfc_typebound_proc* ba, 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
+     this case the defaults are in there.  */
+  ba->access = ACCESS_UNKNOWN;
+  ba->pass_arg = NULL;
+  ba->pass_arg_num = 0;
+  ba->nopass = 0;
+  ba->non_overridable = 0;
+
+  /* If we find a comma, we believe there are binding attributes.  */
+  if (gfc_match_char (',') == MATCH_NO)
+    return MATCH_NO;
+
+  do
+    {
+      /* NOPASS flag.  */
+      m = gfc_match (" nopass");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (found_passing)
+	    {
+	      gfc_error ("Binding attributes already specify passing, illegal"
+			 " NOPASS at %C");
+	      goto error;
+	    }
+
+	  found_passing = true;
+	  ba->nopass = 1;
+	  continue;
+	}
+
+      /* PASS possibly including argument.  */
+      m = gfc_match (" pass");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+	  if (found_passing)
+	    {
+	      gfc_error ("Binding attributes already specify passing, illegal"
+			 " PASS at %C");
+	      goto error;
+	    }
+
+	  m = gfc_match (" ( %n )", arg);
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
+	    ba->pass_arg = xstrdup (arg);
+	  gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+	  found_passing = true;
+	  ba->nopass = 0;
+	  continue;
+	}
+
+      /* Access specifier.  */
+
+      m = gfc_match (" public");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("Duplicate access-specifier at %C");
+	      goto error;
+	    }
+
+	  ba->access = ACCESS_PUBLIC;
+	  continue;
+	}
+
+      m = gfc_match (" private");
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_YES)
+	{
+	  if (ba->access != ACCESS_UNKNOWN)
+	    {
+	      gfc_error ("Duplicate access-specifier at %C");
+	      goto error;
+	    }
+
+	  ba->access = ACCESS_PRIVATE;
+	  continue;
+	}
+
+      if (!ppc)
+	{
+	  /* 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.  */
+	  /* TODO: Handle really once implemented.  */
+	  m = gfc_match (" deferred");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
+	    {
+	      gfc_error ("DEFERRED not yet implemented at %C");
+	      goto error;
+	    }
+	}
+
+      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;
+              continue;
+	    }
+	}
+
+      /* Nothing matching found.  */
+      gfc_error ("Expected binding attribute at %C");
+      goto error;
+    }
+  while (gfc_match_char (',') == MATCH_YES);
+
+  if (ppc && !seen_ptr)
+    {
+      gfc_error ("POINTER attribute is required for procedure pointer component"
+                 " at %C");
+      goto error;
+    }
+
+  return MATCH_YES;
+
+error:
+  gfc_free (ba->pass_arg);
+  return MATCH_ERROR;
+}
+
+
 /* Match a PROCEDURE declaration (R1211).  */
 
 static match
@@ -4089,6 +4260,7 @@ match_procedure_decl (void)
   match m;
   locus old_loc, entry_loc;
   gfc_symbol *sym, *proc_if = NULL;
+  gfc_typespec ts;
   int num;
   gfc_expr *initializer = NULL;
 
@@ -4165,11 +4337,42 @@ got_ts:
     }
 
   /* Parse attributes.  */
-  m = match_attr_spec();
-  if (m == MATCH_ERROR)
-    return MATCH_ERROR;
+  if (gfc_current_state () != COMP_DERIVED)
+    {
+      m = match_attr_spec();
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+    }
+  else
+    {
+      gfc_typebound_proc* tb = XCNEW (gfc_typebound_proc);
+      tb->where = gfc_current_locus;
+      m = match_binding_attributes (tb, true);
+      gfc_clear_attr (&current_attr);
+      current_attr.proc_pointer = 1;
+      current_attr.access = tb->access;
+      if (m == MATCH_ERROR)
+	return m;
+
+      /* Match the colons.  */
+      m = gfc_match (" ::");
+      if (m == MATCH_ERROR)
+	return m;
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Expected '::' after binding-attributes at %C");
+	  return MATCH_ERROR;
+	}
+
+      if (!tb->nopass && proc_if == NULL)
+	{
+	  gfc_error("Procedure with NOPASS or with explicit interface required at %C");
+	  return MATCH_ERROR;
+	}
+   }
 
   /* Get procedure symbols.  */
+  ts = current_ts;
   for(num=1;;num++)
     {
       m = gfc_match_symbol (&sym, 0);
@@ -4220,18 +4423,18 @@ got_ts:
 	  sym->ts.interface = proc_if;
 	  sym->attr.untyped = 1;
 	}
-      else if (current_ts.type != BT_UNKNOWN)
+      else if (ts.type != BT_UNKNOWN)
 	{
-	  sym->ts = current_ts;
+	  sym->ts = ts;
 	  sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
-	  sym->ts.interface->ts = current_ts;
+	  sym->ts.interface->ts = ts;
 	  sym->ts.interface->attr.function = 1;
 	  sym->attr.function = sym->ts.interface->attr.function;
 	}
 
       if (gfc_match (" =>") == MATCH_YES)
 	{
-	  if (!current_attr.pointer)
+	  if (!current_attr.pointer && !current_attr.proc_pointer)
 	    {
 	      gfc_error ("Initialization at %C isn't for a pointer variable");
 	      m = MATCH_ERROR;
@@ -4255,13 +4458,22 @@ got_ts:
 	  if (m != MATCH_YES)
 	    goto cleanup;
 
-	  if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
-	      != SUCCESS)
+	  if (gfc_current_state () != COMP_DERIVED
+	      && add_init_expr_to_sym (sym->name, &initializer,
+				       &gfc_current_locus)
+		 != SUCCESS)
 	    goto cleanup;
-
 	}
 
-      gfc_set_sym_referenced (sym);
+      if (gfc_current_state () != COMP_DERIVED)
+	gfc_set_sym_referenced (sym);
+      else
+	{
+	  current_ts = sym->ts;
+	  if (build_struct (sym->name, sym->ts.cl, &initializer, &sym->as)
+	      != SUCCESS)
+	    goto cleanup;
+	}
 
       if (gfc_match_eos () == MATCH_YES)
 	return MATCH_YES;
@@ -4339,15 +4551,12 @@ gfc_match_procedure (void)
     case COMP_MODULE:
     case COMP_SUBROUTINE:
     case COMP_FUNCTION:
+    case COMP_DERIVED:
       m = match_procedure_decl ();
       break;
     case COMP_INTERFACE:
       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;
     case COMP_DERIVED_CONTAINS:
       m = match_procedure_in_type ();
       break;
@@ -6718,146 +6927,6 @@ cleanup:
 }
 
 
-/* Match binding attributes.  */
-
-static match
-match_binding_attributes (gfc_typebound_proc* ba)
-{
-  bool found_passing = false;
-  match m;
-
-  /* Intialize to defaults.  Do so even before the MATCH_NO check so that in
-     this case the defaults are in there.  */
-  ba->access = ACCESS_UNKNOWN;
-  ba->pass_arg = NULL;
-  ba->pass_arg_num = 0;
-  ba->nopass = 0;
-  ba->non_overridable = 0;
-
-  /* If we find a comma, we believe there are binding attributes.  */
-  if (gfc_match_char (',') == MATCH_NO)
-    return MATCH_NO;
-
-  do
-    {
-      /* NOPASS flag.  */
-      m = gfc_match (" nopass");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  if (found_passing)
-	    {
-	      gfc_error ("Binding attributes already specify passing, illegal"
-			 " NOPASS at %C");
-	      goto error;
-	    }
-
-	  found_passing = true;
-	  ba->nopass = 1;
-	  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.  */
-      /* TODO: Handle really once implemented.  */
-      m = gfc_match (" deferred");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  gfc_error ("DEFERRED not yet implemented at %C");
-	  goto error;
-	}
-
-      /* PASS possibly including argument.  */
-      m = gfc_match (" pass");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  char arg[GFC_MAX_SYMBOL_LEN + 1];
-
-	  if (found_passing)
-	    {
-	      gfc_error ("Binding attributes already specify passing, illegal"
-			 " PASS at %C");
-	      goto error;
-	    }
-
-	  m = gfc_match (" ( %n )", arg);
-	  if (m == MATCH_ERROR)
-	    goto error;
-	  if (m == MATCH_YES)
-	    ba->pass_arg = xstrdup (arg);
-	  gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
-
-	  found_passing = true;
-	  ba->nopass = 0;
-	  continue;
-	}
-
-      /* Access specifier.  */
-
-      m = gfc_match (" public");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  if (ba->access != ACCESS_UNKNOWN)
-	    {
-	      gfc_error ("Duplicate access-specifier at %C");
-	      goto error;
-	    }
-
-	  ba->access = ACCESS_PUBLIC;
-	  continue;
-	}
-
-      m = gfc_match (" private");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  if (ba->access != ACCESS_UNKNOWN)
-	    {
-	      gfc_error ("Duplicate access-specifier at %C");
-	      goto error;
-	    }
-
-	  ba->access = ACCESS_PRIVATE;
-	  continue;
-	}
-
-      /* Nothing matching found.  */
-      gfc_error ("Expected binding attribute at %C");
-      goto error;
-    }
-  while (gfc_match_char (',') == MATCH_YES);
-
-  return MATCH_YES;
-
-error:
-  gfc_free (ba->pass_arg);
-  return MATCH_ERROR;
-}
-
-
 /* Match a PROCEDURE specific binding inside a derived type.  */
 
 static match
@@ -6892,7 +6961,7 @@ match_procedure_in_type (void)
   tb->where = gfc_current_locus;
 
   /* Match binding attributes.  */
-  m = match_binding_attributes (tb);
+  m = match_binding_attributes (tb, false);
   if (m == MATCH_ERROR)
     return m;
   seen_attrs = (m == MATCH_YES);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 139797)
+++ 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;
 
@@ -841,6 +841,8 @@ typedef struct gfc_component
   locus loc;
   struct gfc_expr *initializer;
   struct gfc_component *next;
+
+  struct gfc_formal_arglist *formal;
 }
 gfc_component;
 
@@ -1818,7 +1820,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,
@@ -2408,6 +2410,8 @@ void gfc_expr_set_symbols_referenced (gf
 
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 
+bool is_proc_ptr_comp (gfc_expr *);
+
 /* st.c */
 extern gfc_code new_st;
 
@@ -2513,6 +2517,7 @@ 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);
+match gfc_match_comp (gfc_expr *);
 
 /* trans.c */
 void gfc_generate_code (gfc_namespace *);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 139797)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -417,6 +417,63 @@ gfc_trans_call (gfc_code * code, bool de
 }
 
 
+/* Translate a CALL statement with a procedure pointer components.  */
+
+tree
+gfc_trans_call_ppc (gfc_code * code)
+{
+
+  gfc_se se;
+  /*gfc_ss * ss;*/
+  int has_alternate_specifier;
+
+  /* A CALL starts a new block because the actual arguments may have to
+     be evaluated first.  */
+  gfc_init_se (&se, NULL);
+  gfc_start_block (&se.pre);
+
+  /*gcc_assert (code->resolved_sym);
+
+  ss = gfc_ss_terminator;
+  if (code->resolved_sym->attr.elemental)
+    ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);*/
+
+  /* Is not an elemental subroutine call with array valued arguments.  */
+  /*if (ss == gfc_ss_terminator)
+    {*/
+
+      /* Translate the call.  */
+      has_alternate_specifier
+	= gfc_conv_function_call (&se, code->resolved_sym, code->expr->value.function.actual,
+				  NULL_TREE);
+
+      /* A subroutine without side-effect, by definition, does nothing!  */
+      TREE_SIDE_EFFECTS (se.expr) = 1;
+
+      /* Chain the pieces together and return the block.  */
+      if (has_alternate_specifier)
+	{
+	  gfc_code *select_code;
+	  gfc_symbol *sym;
+	  select_code = code->next;
+	  gcc_assert(select_code->op == EXEC_SELECT);
+	  sym = select_code->expr->symtree->n.sym;
+	  se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
+	  if (sym->backend_decl == NULL)
+	    sym->backend_decl = gfc_get_symbol_decl (sym);
+	  gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
+	}
+      else
+	gfc_add_expr_to_block (&se.pre, se.expr);
+
+      gfc_add_block_to_block (&se.pre, &se.post);
+    /*}*/
+
+  return gfc_finish_block (&se.pre);
+  
+}
+
+
 /* Translate the RETURN statement.  */
 
 tree
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 139797)
+++ 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;
@@ -1682,6 +1684,7 @@ gfc_simplify_expr (gfc_expr *p, int type
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -2890,7 +2893,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)
@@ -2913,16 +2916,18 @@ 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)
     {
-      if (pointer)
+      if (pointer || proc_pointer)
 	check_intent_in = 0;
 
       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
 	pointer = 1;
+      else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer)
+	proc_pointer = 1;
     }
 
   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
@@ -2932,7 +2937,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;
@@ -2954,7 +2959,7 @@ gfc_check_pointer_assign (gfc_expr *lval
     return SUCCESS;
 
   /* TODO checks on rvalue for a procedure pointer assignment.  */
-  if (lvalue->symtree->n.sym->attr.proc_pointer)
+  if (proc_pointer)
     return SUCCESS;
 
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
@@ -3281,6 +3286,26 @@ gfc_expr_set_symbols_referenced (gfc_exp
   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
 }
 
+bool
+is_proc_ptr_comp (gfc_expr *expr)
+{
+  gfc_ref *r;
+  bool ppc = false;
+  for (r = expr->ref; r; r = r->next)
+    {
+      switch (r->type)
+	{
+	case REF_COMPONENT:
+	  ppc = r->u.c.component->attr.proc_pointer;
+	  break;
+	default:
+	  /* Do nothing.  */
+	  break;
+	}
+    }
+  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
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 139797)
+++ gcc/fortran/module.c	(working copy)
@@ -3032,6 +3032,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 139797)
+++ gcc/fortran/trans.c	(working copy)
@@ -1052,6 +1052,12 @@ gfc_trans_code (gfc_code * code)
 	  res = gfc_trans_call (code, true);
 	  break;
 
+	case EXEC_CALL_PPC:
+          gfc_error ("PPC call not implemented");
+	  return build_empty_stmt ();
+	  /*res = gfc_trans_call_ppc (code);*/
+	  break;
+
 	case EXEC_RETURN:
 	  res = gfc_trans_return (code);
 	  break;
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 139797)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -1879,6 +1879,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 = pfunc_type_node;
       else
 	{
 	  if (c->ts.type == BT_CHARACTER)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 139797)
+++ gcc/fortran/resolve.c	(working copy)
@@ -835,7 +835,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 "
@@ -4465,6 +4466,11 @@ gfc_resolve_expr (gfc_expr *e)
       t = SUCCESS;
       break;
 
+    case EXPR_PPC:
+      /* TODO: Resolve procedure pointer components.  */
+      t = SUCCESS;
+      break;
+
     case EXPR_ARRAY:
       t = FAILURE;
       if (resolve_ref (e) == FAILURE)
@@ -6452,6 +6458,10 @@ resolve_code (gfc_code *code, gfc_namesp
 	  resolve_typebound_call (code);
 	  break;
 
+	case EXEC_CALL_PPC:
+	  /* TODO: Resolve calls to procedure pointer components.  */
+	  break;
+
 	case EXEC_SELECT:
 	  /* Select is complicated. Also, a SELECT construct could be
 	     a transformed computed GOTO.  */
@@ -8123,6 +8133,32 @@ resolve_fl_derived (gfc_symbol *sym)
 
   for (c = sym->components; c != NULL; c = c->next)
     {
+      if (c->attr.proc_pointer && c->ts.interface
+	  /*&& c->attr.if_source != IFSRC_DECL*/)
+	{
+	  if (c->ts.interface->attr.procedure)
+	    gfc_error ("Interface '%s', used by procedure '%s' at %L, is "
+		       "declared in a later PROCEDURE statement",
+		       sym->ts.interface->name, sym->name,&sym->declared_at);
+
+	  /* 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;
+	      c->ts = ifc->ts;
+	      c->ts.interface = ifc;
+	      c->attr = ifc->attr;
+	      c->as = gfc_copy_array_spec (c->as);
+/*TODO:	  copy_formal_args (sym, ifc); */
+	    }
+	  else if (c->ts.interface->name[0] != '\0')
+	    {
+	      gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
+			c->ts.interface->name, c->name, &c->loc);
+	      return FAILURE;
+	    }
+	}
+
       /* If this type is an extension, see if this component has the same name
 	 as an inherited type-bound procedure.  */
       if (super_type
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c	(revision 139797)
+++ gcc/fortran/st.c	(working copy)
@@ -109,6 +109,7 @@ gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_COMPCALL:
+    case EXEC_CALL_PPC:
       gfc_free_expr (p->expr);
     case EXEC_CALL:
     case EXEC_ASSIGN_CALL:
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 139797)
+++ gcc/fortran/match.c	(working copy)
@@ -1330,6 +1330,7 @@ match
 gfc_match_pointer_assignment (void)
 {
   gfc_expr *lvalue, *rvalue;
+  gfc_ref *ref;
   locus old_loc;
   match m;
 
@@ -1348,6 +1349,10 @@ gfc_match_pointer_assignment (void)
   if (lvalue->symtree->n.sym->attr.proc_pointer)
     gfc_matching_procptr_assignment = 1;
 
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer)
+      gfc_matching_procptr_assignment = 1;
+
   m = gfc_match (" %e%t", &rvalue);
   gfc_matching_procptr_assignment = 0;
   if (m != MATCH_YES)
@@ -2538,13 +2543,21 @@ match_typebound_call (gfc_symtree* varst
       return MATCH_ERROR;
     }
 
-  if (base->expr_type != EXPR_COMPCALL)
+  /*if (base->expr_type != EXPR_COMPCALL)
     {
       gfc_error ("Expected type-bound procedure reference at %C");
       return MATCH_ERROR;
-    }
+    }*/
 
-  new_st.op = EXEC_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 TBP or PPC at %C");
+      return MATCH_ERROR;
+    }
   new_st.expr = base;
 
   return MATCH_YES;
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 139797)
+++ gcc/fortran/parse.c	(working copy)
@@ -1866,15 +1866,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;
@@ -1980,7 +1976,7 @@ endType:
 	}
 
       /* Look for pointer components.  */
-      if (c->attr.pointer
+      if (c->attr.pointer || c->attr.proc_pointer
 	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
 	{
 	  sym->attr.pointer_comp = 1;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 139797)
+++ gcc/fortran/primary.c	(working copy)
@@ -1819,6 +1819,13 @@ gfc_match_varspec (gfc_expr *primary, in
 
       primary->ts = component->ts;
 
+      if (sub_flag && component->attr.proc_pointer)
+	{
+	  primary->expr_type = EXPR_PPC;
+	  m = gfc_match_actual_arglist(component->attr.subroutine, &primary->value.compcall.actual);
+          break;
+	}
+
       if (component->as != NULL)
 	{
 	  tail = extend_ref (primary, tail);
@@ -1915,7 +1922,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)
@@ -1961,7 +1968,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;