gcc/fortran/

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

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 19a8e7a..bb3a890 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -348,6 +348,27 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
 }
 
 
+/* Get the interface symbol for the procedure corresponding to the given call.
+   We can't get the procedure symbol directly as we have to handle the case
+   of (deferred) type-bound procedures.  */
+
+static gfc_symbol *
+get_proc_ifc_for_call (gfc_code *c)
+{
+  gfc_symbol *sym;
+
+  gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
+
+  sym = gfc_get_proc_ifc_for_expr (c->expr1);
+
+  /* Fall back/last resort try.  */
+  if (sym == NULL)
+    sym = c->resolved_sym;
+
+  return sym;
+}
+
+
 /* Translate the CALL statement.  Builds a call to an F95 subroutine.  */
 
 tree
@@ -372,7 +393,8 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
   ss = gfc_ss_terminator;
   if (code->resolved_sym->attr.elemental)
     ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
-                                          code->expr1, GFC_SS_REFERENCE);
+                                          get_proc_ifc_for_call (code),
+                                          GFC_SS_REFERENCE);
 
   /* Is not an elemental subroutine call with array valued arguments.  */
   if (ss == gfc_ss_terminator)
@@ -1175,6 +1197,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_se se;
 
       gfc_init_se (&se, NULL);
+      se.descriptor_only = 1;
       gfc_conv_expr (&se, e);
 
       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
@@ -4949,13 +4972,14 @@ gfc_trans_allocate (gfc_code * code)
          else
            gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
 
-         if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
+         if (al->expr->ts.type == BT_DERIVED
+             && expr->ts.u.derived->attr.alloc_comp)
            {
              tmp = build_fold_indirect_ref_loc (input_location, se.expr);
              tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
              gfc_add_expr_to_block (&se.pre, tmp);
            }
-         else if (al->expr->ts.type == BT_CLASS && code->expr3)
+         else if (al->expr->ts.type == BT_CLASS)
            {
              /* With class objects, it is best to play safe and null the 
                 memory because we cannot know if dynamic types have allocatable
@@ -5074,7 +5098,13 @@ gfc_trans_allocate (gfc_code * code)
              actual->next->expr = gfc_copy_expr (al->expr);
              actual->next->expr->ts.type = BT_CLASS;
              gfc_add_data_component (actual->next->expr);
+
              dataref = actual->next->expr->ref;
+             /* Make sure we go up through the reference chain to
+                the _data reference, where the arrayspec is found.  */
+             while (dataref->next && dataref->next->type != REF_ARRAY)
+               dataref = dataref->next;
+
              if (dataref->u.c.component->as)
                {
                  int dim;