2005-05-29 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/16939
	PR fortran/17192
	PR fortran/17193
	PR fortran/17202
	PR fortran/18689
	PR fortran/18890
	PR fortran/21297
	* fortran/trans-array.c (gfc_conv_resolve_dependencies): Add string
	length to temp_ss for character pointer array assignments.
	* fortran/trans-expr.c (gfc_conv_variable): Correct errors in
	dereferencing of characters and character pointers.
	* fortran/trans-expr.c (gfc_conv_function_call): Provide string
	length as return argument for various kinds of handling of return.
	Return a char[]* temporary for character pointer functions and
	dereference the temporary upon return.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@100324 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6dc33d3..047f8bc 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2342,7 +2342,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest,
       loop->temp_ss->type = GFC_SS_TEMP;
       loop->temp_ss->data.temp.type =
        gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
-      loop->temp_ss->string_length = NULL_TREE;
+      loop->temp_ss->string_length = dest->string_length;
       loop->temp_ss->data.temp.dimen = loop->dimen;
       loop->temp_ss->next = gfc_ss_terminator;
       gfc_add_ss_to_loop (loop, loop->temp_ss);
@@ -3617,6 +3617,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       loop.temp_ss->type = GFC_SS_TEMP;
       loop.temp_ss->next = gfc_ss_terminator;
       loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+
       /* ... which can hold our string, if present.  */
       if (expr->ts.type == BT_CHARACTER)
        se->string_length = loop.temp_ss->string_length

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 52a532d..c04efd2 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -354,30 +354,43 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
              se->expr = gfc_build_addr_expr (NULL, se->expr);
            }
          return;
-       }
-
-      /* 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
-             || sym->attr.result
-             || sym->attr.function
-             || !sym->attr.dimension)
-          && sym->ts.type != BT_CHARACTER)
-       se->expr = gfc_build_indirect_ref (se->expr);
-
+       }\r
+
+\r
+      /* Dereference the expression, where needed. Since characters\r
+        are entirely different from other types, they are treated \r
+        separately.  */\r
+      if (sym->ts.type == BT_CHARACTER)\r
+       {\r
+          /* Dereference character pointer dummy arguments\r
+            or results.  */
+         if ((sym->attr.pointer || sym->attr.allocatable)\r
+             && ((sym->attr.dummy)\r
+                 || (sym->attr.function\r
+                 || sym->attr.result)))\r
+           se->expr = gfc_build_indirect_ref (se->expr);\r
+       }\r
+      else\r
+       {\r
+          /* Dereference non-charcter scalar dummy arguments.  */
+         if ((sym->attr.dummy) && (!sym->attr.dimension))\r
+           se->expr = gfc_build_indirect_ref (se->expr);\r
+\r
+          /* Dereference scalar hidden result.  */
+         if ((gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX)\r
+             && (sym->attr.function || sym->attr.result)\r
+             && (!sym->attr.dimension))\r
+           se->expr = gfc_build_indirect_ref (se->expr);\r
+\r
+          /* Dereference non-character pointer variables. \r
+            These must be dummys or results or scalars.  */
+         if ((sym->attr.pointer || sym->attr.allocatable)\r
+             && ((sym->attr.dummy) \r
+                 || (sym->attr.function || sym->attr.result)\r
+                 || (!sym->attr.dimension)))\r
+           se->expr = gfc_build_indirect_ref (se->expr);\r
+       }\r
+\r
       ref = expr->ref;
     }
 
@@ -1083,6 +1096,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   var = NULL_TREE;
   len = NULL_TREE;
 
+  /* Obtain the string length now because it is needed often below.  */
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      gcc_assert (sym->ts.cl && sym->ts.cl->length
+                 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
+      len = gfc_conv_mpz_to_tree
+             (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+    }
+
   if (se->ss != NULL)
     {
       if (!sym->attr.elemental)
@@ -1097,6 +1119,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
               /* Access the previously obtained result.  */
               gfc_conv_tmp_array_ref (se);
               gfc_advance_se_ss_chain (se);
+
+             /* Bundle in the string length.  */
+             se->string_length=len;
               return;
             }
        }
@@ -1108,14 +1133,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   byref = gfc_return_by_reference (sym);
   if (byref)
     {
-      if (se->direct_byref)
-       arglist = gfc_chainon_list (arglist, se->expr);
+      if (se->direct_byref) 
+       {
+         arglist = gfc_chainon_list (arglist, se->expr);
+\r
+         /* Add string length to argument list.  */\r
+         if (sym->ts.type == BT_CHARACTER)
+           {
+             sym->ts.cl->backend_decl = len;
+             arglist = gfc_chainon_list (arglist, 
+                               convert (gfc_charlen_type_node, len));
+           }
+       }
       else if (sym->result->attr.dimension)
        {
-         gcc_assert (se->loop && se->ss);
+         gcc_assert (se->loop && se->ss);\r
+
          /* Set the type of the array.  */
          tmp = gfc_typenode_for_spec (&sym->ts);
-         info->dimen = se->loop->dimen;
+         info->dimen = se->loop->dimen;\r
+
          /* Allocate a temporary to store the result.  */
          gfc_trans_allocate_temp_array (se->loop, info, tmp);
 
@@ -1124,22 +1161,46 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
            gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
          gfc_add_modify_expr (&se->pre, tmp,
                               convert (TREE_TYPE (tmp), integer_zero_node));
+\r
          /* Pass the temporary as the first argument.  */
          tmp = info->descriptor;
          tmp = gfc_build_addr_expr (NULL, tmp);
          arglist = gfc_chainon_list (arglist, tmp);
+
+         /* Add string length to argument list.  */
+         if (sym->ts.type == BT_CHARACTER)
+           {
+             sym->ts.cl->backend_decl = len;
+             arglist = gfc_chainon_list (arglist, 
+                             convert (gfc_charlen_type_node, len));
+           }
+
        }
       else if (sym->ts.type == BT_CHARACTER)
        {
-         gcc_assert (sym->ts.cl && sym->ts.cl->length
-                 && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
-         len = gfc_conv_mpz_to_tree
-           (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+\r
+         /* Pass the string length.  */\r
          sym->ts.cl->backend_decl = len;
          type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
          type = build_pointer_type (type);
 
-         var = gfc_conv_string_tmp (se, type, len);
+         /* Return an address to a char[4]* temporary for character pointers.  */
+         if (sym->attr.pointer || sym->attr.allocatable)
+           {
+             /* Build char[4] * pstr.  */
+             tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,\r
+                                convert (gfc_charlen_type_node, integer_one_node));\r
+             tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);\r
+             tmp = build_array_type (gfc_character1_type_node, tmp);\r
+             var = gfc_create_var (build_pointer_type (tmp), "pstr");
+
+             /* Provide an address expression for the function arguments.  */\r
+             var = gfc_build_addr_expr (NULL, var);\r
+           }
+         else
+           {
+             var = gfc_conv_string_tmp (se, type, len);\r
+           }
          arglist = gfc_chainon_list (arglist, var);
          arglist = gfc_chainon_list (arglist, 
                                      convert (gfc_charlen_type_node, len));
@@ -1205,8 +1266,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                  && arg->expr->expr_type != EXPR_NULL)
                 {
                   /* Scalar pointer dummy args require an extra level of
-                     indirection. The null pointer already contains
-                    this level of indirection.  */
+                 indirection. The null pointer already contains
+                 this level of indirection.  */
                   parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
                 }
             }
@@ -1299,10 +1360,17 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                  gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
                }
              se->expr = info->descriptor;
+             /* Bundle in the string length.  */
+             se->string_length = len;
            }
          else if (sym->ts.type == BT_CHARACTER)
-           {
-             se->expr = var;
+           {\r
+             /* Dereference for character pointer results.  */
+             if (sym->attr.pointer || sym->attr.allocatable)
+               se->expr = gfc_build_indirect_ref (var);\r
+             else\r
+               se->expr = var;
+
              se->string_length = len;
            }
          else
@@ -2229,7 +2297,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
     }
   else
     gfc_conv_expr (&lse, expr1);
-
+\r
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
   gfc_add_expr_to_block (&body, tmp);