2009-05-25 Janus Weil <janus@gcc.gnu.org>

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

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 14f64c9..f1f0091 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -476,8 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       se->string_length = tmp;
     }
 
-  if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0
-      && c->ts.type != BT_CHARACTER)
+  if ((c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+      || c->attr.proc_pointer)
     se->expr = build_fold_indirect_ref (se->expr);
 }
 
@@ -2396,6 +2396,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   gfc_symbol *fsym;
   stmtblock_t post;
   enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
+  gfc_component *comp = NULL;
 
   arglist = NULL_TREE;
   retargs = NULL_TREE;
@@ -2424,7 +2425,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              f = f || !sym->attr.always_explicit;
          
              argss = gfc_walk_expr (arg->expr);
-             gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
+             gfc_conv_array_parameter (se, arg->expr, argss, f,
+                                       NULL, NULL, NULL);
            }
 
          /* TODO -- the following two lines shouldn't be necessary, but
@@ -2549,11 +2551,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   gfc_init_block (&post);
   gfc_init_interface_mapping (&mapping);
+  is_proc_ptr_comp (expr, &comp);
   need_interface_mapping = ((sym->ts.type == BT_CHARACTER
                                  && sym->ts.cl->length
                                  && sym->ts.cl->length->expr_type
                                                != EXPR_CONSTANT)
-                             || sym->attr.dimension);
+                             || (comp && comp->attr.dimension)
+                             || (!comp && sym->attr.dimension));
   formal = sym->formal;
   /* Evaluate the arguments.  */
   for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
@@ -2676,7 +2680,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                        fsym ? fsym->attr.intent : INTENT_INOUT);
              else
                gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
-                                         sym->name);
+                                         sym->name, NULL);
 
               /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
                  allocated on entry, it must be deallocated.  */
@@ -2824,7 +2828,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       len = cl.backend_decl;
     }
 
-  byref = gfc_return_by_reference (sym);
+  byref = (comp && comp->attr.dimension)
+         || (!comp && gfc_return_by_reference (sym));
   if (byref)
     {
       if (se->direct_byref)
@@ -4014,7 +4019,7 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
 tree
 gfc_trans_pointer_assign (gfc_code * code)
 {
-  return gfc_trans_pointer_assignment (code->expr, code->expr2);
+  return gfc_trans_pointer_assignment (code->expr1, code->expr2);
 }
 
 
@@ -4052,6 +4057,10 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
          && expr1->symtree->n.sym->attr.dummy)
        lse.expr = build_fold_indirect_ref (lse.expr);
 
+      if (expr2->symtree && expr2->symtree->n.sym->attr.proc_pointer
+         && expr2->symtree->n.sym->attr.dummy)
+       rse.expr = build_fold_indirect_ref (rse.expr);
+
       gfc_add_block_to_block (&block, &lse.pre);
       gfc_add_block_to_block (&block, &rse.pre);
 
@@ -4283,6 +4292,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_ss *ss;
   gfc_ref * ref;
   bool seen_array_ref;
+  gfc_component *comp = NULL;
 
   /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION.  */
   if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
@@ -4342,8 +4352,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
 
   /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
      functions.  */
+  is_proc_ptr_comp(expr2, &comp);
   gcc_assert (expr2->value.function.isym
-             || (gfc_return_by_reference (expr2->value.function.esym)
+             || (comp && comp->attr.dimension)
+             || (!comp && gfc_return_by_reference (expr2->value.function.esym)
              && expr2->value.function.esym->result->attr.dimension));
 
   ss = gfc_walk_expr (expr1);
@@ -4352,7 +4364,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
   gfc_start_block (&se.pre);
   se.want_pointer = 1;
 
-  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
+  gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
 
   se.direct_byref = 1;
   se.ss = gfc_walk_expr (expr2);
@@ -4427,11 +4439,14 @@ gfc_trans_zero_assign (gfc_expr * expr)
   len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
                     fold_convert (gfc_array_index_type, tmp));
 
-  /* Convert arguments to the correct types.  */
+  /* If we are zeroing a local array avoid taking its address by emitting
+     a = {} instead.  */
   if (!POINTER_TYPE_P (TREE_TYPE (dest)))
-    dest = gfc_build_addr_expr (pvoid_type_node, dest);
-  else
-    dest = fold_convert (pvoid_type_node, dest);
+    return build2 (MODIFY_EXPR, void_type_node,
+                  dest, build_constructor (TREE_TYPE (dest), NULL));
+
+  /* Convert arguments to the correct types.  */
+  dest = fold_convert (pvoid_type_node, dest);
   len = fold_convert (size_type_node, len);
 
   /* Construct call to __builtin_memset.  */
@@ -4839,11 +4854,11 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
 tree
 gfc_trans_init_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr, code->expr2, true);
+  return gfc_trans_assignment (code->expr1, code->expr2, true);
 }
 
 tree
 gfc_trans_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr, code->expr2, false);
+  return gfc_trans_assignment (code->expr1, code->expr2, false);
 }