WARNING: This is a draft patch! Not all things work, but also no regressions are to be expected. 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. A) THIS_IMAGE/UCOBOUND/LCOBOUND *without* DIM= do not work -------------------------------------------------------------------------- ! 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 B) THE FOLLOWING WORKS FOR ALLOCATABLE COARRAYS, BUT IT FAILS FOR OTHER COARRAYS (scalarizer issues) -------------------------------------------------------------------------- ! { 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) call five() contains subroutine one() integer, allocatable :: a(:)[:,:,:] integer(8) :: mm mm = 1 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) ! integer, allocatable :: A(:)[:] ! 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() ! end subroutine four ! The following fails: subroutine five() integer, save :: foo[5:7,4:*] integer :: i i = 1 print *, this_image(a,dim=i), 5 ! <<< FAILS print *, lbound(a,dim=i),5 ! <<< FAILS print *, ubound(a,dim=i),7 ! <<< FAILS i = 2 print *, this_image(a,dim=i),4 ! <<< FAILS print *, lbound(a,dim=i),4 ! <<< FAILS print *, ubound(a,dim=i),4 ! <<< FAILS end subroutine five end program test -------------------------------------------------------------------------- intrinsic.c | 16 ++--- intrinsic.h | 4 + iresolve.c | 81 +++++++++++++++++++---------- simplify.c | 43 ++------------- trans-array.c | 35 +++++++++++- trans-intrinsic.c | 150 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- trans-types.c | 11 +++ trans.h | 4 - 8 files changed, 265 insertions(+), 79 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 1c69f20..349cc82 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..b096410 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3121,7 +3121,10 @@ 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; + loop->codimen = ss->data.info.codimen; default: break; @@ -3572,7 +3575,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) mpz_t i; mpz_init (i); - for (n = 0; n < loop->dimen; n++) + for (n = 0; n < loop->dimen + loop->codimen; n++) { loopspec[n] = NULL; dynamic[n] = false; @@ -5319,7 +5322,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) limits will be the limits of the section. A function may decide to repack the array to speed up access, but we're not bothered about that here. */ - int dim, ndim; + int dim, ndim, codim; tree parm; tree parmtype; tree stride; @@ -5331,6 +5334,9 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (expr->ts.type == BT_CHARACTER) se->string_length = gfc_get_expr_charlen (expr); + codim = (info->ref && info->ref->u.ar.type == AR_FULL) + ? info->ref->u.ar.as->corank : 0; + desc = info->descriptor; gcc_assert (secss && secss != gfc_ss_terminator); if (se->direct_byref) @@ -5343,7 +5349,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { /* Otherwise make a new one. */ parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); @@ -5468,6 +5474,18 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) dim++; } + for (n = ndim; n < ndim + codim; n++) + { + from = loop.from[dim]; + to = loop.to[dim]; + gfc_conv_descriptor_lbound_set (&loop.pre, parm, + gfc_rank_cst[dim], from); + if (n < ndim + codim - 1) + gfc_conv_descriptor_ubound_set (&loop.pre, parm, + gfc_rank_cst[dim], to); + dim++; + } + if (se->data_not_needed) gfc_conv_descriptor_data_set (&loop.pre, parm, gfc_index_zero_node); @@ -6470,11 +6488,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) newss->expr = expr; newss->next = ss; newss->data.info.dimen = ar->as->rank; + newss->data.info.codimen = ar->as->corank; newss->data.info.ref = ref; /* Make sure array is the same as array(:,:), this way we don't need to special case all the time. */ ar->dimen = ar->as->rank; + ar->codimen = ar->as->corank; for (n = 0; n < ar->dimen; n++) { newss->data.info.dim[n] = n; @@ -6484,6 +6504,15 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) gcc_assert (ar->end[n] == NULL); gcc_assert (ar->stride[n] == NULL); } + for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) + { + newss->data.info.dim[n] = n; + ar->dimen_type[n] = DIMEN_RANGE; + + gcc_assert (ar->start[n] == NULL); + if (n < ar->dimen + ar->codimen - 1) + gcc_assert (ar->end[n] == NULL); + } ss = newss; break; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 1ffe284..9cb3a69 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,133 @@ 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, resbound2, desc, cond; + tree type; + gfc_array_spec * as; + gfc_ref *ref; + int corank; + + 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; + + gcc_assert (arg->expr->expr_type == EXPR_VARIABLE); + + corank = arg->expr->symtree->n.sym->as + ? arg->expr->symtree->n.sym->as->corank : 0; + for (ref = arg->expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + corank = ref->u.ar.as->corank; + + 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]); +/* FIXME:*/ + cond = boolean_false_node; + } + 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]); + } + if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) + cond = fold_build2 (EQ_EXPR, boolean_type_node, bound, + build_int_cst (TREE_TYPE (bound), + arg->expr->rank + corank - 1)); + else + cond = boolean_false_node; + } + + as = gfc_get_full_arrayspec_from_expr (arg->expr); + gcc_assert (as); + + ss = gfc_walk_expr (arg->expr); + gcc_assert (ss != gfc_ss_terminator); + gfc_init_se (&argse, NULL); + + /* TODO: don't re-evaluate the descriptor on each iteration. */ + /* Get a descriptor for the first parameter. */ +/* if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) + {*/ + 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; + resbound = gfc_conv_descriptor_lbound_get (desc, bound); +/* } + else + { + gfc_ss_info *info; + gfc_ss *secss; + +*/ /* Find the SS for the array section. */ +/* secss = ss; + while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION) + secss = secss->next; + + gcc_assert (secss != gfc_ss_terminator); + info = &secss->data.info; + +*/ /* Get the descriptor for the array. */ +/* gfc_conv_ss_descriptor (&se->pre, secss, 0); + + desc = info->descriptor; + resbound = info->start[1]; + } +*/ + if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND) + { + resbound2 = gfc_conv_descriptor_ubound_get (desc, bound); + se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, + resbound, resbound2); + } + else + se->expr = resbound; + + /* Todo: Add codimension checking; arg->expr should have the + required corank information as init expression. */ + + 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 +5467,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 +5591,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 +5614,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 +5702,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 +5804,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: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 31a250d..f287ee2 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1220,6 +1220,17 @@ gfc_build_array_type (tree type, gfc_array_spec * as, ubound[n] = gfc_conv_array_bound (as->upper[n]); } + for (n = as->rank; n < as->rank + as->corank; n++) + { + if (as->lower[n] == NULL) + lbound[n] = gfc_index_one_node; + else + lbound[n] = gfc_conv_array_bound (as->lower[n]); + + if (n < as->rank + as->corank - 1) + ubound[n] = gfc_conv_array_bound (as->upper[n]); + } + if (as->type == AS_ASSUMED_SHAPE) akind = GFC_ARRAY_ASSUMED_SHAPE; return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 8e2b688..b9ca63b 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -92,7 +92,7 @@ gfc_se; typedef struct gfc_ss_info { - int dimen; + int dimen, codimen; /* The ref that holds information on this section. */ gfc_ref *ref; /* The descriptor of this array. */ @@ -219,7 +219,7 @@ typedef struct gfc_loopinfo stmtblock_t pre; stmtblock_t post; - int dimen; + int dimen, codimen; /* All the SS involved with this loop. */ gfc_ss *ss;