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.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index fc0a033..95e761f 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index b72d540..c0df678 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/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);