OSDN Git Service

PR fortran/29828
authorfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 6 Aug 2007 20:47:17 +0000 (20:47 +0000)
committerfxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 6 Aug 2007 20:47:17 +0000 (20:47 +0000)
* trans.h (gfor_fndecl_string_minmax): New prototype.
* trans-decl.c (gfor_fndecl_string_minmax): New variable.
(gfc_build_intrinsic_function_decls): Create gfor_fndecl_string_minmax.
* check.c (gfc_check_min_max): Allow for character arguments.
* trans-intrinsic.c (gfc_conv_intrinsic_minmax_char): New function.
(gfc_conv_intrinsic_function): Add special case for MIN and MAX
intrinsics with character arguments.
* simplify.c (simplify_min_max): Add simplification for character
arguments.

* intrinsics/string_intrinsics.c (string_minmax): New function
and prototype.
* gfortran.map (GFORTRAN_1.0): Add _gfortran_string_minmax

* gfortran.dg/minmax_char_1.f90: New test.
* gfortran.dg/minmax_char_2.f90: New test.
* gfortran.dg/min_max_optional_4.f90: New test.

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

13 files changed:
gcc/fortran/ChangeLog
gcc/fortran/check.c
gcc/fortran/simplify.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-intrinsic.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/min_max_optional_4.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/minmax_char_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/minmax_char_2.f90 [new file with mode: 0644]
libgfortran/ChangeLog
libgfortran/gfortran.map
libgfortran/intrinsics/string_intrinsics.c

index cc3b89b..2bd347e 100644 (file)
@@ -1,5 +1,18 @@
 2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+       PR fortran/29828
+       * trans.h (gfor_fndecl_string_minmax): New prototype.
+       * trans-decl.c (gfor_fndecl_string_minmax): New variable.
+       (gfc_build_intrinsic_function_decls): Create gfor_fndecl_string_minmax.
+       * check.c (gfc_check_min_max): Allow for character arguments.
+       * trans-intrinsic.c (gfc_conv_intrinsic_minmax_char): New function.
+       (gfc_conv_intrinsic_function): Add special case for MIN and MAX
+       intrinsics with character arguments.
+       * simplify.c (simplify_min_max): Add simplification for character
+       arguments.
+
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
        PR fortran/31612
        * invoke.texi: Adjust documentation for option -fsyntax-only.
 
index e792773..ba72aaa 100644 (file)
@@ -1512,10 +1512,17 @@ gfc_check_min_max (gfc_actual_arglist *arg)
 
   x = arg->expr;
 
-  if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
+  if (x->ts.type == BT_CHARACTER)
+    {
+      if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+                         "with CHARACTER argument at %L",
+                         gfc_current_intrinsic, &x->where) == FAILURE)
+       return FAILURE;
+    }
+  else if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
     {
-      gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
-                "or REAL", gfc_current_intrinsic, &x->where);
+      gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER, "
+                "REAL or CHARACTER", gfc_current_intrinsic, &x->where);
       return FAILURE;
     }
 
index 7919dae..88a146b 100644 (file)
@@ -2361,7 +2361,6 @@ simplify_min_max (gfc_expr *expr, int sign)
          if (mpz_cmp (arg->expr->value.integer,
                       extremum->expr->value.integer) * sign > 0)
            mpz_set (extremum->expr->value.integer, arg->expr->value.integer);
-
          break;
 
        case BT_REAL:
@@ -2369,11 +2368,40 @@ simplify_min_max (gfc_expr *expr, int sign)
              * sign > 0)
            mpfr_set (extremum->expr->value.real, arg->expr->value.real,
                      GFC_RND_MODE);
+         break;
+
+       case BT_CHARACTER:
+#define LENGTH(x) ((x)->expr->value.character.length)
+#define STRING(x) ((x)->expr->value.character.string)
+         if (LENGTH(extremum) < LENGTH(arg))
+           {
+             char * tmp = STRING(extremum);
+
+             STRING(extremum) = gfc_getmem (LENGTH(arg) + 1);
+             memcpy (STRING(extremum), tmp, LENGTH(extremum));
+             memset (&STRING(extremum)[LENGTH(extremum)], ' ',
+                     LENGTH(arg) - LENGTH(extremum));
+             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
+             LENGTH(extremum) = LENGTH(arg);
+             gfc_free (tmp);
+           }
 
+         if (gfc_compare_string (arg->expr, extremum->expr) * sign > 0)
+           {
+             gfc_free (STRING(extremum));
+             STRING(extremum) = gfc_getmem (LENGTH(extremum) + 1);
+             memcpy (STRING(extremum), STRING(arg), LENGTH(arg));
+             memset (&STRING(extremum)[LENGTH(arg)], ' ',
+                     LENGTH(extremum) - LENGTH(arg));
+             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
+           }
+#undef LENGTH
+#undef STRING
          break;
+             
 
        default:
-         gfc_internal_error ("gfc_simplify_max(): Bad type in arglist");
+         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
        }
 
       /* Delete the extra constant argument.  */
index b74b466..c9a195f 100644 (file)
@@ -125,6 +125,7 @@ tree gfor_fndecl_string_index;
 tree gfor_fndecl_string_scan;
 tree gfor_fndecl_string_verify;
 tree gfor_fndecl_string_trim;
+tree gfor_fndecl_string_minmax;
 tree gfor_fndecl_adjustl;
 tree gfor_fndecl_adjustr;
 
@@ -2047,6 +2048,13 @@ gfc_build_intrinsic_function_decls (void)
                                      gfc_charlen_type_node,
                                      pchar_type_node);
 
+  gfor_fndecl_string_minmax = 
+    gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
+                                     void_type_node, -4,
+                                     build_pointer_type (gfc_charlen_type_node),
+                                     ppvoid_type_node, integer_type_node,
+                                     integer_type_node);
+
   gfor_fndecl_ttynam =
     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
                                      void_type_node,
index dcdc3c7..ce6b585 100644 (file)
@@ -1561,6 +1561,45 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 }
 
 
+/* Generate library calls for MIN and MAX intrinsics for character
+   variables.  */
+static void
+gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
+{
+  tree *args;
+  tree var, len, fndecl, tmp, cond;
+  unsigned int nargs;
+
+  nargs = gfc_intrinsic_argument_list_length (expr);
+  args = alloca (sizeof (tree) * (nargs + 4));
+  gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
+
+  /* Create the result variables.  */
+  len = gfc_create_var (gfc_charlen_type_node, "len");
+  args[0] = build_fold_addr_expr (len);
+  var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr");
+  args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
+  args[2] = build_int_cst (NULL_TREE, op);
+  args[3] = build_int_cst (NULL_TREE, nargs / 2);
+
+  /* Make the function call.  */
+  fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl);
+  tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)),
+                         fndecl, nargs + 4, args);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = build2 (GT_EXPR, boolean_type_node, len,
+                build_int_cst (TREE_TYPE (len), 0));
+  tmp = gfc_call_free (var);
+  tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+  gfc_add_expr_to_block (&se->post, tmp);
+
+  se->expr = var;
+  se->string_length = len;
+}
+
+
 /* Create a symbol node for this intrinsic.  The symbol from the frontend
    has the generic name.  */
 
@@ -4058,7 +4097,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_MAX:
-      gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
+      if (expr->ts.type == BT_CHARACTER)
+       gfc_conv_intrinsic_minmax_char (se, expr, 1);
+      else
+       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
       break;
 
     case GFC_ISYM_MAXLOC:
@@ -4074,7 +4116,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_MIN:
-      gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
+      if (expr->ts.type == BT_CHARACTER)
+       gfc_conv_intrinsic_minmax_char (se, expr, -1);
+      else
+       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
       break;
 
     case GFC_ISYM_MINLOC:
index 5ad3ca6..8226187 100644 (file)
@@ -540,6 +540,7 @@ extern GTY(()) tree gfor_fndecl_string_index;
 extern GTY(()) tree gfor_fndecl_string_scan;
 extern GTY(()) tree gfor_fndecl_string_verify;
 extern GTY(()) tree gfor_fndecl_string_trim;
+extern GTY(()) tree gfor_fndecl_string_minmax;
 extern GTY(()) tree gfor_fndecl_adjustl;
 extern GTY(()) tree gfor_fndecl_adjustr;
 
index b50e7d2..5d5654e 100644 (file)
@@ -1,5 +1,12 @@
 2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+       PR fortran/29828
+       * gfortran.dg/minmax_char_1.f90: New test.
+       * gfortran.dg/minmax_char_2.f90: New test.
+       * gfortran.dg/min_max_optional_4.f90: New test.
+
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
        * gfortran.dg/nan_1.f90: Rename module into aux2 to avoid cygwin
        hanging on the testcase.
 
diff --git a/gcc/testsuite/gfortran.dg/min_max_optional_4.f90 b/gcc/testsuite/gfortran.dg/min_max_optional_4.f90
new file mode 100644 (file)
index 0000000..b749db0
--- /dev/null
@@ -0,0 +1,12 @@
+! { dg-do run }
+! { dg-shouldfail "" }
+program test
+  call foo("foo")
+contains
+  subroutine foo(a, b, c, d)
+    character(len=*), optional :: a, b, c, d
+    integer :: i
+    i = len_trim(min(a,b,c,d)) ! { dg-output "Second argument of 'MIN' intrinsic should be present" }
+    print *, i
+  end subroutine foo
+end
diff --git a/gcc/testsuite/gfortran.dg/minmax_char_1.f90 b/gcc/testsuite/gfortran.dg/minmax_char_1.f90
new file mode 100644 (file)
index 0000000..9e73e98
--- /dev/null
@@ -0,0 +1,73 @@
+! Tests for MIN and MAX intrinsics with character arguments
+!
+! { dg-do run }
+program test
+  character(len=3), parameter :: sp = "gee"
+  character(len=6), parameter :: tp = "crunch", wp = "flunch"
+  character(len=2), parameter :: up = "az", vp = "da"
+
+  character(len=3) :: s
+  character(len=6) :: t, w
+  character(len=2) :: u, v
+  s = "gee"
+  t = "crunch"
+  u = "az"
+  v = "da"
+  w = "flunch"
+
+  if (.not. equal(min("foo", "bar"), "bar")) call abort
+  if (.not. equal(max("foo", "bar"), "foo")) call abort
+  if (.not. equal(min("bar", "foo"), "bar")) call abort
+  if (.not. equal(max("bar", "foo"), "foo")) call abort
+
+  if (.not. equal(min("bar", "foo", sp), "bar")) call abort
+  if (.not. equal(max("bar", "foo", sp), "gee")) call abort
+  if (.not. equal(min("bar", sp, "foo"), "bar")) call abort
+  if (.not. equal(max("bar", sp, "foo"), "gee")) call abort
+  if (.not. equal(min(sp, "bar", "foo"), "bar")) call abort
+  if (.not. equal(max(sp, "bar", "foo"), "gee")) call abort
+
+  if (.not. equal(min("foo", "bar", s), "bar")) call abort
+  if (.not. equal(max("foo", "bar", s), "gee")) call abort
+  if (.not. equal(min("foo", s, "bar"), "bar")) call abort
+  if (.not. equal(max("foo", s, "bar"), "gee")) call abort
+  if (.not. equal(min(s, "foo", "bar"), "bar")) call abort
+  if (.not. equal(max(s, "foo", "bar"), "gee")) call abort
+
+  if (.not. equal(min("", ""), "")) call abort
+  if (.not. equal(max("", ""), "")) call abort
+  if (.not. equal(min("", " "), " ")) call abort
+  if (.not. equal(max("", " "), " ")) call abort
+
+  if (.not. equal(min(u,v,w), "az    ")) call abort
+  if (.not. equal(max(u,v,w), "flunch")) call abort
+  if (.not. equal(min(u,vp,w), "az    ")) call abort
+  if (.not. equal(max(u,vp,w), "flunch")) call abort
+  if (.not. equal(min(u,v,wp), "az    ")) call abort
+  if (.not. equal(max(u,v,wp), "flunch")) call abort
+  if (.not. equal(min(up,v,w), "az    ")) call abort
+  if (.not. equal(max(up,v,w), "flunch")) call abort
+
+  call foo("gee   ","az    ",s,t,u,v)
+  call foo("gee   ","az    ",s,t,u,v)
+  call foo("gee   ","az    ",s,t,u)
+  call foo("gee   ","crunch",s,t)
+
+contains
+
+  subroutine foo(res_max, res_min, a, b, c, d)
+    character(len=*) :: res_min, res_max
+    character(len=*), optional :: a, b, c, d
+
+    if (.not. equal(min(a,b,c,d), res_min)) call abort
+    if (.not. equal(max(a,b,c,d), res_max)) call abort
+  end subroutine foo
+
+  pure function equal(a,b)
+    character(len=*), intent(in) :: a, b
+    logical :: equal
+
+    equal = (len(a) == len(b)) .and. (a == b)
+  end function equal
+
+end program test
diff --git a/gcc/testsuite/gfortran.dg/minmax_char_2.f90 b/gcc/testsuite/gfortran.dg/minmax_char_2.f90
new file mode 100644 (file)
index 0000000..b5f74ea
--- /dev/null
@@ -0,0 +1,4 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+  print *, min("foo", "bar") ! { dg-error "Fortran 2003.* CHARACTER argument" }
+  end
index bb999ec..e205466 100644 (file)
@@ -1,3 +1,10 @@
+2007-08-06  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+       PR fortran/29828
+       * intrinsics/string_intrinsics.c (string_minmax): New function
+       and prototype.
+       * gfortran.map (GFORTRAN_1.0): Add _gfortran_string_minmax
+
 2007-08-05  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
        PR fortran/31202
index c16dd1e..ed881eb 100644 (file)
@@ -941,6 +941,7 @@ GFORTRAN_1.0 {
     _gfortran_st_rewind;
     _gfortran_string_index;
     _gfortran_string_len_trim;
+    _gfortran_string_minmax;
     _gfortran_string_scan;
     _gfortran_string_trim;
     _gfortran_string_verify;
index 7c22c16..3e0940f 100644 (file)
@@ -1,5 +1,5 @@
 /* String intrinsics helper functions.
-   Copyright 2002, 2005 Free Software Foundation, Inc.
+   Copyright 2002, 2005, 2007 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -38,6 +38,7 @@ Boston, MA 02110-1301, USA.  */
 
 #include <stdlib.h>
 #include <string.h>
+#include <stdarg.h>
 
 #include "libgfortran.h"
 
@@ -73,6 +74,9 @@ export_proto(string_verify);
 extern void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *);
 export_proto(string_trim);
 
+extern void string_minmax (GFC_INTEGER_4 *, void **, int, int, ...);
+export_proto(string_minmax);
+
 /* Strings of unequal length are extended with pad characters.  */
 
 GFC_INTEGER_4
@@ -351,3 +355,62 @@ string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen,
 
   return 0;
 }
+
+
+/* MIN and MAX intrinsics for strings.  The front-end makes sure that
+   nargs is at least 2.  */
+
+void
+string_minmax (GFC_INTEGER_4 *rlen, void **dest, int op, int nargs, ...)
+{
+  va_list ap;
+  int i;
+  char * next, * res;
+  GFC_INTEGER_4 nextlen, reslen;
+
+  va_start (ap, nargs);
+  reslen = va_arg (ap, GFC_INTEGER_4);
+  res = va_arg (ap, char *);
+  *rlen = reslen;
+
+  if (res == NULL)
+    runtime_error ("First argument of '%s' intrinsic should be present",
+                  op > 0 ? "MAX" : "MIN");
+
+  for (i = 1; i < nargs; i++)
+    {
+      nextlen = va_arg (ap, GFC_INTEGER_4);
+      next = va_arg (ap, char *);
+
+
+      if (next == NULL)
+       {
+         if (i == 1)
+           runtime_error ("Second argument of '%s' intrinsic should be "
+                          "present", op > 0 ? "MAX" : "MIN");
+         else
+           continue;
+       }
+
+      if (nextlen > *rlen)
+       *rlen = nextlen;
+
+      if (op * compare_string (reslen, res, nextlen, next) < 0)
+       {
+         reslen = nextlen;
+         res = next;
+       }
+    }
+  va_end (ap);
+
+  if (*rlen > 0)
+    {
+      char * tmp = internal_malloc_size (*rlen);
+      memcpy (tmp, res, reslen);
+      memset (&tmp[reslen], ' ', *rlen - reslen);
+      *dest = tmp;
+    }
+  else
+    *dest = NULL;
+}
+