diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5aa4bfb22838..ae9c88c78a56 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,36 @@ +2007-02-12 Paul Thomas + + PR fortran/30284 + PR fortran/30626 + * trans-expr.c (gfc_conv_aliased_arg): Remove static attribute + from function and make sure that substring lengths are + translated. + (is_aliased_array): Remove static attribute. + * trans.c : Add prototypes for gfc_conv_aliased_arg and + is_aliased_array. + * trans-io.c (set_internal_unit): Add the post block to the + arguments of the function. Use is_aliased_array to check if + temporary is needed; if so call gfc_conv_aliased_arg. + (build_dt): Pass the post block to set_internal_unit and + add to the block after all io activiy is done. + + PR fortran/30407 + * trans-expr.c (gfc_conv_operator_assign): New function. + * trans.h : Add prototype for gfc_conv_operator_assign. + * trans-stmt.c (gfc_trans_where_assign): Add a gfc_symbol for + a potential operator assignment subroutine. If it is non-NULL + call gfc_conv_operator_assign instead of the first assignment. + ( gfc_trans_where_2): In the case of an operator assignment, + extract the argument expressions from the code for the + subroutine call and pass the symbol to gfc_trans_where_assign. + resolve.c (resolve_where, gfc_resolve_where_code_in_forall, + gfc_resolve_forall_body): Resolve the subroutine call for + operator assignments. + + PR fortran/30514 + * array.c (match_array_element_spec): If the length of an array is + negative, adjust the upper limit to make it zero length. + 2007-02-12 Tobias Schlüter PR fortran/30478 diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index d47ce290cad2..e792d71d4049 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -319,6 +319,15 @@ match_array_element_spec (gfc_array_spec * as) if (m == MATCH_NO) return AS_ASSUMED_SHAPE; + /* If the size is negative in this dimension, set it to zero. */ + if ((*lower)->expr_type == EXPR_CONSTANT + && (*upper)->expr_type == EXPR_CONSTANT + && mpz_cmp ((*upper)->value.integer, (*lower)->value.integer) < 0) + { + gfc_free_expr (*upper); + *upper = gfc_copy_expr (*lower); + mpz_sub_ui ((*upper)->value.integer, (*upper)->value.integer, 1); + } return AS_EXPLICIT; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f91b8c7c86e6..5bd3c1d90aed 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4559,6 +4559,10 @@ resolve_where (gfc_code *code, gfc_expr *mask) "inconsistent shape", &cnext->expr->where); break; + case EXEC_ASSIGN_CALL: + resolve_call (cnext); + break; + /* WHERE or WHERE construct is part of a where-body-construct */ case EXEC_WHERE: resolve_where (cnext, e); @@ -4796,6 +4800,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) gfc_resolve_assign_in_forall (c, nvar, var_expr); break; + case EXEC_ASSIGN_CALL: + resolve_call (c); + break; + /* Because the gfc_resolve_blocks() will handle the nested FORALL, there is no need to handle it here. */ case EXEC_FORALL: diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 240d22d49f28..5c5a15f3d3b2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1205,6 +1205,48 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) } +/* Translate the call for an elemental subroutine call used in an operator + assignment. This is a simplified version of gfc_conv_function_call. */ + +tree +gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym) +{ + tree args; + tree tmp; + gfc_se se; + stmtblock_t block; + + /* Only elemental subroutines with two arguments. */ + gcc_assert (sym->attr.elemental && sym->attr.subroutine); + gcc_assert (sym->formal->next->next == NULL); + + gfc_init_block (&block); + + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + + /* Build the argument list for the call, including hidden string lengths. */ + args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr)); + args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr)); + if (lse->string_length != NULL_TREE) + args = gfc_chainon_list (args, lse->string_length); + if (rse->string_length != NULL_TREE) + args = gfc_chainon_list (args, rse->string_length); + + /* Build the function call. */ + gfc_init_se (&se, NULL); + gfc_conv_function_val (&se, sym); + tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr))); + tmp = build3 (CALL_EXPR, tmp, se.expr, args, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &lse->post); + gfc_add_block_to_block (&block, &rse->post); + + return gfc_finish_block (&block); +} + + /* Initialize MAPPING. */ void @@ -1596,9 +1638,9 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping, an actual argument derived type array is copied and then returned after the function call. TODO Get rid of this kludge, when array descriptors are capable of - handling aliased arrays. */ + handling arrays with a bigger stride in bytes than size. */ -static void +void gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, int g77, sym_intent intent) { @@ -1647,7 +1689,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, { gfc_ref *char_ref = expr->ref; - for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next) + for (; char_ref; char_ref = char_ref->next) if (char_ref->type == REF_SUBSTRING) { gfc_se tmp_se; @@ -1842,7 +1884,7 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr, /* Is true if an array reference is followed by a component or substring reference. */ -static bool +bool is_aliased_array (gfc_expr * e) { gfc_ref * ref; diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 48a52dce0f6b..fcab3ab81ccd 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -585,7 +585,8 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, for an internal unit. */ static unsigned int -set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e) +set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, + tree var, gfc_expr * e) { gfc_se se; tree io; @@ -623,10 +624,23 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e) { se.ss = gfc_walk_expr (e); - /* Return the data pointer and rank from the descriptor. */ - gfc_conv_expr_descriptor (&se, e, se.ss); - tmp = gfc_conv_descriptor_data_get (se.expr); - se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); + if (is_aliased_array (e)) + { + /* Use a temporary for components of arrays of derived types + or substring array references. */ + gfc_conv_aliased_arg (&se, e, 0, + last_dt == READ ? INTENT_IN : INTENT_OUT); + tmp = build_fold_indirect_ref (se.expr); + se.expr = gfc_build_addr_expr (pchar_type_node, tmp); + tmp = gfc_conv_descriptor_data_get (tmp); + } + else + { + /* Return the data pointer and rank from the descriptor. */ + gfc_conv_expr_descriptor (&se, e, se.ss); + tmp = gfc_conv_descriptor_data_get (se.expr); + se.expr = gfc_build_addr_expr (pchar_type_node, se.expr); + } } else gcc_unreachable (); @@ -634,10 +648,12 @@ set_internal_unit (stmtblock_t * block, tree var, gfc_expr * e) /* The cast is needed for character substrings and the descriptor data. */ gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp)); - gfc_add_modify_expr (&se.pre, len, se.string_length); + gfc_add_modify_expr (&se.pre, len, + fold_convert (TREE_TYPE (len), se.string_length)); gfc_add_modify_expr (&se.pre, desc, se.expr); gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (post_block, &se.post); return mask; } @@ -1370,7 +1386,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, static tree build_dt (tree function, gfc_code * code) { - stmtblock_t block, post_block, post_end_block; + stmtblock_t block, post_block, post_end_block, post_iu_block; gfc_dt *dt; tree tmp, var; gfc_expr *nmlname; @@ -1380,6 +1396,7 @@ build_dt (tree function, gfc_code * code) gfc_start_block (&block); gfc_init_block (&post_block); gfc_init_block (&post_end_block); + gfc_init_block (&post_iu_block); var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm"); @@ -1410,7 +1427,8 @@ build_dt (tree function, gfc_code * code) { if (dt->io_unit->ts.type == BT_CHARACTER) { - mask |= set_internal_unit (&block, var, dt->io_unit); + mask |= set_internal_unit (&block, &post_iu_block, + var, dt->io_unit); set_parameter_const (&block, var, IOPARM_common_unit, 0); } else @@ -1501,6 +1519,8 @@ build_dt (tree function, gfc_code * code) gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next)); + gfc_add_block_to_block (&block, &post_iu_block); + dt_parm = NULL; dt_post_end_block = NULL; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 20fe4025d081..409e1fca1d0a 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -2843,7 +2843,8 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, static tree gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask, bool invert, - tree count1, tree count2) + tree count1, tree count2, + gfc_symbol *sym) { gfc_se lse; gfc_se rse; @@ -2957,8 +2958,12 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr); /* Use the scalar assignment as is. */ - tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - loop.temp_ss != NULL, false); + if (sym == NULL) + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + loop.temp_ss != NULL, false); + else + tmp = gfc_conv_operator_assign (&lse, &rse, sym); + tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&body, tmp); @@ -3067,6 +3072,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, tree ppmask = NULL_TREE; tree cmask = NULL_TREE; tree pmask = NULL_TREE; + gfc_actual_arglist *arg; /* the WHERE statement or the WHERE construct statement. */ cblock = code->block; @@ -3178,13 +3184,29 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, switch (cnext->op) { /* WHERE assignment statement. */ + case EXEC_ASSIGN_CALL: + + arg = cnext->ext.actual; + expr1 = expr2 = NULL; + for (; arg; arg = arg->next) + { + if (!arg->expr) + continue; + if (expr1 == NULL) + expr1 = arg->expr; + else + expr2 = arg->expr; + } + goto evaluate; + case EXEC_ASSIGN: expr1 = cnext->expr; expr2 = cnext->expr2; + evaluate: if (nested_forall_info != NULL) { need_temp = gfc_check_dependency (expr1, expr2, 0); - if (need_temp) + if (need_temp && cnext->op != EXEC_ASSIGN_CALL) gfc_trans_assign_need_temp (expr1, expr2, cmask, invert, nested_forall_info, block); @@ -3198,7 +3220,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, - count1, count2); + count1, count2, + cnext->resolved_sym); tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); @@ -3215,7 +3238,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, tmp = gfc_trans_where_assign (expr1, expr2, cmask, invert, - count1, count2); + count1, count2, + cnext->resolved_sym); gfc_add_expr_to_block (block, tmp); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index bded834a6720..2a075094a050 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -303,8 +303,15 @@ void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *); /* Does an intrinsic map directly to an external library call. */ int gfc_is_intrinsic_libcall (gfc_expr *); +/* Used to call the elemental subroutines used in operator assignments. */ +tree gfc_conv_operator_assign (gfc_se *, gfc_se *, gfc_symbol *); + /* Also used to CALL subroutines. */ int gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *); + +void gfc_conv_aliased_arg (gfc_se *, gfc_expr *, int, sym_intent); +bool is_aliased_array (gfc_expr *); + /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */ /* Generate code for a scalar assignment. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 79e1fbac46e2..7f39fbc27b5c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,19 @@ +2007-02-12 Paul Thomas + + PR fortran/30284 + * gfortran.dg/arrayio_11.f90: New test. + + PR fortran/30626 + * gfortran.dg/arrayio_12.f90: New test. + + PR fortran/30407 + * gfortran.dg/where_operator_assign_1.f90: New test. + * gfortran.dg/where_operator_assign_2.f90: New test. + * gfortran.dg/where_operator_assign_3.f90: New test. + + PR fortran/30514 + * gfortran.dg/zero_sized_2.f90: New test. + 2007-02-10 Tobias Schlüter PR fortran/30478 diff --git a/gcc/testsuite/gfortran.dg/arrayio_11.f90 b/gcc/testsuite/gfortran.dg/arrayio_11.f90 new file mode 100644 index 000000000000..39255dbcdaef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/arrayio_11.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! Tests the fix for PR30284, in which the substring plus +! component reference for an internal file would cause an ICE. +! +! Contributed by Harald Anlauf + +program gfcbug51 + implicit none + + type :: date_t + character(len=12) :: date ! yyyymmddhhmm + end type date_t + + type year_t + integer :: year = 0 + end type year_t + + type(date_t) :: file(3) + type(year_t) :: time(3) + + FILE%date = (/'200612231200', '200712231200', & + '200812231200'/) + + time = date_to_year (FILE) + if (any (time%year .ne. (/2006, 2007, 2008/))) call abort () + + call month_to_date ((/8, 9, 10/), FILE) + if ( any (file%date .ne. (/'200608231200', '200709231200', & + '200810231200'/))) call abort () + +contains + + function date_to_year (d) result (y) + type(date_t) :: d(3) + type(year_t) :: y(size (d, 1)) + read (d%date(1:4),'(i4)') time% year + end function date_to_year + + subroutine month_to_date (m, d) + type(date_t) :: d(3) + integer :: m(:) + write (d%date(5:6),'(i2.2)') m + end subroutine month_to_date + +end program gfcbug51 diff --git a/gcc/testsuite/gfortran.dg/arrayio_12.f90 b/gcc/testsuite/gfortran.dg/arrayio_12.f90 new file mode 100644 index 000000000000..ca010479bd2d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/arrayio_12.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! Tests the fix for PR30626, in which the substring reference +! for an internal file would cause an ICE. +! +! Contributed by Francois-Xavier Coudert + +program gfcbug51 + implicit none + + character(len=12) :: cdate(3) ! yyyymmddhhmm + + type year_t + integer :: year = 0 + end type year_t + + type(year_t) :: time(3) + + cdate = (/'200612231200', '200712231200', & + '200812231200'/) + + time = date_to_year (cdate) + if (any (time%year .ne. (/2006, 2007, 2008/))) call abort () + + call month_to_date ((/8, 9, 10/), cdate) + if ( any (cdate .ne. (/'200608231200', '200709231200', & + '200810231200'/))) call abort () + +contains + + function date_to_year (d) result (y) + character(len=12) :: d(3) + type(year_t) :: y(size (d, 1)) + read (cdate(:)(1:4),'(i4)') time% year + end function date_to_year + + subroutine month_to_date (m, d) + character(len=12) :: d(3) + integer :: m(:) + write (cdate(:)(5:6),'(i2.2)') m + end subroutine month_to_date + +end program gfcbug51 diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 new file mode 100644 index 000000000000..c2b4abf85189 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/where_operator_assign_1.f90 @@ -0,0 +1,108 @@ +! { dg-do compile } +! Tests the fix for PR30407, in which operator assignments did not work +! in WHERE blocks or simple WHERE statements. This is the test provided +! by the reporter. +! +! Contributed by Dominique d'Humieres +!============================================================================== + +MODULE kind_mod + + IMPLICIT NONE + + PRIVATE + + INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9) + INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4) + +END MODULE kind_mod + +!============================================================================== + +MODULE pointer_mod + + USE kind_mod, ONLY : I4 + + IMPLICIT NONE + + PRIVATE + + TYPE, PUBLIC :: pvt + INTEGER(I4), POINTER, DIMENSION(:) :: vect + END TYPE pvt + + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE p_to_p + END INTERFACE + + PUBLIC :: ASSIGNMENT(=) + +CONTAINS + + !--------------------------------------------------------------------------- + + PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2) + IMPLICIT NONE + TYPE(pvt), INTENT(OUT) :: a1 + TYPE(pvt), INTENT(IN) :: a2 + a1%vect = a2%vect + END SUBROUTINE p_to_p + + !--------------------------------------------------------------------------- + +END MODULE pointer_mod + +!============================================================================== + +PROGRAM test_prog + + USE pointer_mod, ONLY : pvt, ASSIGNMENT(=) + + USE kind_mod, ONLY : I4, TF + + IMPLICIT NONE + + INTEGER(I4), DIMENSION(12_I4), TARGET :: ia + LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la + TYPE(pvt), DIMENSION(6_I4) :: pv + INTEGER(I4) :: i + + ! Initialisation... + la(:,1_I4:3_I4:2_I4)=.TRUE._TF + la(:,2_I4)=.FALSE._TF + + DO i=1_I4,6_I4 + pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i)) + END DO + + ia=0_I4 + + DO i=1_I4,3_I4 + WHERE(la((/1_I4,2_I4/),i)) + pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/)) + ELSEWHERE + pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/)) + END WHERE + END DO + + if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) call abort () + +CONTAINS + + TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans) + + USE kind_mod, ONLY : I4 + USE pointer_mod, ONLY : pvt, ASSIGNMENT(=) + + IMPLICIT NONE + + INTEGER(I4), INTENT(IN) :: index + + ALLOCATE(ans%vect(2_I4)) + ans%vect=(/index,-index/) + + END FUNCTION iaef + +END PROGRAM test_prog + +! { dg-final { cleanup-modules "kind_mod pointer_mod" } } diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 new file mode 100644 index 000000000000..420103f1978e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/where_operator_assign_2.f90 @@ -0,0 +1,106 @@ +! { dg-do compile } +! Tests the fix for PR30407, in which operator assignments did not work +! in WHERE blocks or simple WHERE statements. +! +! Contributed by Paul Thomas +!****************************************************************************** +module global + type :: a + integer :: b + integer :: c + end type a + interface assignment(=) + module procedure a_to_a + end interface + interface operator(.ne.) + module procedure a_ne_a + end interface + + type(a) :: x(4), y(4), z(4), u(4, 4) + logical :: l1(4), t = .true., f= .false. +contains +!****************************************************************************** + elemental subroutine a_to_a (m, n) + type(a), intent(in) :: n + type(a), intent(out) :: m + m%b = n%b + 1 + m%c = n%c + end subroutine a_to_a +!****************************************************************************** + elemental logical function a_ne_a (m, n) + type(a), intent(in) :: n + type(a), intent(in) :: m + a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c) + end function a_ne_a +!****************************************************************************** + elemental function foo (m) + type(a) :: foo + type(a), intent(in) :: m + foo%b = 0 + foo%c = m%c + end function foo +end module global +!****************************************************************************** +program test + use global + x = (/a (0, 1),a (0, 2),a (0, 3),a (0, 4)/) + y = x + z = x + l1 = (/t, f, f, t/) + + call test_where_1 + if (any (y .ne. (/a (2, 1),a (2, 2),a (2, 3),a (2, 4)/))) call abort () + + call test_where_2 + if (any (y .ne. (/a (1, 0),a (2, 2),a (2, 3),a (1, 0)/))) call abort () + if (any (z .ne. (/a (3, 4),a (1, 0),a (1, 0),a (3, 1)/))) call abort () + + call test_where_3 + if (any (y .ne. (/a (1, 0),a (1, 2),a (1, 3),a (1, 0)/))) call abort () + + y = x + call test_where_forall_1 + if (any (u(4, :) .ne. (/a (1, 4),a (2, 2),a (2, 3),a (1, 4)/))) call abort () + + l1 = (/t, f, t, f/) + call test_where_4 + if (any (x .ne. (/a (1, 1),a (2, 1),a (1, 3),a (2, 3)/))) call abort () + +contains +!****************************************************************************** + subroutine test_where_1 ! Test a simple WHERE + where (l1) y = x + end subroutine test_where_1 +!****************************************************************************** + subroutine test_where_2 ! Test a WHERE blocks + where (l1) + y = a (0, 0) + z = z(4:1:-1) + elsewhere + y = x + z = a (0, 0) + end where + end subroutine test_where_2 +!****************************************************************************** + subroutine test_where_3 ! Test a simple WHERE with a function assignment + where (.not. l1) y = foo (x) + end subroutine test_where_3 +!****************************************************************************** + subroutine test_where_forall_1 ! Test a WHERE in a FORALL block + forall (i = 1:4) + where (.not. l1) + u(i, :) = x + elsewhere + u(i, :) = a(0, i) + endwhere + end forall + end subroutine test_where_forall_1 +!****************************************************************************** + subroutine test_where_4 ! Test a WHERE assignment with dependencies + where (l1(1:3)) + x(2:4) = x(1:3) + endwhere + end subroutine test_where_4 +end program test +! { dg-final { cleanup-modules "global" } } + diff --git a/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 new file mode 100644 index 000000000000..eddbdfc00aff --- /dev/null +++ b/gcc/testsuite/gfortran.dg/where_operator_assign_3.f90 @@ -0,0 +1,81 @@ +! { dg-do compile } +! Tests the fix for PR30407, in which operator assignments did not work +! in WHERE blocks or simple WHERE statements. This tests that the character +! lengths are transmitted OK. +! +! Contributed by Paul Thomas +!****************************************************************************** +module global + type :: a + integer :: b + character(8):: c + end type a + interface assignment(=) + module procedure a_to_a, c_to_a, a_to_c + end interface + interface operator(.ne.) + module procedure a_ne_a + end interface + + type(a) :: x(4), y(4) + logical :: l1(4), t = .true., f= .false. +contains +!****************************************************************************** + elemental subroutine a_to_a (m, n) + type(a), intent(in) :: n + type(a), intent(out) :: m + m%b = len ( trim(n%c)) + m%c = n%c + end subroutine a_to_a + elemental subroutine c_to_a (m, n) + character(8), intent(in) :: n + type(a), intent(out) :: m + m%b = m%b + 1 + m%c = n + end subroutine c_to_a + elemental subroutine a_to_c (m, n) + type(a), intent(in) :: n + character(8), intent(out) :: m + m = n%c + end subroutine a_to_c +!****************************************************************************** + elemental logical function a_ne_a (m, n) + type(a), intent(in) :: n + type(a), intent(in) :: m + a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c) + end function a_ne_a +!****************************************************************************** + elemental function foo (m) + type(a) :: foo + type(a), intent(in) :: m + foo%b = 0 + foo%c = m%c + end function foo +end module global +!****************************************************************************** +program test + use global + x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/) + y = x + l1 = (/t,f,f,t/) + + call test_where_char1 + call test_where_char2 + if (any(y .ne. & + (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort () +contains + subroutine test_where_char1 ! Test a WHERE blocks + where (l1) + y = a (0, "null") + elsewhere + y = x + end where + end subroutine test_where_char1 + subroutine test_where_char2 ! Test a WHERE blocks + where (y%c .ne. "null") + y = a (99, "non-null") + endwhere + end subroutine test_where_char2 +end program test +! { dg-final { cleanup-modules "global" } } + diff --git a/gcc/testsuite/gfortran.dg/zero_sized_2.f90 b/gcc/testsuite/gfortran.dg/zero_sized_2.f90 new file mode 100644 index 000000000000..eda2de226733 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/zero_sized_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests the fix for PR30514 in which the bounds on m would cause an +! error and the rest would cause the compiler to go into an infinite +! loop. +! Contributed by Tobias Burnus +! +integer :: i(2:0), j(1:0), m(1:-1) +integer, parameter :: k(2:0) = 0, l(1:0) = 0 +i = k +j = l +m = 5 +end + diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index c6c5dce68cc8..4681763939aa 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,10 @@ +2007-02-12 Paul Thomas + + PR fortran/30284 + PR fortran/30626 + * io/transfer.c (init_loop_spec, next_array_record): Change to + lbound rather than unity base. + 2007-01-30 Thomas Koenig Backport from trunk diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 074ef9c427fe..92012a9d0ff6 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -2003,7 +2003,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls) index = 1; for (i=0; idim[i].lbound; ls[i].start = desc->dim[i].lbound; ls[i].end = desc->dim[i].ubound; ls[i].step = desc->dim[i].stride; @@ -2040,8 +2040,9 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls) else carry = 0; } - index = index + (ls[i].idx - 1) * ls[i].step; + index = index + (ls[i].idx - ls[i].start) * ls[i].step; } + return index; }