OSDN Git Service

PR fortran/30964
[pf3gnuchains/gcc-fork.git] / gcc / fortran / trans-expr.c
index 898a626..d421a73 100644 (file)
@@ -8,7 +8,7 @@ This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
 version.
 
 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
@@ -17,9 +17,8 @@ FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 for more details.
 
 You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING.  If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA.  */
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
 
 /* trans-expr.c-- generate GENERIC trees for gfc_expr.  */
 
@@ -297,12 +296,14 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
       fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
                           nonempty, fault);
       if (name)
-       asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
+       asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
                  "is less than one", name);
       else
-       asprintf (&msg, "Substring out of bounds: lower bound "
+       asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
                  "is less than one");
-      gfc_trans_runtime_check (fault, msg, &se->pre, where);
+      gfc_trans_runtime_check (fault, &se->pre, where, msg,
+                              fold_convert (long_integer_type_node,
+                                            start.expr));
       gfc_free (msg);
 
       /* Check upper bound.  */
@@ -311,12 +312,15 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
       fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
                           nonempty, fault);
       if (name)
-       asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
-                 "exceeds string length", name);
+       asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
+                 "exceeds string length (%%ld)", name);
       else
-       asprintf (&msg, "Substring out of bounds: upper bound "
-                 "exceeds string length");
-      gfc_trans_runtime_check (fault, msg, &se->pre, where);
+       asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
+                 "exceeds string length (%%ld)");
+      gfc_trans_runtime_check (fault, &se->pre, where, msg,
+                              fold_convert (long_integer_type_node, end.expr),
+                              fold_convert (long_integer_type_node,
+                                            se->string_length));
       gfc_free (msg);
     }
 
@@ -1032,8 +1036,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
   enum tree_code code;
   gfc_se lse;
   gfc_se rse;
-  tree type;
-  tree tmp;
+  tree tmp, type;
   int lop;
   int checkstring;
 
@@ -1182,7 +1185,7 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
   if (lop)
     {
       /* The result of logical ops is always boolean_type_node.  */
-      tmp = fold_build2 (code, type, lse.expr, rse.expr);
+      tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
       se->expr = convert (type, tmp);
     }
   else
@@ -1210,6 +1213,64 @@ gfc_to_single_character (tree len, tree str)
   return NULL_TREE;
 }
 
+
+void
+gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
+{
+
+  if (sym->backend_decl)
+    {
+      /* This becomes the nominal_type in
+        function.c:assign_parm_find_data_types.  */
+      TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
+      /* This becomes the passed_type in
+        function.c:assign_parm_find_data_types.  C promotes char to
+        integer for argument passing.  */
+      DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
+
+      DECL_BY_REFERENCE (sym->backend_decl) = 0;
+    }
+
+  if (expr != NULL)
+    {
+      /* If we have a constant character expression, make it into an
+        integer.  */
+      if ((*expr)->expr_type == EXPR_CONSTANT)
+        {
+         gfc_typespec ts;
+
+         *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
+         if ((*expr)->ts.kind != gfc_c_int_kind)
+           {
+             /* The expr needs to be compatible with a C int.  If the 
+                conversion fails, then the 2 causes an ICE.  */
+             ts.type = BT_INTEGER;
+             ts.kind = gfc_c_int_kind;
+             gfc_convert_type (*expr, &ts, 2);
+           }
+       }
+      else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
+        {
+         if ((*expr)->ref == NULL)
+           {
+             se->expr = gfc_to_single_character
+               (build_int_cst (integer_type_node, 1),
+                gfc_build_addr_expr (pchar_type_node,
+                                     gfc_get_symbol_decl
+                                     ((*expr)->symtree->n.sym)));
+           }
+         else
+           {
+             gfc_conv_variable (se, *expr);
+             se->expr = gfc_to_single_character
+               (build_int_cst (integer_type_node, 1),
+                gfc_build_addr_expr (pchar_type_node, se->expr));
+           }
+       }
+    }
+}
+
+
 /* Compare two strings. If they are all single characters, the result is the
    subtraction of them. Otherwise, we build a library call.  */
 
@@ -1218,23 +1279,20 @@ gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
 {
   tree sc1;
   tree sc2;
-  tree type;
   tree tmp;
 
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
   gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
 
-  type = gfc_get_int_type (gfc_default_integer_kind);
-
   sc1 = gfc_to_single_character (len1, str1);
   sc2 = gfc_to_single_character (len2, str2);
 
   /* Deal with single character specially.  */
   if (sc1 != NULL_TREE && sc2 != NULL_TREE)
     {
-      sc1 = fold_convert (type, sc1);
-      sc2 = fold_convert (type, sc2);
-      tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
+      sc1 = fold_convert (integer_type_node, sc1);
+      sc2 = fold_convert (integer_type_node, sc2);
+      tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
     }
    else
      /* Build a call for the comparison.  */
@@ -1798,6 +1856,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
                                gfc_array_index_type);
            tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
                               tmp, tmp_se.expr);
+           tmp = fold_convert (gfc_charlen_type_node, tmp);
            expr->ts.cl->backend_decl = tmp;
 
            break;
@@ -2167,7 +2226,18 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
             {
              if (fsym && fsym->attr.value)
                {
-                 gfc_conv_expr (&parmse, e);
+                 if (fsym->ts.type == BT_CHARACTER
+                     && fsym->ts.is_c_interop
+                     && fsym->ns->proc_name != NULL
+                     && fsym->ns->proc_name->attr.is_bind_c)
+                   {
+                     parmse.expr = NULL;
+                     gfc_conv_scalar_char_value (fsym, &parmse, &e);
+                     if (parmse.expr == NULL)
+                       gfc_conv_expr (&parmse, e);
+                   }
+                 else
+                   gfc_conv_expr (&parmse, e);
                }
              else if (arg->name && arg->name[0] == '%')
                /* Argument list functions %VAL, %LOC and %REF are signalled
@@ -2233,47 +2303,38 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
            } 
        }
 
-      if (fsym)
+      /* The case with fsym->attr.optional is that of a user subroutine
+        with an interface indicating an optional argument.  When we call
+        an intrinsic subroutine, however, fsym is NULL, but we might still
+        have an optional argument, so we proceed to the substitution
+        just in case.  */
+      if (e && (fsym == NULL || fsym->attr.optional))
        {
-         if (e)
-           {
-             /* If an optional argument is itself an optional dummy
-                argument, check its presence and substitute a null
-                if absent.  */
-             if (e->expr_type == EXPR_VARIABLE
-                   && e->symtree->n.sym->attr.optional
-                   && fsym->attr.optional)
-               gfc_conv_missing_dummy (&parmse, e, fsym->ts);
-
-             /* If an INTENT(OUT) dummy of derived type has a default
-                initializer, it must be (re)initialized here.  */
-             if (fsym->attr.intent == INTENT_OUT
-                   && fsym->ts.type == BT_DERIVED
-                   && fsym->value)
-               {
-                 gcc_assert (!fsym->attr.allocatable);
-                 tmp = gfc_trans_assignment (e, fsym->value, false);
-                 gfc_add_expr_to_block (&se->pre, tmp);
-               }
+         /* If an optional argument is itself an optional dummy argument,
+            check its presence and substitute a null if absent.  */
+         if (e->expr_type == EXPR_VARIABLE
+             && e->symtree->n.sym->attr.optional)
+           gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts);
+       }
 
-             /* Obtain the character length of an assumed character
-                length procedure from the typespec.  */
-             if (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;
-               }
+      if (fsym && e)
+       {
+         /* Obtain the character length of an assumed character length
+            length procedure from the typespec.  */
+         if (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;
            }
-
-         if (need_interface_mapping)
-           gfc_add_interface_mapping (&mapping, fsym, &parmse);
        }
 
+      if (fsym && need_interface_mapping)
+       gfc_add_interface_mapping (&mapping, fsym, &parmse);
+
       gfc_add_block_to_block (&se->pre, &parmse.pre);
       gfc_add_block_to_block (&post, &parmse.post);
 
@@ -2532,7 +2593,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
                  tmp = gfc_conv_descriptor_data_get (info->descriptor);
                  tmp = fold_build2 (NE_EXPR, boolean_type_node,
                                     tmp, info->data);
-                 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
+                 gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
                }
              se->expr = info->descriptor;
              /* Bundle in the string length.  */
@@ -3353,6 +3414,19 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
       return;
     }
 
+  if (expr->expr_type == EXPR_FUNCTION
+       && expr->symtree->n.sym->attr.pointer
+       && !expr->symtree->n.sym->attr.dimension)
+    {
+      se->want_pointer = 1;
+      gfc_conv_expr (se, expr);
+      var = gfc_create_var (TREE_TYPE (se->expr), NULL);
+      gfc_add_modify_expr (&se->pre, var, se->expr);
+      se->expr = var;
+      return;
+    }
+
+
   gfc_conv_expr (se, expr);
 
   /* Create a temporary var to hold the value.  */
@@ -3523,25 +3597,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
        }
 
       /* Deallocate the lhs allocated components as long as it is not
-        the same as the rhs.  */
+        the same as the rhs.  This must be done following the assignment
+        to prevent deallocating data that could be used in the rhs
+        expression.  */
       if (!l_is_temp)
        {
-         tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
+         tmp = gfc_evaluate_now (lse->expr, &lse->pre);
+         tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
          if (r_is_var)
            tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
-         gfc_add_expr_to_block (&lse->pre, tmp);
+         gfc_add_expr_to_block (&lse->post, tmp);
        }
 
-      if (r_is_var)
-       {
-         gfc_add_block_to_block (&block, &lse->pre);
-         gfc_add_block_to_block (&block, &rse->pre);
-       }
-      else
-       {
-         gfc_add_block_to_block (&block, &rse->pre);
-         gfc_add_block_to_block (&block, &lse->pre);
-       }
+      gfc_add_block_to_block (&block, &rse->pre);
+      gfc_add_block_to_block (&block, &lse->pre);
 
       gfc_add_modify_expr (&block, lse->expr,
                           fold_convert (TREE_TYPE (lse->expr), rse->expr));