OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/45776 (Full implementation of variable definition contexts (and related checks)) 

2010-09-25  Daniel Kraft  <d@domob.eu>

	PR fortran/45776
	* gfortran.h (struct gfc_dt): New member `dt_io_kind'.
	* io.c (resolve_tag): F2008 check for NEWUNIT and variable
	definition checks for NEWUNIT, IOSTAT, SIZE and IOMSG.
	(gfc_free_dt): Correctly handle freeing of `dt_io_kind' and
	`extra_comma' with changed semantics.
	(gfc_resolve_dt): Check variable definitions.
	(match_io_element): Remove INTENT and PURE checks here and
	initialize code->ext.dt member.
	(match_io): Set dt->dt_io_kind.
	(gfc_resolve_inquire): Check variable definition for all tags
	except UNIT, FILE and ID.
	* resolve.c (resolve_transfer): Variable definition check.

2010-09-25  Daniel Kraft  <d@domob.eu>

	PR fortran/45776
	* gfortran.dg/io_constraints_6.f03: New test.
	* gfortran.dg/io_constraints_7.f03: New test.
	* gfortran.dg/newunit_2.f90: New test.

From-SVN: r164619
This commit is contained in:
Daniel Kraft 2010-09-25 16:27:20 +02:00 committed by Daniel Kraft
parent c21136eebb
commit 8e8dc06035
8 changed files with 239 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
gcc/fortran/ChangeLog
View File

@ -1,3 +1,19 @@
2010-09-25 Daniel Kraft <d@domob.eu>
PR fortran/45776
* gfortran.h (struct gfc_dt): New member `dt_io_kind'.
* io.c (resolve_tag): F2008 check for NEWUNIT and variable
definition checks for NEWUNIT, IOSTAT, SIZE and IOMSG.
(gfc_free_dt): Correctly handle freeing of `dt_io_kind' and
`extra_comma' with changed semantics.
(gfc_resolve_dt): Check variable definitions.
(match_io_element): Remove INTENT and PURE checks here and
initialize code->ext.dt member.
(match_io): Set dt->dt_io_kind.
(gfc_resolve_inquire): Check variable definition for all tags
except UNIT, FILE and ID.
* resolve.c (resolve_transfer): Variable definition check.
2010-09-25 Tobias Burnus <burnus@net-b.de>
* interface.c (gfc_match_end_interface): Constify char pointer

2
gcc/fortran/gfortran.h
View File

@ -2000,7 +2000,7 @@ typedef struct
{
gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg,
*id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round,
*sign, *extra_comma;
*sign, *extra_comma, *dt_io_kind;
gfc_symbol *namelist;
/* A format_label of `format_asterisk' indicates the "*" format */

205
gcc/fortran/io.c
View File

@ -1505,13 +1505,31 @@ resolve_tag (const io_tag *tag, gfc_expr *e)
return FAILURE;
}
if (tag == &tag_newunit)
{
if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: NEWUNIT specifier"
" at %L", &e->where) == FAILURE)
return FAILURE;
}
/* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts. */
if (tag == &tag_newunit || tag == &tag_iostat
|| tag == &tag_size || tag == &tag_iomsg)
{
char context[64];
sprintf (context, _("%s tag"), tag->name);
if (gfc_check_vardef_context (e, false, context) == FAILURE)
return FAILURE;
}
if (tag == &tag_convert)
{
if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
&e->where) == FAILURE)
return FAILURE;
}
return SUCCESS;
}
@ -2707,8 +2725,9 @@ gfc_free_dt (gfc_dt *dt)
gfc_free_expr (dt->round);
gfc_free_expr (dt->blank);
gfc_free_expr (dt->decimal);
gfc_free_expr (dt->extra_comma);
gfc_free_expr (dt->pos);
gfc_free_expr (dt->dt_io_kind);
/* dt->extra_comma is a link to dt_io_kind if it is set. */
gfc_free (dt);
}
@ -2719,6 +2738,11 @@ gfc_try
gfc_resolve_dt (gfc_dt *dt, locus *loc)
{
gfc_expr *e;
io_kind k;
/* This is set in any case. */
gcc_assert (dt->dt_io_kind);
k = dt->dt_io_kind->value.iokind;
RESOLVE_TAG (&tag_format, dt->format_expr);
RESOLVE_TAG (&tag_rec, dt->rec);
@ -2761,16 +2785,13 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
type character, we assume its really the "format" form of the I/O
statement. We set the io_unit to the default unit and format to
the character expression. See F95 Standard section 9.4. */
io_kind k;
k = dt->extra_comma->value.iokind;
if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
{
dt->format_expr = dt->io_unit;
dt->io_unit = default_unit (k);
/* Free this pointer now so that a warning/error is not triggered
below for the "Extension". */
gfc_free_expr (dt->extra_comma);
/* Nullify this pointer now so that a warning/error is not
triggered below for the "Extension". */
dt->extra_comma = NULL;
}
@ -2790,6 +2811,13 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
gfc_error ("Internal unit with vector subscript at %L", &e->where);
return FAILURE;
}
/* If we are writing, make sure the internal unit can be changed. */
gcc_assert (k != M_PRINT);
if (k == M_WRITE
&& gfc_check_vardef_context (e, false, _("internal unit in WRITE"))
== FAILURE)
return FAILURE;
}
if (e->rank && e->ts.type != BT_CHARACTER)
@ -2801,10 +2829,36 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
&& mpz_sgn (e->value.integer) < 0)
{
gfc_error ("UNIT number in statement at %L must be non-negative", &e->where);
gfc_error ("UNIT number in statement at %L must be non-negative",
&e->where);
return FAILURE;
}
/* If we are reading and have a namelist, check that all namelist symbols
can appear in a variable definition context. */
if (k == M_READ && dt->namelist)
{
gfc_namelist* n;
for (n = dt->namelist->namelist; n; n = n->next)
{
gfc_expr* e;
gfc_try t;
e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
t = gfc_check_vardef_context (e, false, NULL);
gfc_free_expr (e);
if (t == FAILURE)
{
gfc_error ("NAMELIST '%s' in READ statement at %L contains"
" the symbol '%s' which may not appear in a"
" variable definition context",
dt->namelist->name, loc, n->sym->name);
return FAILURE;
}
}
}
if (dt->extra_comma
&& gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
"item list at %L", &dt->extra_comma->where) == FAILURE)
@ -2854,6 +2908,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
&dt->format_label->where);
return FAILURE;
}
return SUCCESS;
}
@ -3012,50 +3067,8 @@ match_io_element (io_kind k, gfc_code **cpp)
io_kind_name (k));
}
if (m == MATCH_YES)
switch (k)
{
case M_READ:
if (expr->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Variable '%s' in input list at %C cannot be "
"INTENT(IN)", expr->symtree->n.sym->name);
m = MATCH_ERROR;
}
if (gfc_pure (NULL)
&& gfc_impure_variable (expr->symtree->n.sym)
&& current_dt->io_unit
&& current_dt->io_unit->ts.type == BT_CHARACTER)
{
gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
expr->symtree->n.sym->name);
m = MATCH_ERROR;
}
if (gfc_check_do_variable (expr->symtree))
m = MATCH_ERROR;
break;
case M_WRITE:
if (current_dt->io_unit
&& current_dt->io_unit->ts.type == BT_CHARACTER
&& gfc_pure (NULL)
&& current_dt->io_unit->expr_type == EXPR_VARIABLE
&& gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
{
gfc_error ("Cannot write to internal file unit '%s' at %C "
"inside a PURE procedure",
current_dt->io_unit->symtree->n.sym->name);
m = MATCH_ERROR;
}
break;
default:
break;
}
if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
m = MATCH_ERROR;
if (m != MATCH_YES)
{
@ -3066,6 +3079,7 @@ match_io_element (io_kind k, gfc_code **cpp)
cp = gfc_get_code ();
cp->op = EXEC_TRANSFER;
cp->expr1 = expr;
cp->ext.dt = current_dt;
*cpp = cp;
return MATCH_YES;
@ -3657,14 +3671,14 @@ get_io_list:
/* Used in check_io_constraints, where no locus is available. */
spec_end = gfc_current_locus;
/* Save the IO kind for later use. */
dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
/* Optional leading comma (non-standard). We use a gfc_expr structure here
to save the locus. This is used later when resolving transfer statements
that might have a format expression without unit number. */
if (!comma_flag && gfc_match_char (',') == MATCH_YES)
{
/* Save the iokind and locus for later use in resolution. */
dt->extra_comma = gfc_get_iokind_expr (&gfc_current_locus, k);
}
dt->extra_comma = dt->dt_io_kind;
io_code = NULL;
if (gfc_match_eos () != MATCH_YES)
@ -3973,41 +3987,54 @@ gfc_resolve_inquire (gfc_inquire *inquire)
{
RESOLVE_TAG (&tag_unit, inquire->unit);
RESOLVE_TAG (&tag_file, inquire->file);
RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
RESOLVE_TAG (&tag_iostat, inquire->iostat);
RESOLVE_TAG (&tag_exist, inquire->exist);
RESOLVE_TAG (&tag_opened, inquire->opened);
RESOLVE_TAG (&tag_number, inquire->number);
RESOLVE_TAG (&tag_named, inquire->named);
RESOLVE_TAG (&tag_name, inquire->name);
RESOLVE_TAG (&tag_s_access, inquire->access);
RESOLVE_TAG (&tag_sequential, inquire->sequential);
RESOLVE_TAG (&tag_direct, inquire->direct);
RESOLVE_TAG (&tag_s_form, inquire->form);
RESOLVE_TAG (&tag_formatted, inquire->formatted);
RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
RESOLVE_TAG (&tag_s_recl, inquire->recl);
RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
RESOLVE_TAG (&tag_s_blank, inquire->blank);
RESOLVE_TAG (&tag_s_position, inquire->position);
RESOLVE_TAG (&tag_s_action, inquire->action);
RESOLVE_TAG (&tag_read, inquire->read);
RESOLVE_TAG (&tag_write, inquire->write);
RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
RESOLVE_TAG (&tag_s_delim, inquire->delim);
RESOLVE_TAG (&tag_s_pad, inquire->pad);
RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
RESOLVE_TAG (&tag_s_round, inquire->round);
RESOLVE_TAG (&tag_iolength, inquire->iolength);
RESOLVE_TAG (&tag_convert, inquire->convert);
RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
RESOLVE_TAG (&tag_s_sign, inquire->sign);
RESOLVE_TAG (&tag_s_round, inquire->round);
RESOLVE_TAG (&tag_pending, inquire->pending);
RESOLVE_TAG (&tag_size, inquire->size);
RESOLVE_TAG (&tag_id, inquire->id);
/* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
contexts. Thus, use an extended RESOLVE_TAG macro for that. */
#define INQUIRE_RESOLVE_TAG(tag, expr) \
RESOLVE_TAG (tag, expr); \
if (expr) \
{ \
char context[64]; \
sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
if (gfc_check_vardef_context ((expr), false, context) == FAILURE) \
return FAILURE; \
}
INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
#undef INQUIRE_RESOLVE_TAG
if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
return FAILURE;

7
gcc/fortran/resolve.c
View File

@ -7916,6 +7916,13 @@ resolve_transfer (gfc_code *code)
&& exp->expr_type != EXPR_FUNCTION))
return;
/* If we are reading, the variable will be changed. Note that
code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */
if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
&& gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
return;
sym = exp->symtree->n.sym;
ts = &sym->ts;

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2010-09-25 Daniel Kraft <d@domob.eu>
PR fortran/45776
* gfortran.dg/io_constraints_6.f03: New test.
* gfortran.dg/io_constraints_7.f03: New test.
* gfortran.dg/newunit_2.f90: New test.
2010-09-24 Steven G. Kargl < kargl@gcc.gnu.org>
* testsuite/gfortran.dg/operator_c1202.f90: New test.

40
gcc/testsuite/gfortran.dg/io_constraints_6.f03 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do compile }
! PR fortran/45776
! Variable definition context checks related to IO.
! Contributed by Daniel Kraft, d@domob.eu.
module m
implicit none
integer, protected :: a
character(len=128), protected :: str
end module m
program main
use :: m
integer, parameter :: b = 42
integer :: x
character(len=128) :: myStr
namelist /definable/ x, myStr
namelist /undefinable/ x, a
! These are invalid.
read (myStr, *) a ! { dg-error "variable definition context" }
read (myStr, *) x, b ! { dg-error "variable definition context" }
write (str, *) 5 ! { dg-error "variable definition context" }
read (*, nml=undefinable) ! { dg-error "contains the symbol 'a' which may not" }
! These are ok.
read (str, *) x
write (myStr, *) a
write (myStr, *) b
print *, a, b
write (*, nml=undefinable)
read (*, nml=definable)
write (*, nml=definable)
end program main
! { dg-final { cleanup-modules "m" } }

37
gcc/testsuite/gfortran.dg/io_constraints_7.f03 Normal file
View File

@ -0,0 +1,37 @@
! { dg-do compile }
! PR fortran/45776
! Variable definition context checks related to IO.
! Contributed by Daniel Kraft, d@domob.eu.
module m
implicit none
integer, protected :: a
character(len=128), protected :: msg
end module m
program main
use :: m
integer :: x
logical :: bool
write (*, iostat=a) 42 ! { dg-error "variable definition context" }
write (*, iomsg=msg) 42 ! { dg-error "variable definition context" }
read (*, '(I2)', advance='no', size=a) x ! { dg-error "variable definition context" }
! These are ok.
inquire (unit=a)
inquire (file=msg, id=a, pending=bool)
inquire (file=msg)
! These not, but list is not extensive.
inquire (unit=1, number=a) ! { dg-error "variable definition context" }
inquire (unit=1, encoding=msg) ! { dg-error "variable definition context" }
inquire (unit=1, formatted=msg) ! { dg-error "variable definition context" }
open (newunit=a, file="foo") ! { dg-error "variable definition context" }
close (unit=a)
end program main
! { dg-final { cleanup-modules "m" } }

15
gcc/testsuite/gfortran.dg/newunit_2.f90 Normal file
View File

@ -0,0 +1,15 @@
! { dg-do compile }
! { dg-options "-std=f95" }
! PR40008 F2008: Add NEWUNIT= for OPEN statement
! Check for rejection with pre-F2008 standard.
! Contributed by Daniel Kraft, d@domob.eu.
program main
character(len=25) :: str
integer(1) :: myunit
open (newunit=myunit, file="some_file") ! { dg-error "Fortran 2008" }
close (unit=myunit)
end program main