mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-03-10 19:07:38 +08:00
re PR fortran/45424 ([F08] Add IS_CONTIGUOUS intrinsic)
2019-01-07 Thomas Koenig <tkoenig@gcc.gnu.org> Harald Anlauf <anlauf@gmx.de> Tobias Burnus <burnus@gcc.gnu.org> 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 <tkoenig@gcc.gnu.org> Harald Anlauf <anlauf@gmx.de> Tobias Burnus <burnus@gcc.gnu.org> 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 <tkoenig@gcc.gnu.org> Harald Anlauf <anlauf@gmx.de> Tobias Burnus <burnus@gcc.gnu.org> * 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 <anlauf@gmx.de> Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org> From-SVN: r267657
This commit is contained in:
Thomas Koenig
parent
25a34b0236
commit
419af57c13
@ -1,3 +1,25 @@
|
||||
2019-01-07 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
Harald Anlauf <anlauf@gmx.de>
|
||||
Tobias Burnus <burnus@gcc.gnu.org>
|
||||
|
||||
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 <tkoenig@gcc.gnu.org>
|
||||
|
||||
PR fortran/88658
|
||||
|
||||
@ -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)
|
||||
{
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 *);
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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 *);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
{
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -1,3 +1,11 @@
|
||||
2019-01-07 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
Harald Anlauf <anlauf@gmx.de>
|
||||
Tobias Burnus <burnus@gcc.gnu.org>
|
||||
|
||||
* 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 <polacek@redhat.com>
|
||||
|
||||
PR c++/88741 - wrong error with initializer-string.
|
||||
|
||||
33
gcc/testsuite/gfortran.dg/is_contiguous_1.f90
Normal file
33
gcc/testsuite/gfortran.dg/is_contiguous_1.f90
Normal file
@ -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
|
||||
47
gcc/testsuite/gfortran.dg/is_contiguous_2.f90
Normal file
47
gcc/testsuite/gfortran.dg/is_contiguous_2.f90
Normal file
@ -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
|
||||
24
gcc/testsuite/gfortran.dg/is_contiguous_3.f90
Normal file
24
gcc/testsuite/gfortran.dg/is_contiguous_3.f90
Normal file
@ -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" } }
|
||||
@ -1,3 +1,14 @@
|
||||
2019-01-07 Thomas Koenig <tkoenig@gcc.gnu.org>
|
||||
Harald Anlauf <anlauf@gmx.de>
|
||||
Tobias Burnus <burnus@gcc.gnu.org>
|
||||
|
||||
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 <jb@gcc.gnu.org>
|
||||
|
||||
* gfortran.map (GFORTRAN_9): Make GFORTRAN_9 node depend on
|
||||
|
||||
@ -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 \
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
49
libgfortran/intrinsics/is_contiguous.c
Normal file
49
libgfortran/intrinsics/is_contiguous.c
Normal file
@ -0,0 +1,49 @@
|
||||
/* Implementation of the is_contiguous intrinsic.
|
||||
Copyright (C) 2019 Free Software Foundation, Inc.
|
||||
Contributed by Thomas König <tkoenig@gcc.gnu.org>
|
||||
|
||||
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
|
||||
<https://www.gnu.org/licenses/>. */
|
||||
|
||||
#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);
|
||||
@ -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 *,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user