diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cdaafa50aebf..a14cf4261a64 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,9 +1,19 @@ -2007-05-22 Tobias Burnus +2007-05-31 Paul Thomas - PR fortran/31559 - Backport from mainline. - * primary.c (match_variable): External functions - are no variables. + PR fortran/31483 + * trans-expr.c (gfc_conv_function_call): Give a dummy + procedure the correct type if it has alternate returns. + + + PR fortran/31540 + * resolve.c (resolve_fl_procedure): Resolve constant character + lengths. + + PR fortran/31867 + PR fortran/31994 + * trans-array.c (gfc_conv_expr_descriptor): Obtain the stored + offset for non-descriptor, source arrays and correct for stride + not equal to one before writing to field of output descriptor. 2007-05-17 Tobias Burnus diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e2d58371b586..78bd4dc3b048 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5742,6 +5742,11 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag) if (sym->ts.type == BT_CHARACTER) { gfc_charlen *cl = sym->ts.cl; + + if (cl && cl->length && gfc_is_constant_expr (cl->length) + && resolve_charlen (cl) == FAILURE) + return FAILURE; + if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) { if (sym->attr.proc == PROC_ST_FUNCTION) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 53427f297c7a..cafb92c7e3f5 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4422,6 +4422,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (se->direct_byref) base = gfc_index_zero_node; + else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre); else base = NULL_TREE; @@ -4489,8 +4491,20 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) stride, info->stride[dim]); if (se->direct_byref) - base = fold_build2 (MINUS_EXPR, TREE_TYPE (base), - base, stride); + { + base = fold_build2 (MINUS_EXPR, TREE_TYPE (base), + base, stride); + } + else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + { + tmp = gfc_conv_array_lbound (desc, n); + tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (base), + tmp, loop.from[dim]); + tmp = fold_build2 (MULT_EXPR, TREE_TYPE (base), + tmp, gfc_conv_array_stride (desc, n)); + base = fold_build2 (PLUS_EXPR, TREE_TYPE (base), + tmp, base); + } /* Store the new stride. */ tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]); @@ -4511,7 +4525,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_conv_descriptor_data_set (&loop.pre, parm, offset); } - if (se->direct_byref && !se->data_not_needed) + if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + && !se->data_not_needed) { /* Set the offset. */ tmp = gfc_conv_descriptor_offset (parm); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index f842f4ae9b40..d89c5c032e0b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2348,17 +2348,23 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, /* Generate the actual call. */ gfc_conv_function_val (se, sym); + /* If there are alternate return labels, function type should be integer. Can't modify the type in place though, since it can be shared - with other functions. */ + with other functions. For dummy arguments, the typing is done to + to this result, even if it has to be repeated for each call. */ if (has_alternate_specifier && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node) { - gcc_assert (! sym->attr.dummy); - TREE_TYPE (sym->backend_decl) - = build_function_type (integer_type_node, - TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl))); - se->expr = build_fold_addr_expr (sym->backend_decl); + if (!sym->attr.dummy) + { + TREE_TYPE (sym->backend_decl) + = build_function_type (integer_type_node, + TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl))); + se->expr = build_fold_addr_expr (sym->backend_decl); + } + else + TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node; } fntype = TREE_TYPE (TREE_TYPE (se->expr)); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ce147ab116a7..ed1bf674c1d8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,24 @@ +2007-05-31 Paul Thomas + + PR fortran/31483 + * gfortran.dg/altreturn_5.f90: New test. + + PR fortran/31540 + * gfortran.dg/char_result_5.f90: New test. + + PR fortran/31867 + * gfortran.dg/char_length_5.f90: New test. + + PR fortran/31994 + * gfortran.dg/array_reference_1.f90: New test. + +2007-05-22 Tobias Burnus + + PR fortran/31559 + Backport from mainline. + * primary.c (match_variable): External functions + are no variables. + 2007-05-30 Jakub Jelinek PR tree-optimization/31769 diff --git a/gcc/testsuite/gfortran.dg/altreturn_5.f90 b/gcc/testsuite/gfortran.dg/altreturn_5.f90 new file mode 100644 index 000000000000..ddf009ab52d3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/altreturn_5.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! Tests the fix for PR31483, in which dummy argument procedures +! produced an ICE if they had an alternate return. +! +! Contributed by Mathias Fröhlich + + SUBROUTINE R (i, *, *) + INTEGER i + RETURN i + END + + SUBROUTINE PHLOAD (READER, i, res) + IMPLICIT NONE + EXTERNAL READER + integer i + character(3) res + CALL READER (i, *1, *2) + 1 res = "one" + return + 2 res = "two" + return + END + + EXTERNAL R + character(3) res + call PHLOAD (R, 1, res) + if (res .ne. "one") call abort () + CALL PHLOAD (R, 2, res) + if (res .ne. "two") call abort () + END \ No newline at end of file diff --git a/gcc/testsuite/gfortran.dg/array_reference_1.f90 b/gcc/testsuite/gfortran.dg/array_reference_1.f90 new file mode 100644 index 000000000000..66c08cc0a377 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_reference_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Tests the fix for PR31994, aka 31867, in which the offset +! of 'a' in both subroutines was being evaluated incorrectly. +! The testcase for PR31867 is char_length_5.f90 +! +! Contributed by Elizabeth Yip +! and Francois-Xavier Coudert +! +program main + call PR31994 + call PR31994_comment6 +contains + subroutine PR31994 + implicit none + complex (kind=4), dimension(2,2) :: a, b, c + a(1,1) = (1.,1.) + a(2,1) = (2.,2.) + a(1,2) = (3.,3.) + a(2,2) = (4.,4.) + b=conjg (transpose (a)) + c=transpose (a) + c=conjg (c) + if (any (b .ne. c)) call abort () + end subroutine PR31994 + subroutine PR31994_comment6 + implicit none + real ,dimension(2,2)::a + integer ,dimension(2,2) :: b, c + a = reshape ((/1.,2.,3.,4./), (/2,2/)) + b=int (transpose(a)) + c = int (a) + c = transpose (c) + if (any (b .ne. c)) call abort () + end subroutine PR31994_comment6 +END program main diff --git a/gcc/testsuite/gfortran.dg/char_length_5.f90 b/gcc/testsuite/gfortran.dg/char_length_5.f90 new file mode 100644 index 000000000000..03a4d8560297 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_length_5.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +! Tests the fix for PR31867, in which the interface evaluation +! of the character length of 'join' (ie. the length available in +! the caller) was wrong. +! +! Contributed by +! +module util_mod + implicit none +contains + function join (words, sep) result(str) + character (len=*), intent(in) :: words(:),sep + character (len = (size (words) - 1) * len_trim (sep) + & + sum (len_trim (words))) :: str + integer :: i,nw + nw = size (words) + str = "" + if (nw < 1) then + return + else + str = words(1) + end if + do i=2,nw + str = trim (str) // trim (sep) // words(i) + end do + end function join +end module util_mod +! +program xjoin + use util_mod, only: join + implicit none + integer yy + character (len=5) :: words(5:8) = (/"two ","three","four ","five "/), sep = "^#^" + character (len=5) :: words2(4) = (/"bat ","ball ","goal ","stump"/), sep2 = "&" + + if (join (words, sep) .ne. "two^#^three^#^four^#^five") call abort () + if (len (join (words, sep)) .ne. 25) call abort () + + if (join (words(5:6), sep) .ne. "two^#^three") call abort () + if (len (join (words(5:6), sep)) .ne. 11) call abort () + + if (join (words(7:8), sep) .ne. "four^#^five") call abort () + if (len (join (words(7:8), sep)) .ne. 11) call abort () + + if (join (words(5:7:2), sep) .ne. "two^#^four") call abort () + if (len (join (words(5:7:2), sep)) .ne. 10) call abort () + + if (join (words(6:8:2), sep) .ne. "three^#^five") call abort () + if (len (join (words(6:8:2), sep)) .ne. 12) call abort () + + if (join (words2, sep2) .ne. "bat&ball&goal&stump") call abort () + if (len (join (words2, sep2)) .ne. 19) call abort () + + if (join (words2(1:2), sep2) .ne. "bat&ball") call abort () + if (len (join (words2(1:2), sep2)) .ne. 8) call abort () + + if (join (words2(2:4:2), sep2) .ne. "ball&stump") call abort () + if (len (join (words2(2:4:2), sep2)) .ne. 10) call abort () + +end program xjoin +! { dg-final { cleanup-modules "util_mod" } } diff --git a/gcc/testsuite/gfortran.dg/char_result_13.f90 b/gcc/testsuite/gfortran.dg/char_result_13.f90 new file mode 100644 index 000000000000..13a9b781bbe5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_result_13.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! tests the fix for PR31540, in which the character lengths in +! parentheses were not resolved. +! +! Contributed by Tobias Burnus +! + subroutine pfb() + implicit none + external pfname1, pfname2 + character ((136)) pfname1 + character ((129+7)) pfname2 + return + end