mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-01-14 17:15:15 +08:00
re PR fortran/18022 (problem with structure and calling a function)
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. * 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. From-SVN: r105810
This commit is contained in:
Paul Thomas
parent
1903e03eca
commit
2853e5127d
@ -1,3 +1,19 @@
|
||||
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
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -1,3 +1,14 @@
|
||||
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 }.
|
||||
|
||||
47
gcc/testsuite/gfortran.dg/assign_func_dtcomp_1.f90
Normal file
47
gcc/testsuite/gfortran.dg/assign_func_dtcomp_1.f90
Normal file
@ -0,0 +1,47 @@
|
||||
! { 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
|
||||
|
||||
13
gcc/testsuite/gfortran.dg/merge_char_const.f90
Normal file
13
gcc/testsuite/gfortran.dg/merge_char_const.f90
Normal file
@ -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 <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
|
||||
|
||||
|
||||
52
gcc/testsuite/gfortran.dg/spread_scalar_source.f90
Executable file
52
gcc/testsuite/gfortran.dg/spread_scalar_source.f90
Executable file
@ -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
|
||||
@ -1,3 +1,12 @@
|
||||
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
|
||||
|
||||
@ -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);
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user