re PR fortran/32580 (iso_c_binding c_f_procpointer / procedure pointers)

2008-07-02  Janus Weil  <janus@gcc.gnu.org>
	    Tobias Burnus  <burnus@net-b.de>
	    Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/32580
	* gfortran.h (struct gfc_symbol): New member "proc_pointer".
	* check.c (gfc_check_associated,gfc_check_null): Implement
	procedure pointers.
	* decl.c (match_procedure_decl): Ditto.
	* expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto.
	* interface.c (compare_actual_formal): Ditto.
	* match.h: Ditto.
	* match.c (gfc_match_pointer_assignment): Ditto.
	* parse.c (parse_interface): Ditto.
	* primary.c (gfc_match_rvalue,match_variable): Ditto.
	* resolve.c (resolve_fl_procedure): Ditto.
	* symbol.c (check_conflict,gfc_add_external,gfc_add_pointer,
	gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto.
	* trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl,
	create_function_arglist): Ditto.
	* trans-expr.c (gfc_conv_variable,gfc_conv_function_val,
	gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto.


2008-07-02  Janus Weil  <janus@gcc.gnu.org>
	    Tobias Burnus  <burnus@net-b.de>

	PR fortran/32580
	* gfortran.dg/c_f_pointer_tests_3.f90: Updated.
	* gfortran.dg/proc_decl_1.f90: Updated.
	* gfortran.dg/proc_ptr_1.f90: New.
	* gfortran.dg/proc_ptr_2.f90: New.
	* gfortran.dg/proc_ptr_3.f90: New.
	* gfortran.dg/proc_ptr_4.f90: New.
	* gfortran.dg/proc_ptr_5.f90: New.
	* gfortran.dg/proc_ptr_6.f90: New.
	* gfortran.dg/proc_ptr_7.f90: New.
	* gfortran.dg/proc_ptr_8.f90: New.

Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>
Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r137386

27 files changed, 625 insertions, 49 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 82c2392..7b641f0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,26 @@
+2008-07-02  Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32580
+	* gfortran.h (struct gfc_symbol): New member "proc_pointer".
+	* check.c (gfc_check_associated,gfc_check_null): Implement
+	procedure pointers.
+	* decl.c (match_procedure_decl): Ditto.
+	* expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto.
+	* interface.c (compare_actual_formal): Ditto.
+	* match.h: Ditto.
+	* match.c (gfc_match_pointer_assignment): Ditto.
+	* parse.c (parse_interface): Ditto.
+	* primary.c (gfc_match_rvalue,match_variable): Ditto.
+	* resolve.c (resolve_fl_procedure): Ditto.
+	* symbol.c (check_conflict,gfc_add_external,gfc_add_pointer,
+	gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto.
+	* trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl,
+	create_function_arglist): Ditto.
+	* trans-expr.c (gfc_conv_variable,gfc_conv_function_val,
+	gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto.
+
 2008-07-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/36590
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 87d962e..c0f9891 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -584,7 +584,7 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
 try
 gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
 {
-  symbol_attribute attr;
+  symbol_attribute attr1, attr2;
   int i;
   try t;
   locus *where;
@@ -592,15 +592,15 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   where = &pointer->where;
 
   if (pointer->expr_type == EXPR_VARIABLE)
-    attr = gfc_variable_attr (pointer, NULL);
+    attr1 = gfc_variable_attr (pointer, NULL);
   else if (pointer->expr_type == EXPR_FUNCTION)
-    attr = pointer->symtree->n.sym->attr;
+    attr1 = pointer->symtree->n.sym->attr;
   else if (pointer->expr_type == EXPR_NULL)
     goto null_arg;
   else
     gcc_assert (0); /* Pointer must be a variable or a function.  */
 
-  if (!attr.pointer)
+  if (!attr1.pointer && !attr1.proc_pointer)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
 		 gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
@@ -617,9 +617,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
     goto null_arg;
 
   if (target->expr_type == EXPR_VARIABLE)
-    attr = gfc_variable_attr (target, NULL);
+    attr2 = gfc_variable_attr (target, NULL);
   else if (target->expr_type == EXPR_FUNCTION)
-    attr = target->symtree->n.sym->attr;
+    attr2 = target->symtree->n.sym->attr;
   else
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
@@ -628,7 +628,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
       return FAILURE;
     }
 
-  if (!attr.pointer && !attr.target)
+  if (attr1.pointer && !attr2.pointer && !attr2.target)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
 		 "or a TARGET", gfc_current_intrinsic_arg[1],
@@ -2071,7 +2071,7 @@ gfc_check_null (gfc_expr *mold)
 
   attr = gfc_variable_attr (mold, NULL);
 
-  if (!attr.pointer)
+  if (!attr.pointer && !attr.proc_pointer)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
 		 gfc_current_intrinsic_arg[0],
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 869ece6..d23a329 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4065,6 +4065,7 @@ match_procedure_decl (void)
   locus old_loc, entry_loc;
   gfc_symbol *sym, *proc_if = NULL;
   int num;
+  gfc_expr *initializer = NULL;
 
   old_loc = entry_loc = gfc_current_locus;
 
@@ -4183,7 +4184,7 @@ got_ts:
 	    return MATCH_ERROR;
 	}
 
-      if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
+      if (gfc_add_external (&sym->attr, NULL) == FAILURE)
 	return MATCH_ERROR;
       if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
 	return MATCH_ERROR;
@@ -4203,6 +4204,40 @@ got_ts:
 	  sym->attr.function = sym->ts.interface->attr.function;
 	}
 
+      if (gfc_match (" =>") == MATCH_YES)
+	{
+	  if (!current_attr.pointer)
+	    {
+	      gfc_error ("Initialization at %C isn't for a pointer variable");
+	      m = MATCH_ERROR;
+	      goto cleanup;
+	    }
+
+	  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)
+	    goto cleanup;
+
+	  if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
+	      != SUCCESS)
+	    goto cleanup;
+
+	}
+
+      gfc_set_sym_referenced (sym);
+
       if (gfc_match_eos () == MATCH_YES)
 	return MATCH_YES;
       if (gfc_match_char (',') != MATCH_YES)
@@ -4212,6 +4247,11 @@ got_ts:
 syntax:
   gfc_error ("Syntax error in PROCEDURE statement at %C");
   return MATCH_ERROR;
+
+cleanup:
+  /* Free stuff up and return.  */
+  gfc_free_expr (initializer);
+  return m;
 }
 
 
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 2f7030e..12987e6 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -2874,7 +2874,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   int is_pure;
   int pointer, check_intent_in;
 
-  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
+  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
+      && !lvalue->symtree->n.sym->attr.proc_pointer)
     {
       gfc_error ("Pointer assignment target is not a POINTER at %L",
 		 &lvalue->where);
@@ -2894,7 +2895,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   /* 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;
+  pointer = lvalue->symtree->n.sym->attr.pointer
+	      | lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
@@ -2933,6 +2935,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
     return SUCCESS;
 
+  /* TODO checks on rvalue for a procedure pointer assignment.  */
+  if (lvalue->symtree->n.sym->attr.proc_pointer)
+    return SUCCESS;
+
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
       gfc_error ("Different types in pointer assignment at %L; attempted "
@@ -3024,7 +3030,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
   lvalue.symtree->n.sym = sym;
   lvalue.where = sym->declared_at;
 
-  if (sym->attr.pointer)
+  if (sym->attr.pointer || sym->attr.proc_pointer)
     r = gfc_check_pointer_assign (&lvalue, rvalue);
   else
     r = gfc_check_assign (&lvalue, rvalue, 1);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5d025db..aa2296c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -620,7 +620,7 @@ typedef struct
   unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
     optional:1, pointer:1, target:1, value:1, volatile_:1,
     dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
-    implied_index:1, subref_array_pointer:1;
+    implied_index:1, subref_array_pointer:1, proc_pointer:1;
 
   ENUM_BITFIELD (save_state) save:2;
 
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 26b4591..a203199 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1959,6 +1959,17 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return  0;
 	}
 
+      /* 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)
+	{
+	  if (where)
+	    gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+		       f->sym->name, &a->expr->where);
+	  return 0;
+	}
+
       /* 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
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 6f5765f..d501d68 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -26,6 +26,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "match.h"
 #include "parse.h"
 
+int gfc_matching_procptr_assignment = 0;
 
 /* For debugging and diagnostic purposes.  Return the textual representation
    of the intrinsic operator OP.  */
@@ -1329,6 +1330,7 @@ gfc_match_pointer_assignment (void)
   old_loc = gfc_current_locus;
 
   lvalue = rvalue = NULL;
+  gfc_matching_procptr_assignment = 0;
 
   m = gfc_match (" %v =>", &lvalue);
   if (m != MATCH_YES)
@@ -1337,7 +1339,11 @@ gfc_match_pointer_assignment (void)
       goto cleanup;
     }
 
+  if (lvalue->symtree->n.sym->attr.proc_pointer)
+    gfc_matching_procptr_assignment = 1;
+
   m = gfc_match (" %e%t", &rvalue);
+  gfc_matching_procptr_assignment = 0;
   if (m != MATCH_YES)
     goto cleanup;
 
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index cf30b27..21a2479 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -33,6 +33,8 @@ extern gfc_symbol *gfc_new_block;
    separate.  */
 extern gfc_st_label *gfc_statement_label;
 
+extern int gfc_matching_procptr_assignment;
+
 /****************** All gfc_match* routines *****************/
 
 /* match.c.  */
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index c35db2d9..781efbc 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1992,6 +1992,11 @@ loop:
 	new_state = COMP_SUBROUTINE;
       else if (st == ST_FUNCTION)
 	new_state = COMP_FUNCTION;
+      if (gfc_new_block->attr.pointer)
+	{
+	  gfc_new_block->attr.pointer = 0;
+	  gfc_new_block->attr.proc_pointer = 1;
+	}
       if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
 				  gfc_new_block->formal, NULL) == FAILURE)
 	{
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index d7236e1..c67f2bd 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2323,6 +2323,9 @@ gfc_match_rvalue (gfc_expr **result)
 	}
     }
 
+  if (gfc_matching_procptr_assignment)
+    goto procptr0;
+
   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
     goto function0;
 
@@ -2399,6 +2402,27 @@ gfc_match_rvalue (gfc_expr **result)
     /* If we're here, then the name is known to be the name of a
        procedure, yet it is not sure to be the name of a function.  */
     case FL_PROCEDURE:
+
+    /* Procedure Pointer Assignments. */
+    procptr0:
+      if (gfc_matching_procptr_assignment)
+	{
+	  gfc_gobble_whitespace ();
+	  if (sym->attr.function && gfc_peek_ascii_char () == '(')
+	    /* Parse functions returning a procptr.  */
+	    goto function0;
+
+	  if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
+	  if (gfc_intrinsic_name (sym->name, 0)
+	      || gfc_intrinsic_name (sym->name, 1))
+	    sym->attr.intrinsic = 1;
+	  e = gfc_get_expr ();
+	  e->expr_type = EXPR_VARIABLE;
+	  e->symtree = symtree;
+	  m = match_varspec (e, 0);
+	  break;
+	}
+
       if (sym->attr.subroutine)
 	{
 	  gfc_error ("Unexpected use of subroutine name '%s' at %C",
@@ -2780,6 +2804,9 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 	  break;
 	}
 
+      if (sym->attr.proc_pointer)
+	break;
+
       /* Fall through to error */
 
     default:
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 3b798d8..c0ec784 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7330,7 +7330,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
 	}
     }
 
-  if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
+  if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
+      && !sym->attr.proc_pointer)
     {
       gfc_error ("Function '%s' at %L cannot have an initializer",
 		 sym->name, &sym->declared_at);
@@ -7338,8 +7339,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
     }
 
   /* An external symbol may not have an initializer because it is taken to be
-     a procedure.  */
-  if (sym->attr.external && sym->value)
+     a procedure. Exception: Procedure Pointers.  */
+  if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
     {
       gfc_error ("External object '%s' at %L may not have an initializer",
 		 sym->name, &sym->declared_at);
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cd181d4..f91ef91 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -410,13 +410,19 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
 	  case FL_BLOCK_DATA:
 	  case FL_MODULE:
 	  case FL_LABEL:
-	  case FL_PROCEDURE:
 	  case FL_DERIVED:
 	  case FL_PARAMETER:
             a1 = gfc_code2string (flavors, attr->flavor);
             a2 = save;
 	    goto conflict;
 
+	  case FL_PROCEDURE:
+	    if (attr->proc_pointer)
+	      break;
+	    a1 = gfc_code2string (flavors, attr->flavor);
+	    a2 = save;
+	    goto conflict;
+
 	  case FL_VARIABLE:
 	  case FL_NAMELIST:
 	  default:
@@ -557,13 +563,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (procedure, value)
   conf (procedure, volatile_)
   conf (procedure, entry)
-  /* TODO: Implement procedure pointers.  */
-  if (attr->procedure && attr->pointer)
-    {
-      gfc_error ("Fortran 2003: Procedure pointers at %L are "
-		 "not yet implemented in gfortran", where);
-      return FAILURE;
-    }
 
   a1 = gfc_code2string (flavors, attr->flavor);
 
@@ -619,11 +618,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       break;
 
     case FL_PROCEDURE:
-      conf2 (intent);
+      if (!attr->proc_pointer)
+        conf2 (intent);
 
       if (attr->subroutine)
 	{
-	  conf2 (pointer);
 	  conf2 (target);
 	  conf2 (allocatable);
 	  conf2 (result);
@@ -866,6 +865,12 @@ gfc_add_external (symbol_attribute *attr, locus *where)
       return FAILURE;
     }
 
+  if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+    {
+      attr->pointer = 0;
+      attr->proc_pointer = 1;
+    }
+
   attr->external = 1;
 
   return check_conflict (attr, NULL, where);
@@ -916,7 +921,20 @@ gfc_add_pointer (symbol_attribute *attr, locus *where)
   if (check_used (attr, NULL, where))
     return FAILURE;
 
-  attr->pointer = 1;
+  if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+      && gfc_find_state (COMP_INTERFACE) == FAILURE))
+    {
+      duplicate_attr ("POINTER", where);
+      return FAILURE;
+    }
+
+  if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+      || (attr->if_source == IFSRC_IFBODY
+      && gfc_find_state (COMP_INTERFACE) == FAILURE))
+    attr->proc_pointer = 1;
+  else
+    attr->pointer = 1;
+
   return check_conflict (attr, NULL, where);
 }
 
@@ -1641,6 +1659,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
     goto fail;
   if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
     goto fail;
+  if (src->proc_pointer)
+    dest->proc_pointer = 1;
 
   return SUCCESS;
 
@@ -3574,7 +3594,7 @@ static void
 gen_fptr_param (gfc_formal_arglist **head,
                 gfc_formal_arglist **tail,
                 const char *module_name,
-                gfc_namespace *ns, const char *f_ptr_name)
+                gfc_namespace *ns, const char *f_ptr_name, int proc)
 {
   gfc_symbol *param_sym = NULL;
   gfc_symtree *param_symtree = NULL;
@@ -3593,7 +3613,10 @@ gen_fptr_param (gfc_formal_arglist **head,
 
   /* Set up the necessary fields for the fptr output param sym.  */
   param_sym->refs++;
-  param_sym->attr.pointer = 1;
+  if (proc)
+    param_sym->attr.proc_pointer = 1;
+  else
+    param_sym->attr.pointer = 1;
   param_sym->attr.dummy = 1;
   param_sym->attr.use_assoc = 1;
 
@@ -3773,21 +3796,23 @@ build_formal_args (gfc_symbol *new_proc_sym,
   gfc_current_ns->proc_name = new_proc_sym;
 
   /* Generate the params.  */
-  if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
-      (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+  if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
     {
       gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
 		      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
       gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
-		      gfc_current_ns, "fptr");
-
+		      gfc_current_ns, "fptr", 1);
+    }
+  else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+    {
+      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+		      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+      gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+		      gfc_current_ns, "fptr", 0);
       /* If we're dealing with c_f_pointer, it has an optional third arg.  */
-      if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
-	{
-	  gen_shape_param (&head, &tail,
-			   (const char *) new_proc_sym->module,
-			   gfc_current_ns, "shape");
-	}
+      gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+		       gfc_current_ns, "shape");
+
     }
   else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
     {
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 686e059..e960fa0 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1104,6 +1104,44 @@ gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
 }
 
 
+/* Declare a procedure pointer.  */
+
+static tree
+get_proc_pointer_decl (gfc_symbol *sym)
+{
+  tree decl;
+
+  decl = sym->backend_decl;
+  if (decl)
+    return decl;
+
+  decl = build_decl (VAR_DECL, get_identifier (sym->name),
+		     build_pointer_type (gfc_get_function_type (sym)));
+
+  if (sym->ns->proc_name->backend_decl == current_function_decl
+      || sym->attr.contained)
+    gfc_add_decl_to_function (decl);
+  else
+    gfc_add_decl_to_parent_function (decl);
+
+  sym->backend_decl = decl;
+
+  if (!sym->attr.use_assoc
+	&& (sym->attr.save != SAVE_NONE || sym->attr.data
+	      || (sym->value && sym->ns->proc_name->attr.is_main_program)))
+    TREE_STATIC (decl) = 1;
+
+  if (TREE_STATIC (decl) && sym->value)
+    {
+      /* Add static initializer.  */
+      DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+	  TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+    }
+
+  return decl;
+}
+
+
 /* Get a basic decl for an external function.  */
 
 tree
@@ -1126,6 +1164,9 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
      to know that.  */
   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
 
+  if (sym->attr.proc_pointer)
+    return get_proc_pointer_decl (sym);
+
   if (sym->attr.intrinsic)
     {
       /* Call the resolution function to get the actual name.  This is
@@ -1540,6 +1581,9 @@ create_function_arglist (gfc_symbol * sym)
 	    type = gfc_sym_type (f->sym);
 	}
 
+      if (f->sym->attr.proc_pointer)
+        type = build_pointer_type (type);
+
       /* Build a the argument declaration.  */
       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 59a0a2d..570e07b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -480,8 +480,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       else if (sym->attr.flavor == FL_PROCEDURE
 	       && se->expr != current_function_decl)
 	{
-	  gcc_assert (se->want_pointer);
-	  if (!sym->attr.dummy)
+	  if (!sym->attr.dummy && !sym->attr.proc_pointer)
 	    {
 	      gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
 	      se->expr = build_fold_addr_expr (se->expr);
@@ -1372,6 +1371,8 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
   if (sym->attr.dummy)
     {
       tmp = gfc_get_symbol_decl (sym);
+      if (sym->attr.proc_pointer)
+        tmp = build_fold_indirect_ref (tmp);
       gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
 	      && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
     }
@@ -2498,9 +2499,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	      else
 		{
 		  gfc_conv_expr_reference (&parmse, e);
-		  if (fsym && fsym->attr.pointer
-		      && fsym->attr.flavor != FL_PROCEDURE
-		      && e->expr_type != EXPR_NULL)
+		  if (fsym && e->expr_type != EXPR_NULL
+		      && ((fsym->attr.pointer
+			   && fsym->attr.flavor != FL_PROCEDURE)
+			  || fsym->attr.proc_pointer))
 		    {
 		      /* Scalar pointer dummy args require an extra level of
 			 indirection. The null pointer already contains
@@ -3867,6 +3869,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
       gfc_init_se (&rse, NULL);
       rse.want_pointer = 1;
       gfc_conv_expr (&rse, expr2);
+
+      if (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);
       gfc_add_block_to_block (&block, &rse.pre);
       gfc_add_modify_expr (&block, lse.expr,
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 607cf0f..78562ce 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,18 @@
+2008-07-02  Janus Weil  <janus@gcc.gnu.org>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/32580
+	* gfortran.dg/c_f_pointer_tests_3.f90: Updated.
+	* gfortran.dg/proc_decl_1.f90: Updated.
+	* gfortran.dg/proc_ptr_1.f90: New.
+	* gfortran.dg/proc_ptr_2.f90: New.
+	* gfortran.dg/proc_ptr_3.f90: New.
+	* gfortran.dg/proc_ptr_4.f90: New.
+	* gfortran.dg/proc_ptr_5.f90: New.
+	* gfortran.dg/proc_ptr_6.f90: New.
+	* gfortran.dg/proc_ptr_7.f90: New.
+	* gfortran.dg/proc_ptr_8.f90: New.
+
 2008-07-02  Joseph Myers  <joseph@codesourcery.com>
 
 	* gcc.target/arm/neon/polytypes.c: Use dg-message separately from
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
index 525af50..3b28f52 100644
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
@@ -14,11 +14,11 @@ program test
   type(c_funptr) :: cfunptr
   integer(4), pointer :: fptr
   integer(4), pointer :: fptr_array(:)
-!  procedure(integer(4)), pointer :: fprocptr ! TODO
+  procedure(integer(4)), pointer :: fprocptr
 
   call c_f_pointer(cptr, fptr)
   call c_f_pointer(cptr, fptr_array, [ 1 ])
-!  call c_f_procpointer(cfunptr, fprocptr) ! TODO
+  call c_f_procpointer(cfunptr, fprocptr)
 end program test
 
 ! Make sure there is only a single function call:
@@ -30,6 +30,6 @@ end program test
 ! { dg-final { scan-tree-dump-times "  fptr = .integer.kind=4. .. cptr" 1 "original" } }
 !
 ! Check c_f_procpointer
-!   TODO     { scan-tree-dump-times "  fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } }  TODO
+! { dg-final { scan-tree-dump-times "  fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } }
 !
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/proc_decl_1.f90 b/gcc/testsuite/gfortran.dg/proc_decl_1.f90
index c01f7c6..3e7a3d1 100644
--- a/gcc/testsuite/gfortran.dg/proc_decl_1.f90
+++ b/gcc/testsuite/gfortran.dg/proc_decl_1.f90
@@ -40,8 +40,6 @@ program prog
   procedure(dcos) :: my1
   procedure(amax0) :: my2  ! { dg-error "not allowed in PROCEDURE statement" }
 
-  procedure(),pointer:: ptr  ! { dg-error "not yet implemented" }
-
   type t
     procedure(),pointer:: p  ! { dg-error "not yet implemented" }
   end type
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_1.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_1.f90
new file mode 100755
index 0000000..fe8e201
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_1.f90
@@ -0,0 +1,73 @@
+! { dg-do run }
+!
+! basic tests of PROCEDURE POINTERS
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+contains
+  subroutine proc1(arg)
+    character (5) :: arg
+    arg = "proc1"
+  end subroutine
+  integer function proc2(arg)
+    integer, intent(in) :: arg
+    proc2 = arg**2
+  end function
+  complex function proc3(re, im)
+    real, intent(in) :: re, im
+    proc3 = complex (re, im)
+  end function
+end module
+
+subroutine foo1
+end subroutine
+
+real function foo2()
+  foo2=6.3
+end function
+
+program procPtrTest
+  use m, only: proc1, proc2, proc3
+  character (5) :: str
+  PROCEDURE(proc1), POINTER :: ptr1
+  PROCEDURE(proc2), POINTER :: ptr2
+  PROCEDURE(proc3), POINTER :: ptr3 => NULL()
+  PROCEDURE(REAL), SAVE, POINTER :: ptr4
+  PROCEDURE(), POINTER :: ptr5,ptr6
+
+  EXTERNAL :: foo1,foo2
+  real :: foo2
+
+  if(ASSOCIATED(ptr3)) call abort()
+
+  NULLIFY(ptr1)
+  if (ASSOCIATED(ptr1)) call abort()
+  ptr1 => proc1
+  if (.not. ASSOCIATED(ptr1)) call abort()
+  call ptr1 (str)
+  if (str .ne. "proc1") call abort ()
+
+  ptr2 => NULL()
+  if (ASSOCIATED(ptr2)) call abort()
+  ptr2 => proc2
+  if (.not. ASSOCIATED(ptr2,proc2)) call abort()
+  if (10*ptr2 (10) .ne. 1000) call abort ()
+
+  ptr3 => NULL (ptr3)
+  if (ASSOCIATED(ptr3)) call abort()
+  ptr3 => proc3
+  if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) call abort ()
+
+  ptr4 => cos
+  if (ptr4(0.0)/=1.0) call abort()
+
+  ptr5 => foo1
+  call ptr5()
+
+  ptr6 => foo2
+  if (ptr6()/=6.3) call abort()
+
+end program 
+
+! { dg-final { cleanup-modules "m" } }
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_2.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
new file mode 100755
index 0000000..d19b81d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_2.f90
@@ -0,0 +1,14 @@
+! { dg-do compile }
+!
+! checking invalid code for PROCEDURE POINTERS
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+PROCEDURE(REAL), POINTER :: ptr
+PROCEDURE(REAL), SAVE    :: noptr    ! { dg-error "attribute conflicts with" }
+
+ptr => cos(4.0)        ! { dg-error "Invalid character" }
+
+ALLOCATE(ptr)          ! { dg-error "must be ALLOCATABLE" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
new file mode 100755
index 0000000..34d4f16
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_3.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+!
+! PROCEDURE POINTERS without the PROCEDURE statement
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+real function e1(x)
+  real :: x
+  print *,'e1!',x
+  e1 = x * 3.0
+end function
+
+subroutine e2(a,b)
+  real, intent(inout) :: a
+  real, intent(in) :: b
+  print *,'e2!',a,b
+  a = a + b
+end subroutine
+
+program proc_ptr_3
+
+real, external, pointer :: fp
+
+pointer :: sp
+interface
+  subroutine sp(a,b)
+    real, intent(inout) :: a
+    real, intent(in) :: b
+  end subroutine sp
+end interface
+
+external :: e1,e2
+real :: c = 1.2
+
+fp => e1
+
+if (abs(fp(2.5)-7.5)>0.01) call abort()
+
+sp => e2
+
+call sp(c,3.4)
+
+if (abs(c-4.6)>0.01) call abort()
+
+end
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_4.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_4.f90
new file mode 100755
index 0000000..60b9e73
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_4.f90
@@ -0,0 +1,57 @@
+! { dg-do compile }
+!
+! PROCEDURE POINTERS & pointer-valued functions
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+interface
+  integer function f1()
+  end function
+end interface
+
+interface
+ function f2()
+   integer, pointer :: f2
+ end function
+end interface
+
+interface
+ function pp1()
+   integer :: pp1
+ end function
+end interface
+pointer :: pp1
+
+pointer :: pp2
+interface
+  function pp2()
+    integer :: pp2
+  end function
+end interface
+
+pointer :: pp3
+interface
+  function pp3()
+    integer, pointer :: pp3
+  end function
+end interface
+
+interface
+  function pp4()
+    integer, pointer :: pp4
+  end function
+end interface
+pointer :: pp4
+
+
+pp1 => f1
+
+pp2 => pp1
+
+f2 => f1	! { dg-error "is not a variable" }
+
+pp3 => f2
+
+pp4 => pp3
+
+end
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_5.f90
new file mode 100755
index 0000000..61cf8a3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_5.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+!
+! NULL() initialization for PROCEDURE POINTERS
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program main
+implicit none
+call test(.true.)
+call test(.false.)
+
+contains
+
+integer function hello()
+ hello = 42
+end function hello
+
+subroutine test(first)
+ logical :: first
+ integer :: i
+ procedure(integer), pointer :: x => null()
+
+ if(first) then
+  if(associated(x)) call abort()
+  x => hello
+ else
+  if(.not. associated(x)) call abort()
+  i = x()
+  if(i /= 42) call abort()
+ end if
+ end subroutine test
+
+end program main
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_6.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_6.f90
new file mode 100755
index 0000000..6a5c7e5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_6.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+!
+! PROCEDURE POINTERS as actual/formal arguments
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+subroutine foo(j)
+  INTEGER, INTENT(OUT) :: j
+  j = 6
+end subroutine
+
+program proc_ptr_6
+
+PROCEDURE(),POINTER :: ptr1
+PROCEDURE(REAL),POINTER :: ptr2
+EXTERNAL foo
+INTEGER :: k = 0
+
+ptr1 => foo
+call s_in(ptr1,k)
+if (k /= 6) call abort()
+
+call s_out(ptr2)
+if (ptr2(-3.0) /= 3.0) call abort()
+
+contains
+
+subroutine s_in(p,i)
+  PROCEDURE(),POINTER,INTENT(IN) :: p
+  INTEGER, INTENT(OUT) :: i
+  call p(i)
+end subroutine
+
+subroutine s_out(p)
+  PROCEDURE(REAL),POINTER,INTENT(OUT) :: p
+  p => abs
+end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_7.c b/gcc/testsuite/gfortran.dg/proc_ptr_7.c
new file mode 100644
index 0000000..7e9542f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_7.c
@@ -0,0 +1,10 @@
+/* Procedure pointer test. Used by proc_ptr_7.f90.
+   PR fortran/32580.  */
+
+int f(void) {
+  return 42;
+}
+
+void assignf_(int(**ptr)(void)) {
+  *ptr = f;
+}
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_7.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_7.f90
new file mode 100644
index 0000000..8b1ea0a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_7.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+! { dg-additional-sources proc_ptr_7.c }
+!
+! PR fortran/32580
+! Procedure pointer test
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program proc_pointer_test
+  use iso_c_binding, only: c_int
+  implicit none
+
+  interface
+    subroutine assignF(f)
+      import c_int
+      procedure(Integer(c_int)), pointer :: f
+    end subroutine
+  end interface
+
+  procedure(Integer(c_int)), pointer :: ptr
+
+  call assignF(ptr)
+  if(ptr() /= 42) call abort()
+
+  ptr => f55
+  if(ptr() /= 55) call abort()  
+
+  call foo(ptr)
+  if(ptr() /= 65) call abort()  
+
+contains
+
+ subroutine foo(a)
+   procedure(integer(c_int)), pointer :: a
+   if(a() /= 55) call abort()
+   a => f65
+   if(a() /= 65) call abort()
+ end subroutine foo
+
+ integer(c_int) function f55()
+    f55 = 55
+ end function f55
+
+ integer(c_int) function f65()
+    f65 = 65
+ end function f65
+end program proc_pointer_test
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_8.c b/gcc/testsuite/gfortran.dg/proc_ptr_8.c
new file mode 100644
index 0000000..c732ff6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_8.c
@@ -0,0 +1,14 @@
+/* Used by proc_ptr_8.f90.
+   PR fortran/32580.  */
+
+int (*funpointer)(int);
+
+int f(int t)
+{
+  return t*3;
+}
+
+void init()
+{
+ funpointer=f;
+}
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_8.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_8.f90
new file mode 100644
index 0000000..80d2661
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/proc_ptr_8.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-additional-sources proc_ptr_8.c }
+!
+! PR fortran/32580
+! Original test case
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+
+MODULE X
+
+  USE ISO_C_BINDING
+  INTERFACE
+    INTEGER(KIND=C_INT) FUNCTION mytype( a ) BIND(C)
+       USE ISO_C_BINDING
+       INTEGER(KIND=C_INT), VALUE :: a
+    END FUNCTION
+    SUBROUTINE init() BIND(C,name="init")
+    END SUBROUTINE
+  END INTERFACE
+
+  TYPE(C_FUNPTR), BIND(C,name="funpointer") :: funpointer
+
+END MODULE X
+
+USE X
+PROCEDURE(mytype), POINTER :: ptype
+
+CALL init()
+CALL C_F_PROCPOINTER(funpointer,ptype)
+if (ptype(3) /= 9) call abort()
+
+END
+
+! { dg-final { cleanup-modules "X" } }