mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-22 21:51:36 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/29828 ([F2003] MIN and MAX with character variables)

Browse Source 
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.

From-SVN: r127252
This commit is contained in:
Francois-Xavier Coudert 2007-08-06 20:47:17 +00:00 committed by François-Xavier Coudert
parent d3ef67eaf3
commit 2263c77558
13 changed files with 278 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -1,3 +1,16 @@
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

13
gcc/fortran/check.c
View 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)
{
gfc_error ("'a1' argument of '%s' intrinsic at %L must be INTEGER "
"or REAL", gfc_current_intrinsic, &x->where);
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, "
"REAL or CHARACTER", gfc_current_intrinsic, &x->where);
return FAILURE;
}

34
gcc/fortran/simplify.c
View 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. */

8
gcc/fortran/trans-decl.c
View 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,

49
gcc/fortran/trans-intrinsic.c
View 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:

1
gcc/fortran/trans.h
View 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;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
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

12
gcc/testsuite/gfortran.dg/min_max_optional_4.f90 Normal file
View File

@ -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

73
gcc/testsuite/gfortran.dg/minmax_char_1.f90 Normal file
View File

@ -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

4
gcc/testsuite/gfortran.dg/minmax_char_2.f90 Normal file
View File

@ -0,0 +1,4 @@
! { dg-do compile }
! { dg-options "-std=f95" }
print *, min("foo", "bar") ! { dg-error "Fortran 2003.* CHARACTER argument" }
end

7
libgfortran/ChangeLog
View 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

1
libgfortran/gfortran.map
View 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;

65
libgfortran/intrinsics/string_intrinsics.c
View 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;
}