From 5fcc6ec223fed0d7dcd200bd3ee08ef6ae1c4965 Mon Sep 17 00:00:00 2001 From: fxcoudert Date: Mon, 6 Aug 2007 20:47:17 +0000 Subject: [PATCH] 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. * 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 --- gcc/fortran/ChangeLog | 13 +++++ gcc/fortran/check.c | 13 ++++- gcc/fortran/simplify.c | 32 ++++++++++- gcc/fortran/trans-decl.c | 8 +++ gcc/fortran/trans-intrinsic.c | 49 +++++++++++++++- gcc/fortran/trans.h | 1 + gcc/testsuite/ChangeLog | 7 +++ gcc/testsuite/gfortran.dg/min_max_optional_4.f90 | 12 ++++ gcc/testsuite/gfortran.dg/minmax_char_1.f90 | 73 ++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/minmax_char_2.f90 | 4 ++ libgfortran/ChangeLog | 7 +++ libgfortran/gfortran.map | 1 + libgfortran/intrinsics/string_intrinsics.c | 65 ++++++++++++++++++++- 13 files changed, 277 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/min_max_optional_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/minmax_char_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/minmax_char_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cc3b89b0beb..2bd347e6338 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,18 @@ 2007-08-06 Francois-Xavier Coudert + 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 + PR fortran/31612 * invoke.texi: Adjust documentation for option -fsyntax-only. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index e792773f928..ba72aaa862e 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7919dae02c6..88a146bd18f 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index b74b4664138..c9a195fe784 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index dcdc3c7be41..ce6b58528c0 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 5ad3ca61dc4..8226187f78c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index b50e7d2b1ed..5d5654ee25f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,12 @@ 2007-08-06 Francois-Xavier Coudert + 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 + * 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 index 00000000000..b749db0f8e3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/min_max_optional_4.f90 @@ -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 index 00000000000..9e73e9850be --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmax_char_1.f90 @@ -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 index 00000000000..b5f74eac93b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmax_char_2.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + print *, min("foo", "bar") ! { dg-error "Fortran 2003.* CHARACTER argument" } + end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index bb999ece2f0..e205466bb46 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2007-08-06 Francois-Xavier Coudert + + 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 PR fortran/31202 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index c16dd1eee33..ed881ebfbcc 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -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; diff --git a/libgfortran/intrinsics/string_intrinsics.c b/libgfortran/intrinsics/string_intrinsics.c index 7c22c16abfe..3e0940f59ee 100644 --- a/libgfortran/intrinsics/string_intrinsics.c +++ b/libgfortran/intrinsics/string_intrinsics.c @@ -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 This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -38,6 +38,7 @@ Boston, MA 02110-1301, USA. */ #include #include +#include #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; +} + -- 2.11.0