PR fortran/31974

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

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5ff0c44..d5f584c 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1,5 +1,6 @@
 /* Expression translation
-   Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
+   Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
 
@@ -260,6 +261,10 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
     gfc_conv_string_parameter (se);
   else
     {
+      /* Avoid multiple evaluation of substring start.  */
+      if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
+       start.expr = gfc_evaluate_now (start.expr, &se->pre);
+
       /* Change the start of the string.  */
       if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
        tmp = se->expr;
@@ -278,6 +283,9 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
       gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
       gfc_add_block_to_block (&se->pre, &end.pre);
     }
+  if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
+    end.expr = gfc_evaluate_now (end.expr, &se->pre);
+
   if (flag_bounds_check)
     {
       tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
@@ -927,13 +935,11 @@ gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
     {
       /* Allocate a temporary to hold the result.  */
       var = gfc_create_var (type, "pstr");
-      tmp = build_call_expr (gfor_fndecl_internal_malloc, 1, len);
-      tmp = convert (type, tmp);
+      tmp = gfc_call_malloc (&se->pre, type, len);
       gfc_add_modify_expr (&se->pre, var, tmp);
 
       /* Free the temporary afterwards.  */
-      tmp = convert (pvoid_type_node, var);
-      tmp = build_call_expr (gfor_fndecl_internal_free, 1, tmp);
+      tmp = gfc_call_free (convert (pvoid_type_node, var));
       gfc_add_expr_to_block (&se->post, tmp);
     }
 
@@ -1347,7 +1353,7 @@ gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
 
 static tree
 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
-                                int packed, tree data)
+                                gfc_packed packed, tree data)
 {
   tree type;
   tree var;
@@ -1499,14 +1505,16 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
 
       /* Create the replacement variable.  */
       tmp = gfc_conv_descriptor_data_get (desc);
-      value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
+      value = gfc_get_interface_mapping_array (&se->pre, sym,
+                                              PACKED_NO, tmp);
 
       /* Use DESC to work out the upper bounds, strides and offset.  */
       gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
     }
   else
     /* Otherwise we have a packed array.  */
-    value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
+    value = gfc_get_interface_mapping_array (&se->pre, sym,
+                                            PACKED_FULL, se->expr);
 
   new_sym->backend_decl = value;
 }
@@ -2314,7 +2322,17 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   if (byref)
     {
       if (se->direct_byref)
-       retargs = gfc_chainon_list (retargs, se->expr);
+       {
+         /* Sometimes, too much indirection can be applied; eg. for
+            function_result = array_valued_recursive_function.  */
+         if (TREE_TYPE (TREE_TYPE (se->expr))
+               && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
+               && GFC_DESCRIPTOR_TYPE_P
+                       (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
+           se->expr = build_fold_indirect_ref (se->expr);
+
+         retargs = gfc_chainon_list (retargs, se->expr);
+       }
       else if (sym->result->attr.dimension)
        {
          gcc_assert (se->loop && info);
@@ -3940,6 +3958,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
   if (expr1->expr_type == EXPR_VARIABLE
       && expr1->rank > 0
       && expr1->ref
+      && expr1->ref->next == NULL
       && gfc_full_array_ref_p (expr1->ref)
       && is_zero_initializer_p (expr2))
     {