+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
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;
}
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:
* 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. */
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;
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,
}
+/* 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. */
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:
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:
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;
+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
--- /dev/null
+! { 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
--- /dev/null
+! 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
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f95" }
+ print *, min("foo", "bar") ! { dg-error "Fortran 2003.* CHARACTER argument" }
+ end
+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
_gfortran_st_rewind;
_gfortran_string_index;
_gfortran_string_len_trim;
+ _gfortran_string_minmax;
_gfortran_string_scan;
_gfortran_string_trim;
_gfortran_string_verify;
/* 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).
#include <stdlib.h>
#include <string.h>
+#include <stdarg.h>
#include "libgfortran.h"
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
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;
+}
+
projects / gcc.git / commitdiff