WARNING: This is a draft patch! Not all things work, cf. test cases below. However, no regressions are to be expected. Cf. also PR 43931. 2010-04-27 Tobias Burnus WARNING: THE CHANGELOG IS INCOMPLETE! PR fortran/18918 * intrinsic.c (add_functions): Fix GFC_STD and add gfc_resolve_ calls for lcobound, ucobound, image_index and this_image. * intrinsic.h (gfc_resolve_lcobound, gfc_resolve_this_image, gfc_resolve_image_index, gfc_resolve_ucobound): New prototypes. * iresolve.c (gfc_resolve_lcobound, gfc_resolve_this_image, gfc_resolve_image_index, gfc_resolve_ucobound, resolve_bound): New functions. (gfc_resolve_lbound, gfc_resolve_ubound): Use resolve_bound. * simplify.c (gfc_simplify_lbound,gfc_simplify_this_image, gfc_simplify_ubound): Allow non-constant bounds. * trans-intrinsic.c (gfc_conv_intrinsic_bound): Use arg2. (conv_intrinsic_cobound): New function. (gfc_conv_intrinsic_function): Call it. (gfc_walk_intrinsic_function): Handle ucobound and lcobound. (gfc_add_intrinsic_ss_code): Update comment. -------------------------------------------------------------------------- ! TEST CASE (causes segfault "Invalid read of size 2" in ! gfc_conv_loop_setup (trans-array.c:3665)): ! integer, allocatable :: a(:)[:,:,:] print *, ucobound(a) end -------------------------------------------------------------------------- ! { dg-do run } ! { dg-options "-fcoarray=single" } ! program test implicit none integer :: A(3)[*] integer,allocatable :: B(:)[:] call one() call two() call three(3,A) allocate(B(3)[-4:*]) call four(B) contains subroutine one() integer, allocatable :: a(:)[:,:,:] allocate(a(1)[-4:9,8,4:*]) if (this_image(a,dim=1) /= -4_8) call abort() if (lcobound (a,dim=1) /= -4_8) call abort() if (ucobound (a,dim=1) /= 9_8) call abort() if (this_image(a,dim=2) /= 1_8) call abort() if (lcobound (a,dim=2) /= 1_8) call abort() if (ucobound (a,dim=2) /= 8_8) call abort() if (this_image(a,dim=3) /= 4_8) call abort() if (lcobound (a,dim=3) /= 4_8) call abort() if (ucobound (a,dim=3) /= 4_8) call abort() ! <<< FAILS end subroutine one subroutine two() integer, allocatable :: a(:)[:,:,:] allocate(a(1)[-4:9,8,4:*]) if (this_image(a,dim=1) /= -4) call abort() if (lcobound (a,dim=1) /= -4) call abort() if (ucobound (a,dim=1) /= 9) call abort() if (this_image(a,dim=2) /= 1) call abort() if (lcobound (a,dim=2) /= 1) call abort() if (ucobound (a,dim=2) /= 8) call abort() if (this_image(a,dim=3) /= 4) call abort() if (lcobound (a,dim=3) /= 4) call abort() if (ucobound (a,dim=3) /= 4) call abort() ! <<< FAILS end subroutine two subroutine three(n,A) integer :: n integer :: A(3)[n:*] print *, lcobound(A,dim=1),':=',n !! TEST if (this_image(A,dim=1) /= n) call abort() ! << FAILS if (lcobound (A,dim=1) /= n) call abort() ! << FAILS if (ucobound (A,dim=1) /= n) call abort() ! << FAILS end subroutine three subroutine four(A) ! << SEGFAULT (PR 43931) integer, allocatable :: A(:)[:] !FIXME: What's the proper bound? -4 or 1 if (this_image(A,dim=1) /= -4_8) call abort() if (lcobound (A,dim=1) /= -4_8) call abort() if (ucobound (A,dim=1) /= -4_8) call abort() ! << FAILS end subroutine four end program test -------------------------------------------------------------------------- intrinsic.c | 16 ++++---- intrinsic.h | 4 ++ iresolve.c | 81 +++++++++++++++++++++++++++------------- simplify.c | 43 +++------------------ trans-array.c | 2 + trans-intrinsic.c | 108 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 6 files changed, 180 insertions(+), 74 deletions(-) diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 494b816..34afabc 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1786,7 +1786,7 @@ add_functions (void) make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_image_index, gfc_simplify_image_index, NULL, + gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); /* The resolution function for INDEX is called gfc_resolve_index_func @@ -1925,12 +1925,12 @@ add_functions (void) make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95); add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_lcobound, gfc_simplify_lcobound, NULL, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound, ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); - make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F95); + make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008); add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, @@ -2540,7 +2540,7 @@ add_functions (void) make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, - gfc_check_this_image, gfc_simplify_this_image, NULL, + gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, @@ -2600,12 +2600,12 @@ add_functions (void) make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95); add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO, - BT_INTEGER, di, GFC_STD_F95, - gfc_check_ucobound, gfc_simplify_ucobound, NULL, + BT_INTEGER, di, GFC_STD_F2008, + gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound, ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); - make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F95); + make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008); /* g77 compatibility for UMASK. */ add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index de33a4f..72dcc9c 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -422,6 +422,7 @@ void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ierrno (gfc_expr *); @@ -441,6 +442,7 @@ void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_lcobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_len (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_len_trim (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lgamma (gfc_expr *, gfc_expr *); @@ -498,6 +500,7 @@ void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_system (gfc_expr *, gfc_expr *); void gfc_resolve_tan (gfc_expr *, gfc_expr *); void gfc_resolve_tanh (gfc_expr *, gfc_expr *); +void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_time (gfc_expr *); void gfc_resolve_time8 (gfc_expr *); void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); @@ -505,6 +508,7 @@ void gfc_resolve_transpose (gfc_expr *, gfc_expr *); void gfc_resolve_trim (gfc_expr *, gfc_expr *); void gfc_resolve_ttynam (gfc_expr *, gfc_expr *); void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ucobound (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_umask (gfc_expr *, gfc_expr *); void gfc_resolve_unlink (gfc_expr *, gfc_expr *); void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 0b75604..35bd77e 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -119,6 +119,24 @@ resolve_mask_arg (gfc_expr *mask) } } + +static void +resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + f->ts.type = BT_INTEGER; + if (kind) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = gfc_default_integer_kind; + + if (dim == NULL) + { + f->rank = 1; + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], array->rank); + } +} + /********************** Resolution functions **********************/ @@ -1248,21 +1266,17 @@ void gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { static char lbound[] = "__lbound"; + resolve_bound (f, array, dim, kind); + f->value.function.name = lbound; +} - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - - if (dim == NULL) - { - f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); - } - f->value.function.name = lbound; +void +gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + static char lcobound[] = "__lbound"; + resolve_bound (f, array, dim, kind); + f->value.function.name = lcobound; } @@ -2376,6 +2390,25 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x) void +gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED, + gfc_expr *sub ATTRIBUTE_UNUSED) +{ + static char this_image[] = "__image_index"; + f->ts.kind = gfc_default_integer_kind; + f->value.function.name = this_image; +} + + +void +gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim) +{ + static char this_image[] = "__this_image"; + resolve_bound (f, array, dim, NULL); + f->value.function.name = this_image; +} + + +void gfc_resolve_time (gfc_expr *f) { f->ts.type = BT_INTEGER; @@ -2511,21 +2544,17 @@ void gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { static char ubound[] = "__ubound"; + resolve_bound (f, array, dim, kind); + f->value.function.name = ubound; +} - f->ts.type = BT_INTEGER; - if (kind) - f->ts.kind = mpz_get_si (kind->value.integer); - else - f->ts.kind = gfc_default_integer_kind; - - if (dim == NULL) - { - f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); - } - f->value.function.name = ubound; +void +gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind) +{ + static char ucobound[] = "__ucobound"; + resolve_bound (f, array, dim, kind); + f->value.function.name = ucobound; } diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index a40cec1..ad9d36c 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -3057,16 +3057,7 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_expr * gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - gfc_expr *e; - /* return simplify_cobound (array, dim, kind, 0);*/ - - e = simplify_cobound (array, dim, kind, 0); - if (e != NULL) - return e; - - gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant " - "cobounds at %L", &array->where); - return &gfc_bad_expr; + return simplify_cobound (array, dim, kind, 0); } gfc_expr * @@ -5478,7 +5469,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) as = ref->u.ar.as; if (as->type == AS_DEFERRED) - goto not_implemented; /* return NULL;*/ + return NULL; if (dim == NULL) { @@ -5497,8 +5488,7 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) for (j = 0; j < d; j++) gfc_free_expr (bounds[j]); - if (bounds[d] == NULL) - goto not_implemented; + return bounds[d]; } } @@ -5523,10 +5513,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) } else { - gfc_expr *e; /* A DIM argument is specified. */ if (dim->expr_type != EXPR_CONSTANT) - goto not_implemented; /*return NULL;*/ + return NULL; d = mpz_get_si (dim->value.integer); @@ -5536,18 +5525,9 @@ gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim) return &gfc_bad_expr; } - /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/ - e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true); - if (e != NULL) - return e; - else - goto not_implemented; + return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, + true); } - -not_implemented: - gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant " - "cobounds at %L", &coarray->where); - return &gfc_bad_expr; } @@ -5560,16 +5540,7 @@ gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) gfc_expr * gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) { - gfc_expr *e; - /* return simplify_cobound (array, dim, kind, 1);*/ - - e = simplify_cobound (array, dim, kind, 1); - if (e != NULL) - return e; - - gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant " - "cobounds at %L", &array->where); - return &gfc_bad_expr; + return simplify_cobound (array, dim, kind, 1); } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e20406c..bb722a4 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3121,6 +3121,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) { case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + case GFC_ISYM_LCOBOUND: + case GFC_ISYM_UCOBOUND: loop->dimen = ss->data.info.dimen; default: diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 1ffe284..135ac54 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -820,6 +820,7 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) se->expr = fold_convert (type, res); } + /* Evaluate a single upper or lower bound. */ /* TODO: bound intrinsic generates way too much unnecessary code. */ @@ -856,9 +857,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) else { /* use the passed argument. */ - gcc_assert (arg->next->expr); + gcc_assert (arg2->expr); gfc_init_se (&argse, NULL); - gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type); + gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); gfc_add_block_to_block (&se->pre, &argse.pre); bound = argse.expr; /* Convert from one based to zero based. */ @@ -991,6 +992,91 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) static void +conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *arg; + gfc_actual_arglist *arg2; + gfc_se argse; + gfc_ss *ss; + tree bound, resbound, desc; + tree type; + gfc_array_spec * as; + + gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND + || expr->value.function.isym->id == GFC_ISYM_UCOBOUND + || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE); + + arg = expr->value.function.actual; + arg2 = arg->next; + + if (se->ss) + { + /* Create an implicit second parameter from the loop variable. */ + gcc_assert (!arg2->expr); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->expr == expr); + gfc_advance_se_ss_chain (se); + bound = se->loop->loopvar[0]; + bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, + se->loop->from[0]); + } + else + { + /* use the passed argument. */ + gcc_assert (arg2->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + bound = argse.expr; + /* Substract 1 to get to zero based and add dimensions */ + switch (arg->expr->rank) + { + case 0: + bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, + gfc_index_one_node); + case 1: + break; + default: + bound = fold_build2 (PLUS_EXPR, gfc_array_index_type, bound, + gfc_rank_cst[arg->expr->rank - 1]); + } + } + + /* TODO: don't re-evaluate the descriptor on each iteration. */ + /* Get a descriptor for the first parameter. */ + ss = gfc_walk_expr (arg->expr); + gcc_assert (ss != gfc_ss_terminator); + gfc_init_se (&argse, NULL); + gfc_conv_expr_descriptor (&argse, arg->expr, ss); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + desc = argse.expr; + + as = gfc_get_full_arrayspec_from_expr (arg->expr); + gcc_assert (as); + + if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) + resbound = gfc_conv_descriptor_ubound_get (desc, bound); + else + resbound = gfc_conv_descriptor_lbound_get (desc, bound); + + /* Todo: Add codimension checking; arg->expr should have the + required corank information as init expression. */ + + se->expr = resbound; /*fold_build3 (COND_EXPR, gfc_array_index_type, cond, + resbound, gfc_index_zero_node);*/ + + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, se->expr); + +/* gfc_fatal_error ("Not yet implemented: %s for coarray with non-constant " + "cobounds at %L", expr->value.function.isym->name, + &expr->where); */ +} + + +static void gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { tree arg; @@ -5339,6 +5425,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bound (se, expr, 0); break; + case GFC_ISYM_LCOBOUND: + conv_intrinsic_cobound (se, expr); + break; + case GFC_ISYM_TRANSPOSE: if (se->ss && se->ss->useflags) { @@ -5459,6 +5549,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR); break; + case GFC_ISYM_THIS_IMAGE: + conv_intrinsic_cobound (se, expr); + break; + case GFC_ISYM_TRANSFER: if (se->ss && se->ss->useflags) { @@ -5478,6 +5572,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bound (se, expr, 1); break; + case GFC_ISYM_UCOBOUND: + conv_intrinsic_cobound (se, expr); + break; + case GFC_ISYM_XOR: gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); break; @@ -5562,8 +5660,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) } -/* UBOUND and LBOUND intrinsics with one parameter are expanded into code - inside the scalarization loop. */ +/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter + are expanded into code inside the scalarization loop. */ static gfc_ss * gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) @@ -5664,7 +5762,9 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, switch (isym->id) { case GFC_ISYM_LBOUND: + case GFC_ISYM_LCOBOUND: case GFC_ISYM_UBOUND: + case GFC_ISYM_UCOBOUND: return gfc_walk_intrinsic_bound (ss, expr); case GFC_ISYM_TRANSFER: