From: Francois-Xavier Coudert Date: Tue, 3 Apr 2007 21:05:14 +0000 (+0000) Subject: re PR fortran/31304 (REPEAT argument NCOPIES is not converted as it should) X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=f1412ca58a77159d46432eae4eb56ea9edf432b4;p=platform%2Fupstream%2Fgcc.git re PR fortran/31304 (REPEAT argument NCOPIES is not converted as it should) PR fortran/31304 * fortran/gfortran.h (gfc_charlen_int_kind): New prototype. * fortran/trans-types.c (gfc_charlen_int_kind): New variable. (gfc_init_types): Define gfc_charlen_int_kind. * fortran/trans.h (gfor_fndecl_string_repeat): Remove prototype. * fortran/trans-decl.c (gfor_fndecl_string_repeat): Delete. (gfc_build_intrinsic_function_decls): Don't set gfor_fndecl_string_repeat. * fortran/trans-intrinsic.c (gfc_conv_intrinsic_repeat): Rewrite so that we don't have to call a library function. * fortran/simplify.c (gfc_simplify_repeat): Perform the necessary checks on the NCOPIES argument, and work with arbitrary size arguments. * intrinsics/string_intrinsics.c (string_repeat): Remove. * gfortran.dg/repeat_2.f90: New test. * gfortran.dg/repeat_3.f90: New test. * gfortran.dg/repeat_4.f90: New test. From-SVN: r123481 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2b113f4..f43ac73 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2007-04-03 Francois-Xavier Coudert + + PR fortran/31304 + * fortran/gfortran.h (gfc_charlen_int_kind): New prototype. + * fortran/trans-types.c (gfc_charlen_int_kind): New variable. + (gfc_init_types): Define gfc_charlen_int_kind. + * fortran/trans.h (gfor_fndecl_string_repeat): Remove prototype. + * fortran/trans-decl.c (gfor_fndecl_string_repeat): Delete. + (gfc_build_intrinsic_function_decls): Don't set + gfor_fndecl_string_repeat. + * fortran/trans-intrinsic.c (gfc_conv_intrinsic_repeat): Rewrite + so that we don't have to call a library function. + * fortran/simplify.c (gfc_simplify_repeat): Perform the necessary + checks on the NCOPIES argument, and work with arbitrary size + arguments. + 2007-03-31 Tobias Burnus * intrinsic.c (add_functions): Fix name of dummy argument diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index cd1d7616..3ef4902 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1844,6 +1844,7 @@ extern int gfc_default_logical_kind; extern int gfc_default_complex_kind; extern int gfc_c_int_kind; extern int gfc_intio_kind; +extern int gfc_charlen_int_kind; extern int gfc_numeric_storage_size; extern int gfc_character_storage_size; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 8c6847b..27f30ae 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -2788,23 +2788,76 @@ gfc_expr * gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) { gfc_expr *result; - int i, j, len, ncopies, nlen; + int i, j, len, ncop, nlen; + mpz_t ncopies; - if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT) + /* If NCOPIES isn't a constant, there's nothing we can do. */ + if (n->expr_type != EXPR_CONSTANT) return NULL; - if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0)) + /* If NCOPIES is negative, it's an error. */ + if (mpz_sgn (n->value.integer) < 0) { - gfc_error ("Invalid second argument of REPEAT at %L", &n->where); + gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L", + &n->where); return &gfc_bad_expr; } + /* If we don't know the character length, we can do no more. */ + if (e->ts.cl == NULL || e->ts.cl->length == NULL + || e->ts.cl->length->expr_type != EXPR_CONSTANT) + return NULL; + + /* If the source length is 0, any value of NCOPIES is valid + and everything behaves as if NCOPIES == 0. */ + mpz_init (ncopies); + if (mpz_sgn (e->ts.cl->length->value.integer) == 0) + mpz_set_ui (ncopies, 0); + else + mpz_set (ncopies, n->value.integer); + + /* Check that NCOPIES isn't too large. */ + if (mpz_sgn (e->ts.cl->length->value.integer) != 0) + { + mpz_t max; + int i; + + /* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */ + mpz_init (max); + i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); + mpz_tdiv_q (max, gfc_integer_kinds[i].huge, + e->ts.cl->length->value.integer); + + /* The check itself. */ + if (mpz_cmp (ncopies, max) > 0) + { + mpz_clear (max); + mpz_clear (ncopies); + gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L", + &n->where); + return &gfc_bad_expr; + } + + mpz_clear (max); + } + mpz_clear (ncopies); + + /* For further simplication, we need the character string to be + constant. */ + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpz_sgn (e->ts.cl->length->value.integer) != 0) + gcc_assert (gfc_extract_int (n, &ncop) == NULL); + else + ncop = 0; + len = e->value.character.length; - nlen = ncopies * len; + nlen = ncop * len; result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); - if (ncopies == 0) + if (ncop == 0) { result->value.character.string = gfc_getmem (1); result->value.character.length = 0; @@ -2815,7 +2868,7 @@ gfc_simplify_repeat (gfc_expr *e, gfc_expr *n) result->value.character.length = nlen; result->value.character.string = gfc_getmem (nlen + 1); - for (i = 0; i < ncopies; i++) + for (i = 0; i < ncop; i++) for (j = 0; j < len; j++) result->value.character.string[j + i * len] = e->value.character.string[j]; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index f8be3df5..6cd1304 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -129,7 +129,6 @@ tree gfor_fndecl_string_index; tree gfor_fndecl_string_scan; tree gfor_fndecl_string_verify; tree gfor_fndecl_string_trim; -tree gfor_fndecl_string_repeat; tree gfor_fndecl_adjustl; tree gfor_fndecl_adjustr; @@ -2036,15 +2035,6 @@ gfc_build_intrinsic_function_decls (void) gfc_charlen_type_node, pchar_type_node); - gfor_fndecl_string_repeat = - gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")), - void_type_node, - 4, - pchar_type_node, - gfc_charlen_type_node, - pchar_type_node, - gfc_int4_type_node); - gfor_fndecl_ttynam = gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")), void_type_node, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 4465030..25c8e1e 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -3378,41 +3378,111 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) { - tree gfc_int4_type_node = gfc_get_int_type (4); - tree tmp; - tree len; - tree args; - tree ncopies; - tree var; - tree type; - tree cond; + tree args, ncopies, dest, dlen, src, slen, ncopies_type; + tree type, cond, tmp, count, exit_label, n, max, largest; + stmtblock_t block, body; + int i; + /* Get the arguments. */ args = gfc_conv_intrinsic_function_args (se, expr); - len = TREE_VALUE (args); - tmp = gfc_advance_chain (args, 2); - ncopies = TREE_VALUE (tmp); - - /* Check that ncopies is not negative. */ + slen = fold_convert (size_type_node, gfc_evaluate_now (TREE_VALUE (args), + &se->pre)); + src = TREE_VALUE (TREE_CHAIN (args)); + ncopies = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args))); ncopies = gfc_evaluate_now (ncopies, &se->pre); + ncopies_type = TREE_TYPE (ncopies); + + /* Check that NCOPIES is not negative. */ cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies, - build_int_cst (TREE_TYPE (ncopies), 0)); + build_int_cst (ncopies_type, 0)); gfc_trans_runtime_check (cond, "Argument NCOPIES of REPEAT intrinsic is negative", &se->pre, &expr->where); + /* If the source length is zero, any non negative value of NCOPIES + is valid, and nothing happens. */ + n = gfc_create_var (ncopies_type, "ncopies"); + cond = fold_build2 (EQ_EXPR, boolean_type_node, slen, + build_int_cst (size_type_node, 0)); + tmp = fold_build3 (COND_EXPR, ncopies_type, cond, + build_int_cst (ncopies_type, 0), ncopies); + gfc_add_modify_expr (&se->pre, n, tmp); + ncopies = n; + + /* Check that ncopies is not too large: ncopies should be less than + (or equal to) MAX / slen, where MAX is the maximal integer of + the gfc_charlen_type_node type. If slen == 0, we need a special + case to avoid the division by zero. */ + i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); + max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind); + max = fold_build2 (TRUNC_DIV_EXPR, size_type_node, + fold_convert (size_type_node, max), slen); + largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type) + ? size_type_node : ncopies_type; + cond = fold_build2 (GT_EXPR, boolean_type_node, + fold_convert (largest, ncopies), + fold_convert (largest, max)); + tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen, + build_int_cst (size_type_node, 0)); + cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node, + cond); + gfc_trans_runtime_check (cond, + "Argument NCOPIES of REPEAT intrinsic is too large", + &se->pre, &expr->where); + /* Compute the destination length. */ - len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies); + dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen, ncopies); type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); - var = gfc_conv_string_tmp (se, build_pointer_type (type), len); + dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen); + + /* Generate the code to do the repeat operation: + for (i = 0; i < ncopies; i++) + memmove (dest + (i * slen), src, slen); */ + gfc_start_block (&block); + count = gfc_create_var (ncopies_type, "count"); + gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0)); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Start the loop body. */ + gfc_start_block (&body); - /* Create the argument list and generate the function call. */ - tmp = build_call_expr (gfor_fndecl_string_repeat, 4, var, - TREE_VALUE (args), - TREE_VALUE (TREE_CHAIN (args)), ncopies); + /* Exit the loop if count >= ncopies. */ + cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies); + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, + build_empty_stmt ()); + gfc_add_expr_to_block (&body, tmp); + + /* Call memmove (dest + (i*slen), src, slen). */ + tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen, + fold_convert (gfc_charlen_type_node, count)); + tmp = fold_build2 (PLUS_EXPR, pchar_type_node, dest, + fold_convert (pchar_type_node, tmp)); + tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, + tmp, src, slen); + gfc_add_expr_to_block (&body, tmp); + + /* Increment count. */ + tmp = build2 (PLUS_EXPR, ncopies_type, count, + build_int_cst (TREE_TYPE (count), 1)); + gfc_add_modify_expr (&body, count, tmp); + + /* Build the loop. */ + tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body)); + gfc_add_expr_to_block (&block, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + /* Finish the block. */ + tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&se->pre, tmp); - se->expr = var; - se->string_length = len; + /* Set the result value. */ + se->expr = dest; + se->string_length = dlen; } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 80cdb25..c0233a1 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -97,6 +97,9 @@ int gfc_c_int_kind; kind=8, this will be set to 8, otherwise it is set to 4. */ int gfc_intio_kind; +/* The integer kind used to store character lengths. */ +int gfc_charlen_int_kind; + /* The size of the numeric storage unit and character storage unit. */ int gfc_numeric_storage_size; int gfc_character_storage_size; @@ -607,7 +610,8 @@ gfc_init_types (void) boolean_false_node = build_int_cst (boolean_type_node, 0); /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */ - gfc_charlen_type_node = gfc_get_int_type (4); + gfc_charlen_int_kind = 4; + gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind); } /* Get the type node for the given type and kind. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index a66ad39..97d4d0f 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -533,7 +533,6 @@ extern GTY(()) tree gfor_fndecl_string_index; extern GTY(()) tree gfor_fndecl_string_scan; extern GTY(()) tree gfor_fndecl_string_verify; extern GTY(()) tree gfor_fndecl_string_trim; -extern GTY(()) tree gfor_fndecl_string_repeat; extern GTY(()) tree gfor_fndecl_adjustl; extern GTY(()) tree gfor_fndecl_adjustr; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1f3c024..b9c4127 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2007-04-03 Francois-Xavier Coudert + + PR fortran/31304 + * gfortran.dg/repeat_2.f90: New test. + * gfortran.dg/repeat_3.f90: New test. + * gfortran.dg/repeat_4.f90: New test. + 2007-04-03 Uros Bizjak * gcc.dg/tls/opt-3.c: Use -mregparm=3 only for ilp32 on x86_64 targets. diff --git a/gcc/testsuite/gfortran.dg/repeat_2.f90 b/gcc/testsuite/gfortran.dg/repeat_2.f90 new file mode 100644 index 0000000..d38718a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/repeat_2.f90 @@ -0,0 +1,92 @@ +! REPEAT intrinsic +! +! { dg-do run } +subroutine foo(i, j, s, t) + implicit none + integer, intent(in) :: i, j + character(len=i), intent(in) :: s + character(len=i*j), intent(in) :: t + + if (repeat(s,j) /= t) call abort + call bar(j,s,t) +end subroutine foo + +subroutine bar(j, s, t) + implicit none + integer, intent(in) :: j + character(len=*), intent(in) :: s + character(len=len(s)*j), intent(in) :: t + + if (repeat(s,j) /= t) call abort +end subroutine bar + +program test + implicit none + character(len=0), parameter :: s0 = "" + character(len=1), parameter :: s1 = "a" + character(len=2), parameter :: s2 = "ab" + character(len=0) :: t0 + character(len=1) :: t1 + character(len=2) :: t2 + integer :: i + + t0 = "" + t1 = "a" + t2 = "ab" + + if (repeat(t0, 0) /= "") call abort + if (repeat(t1, 0) /= "") call abort + if (repeat(t2, 0) /= "") call abort + if (repeat(t0, 1) /= "") call abort + if (repeat(t1, 1) /= "a") call abort + if (repeat(t2, 1) /= "ab") call abort + if (repeat(t0, 2) /= "") call abort + if (repeat(t1, 2) /= "aa") call abort + if (repeat(t2, 2) /= "abab") call abort + + if (repeat(s0, 0) /= "") call abort + if (repeat(s1, 0) /= "") call abort + if (repeat(s2, 0) /= "") call abort + if (repeat(s0, 1) /= "") call abort + if (repeat(s1, 1) /= "a") call abort + if (repeat(s2, 1) /= "ab") call abort + if (repeat(s0, 2) /= "") call abort + if (repeat(s1, 2) /= "aa") call abort + if (repeat(s2, 2) /= "abab") call abort + + i = 0 + if (repeat(t0, i) /= "") call abort + if (repeat(t1, i) /= "") call abort + if (repeat(t2, i) /= "") call abort + i = 1 + if (repeat(t0, i) /= "") call abort + if (repeat(t1, i) /= "a") call abort + if (repeat(t2, i) /= "ab") call abort + i = 2 + if (repeat(t0, i) /= "") call abort + if (repeat(t1, i) /= "aa") call abort + if (repeat(t2, i) /= "abab") call abort + + i = 0 + if (repeat(s0, i) /= "") call abort + if (repeat(s1, i) /= "") call abort + if (repeat(s2, i) /= "") call abort + i = 1 + if (repeat(s0, i) /= "") call abort + if (repeat(s1, i) /= "a") call abort + if (repeat(s2, i) /= "ab") call abort + i = 2 + if (repeat(s0, i) /= "") call abort + if (repeat(s1, i) /= "aa") call abort + if (repeat(s2, i) /= "abab") call abort + + call foo(0,0,"","") + call foo(0,1,"","") + call foo(0,2,"","") + call foo(1,0,"a","") + call foo(1,1,"a","a") + call foo(1,2,"a","aa") + call foo(2,0,"ab","") + call foo(2,1,"ab","ab") + call foo(2,2,"ab","abab") +end program test diff --git a/gcc/testsuite/gfortran.dg/repeat_3.f90 b/gcc/testsuite/gfortran.dg/repeat_3.f90 new file mode 100644 index 0000000..d571fc6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/repeat_3.f90 @@ -0,0 +1,29 @@ +! REPEAT intrinsic, test for PR 31304 +! We check that REPEAT accepts all kind arguments for NCOPIES +! +! { dg-do run } +program test + implicit none + + integer(kind=1) i1 + integer(kind=2) i2 + integer(kind=4) i4 + integer(kind=4) i8 + real(kind=8) r + character(len=2) s1, s2 + + i1 = 1 ; i2 = 1 ; i4 = 1 ; i8 = 1 + r = 1 + s1 = '42' + r = nearest(r,r) + + s2 = repeat(s1,i1) + if (s2 /= s1) call abort + s2 = repeat(s1,i2) + if (s2 /= s1) call abort + s2 = repeat(s1,i4) + if (s2 /= s1) call abort + s2 = repeat(s1,i8) + if (s2 /= s1) call abort + +end program test diff --git a/gcc/testsuite/gfortran.dg/repeat_4.f90 b/gcc/testsuite/gfortran.dg/repeat_4.f90 new file mode 100644 index 0000000..de74d4e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/repeat_4.f90 @@ -0,0 +1,38 @@ +! REPEAT intrinsic -- various checks should be enforced +! +! { dg-do compile } +program test + implicit none + character(len=0), parameter :: s0 = "" + character(len=1), parameter :: s1 = "a" + character(len=2), parameter :: s2 = "ab" + character(len=0) :: t0 + character(len=1) :: t1 + character(len=2) :: t2 + + t0 = "" ; t1 = "a" ; t2 = "ab" + + ! Check for negative NCOPIES argument + print *, repeat(s0, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(s1, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(s2, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(t0, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(t1, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + print *, repeat(t2, -1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is negative" } + + ! Check for too large NCOPIES argument and limit cases + print *, repeat(t0, huge(0)) + print *, repeat(t1, huge(0)) + print *, repeat(t2, huge(0)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(s2, huge(0)) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + + print *, repeat(t0, huge(0)/2) + print *, repeat(t1, huge(0)/2) + print *, repeat(t2, huge(0)/2) + + print *, repeat(t0, huge(0)/2+1) + print *, repeat(t1, huge(0)/2+1) + print *, repeat(t2, huge(0)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + print *, repeat(s2, huge(0)/2+1) ! { dg-error "Argument NCOPIES of REPEAT intrinsic is too large " } + +end program test diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index d360b6c..87ad838 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,8 @@ +2007-04-03 Francois-Xavier Coudert + + PR fortran/31304 + intrinsics/string_intrinsics.c (string_repeat): Remove. + 2007-04-01 Jerry DeLisle PR libgfortran/31052 diff --git a/libgfortran/intrinsics/string_intrinsics.c b/libgfortran/intrinsics/string_intrinsics.c index 86ef9d4..1a4b159 100644 --- a/libgfortran/intrinsics/string_intrinsics.c +++ b/libgfortran/intrinsics/string_intrinsics.c @@ -73,9 +73,6 @@ export_proto(string_verify); extern void string_trim (GFC_INTEGER_4 *, void **, GFC_INTEGER_4, const char *); export_proto(string_trim); -extern void string_repeat (char *, GFC_INTEGER_4, const char *, GFC_INTEGER_4); -export_proto(string_repeat); - /* Strings of unequal length are extended with pad characters. */ GFC_INTEGER_4 @@ -352,20 +349,3 @@ string_verify (GFC_INTEGER_4 slen, const char * str, GFC_INTEGER_4 setlen, return 0; } - - -/* Concatenate several copies of a string. */ - -void -string_repeat (char * dest, GFC_INTEGER_4 slen, - const char * src, GFC_INTEGER_4 ncopies) -{ - int i; - - /* We don't need to check that ncopies is non-negative here, because - the front-end already generates code for that check. */ - for (i = 0; i < ncopies; i++) - { - memmove (dest + (i * slen), src, slen); - } -}