diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2006-06-20 04:30:48 +0000 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2006-06-20 04:30:48 +0000 |
commit | a4a11197f9f65c5523da3ce588d7508e47f801ab (patch) | |
tree | ac18f8deb5aff7c9354a8879e1c428d69345b10f | |
parent | 73dab33bce6cc186f05ac0cf45e42c58f9086b3c (diff) | |
download | gcc-a4a11197f9f65c5523da3ce588d7508e47f801ab.zip gcc-a4a11197f9f65c5523da3ce588d7508e47f801ab.tar.gz gcc-a4a11197f9f65c5523da3ce588d7508e47f801ab.tar.bz2 |
re PR fortran/25049 (TRANSPOSE not allowed in initialisation expression)
2006-06-20 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25049
PR fortran/25050
* check.c (non_init_transformational): New function.
(find_substring_ref): New function to signal use of disallowed
transformational intrinsic in an initialization expression.
(gfc_check_all_any): Call previous if initialization expr.
(gfc_check_count): The same.
(gfc_check_cshift): The same.
(gfc_check_dot_product): The same.
(gfc_check_eoshift): The same.
(gfc_check_minloc_maxloc): The same.
(gfc_check_minval_maxval): The same.
(gfc_check_gfc_check_product_sum): The same.
(gfc_check_pack): The same.
(gfc_check_spread): The same.
(gfc_check_transpose): The same.
(gfc_check_unpack): The same.
PR fortran/18769
*intrinsic.c (add_functions): Add gfc_simplify_transfer.
*intrinsic.h : Add prototype for gfc_simplify_transfer.
*simplify.c (gfc_simplify_transfer) : New function to act as
placeholder for eventual implementation. Emit error for now.
PR fortran/16206
* expr.c (find_array_element): Eliminate condition on length of
offset. Add bounds checking. Rearrange exit. Return try and
put gfc_constructor result as an argument.
(find_array_section): New function.
(find_substring_ref): New function.
(simplify_const_ref): Add calls to previous.
(simplify_parameter_variable): Return on NULL expr.
(gfc_simplify_expr): Only call gfc_expand_constructor for full
arrays.
PR fortran/20876
* match.c (gfc_match_forall): Add missing locus to gfc_code.
2006-06-20 Paul Thomas <pault@gcc.gnu.org>
PR libfortran/28005
* m4/matmul.m4: aystride = 1 does not uniquely detect the
presence of a temporary transpose; an array element in the
first dimension produces the same signature. Detect this
using the rank of a and add specific code.
* generated/matmul_r4.c: Regenerate.
* generated/matmul_r8.c: Regenerate.
* generated/matmul_r10.c: Regenerate.
* generated/matmul_r16.c: Regenerate.
* generated/matmul_c4.c: Regenerate.
* generated/matmul_c8.c: Regenerate.
* generated/matmul_c10.c: Regenerate.
* generated/matmul_c16.c: Regenerate.
* generated/matmul_i4.c: Regenerate.
* generated/matmul_i8.c: Regenerate.
* generated/matmul_i16.c: Regenerate.
2006-06-20 Paul Thomas <pault@gcc.gnu.org>
PR fortran/16206
* gfortran.dg/array_initializer_1.f90: New test.
PR fortran/28005
* gfortran.dg/matmul_3.f90: New test.
From-SVN: r114802
-rw-r--r-- | gcc/fortran/ChangeLog | 40 | ||||
-rw-r--r-- | gcc/fortran/check.c | 51 | ||||
-rw-r--r-- | gcc/fortran/expr.c | 336 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.c | 2 | ||||
-rw-r--r-- | gcc/fortran/intrinsic.h | 1 | ||||
-rw-r--r-- | gcc/fortran/match.c | 1 | ||||
-rw-r--r-- | gcc/fortran/simplify.c | 13 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 8 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/array_initializer_1.f90 | 36 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/matmul_3.f90 | 36 | ||||
-rw-r--r-- | libgfortran/ChangeLog | 19 | ||||
-rw-r--r-- | libgfortran/generated/matmul_c10.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_c16.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_c4.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_c8.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_i16.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_i4.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_i8.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_r10.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_r16.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_r4.c | 39 | ||||
-rw-r--r-- | libgfortran/generated/matmul_r8.c | 39 | ||||
-rw-r--r-- | libgfortran/m4/matmul.m4 | 39 |
23 files changed, 851 insertions, 160 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 935adf5..d872fe7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,43 @@ +2006-06-20 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/25049 + PR fortran/25050 + * check.c (non_init_transformational): New function. + (find_substring_ref): New function to signal use of disallowed + transformational intrinsic in an initialization expression. + (gfc_check_all_any): Call previous if initialization expr. + (gfc_check_count): The same. + (gfc_check_cshift): The same. + (gfc_check_dot_product): The same. + (gfc_check_eoshift): The same. + (gfc_check_minloc_maxloc): The same. + (gfc_check_minval_maxval): The same. + (gfc_check_gfc_check_product_sum): The same. + (gfc_check_pack): The same. + (gfc_check_spread): The same. + (gfc_check_transpose): The same. + (gfc_check_unpack): The same. + + PR fortran/18769 + *intrinsic.c (add_functions): Add gfc_simplify_transfer. + *intrinsic.h : Add prototype for gfc_simplify_transfer. + *simplify.c (gfc_simplify_transfer) : New function to act as + placeholder for eventual implementation. Emit error for now. + + PR fortran/16206 + * expr.c (find_array_element): Eliminate condition on length of + offset. Add bounds checking. Rearrange exit. Return try and + put gfc_constructor result as an argument. + (find_array_section): New function. + (find_substring_ref): New function. + (simplify_const_ref): Add calls to previous. + (simplify_parameter_variable): Return on NULL expr. + (gfc_simplify_expr): Only call gfc_expand_constructor for full + arrays. + + PR fortran/20876 + * match.c (gfc_match_forall): Add missing locus to gfc_code. + 2006-06-18 Francois-Xavier Coudert <coudert@clipper.ens.fr> PR fortran/26801 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 15278f4..6ca5246 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -378,6 +378,18 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi) return ret; } +/* Error return for transformational intrinsics not allowed in + initalization expressions. */ + +static try +non_init_transformational (void) +{ + gfc_error ("transformational intrinsic '%s' at %L is not permitted " + "in an initialization expression", gfc_current_intrinsic, + gfc_current_intrinsic_where); + return FAILURE; +} + /***** Check functions *****/ /* Check subroutine suitable for intrinsics taking a real argument and @@ -439,6 +451,9 @@ gfc_check_all_any (gfc_expr * mask, gfc_expr * dim) if (dim_check (dim, 1, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -724,6 +739,9 @@ gfc_check_count (gfc_expr * mask, gfc_expr * dim) if (dim_check (dim, 1, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -747,6 +765,9 @@ gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim) if (dim_check (dim, 2, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -848,6 +869,9 @@ gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b) return FAILURE; } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -883,6 +907,9 @@ gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary, if (dim_check (dim, 1, 1) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -1545,6 +1572,9 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b) return FAILURE; } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -1605,6 +1635,9 @@ gfc_check_minloc_maxloc (gfc_actual_arglist * ap) return FAILURE; } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -1673,6 +1706,9 @@ gfc_check_minval_maxval (gfc_actual_arglist * ap) || array_check (ap->expr, 0) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return check_reduction (ap); } @@ -1684,6 +1720,9 @@ gfc_check_product_sum (gfc_actual_arglist * ap) || array_check (ap->expr, 0) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return check_reduction (ap); } @@ -1781,6 +1820,9 @@ gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector) /* TODO: More constraints here. */ } + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -2152,6 +2194,9 @@ gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies) if (scalar_check (ncopies, 2) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -2367,6 +2412,9 @@ gfc_check_transpose (gfc_expr * matrix) if (rank_check (matrix, 0, 2) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } @@ -2405,6 +2453,9 @@ gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field) if (same_type_check (vector, 0, field, 2) == FAILURE) return FAILURE; + if (gfc_init_expr) + return non_init_transformational (); + return SUCCESS; } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index a163151..4b03798 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -902,50 +902,70 @@ simplify_constructor (gfc_constructor * c, int type) /* Pull a single array element out of an array constructor. */ -static gfc_constructor * -find_array_element (gfc_constructor * cons, gfc_array_ref * ar) +static try +find_array_element (gfc_constructor * cons, gfc_array_ref * ar, + gfc_constructor ** rval) { unsigned long nelemen; int i; mpz_t delta; mpz_t offset; + gfc_expr *e; + try t; + + t = SUCCESS; + e = NULL; mpz_init_set_ui (offset, 0); mpz_init (delta); for (i = 0; i < ar->dimen; i++) { - if (ar->start[i]->expr_type != EXPR_CONSTANT) + e = gfc_copy_expr (ar->start[i]); + if (e->expr_type != EXPR_CONSTANT) { cons = NULL; - break; + goto depart; } - mpz_sub (delta, ar->start[i]->value.integer, + + /* Check the bounds. */ + if (ar->as->upper[i] + && (mpz_cmp (e->value.integer, + ar->as->upper[i]->value.integer) > 0 + || mpz_cmp (e->value.integer, + ar->as->lower[i]->value.integer) < 0)) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", i + 1, &ar->c_where[i]); + cons = NULL; + t = FAILURE; + goto depart; + } + + mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer); mpz_add (offset, offset, delta); } if (cons) { - if (mpz_fits_ulong_p (offset)) + for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) { - for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) + if (cons->iterator) { - if (cons->iterator) - { - cons = NULL; - break; - } - cons = cons->next; + cons = NULL; + goto depart; } + cons = cons->next; } - else - cons = NULL; } +depart: mpz_clear (delta); mpz_clear (offset); - - return cons; + if (e) + gfc_free_expr (e); + *rval = cons; + return t; } @@ -985,6 +1005,240 @@ remove_subobject_ref (gfc_expr * p, gfc_constructor * cons) } +/* Pull an array section out of an array constructor. */ + +static try +find_array_section (gfc_expr *expr, gfc_ref *ref) +{ + int idx; + int rank; + int d; + long unsigned one = 1; + mpz_t end[GFC_MAX_DIMENSIONS]; + mpz_t stride[GFC_MAX_DIMENSIONS]; + mpz_t delta[GFC_MAX_DIMENSIONS]; + mpz_t ctr[GFC_MAX_DIMENSIONS]; + mpz_t delta_mpz; + mpz_t tmp_mpz; + mpz_t nelts; + mpz_t ptr; + mpz_t stop; + mpz_t index; + gfc_constructor *cons; + gfc_constructor *base; + gfc_expr *begin; + gfc_expr *finish; + gfc_expr *step; + gfc_expr *upper; + gfc_expr *lower; + try t; + + t = SUCCESS; + + base = expr->value.constructor; + expr->value.constructor = NULL; + + rank = ref->u.ar.as->rank; + + if (expr->shape == NULL) + expr->shape = gfc_get_shape (rank); + + mpz_init_set_ui (delta_mpz, one); + mpz_init_set_ui (nelts, one); + mpz_init (tmp_mpz); + + /* Do the initialization now, so that we can cleanup without + keeping track of where we were. */ + for (d = 0; d < rank; d++) + { + mpz_init (delta[d]); + mpz_init (end[d]); + mpz_init (ctr[d]); + mpz_init (stride[d]); + } + + /* Build the counters to clock through the array reference. */ + for (d = 0; d < rank; d++) + { + /* Make this stretch of code easier on the eye! */ + begin = ref->u.ar.start[d]; + finish = ref->u.ar.end[d]; + step = ref->u.ar.stride[d]; + lower = ref->u.ar.as->lower[d]; + upper = ref->u.ar.as->upper[d]; + + if ((begin && begin->expr_type != EXPR_CONSTANT) + || (finish && finish->expr_type != EXPR_CONSTANT) + || (step && step->expr_type != EXPR_CONSTANT)) + { + t = FAILURE; + goto cleanup; + } + + /* Obtain the stride. */ + if (step) + mpz_set (stride[d], step->value.integer); + else + mpz_set_ui (stride[d], one); + + if (mpz_cmp_ui (stride[d], 0) == 0) + mpz_set_ui (stride[d], one); + + /* Obtain the start value for the index. */ + if (begin->value.integer) + mpz_set (ctr[d], begin->value.integer); + else + { + if (mpz_cmp_si (stride[d], 0) < 0) + mpz_set (ctr[d], upper->value.integer); + else + mpz_set (ctr[d], lower->value.integer); + } + + /* Obtain the end value for the index. */ + if (finish) + mpz_set (end[d], finish->value.integer); + else + { + if (mpz_cmp_si (stride[d], 0) < 0) + mpz_set (end[d], lower->value.integer); + else + mpz_set (end[d], upper->value.integer); + } + + /* Separate 'if' because elements sometimes arrive with + non-null end. */ + if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT) + mpz_set (end [d], begin->value.integer); + + /* Check the bounds. */ + if (mpz_cmp (ctr[d], upper->value.integer) > 0 + || mpz_cmp (end[d], upper->value.integer) > 0 + || mpz_cmp (ctr[d], lower->value.integer) < 0 + || mpz_cmp (end[d], lower->value.integer) < 0) + { + gfc_error ("index in dimension %d is out of bounds " + "at %L", d + 1, &ref->u.ar.c_where[d]); + t = FAILURE; + goto cleanup; + } + + /* Calculate the number of elements and the shape. */ + mpz_abs (tmp_mpz, stride[d]); + mpz_div (tmp_mpz, stride[d], tmp_mpz); + mpz_add (tmp_mpz, end[d], tmp_mpz); + mpz_sub (tmp_mpz, tmp_mpz, ctr[d]); + mpz_div (tmp_mpz, tmp_mpz, stride[d]); + mpz_mul (nelts, nelts, tmp_mpz); + + mpz_set (expr->shape[d], tmp_mpz); + + /* Calculate the 'stride' (=delta) for conversion of the + counter values into the index along the constructor. */ + mpz_set (delta[d], delta_mpz); + mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer); + mpz_add_ui (tmp_mpz, tmp_mpz, one); + mpz_mul (delta_mpz, delta_mpz, tmp_mpz); + } + + mpz_init (index); + mpz_init (ptr); + mpz_init (stop); + cons = base; + + /* Now clock through the array reference, calculating the index in + the source constructor and transferring the elements to the new + constructor. */ + for (idx = 0; idx < (int)mpz_get_si (nelts); idx++) + { + if (ref->u.ar.offset) + mpz_set (ptr, ref->u.ar.offset->value.integer); + else + mpz_init_set_ui (ptr, 0); + + mpz_set_ui (stop, one); + for (d = 0; d < rank; d++) + { + mpz_set (tmp_mpz, ctr[d]); + mpz_sub_ui (tmp_mpz, tmp_mpz, one); + mpz_mul (tmp_mpz, tmp_mpz, delta[d]); + mpz_add (ptr, ptr, tmp_mpz); + + mpz_mul (tmp_mpz, stride[d], stop); + mpz_add (ctr[d], ctr[d], tmp_mpz); + + mpz_set (tmp_mpz, end[d]); + if (mpz_cmp_ui (stride[d], 0) > 0 ? + mpz_cmp (ctr[d], tmp_mpz) > 0 : + mpz_cmp (ctr[d], tmp_mpz) < 0) + mpz_set (ctr[d], ref->u.ar.start[d]->value.integer); + else + mpz_set_ui (stop, 0); + } + + /* There must be a better way of dealing with negative strides + than resetting the index and the constructor pointer! */ + if (mpz_cmp (ptr, index) < 0) + { + mpz_set_ui (index, 0); + cons = base; + } + + while (mpz_cmp (ptr, index) > 0) + { + mpz_add_ui (index, index, one); + cons = cons->next; + } + + gfc_append_constructor (expr, gfc_copy_expr (cons->expr)); + } + + mpz_clear (ptr); + mpz_clear (index); + mpz_clear (stop); + +cleanup: + + mpz_clear (delta_mpz); + mpz_clear (tmp_mpz); + mpz_clear (nelts); + for (d = 0; d < rank; d++) + { + mpz_clear (delta[d]); + mpz_clear (end[d]); + mpz_clear (ctr[d]); + mpz_clear (stride[d]); + } + gfc_free_constructor (base); + return t; +} + +/* Pull a substring out of an expression. */ + +static try +find_substring_ref (gfc_expr *p, gfc_expr **newp) +{ + int end; + int start; + char *chr; + + if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT + || p->ref->u.ss.end->expr_type != EXPR_CONSTANT) + return FAILURE; + + *newp = gfc_copy_expr (p); + chr = p->value.character.string; + end = (int)mpz_get_ui (p->ref->u.ss.end->value.integer); + start = (int)mpz_get_ui (p->ref->u.ss.start->value.integer); + + (*newp)->value.character.length = end - start + 1; + strncpy ((*newp)->value.character.string, &chr[start - 1], + (*newp)->value.character.length); + return SUCCESS; +} + + + /* Simplify a subobject reference of a constructor. This occurs when parameter variable values are substituted. */ @@ -992,6 +1246,7 @@ static try simplify_const_ref (gfc_expr * p) { gfc_constructor *cons; + gfc_expr *newp; while (p->ref) { @@ -1001,24 +1256,40 @@ simplify_const_ref (gfc_expr * p) switch (p->ref->u.ar.type) { case AR_ELEMENT: - cons = find_array_element (p->value.constructor, &p->ref->u.ar); + if (find_array_element (p->value.constructor, + &p->ref->u.ar, + &cons) == FAILURE) + return FAILURE; + if (!cons) return SUCCESS; + remove_subobject_ref (p, cons); break; + case AR_SECTION: + if (find_array_section (p, p->ref) == FAILURE) + return FAILURE; + p->ref->u.ar.type = AR_FULL; + + /* FALLTHROUGH */ + case AR_FULL: - if (p->ref->next != NULL) + if (p->ref->next != NULL + && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) { - /* TODO: Simplify array subobject references. */ - return SUCCESS; + cons = p->value.constructor; + for (; cons; cons = cons->next) + { + cons->expr->ref = copy_ref (p->ref->next); + simplify_const_ref (cons->expr); + } } - gfc_free_ref_list (p->ref); - p->ref = NULL; + gfc_free_ref_list (p->ref); + p->ref = NULL; break; default: - /* TODO: Simplify array subsections. */ return SUCCESS; } @@ -1030,8 +1301,13 @@ simplify_const_ref (gfc_expr * p) break; case REF_SUBSTRING: - /* TODO: Constant substrings. */ - return SUCCESS; + if (find_substring_ref (p, &newp) == FAILURE) + return FAILURE; + + gfc_replace_expr (p, newp); + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; } } @@ -1062,6 +1338,7 @@ simplify_ref_chain (gfc_ref * ref, int type) if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE) return FAILURE; + } break; @@ -1088,6 +1365,9 @@ simplify_parameter_variable (gfc_expr * p, int type) try t; e = gfc_copy_expr (p->symtree->n.sym->value); + if (e == NULL) + return FAILURE; + /* Do not copy subobject refs for constant. */ if (e->expr_type != EXPR_CONSTANT && p->ref != NULL) e->ref = copy_ref (p->ref); @@ -1211,7 +1491,9 @@ gfc_simplify_expr (gfc_expr * p, int type) if (simplify_constructor (p->value.constructor, type) == FAILURE) return FAILURE; - if (p->expr_type == EXPR_ARRAY) + if (p->expr_type == EXPR_ARRAY + && p->ref && p->ref->type == REF_ARRAY + && p->ref->u.ar.type == AR_FULL) gfc_expand_constructor (p); if (simplify_const_ref (p) == FAILURE) diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 403bf08..46c25f6 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2139,7 +2139,7 @@ add_functions (void) make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95); add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95, - gfc_check_transfer, NULL, gfc_resolve_transfer, + gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer, src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED, sz, BT_INTEGER, di, OPTIONAL); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 880f418..4028f79 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -276,6 +276,7 @@ gfc_expr *gfc_simplify_sqrt (gfc_expr *); gfc_expr *gfc_simplify_tan (gfc_expr *); gfc_expr *gfc_simplify_tanh (gfc_expr *); gfc_expr *gfc_simplify_tiny (gfc_expr *); +gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_trim (gfc_expr *); gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index ab01ad6..448d927 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -3578,6 +3578,7 @@ gfc_match_forall (gfc_statement * st) c = gfc_get_code (); *c = new_st; + c->loc = gfc_current_locus; if (gfc_match_eos () != MATCH_YES) goto syntax; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index f8bf372..7bf79fc 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3715,6 +3715,19 @@ gfc_simplify_tiny (gfc_expr * e) gfc_expr * +gfc_simplify_transfer (gfc_expr * source, gfc_expr *mold, gfc_expr * size) +{ + + /* Reference mold and size to suppress warning. */ + if (gfc_init_expr && (mold || size)) + gfc_error ("TRANSFER intrinsic not implemented for initialization at %L", + &source->where); + + return NULL; +} + + +gfc_expr * gfc_simplify_trim (gfc_expr * e) { gfc_expr *result; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 96c8628..fb97bc7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2006-06-20 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/16206 + * gfortran.dg/array_initializer_1.f90: New test. + + PR fortran/28005 + * gfortran.dg/matmul_3.f90: New test. + 2006-06-19 Andrew Pinski <pinskia@gmail.com> PR middle-end/28075 diff --git a/gcc/testsuite/gfortran.dg/array_initializer_1.f90 b/gcc/testsuite/gfortran.dg/array_initializer_1.f90 new file mode 100644 index 0000000..a0d5761 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_initializer_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run }
+! Check the fix for PR16206, in which array sections would not work
+! in array initializers. Use of implied do loop variables for indices
+! and substrings, with and without implied do loops, were fixed at the
+! same time.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+! based on testcase from Harald Anlauf <anlauf@gmx.de>
+!
+ real, parameter :: x(4,4) = reshape((/(i, i = 1, 16)/), (/4,4/))
+ real, parameter :: y(4) = (/ x(1:2, 2), x(3:4, 4)/)
+ real, parameter :: z(2) = x(2:3, 3) + 1
+ real, parameter :: r(6) = (/(x(i:i +1, i), i = 1,3)/)
+ real, parameter :: s(12) = (/((x(i, i:j-1:-1), i = 3,4), j = 2,3)/)
+ real, parameter :: t(8) = (/(z, &
+ real (i)**3, y(i), i = 2, 3)/) ! { dg-warning "nonstandard" }
+
+ integer, parameter :: ii = 4
+
+ character(4), parameter :: chr(4) = (/"abcd", "efgh", "ijkl", "mnop"/)
+ character(4), parameter :: chrs = chr(ii)(2:3)//chr(2)(ii-3:ii-2)
+ character(4), parameter :: chrt(2) = (/chr(2:2)(2:3), chr(ii-1)(3:ii)/)
+ character(2), parameter :: chrx(2) = (/(chr(i)(i:i+1), i=2,3)/)
+
+ if (any (y .ne. (/5., 6., 15., 16./))) call abort ()
+ if (any (z .ne. (/11., 12./))) call abort ()
+ if (any (r .ne. (/1., 2., 6., 7., 11., 12./))) call abort ()
+ if (any (s .ne. (/11., 7., 3., 16., 12., 8., 4., &
+ 11., 7., 16., 12., 8. /))) call abort ()
+
+ if (any (t .ne. (/11., 12., 8., 6., 11., 12., 27., 15. /))) call abort ()
+
+ if (chrs .ne. "noef") call abort ()
+ if (any (chrt .ne. (/"fg", "kl"/))) call abort ()
+ if (any (chrx .ne. (/"fg", "kl"/))) call abort ()
+end
diff --git a/gcc/testsuite/gfortran.dg/matmul_3.f90 b/gcc/testsuite/gfortran.dg/matmul_3.f90 new file mode 100644 index 0000000..65290fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/matmul_3.f90 @@ -0,0 +1,36 @@ +! { dg-do run }
+! Check the fix for PR28005, in which the mechanism for dealing
+! with matmul (transpose (a), b) would cause wrong results for
+! matmul (a(i, 1:n), b(1:n, 1:n)).
+!
+! Based on the original testcase contributed by
+! Tobias Burnus <tobias.burnus@physik.fu-berlin.de>
+!
+ implicit none
+ integer, parameter :: nmax = 3
+ integer :: i, n = 2
+ integer, dimension(nmax,nmax) :: iB=0 , iC=1
+ integer, dimension(nmax,nmax) :: iX1=99, iX2=99, iChk
+ iChk = reshape((/30,66,102,36,81,126,42,96,150/),(/3,3/))
+
+! This would give 3, 3, 99
+ iB = reshape((/1 ,3 ,0 ,2 ,5 ,0 ,0 ,0 ,0 /),(/3,3/))
+ iX1(1:n,1) = matmul( iB(2,1:n),iC(1:n,1:n) )
+
+! This would give 4, 4, 99
+ ib(3,1) = 1
+ iX2(1:n,1) = matmul( iB(2,1:n),iC(1:n,1:n) )
+
+! Whereas, we should have 8, 8, 99
+ if (any (iX1(1:n,1) .ne. (/8, 8, 99/))) call abort ()
+ if (any (iX1 .ne. iX2)) call abort ()
+
+! Make sure that the fix does not break transpose temporaries.
+ iB = reshape((/(i, i = 1, 9)/),(/3,3/))
+ ic = transpose (iB)
+ iX1 = transpose (iB)
+ iX1 = matmul (iX1, iC)
+ iX2 = matmul (transpose (iB), iC)
+ if (any (iX1 .ne. iX2)) call abort ()
+ if (any (iX1 .ne. iChk)) call abort ()
+end
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 8517cae..8ab88b7 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,22 @@ +2006-06-20 Paul Thomas <pault@gcc.gnu.org> + + PR libfortran/28005 + * m4/matmul.m4: aystride = 1 does not uniquely detect the + presence of a temporary transpose; an array element in the + first dimension produces the same signature. Detect this + using the rank of a and add specific code. + * generated/matmul_r4.c: Regenerate. + * generated/matmul_r8.c: Regenerate. + * generated/matmul_r10.c: Regenerate. + * generated/matmul_r16.c: Regenerate. + * generated/matmul_c4.c: Regenerate. + * generated/matmul_c8.c: Regenerate. + * generated/matmul_c10.c: Regenerate. + * generated/matmul_c16.c: Regenerate. + * generated/matmul_i4.c: Regenerate. + * generated/matmul_i8.c: Regenerate. + * generated/matmul_i16.c: Regenerate. + 2006-06-18 John David Anglin <dave.anglin@nrc-cnrc.gc.ca> PR libgomp/27254 diff --git a/libgfortran/generated/matmul_c10.c b/libgfortran/generated/matmul_c10.c index 72c3a7d..7b67ddd 100644 --- a/libgfortran/generated/matmul_c10.c +++ b/libgfortran/generated/matmul_c10.c @@ -210,22 +210,39 @@ matmul_c10 (gfc_array_c10 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_COMPLEX_10 *restrict abase_x; - const GFC_COMPLEX_10 *restrict bbase_y; - GFC_COMPLEX_10 *restrict dest_y; - GFC_COMPLEX_10 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_10 *restrict abase_x; + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 *restrict dest_y; + GFC_COMPLEX_10 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_COMPLEX_10 *restrict bbase_y; + GFC_COMPLEX_10 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_COMPLEX_10) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_c16.c b/libgfortran/generated/matmul_c16.c index d87eea1..c17bcaa 100644 --- a/libgfortran/generated/matmul_c16.c +++ b/libgfortran/generated/matmul_c16.c @@ -210,22 +210,39 @@ matmul_c16 (gfc_array_c16 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_COMPLEX_16 *restrict abase_x; - const GFC_COMPLEX_16 *restrict bbase_y; - GFC_COMPLEX_16 *restrict dest_y; - GFC_COMPLEX_16 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_16 *restrict abase_x; + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 *restrict dest_y; + GFC_COMPLEX_16 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_COMPLEX_16 *restrict bbase_y; + GFC_COMPLEX_16 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_COMPLEX_16) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_c4.c b/libgfortran/generated/matmul_c4.c index 339c9c0..d85bd27 100644 --- a/libgfortran/generated/matmul_c4.c +++ b/libgfortran/generated/matmul_c4.c @@ -210,22 +210,39 @@ matmul_c4 (gfc_array_c4 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_COMPLEX_4 *restrict abase_x; - const GFC_COMPLEX_4 *restrict bbase_y; - GFC_COMPLEX_4 *restrict dest_y; - GFC_COMPLEX_4 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_4 *restrict abase_x; + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 *restrict dest_y; + GFC_COMPLEX_4 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_COMPLEX_4 *restrict bbase_y; + GFC_COMPLEX_4 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_COMPLEX_4) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_c8.c b/libgfortran/generated/matmul_c8.c index 13a9e37..be4ee6c 100644 --- a/libgfortran/generated/matmul_c8.c +++ b/libgfortran/generated/matmul_c8.c @@ -210,22 +210,39 @@ matmul_c8 (gfc_array_c8 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_COMPLEX_8 *restrict abase_x; - const GFC_COMPLEX_8 *restrict bbase_y; - GFC_COMPLEX_8 *restrict dest_y; - GFC_COMPLEX_8 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_COMPLEX_8 *restrict abase_x; + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 *restrict dest_y; + GFC_COMPLEX_8 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_COMPLEX_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_COMPLEX_8 *restrict bbase_y; + GFC_COMPLEX_8 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_COMPLEX_8) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_i16.c b/libgfortran/generated/matmul_i16.c index b6136ef..c4de78a 100644 --- a/libgfortran/generated/matmul_i16.c +++ b/libgfortran/generated/matmul_i16.c @@ -210,22 +210,39 @@ matmul_i16 (gfc_array_i16 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_INTEGER_16 *restrict abase_x; - const GFC_INTEGER_16 *restrict bbase_y; - GFC_INTEGER_16 *restrict dest_y; - GFC_INTEGER_16 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_16 *restrict abase_x; + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 *restrict dest_y; + GFC_INTEGER_16 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_INTEGER_16 *restrict bbase_y; + GFC_INTEGER_16 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_INTEGER_16) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_i4.c b/libgfortran/generated/matmul_i4.c index 4cffcf0..cd506a0 100644 --- a/libgfortran/generated/matmul_i4.c +++ b/libgfortran/generated/matmul_i4.c @@ -210,22 +210,39 @@ matmul_i4 (gfc_array_i4 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_INTEGER_4 *restrict abase_x; - const GFC_INTEGER_4 *restrict bbase_y; - GFC_INTEGER_4 *restrict dest_y; - GFC_INTEGER_4 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_4 *restrict abase_x; + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 *restrict dest_y; + GFC_INTEGER_4 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_INTEGER_4 *restrict bbase_y; + GFC_INTEGER_4 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_INTEGER_4) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_i8.c b/libgfortran/generated/matmul_i8.c index c4fb0c7..7bdfb6f 100644 --- a/libgfortran/generated/matmul_i8.c +++ b/libgfortran/generated/matmul_i8.c @@ -210,22 +210,39 @@ matmul_i8 (gfc_array_i8 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_INTEGER_8 *restrict abase_x; - const GFC_INTEGER_8 *restrict bbase_y; - GFC_INTEGER_8 *restrict dest_y; - GFC_INTEGER_8 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_INTEGER_8 *restrict abase_x; + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 *restrict dest_y; + GFC_INTEGER_8 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_INTEGER_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_INTEGER_8 *restrict bbase_y; + GFC_INTEGER_8 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_INTEGER_8) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_r10.c b/libgfortran/generated/matmul_r10.c index e90ac57..2bdaaf5 100644 --- a/libgfortran/generated/matmul_r10.c +++ b/libgfortran/generated/matmul_r10.c @@ -210,22 +210,39 @@ matmul_r10 (gfc_array_r10 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_REAL_10 *restrict abase_x; - const GFC_REAL_10 *restrict bbase_y; - GFC_REAL_10 *restrict dest_y; - GFC_REAL_10 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_10 *restrict abase_x; + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 *restrict dest_y; + GFC_REAL_10 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_10) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_REAL_10 *restrict bbase_y; + GFC_REAL_10 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_REAL_10) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_r16.c b/libgfortran/generated/matmul_r16.c index 3823fa6..f120e7f 100644 --- a/libgfortran/generated/matmul_r16.c +++ b/libgfortran/generated/matmul_r16.c @@ -210,22 +210,39 @@ matmul_r16 (gfc_array_r16 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_REAL_16 *restrict abase_x; - const GFC_REAL_16 *restrict bbase_y; - GFC_REAL_16 *restrict dest_y; - GFC_REAL_16 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_16 *restrict abase_x; + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 *restrict dest_y; + GFC_REAL_16 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_16) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_REAL_16 *restrict bbase_y; + GFC_REAL_16 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_REAL_16) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_r4.c b/libgfortran/generated/matmul_r4.c index 3757b65..0855133 100644 --- a/libgfortran/generated/matmul_r4.c +++ b/libgfortran/generated/matmul_r4.c @@ -210,22 +210,39 @@ matmul_r4 (gfc_array_r4 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_REAL_4 *restrict abase_x; - const GFC_REAL_4 *restrict bbase_y; - GFC_REAL_4 *restrict dest_y; - GFC_REAL_4 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_4 *restrict abase_x; + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 *restrict dest_y; + GFC_REAL_4 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_4) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_REAL_4 *restrict bbase_y; + GFC_REAL_4 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_REAL_4) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/generated/matmul_r8.c b/libgfortran/generated/matmul_r8.c index 2bd607c..ba177a8 100644 --- a/libgfortran/generated/matmul_r8.c +++ b/libgfortran/generated/matmul_r8.c @@ -210,22 +210,39 @@ matmul_r8 (gfc_array_r8 * const restrict retarray, } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const GFC_REAL_8 *restrict abase_x; - const GFC_REAL_8 *restrict bbase_y; - GFC_REAL_8 *restrict dest_y; - GFC_REAL_8 s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const GFC_REAL_8 *restrict abase_x; + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 *restrict dest_y; + GFC_REAL_8 s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (GFC_REAL_8) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const GFC_REAL_8 *restrict bbase_y; + GFC_REAL_8 s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (GFC_REAL_8) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } diff --git a/libgfortran/m4/matmul.m4 b/libgfortran/m4/matmul.m4 index f83837b..f55e2cf 100644 --- a/libgfortran/m4/matmul.m4 +++ b/libgfortran/m4/matmul.m4 @@ -212,22 +212,39 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl } else if (rxstride == 1 && aystride == 1 && bxstride == 1) { - const rtype_name *restrict abase_x; - const rtype_name *restrict bbase_y; - rtype_name *restrict dest_y; - rtype_name s; + if (GFC_DESCRIPTOR_RANK (a) != 1) + { + const rtype_name *restrict abase_x; + const rtype_name *restrict bbase_y; + rtype_name *restrict dest_y; + rtype_name s; - for (y = 0; y < ycount; y++) + for (y = 0; y < ycount; y++) + { + bbase_y = &bbase[y*bystride]; + dest_y = &dest[y*rystride]; + for (x = 0; x < xcount; x++) + { + abase_x = &abase[x*axstride]; + s = (rtype_name) 0; + for (n = 0; n < count; n++) + s += abase_x[n] * bbase_y[n]; + dest_y[x] = s; + } + } + } + else { - bbase_y = &bbase[y*bystride]; - dest_y = &dest[y*rystride]; - for (x = 0; x < xcount; x++) + const rtype_name *restrict bbase_y; + rtype_name s; + + for (y = 0; y < ycount; y++) { - abase_x = &abase[x*axstride]; + bbase_y = &bbase[y*bystride]; s = (rtype_name) 0; for (n = 0; n < count; n++) - s += abase_x[n] * bbase_y[n]; - dest_y[x] = s; + s += abase[n*axstride] * bbase_y[n]; + dest[y*rystride] = s; } } } |