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 <pault@gcc.gnu.org>
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@105810
138bc75d-0d04-0410-961f-
82ee72b054a4
+2005-10-23 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <eedelman@gcc.gnu.org>
PR fortran/24426
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 **********************/
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),
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);
{
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))
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;
+2005-10-23 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <hp@axis.com>
* g++.old-deja/g++.jason/thunk2.C: Guard test with { target fpic }.
--- /dev/null
+! { dg-do run }
+! { dg-options "-O0" }
+!
+! Test fix for PR18022.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+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
+
--- /dev/null
+! { 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 <pault@gcc.gnu.org>
+!
+ integer, dimension(6) :: i = (/1,0,0,1,1,0/)
+ print '(6a1)', Merge ("a", "b", i == 1) ! { dg-output "abbaab" }
+ end
+
+
--- /dev/null
+! { 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
+2005-10-23 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <coudert@clipper.ens.fr>
PR libfortran/24383
}
}
+/* 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);
{
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);
+}
+
projects / platform / upstream / linaro-gcc.git / commitdiff