From 24722ea98e979fd3c7a0e82c8f422544fa5cd947 Mon Sep 17 00:00:00 2001 From: Jakub Jelinek Date: Wed, 9 Apr 2008 11:00:31 +0200 Subject: [PATCH] list_read.c (snprintf): Define if HAVE_SNPRINTF isn't defined. * io/list_read.c (snprintf): Define if HAVE_SNPRINTF isn't defined. (nml_read_obj): Add nml_err_msg_size argument. Pass it down to recursive call. Use snprintf instead of sprintf when %s nl->var_name is used. (nml_get_obj_data): Add nml_err_msg_size argument. Pass it down to nml_read_obj call. Use snprintf instead of sprintf when %s nl->var_name is used. Pass nml_err_msg to nml_parse_qualifier instead of parse_err_msg array. Append " for namelist variable " and nl->var_name to it. (namelist_read): Increase size of nml_err_msg array to 200. Pass sizeof nml_err_msg as extra argument to nml_get_obj_data. * gfortran.dg/namelist_47.f90: New test. From-SVN: r134132 --- gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gfortran.dg/namelist_47.f90 | 52 ++++++++++++++ libgfortran/ChangeLog | 14 ++++ libgfortran/io/list_read.c | 85 +++++++++++++---------- 4 files changed, 119 insertions(+), 36 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/namelist_47.f90 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 54c058efce4..49601612d22 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2008-04-09 Jakub Jelinek + + * gfortran.dg/namelist_47.f90: New test. + 2008-04-09 Richard Guenther * gfortran.dg/bind_c_usage_14.f03: Adjust. diff --git a/gcc/testsuite/gfortran.dg/namelist_47.f90 b/gcc/testsuite/gfortran.dg/namelist_47.f90 new file mode 100644 index 00000000000..bc9110fa3cd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_47.f90 @@ -0,0 +1,52 @@ +! { dg-do run } + +module nml_47 + type :: mt + character(len=2) :: c012345678901234567890123456789012345678901234567890123456789h(2) = (/"aa","bb"/) + end type mt + type :: bt + integer :: i(2) = (/1,2/) + type(mt) :: m(2) + end type bt +end module nml_47 + +program namelist_47 + use nml_47 + type(bt) :: x(2) + character(140) :: teststring + namelist /mynml/ x + + teststring = " x(2)%m%c012345678901234567890123456789012345678901234567890123456789h(:)(2:2) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(:)(2) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(:)(:3) = 'z','z'," + call writenml (teststring) + teststring = " x(2)%m(2)%c012345678901234567890123456789012345678901234567890123456789h(1:2)(k:) = 'z','z'," + call writenml (teststring) + +contains + +subroutine writenml (astring) + character(140), intent(in) :: astring + character(300) :: errmessage + integer :: ierror + + open (10, status="scratch", delim='apostrophe') + write (10, '(A)') "&MYNML" + write (10, '(A)') astring + write (10, '(A)') "/" + rewind (10) + read (10, nml = mynml, iostat=ierror, iomsg=errmessage) + if (ierror == 0) call abort + print '(a)', trim(errmessage) + close (10) + +end subroutine writenml + +end program namelist_47 +! { dg-output "Multiple sub-objects with non-zero rank in namelist object x(\n|\r\n|\r)" } +! { dg-output "Missing colon in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\n|\r\n|\r)" } +! { dg-output "Substring out of range for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\n|\r\n|\r)" } +! { dg-output "Bad character in substring qualifier for namelist variable x%m%c012345678901234567890123456789012345678901234567890123456789h(\n|\r\n|\r)" } +! { dg-final { cleanup-modules "nml_47" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 631d1ac43f1..e5908bb79ca 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,17 @@ +2008-04-09 Jakub Jelinek + + * io/list_read.c (snprintf): Define if HAVE_SNPRINTF isn't defined. + (nml_read_obj): Add nml_err_msg_size argument. Pass it down to + recursive call. Use snprintf instead of sprintf when %s nl->var_name + is used. + (nml_get_obj_data): Add nml_err_msg_size argument. Pass it down to + nml_read_obj call. Use snprintf instead of sprintf when %s + nl->var_name is used. Pass nml_err_msg to nml_parse_qualifier instead + of parse_err_msg array. Append " for namelist variable " and + nl->var_name to it. + (namelist_read): Increase size of nml_err_msg array to 200. Pass + sizeof nml_err_msg as extra argument to nml_get_obj_data. + 2008-04-07 Jerry DeLisle PR fortran/25829 28655 diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 89c55c7c51b..802bf9e7706 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -65,6 +65,10 @@ Boston, MA 02110-1301, USA. */ #define MAX_REPEAT 200000000 +#ifndef HAVE_SNPRINTF +# undef snprintf +# define snprintf(str, size, ...) sprintf (str, __VA_ARGS__) +#endif /* Save a character to a string buffer, enlarging it as necessary. */ @@ -1912,7 +1916,7 @@ calls: static void nml_match_name (char *name, int len) static int nml_query (st_parameter_dt *dtp) static int nml_get_obj_data (st_parameter_dt *dtp, - namelist_info **prev_nl, char *) + namelist_info **prev_nl, char *, size_t) calls: static void nml_untouch_nodes (st_parameter_dt *dtp) static namelist_info * find_nml_node (st_parameter_dt *dtp, @@ -1921,7 +1925,7 @@ calls: array_loop_spec * ls, int rank, char *) static void nml_touch_nodes (namelist_info * nl) static int nml_read_obj (namelist_info *nl, index_type offset, - namelist_info **prev_nl, char *, + namelist_info **prev_nl, char *, size_t, index_type clow, index_type chigh) calls: -itself- */ @@ -2335,7 +2339,7 @@ query_return: static try nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, namelist_info **pprev_nl, char *nml_err_msg, - index_type clow, index_type chigh) + size_t nml_err_msg_size, index_type clow, index_type chigh) { namelist_info * cmp; char * obj_name; @@ -2453,8 +2457,8 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, { if (nml_read_obj (dtp, cmp, (index_type)(pdata - nl->mem_pos), - pprev_nl, nml_err_msg, clow, chigh) - == FAILURE) + pprev_nl, nml_err_msg, nml_err_msg_size, + clow, chigh) == FAILURE) { free_mem (obj_name); return FAILURE; @@ -2471,8 +2475,8 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset, goto incr_idx; default: - sprintf (nml_err_msg, "Bad type for namelist object %s", - nl->var_name); + snprintf (nml_err_msg, nml_err_msg_size, + "Bad type for namelist object %s", nl->var_name); internal_error (&dtp->common, nml_err_msg); goto nml_err_ret; } @@ -2560,9 +2564,9 @@ incr_idx: if (dtp->u.p.repeat_count > 1) { - sprintf (nml_err_msg, "Repeat count too large for namelist object %s" , - nl->var_name ); - goto nml_err_ret; + snprintf (nml_err_msg, nml_err_msg_size, + "Repeat count too large for namelist object %s", nl->var_name); + goto nml_err_ret; } return SUCCESS; @@ -2580,7 +2584,7 @@ nml_err_ret: static try nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, - char *nml_err_msg) + char *nml_err_msg, size_t nml_err_msg_size) { char c; namelist_info * nl; @@ -2588,7 +2592,6 @@ nml_get_obj_data (st_parameter_dt *dtp, namelist_info **pprev_nl, namelist_info * root_nl = NULL; int dim, parsed_rank; int component_flag; - char parse_err_msg[30]; index_type clow, chigh; int non_zero_rank_count; @@ -2687,12 +2690,13 @@ get_name: if (nl == NULL) { if (dtp->u.p.nml_read_error && *pprev_nl) - sprintf (nml_err_msg, "Bad data for namelist object %s", - (*pprev_nl)->var_name); + snprintf (nml_err_msg, nml_err_msg_size, + "Bad data for namelist object %s", (*pprev_nl)->var_name); else - sprintf (nml_err_msg, "Cannot match namelist object name %s", - dtp->u.p.saved_string); + snprintf (nml_err_msg, nml_err_msg_size, + "Cannot match namelist object name %s", + dtp->u.p.saved_string); goto nml_err_ret; } @@ -2714,10 +2718,12 @@ get_name: { parsed_rank = 0; if (nml_parse_qualifier (dtp, nl->dim, nl->ls, nl->var_rank, - parse_err_msg, &parsed_rank) == FAILURE) + nml_err_msg, &parsed_rank) == FAILURE) { - sprintf (nml_err_msg, "%s for namelist variable %s", - parse_err_msg, nl->var_name); + char *nml_err_msg_end = strchr (nml_err_msg, '\0'); + snprintf (nml_err_msg_end, + nml_err_msg_size - (nml_err_msg_end - nml_err_msg), + " for namelist variable %s", nl->var_name); goto nml_err_ret; } @@ -2738,8 +2744,8 @@ get_name: { if (nl->type != GFC_DTYPE_DERIVED) { - sprintf (nml_err_msg, "Attempt to get derived component for %s", - nl->var_name); + snprintf (nml_err_msg, nml_err_msg_size, + "Attempt to get derived component for %s", nl->var_name); goto nml_err_ret; } @@ -2763,11 +2769,13 @@ get_name: descriptor_dimension chd[1] = { {1, clow, nl->string_length} }; array_loop_spec ind[1] = { {1, clow, nl->string_length, 1} }; - if (nml_parse_qualifier (dtp, chd, ind, -1, parse_err_msg, &parsed_rank) + if (nml_parse_qualifier (dtp, chd, ind, -1, nml_err_msg, &parsed_rank) == FAILURE) { - sprintf (nml_err_msg, "%s for namelist variable %s", - parse_err_msg, nl->var_name); + char *nml_err_msg_end = strchr (nml_err_msg, '\0'); + snprintf (nml_err_msg_end, + nml_err_msg_size - (nml_err_msg_end - nml_err_msg), + " for namelist variable %s", nl->var_name); goto nml_err_ret; } @@ -2776,9 +2784,9 @@ get_name: if (ind[0].step != 1) { - sprintf (nml_err_msg, - "Step not allowed in substring qualifier" - " for namelist object %s", nl->var_name); + snprintf (nml_err_msg, nml_err_msg_size, + "Step not allowed in substring qualifier" + " for namelist object %s", nl->var_name); goto nml_err_ret; } @@ -2799,16 +2807,18 @@ get_name: if (c == '(') { - sprintf (nml_err_msg, "Qualifier for a scalar or non-character" - " namelist object %s", nl->var_name); + snprintf (nml_err_msg, nml_err_msg_size, + "Qualifier for a scalar or non-character namelist object %s", + nl->var_name); goto nml_err_ret; } /* Make sure there is no more than one non-zero rank object. */ if (non_zero_rank_count > 1) { - sprintf (nml_err_msg, "Multiple sub-objects with non-zero rank in" - " namelist object %s", nl->var_name); + snprintf (nml_err_msg, nml_err_msg_size, + "Multiple sub-objects with non-zero rank in namelist object %s", + nl->var_name); non_zero_rank_count = 0; goto nml_err_ret; } @@ -2832,12 +2842,14 @@ get_name: if (c != '=') { - sprintf (nml_err_msg, "Equal sign must follow namelist object name %s", - nl->var_name); + snprintf (nml_err_msg, nml_err_msg_size, + "Equal sign must follow namelist object name %s", + nl->var_name); goto nml_err_ret; } - if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, clow, chigh) == FAILURE) + if (nml_read_obj (dtp, nl, 0, pprev_nl, nml_err_msg, nml_err_msg_size, + clow, chigh) == FAILURE) goto nml_err_ret; return SUCCESS; @@ -2856,7 +2868,7 @@ namelist_read (st_parameter_dt *dtp) { char c; jmp_buf eof_jump; - char nml_err_msg[100]; + char nml_err_msg[200]; /* Pointer to the previously read object, in case attempt is made to read new object name. Should this fail, error message can give previous name. */ @@ -2924,7 +2936,8 @@ find_nml_name: while (!dtp->u.p.input_complete) { - if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg) == FAILURE) + if (nml_get_obj_data (dtp, &prev_nl, nml_err_msg, sizeof nml_err_msg) + == FAILURE) { gfc_unit *u; -- 2.30.2