2006-09-30 Brooks Moses <bmoses@stanford.edu>

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

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5c396ef..e477f9c 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1386,11 +1386,10 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
       tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
       tmp = build_pointer_type (tmp);
       if (sym->attr.pointer)
-       tmp = build_pointer_type (tmp);
-
-      value = fold_convert (tmp, se->expr);
-      if (sym->attr.pointer)
-       value = build_fold_indirect_ref (value);
+        value = build_fold_indirect_ref (se->expr);
+      else
+        value = se->expr;
+      value = fold_convert (tmp, value);
     }
 
   /* If the argument is a scalar, a pointer to an array or an allocatable,
@@ -1707,6 +1706,12 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
       gcc_assert (rse.ss == gfc_ss_terminator);
       gfc_trans_scalarizing_loops (&loop, &body);
     }
+  else
+    {
+      /* Make sure that the temporary declaration survives.  */
+      tmp = gfc_finish_block (&body);
+      gfc_add_expr_to_block (&loop.pre, tmp);
+    }
 
   /* Add the post block after the second loop, so that any
      freeing of allocated memory is done at the right time.  */
@@ -1981,7 +1986,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                   array of derived types.  In this case, the argument
                   is converted to a temporary, which is passed and then
                   written back after the procedure call.  */
-               gfc_conv_aliased_arg (&parmse, e, f, fsym->attr.intent);
+               gfc_conv_aliased_arg (&parmse, e, f,
+                       fsym ? fsym->attr.intent : INTENT_INOUT);
              else
                gfc_conv_array_parameter (&parmse, e, argss, f);
 
@@ -2013,6 +2019,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
 
+      /* If an INTENT(OUT) dummy of derived type has a default
+        initializer, it must be (re)initialized here.  */
+      if (fsym && fsym->attr.intent == INTENT_OUT && fsym->ts.type == BT_DERIVED
+          && fsym->value)
+       {
+         gcc_assert (!fsym->attr.allocatable);
+         tmp = gfc_trans_assignment (e, fsym->value);
+         gfc_add_expr_to_block (&se->pre, tmp);
+       }
+
+      if (fsym && fsym->ts.type == BT_CHARACTER
+            && parmse.string_length == NULL_TREE
+            && e->ts.type == BT_PROCEDURE
+            && e->symtree->n.sym->ts.type == BT_CHARACTER
+            && e->symtree->n.sym->ts.cl->length != NULL)
+       {
+         gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
+         parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
+       }
+
       /* Character strings are passed as two parameters, a length and a
          pointer.  */
       if (parmse.string_length != NULL_TREE)
@@ -2029,12 +2055,22 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
        {
          /* Assumed character length results are not allowed by 5.1.1.5 of the
             standard and are trapped in resolve.c; except in the case of SPREAD
-            (and other intrinsics?).  In this case, we take the character length
-            of the first argument for the result.  */
-         cl.backend_decl = TREE_VALUE (stringargs);
-       }
-      else
-       {
+            (and other intrinsics?) and dummy functions.  In the case of SPREAD,
+            we take the character length of the first argument for the result.
+            For dummies, we have to look through the formal argument list for
+            this function and use the character length found there.*/
+         if (!sym->attr.dummy)
+           cl.backend_decl = TREE_VALUE (stringargs);
+         else
+           {
+             formal = sym->ns->proc_name->formal;
+             for (; formal; formal = formal->next)
+               if (strcmp (formal->sym->name, sym->name) == 0)
+                 cl.backend_decl = formal->sym->ts.cl->backend_decl;
+           }
+        }
+        else
+        {
          /* Calculate the length of the returned string.  */
          gfc_init_se (&parmse, NULL);
          if (need_interface_mapping)
@@ -2227,10 +2263,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 /* Generate code to copy a string.  */
 
 static void
-gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
-                      tree slen, tree src)
+gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
+                      tree slength, tree src)
 {
-  tree tmp;
+  tree tmp, dlen, slen;
   tree dsc;
   tree ssc;
   tree cond;
@@ -2240,6 +2276,9 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
   tree tmp4;
   stmtblock_t tempblock;
 
+  dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
+  slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+
   /* Deal with single character specially.  */
   dsc = gfc_to_single_character (dlen, dest);
   ssc = gfc_to_single_character (slen, src);
@@ -2655,9 +2694,19 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
     }
   else if (expr->ts.type == BT_DERIVED)
     {
-      /* Nested derived type.  */
-      tmp = gfc_trans_structure_assign (dest, expr);
-      gfc_add_expr_to_block (&block, tmp);
+      if (expr->expr_type != EXPR_STRUCTURE)
+       {
+         gfc_init_se (&se, NULL);
+         gfc_conv_expr (&se, expr);
+         gfc_add_modify_expr (&block, dest,
+                              fold_convert (TREE_TYPE (dest), se.expr));
+       }
+      else
+       {
+         /* Nested constructors.  */
+         tmp = gfc_trans_structure_assign (dest, expr);
+         gfc_add_expr_to_block (&block, tmp);
+       }
     }
   else
     {