From: Thomas Koenig Date: Mon, 7 Jan 2019 19:30:28 +0000 (+0000) Subject: re PR fortran/45424 ([F08] Add IS_CONTIGUOUS intrinsic) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=419af57c134f3b068530ea51179c220e52623067;p=gcc.git re PR fortran/45424 ([F08] Add IS_CONTIGUOUS intrinsic) 2019-01-07 Thomas Koenig Harald Anlauf Tobias Burnus PR fortran/45424 * check.c (gfc_check_is_contiguous): New function. * expr.c (gfc_is_not_contiguous): New function. * gfortran.h (gfc_isym_id): Add GFC_ISYM_IS_CONTIGUOUS. Add prototype for gfc_is_not_contiguous. * intrinsic.c (do_ts29113_check): Add GFC_ISYM_IS_CONTIGUOUS. (add_function): Add is_contiguous. * intrinsic.h: Add prototypes for gfc_check_is_contiguous, gfc_simplify_is_contiguous and gfc_resolve_is_contiguous. * intrinsic.texi: Add IS_CONTIGUOUS. * iresolve.c (gfc_resolve_is_contiguous): New function. * simplify.c (gfc_simplify_is_contiguous): New function. * trans-decl.c (gfor_fncecl_is_contiguous0): New variable. (gfc_build_intrinsic_function_decl): Add it. * trans-intrinsic.c (gfc_conv_intrinsic_is_contiguous): New function. (gfc_conv_intrinsic_function): Handle GFC_ISYM_IS_CONTIGUOUS. 2019-01-07 Thomas Koenig Harald Anlauf Tobias Burnus PR fortran/45424 * Makefile.am: Add intrinsics/is_contiguous.c. * Makefile.in: Regenerated. * gfortran.map: Add _gfortran_is_contiguous0. * intrinsics/is_contiguous.c: New file. * libgfortran.h: Add prototype for is_contiguous0. 2019-01-07 Thomas Koenig Harald Anlauf Tobias Burnus * gfortran.dg/is_contiguous_1.f90: New test. * gfortran.dg/is_contiguous_2.f90: New test. * gfortran.dg/is_contiguous_3.f90: New test. Co-Authored-By: Harald Anlauf Co-Authored-By: Tobias Burnus From-SVN: r267657 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cf869f8785a..ba95a26e6ae 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2019-01-07 Thomas Koenig + Harald Anlauf + Tobias Burnus + + PR fortran/45424 + * check.c (gfc_check_is_contiguous): New function. + * expr.c (gfc_is_not_contiguous): New function. + * gfortran.h (gfc_isym_id): Add GFC_ISYM_IS_CONTIGUOUS. + Add prototype for gfc_is_not_contiguous. + * intrinsic.c (do_ts29113_check): Add GFC_ISYM_IS_CONTIGUOUS. + (add_function): Add is_contiguous. + * intrinsic.h: Add prototypes for gfc_check_is_contiguous, + gfc_simplify_is_contiguous and gfc_resolve_is_contiguous. + * intrinsic.texi: Add IS_CONTIGUOUS. + * iresolve.c (gfc_resolve_is_contiguous): New function. + * simplify.c (gfc_simplify_is_contiguous): New function. + * trans-decl.c (gfor_fncecl_is_contiguous0): New variable. + (gfc_build_intrinsic_function_decl): Add it. + * trans-intrinsic.c (gfc_conv_intrinsic_is_contiguous): New + function. + (gfc_conv_intrinsic_function): Handle GFC_ISYM_IS_CONTIGUOUS. + 2019-01-06 Thomas Koenig PR fortran/88658 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 10f4f254a28..c60de6b5e4d 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -6499,6 +6499,17 @@ gfc_check_ttynam_sub (gfc_expr *unit, gfc_expr *name) } +bool +gfc_check_is_contiguous (gfc_expr *array) +{ + if (!array_check (array, 0)) + return false; + + return true; +} + + + bool gfc_check_isatty (gfc_expr *unit) { diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 7d1c65d5419..cd8d4dd26eb 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -5695,6 +5695,75 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element) return true; } +/* Return true if the expression is guaranteed to be non-contiguous, + false if we cannot prove anything. It is probably best to call + this after gfc_is_simply_contiguous. If neither of them returns + true, we cannot say (at compile-time). */ + +bool +gfc_is_not_contiguous (gfc_expr *array) +{ + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref; + bool previous_incomplete; + + for (ref = array->ref; ref; ref = ref->next) + { + /* Array-ref shall be last ref. */ + + if (ar) + return true; + + if (ref->type == REF_ARRAY) + ar = &ref->u.ar; + } + + if (ar == NULL || ar->type != AR_SECTION) + return false; + + previous_incomplete = false; + + /* Check if we can prove that the array is not contiguous. */ + + for (i = 0; i < ar->dimen; i++) + { + mpz_t arr_size, ref_size; + + if (gfc_ref_dimen_size (ar, i, &ref_size, NULL)) + { + if (gfc_dep_difference (ar->as->lower[i], ar->as->upper[i], &arr_size)) + { + /* a(2:4,2:) is known to be non-contiguous, but + a(2:4,i:i) can be contiguous. */ + if (previous_incomplete && mpz_cmp_si (ref_size, 1) != 0) + { + mpz_clear (arr_size); + mpz_clear (ref_size); + return true; + } + else if (mpz_cmp (arr_size, ref_size) != 0) + previous_incomplete = true; + + mpz_clear (arr_size); + } + + /* Check for a(::2), i.e. where the stride is not unity. + This is only done if there is more than one element in + the reference along this dimension. */ + + if (mpz_cmp_ui (ref_size, 1) > 0 && ar->type == AR_SECTION + && ar->dimen_type[i] == DIMEN_RANGE + && ar->stride[i] && ar->stride[i]->expr_type == EXPR_CONSTANT + && mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0) + return true; + + mpz_clear (ref_size); + } + } + /* We didn't find anything definitive. */ + return false; +} /* Build call to an intrinsic procedure. The number of arguments has to be passed (rather than ending the list with a NULL value) because we may diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 0b281105fb4..e7a9b6f5674 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -487,6 +487,7 @@ enum gfc_isym_id GFC_ISYM_IPARITY, GFC_ISYM_IRAND, GFC_ISYM_ISATTY, + GFC_ISYM_IS_CONTIGUOUS, GFC_ISYM_IS_IOSTAT_END, GFC_ISYM_IS_IOSTAT_EOR, GFC_ISYM_ISNAN, @@ -3205,6 +3206,7 @@ bool gfc_extract_hwi (gfc_expr *, HOST_WIDE_INT *, int = 0); bool is_subref_array (gfc_expr *); bool gfc_is_simply_contiguous (gfc_expr *, bool, bool); +bool gfc_is_not_contiguous (gfc_expr *); bool gfc_check_init_expr (gfc_expr *); gfc_expr *gfc_build_conversion (gfc_expr *); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 2cb70845f99..8d80869b9bc 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -211,6 +211,7 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) && specific->id != GFC_ISYM_SIZE && specific->id != GFC_ISYM_SIZEOF && specific->id != GFC_ISYM_UBOUND + && specific->id != GFC_ISYM_IS_CONTIGUOUS && specific->id != GFC_ISYM_C_LOC) { gfc_error ("Assumed-type argument at %L is not permitted as actual" @@ -2235,6 +2236,14 @@ add_functions (void) make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU); + add_sym_1 ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2008, + gfc_check_is_contiguous, gfc_simplify_is_contiguous, + gfc_resolve_is_contiguous, + ar, BT_REAL, dr, REQUIRED); + + make_generic ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, GFC_STD_F2008); + add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_i, gfc_simplify_is_iostat_end, NULL, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 027f16b556d..0c60dab8390 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -99,6 +99,7 @@ bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_int (gfc_expr *, gfc_expr *); bool gfc_check_intconv (gfc_expr *); bool gfc_check_irand (gfc_expr *); +bool gfc_check_is_contiguous (gfc_expr *); bool gfc_check_isatty (gfc_expr *); bool gfc_check_isnan (gfc_expr *); bool gfc_check_ishft (gfc_expr *, gfc_expr *); @@ -327,6 +328,7 @@ gfc_expr *gfc_simplify_ifix (gfc_expr *); gfc_expr *gfc_simplify_idint (gfc_expr *); gfc_expr *gfc_simplify_ior (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_iparity (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_is_contiguous (gfc_expr *); gfc_expr *gfc_simplify_is_iostat_end (gfc_expr *); gfc_expr *gfc_simplify_is_iostat_eor (gfc_expr *); gfc_expr *gfc_simplify_isnan (gfc_expr *); @@ -531,6 +533,7 @@ void gfc_resolve_long (gfc_expr *, gfc_expr *); void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_iparity (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_isatty (gfc_expr *, gfc_expr *); +void gfc_resolve_is_contiguous (gfc_expr *, gfc_expr *); void gfc_resolve_rank (gfc_expr *, gfc_expr *); void gfc_resolve_rshift (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lshift (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index ae24dc61f07..e47ee1ecc4f 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -195,6 +195,7 @@ Some basic guidelines for editing this document: * @code{IOR}: IOR, Bitwise logical or * @code{IPARITY}: IPARITY, Bitwise XOR of array elements * @code{IRAND}: IRAND, Integer pseudo-random number +* @code{IS_CONTIGUOUS}: IS_CONTIGUOUS, Test whether an array is contiguous * @code{IS_IOSTAT_END}: IS_IOSTAT_END, Test for end-of-file value * @code{IS_IOSTAT_EOR}: IS_IOSTAT_EOR, Test for end-of-record value * @code{ISATTY}: ISATTY, Whether a unit is a terminal device @@ -8438,6 +8439,55 @@ end program test_irand +@node IS_CONTIGUOUS +@section @code{IS_CONTIGUOUS} --- Test whether an array is contiguous +@fnindex IS_IOSTAT_EOR +@cindex array, contiguity + +@table @asis +@item @emph{Description}: +@code{IS_CONTIGUOUS} tests whether an array is contiguous. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = IS_CONTIGUOUS(ARRAY)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{ARRAY} @tab Shall be an array of any type. +@end multitable + +@item @emph{Return value}: +Returns a @code{LOGICAL} of the default kind, which @code{.TRUE.} if +@var{ARRAY} is contiguous and false otherwise. + +@item @emph{Example}: +@smallexample +program test + integer :: a(10) + a = [1,2,3,4,5,6,7,8,9,10] + call sub (a) ! every element, is contiguous + call sub (a(::2)) ! every other element, is noncontiguous +contains + subroutine sub (x) + integer :: x(:) + if (is_contiguous (x)) then + write (*,*) 'X is contiguous' + else + write (*,*) 'X is not contiguous' + end if + end subroutine sub +end program test +@end smallexample +@end table + + + @node IS_IOSTAT_END @section @code{IS_IOSTAT_END} --- Test for end-of-file value @fnindex IS_IOSTAT_END @@ -8527,7 +8577,6 @@ END PROGRAM @end table - @node ISATTY @section @code{ISATTY} --- Whether a unit is a terminal device. @fnindex ISATTY diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index d132f56eed3..135e6bc6920 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1451,6 +1451,15 @@ gfc_resolve_isatty (gfc_expr *f, gfc_expr *u) } +void +gfc_resolve_is_contiguous (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED) +{ + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind; + f->value.function.name = gfc_get_string ("__is_contiguous"); +} + + void gfc_resolve_ishft (gfc_expr *f, gfc_expr *i, gfc_expr *shift) { diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index fdaf3cb4740..90477e5dadc 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -6289,6 +6289,18 @@ do_xor (gfc_expr *result, gfc_expr *e) } +gfc_expr * +gfc_simplify_is_contiguous (gfc_expr *array) +{ + if (gfc_is_simply_contiguous (array, false, true)) + return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1); + + if (gfc_is_not_contiguous (array)) + return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0); + + return NULL; +} + gfc_expr * gfc_simplify_parity (gfc_expr *e, gfc_expr *dim) diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index a51f6a6246a..c92d8913334 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -213,6 +213,7 @@ tree gfor_fndecl_size1; tree gfor_fndecl_iargc; tree gfor_fndecl_kill; tree gfor_fndecl_kill_sub; +tree gfor_fndecl_is_contiguous0; /* Intrinsic functions implemented in Fortran. */ @@ -3498,6 +3499,12 @@ gfc_build_intrinsic_function_decls (void) gfor_fndecl_kill = gfc_build_library_function_decl ( get_identifier (PREFIX ("kill")), gfc_int4_type_node, 2, gfc_int4_type_node, gfc_int4_type_node); + + gfor_fndecl_is_contiguous0 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("is_contiguous0")), ".R", + gfc_int4_type_node, 1, pvoid_type_node); + DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1; + TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1; } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 96a749e1343..b997ae53fc2 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2828,6 +2828,79 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) } +static void +gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr) +{ + gfc_expr *arg; + gfc_ss *ss; + gfc_se argse; + tree desc, tmp, stride, extent, cond; + int i; + tree fncall0; + gfc_array_spec *as; + + arg = expr->value.function.actual->expr; + + if (arg->ts.type == BT_CLASS) + gfc_add_class_array_ref (arg); + + ss = gfc_walk_expr (arg); + gcc_assert (ss != gfc_ss_terminator); + gfc_init_se (&argse, NULL); + argse.data_not_needed = 1; + gfc_conv_expr_descriptor (&argse, arg); + + as = gfc_get_full_arrayspec_from_expr (arg); + + /* Create: stride[0] == 1 && stride[1] == extend[0]*stride[0] && ... + Note in addition that zero-sized arrays don't count as contiguous. */ + + if (as && as->type == AS_ASSUMED_RANK) + { + /* Build the call to is_contiguous0. */ + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, arg); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = gfc_evaluate_now (argse.expr, &se->pre); + fncall0 = build_call_expr_loc (input_location, + gfor_fndecl_is_contiguous0, 1, desc); + se->expr = fncall0; + se->expr = convert (logical_type_node, se->expr); + } + else + { + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + desc = gfc_evaluate_now (argse.expr, &se->pre); + + stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]); + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + stride, build_int_cst (TREE_TYPE (stride), 1)); + + for (i = 0; i < expr->value.function.actual->expr->rank - 1; i++) + { + tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); + extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); + extent = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, extent, tmp); + extent = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, extent, + gfc_index_one_node); + tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), + tmp, extent); + stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]); + tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + stride, tmp); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, tmp); + } + se->expr = convert (gfc_typenode_for_spec (&expr->ts), cond); + } +} + + /* Evaluate a single upper or lower bound. */ /* TODO: bound intrinsic generates way too much unnecessary code. */ @@ -9731,6 +9804,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_has_intvalue (se, expr, LIBERROR_EOR); break; + case GFC_ISYM_IS_CONTIGUOUS: + gfc_conv_intrinsic_is_contiguous (se, expr); + break; + case GFC_ISYM_ISNAN: gfc_conv_intrinsic_isnan (se, expr); break; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 409c6aba03b..e42160b5962 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -907,6 +907,7 @@ extern GTY(()) tree gfor_fndecl_size1; extern GTY(()) tree gfor_fndecl_iargc; extern GTY(()) tree gfor_fndecl_kill; extern GTY(()) tree gfor_fndecl_kill_sub; +extern GTY(()) tree gfor_fndecl_is_contiguous0; /* Implemented in Fortran. */ extern GTY(()) tree gfor_fndecl_sc_kind; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c79593d7f0e..f512ed1ac11 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2019-01-07 Thomas Koenig + Harald Anlauf + Tobias Burnus + + * gfortran.dg/is_contiguous_1.f90: New test. + * gfortran.dg/is_contiguous_2.f90: New test. + * gfortran.dg/is_contiguous_3.f90: New test. + 2019-01-07 Marek Polacek PR c++/88741 - wrong error with initializer-string. diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_1.f90 b/gcc/testsuite/gfortran.dg/is_contiguous_1.f90 new file mode 100644 index 00000000000..ee592f27f6d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/is_contiguous_1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/45424 +! PR fortran/48820 +! +! Run-time checks for IS_CONTIGUOUS + +implicit none +integer, pointer :: a(:), b(:,:) +integer :: i, j, k, s + +allocate(a(5), b(10,10)) + +s = 1 +if (.true. .neqv. is_contiguous (a(::s))) stop 1 +s = 2 +if (.false. .neqv. is_contiguous (a(::s))) stop 2 +i=5; j=7 +if (.true. .neqv. is_contiguous (b(1:i*2,1:j))) stop 3 +if (.false. .neqv. is_contiguous (b(1:i,1:j))) stop 4 +i=5; j=5; s=1 +if (.false. .neqv. is_contiguous (b(i:5:s,i:j*2))) stop 5 + +! The following test zero-sized arrays. For the standard, they +! are regarded as noncontiguous. However, gfortran in line with +! other compilers only checks for the strides and thus prints +! .true. or .false. depending on this setting. + +s = 4 +if (.false. .neqv. is_contiguous (a(2:1:s))) stop 6 +s = 1 +if (.true. .neqv. is_contiguous (a(2:1:s))) stop 7 +end diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_2.f90 b/gcc/testsuite/gfortran.dg/is_contiguous_2.f90 new file mode 100644 index 00000000000..210c191956b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/is_contiguous_2.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! PR fortran/45424 +! PR fortran/48820 +! +! Additional run-time checks for IS_CONTIGUOUS with assumed type/rank +program is_contiguous_2 + implicit none + real, allocatable :: b(:,:) + real, pointer :: c(:,:) + integer, volatile :: k + target :: b + allocate(b(10,10)) + k = 2 + if (fail_ar (b, .true.) ) stop 1 + if (fail_ar (b(::1,::1), .true.) ) stop 2 + if (fail_ar (b(::2,::1), .false.)) stop 3 + if (fail_ar (b(::1,::2), .false.)) stop 4 + if (fail_ar (b(:10,:10), .true. )) stop 5 + if (fail_ar (b(: 9,:10), .false.)) stop 6 + if (fail_ar (b(2: ,: ), .false.)) stop 7 + if (fail_ar (b(: ,2: ), .true. )) stop 8 + if (fail_ar (b(k: ,: ), .false.)) stop 9 + if (fail_ar (b(: ,k: ), .true. )) stop 10 + if (fail_at (b(::1,k: ), .true. )) stop 11 + if (fail_at (b(::k,k: ), .false.)) stop 12 + if (fail_at (b(10,k) , .true. )) stop 13 + c => b(::1,:) + if (fail_ar (c, .true.) ) stop 14 + c => b(::2,:) + if (fail_ar (c, .false.)) stop 15 + associate (d => b(:,2:), e => b(::k,:)) + if (fail_ar (d, .true.) ) stop 16 + if (fail_ar (e, .false.)) stop 17 + end associate +contains + pure logical function fail_ar (x, expect) result (fail) + real, dimension(..), intent(in) :: x ! Assumed rank + logical, intent(in) :: expect + fail = is_contiguous (x) .neqv. expect + end function fail_ar + pure logical function fail_at (x, expect) result (fail) + type(*), dimension(..), intent(in) :: x ! Assumed type/assumed rank + logical, intent(in) :: expect + fail = is_contiguous (x) .neqv. expect + end function fail_at +end program diff --git a/gcc/testsuite/gfortran.dg/is_contiguous_3.f90 b/gcc/testsuite/gfortran.dg/is_contiguous_3.f90 new file mode 100644 index 00000000000..e4d20605f24 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/is_contiguous_3.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR 45424 - compile-time simplification of is_contiguous +program main + real, dimension(10,5) :: a + character (len=1) :: line + + write (unit=line,fmt='(L1)') is_contiguous(a(4:2,:)) + if (line /= 'F') stop 1 + + write (unit=line,fmt='(L1)') is_contiguous(a(:,2:4)) + if (line /= 'T') stop 1 + + write (unit=line,fmt='(L1)') is_contiguous(a(2:4,3:4)) + if (line /= 'F') stop 3 + + write (unit=line,fmt='(L1)') is_contiguous(a(::2,:)) + if (line /= 'F') stop 4 + + write (unit=line,fmt='(L1)') is_contiguous(a(:,::2)) + if (line /= 'F') stop 5 + +end program main +! { dg-final { scan-tree-dump-not " _gfortran_is_contiguous" "original" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 52d8d1e317d..eee978f654b 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,14 @@ +2019-01-07 Thomas Koenig + Harald Anlauf + Tobias Burnus + + PR fortran/45424 + * Makefile.am: Add intrinsics/is_contiguous.c. + * Makefile.in: Regenerated. + * gfortran.map: Add _gfortran_is_contiguous0. + * intrinsics/is_contiguous.c: New file. + * libgfortran.h: Add prototype for is_contiguous0. + 2019-01-07 Janne Blomqvist * gfortran.map (GFORTRAN_9): Make GFORTRAN_9 node depend on diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 87000c6e60c..e1d757d9b91 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -124,6 +124,7 @@ intrinsics/extends_type_of.c \ intrinsics/fnum.c \ intrinsics/ierrno.c \ intrinsics/ishftc.c \ +intrinsics/is_contiguous.c \ intrinsics/mvbits.c \ intrinsics/move_alloc.c \ intrinsics/pack_generic.c \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 2424f7e6ba8..ed8cf4cf9c9 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -414,7 +414,7 @@ am__objects_54 = size_from_kind.lo $(am__objects_53) am__objects_57 = associated.lo abort.lo args.lo cshift0.lo eoshift0.lo \ eoshift2.lo erfc_scaled.lo extends_type_of.lo fnum.lo \ ierrno.lo ishftc.lo mvbits.lo move_alloc.lo pack_generic.lo \ - selected_char_kind.lo size.lo spread_generic.lo \ + selected_char_kind.lo size.lo is_contiguous.lo spread_generic.lo \ string_intrinsics.lo rand.lo random.lo reshape_generic.lo \ reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \ unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \ @@ -760,6 +760,7 @@ gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \ intrinsics/ierrno.c intrinsics/ishftc.c intrinsics/mvbits.c \ intrinsics/move_alloc.c intrinsics/pack_generic.c \ intrinsics/selected_char_kind.c intrinsics/size.c \ + intrinsics/is_contiguous.c \ intrinsics/spread_generic.c intrinsics/string_intrinsics.c \ intrinsics/rand.c intrinsics/random.c \ intrinsics/reshape_generic.c intrinsics/reshape_packed.c \ @@ -2198,6 +2199,7 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/single.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/size.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/size_from_kind.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/is_contiguous.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/sleep.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/spread_c16.Plo@am__quote@ @@ -6318,6 +6320,13 @@ size.lo: intrinsics/size.c @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o size.lo `test -f 'intrinsics/size.c' || echo '$(srcdir)/'`intrinsics/size.c +is_contiguous.lo: intrinsics/is_contiguous.c +@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT is_contiguous.lo -MD -MP -MF $(DEPDIR)/is_contiguous.Tpo -c -o is_contiguous.lo `test -f 'intrinsics/is_contiguous.c' || echo '$(srcdir)/'`intrinsics/is_contiguous.c +@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/is_contiguous.Tpo $(DEPDIR)/is_contiguous.Plo +@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='intrinsics/is_contiguous.c' object='is_contiguous.lo' libtool=yes @AMDEPBACKSLASH@ +@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ +@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o is_contiguous.lo `test -f 'intrinsics/is_contiguous.c' || echo '$(srcdir)/'`intrinsics/is_contiguous.c + spread_generic.lo: intrinsics/spread_generic.c @am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT spread_generic.lo -MD -MP -MF $(DEPDIR)/spread_generic.Tpo -c -o spread_generic.lo `test -f 'intrinsics/spread_generic.c' || echo '$(srcdir)/'`intrinsics/spread_generic.c @am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/spread_generic.Tpo $(DEPDIR)/spread_generic.Plo diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 681f7dd6125..43b32de5bf7 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1518,6 +1518,7 @@ GFORTRAN_9 { _gfortran_findloc1_s4; _gfortran_findloc2_s1; _gfortran_findloc2_s4; + _gfortran_is_contiguous0; _gfortran_mfindloc0_c16; _gfortran_mfindloc0_c4; _gfortran_mfindloc0_c8; diff --git a/libgfortran/intrinsics/is_contiguous.c b/libgfortran/intrinsics/is_contiguous.c new file mode 100644 index 00000000000..eea63a04462 --- /dev/null +++ b/libgfortran/intrinsics/is_contiguous.c @@ -0,0 +1,49 @@ +/* Implementation of the is_contiguous intrinsic. + Copyright (C) 2019 Free Software Foundation, Inc. + Contributed by Thomas König + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" + +GFC_LOGICAL_4 +is_contiguous0 (const array_t * const restrict array) +{ + index_type dim; + index_type n; + index_type extent, stride; + + dim = GFC_DESCRIPTOR_RANK (array); + + extent = 1; + for (n = 0; n < dim; n++) + { + stride = GFC_DESCRIPTOR_STRIDE (array, n); + if (stride != extent) + return 0; + + extent *= GFC_DESCRIPTOR_EXTENT (array, n); + } + + return 1; +} +iexport(is_contiguous0); diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 6b4775a1365..433b204abda 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -1375,6 +1375,11 @@ typedef GFC_ARRAY_DESCRIPTOR (void) array_t; extern index_type size0 (const array_t * array); iexport_proto(size0); +/* is_contiguous.c */ + +extern GFC_LOGICAL_4 is_contiguous0 (const array_t * const restrict array); +iexport_proto(is_contiguous0); + /* bounds.c */ extern void bounds_equal_extents (array_t *, array_t *, const char *,