Re: Procedure Pointers: a first patch

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

Hi,

> Well, NULL() still does not work. As an example counts more than thousand
> descriptions, here comes one which works with g95 and ifort 11beta but fails
> with gfortran.

Ok, I fixed this problem with the NULL() initialization.


> The problem is that the line
>
>  void (*<T5f>) (void) x;
>
> should be
>
>  static void (*<T5f>) (void) x = 0B;
>
> program main
> implicit none
> call test(.true.)
> call test(.false.)
>
> contains
> integer function hello()
>  print *, 'Hello'
>  hello = 42
> end function hello
> subroutine test(first)
>  logical :: first
>  integer :: i
>  procedure(), pointer :: x => null()
>
>  if(first) then
>   if(associated(x)) call abort()
>   x => hello
>  else
>   if(.not. associated(x)) call abort()
>   i = hello()
>   if(i /= 42) call abort()
>  end if
>  end subroutine test
> end program main

This test case should work now. Besides some other things, I added the
following lines to trans-decl.c (get_proc_pointer_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);
    }

which I basically copied from other places. I hope it's ok like this
(at least it makes the test case work).


> Well, the problem is that the procedure pointer is passed as value and not
> as reference.
> See  http://gcc.gnu.org/ml/fortran/2008-05/msg00299.html

I haven't really looked into this, and I'm not quite sure how to do
it. Any help is surely appreciated.


> I think the patch can be committed after:
> - NULL() is fixed
> - Procedure pointers are passed by reference
>
> Working procedure-pointer-returning functions were nice, but I think they
> can be deferred to a follow up patch. The same is true for the other smaller
> bugs.

Ok. Also I think procedure-pointer return values are rather exotic
(and I'm sure one can find a lot of other exotics which do not work
yet).
And given the fact that both ifort 11 beta and g95 seem to have
trouble with most of my (working) test cases, I guess this is quite ok
for an initial patch.

Cheers,
Janus

Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90	(revision 136838)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90	(working copy)
@@ -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
Index: gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90	(revision 136838)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90	(working copy)
@@ -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" } }
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 136838)
+++ gcc/fortran/interface.c	(working copy)
@@ -1959,6 +1959,17 @@ compare_actual_formal (gfc_actual_arglis
 	  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
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 136838)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -480,8 +480,7 @@ gfc_conv_variable (gfc_se * se, gfc_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);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 136838)
+++ gcc/fortran/symbol.c	(working copy)
@@ -410,13 +410,18 @@ check_conflict (symbol_attribute *attr, 
 	  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 +562,6 @@ check_conflict (symbol_attribute *attr, 
   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 +617,11 @@ check_conflict (symbol_attribute *attr, 
       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 +864,12 @@ gfc_add_external (symbol_attribute *attr
       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 +920,20 @@ gfc_add_pointer (symbol_attribute *attr,
   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 +1658,8 @@ gfc_copy_attr (symbol_attribute *dest, s
     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 +3593,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 +3612,10 @@ gen_fptr_param (gfc_formal_arglist **hea
 
   /* 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 +3795,23 @@ build_formal_args (gfc_symbol *new_proc_
   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)
     {
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 136838)
+++ gcc/fortran/decl.c	(working copy)
@@ -4033,6 +4033,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;
 
@@ -4151,7 +4152,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;
@@ -4171,6 +4172,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)
@@ -4180,6 +4215,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;
 }
 
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 136838)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -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;
 
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 136838)
+++ gcc/fortran/expr.c	(working copy)
@@ -2873,7 +2873,7 @@ gfc_check_pointer_assign (gfc_expr *lval
   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);
@@ -2893,7 +2893,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;
+  pointer = lvalue->symtree->n.sym->attr.pointer
+	      | lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
@@ -2932,6 +2933,10 @@ gfc_check_pointer_assign (gfc_expr *lval
   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 "
@@ -2973,7 +2978,7 @@ gfc_check_pointer_assign (gfc_expr *lval
     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
 
   attr = gfc_expr_attr (rvalue);
-  if (!attr.target && !attr.pointer)
+  if (!attr.target && !attr.pointer /*&& lvalue->ts.type!=BT_PROCEDURE*/)
     {
       gfc_error ("Pointer assignment target is neither TARGET "
 		 "nor POINTER at %L", &rvalue->where);
@@ -3023,7 +3028,7 @@ gfc_check_assign_symbol (gfc_symbol *sym
   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);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 136838)
+++ gcc/fortran/resolve.c	(working copy)
@@ -7330,7 +7330,8 @@ resolve_fl_procedure (gfc_symbol *sym, i
 	}
     }
 
-  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, i
     }
 
   /* 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);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 136838)
+++ gcc/fortran/match.c	(working copy)
@@ -26,6 +26,7 @@ along with GCC; see the file COPYING3.  
 #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;
 
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 136838)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -1104,6 +1104,44 @@ gfc_restore_sym (gfc_symbol * sym, gfc_s
 }
 
 
+/* 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
      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
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 136838)
+++ gcc/fortran/match.h	(working copy)
@@ -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.  */
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 136838)
+++ gcc/fortran/parse.c	(working copy)
@@ -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)
 	{
Index: gcc/fortran/check.c
===================================================================
--- gcc/fortran/check.c	(revision 136838)
+++ gcc/fortran/check.c	(working copy)
@@ -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,
   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,
     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,
       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],
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 136838)
+++ gcc/fortran/primary.c	(working copy)
@@ -2324,6 +2324,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;
 
@@ -2400,6 +2403,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",
@@ -2781,6 +2805,9 @@ match_variable (gfc_expr **result, int e
 	  break;
 	}
 
+      if (sym->attr.proc_pointer)
+	break;
+
       /* Fall through to error */
 
     default: