gcc/fortran/

[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-expr.c

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 58a0d6e..35c3f12 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -309,11 +309,43 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
     }
   else
     {
+      tree se_expr = NULL_TREE;
+
       se->expr = gfc_get_symbol_decl (sym);
 
+      /* Special case for assigning the return value of a function.
+        Self recursive functions must have an explicit return value.  */
+      if (se->expr == current_function_decl && sym->attr.function
+         && (sym->result == sym))
+       se_expr = gfc_get_fake_result_decl (sym);
+
+      /* Similarly for alternate entry points.  */
+      else if (sym->attr.function && sym->attr.entry
+              && (sym->result == sym)
+              && sym->ns->proc_name->backend_decl == current_function_decl)
+       {
+         gfc_entry_list *el = NULL;
+
+         for (el = sym->ns->entries; el; el = el->next)
+           if (sym == el->sym)
+             {
+               se_expr = gfc_get_fake_result_decl (sym);
+               break;
+             }
+       }
+
+      else if (sym->attr.result
+              && sym->ns->proc_name->backend_decl == current_function_decl
+              && sym->ns->proc_name->attr.entry_master
+              && !gfc_return_by_reference (sym->ns->proc_name))
+       se_expr = gfc_get_fake_result_decl (sym);
+
+      if (se_expr)
+       se->expr = se_expr;
+
       /* Procedure actual arguments.  */
-      if (sym->attr.flavor == FL_PROCEDURE
-         && se->expr != current_function_decl)
+      else if (sym->attr.flavor == FL_PROCEDURE
+              && se->expr != current_function_decl)
        {
          gcc_assert (se->want_pointer);
          if (!sym->attr.dummy)
@@ -324,20 +356,19 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
          return;
        }
 
-      /* Special case for assigning the return value of a function.
-         Self recursive functions must have an explicit return value.  */
-      if (se->expr == current_function_decl && sym->attr.function
-         && (sym->result == sym))
-       {
-         se->expr = gfc_get_fake_result_decl (sym);
-       }
-
       /* Dereference scalar dummy variables.  */
       if (sym->attr.dummy
          && sym->ts.type != BT_CHARACTER
          && !sym->attr.dimension)
        se->expr = gfc_build_indirect_ref (se->expr);
 
+      /* Dereference scalar hidden result.  */
+      if (gfc_option.flag_f2c 
+         && (sym->attr.function || sym->attr.result)
+         && sym->ts.type == BT_COMPLEX
+         && !sym->attr.dimension)
+       se->expr = gfc_build_indirect_ref (se->expr);
+
       /* Dereference pointer variables.  */
       if ((sym->attr.pointer || sym->attr.allocatable)
          && (sym->attr.dummy
@@ -1114,7 +1145,13 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                                      convert (gfc_charlen_type_node, len));
        }
       else
-       gcc_unreachable ();
+       {
+         gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
+
+         type = gfc_get_complex_type (sym->ts.kind);
+         var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
+         arglist = gfc_chainon_list (arglist, var);
+       }
     }
 
   formal = sym->formal;
@@ -1216,14 +1253,25 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
                     arglist, NULL_TREE);
 
+  if (sym->result)
+    sym = sym->result;
+
   /* If we have a pointer function, but we don't want a pointer, e.g.
      something like
         x = f()
      where f is pointer valued, we have to dereference the result.  */
-  if (!se->want_pointer && !byref
-      && (sym->attr.pointer || (sym->result && sym->result->attr.pointer)))
+  if (!se->want_pointer && !byref && sym->attr.pointer)
     se->expr = gfc_build_indirect_ref (se->expr);
 
+  /* f2c calling conventions require a scalar default real function to
+     return a double precision result.  Convert this back to default
+     real.  We only care about the cases that can happen in Fortran 77.
+  */
+  if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
+      && sym->ts.kind == gfc_default_real_kind
+      && !sym->attr.always_explicit)
+    se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
+
   /* A pure function may still have side-effects - it may modify its
      parameters.  */
   TREE_SIDE_EFFECTS (se->expr) = 1;
@@ -1258,7 +1306,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
              se->string_length = len;
            }
          else
-           gcc_unreachable ();
+           {
+             gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+             se->expr = gfc_build_indirect_ref (var);
+           }
        }
     }
 }