2009-05-06 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.
	* dump-parse-tree.c (show_expr,show_components,show_code_node): Handle
	procedure pointer components.
	* 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-06  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.



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

1 files changed, 45 insertions, 17 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index a541a79eb33..280a1922a8b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -476,7 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       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, tree str1, tree len2, tree str2, int kind)
 }
 
 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_symbol * sym)
 
 
 /* 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, gfc_se *rse, gfc_symbol *sym)
 
   /* 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_interface_mapping * mapping,
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -2402,11 +2406,13 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 
 /* 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_symbol * sym,
 	  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_symbol * sym,
     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_symbol * sym,
      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,20 @@ gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
 }
 
 
+/* 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 +3397,9 @@ gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
   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 +3821,8 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
         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);