From: burnus Date: Wed, 15 Nov 2006 10:13:16 +0000 (+0000) Subject: fortran/ X-Git-Tag: upstream/4.9.2~52027 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=ee3729de252bba2bb3dc3eaa7f22fa91caa7322c;p=platform%2Fupstream%2Flinaro-gcc.git fortran/ 2006-11-15 Tobias Burnus Francois-Xavier Coudert PR fortran/27588 * trans-expr.c (gfc_conv_substring): Add bounds checking. (gfc_conv_variable, gfc_conv_substring_expr): Pass more arguments to gfc_conv_substring. testsuite/ 2006-11-15 Tobias Burnus PR fortran/27588 * gfortran.dg/char_bounds_check_fail_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@118852 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4486399..ea2d741 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,4 +1,12 @@ 2006-11-15 Tobias Burnus + Francois-Xavier Coudert + + PR fortran/27588 + * trans-expr.c (gfc_conv_substring): Add bounds checking. + (gfc_conv_variable, gfc_conv_substring_expr): Pass more + arguments to gfc_conv_substring. + +2006-11-15 Tobias Burnus PR fortran/29806 * parse.c (parse_contained): Check for empty contains statement. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6d8b8b9..984c6d3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -234,13 +234,16 @@ gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock) static void -gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind) +gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, + const char *name, locus *where) { tree tmp; tree type; tree var; + tree fault; gfc_se start; gfc_se end; + char *msg; type = gfc_get_character_type (kind, ref->u.ss.length); type = build_pointer_type (type); @@ -272,6 +275,33 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind) gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node); gfc_add_block_to_block (&se->pre, &end.pre); } + if (flag_bounds_check) + { + /* Check lower bound. */ + fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr, + build_int_cst (gfc_charlen_type_node, 1)); + if (name) + asprintf (&msg, "Substring out of bounds: lower bound of '%s' " + "is less than one", name); + else + asprintf (&msg, "Substring out of bounds: lower bound " + "is less than one"); + gfc_trans_runtime_check (fault, msg, &se->pre, where); + gfc_free (msg); + + /* Check upper bound. */ + fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr, + se->string_length); + if (name) + asprintf (&msg, "Substring out of bounds: upper bound of '%s' " + "exceeds string length", name); + else + asprintf (&msg, "Substring out of bounds: upper bound " + "exceeds string length"); + gfc_trans_runtime_check (fault, msg, &se->pre, where); + gfc_free (msg); + } + tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, build_int_cst (gfc_charlen_type_node, 1), start.expr); @@ -485,7 +515,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) break; case REF_SUBSTRING: - gfc_conv_substring (se, ref, expr->ts.kind); + gfc_conv_substring (se, ref, expr->ts.kind, + expr->symtree->name, &expr->where); break; default: @@ -2958,7 +2989,7 @@ gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1; - gfc_conv_substring(se,ref,expr->ts.kind); + gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0288e55..c485ed6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2006-11-15 Tobias Burnus + PR fortran/27588 + * gfortran.dg/char_bounds_check_fail_1.f90: New test. + +2006-11-15 Tobias Burnus + PR fortran/29806 * gfortran.dg/contains.f90: New test. * gfortran.dg/derived_function_interface_1.f90: Add a dg-warning.