re PR fortran/39630 ([F03] Procedure Pointer Components)

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.


Co-Authored-By: Paul Thomas <pault@gcc.gnu.org>

From-SVN: r147206

1 files changed, 154 insertions, 8 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 1878042..34cb365 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -528,14 +528,14 @@ resolve_entries (gfc_namespace *ns)
       fas = fas ? fas : ns->entries->sym->result->as;
       fts = &ns->entries->sym->result->ts;
       if (fts->type == BT_UNKNOWN)
-	fts = gfc_get_default_type (ns->entries->sym->result, NULL);
+	fts = gfc_get_default_type (ns->entries->sym->result->name, NULL);
       for (el = ns->entries->next; el; el = el->next)
 	{
 	  ts = &el->sym->result->ts;
 	  as = el->sym->as;
 	  as = as ? as : el->sym->result->as;
 	  if (ts->type == BT_UNKNOWN)
-	    ts = gfc_get_default_type (el->sym->result, NULL);
+	    ts = gfc_get_default_type (el->sym->result->name, NULL);
 
 	  if (! gfc_compare_types (ts, fts)
 	      || (el->sym->result->attr.dimension
@@ -612,7 +612,7 @@ resolve_entries (gfc_namespace *ns)
 		{
 		  ts = &sym->ts;
 		  if (ts->type == BT_UNKNOWN)
-		    ts = gfc_get_default_type (sym, NULL);
+		    ts = gfc_get_default_type (sym->name, NULL);
 		  switch (ts->type)
 		    {
 		    case BT_INTEGER:
@@ -878,7 +878,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 "
@@ -1215,6 +1216,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
   gfc_symtree *parent_st;
   gfc_expr *e;
   int save_need_full_assumed_size;
+  gfc_component *comp;
 	
   for (; arg; arg = arg->next)
     {
@@ -1234,6 +1236,13 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  continue;
 	}
 
+      if (is_proc_ptr_comp (e, &comp))
+	{
+	  e->ts = comp->ts;
+	  e->expr_type = EXPR_VARIABLE;
+	  goto argument_list;
+	}
+
       if (e->expr_type == EXPR_VARIABLE
 	    && e->symtree->n.sym->attr.generic
 	    && no_formal_args
@@ -1906,7 +1915,7 @@ set_type:
     expr->ts = sym->ts;
   else
     {
-      ts = gfc_get_default_type (sym, sym->ns);
+      ts = gfc_get_default_type (sym->name, sym->ns);
 
       if (ts->type == BT_UNKNOWN)
 	{
@@ -4804,6 +4813,61 @@ resolve_compcall (gfc_expr* e)
 }
 
 
+/* Resolve a CALL to a Procedure Pointer Component (Subroutine).  */
+
+static gfc_try
+resolve_ppc_call (gfc_code* c)
+{
+  gfc_component *comp;
+  gcc_assert (is_proc_ptr_comp (c->expr, &comp));
+
+  c->resolved_sym = c->expr->symtree->n.sym;
+  c->expr->expr_type = EXPR_VARIABLE;
+  c->ext.actual = c->expr->value.compcall.actual;
+
+  if (!comp->attr.subroutine)
+    gfc_add_subroutine (&comp->attr, comp->name, &c->expr->where);
+
+  if (resolve_actual_arglist (c->ext.actual, comp->attr.proc,
+			      comp->formal == NULL) == FAILURE)
+    return FAILURE;
+
+  /* TODO: Check actual arguments.
+     gfc_procedure_use (stree->n.sym, &c->expr->value.compcall.actual,
+			&c->expr->where);*/
+
+  return SUCCESS;
+}
+
+
+/* Resolve a Function Call to a Procedure Pointer Component (Function).  */
+
+static gfc_try
+resolve_expr_ppc (gfc_expr* e)
+{
+  gfc_component *comp;
+  gcc_assert (is_proc_ptr_comp (e, &comp));
+
+  /* Convert to EXPR_FUNCTION.  */
+  e->expr_type = EXPR_FUNCTION;
+  e->value.function.isym = NULL;
+  e->value.function.actual = e->value.compcall.actual;
+  e->ts = comp->ts;
+
+  if (!comp->attr.function)
+    gfc_add_function (&comp->attr, comp->name, &e->where);
+
+  if (resolve_actual_arglist (e->value.function.actual, comp->attr.proc,
+			      comp->formal == NULL) == FAILURE)
+    return FAILURE;
+
+  /* TODO: Check actual arguments.
+     gfc_procedure_use (stree->n.sym, &e->value.compcall.actual, &e->where);  */
+
+  return SUCCESS;
+}
+
+
 /* Resolve an expression.  That is, make sure that types of operands agree
    with their operators, intrinsic operators are converted to function calls
    for overloaded types and unresolved function references are resolved.  */
@@ -4853,6 +4917,10 @@ gfc_resolve_expr (gfc_expr *e)
       t = SUCCESS;
       break;
 
+    case EXPR_PPC:
+      t = resolve_expr_ppc (e);
+      break;
+
     case EXPR_ARRAY:
       t = FAILURE;
       if (resolve_ref (e) == FAILURE)
@@ -6819,7 +6887,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	}
 
       t = SUCCESS;
-      if (code->op != EXEC_COMPCALL)
+      if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
 	t = gfc_resolve_expr (code->expr);
       forall_flag = forall_save;
 
@@ -6931,6 +6999,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  resolve_typebound_call (code);
 	  break;
 
+	case EXEC_CALL_PPC:
+          resolve_ppc_call (code);
+	  break;
+
 	case EXEC_SELECT:
 	  /* Select is complicated. Also, a SELECT construct could be
 	     a transformed computed GOTO.  */
@@ -8906,6 +8978,78 @@ resolve_fl_derived (gfc_symbol *sym)
 
   for (c = sym->components; c != NULL; c = c->next)
     {
+      if (c->attr.proc_pointer && c->ts.interface)
+	{
+	  if (c->ts.interface->attr.procedure)
+	    gfc_error ("Interface '%s', used by procedure pointer component "
+		       "'%s' at %L, is declared in a later PROCEDURE statement",
+		       c->ts.interface->name, c->name, &c->loc);
+
+	  /* 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;
+
+	      if (ifc->attr.intrinsic)
+		resolve_intrinsic (ifc, &ifc->declared_at);
+
+	      if (ifc->result)
+		c->ts = ifc->result->ts;
+	      else   
+		c->ts = ifc->ts;
+	      c->ts.interface = ifc;
+	      c->attr.function = ifc->attr.function;
+	      c->attr.subroutine = ifc->attr.subroutine;
+	      /* TODO: gfc_copy_formal_args (c, ifc);  */
+
+	      c->attr.allocatable = ifc->attr.allocatable;
+	      c->attr.pointer = ifc->attr.pointer;
+	      c->attr.pure = ifc->attr.pure;
+	      c->attr.elemental = ifc->attr.elemental;
+	      c->attr.dimension = ifc->attr.dimension;
+	      c->attr.recursive = ifc->attr.recursive;
+	      c->attr.always_explicit = ifc->attr.always_explicit;
+	      /* Copy array spec.  */
+	      c->as = gfc_copy_array_spec (ifc->as);
+	      /*if (c->as)
+		{
+		  int i;
+		  for (i = 0; i < c->as->rank; i++)
+		    {
+		      gfc_expr_replace_symbols (c->as->lower[i], c);
+		      gfc_expr_replace_symbols (c->as->upper[i], c);
+		    }
+	        }*/
+	      /* Copy char length.  */
+	      if (ifc->ts.cl)
+		{
+		  c->ts.cl = gfc_get_charlen();
+	          c->ts.cl->resolved = ifc->ts.cl->resolved;
+		  c->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
+		  /*gfc_expr_replace_symbols (c->ts.cl->length, c);*/
+		  /* Add charlen to namespace.  */
+		  /*if (c->formal_ns)
+		    {
+		      c->ts.cl->next = c->formal_ns->cl_list;
+		      c->formal_ns->cl_list = c->ts.cl;
+		    }*/
+		}
+	    }
+	  else if (c->ts.interface->name[0] != '\0')
+	    {
+	      gfc_error ("Interface '%s' of procedure pointer component "
+			 "'%s' at %L must be explicit", c->ts.interface->name,
+			 c->name, &c->loc);
+	      return FAILURE;
+ 	    }
+	}
+      else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
+	{
+	  c->ts = *gfc_get_default_type (c->name, NULL);
+	  c->attr.implicit_type = 1;
+	}
+
       /* Check type-spec if this is not the parent-type component.  */
       if ((!sym->attr.extension || c != sym->components)
 	  && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
@@ -9157,7 +9301,8 @@ resolve_fl_parameter (gfc_symbol *sym)
      matches the implicit type, since PARAMETER statements can precede
      IMPLICIT statements.  */
   if (sym->attr.implicit_type
-      && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
+      && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name,
+							     sym->ns)))
     {
       gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
 		 "later IMPLICIT type", sym->name, &sym->declared_at);
@@ -9237,7 +9382,8 @@ resolve_symbol (gfc_symbol *sym)
 		   sym->name,&sym->declared_at);
 
       /* Get the attributes from the interface (now resolved).  */
-      if (sym->ts.interface->attr.if_source || sym->ts.interface->attr.intrinsic)
+      if (sym->ts.interface->attr.if_source
+	  || sym->ts.interface->attr.intrinsic)
 	{
 	  gfc_symbol *ifc = sym->ts.interface;