FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/23420 (ICE on invalid print statement)

Browse source 
fortran/
	PR fortran/23420
	* io.c (resolve_tag): Don't allow non-CHARACTER constants as formats.
	(match_io): Fix usage of gfc_find_symbol.
testsuite/
	PR fortran/23420
	* gfortran.dg/print_fmt_4.f: New.

From-SVN: r104454
This commit is contained in:
Tobias Schlüter 2005-09-20 17:05:32 +02:00 • committed by Tobias Schlüter
parent 7a4ef45bf4
commit 7fd4d3123d
4 changed files with 66 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View file

@ -1,3 +1,9 @@
2005-09-20 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/23420
* io.c (resolve_tag): Don't allow non-CHARACTER constants as formats.
(match_io): Fix usage of gfc_find_symbol.
2005-09-20 Jakub Jelinek <jakub@redhat.com>
PR fortran/23663

92
gcc/fortran/io.c
View file

@ -979,6 +979,15 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
if (tag == &tag_format)
{
if (e->expr_type == EXPR_CONSTANT
&& (e->ts.type != BT_CHARACTER
|| e->ts.kind != gfc_default_character_kind))
{
gfc_error ("Constant expression in FORMAT tag at %L must be "
"of type default CHARACTER", &e->where);
return FAILURE;
}
/* If e's rank is zero and e is not an element of an array, it should be
of integer or character type. The integer variable should be
ASSIGNED. */
@ -2158,51 +2167,51 @@ match_io (io_kind k)
comma_flag = 0;
current_dt = dt = gfc_getmem (sizeof (gfc_dt));
if (gfc_match_char ('(') == MATCH_NO)
{
where = gfc_current_locus;
if (k == M_WRITE)
goto syntax;
else if (k == M_PRINT
&& (gfc_current_form == FORM_FIXED
|| gfc_peek_char () == ' '))
else if (k == M_PRINT)
{
/* Treat the non-standard case of PRINT namelist. */
where = gfc_current_locus;
if ((gfc_match_name (name) == MATCH_YES)
&& !gfc_find_symbol (name, NULL, 1, &sym)
&& sym->attr.flavor == FL_NAMELIST)
if ((gfc_current_form == FORM_FIXED || gfc_peek_char () == ' ')
&& gfc_match_name (name) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
"%C is an extension") == FAILURE)
gfc_find_symbol (name, NULL, 1, &sym);
if (sym && sym->attr.flavor == FL_NAMELIST)
{
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_match_eos () == MATCH_NO)
{
gfc_error ("Namelist followed by I/O list at %C");
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_notify_std (GFC_STD_GNU, "PRINT namelist at "
"%C is an extension") == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
}
if (gfc_match_eos () == MATCH_NO)
{
gfc_error ("Namelist followed by I/O list at %C");
m = MATCH_ERROR;
goto cleanup;
}
dt->io_unit = default_unit (k);
dt->namelist = sym;
goto get_io_list;
dt->io_unit = default_unit (k);
dt->namelist = sym;
goto get_io_list;
}
else
gfc_current_locus = where;
}
else
gfc_current_locus = where;
}
if (gfc_current_form == FORM_FREE)
{
c = gfc_peek_char();
if (c != ' ' && c != '*' && c != '\'' && c != '"')
{
m = MATCH_NO;
goto cleanup;
}
}
{
c = gfc_peek_char();
if (c != ' ' && c != '*' && c != '\'' && c != '"')
{
m = MATCH_NO;
goto cleanup;
}
}
m = match_dt_format (dt);
if (m == MATCH_ERROR)
@ -2240,17 +2249,20 @@ match_io (io_kind k)
where = gfc_current_locus;
if (gfc_match_name (name) == MATCH_YES
&& !gfc_find_symbol (name, NULL, 1, &sym)
&& sym->attr.flavor == FL_NAMELIST)
m = gfc_match_name (name);
if (m == MATCH_YES)
{
dt->namelist = sym;
if (k == M_READ && check_namelist (sym))
gfc_find_symbol (name, NULL, 1, &sym);
if (sym && sym->attr.flavor == FL_NAMELIST)
{
m = MATCH_ERROR;
goto cleanup;
dt->namelist = sym;
if (k == M_READ && check_namelist (sym))
{
m = MATCH_ERROR;
goto cleanup;
}
goto next;
}
goto next;
}
gfc_current_locus = where;

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
2005-09-20 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/23420
* gfortran.dg/print_fmt_4.f: New.
2005-09-20 Jakub Jelinek <jakub@redhat.com>
PR fortran/23663

3
gcc/testsuite/gfortran.dg/print_fmt_4.f Normal file
View file

@ -0,0 +1,3 @@
! { dg-do compile }
print precision(1.) ! { dg-error "must be of type default CHARACTER" }
end