From 2853e5127d7dcac713ad509ab44c5c0028037dca Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 23 Oct 2005 06:59:17 +0000 Subject: [PATCH] re PR fortran/18022 (problem with structure and calling a function) 2005-10-23 Paul Thomas PR fortran/18022 * trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL if there is a component ref during an array ref to force use of temporary in assignment. PR fortran/24311 PR fortran/24384 * fortran/iresolve.c (check_charlen_present): New function to add a charlen to the typespec, in the case of constant expressions. (gfc_resolve_merge, gfc_resolve_spread): Call.the above. (gfc_resolve_spread): Make calls to library functions that handle the case of the spread intrinsic with a scalar source. * libgfortran/intrinsics/spread_generic.c (spread_internal _scalar): New function that handles the special case of spread with a scalar source. This has interface functions - (spread_scalar, spread_char_scalar): New functions to interface with the calls specified in gfc_resolve_spread. 2005-10-23 Paul Thomas PR fortran/18022 gfortran.dg/assign_func_dtcomp_1.f90: New test. PR fortran/24311 gfortran.dg/merge_char_const.f90: New test. PR fortran/24384 gfortran.dg/spread_scalar_source.f90: New test. From-SVN: r105810 --- gcc/fortran/ChangeLog | 16 ++++ gcc/fortran/iresolve.c | 32 +++++++- gcc/fortran/trans-expr.c | 16 ++++ gcc/testsuite/ChangeLog | 11 +++ .../gfortran.dg/assign_func_dtcomp_1.f90 | 47 +++++++++++ .../gfortran.dg/merge_char_const.f90 | 13 ++++ .../gfortran.dg/spread_scalar_source.f90 | 52 +++++++++++++ libgfortran/ChangeLog | 9 +++ libgfortran/intrinsics/spread_generic.c | 77 +++++++++++++++++++ 9 files changed, 270 insertions(+), 3 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/assign_func_dtcomp_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/merge_char_const.f90 create mode 100755 gcc/testsuite/gfortran.dg/spread_scalar_source.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 51178f26189..af155949c7f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2005-10-23 Paul Thomas + + PR fortran/18022 + * trans-expr.c (gfc_trans_arrayfunc_assign): Return NULL + if there is a component ref during an array ref to force + use of temporary in assignment. + + PR fortran/24311 + PR fortran/24384 + * fortran/iresolve.c (check_charlen_present): New function to + add a charlen to the typespec, in the case of constant + expressions. + (gfc_resolve_merge, gfc_resolve_spread): Call.the above. + (gfc_resolve_spread): Make calls to library functions that + handle the case of the spread intrinsic with a scalar source. + 2005-10-22 Erik Edelmann PR fortran/24426 diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 6c23d4a2c74..9cba18bd1ef 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -59,6 +59,21 @@ gfc_get_string (const char *format, ...) return IDENTIFIER_POINTER (ident); } +/* MERGE and SPREAD need to have source charlen's present for passing + to the result expression. */ +static void +check_charlen_present (gfc_expr *source) +{ + if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL) + { + source->ts.cl = gfc_get_charlen (); + source->ts.cl->next = gfc_current_ns->cl_list; + gfc_current_ns->cl_list = source->ts.cl; + source->ts.cl->length = gfc_int_expr (source->value.character.length); + source->rank = 0; + } +} + /********************** Resolution functions **********************/ @@ -996,6 +1011,9 @@ gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource, gfc_expr * fsource ATTRIBUTE_UNUSED, gfc_expr * mask ATTRIBUTE_UNUSED) { + if (tsource->ts.type == BT_CHARACTER) + check_charlen_present (tsource); + f->ts = tsource->ts; f->value.function.name = gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type), @@ -1395,11 +1413,19 @@ gfc_resolve_spread (gfc_expr * f, gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies) { + if (source->ts.type == BT_CHARACTER) + check_charlen_present (source); + f->ts = source->ts; f->rank = source->rank + 1; - f->value.function.name = (source->ts.type == BT_CHARACTER - ? PREFIX("spread_char") - : PREFIX("spread")); + if (source->rank == 0) + f->value.function.name = (source->ts.type == BT_CHARACTER + ? PREFIX("spread_char_scalar") + : PREFIX("spread_scalar")); + else + f->value.function.name = (source->ts.type == BT_CHARACTER + ? PREFIX("spread_char") + : PREFIX("spread")); gfc_resolve_dim_arg (dim); gfc_resolve_index (ncopies, 1); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7c6b4097bae..fe5e24bdb07 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2591,6 +2591,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) { gfc_se se; gfc_ss *ss; + gfc_ref * ref; + bool seen_array_ref; /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) @@ -2605,6 +2607,20 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) if (gfc_ref_needs_temporary_p (expr1->ref)) return NULL; + /* Check that no LHS component references appear during an array + reference. This is needed because we do not have the means to + span any arbitrary stride with an array descriptor. This check + is not needed for the rhs because the function result has to be + a complete type. */ + seen_array_ref = false; + for (ref = expr1->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + seen_array_ref= true; + else if (ref->type == REF_COMPONENT && seen_array_ref) + return NULL; + } + /* Check for a dependency. */ if (gfc_check_fncall_dependency (expr1, expr2)) return NULL; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index e1ddf72552c..af24da12767 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2005-10-23 Paul Thomas + + PR fortran/18022 + gfortran.dg/assign_func_dtcomp_1.f90: New test. + + PR fortran/24311 + gfortran.dg/merge_char_const.f90: New test. + + PR fortran/24384 + gfortran.dg/spread_scalar_source.f90: New test. + 2005-10-22 Hans-Peter Nilsson * g++.old-deja/g++.jason/thunk2.C: Guard test with { target fpic }. diff --git a/gcc/testsuite/gfortran.dg/assign_func_dtcomp_1.f90 b/gcc/testsuite/gfortran.dg/assign_func_dtcomp_1.f90 new file mode 100644 index 00000000000..385eb2715f6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/assign_func_dtcomp_1.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-O0" } +! +! Test fix for PR18022. +! +! Contributed by Paul Thomas +! +program assign_func_dtcomp + implicit none + type :: mytype + real :: x + real :: y + end type mytype + type (mytype), dimension (4) :: z + + type :: thytype + real :: x(4) + end type thytype + type (thytype) :: w + real, dimension (4) :: a = (/1.,2.,3.,4./) + real, dimension (4) :: b = (/5.,6.,7.,8./) + + +! Test the original problem is fixed. + z(:)%x = foo (a) + z(:)%y = foo (b) + + + if (any(z%x.ne.a).or.any(z%y.ne.b)) call abort () + +! Make sure we did not break anything on the way. + w%x(:) = foo (b) + a = foo (b) + + if (any(w%x.ne.b).or.any(a.ne.b)) call abort () + +contains + + function foo (v) result (ans) + real, dimension (:), intent(in) :: v + real, dimension (size(v)) :: ans + ans = v + end function foo + + +end program assign_func_dtcomp + diff --git a/gcc/testsuite/gfortran.dg/merge_char_const.f90 b/gcc/testsuite/gfortran.dg/merge_char_const.f90 new file mode 100644 index 00000000000..32c87f51000 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/merge_char_const.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-O0" } +! This tests the patch for PR24311 in which the PRINT statement would +! ICE on trying to print a MERGE statement with character constants +! for the first two arguments. +! +! Contributed by Paul Thomas +! + integer, dimension(6) :: i = (/1,0,0,1,1,0/) + print '(6a1)', Merge ("a", "b", i == 1) ! { dg-output "abbaab" } + end + + diff --git a/gcc/testsuite/gfortran.dg/spread_scalar_source.f90 b/gcc/testsuite/gfortran.dg/spread_scalar_source.f90 new file mode 100755 index 00000000000..c253165cc36 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/spread_scalar_source.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-O0" } + + character*1 :: i, j(10) + character*8 :: buffer + integer*1 :: ii, jj(10) + type :: mytype + real*8 :: x + integer*1 :: i + character*15 :: ch + end type mytype + type(mytype) :: iii, jjj(10) + + i = "w" + ii = 42 + iii = mytype (41.9999_8, 77, "test_of_spread_") + +! Test constant sources. + + j = spread ("z", 1 , 10) + if (any (j /= "z")) call abort () + jj = spread (19, 1 , 10) + if (any (jj /= 19)) call abort () + +! Test variable sources. + + j = spread (i, 1 , 10) + if (any (j /= "w")) call abort () + jj = spread (ii, 1 , 10) + if (any (jj /= 42)) call abort () + jjj = spread (iii, 1 , 10) + if (any (jjj%x /= 41.9999_8)) call abort () + if (any (jjj%i /= 77)) call abort () + if (any (jjj%ch /= "test_of_spread_")) call abort () + +! Check that spread != 1 is OK. + + jj(2:10:2) = spread (1, 1, 5) + if (any (jj(1:9:2) /= 42) .or. any (jj(2:10:2) /= 1)) call abort () + +! Finally, check that temporaries and trans-io.c work correctly. + + write (buffer, '(4a1)') spread (i, 1 , 4) + if (trim(buffer) /= "wwww") call abort () + write (buffer, '(4a1)') spread ("r", 1 , 4) + if (trim(buffer) /= "rrrr") call abort () + write (buffer, '(4i2)') spread (ii, 1 , 4) + if (trim(buffer) /= "42424242") call abort () + write (buffer, '(4i2)') spread (31, 1 , 4) + if (trim(buffer) /= "31313131") call abort () + + end \ No newline at end of file diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 2c4f5f8f712..3666964d6c9 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2005-10-23 Paul Thomas + + PR fortran/24384 + * intrinsics/spread_generic.c (spread_internal_scalar): New + function that handles the special case of spread with a scalar + source. This has new interface functions - + (spread_scalar, spread_char_scalar): New functions to interface + with the calls specified in gfc_resolve_spread. + 2005-10-21 Francois-Xavier Coudert PR libfortran/24383 diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index a9cddb0f689..bdcc0d11c12 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -176,6 +176,49 @@ spread_internal (gfc_array_char *ret, const gfc_array_char *source, } } +/* This version of spread_internal treats the special case of a scalar + source. This is much simpler than the more general case above. */ + +static void +spread_internal_scalar (gfc_array_char *ret, const char *source, + const index_type *along, const index_type *pncopies, + index_type size) +{ + int n; + int ncopies = *pncopies; + char * dest; + + if (GFC_DESCRIPTOR_RANK (ret) != 1) + runtime_error ("incorrect destination rank in spread()"); + + if (*along > 1) + runtime_error ("dim outside of rank in spread()"); + + if (ret->data == NULL) + { + ret->data = internal_malloc_size (ncopies * size); + ret->offset = 0; + ret->dim[0].stride = 1; + ret->dim[0].lbound = 0; + ret->dim[0].ubound = ncopies - 1; + } + else + { + if (ret->dim[0].stride == 0) + ret->dim[0].stride = 1; + + if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound) + / ret->dim[0].stride) + runtime_error ("dim too large in spread()"); + } + + for (n = 0; n < ncopies; n++) + { + dest = (char*)(ret->data + n*size*ret->dim[0].stride); + memcpy (dest , source, size); + } +} + extern void spread (gfc_array_char *, const gfc_array_char *, const index_type *, const index_type *); export_proto(spread); @@ -200,3 +243,37 @@ spread_char (gfc_array_char *ret, { spread_internal (ret, source, along, pncopies, source_length); } + +/* The following are the prototypes for the versions of spread with a + scalar source. */ + +extern void spread_scalar (gfc_array_char *, const char *, + const index_type *, const index_type *); +export_proto(spread_scalar); + +void +spread_scalar (gfc_array_char *ret, const char *source, + const index_type *along, const index_type *pncopies) +{ + if (!ret->dtype) + runtime_error ("return array missing descriptor in spread()"); + spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret)); +} + + +extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4, + const char *, const index_type *, + const index_type *, GFC_INTEGER_4); +export_proto(spread_char_scalar); + +void +spread_char_scalar (gfc_array_char *ret, + GFC_INTEGER_4 ret_length __attribute__((unused)), + const char *source, const index_type *along, + const index_type *pncopies, GFC_INTEGER_4 source_length) +{ + if (!ret->dtype) + runtime_error ("return array missing descriptor in spread()"); + spread_internal_scalar (ret, source, along, pncopies, source_length); +} +