From 8ec259c12bf6fdaefa2221a08be3e5f90185567b Mon Sep 17 00:00:00 2001 From: Daniel Franke Date: Sun, 7 Jun 2009 07:53:21 -0400 Subject: re PR fortran/25104 ([F2003] Non-initialization expr. as case-selector) 2009-06-07 Daniel Franke PR fortran/25104 PR fortran/29962 * intrinsic.h (gfc_simplify_dot_product): New prototype. (gfc_simplify_matmul): Likewise. (gfc_simplify_transpose): Likewise. * intrinsic.c (add_functions): Added new simplifier callbacks. * simplify.c (init_result_expr): New. (compute_dot_product): New. (gfc_simplify_dot_product): New. (gfc_simplify_matmul): New. (gfc_simplify_transpose): New. * expr.c (check_transformational): Allow transformational * intrinsics with simplifier in initialization expression. 2009-06-07 Daniel Franke PR fortran/25104 PR fortran/29962 * gfortran.dg/dot_product_1.f03: New. * gfortran.dg/matmul_8.f03: New. * gfortran.dg/transpose_3.f03: New. From-SVN: r148243 --- gcc/fortran/simplify.c | 277 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 277 insertions(+) (limited to 'gcc/fortran/simplify.c') diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 737f299..db28d36 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -255,6 +255,138 @@ is_constant_array_expr (gfc_expr *e) } +/* 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(); +} + + +/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */ + +static gfc_expr * +compute_dot_product (gfc_constructor *ctor_a, int stride_a, + gfc_constructor *ctor_b, int stride_b) +{ + gfc_expr *result; + gfc_expr *a = ctor_a->expr, *b = ctor_b->expr; + + gcc_assert (gfc_compare_types (&a->ts, &b->ts)); + + result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where); + init_result_expr (result, 0, NULL); + + while (ctor_a && ctor_b) + { + /* Copying of expressions is required as operands are free'd + by the gfc_arith routines. */ + switch (result->ts.type) + { + case BT_LOGICAL: + result = gfc_or (result, + gfc_and (gfc_copy_expr (ctor_a->expr), + gfc_copy_expr (ctor_b->expr))); + break; + + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + result = gfc_add (result, + gfc_multiply (gfc_copy_expr (ctor_a->expr), + gfc_copy_expr (ctor_b->expr))); + break; + + default: + gcc_unreachable(); + } + + ADVANCE (ctor_a, stride_a); + ADVANCE (ctor_b, stride_b); + } + + return result; +} + /********************** Simplification functions *****************************/ gfc_expr * @@ -1210,6 +1342,32 @@ gfc_simplify_dim (gfc_expr *x, gfc_expr *y) } +gfc_expr* +gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b) +{ + gfc_expr *result; + + if (!is_constant_array_expr (vector_a) + || !is_constant_array_expr (vector_b)) + return NULL; + + gcc_assert (vector_a->rank == 1); + gcc_assert (vector_b->rank == 1); + gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts)); + + if (vector_a->value.constructor && vector_b->value.constructor) + return compute_dot_product (vector_a->value.constructor, 1, + vector_b->value.constructor, 1); + + /* Zero sized array ... */ + result = gfc_constant_result (vector_a->ts.type, + vector_a->ts.kind, + &vector_a->where); + init_result_expr (result, 0, NULL); + return result; +} + + gfc_expr * gfc_simplify_dprod (gfc_expr *x, gfc_expr *y) { @@ -2856,6 +3014,84 @@ gfc_simplify_logical (gfc_expr *e, gfc_expr *k) } +gfc_expr* +gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) +{ + gfc_expr *result; + gfc_constructor *ma_ctor, *mb_ctor; + int row, result_rows, col, result_columns, stride_a, stride_b; + + if (!is_constant_array_expr (matrix_a) + || !is_constant_array_expr (matrix_b)) + return NULL; + + gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts)); + result = gfc_start_constructor (matrix_a->ts.type, + matrix_a->ts.kind, + &matrix_a->where); + + if (matrix_a->rank == 1 && matrix_b->rank == 2) + { + result_rows = 1; + result_columns = mpz_get_si (matrix_b->shape[0]); + stride_a = 1; + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_columns); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 1) + { + result_rows = mpz_get_si (matrix_b->shape[0]); + result_columns = 1; + stride_a = mpz_get_si (matrix_a->shape[0]); + stride_b = 1; + + result->rank = 1; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + } + else if (matrix_a->rank == 2 && matrix_b->rank == 2) + { + result_rows = mpz_get_si (matrix_a->shape[0]); + result_columns = mpz_get_si (matrix_b->shape[1]); + stride_a = mpz_get_si (matrix_a->shape[1]); + stride_b = mpz_get_si (matrix_b->shape[0]); + + result->rank = 2; + result->shape = gfc_get_shape (result->rank); + mpz_init_set_si (result->shape[0], result_rows); + mpz_init_set_si (result->shape[1], result_columns); + } + else + gcc_unreachable(); + + ma_ctor = matrix_a->value.constructor; + mb_ctor = matrix_b->value.constructor; + + for (col = 0; col < result_columns; ++col) + { + ma_ctor = matrix_a->value.constructor; + + for (row = 0; row < result_rows; ++row) + { + gfc_expr *e; + e = compute_dot_product (ma_ctor, stride_a, + mb_ctor, 1); + + gfc_append_constructor (result, e); + + ADVANCE (ma_ctor, 1); + } + + ADVANCE (mb_ctor, stride_b); + } + + return result; +} + + gfc_expr * gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask) { @@ -4761,6 +4997,47 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) gfc_expr * +gfc_simplify_transpose (gfc_expr *matrix) +{ + int i, matrix_rows; + gfc_expr *result; + gfc_constructor *matrix_ctor; + + if (!is_constant_array_expr (matrix)) + return NULL; + + gcc_assert (matrix->rank == 2); + + result = gfc_start_constructor (matrix->ts.type, matrix->ts.kind, &matrix->where); + result->rank = 2; + result->shape = gfc_get_shape (result->rank); + mpz_set (result->shape[0], matrix->shape[1]); + mpz_set (result->shape[1], matrix->shape[0]); + + if (matrix->ts.type == BT_CHARACTER) + result->ts.cl = matrix->ts.cl; + + matrix_rows = mpz_get_si (matrix->shape[0]); + matrix_ctor = matrix->value.constructor; + for (i = 0; i < matrix_rows; ++i) + { + gfc_constructor *column_ctor = matrix_ctor; + while (column_ctor) + { + gfc_append_constructor (result, + gfc_copy_expr (column_ctor->expr)); + + ADVANCE (column_ctor, matrix_rows); + } + + ADVANCE (matrix_ctor, 1); + } + + return result; +} + + +gfc_expr * gfc_simplify_trim (gfc_expr *e) { gfc_expr *result; -- cgit v1.1