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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@137386 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 48 insertions, 23 deletions

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cd181d4f0f1..f91ef9157c0 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)
     {