trans-expr.c (conv_isocbinding_procedure): New function.

2009-11-19  Janus Weil  <janus@gcc.gnu.org>

	* trans-expr.c (conv_isocbinding_procedure): New function.
	(gfc_conv_procedure_call): Move ISO_C_BINDING stuff to
	separate function.

From-SVN: r154327

gcc/fortran/ChangeLog

+2009-11-19  Janus Weil  <janus@gcc.gnu.org>
+
+	* trans-expr.c (conv_isocbinding_procedure): New function.
+	(gfc_conv_procedure_call): Move ISO_C_BINDING stuff to
+	separate function.
+
 2009-11-19  Tobias Burnus  <burnus@net-b.de>
 
 	* gfortran.texi (Interoperable Subroutines and Functions): Fix

gcc/fortran/trans-expr.c

@@ -2533,6 +2533,150 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
 }
 
 
+/* The following routine generates code for the intrinsic
+   procedures from the ISO_C_BINDING module:
+    * C_LOC           (function)
+    * C_FUNLOC        (function)
+    * C_F_POINTER     (subroutine)
+    * C_F_PROCPOINTER (subroutine)
+    * C_ASSOCIATED    (function)
+   One exception which is not handled here is C_F_POINTER with non-scalar
+   arguments. Returns 1 if the call was replaced by inline code (else: 0).  */
+
+static int
+conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
+			    gfc_actual_arglist * arg)
+{
+  gfc_symbol *fsym;
+  gfc_ss *argss;
+    
+  if (sym->intmod_sym_id == ISOCBINDING_LOC)
+    {
+      if (arg->expr->rank == 0)
+	gfc_conv_expr_reference (se, arg->expr);
+      else
+	{
+	  int f;
+	  /* This is really the actual arg because no formal arglist is
+	     created for C_LOC.	 */
+	  fsym = arg->expr->symtree->n.sym;
+
+	  /* We should want it to do g77 calling convention.  */
+	  f = (fsym != NULL)
+	    && !(fsym->attr.pointer || fsym->attr.allocatable)
+	    && fsym->as->type != AS_ASSUMED_SHAPE;
+	  f = f || !sym->attr.always_explicit;
+      
+	  argss = gfc_walk_expr (arg->expr);
+	  gfc_conv_array_parameter (se, arg->expr, argss, f,
+				    NULL, NULL, NULL);
+	}
+
+      /* TODO -- the following two lines shouldn't be necessary, but if
+	 they're removed, a bug is exposed later in the code path.
+	 This workaround was thus introduced, but will have to be
+	 removed; please see PR 35150 for details about the issue.  */
+      se->expr = convert (pvoid_type_node, se->expr);
+      se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+      return 1;
+    }
+  else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
+    {
+      arg->expr->ts.type = sym->ts.u.derived->ts.type;
+      arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
+      arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
+      gfc_conv_expr_reference (se, arg->expr);
+  
+      return 1;
+    }
+  else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
+	    && arg->next->expr->rank == 0)
+	   || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
+    {
+      /* Convert c_f_pointer if fptr is a scalar
+	 and convert c_f_procpointer.  */
+      gfc_se cptrse;
+      gfc_se fptrse;
+
+      gfc_init_se (&cptrse, NULL);
+      gfc_conv_expr (&cptrse, arg->expr);
+      gfc_add_block_to_block (&se->pre, &cptrse.pre);
+      gfc_add_block_to_block (&se->post, &cptrse.post);
+
+      gfc_init_se (&fptrse, NULL);
+      if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+	  || gfc_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);
+      
+      if (arg->next->expr->symtree->n.sym->attr.proc_pointer
+	  && arg->next->expr->symtree->n.sym->attr.dummy)
+	fptrse.expr = build_fold_indirect_ref_loc (input_location,
+						   fptrse.expr);
+      
+      se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
+			      fptrse.expr,
+			      fold_convert (TREE_TYPE (fptrse.expr),
+					    cptrse.expr));
+
+      return 1;
+    }
+  else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+    {
+      gfc_se arg1se;
+      gfc_se arg2se;
+
+      /* Build the addr_expr for the first argument.  The argument is
+	 already an *address* so we don't need to set want_pointer in
+	 the gfc_se.  */
+      gfc_init_se (&arg1se, NULL);
+      gfc_conv_expr (&arg1se, arg->expr);
+      gfc_add_block_to_block (&se->pre, &arg1se.pre);
+      gfc_add_block_to_block (&se->post, &arg1se.post);
+
+      /* See if we were given two arguments.  */
+      if (arg->next == NULL)
+	/* Only given one arg so generate a null and do a
+	   not-equal comparison against the first arg.  */
+	se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+				fold_convert (TREE_TYPE (arg1se.expr),
+					      null_pointer_node));
+      else
+	{
+	  tree eq_expr;
+	  tree not_null_expr;
+	  
+	  /* Given two arguments so build the arg2se from second arg.  */
+	  gfc_init_se (&arg2se, NULL);
+	  gfc_conv_expr (&arg2se, arg->next->expr);
+	  gfc_add_block_to_block (&se->pre, &arg2se.pre);
+	  gfc_add_block_to_block (&se->post, &arg2se.post);
+
+	  /* Generate test to compare that the two args are equal.  */
+	  eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
+				 arg1se.expr, arg2se.expr);
+	  /* Generate test to ensure that the first arg is not null.  */
+	  not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
+				       arg1se.expr, null_pointer_node);
+
+	  /* Finally, the generated test must check that both arg1 is not
+	     NULL and that it is equal to the second arg.  */
+	  se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+				  not_null_expr, eq_expr);
+	}
+
+      return 1;
+    }
+    
+  /* Nothing was done.  */
+  return 0;
+}
+
+
 /* 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.
@@ -2576,130 +2720,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   len = NULL_TREE;
   gfc_clear_ts (&ts);
 
-  if (sym->from_intmod == INTMOD_ISO_C_BINDING)
-    {
-      if (sym->intmod_sym_id == ISOCBINDING_LOC)
-	{
-	  if (arg->expr->rank == 0)
-	    gfc_conv_expr_reference (se, arg->expr);
-	  else
-	    {
-	      int f;
-	      /* This is really the actual arg because no formal arglist is
-		 created for C_LOC.	 */
-	      fsym = arg->expr->symtree->n.sym;
-
-	      /* We should want it to do g77 calling convention.  */
-	      f = (fsym != NULL)
-		&& !(fsym->attr.pointer || fsym->attr.allocatable)
-		&& fsym->as->type != AS_ASSUMED_SHAPE;
-	      f = f || !sym->attr.always_explicit;
-	  
-	      argss = gfc_walk_expr (arg->expr);
-	      gfc_conv_array_parameter (se, arg->expr, argss, f,
-					NULL, NULL, NULL);
-	    }
-
-	  /* TODO -- the following two lines shouldn't be necessary, but
-	    they're removed a bug is exposed later in the codepath.
-	    This is workaround was thus introduced, but will have to be
-	    removed; please see PR 35150 for details about the issue.  */
-	  se->expr = convert (pvoid_type_node, se->expr);
-	  se->expr = gfc_evaluate_now (se->expr, &se->pre);
-
-	  return 0;
-	}
-      else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
-	{
-	  arg->expr->ts.type = sym->ts.u.derived->ts.type;
-	  arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
-	  arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
-	  gfc_conv_expr_reference (se, arg->expr);
-      
-	  return 0;
-	}
-      else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
-	         && arg->next->expr->rank == 0)
-	       || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
-	{
-	  /* Convert c_f_pointer if fptr is a scalar
-	     and convert c_f_procpointer.  */
-	  gfc_se cptrse;
-	  gfc_se fptrse;
-
-	  gfc_init_se (&cptrse, NULL);
-	  gfc_conv_expr (&cptrse, arg->expr);
-	  gfc_add_block_to_block (&se->pre, &cptrse.pre);
-	  gfc_add_block_to_block (&se->post, &cptrse.post);
-
-	  gfc_init_se (&fptrse, NULL);
-	  if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
-	      || gfc_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);
-	  
-	  if (arg->next->expr->symtree->n.sym->attr.proc_pointer
-	      && arg->next->expr->symtree->n.sym->attr.dummy)
-	    fptrse.expr = build_fold_indirect_ref_loc (input_location,
-						       fptrse.expr);
-	  
-	  se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (fptrse.expr),
-				  fptrse.expr,
-				  fold_convert (TREE_TYPE (fptrse.expr),
-						cptrse.expr));
-
-	  return 0;
-	}
-      else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
-        {
-	  gfc_se arg1se;
-	  gfc_se arg2se;
-
-	  /* Build the addr_expr for the first argument.  The argument is
-	     already an *address* so we don't need to set want_pointer in
-	     the gfc_se.  */
-	  gfc_init_se (&arg1se, NULL);
-	  gfc_conv_expr (&arg1se, arg->expr);
-	  gfc_add_block_to_block (&se->pre, &arg1se.pre);
-	  gfc_add_block_to_block (&se->post, &arg1se.post);
-
-	  /* See if we were given two arguments.  */
-	  if (arg->next == NULL)
-	    /* Only given one arg so generate a null and do a
-	       not-equal comparison against the first arg.  */
-	    se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
-				    fold_convert (TREE_TYPE (arg1se.expr),
-						  null_pointer_node));
-	  else
-	    {
-	      tree eq_expr;
-	      tree not_null_expr;
-	      
-	      /* Given two arguments so build the arg2se from second arg.  */
-	      gfc_init_se (&arg2se, NULL);
-	      gfc_conv_expr (&arg2se, arg->next->expr);
-	      gfc_add_block_to_block (&se->pre, &arg2se.pre);
-	      gfc_add_block_to_block (&se->post, &arg2se.post);
-
-	      /* Generate test to compare that the two args are equal.  */
-	      eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
-				     arg1se.expr, arg2se.expr);
-	      /* Generate test to ensure that the first arg is not null.  */
-	      not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
-					   arg1se.expr, null_pointer_node);
-
-	      /* Finally, the generated test must check that both arg1 is not
-		 NULL and that it is equal to the second arg.  */
-	      se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
-				      not_null_expr, eq_expr);
-	    }
-
-	  return 0;
-	}
-    }
+  if (sym->from_intmod == INTMOD_ISO_C_BINDING
+      && conv_isocbinding_procedure (se, sym, arg))
+    return 0;
 
   gfc_is_proc_ptr_comp (expr, &comp);