mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-21 00:30:36 +08:00
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
This commit is contained in:
Jakub Jelinek
Jakub Jelinek
parent
6d21c8af17
commit
24722ea98e
@ -1,3 +1,7 @@
|
||||
2008-04-09 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
* gfortran.dg/namelist_47.f90: New test.
|
||||
|
||||
2008-04-09 Richard Guenther <rguenther@suse.de>
|
||||
|
||||
* gfortran.dg/bind_c_usage_14.f03: Adjust.
|
||||
|
||||
52
gcc/testsuite/gfortran.dg/namelist_47.f90
Normal file
52
gcc/testsuite/gfortran.dg/namelist_47.f90
Normal file
@ -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" } }
|
||||
@ -1,3 +1,17 @@
|
||||
2008-04-09 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
* 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 <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR fortran/25829 28655
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user