This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[patch, fortran, 4.5] F2003: simplifiers for array transformations
- From: Daniel Franke <franke dot daniel at gmail dot com>
- To: "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>, gcc-patches at gcc dot gnu dot org
- Date: Sat, 3 Jan 2009 17:54:37 +0100
- Subject: [patch, fortran, 4.5] F2003: simplifiers for array transformations
Hi all.
This somewhat lengthy patch adds simplification support for transformational
functions that reduce arrays. This allows to use the intrinsics SUM, PRODUCT,
ANY, ALL, MINVAL and MAXVAL in initialization expressions as specified by
Fortran 2003.
With this, the functions ALL, ANY, PRODUCT and SUM are newly supported. The
existing simplifiers of MAXVAL and MINVAL have been extended to accept the
optional DIM argument. While at it, MAX and MIN have been reworked to use the
same transformational operators as MAXVAL and MINVAL. The latter now also
accept character arguments.
Please note, character arguments in MAXVAL/MINVAL are now supported for
initialization expressions, but are not properly translated yet if
simplification doesn't apply (see change in trans-intrinsic.c).
There are no specific testcases for ALL and ANY as there are some implicit
checks in the tests and the code paths are virtually the same.
Bootstrapped and regression tested on i686-pc-linux-gnu. Tested html-target
for doc changes. Ok for 4.5?
Regards
Daniel
P.S. As time permits, I plan to work on TRANSPOSE, MATMUL and DOT_PRODUCT
next.
2009-01-03 Daniel Franke <franke.daniel@gmail.com>
PR fortran/29962
* gfortran.h (gfc_wide_strcpy): New prototype.
* scanner.c (wide_strcpy): Renamed to ...
(gfc_wide_strcpy): ... this. Fixed all callers.
* simplify.c (init_result_expr): New.
(trans_result): New.
(simplify_trans_scalar): New.
(simplify_trans_array): New.
(trans_op_and): New.
(trans_op_or): New.
(trans_op_sum): New.
(trans_op_product): New.
(trans_op_max): New.
(trans_op_min): New.
(min_max_choose): Removed.
(gfc_simplify_all): New.
(gfc_simplify_any): New.
(gfc_simplify_product): New.
(gfc_simplify_sum): New.
(gfc_simplify_max): Reimplemented to use transformational operator.
(gfc_simplify_min): Likewise.
(gfc_simplify_maxval): Likewise.
(gfc_simplify_minval): Likewise.
* intrinsic.h (gfc_simplify_all): New prototype.
(gfc_simplify_any): New prototype.
(gfc_simplify_product): New prototype.
(gfc_simplify_sum): New prototype.
* intrinsic.c (add_functions): Added new simplification callbacks.
* check.c (dim_rank_rank): Added NULL-pointer check for DIM.
(gfc_check_all_any): Also check rank of DIM.
(gfc_check_min_max): Replaced explicit check by equivalent function call.
(gfc_check_minval_maxval): Allow character arguments if std=f2003.
(gfc_check_lbound): Removed redundant check for NULL on DIM.
(gfc_check_minloc_maxloc): Likewise.
(check_reduction): Likewise.
(gfc_check_size): Likewise.
(gfc_check_ubound): Likewise.
* trans-intrinsic.c (gfc_conv_intrinsic_minmaxval): Replaced assert with
fatal error if called with character arguments.
* expr.c (check_inquiry): Fixed check for applicable standard.
(check_transformational): List transformational intrinsics with
simplifications.
* intrinsic.texi (COUNT): Clarified documentation.
(MAX): List CHARACTER arguments allowed by F2003, added example.
(MIN): Likewise.
(MAXVAL): Clarified that CHARACTER arguments are only allowed by F2003.
(MINVAL): Likewise.
gcc/testsuite:
2009-01-03 Daniel Franke <franke.daniel@gmail.com>
PR fortran/29962
* gfortran.dg/minmaxval_2.f90 New.
* gfortran.dg/product_init_expr.f90: New.
* gfortran.dg/sum_init_expr.f90: New.
Index: fortran/gfortran.h
===================================================================
--- fortran/gfortran.h (revision 143030)
+++ fortran/gfortran.h (working copy)
@@ -2115,6 +2115,7 @@ gfc_char_t gfc_wide_toupper (gfc_char_t)
size_t gfc_wide_strlen (const gfc_char_t *);
int gfc_wide_strncasecmp (const gfc_char_t *, const char *, size_t);
gfc_char_t *gfc_wide_memset (gfc_char_t *, gfc_char_t, size_t);
+gfc_char_t *gfc_wide_strcpy (gfc_char_t *, const gfc_char_t *);
char *gfc_widechar_to_char (const gfc_char_t *, int);
gfc_char_t *gfc_char_to_widechar (const char *);
Index: fortran/scanner.c
===================================================================
--- fortran/scanner.c (revision 143030)
+++ fortran/scanner.c (working copy)
@@ -161,8 +161,8 @@ gfc_wide_memset (gfc_char_t *b, gfc_char
return b;
}
-static gfc_char_t *
-wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
+gfc_char_t *
+gfc_wide_strcpy (gfc_char_t *dest, const gfc_char_t *src)
{
gfc_char_t *d;
@@ -1857,7 +1857,7 @@ load_file (const char *realfilename, con
int n = line[1] == (unsigned char) '\xBB' ? 3 : 2;
gfc_char_t *new_char = gfc_get_wide_string (line_len);
- wide_strcpy (new_char, &line[n]);
+ gfc_wide_strcpy (new_char, &line[n]);
gfc_free (line);
line = new_char;
len -= n;
@@ -1902,7 +1902,7 @@ load_file (const char *realfilename, con
= linemap_line_start (line_table, current_file->line++, 120);
b->file = current_file;
b->truncated = trunc;
- wide_strcpy (b->line, line);
+ gfc_wide_strcpy (b->line, line);
if (line_head == NULL)
line_head = b;
Index: fortran/simplify.c
===================================================================
--- fortran/simplify.c (revision 143030)
+++ fortran/simplify.c (working copy)
@@ -211,6 +211,334 @@ convert_mpz_to_signed (mpz_t x, int bits
}
+/* Test that the expression is an constant array. */
+
+static bool
+is_constant_array_expr (gfc_expr *e)
+{
+ gfc_constructor *c;
+
+ if (e == NULL)
+ return true;
+
+ if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
+ return false;
+
+ for (c = e->value.constructor; c; c = c->next)
+ if (c->expr->expr_type != EXPR_CONSTANT)
+ return false;
+
+ return true;
+}
+
+
+/* Initialize a transformational result expression with a given value. */
+
+static void
+init_result_expr (gfc_expr *e, int init, gfc_expr *array)
+{
+ if (e && e->expr_type == EXPR_ARRAY)
+ {
+ gfc_constructor *ctor = e->value.constructor;
+ while (ctor)
+ {
+ init_result_expr (ctor->expr, init, array);
+ ctor = ctor->next;
+ }
+ }
+ else if (e && e->expr_type == EXPR_CONSTANT)
+ {
+ int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ int length;
+ gfc_char_t *string;
+
+ switch (e->ts.type)
+ {
+ case BT_LOGICAL:
+ e->value.logical = (init ? 1 : 0);
+ break;
+
+ case BT_INTEGER:
+ if (init == INT_MIN)
+ {
+ mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
+ }
+ else if (init == INT_MAX)
+ mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
+ else
+ mpz_set_si (e->value.integer, init);
+ break;
+
+ case BT_REAL:
+ if (init == INT_MIN)
+ {
+ mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
+ }
+ else if (init == INT_MAX)
+ mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ else
+ mpfr_set_si (e->value.real, init, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpfr_set_si (e->value.complex.r, init, GFC_RND_MODE);
+ mpfr_set_si (e->value.complex.i, 0, GFC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+ if (init == INT_MIN)
+ {
+ gfc_expr *len = gfc_simplify_len (array, NULL);
+ gfc_extract_int (len, &length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_memset (string, 0, length);
+ }
+ else if (init == INT_MAX)
+ {
+ gfc_expr *len = gfc_simplify_len (array, NULL);
+ gfc_extract_int (len, &length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_memset (string, 255, length);
+ }
+ else
+ {
+ length = 0;
+ string = gfc_get_wide_string (1);
+ }
+
+ string[length] = '\0';
+ e->value.character.length = length;
+ e->value.character.string = string;
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+ }
+ else
+ gcc_unreachable();
+}
+
+
+/* Build a result expression for transformational intrinsics,
+ depending on DIM. */
+
+static gfc_expr*
+trans_result (gfc_expr *array, gfc_expr *dim)
+{
+ gfc_expr *result;
+ int i, j, nelem;
+ int dropped_rank;
+ gfc_constructor *head, *tail;
+
+ if (!dim || array->rank == 1)
+ return gfc_constant_result (array->ts.type, array->ts.kind, &array->where);
+
+ result = gfc_get_expr();
+ result->expr_type = EXPR_ARRAY;
+ result->where = array->where;
+ result->ts = array->ts;
+ result->rank = array->rank - 1;
+ result->shape = gfc_get_shape (result->rank);
+
+ gfc_extract_int (dim, &dropped_rank);
+
+ nelem = 1;
+ for (i = 0, j = 0; i < array->rank; ++i)
+ {
+ if (i + 1 == dropped_rank)
+ continue;
+
+ mpz_init_set (result->shape[j], array->shape[i]);
+ nelem *= mpz_get_ui (result->shape[j]);
+ j++;
+ }
+
+ head = tail = NULL;
+ for (i = 0; i < nelem; ++i)
+ {
+ if (head == NULL)
+ head = tail = gfc_get_constructor();
+ else
+ {
+ tail->next = gfc_get_constructor();
+ tail = tail->next;
+ }
+ tail->where = array->where;
+ tail->expr = gfc_constant_result (array->ts.type, array->ts.kind, &array->where);
+ }
+
+ result->value.constructor = head;
+ return result;
+}
+
+
+/* Generic transformational operations to be used with the functions below. */
+
+typedef void (*trans_op)(gfc_expr*, gfc_expr*, gfc_expr*);
+
+
+static gfc_expr *
+simplify_trans_scalar (gfc_expr *array, gfc_expr *mask, trans_op op, int init)
+{
+ gfc_expr *a, *m, *result;
+ gfc_constructor *array_ctor, *mask_ctor;
+
+ array_ctor = array->value.constructor;
+ mask_ctor = NULL;
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = mask->value.constructor;
+
+ result = trans_result (array, NULL);
+ init_result_expr (result, init, array);
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ while (array_ctor)
+ {
+ a = array_ctor->expr;
+ array_ctor = array_ctor->next;
+
+ /* A constant MASK equals .TRUE. here and can be ignored. */
+ if (mask_ctor)
+ {
+ m = mask_ctor->expr;
+ mask_ctor = mask_ctor->next;
+ if (!m->value.logical)
+ continue;
+ }
+
+ op (result, result, a);
+ }
+
+ return result;
+}
+
+static gfc_expr *
+simplify_trans_array (gfc_expr *array, gfc_expr *dim,
+ gfc_expr *mask, trans_op op, int init ATTRIBUTE_UNUSED)
+{
+ mpz_t size;
+ int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
+ gfc_expr *result, **arrayvec, **resultvec, **base, **src, **dest;
+ gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
+
+ int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
+ sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
+ tmpstride[GFC_MAX_DIMENSIONS];
+
+ result = trans_result (array, dim);
+ init_result_expr (result, init, array);
+
+ /* Shortcut for constant .FALSE. MASK. */
+ if (mask
+ && mask->expr_type == EXPR_CONSTANT
+ && !mask->value.logical)
+ return result;
+
+ /* Build an indexed table for array element expressions to minimize
+ linked-list traversal. Masked elements are set to NULL. */
+ gfc_array_size (array, &size);
+ arraysize = mpz_get_ui (size);
+
+ arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
+
+ array_ctor = array->value.constructor;
+ mask_ctor = NULL;
+ if (mask && mask->expr_type == EXPR_ARRAY)
+ mask_ctor = mask->value.constructor;
+
+ for (i = 0; i < arraysize; ++i)
+ {
+ arrayvec[i] = array_ctor->expr;
+ array_ctor = array_ctor->next;
+
+ if (mask_ctor)
+ {
+ if (!mask_ctor->expr->value.logical)
+ arrayvec[i] = NULL;
+
+ mask_ctor = mask_ctor->next;
+ }
+ }
+
+ /* Same for the result expression. */
+ gfc_array_size (result, &size);
+ resultsize = mpz_get_ui (size);
+ mpz_clear (size);
+
+ resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
+ result_ctor = result->value.constructor;
+ for (i = 0; i < resultsize; ++i)
+ {
+ resultvec[i] = result_ctor->expr;
+ result_ctor = result_ctor->next;
+ }
+
+ gfc_extract_int (dim, &dim_index);
+ dim_index -= 1; /* zero-base index */
+ dim_extent = 0;
+ dim_stride = 0;
+
+ for (i = 0, n = 0; i < array->rank; ++i)
+ {
+ count[i] = 0;
+ tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
+ if (i == dim_index)
+ {
+ dim_extent = mpz_get_si (array->shape[i]);
+ dim_stride = tmpstride[i];
+ continue;
+ }
+
+ extent[n] = mpz_get_si (array->shape[i]);
+ sstride[n] = tmpstride[i];
+ dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
+ n += 1;
+ }
+
+ done = false;
+ base = arrayvec;
+ dest = resultvec;
+ while (!done)
+ {
+ for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
+ op (*dest, *dest, *src);
+
+ count[0]++;
+ base += sstride[0];
+ dest += dstride[0];
+
+ n = 0;
+ while (!done && count[n] == extent[n])
+ {
+ count[n] = 0;
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+
+ n++;
+ if (n < result->rank)
+ {
+ count [n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ else
+ done = true;
+ }
+ }
+
+ gfc_free (arrayvec);
+ gfc_free (resultvec);
+ return result;
+}
+
+
/********************** Simplification functions *****************************/
gfc_expr *
@@ -481,6 +809,33 @@ gfc_simplify_aint (gfc_expr *e, gfc_expr
}
+static void
+trans_op_and (gfc_expr *result, gfc_expr *op1, gfc_expr *op2)
+{
+ switch (result->ts.type)
+ {
+ case BT_LOGICAL:
+ result->value.logical = op1->value.logical && op2->value.logical;
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+}
+
+
+gfc_expr *
+gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
+{
+ if (!is_constant_array_expr (mask))
+ return NULL;
+
+ return !dim || mask->rank == 1 ?
+ simplify_trans_scalar (mask, NULL, trans_op_and, true) :
+ simplify_trans_array (mask, dim, NULL, trans_op_and, true);
+}
+
+
gfc_expr *
gfc_simplify_dint (gfc_expr *e)
{
@@ -546,6 +901,32 @@ gfc_simplify_and (gfc_expr *x, gfc_expr
}
+static void
+trans_op_or (gfc_expr *result, gfc_expr *op1, gfc_expr *op2)
+{
+ switch (result->ts.type)
+ {
+ case BT_LOGICAL:
+ result->value.logical = op1->value.logical || op2->value.logical;
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+}
+
+
+gfc_expr *
+gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
+{
+ if (!is_constant_array_expr (mask))
+ return NULL;
+
+ return !dim || mask->rank == 1 ?
+ simplify_trans_scalar (mask, NULL, trans_op_or, false) :
+ simplify_trans_array (mask, dim, NULL, trans_op_or, false);
+}
+
gfc_expr *
gfc_simplify_dnint (gfc_expr *e)
{
@@ -2619,201 +3000,167 @@ gfc_simplify_logical (gfc_expr *e, gfc_e
}
-/* Selects bewteen current value and extremum for simplify_min_max
- and simplify_minval_maxval. */
static void
-min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign)
+trans_op_max (gfc_expr *result, gfc_expr *op1, gfc_expr *op2)
{
- switch (arg->ts.type)
+ gfc_expr *op;
+ size_t length;
+ gfc_char_t *string;
+
+ switch (result->ts.type)
{
case BT_INTEGER:
- if (mpz_cmp (arg->value.integer,
- extremum->value.integer) * sign > 0)
- mpz_set (extremum->value.integer, arg->value.integer);
- break;
+ mpz_set (result->value.integer,
+ mpz_cmp (op1->value.integer, op2->value.integer) > 0
+ ? op1->value.integer
+ : op2->value.integer);
+ break;
case BT_REAL:
- /* We need to use mpfr_min and mpfr_max to treat NaN properly. */
- if (sign > 0)
- mpfr_max (extremum->value.real, extremum->value.real,
- arg->value.real, GFC_RND_MODE);
- else
- mpfr_min (extremum->value.real, extremum->value.real,
- arg->value.real, GFC_RND_MODE);
- break;
+ mpfr_max (result->value.real,
+ op1->value.real, op2->value.real, GFC_RND_MODE);
+ break;
case BT_CHARACTER:
-#define LENGTH(x) ((x)->value.character.length)
-#define STRING(x) ((x)->value.character.string)
- if (LENGTH(extremum) < LENGTH(arg))
- {
- gfc_char_t *tmp = STRING(extremum);
-
- STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
- memcpy (STRING(extremum), tmp,
- LENGTH(extremum) * sizeof (gfc_char_t));
- gfc_wide_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, extremum) * sign > 0)
- {
- gfc_free (STRING(extremum));
- STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
- memcpy (STRING(extremum), STRING(arg),
- LENGTH(arg) * sizeof (gfc_char_t));
- gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
- LENGTH(extremum) - LENGTH(arg));
- STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
- }
-#undef LENGTH
-#undef STRING
+ /* When comparing CHARACTER strings, the result needs to be
+ padded with spaces to match the size of the larger of the
+ two operands. */
+ op = (gfc_compare_string (op1, op2) > 0) ? op1 : op2;
+ length = MAX(op1->value.character.length,
+ op2->value.character.length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_strcpy (string, op->value.character.string);
+ gfc_wide_memset (&string[op->value.character.length], ' ',
+ length - op->value.character.length);
+ string[length] = '\0'; /* Debugger prefers terminated strings. */
+
+ gfc_free (result->value.character.string);
+ result->value.character.length = length;
+ result->value.character.string = string;
break;
-
+
default:
- gfc_internal_error ("simplify_min_max(): Bad type in arglist");
+ gcc_unreachable();
}
}
-/* This function is special since MAX() can take any number of
- arguments. The simplified expression is a rewritten version of the
- argument list containing at most one constant element. Other
- constant elements are deleted. Because the argument list has
- already been checked, this function always succeeds. sign is 1 for
- MAX(), -1 for MIN(). */
-
-static gfc_expr *
-simplify_min_max (gfc_expr *expr, int sign)
+gfc_expr *
+gfc_simplify_max (gfc_expr *e)
{
- gfc_actual_arglist *arg, *last, *extremum;
- gfc_intrinsic_sym * specific;
-
- last = NULL;
- extremum = NULL;
- specific = expr->value.function.isym;
-
- arg = expr->value.function.actual;
+ gfc_expr *result;
+ gfc_actual_arglist *arg;
- for (; arg; last = arg, arg = arg->next)
+ arg = e->value.function.actual;
+ result = gfc_copy_expr (arg->expr);
+ for ( ; arg; arg = arg->next)
{
if (arg->expr->expr_type != EXPR_CONSTANT)
- continue;
+ return NULL;
- if (extremum == NULL)
- {
- extremum = arg;
- continue;
- }
-
- min_max_choose (arg->expr, extremum->expr, sign);
-
- /* Delete the extra constant argument. */
- if (last == NULL)
- expr->value.function.actual = arg->next;
- else
- last->next = arg->next;
-
- arg->next = NULL;
- gfc_free_actual_arglist (arg);
- arg = last;
+ trans_op_max (result, result, arg->expr);
}
- /* If there is one value left, replace the function call with the
- expression. */
- if (expr->value.function.actual->next != NULL)
- return NULL;
-
- /* Convert to the correct type and kind. */
- if (expr->ts.type != BT_UNKNOWN)
- return gfc_convert_constant (expr->value.function.actual->expr,
- expr->ts.type, expr->ts.kind);
-
- if (specific->ts.type != BT_UNKNOWN)
- return gfc_convert_constant (expr->value.function.actual->expr,
- specific->ts.type, specific->ts.kind);
-
- return gfc_copy_expr (expr->value.function.actual->expr);
+ return result;
}
gfc_expr *
-gfc_simplify_min (gfc_expr *e)
+gfc_simplify_maxval (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
- return simplify_min_max (e, -1);
-}
+ if (!is_constant_array_expr (array))
+ return NULL;
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
+ return NULL;
-gfc_expr *
-gfc_simplify_max (gfc_expr *e)
-{
- return simplify_min_max (e, 1);
+ return !dim || array->rank == 1 ?
+ simplify_trans_scalar (array, mask, trans_op_max, INT_MIN) :
+ simplify_trans_array (array, dim, mask, trans_op_max, INT_MIN);
}
-/* This is a simplified version of simplify_min_max to provide
- simplification of minval and maxval for a vector. */
-
-static gfc_expr *
-simplify_minval_maxval (gfc_expr *expr, int sign)
+static void
+trans_op_min (gfc_expr *result, gfc_expr *op1, gfc_expr *op2)
{
- gfc_constructor *ctr, *extremum;
- gfc_intrinsic_sym * specific;
-
- extremum = NULL;
- specific = expr->value.function.isym;
+ gfc_expr *op;
+ size_t length;
+ gfc_char_t *string;
- ctr = expr->value.constructor;
-
- for (; ctr; ctr = ctr->next)
+ switch (result->ts.type)
{
- if (ctr->expr->expr_type != EXPR_CONSTANT)
- return NULL;
-
- if (extremum == NULL)
- {
- extremum = ctr;
- continue;
- }
-
- min_max_choose (ctr->expr, extremum->expr, sign);
- }
+ case BT_INTEGER:
+ mpz_set (result->value.integer,
+ mpz_cmp (op1->value.integer, op2->value.integer) <= 0
+ ? op1->value.integer
+ : op2->value.integer);
+ break;
- if (extremum == NULL)
- return NULL;
+ case BT_REAL:
+ mpfr_min (result->value.real,
+ op1->value.real, op2->value.real, GFC_RND_MODE);
+ break;
- /* Convert to the correct type and kind. */
- if (expr->ts.type != BT_UNKNOWN)
- return gfc_convert_constant (extremum->expr,
- expr->ts.type, expr->ts.kind);
+ case BT_CHARACTER:
+ /* When comparing CHARACTER strings, the result needs to be
+ padded with spaces to match the size of the larger of the
+ two operands. */
+ op = (gfc_compare_string (op1, op2) <= 0) ? op1 : op2;
+ length = MAX(op1->value.character.length,
+ op2->value.character.length);
+ string = gfc_get_wide_string (length + 1);
+ gfc_wide_strcpy (string, op->value.character.string);
+ gfc_wide_memset (&string[op->value.character.length], ' ',
+ length - op->value.character.length);
+ string[length] = '\0'; /* Debugger prefers terminated strings. */
+
+ gfc_free (result->value.character.string);
+ result->value.character.length = length;
+ result->value.character.string = string;
+ break;
- if (specific->ts.type != BT_UNKNOWN)
- return gfc_convert_constant (extremum->expr,
- specific->ts.type, specific->ts.kind);
-
- return gfc_copy_expr (extremum->expr);
+ default:
+ gcc_unreachable();
+ }
}
gfc_expr *
-gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+gfc_simplify_min (gfc_expr *e)
{
- if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
- return NULL;
-
- return simplify_minval_maxval (array, -1);
+ gfc_expr *result;
+ gfc_actual_arglist *arg;
+
+ arg = e->value.function.actual;
+ result = gfc_copy_expr (arg->expr);
+ for ( ; arg; arg = arg->next)
+ {
+ if (arg->expr->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ trans_op_min (result, result, arg->expr);
+ }
+
+ return result;
}
gfc_expr *
-gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
+gfc_simplify_minval (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
{
- if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
+ if (!is_constant_array_expr (array))
+ return NULL;
+
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
return NULL;
- return simplify_minval_maxval (array, 1);
+
+ return !dim || array->rank == 1 ?
+ simplify_trans_scalar (array, mask, trans_op_min, INT_MAX) :
+ simplify_trans_array (array, dim, mask, trans_op_min, INT_MAX);
}
@@ -3136,6 +3483,62 @@ gfc_simplify_or (gfc_expr *x, gfc_expr *
}
+static void
+trans_op_product (gfc_expr *result, gfc_expr *op1, gfc_expr *op2)
+{
+ mpfr_t r1r2, i1i2, r1i2, i1r2;
+
+ switch (result->ts.type)
+ {
+ case BT_INTEGER:
+ mpz_mul (result->value.integer,
+ op1->value.integer, op2->value.integer);
+ break;
+
+ case BT_REAL:
+ mpfr_mul (result->value.real,
+ op1->value.real, op2->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpfr_inits (r1r2, i1i2, r1i2, i1r2, NULL);
+ mpfr_mul (r1r2,
+ op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
+ mpfr_mul (i1i2,
+ op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (r1i2,
+ op1->value.complex.r, op2->value.complex.i, GFC_RND_MODE);
+ mpfr_mul (i1r2,
+ op1->value.complex.i, op2->value.complex.r, GFC_RND_MODE);
+
+ mpfr_sub (result->value.complex.r, r1r2, i1i2, GFC_RND_MODE);
+ mpfr_add (result->value.complex.i, r1i2, i1r2, GFC_RND_MODE);
+ mpfr_clears (r1r2, i1i2, r1i2, i1r2, NULL);
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+}
+
+
+gfc_expr *
+gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ if (!is_constant_array_expr (array))
+ return NULL;
+
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return !dim || array->rank == 1 ?
+ simplify_trans_scalar (array, mask, trans_op_product, 1) :
+ simplify_trans_array (array, dim, mask, trans_op_product, 1);
+}
+
+
gfc_expr *
gfc_simplify_precision (gfc_expr *e)
{
@@ -3398,27 +3801,6 @@ gfc_simplify_repeat (gfc_expr *e, gfc_ex
}
-/* Test that the expression is an constant array. */
-
-static bool
-is_constant_array_expr (gfc_expr *e)
-{
- gfc_constructor *c;
-
- if (e == NULL)
- return true;
-
- if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
- return false;
-
- for (c = e->value.constructor; c; c = c->next)
- if (c->expr->expr_type != EXPR_CONSTANT)
- return false;
-
- return true;
-}
-
-
/* This one is a bear, but mainly has to do with shuffling elements. */
gfc_expr *
@@ -4351,6 +4733,51 @@ negative_arg:
}
+static void
+trans_op_sum (gfc_expr *result, gfc_expr *op1, gfc_expr *op2)
+{
+ switch (result->ts.type)
+ {
+ case BT_INTEGER:
+ mpz_add (result->value.integer,
+ op1->value.integer, op2->value.integer);
+ break;
+
+ case BT_REAL:
+ mpfr_add (result->value.real,
+ op1->value.real, op2->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpfr_add (result->value.complex.r,
+ op1->value.complex.r, op2->value.complex.r, GFC_RND_MODE);
+ mpfr_add (result->value.complex.i,
+ op1->value.complex.i, op2->value.complex.i, GFC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+}
+
+
+gfc_expr *
+gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
+{
+ if (!is_constant_array_expr (array))
+ return NULL;
+
+ if (mask
+ && !is_constant_array_expr (mask)
+ && mask->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ return !dim || array->rank == 1 ?
+ simplify_trans_scalar (array, mask, trans_op_sum, 0) :
+ simplify_trans_array (array, dim, mask, trans_op_sum, 0);
+}
+
+
gfc_expr *
gfc_simplify_tan (gfc_expr *x)
{
Index: fortran/intrinsic.h
===================================================================
--- fortran/intrinsic.h (revision 143030)
+++ fortran/intrinsic.h (working copy)
@@ -200,10 +200,12 @@ gfc_expr *gfc_simplify_adjustl (gfc_expr
gfc_expr *gfc_simplify_adjustr (gfc_expr *);
gfc_expr *gfc_simplify_aimag (gfc_expr *);
gfc_expr *gfc_simplify_aint (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_all (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dint (gfc_expr *);
gfc_expr *gfc_simplify_anint (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_dnint (gfc_expr *);
gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_any (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_asin (gfc_expr *);
gfc_expr *gfc_simplify_asinh (gfc_expr *);
gfc_expr *gfc_simplify_atan (gfc_expr *);
@@ -288,6 +290,7 @@ gfc_expr *gfc_simplify_idnint (gfc_expr
gfc_expr *gfc_simplify_not (gfc_expr *);
gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_precision (gfc_expr *);
+gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_radix (gfc_expr *);
gfc_expr *gfc_simplify_range (gfc_expr *);
gfc_expr *gfc_simplify_real (gfc_expr *, gfc_expr *);
@@ -310,6 +313,7 @@ gfc_expr *gfc_simplify_size (gfc_expr *,
gfc_expr *gfc_simplify_sngl (gfc_expr *);
gfc_expr *gfc_simplify_spacing (gfc_expr *);
gfc_expr *gfc_simplify_sqrt (gfc_expr *);
+gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_tan (gfc_expr *);
gfc_expr *gfc_simplify_tanh (gfc_expr *);
gfc_expr *gfc_simplify_tiny (gfc_expr *);
Index: fortran/intrinsic.c
===================================================================
--- fortran/intrinsic.c (revision 143030)
+++ fortran/intrinsic.c (working copy)
@@ -1065,7 +1065,7 @@ add_functions (void)
make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
- gfc_check_all_any, NULL, gfc_resolve_all,
+ gfc_check_all_any, gfc_simplify_all, gfc_resolve_all,
msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
@@ -1087,7 +1087,7 @@ add_functions (void)
make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
- gfc_check_all_any, NULL, gfc_resolve_any,
+ gfc_check_all_any, gfc_simplify_any, gfc_resolve_any,
msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
@@ -2103,7 +2103,7 @@ add_functions (void)
make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
- gfc_check_product_sum, NULL, gfc_resolve_product,
+ gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
@@ -2341,7 +2341,7 @@ add_functions (void)
make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
- gfc_check_product_sum, NULL, gfc_resolve_sum,
+ gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
msk, BT_LOGICAL, dl, OPTIONAL);
Index: fortran/check.c
===================================================================
--- fortran/check.c (revision 143030)
+++ fortran/check.c (working copy)
@@ -339,6 +339,9 @@ dim_rank_check (gfc_expr *dim, gfc_expr
gfc_array_ref *ar;
int rank;
+ if (dim == NULL)
+ return SUCCESS;
+
if (dim->expr_type != EXPR_CONSTANT
|| (array->expr_type != EXPR_VARIABLE
&& array->expr_type != EXPR_ARRAY))
@@ -519,6 +522,9 @@ gfc_check_all_any (gfc_expr *mask, gfc_e
if (dim_check (dim, 1, false) == FAILURE)
return FAILURE;
+ if (dim_rank_check (dim, mask, 0) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
@@ -1512,14 +1518,11 @@ gfc_check_lbound (gfc_expr *array, gfc_e
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, false) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 1) == FAILURE)
- return FAILURE;
- }
+ if (dim_rank_check (dim, array, 1) == FAILURE)
+ return FAILURE;
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
return FAILURE;
@@ -1749,12 +1752,8 @@ gfc_check_min_max (gfc_actual_arglist *a
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;
- }
+ else if (int_or_real_check (x, 0) == FAILURE)
+ return FAILURE;
return check_rest (x->ts.type, x->ts.kind, arg);
}
@@ -1905,10 +1904,10 @@ gfc_check_minloc_maxloc (gfc_actual_argl
ap->next->next->expr = m;
}
- if (d && dim_check (d, 1, false) == FAILURE)
+ if (dim_check (d, 1, false) == FAILURE)
return FAILURE;
- if (d && dim_rank_check (d, a, 0) == FAILURE)
+ if (dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
@@ -1961,10 +1960,10 @@ check_reduction (gfc_actual_arglist *ap)
ap->next->next->expr = m;
}
- if (d && dim_check (d, 1, false) == FAILURE)
+ if (dim_check (d, 1, false) == FAILURE)
return FAILURE;
- if (d && dim_rank_check (d, a, 0) == FAILURE)
+ if (dim_rank_check (d, a, 0) == FAILURE)
return FAILURE;
if (m != NULL && type_check (m, 2, BT_LOGICAL) == FAILURE)
@@ -1987,8 +1986,17 @@ check_reduction (gfc_actual_arglist *ap)
gfc_try
gfc_check_minval_maxval (gfc_actual_arglist *ap)
{
- if (int_or_real_check (ap->expr, 0) == FAILURE
- || array_check (ap->expr, 0) == FAILURE)
+ if (ap->expr->ts.type == BT_CHARACTER)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
+ "with CHARACTER argument at %L",
+ gfc_current_intrinsic, &ap->expr->where) == FAILURE)
+ return FAILURE;
+ }
+ else if (int_or_real_check (ap->expr, 0) == FAILURE)
+ return FAILURE;
+
+ if (array_check (ap->expr, 0) == FAILURE)
return FAILURE;
return check_reduction (ap);
@@ -2555,17 +2563,15 @@ gfc_check_size (gfc_expr *array, gfc_exp
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, true) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, true) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 0) == FAILURE)
- return FAILURE;
- }
+ if (dim_rank_check (dim, array, 0) == FAILURE)
+ return FAILURE;
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
return FAILURE;
+
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where) == FAILURE)
@@ -2898,17 +2904,15 @@ gfc_check_ubound (gfc_expr *array, gfc_e
if (array_check (array, 0) == FAILURE)
return FAILURE;
- if (dim != NULL)
- {
- if (dim_check (dim, 1, false) == FAILURE)
- return FAILURE;
+ if (dim_check (dim, 1, false) == FAILURE)
+ return FAILURE;
- if (dim_rank_check (dim, array, 0) == FAILURE)
- return FAILURE;
- }
+ if (dim_rank_check (dim, array, 0) == FAILURE)
+ return FAILURE;
if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
return FAILURE;
+
if (kind && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: '%s' intrinsic "
"with KIND argument at %L",
gfc_current_intrinsic, &kind->where) == FAILURE)
Index: fortran/trans-intrinsic.c
===================================================================
--- fortran/trans-intrinsic.c (revision 143030)
+++ fortran/trans-intrinsic.c (working copy)
@@ -2344,6 +2344,11 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
break;
+ case BT_CHARACTER:
+ gfc_fatal_error("F2003 Feature: character arguments to MINVAL/MAXVAL "
+ "are not implemented yet.");
+ return;
+
default:
gcc_unreachable ();
}
Index: fortran/expr.c
===================================================================
--- fortran/expr.c (revision 143030)
+++ fortran/expr.c (working copy)
@@ -2066,7 +2066,7 @@ check_inquiry (gfc_expr *e, int not_rest
name = e->symtree->n.sym->name;
- functions = (gfc_option.warn_std & GFC_STD_F2003)
+ functions = (gfc_option.allow_std & GFC_STD_F2003)
? inquiry_func_f2003 : inquiry_func_f95;
for (i = 0; functions[i]; i++)
@@ -2129,8 +2129,21 @@ check_transformational (gfc_expr *e)
"selected_real_kind", "transfer", "trim", NULL
};
+/* TODO: Simplifiers for transformation intrinsics:
+ COUNT, CSHIFT, DOT_PRODUCT, EOSHIFT,
+ MAXLOC, MATMUL, MINLOC, NULL, PACK,
+ SELECTED_CHAR_KIND, SPREAD, TRANSPOSE,
+ UNPACK */
+
+ static const char * const trans_func_f2003[] = {
+ "all", "any", "maxval", "minval", "product",
+ "repeat", "reshape", "selected_int_kind",
+ "selected_real_kind", "sum", "transfer", "trim", NULL
+ };
+
int i;
const char *name;
+ const char *const *functions;
if (!e->value.function.isym
|| !e->value.function.isym->transformational)
@@ -2138,31 +2151,23 @@ check_transformational (gfc_expr *e)
name = e->symtree->n.sym->name;
+ functions = (gfc_option.allow_std & GFC_STD_F2003)
+ ? trans_func_f2003 : trans_func_f95;
+
/* NULL() is dealt with below. */
if (strcmp ("null", name) == 0)
return MATCH_NO;
- for (i = 0; trans_func_f95[i]; i++)
- if (strcmp (trans_func_f95[i], name) == 0)
- break;
+ for (i = 0; functions[i]; i++)
+ if (strcmp (functions[i], name) == 0)
+ break;
- /* FIXME, F2003: implement translation of initialization
- expressions before enabling this check. For F95, error
- out if the transformational function is not in the list. */
-#if 0
- if (trans_func_f95[i] == NULL
- && gfc_notify_std (GFC_STD_F2003,
- "transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", name, &e->where) == FAILURE)
- return MATCH_ERROR;
-#else
- if (trans_func_f95[i] == NULL)
+ if (functions[i] == NULL)
{
gfc_error("transformational intrinsic '%s' at %L is not permitted "
"in an initialization expression", name, &e->where);
return MATCH_ERROR;
}
-#endif
return check_init_expr_arguments (e);
}
Index: fortran/intrinsic.texi
===================================================================
--- fortran/intrinsic.texi (revision 143030)
+++ fortran/intrinsic.texi (working copy)
@@ -2725,12 +2725,11 @@ Inverse function: @ref{ACOSH}
@table @asis
@item @emph{Description}:
-
-@code{COUNT(MASK [, DIM [, KIND]])} counts the number of @code{.TRUE.}
-elements of @var{MASK} along the dimension of @var{DIM}. If @var{DIM} is
-omitted it is taken to be @code{1}. @var{DIM} is a scalar of type
-@code{INTEGER} in the range of @math{1 /leq DIM /leq n)} where @math{n}
-is the rank of @var{MASK}.
+Counts the number of @code{.TRUE.} elements in a logical @var{MASK},
+or, if the @var{DIM} argument is supplied, counts the number of
+elements along each row of the array in the @var{DIM} direction.
+If the array has zero size, or all of the elements of @var{MASK} are
+@code{.FALSE.}, then the result is @code{0}.
@item @emph{Standard}:
Fortran 95 and later, with @var{KIND} argument Fortran 2003 and later
@@ -2752,7 +2751,9 @@ expression indicating the kind parameter
@item @emph{Return value}:
The return value is of type @code{INTEGER} and of kind @var{KIND}. If
@var{KIND} is absent, the return value is of default integer kind.
-The result has a rank equal to that of @var{MASK}.
+If @var{DIM} is present, the result is an array with a rank one less
+than the rank of @var{ARRAY}, and a size corresponding to the shape
+of @var{ARRAY} with the @var{DIM} dimension removed.
@item @emph{Example}:
@smallexample
@@ -7420,7 +7421,7 @@ for the @code{*} or @code{.AND.} operato
Returns the argument with the largest (most positive) value.
@item @emph{Standard}:
-Fortran 77 and later
+Fortran 77 and later, with @code{CHARACTER} argument type Fortran 2003 and later
@item @emph{Class}:
Elemental function
@@ -7430,16 +7431,25 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{A1} @tab The type shall be @code{INTEGER} or
-@code{REAL}.
-@item @var{A2}, @var{A3}, ... @tab An expression of the same type and kind
-as @var{A1}. (As a GNU extension, arguments of different kinds are
+@item @var{A1} @tab The type shall be @code{INTEGER}, @code{REAL}
+or @code{CHARACTER} (Fortran 2003).
+@item @var{A2}, @var{A3}, ... @tab An expression of the same type and
+kind as @var{A1}. (As a GNU extension, arguments of different kinds are
permitted.)
@end multitable
@item @emph{Return value}:
The return value corresponds to the maximum value among the arguments,
-and has the same type and kind as the first argument.
+and has the same type and kind as the first argument. If the arguments
+are of type @code{CHARACTER}, the result string has the same length as
+the longest string of all arguments, padded with blanks if necessary.
+
+@item @emph{Example}:
+@smallexample
+program max_string
+ print *, MAX ("", "foo", "bazamm") ! "foo "
+end program
+@end smallexample
@item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25
@@ -7572,11 +7582,11 @@ each row of the array in the @var{DIM} d
present, only the elements for which @var{MASK} is @code{.TRUE.} are
considered. If the array has zero size, or all of the elements of
@var{MASK} are @code{.FALSE.}, then the result is @code{-HUGE(ARRAY)}
-if @var{ARRAY} is numeric, or a string of nulls if @var{ARRAY} is of character
-type.
+if @var{ARRAY} is numeric, or a string of @code{CHAR(0)} if @var{ARRAY}
+is of character type.
@item @emph{Standard}:
-Fortran 95 and later
+Fortran 95 and later, with @code{CHARACTER} argument type Fortran 2003 and later
@item @emph{Class}:
Transformational function
@@ -7590,7 +7600,7 @@ Transformational function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER},
-@code{REAL}, or @code{CHARACTER}.
+@code{REAL}, or @code{CHARACTER} (Fortran 2003).
@item @var{DIM} @tab (Optional) Shall be a scalar of type
@code{INTEGER}, with a value between one and the rank of @var{ARRAY},
inclusive. It may not be an optional dummy argument.
@@ -7602,11 +7612,11 @@ and conformable with @var{ARRAY}.
If @var{DIM} is absent, or if @var{ARRAY} has a rank of one, the result
is a scalar. If @var{DIM} is present, the result is an array with a
rank one less than the rank of @var{ARRAY}, and a size corresponding to
-the size of @var{ARRAY} with the @var{DIM} dimension removed. In all
+the shape of @var{ARRAY} with the @var{DIM} dimension removed. In all
cases, the result is of the same type and kind as @var{ARRAY}.
@item @emph{See also}:
-@ref{MAX}, @ref{MAXLOC}
+@ref{MAX}, @ref{MAXLOC}, , @ref{MINVAL}
@end table
@@ -7740,7 +7750,7 @@ The result is of the same type and type
Returns the argument with the smallest (most negative) value.
@item @emph{Standard}:
-Fortran 77 and later
+Fortran 77 and later, with @code{CHARACTER} argument type Fortran 2003 and later
@item @emph{Class}:
Elemental function
@@ -7750,16 +7760,25 @@ Elemental function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{A1} @tab The type shall be @code{INTEGER} or
-@code{REAL}.
+@item @var{A1} @tab The type shall be @code{INTEGER},
+@code{REAL} or @code{CHARACTER} (Fortran 2003).
@item @var{A2}, @var{A3}, ... @tab An expression of the same type and kind
as @var{A1}. (As a GNU extension, arguments of different kinds are
permitted.)
@end multitable
@item @emph{Return value}:
-The return value corresponds to the maximum value among the arguments,
-and has the same type and kind as the first argument.
+The return value corresponds to the minimum value among the arguments,
+and has the same type and kind as the first argument. If the arguments
+are of type @code{CHARACTER}, the result string has the same length as
+the longest string of all arguments, padded with blanks if necessary.
+
+@item @emph{Example}:
+@smallexample
+program min_string
+ print *, MIN ("", "foo", "bazamm") ! " "
+end program
+@end smallexample
@item @emph{Specific names}:
@multitable @columnfractions .20 .20 .20 .25
@@ -7887,7 +7906,7 @@ considered. If the array has zero size,
@var{ARRAY} is of character type.
@item @emph{Standard}:
-Fortran 95 and later
+Fortran 95 and later, with @code{CHARACTER} argument type Fortran 2003 and later
@item @emph{Class}:
Transformational function
@@ -7901,7 +7920,7 @@ Transformational function
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{ARRAY} @tab Shall be an array of type @code{INTEGER},
-@code{REAL}, or @code{CHARACTER}.
+@code{REAL}, or @code{CHARACTER} (Fortran 2003).
@item @var{DIM} @tab (Optional) Shall be a scalar of type
@code{INTEGER}, with a value between one and the rank of @var{ARRAY},
inclusive. It may not be an optional dummy argument.
@@ -7913,11 +7932,11 @@ and conformable with @var{ARRAY}.
If @var{DIM} is absent, or if @var{ARRAY} has a rank of one, the result
is a scalar. If @var{DIM} is present, the result is an array with a
rank one less than the rank of @var{ARRAY}, and a size corresponding to
-the size of @var{ARRAY} with the @var{DIM} dimension removed. In all
+the shape of @var{ARRAY} with the @var{DIM} dimension removed. In all
cases, the result is of the same type and kind as @var{ARRAY}.
@item @emph{See also}:
-@ref{MIN}, @ref{MINLOC}
+@ref{MAXVAL}, @ref{MIN}, @ref{MINLOC}
@end table
Index: testsuite/gfortran.dg/product_init_expr.f90
===================================================================
--- testsuite/gfortran.dg/product_init_expr.f90 (revision 0)
+++ testsuite/gfortran.dg/product_init_expr.f90 (revision 0)
@@ -0,0 +1,66 @@
+! { dg-do "run" }
+! { dg-options "-fno-inline" }
+!
+! PRODUCT as initialization expression.
+!
+! This test compares results of simplifier of PRODUCT
+! with the corresponding inlined or library routine(s).
+!
+
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] )
+ INTEGER, PARAMETER :: imatrix_prod = PRODUCT (imatrix)
+ INTEGER, PARAMETER :: imatrix_prod_d1(4) = PRODUCT (imatrix, dim=1)
+ INTEGER, PARAMETER :: imatrix_prod_d2(2) = PRODUCT (imatrix, dim=2)
+ LOGICAL, PARAMETER :: i_equal_prod = ALL ([PRODUCT( imatrix_prod_d1 ) == PRODUCT ( imatrix_prod_d2 ), &
+ PRODUCT( imatrix_prod_d1 ) == imatrix_prod])
+ LOGICAL, PARAMETER :: i_empty_prod = PRODUCT(imatrix, mask=.FALSE.) == 1
+
+ REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0 ], [2, 4] )
+ REAL, PARAMETER :: rmatrix_prod = PRODUCT (rmatrix)
+ REAL, PARAMETER :: rmatrix_prod_d1(4) = PRODUCT (rmatrix, dim=1)
+ REAL, PARAMETER :: rmatrix_prod_d2(2) = PRODUCT (rmatrix, dim=2)
+ LOGICAL, PARAMETER :: r_equal_prod = ALL ([PRODUCT( rmatrix_prod_d1 ) == PRODUCT ( rmatrix_prod_d2 ), &
+ PRODUCT( rmatrix_prod_d1 ) == rmatrix_prod])
+ LOGICAL, PARAMETER :: r_empty_prod = PRODUCT(rmatrix, mask=.FALSE.) == 1.0
+
+ IF (.NOT. ALL ([i_equal_prod, i_empty_prod])) CALL abort()
+ IF (.NOT. ALL ([r_equal_prod, r_empty_prod])) CALL abort()
+
+ CALL ilib (imatrix, imatrix_prod)
+ CALL ilib_with_dim (imatrix, 1, imatrix_prod_d1)
+ CALL ilib_with_dim (imatrix, 2, imatrix_prod_d2)
+ CALL rlib (rmatrix, rmatrix_prod)
+ CALL rlib_with_dim (rmatrix, 1, rmatrix_prod_d1)
+ CALL rlib_with_dim (rmatrix, 2, rmatrix_prod_d2)
+
+CONTAINS
+ SUBROUTINE ilib (array, result)
+ INTEGER, DIMENSION(:,:), INTENT(in) :: array
+ INTEGER, INTENT(in) :: result
+ IF (PRODUCT(array) /= result) CALL abort()
+ END SUBROUTINE
+
+ SUBROUTINE ilib_with_dim (array, dim, result)
+ INTEGER, DIMENSION(:,:), INTENT(in) :: array
+ INTEGER, INTENT(iN) :: dim
+ INTEGER, DIMENSION(:), INTENT(in) :: result
+ IF (ANY (PRODUCT (array, dim=dim) /= result)) CALL abort()
+ END SUBROUTINE
+
+ SUBROUTINE rlib (array, result)
+ REAL, DIMENSION(:,:), INTENT(in) :: array
+ REAL, INTENT(in) :: result
+ IF (ABS(PRODUCT(array) - result) > 2e-6) CALL abort()
+ END SUBROUTINE
+
+ SUBROUTINE rlib_with_dim (array, dim, result)
+ REAL, DIMENSION(:,:), INTENT(in) :: array
+ INTEGER, INTENT(iN) :: dim
+ REAL, DIMENSION(:), INTENT(in) :: result
+ IF (ANY (ABS(PRODUCT (array, dim=dim) - result) > 2e-6)) CALL abort()
+ END SUBROUTINE
+END
+
+
Index: testsuite/gfortran.dg/minmaxval_2.f90
===================================================================
--- testsuite/gfortran.dg/minmaxval_2.f90 (revision 0)
+++ testsuite/gfortran.dg/minmaxval_2.f90 (revision 0)
@@ -0,0 +1,47 @@
+! { dg-do run }
+! { dg-options "-fno-range-check" }
+!
+! Test MINVAL/MAXVAL in initialization expressions.
+!
+! On success, the original dump should be empty, on failure,
+! it should only contain a single ABORT. Anything else must
+! be simplified into oblivion.
+!
+
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: array(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2,4])
+
+ INTEGER, PARAMETER :: array_min = MINVAL (array, mask=.TRUE.)
+ INTEGER, PARAMETER :: array_min_d1(4) = MINVAL (array, dim=1)
+ INTEGER, PARAMETER :: array_min_d2(2) = MINVAL (array, dim=2)
+ LOGICAL, PARAMETER :: equal_min = MINVAL( [ array_min_d1, array_min_d2 ] ) == array_min
+ LOGICAL, PARAMETER :: equal_min_huge = MINVAL (array, mask=.FALSE.) == HUGE(array)
+ LOGICAL, PARAMETER :: equal_masked_min = MINVAL (array, mask=MOD(array, 2) == 0) == 2
+
+ INTEGER, PARAMETER :: array_max = MAXVAL (array, mask=.TRUE.)
+ INTEGER, PARAMETER :: array_max_d1(4) = MAXVAL (array, dim=1)
+ INTEGER, PARAMETER :: array_max_d2(2) = MAXVAL (array, dim=2)
+ LOGICAL, PARAMETER :: equal_max = MAXVAL( [ array_max_d1, array_max_d2 ] ) == array_max
+ LOGICAL, PARAMETER :: equal_max_neg_huge = MAXVAL (array, mask=.FALSE.) == -HUGE(array)-1
+ LOGICAL, PARAMETER :: equal_masked_max = MAXVAL (array, mask=MOD(array, 2) == 1) == 7
+
+ CHARACTER(len=*), PARAMETER :: strings(3,2) = RESHAPE (["foo", "bar", "baz", "zab", "rab", "oof"], [3,2])
+ CHARACTER(len=*), PARAMETER :: strings_min = MINVAL (strings)
+ CHARACTER(len=*), PARAMETER :: strings_min_d1(2) = MINVAL (strings, dim=1)
+ CHARACTER(len=*), PARAMETER :: strings_min_d2(3) = MINVAL (strings, dim=2)
+ LOGICAL, PARAMETER :: equal_strings_min = MINVAL( [ strings_min_d1, strings_min_d2 ] ) == strings_min
+ LOGICAL, PARAMETER :: equal_strings_min_huge = MINVAL (strings, mask=.FALSE.) == CHAR(255)//CHAR(255)//CHAR(255)
+
+ CHARACTER(len=*), PARAMETER :: strings_max = MAXVAL (strings)
+ CHARACTER(len=*), PARAMETER :: strings_max_d1(2) = MAXVAL (strings, dim=1)
+ CHARACTER(len=*), PARAMETER :: strings_max_d2(3) = MAXVAL (strings, dim=2)
+ LOGICAL, PARAMETER :: equal_strings_max = MAXVAL( [ strings_max_d1, strings_max_d2 ] ) == strings_max
+ LOGICAL, PARAMETER :: equal_strings_max_huge = MAXVAL (strings, mask=.FALSE.) == CHAR(0)//CHAR(0)//CHAR(0)
+
+
+ IF (.NOT. ALL( [ equal_min, equal_min_huge, equal_masked_min, &
+ equal_max, equal_max_neg_huge, equal_masked_max, &
+ equal_strings_min, equal_strings_min_huge, &
+ equal_strings_max, equal_strings_max_huge ] )) CALL abort()
+end
Index: testsuite/gfortran.dg/sum_init_expr.f90
===================================================================
--- testsuite/gfortran.dg/sum_init_expr.f90 (revision 0)
+++ testsuite/gfortran.dg/sum_init_expr.f90 (revision 0)
@@ -0,0 +1,66 @@
+! { dg-do "run" }
+! { dg-options "-fno-inline" }
+!
+! SUM as initialization expression.
+!
+! This test compares results of simplifier of SUM
+! with the corresponding inlined or library routine(s).
+!
+
+ IMPLICIT NONE
+
+ INTEGER, PARAMETER :: imatrix(2,4) = RESHAPE ([ 1, 2, 3, 4, 5, 6, 7, 8 ], [2, 4] )
+ INTEGER, PARAMETER :: imatrix_sum = SUM (imatrix)
+ INTEGER, PARAMETER :: imatrix_sum_d1(4) = SUM (imatrix, dim=1)
+ INTEGER, PARAMETER :: imatrix_sum_d2(2) = SUM (imatrix, dim=2)
+ LOGICAL, PARAMETER :: i_equal_sum = ALL ([SUM( imatrix_sum_d1 ) == SUM ( imatrix_sum_d2 ), &
+ SUM( imatrix_sum_d1 ) == imatrix_sum])
+ LOGICAL, PARAMETER :: i_empty_sum = SUM(imatrix, mask=.FALSE.) == 0
+
+ REAL, PARAMETER :: rmatrix(2,4) = RESHAPE ([ 1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, 8.8 ], [2, 4] )
+ REAL, PARAMETER :: rmatrix_sum = SUM (rmatrix)
+ REAL, PARAMETER :: rmatrix_sum_d1(4) = SUM (rmatrix, dim=1)
+ REAL, PARAMETER :: rmatrix_sum_d2(2) = SUM (rmatrix, dim=2)
+ LOGICAL, PARAMETER :: r_equal_sum = ALL ([SUM( rmatrix_sum_d1 ) == SUM ( rmatrix_sum_d2 ), &
+ SUM( rmatrix_sum_d1 ) == rmatrix_sum])
+ LOGICAL, PARAMETER :: r_empty_sum = SUM(rmatrix, mask=.FALSE.) == 0.0
+
+ IF (.NOT. ALL ([i_equal_sum, i_empty_sum])) CALL abort()
+ IF (.NOT. ALL ([r_equal_sum, r_empty_sum])) CALL abort()
+
+ CALL ilib (imatrix, imatrix_sum)
+ CALL ilib_with_dim (imatrix, 1, imatrix_sum_d1)
+ CALL ilib_with_dim (imatrix, 2, imatrix_sum_d2)
+ CALL rlib (rmatrix, rmatrix_sum)
+ CALL rlib_with_dim (rmatrix, 1, rmatrix_sum_d1)
+ CALL rlib_with_dim (rmatrix, 2, rmatrix_sum_d2)
+
+CONTAINS
+ SUBROUTINE ilib (array, result)
+ INTEGER, DIMENSION(:,:), INTENT(in) :: array
+ INTEGER, INTENT(in) :: result
+ IF (SUM(array) /= result) CALL abort()
+ END SUBROUTINE
+
+ SUBROUTINE ilib_with_dim (array, dim, result)
+ INTEGER, DIMENSION(:,:), INTENT(in) :: array
+ INTEGER, INTENT(iN) :: dim
+ INTEGER, DIMENSION(:), INTENT(in) :: result
+ IF (ANY (SUM (array, dim=dim) /= result)) CALL abort()
+ END SUBROUTINE
+
+ SUBROUTINE rlib (array, result)
+ REAL, DIMENSION(:,:), INTENT(in) :: array
+ REAL, INTENT(in) :: result
+ IF (ABS(SUM(array) - result) > 2e-6) CALL abort()
+ END SUBROUTINE
+
+ SUBROUTINE rlib_with_dim (array, dim, result)
+ REAL, DIMENSION(:,:), INTENT(in) :: array
+ INTEGER, INTENT(iN) :: dim
+ REAL, DIMENSION(:), INTENT(in) :: result
+ IF (ANY (ABS(SUM (array, dim=dim) - result) > 2e-6)) CALL abort()
+ END SUBROUTINE
+END
+
+