From: Steven G. Kargl Date: Mon, 6 Jul 2015 16:33:38 +0000 (+0000) Subject: io.c (check_char_variable): New function. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=fd5cabb2d7b8eed87dd4e00a8341b769674046ef;p=gcc.git io.c (check_char_variable): New function. 2015-07-06 Steven G. Kargl * io.c (check_char_variable): New function. (match_open_element, match_close_element, match_file_element, match_dt_element, match_inquire_element, match_wait_element): Use it. 2015-07-06 Steven G. Kargl * gfortran.dg/iomsg_2.f90: New test. From-SVN: r225462 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 10b6cddf9fd..a3a37db8e20 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2015-07-06 Steven G. Kargl + + * io.c (check_char_variable): New function. + (match_open_element, match_close_element, match_file_element, + match_dt_element, match_inquire_element, match_wait_element): Use it. + 2015-07-06 Andre Vehreschild PR fortran/58586 diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index fe3edb9f6e2..e8395b5480d 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -1181,7 +1181,7 @@ check_format_string (gfc_expr *e, bool is_input) } -/************ Fortran 95 I/O statement matchers *************/ +/************ Fortran I/O statement matchers *************/ /* Match a FORMAT statement. This amounts to actually parsing the format descriptors in order to correctly locate the end of the @@ -1242,6 +1242,21 @@ gfc_match_format (void) } +/* Check for a CHARACTER variable. The check for scalar is done in + resolve_tag. */ + +static bool +check_char_variable (gfc_expr *e) +{ + if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER) + { + gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where); + return false; + } + return true; +} + + static bool is_char_type (const char *name, gfc_expr *e) { @@ -1570,7 +1585,9 @@ match_open_element (gfc_open *open) m = match_etag (&tag_unit, &open->unit); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &open->iomsg); + m = match_etag (&tag_iomsg, &open->iomsg); + if (m == MATCH_YES && !check_char_variable (open->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &open->iostat); @@ -2234,7 +2251,9 @@ match_close_element (gfc_close *close) m = match_etag (&tag_status, &close->status); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &close->iomsg); + m = match_etag (&tag_iomsg, &close->iomsg); + if (m == MATCH_YES && !check_char_variable (close->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &close->iostat); @@ -2395,7 +2414,9 @@ match_file_element (gfc_filepos *fp) m = match_etag (&tag_unit, &fp->unit); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &fp->iomsg); + m = match_etag (&tag_iomsg, &fp->iomsg); + if (m == MATCH_YES && !check_char_variable (fp->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; m = match_out_tag (&tag_iostat, &fp->iostat); @@ -2760,7 +2781,9 @@ match_dt_element (io_kind k, gfc_dt *dt) m = match_etag (&tag_spos, &dt->pos); if (m != MATCH_NO) return m; - m = match_out_tag (&tag_iomsg, &dt->iomsg); + m = match_etag (&tag_iomsg, &dt->iomsg); + if (m == MATCH_YES && !check_char_variable (dt->iomsg)) + return MATCH_ERROR; if (m != MATCH_NO) return m; @@ -3939,7 +3962,9 @@ match_inquire_element (gfc_inquire *inquire) m = match_etag (&tag_unit, &inquire->unit); RETM m = match_etag (&tag_file, &inquire->file); RETM m = match_ltag (&tag_err, &inquire->err); - RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg); + RETM m = match_etag (&tag_iomsg, &inquire->iomsg); + if (m == MATCH_YES && !check_char_variable (inquire->iomsg)) + return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &inquire->iostat); RETM m = match_vtag (&tag_exist, &inquire->exist); RETM m = match_vtag (&tag_opened, &inquire->opened); @@ -4222,7 +4247,9 @@ match_wait_element (gfc_wait *wait) RETM m = match_ltag (&tag_err, &wait->err); RETM m = match_ltag (&tag_end, &wait->eor); RETM m = match_ltag (&tag_eor, &wait->end); - RETM m = match_out_tag (&tag_iomsg, &wait->iomsg); + RETM m = match_etag (&tag_iomsg, &wait->iomsg); + if (m == MATCH_YES && !check_char_variable (wait->iomsg)) + return MATCH_ERROR; RETM m = match_out_tag (&tag_iostat, &wait->iostat); RETM m = match_etag (&tag_id, &wait->id); RETM return MATCH_NO; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f7f15ddb74c..1d26b14cf85 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2015-07-06 Steven G. Kargl + + * gfortran.dg/iomsg_2.f90: New test. + 2015-07-06 Richard Biener PR tree-optimization/66772 diff --git a/gcc/testsuite/gfortran.dg/iomsg_2.f90 b/gcc/testsuite/gfortran.dg/iomsg_2.f90 new file mode 100644 index 00000000000..29500ed01ae --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iomsg_2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +subroutine foo1 + implicit none + integer i + open(1, iomsg=666) ! { dg-error "IOMSG must be" } + open(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + open(1, iomsg=i) ! { dg-error "IOMSG must be" } + close(1, iomsg=666) ! { dg-error "IOMSG must be" } + close(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + close(1, iomsg=i) ! { dg-error "IOMSG must be" } +end subroutine foo1 + +subroutine foo + implicit none + integer i + real :: x = 1 + write(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } + write(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } + read(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" } + read(1, *, iomsg=i) x ! { dg-error "IOMSG must be" } + flush(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + flush(1, iomsg=i) ! { dg-error "IOMSG must be" } + rewind(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + rewind(1, iomsg=i) ! { dg-error "IOMSG must be" } + backspace(1,iomsg='sgk') ! { dg-error "IOMSG must be" } + backspace(1,iomsg=i) ! { dg-error "IOMSG must be" } + wait(1, iomsg='sgk') ! { dg-error "IOMSG must be" } + wait(1, iomsg=i) ! { dg-error "IOMSG must be" } +end subroutine foo + +subroutine bar + implicit none + integer i + real :: x = 1 + character(len=20) s(2) + open(1, iomsg=s) ! { dg-error "must be scalar" } + close(1, iomsg=s) ! { dg-error "must be scalar" } + write(1, *, iomsg=s) x ! { dg-error "must be scalar" } + read(1, *, iomsg=s) x ! { dg-error "must be scalar" } + flush(1, iomsg=s) ! { dg-error "must be scalar" } + rewind(1, iomsg=s) ! { dg-error "must be scalar" } + backspace(1,iomsg=s) ! { dg-error "must be scalar" } + wait(1, iomsg=s) ! { dg-error "must be scalar" } +end subroutine bar