From a48718a2f61f10c0531daa0ef73531174144a14b Mon Sep 17 00:00:00 2001 From: Thomas Koenig Date: Mon, 26 Mar 2018 06:29:01 +0000 Subject: [PATCH] re PR fortran/66709 (ICE on formatted io with parameter array specifier fmt) 2018-03-26 Thomas Koenig PR fortran/66709 * io.c: Include constructor.h. (resolve_tag_format): For a constant character array, concatenate into a single character expression. 2018-03-26 Thomas Koenig PR fortran/66709 * gfortran.dg/parameter_array_format.f90: New test. From-SVN: r258850 --- gcc/fortran/ChangeLog | 7 +++ gcc/fortran/io.c | 44 ++++++++++++++++++- gcc/testsuite/ChangeLog | 5 +++ .../gfortran.dg/parameter_array_format.f90 | 14 ++++++ 4 files changed, 69 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/parameter_array_format.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4d93c55fe50..0f07e0a30d9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2018-03-26 Thomas Koenig + + PR fortran/66709 + * io.c: Include constructor.h. + (resolve_tag_format): For a constant character array, concatenate + into a single character expression. + 2018-03-25 Seth Johnson Dominique d'Humieres diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index d9f0fb1d4ac..10b7e827dab 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -25,6 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "match.h" #include "parse.h" +#include "constructor.h" gfc_st_label format_asterisk = {0, NULL, NULL, -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, @@ -1606,7 +1607,7 @@ match_dec_ftag (const io_tag *tag, gfc_open *o) /* Resolution of the FORMAT tag, to be called from resolve_tag. */ static bool -resolve_tag_format (const gfc_expr *e) +resolve_tag_format (gfc_expr *e) { if (e->expr_type == EXPR_CONSTANT && (e->ts.type != BT_CHARACTER @@ -1617,6 +1618,47 @@ resolve_tag_format (const gfc_expr *e) return false; } + /* Concatenate a constant character array into a single character + expression. */ + + if ((e->expr_type == EXPR_ARRAY || e->rank > 0) + && e->ts.type == BT_CHARACTER + && gfc_is_constant_expr (e)) + { + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor == FL_PARAMETER) + gfc_simplify_expr (e, 1); + + if (e->expr_type == EXPR_ARRAY) + { + gfc_constructor *c; + gfc_charlen_t n, len; + gfc_expr *r; + gfc_char_t *dest, *src; + + n = 0; + c = gfc_constructor_first (e->value.constructor); + len = c->expr->value.character.length; + + for ( ; c; c = gfc_constructor_next (c)) + n += len; + + r = gfc_get_character_expr (e->ts.kind, &e->where, NULL, n); + dest = r->value.character.string; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + src = c->expr->value.character.string; + for (gfc_charlen_t i = 0 ; i < len; i++) + *dest++ = *src++; + } + + gfc_replace_expr (e, r); + return true; + } + } + /* 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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cbd5efcb16e..4b7fc36ba2c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2018-03-26 Thomas Koenig + + PR fortran/66709 + * gfortran.dg/parameter_array_format.f90: New test. + 2018-03-25 Thomas Koenig Neil Carlson diff --git a/gcc/testsuite/gfortran.dg/parameter_array_format.f90 b/gcc/testsuite/gfortran.dg/parameter_array_format.f90 new file mode 100644 index 00000000000..d4ae9dac8c9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/parameter_array_format.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR fortran/66709 +! Check that parameter formats are handled correctly. +! Original test case by Gerhard Steinmetz. +program main + character(len=2), dimension(9), parameter :: f = ['("','He','ll','lo',', ','wo','rl','d!','")'] + character(len=2), dimension(9) :: g = ['("','He','ll','lo',', ','wo','rl','d!','")'] + character (len=20) :: line + write (unit=line,fmt=f) + if (line /= "Helllo, world!") STOP 1 + line = " " + write (unit=line,fmt=g) + if (line /= "Helllo, world!") STOP 2 +end program main -- 2.30.2