From 8d48826b99b81b7ed96c5db08ec8334a2b0c6557 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sat, 24 Oct 2015 16:20:26 +0000 Subject: [PATCH] re PR fortran/67805 (ICE on array constructor with wrong character specification) 2015-10-24 Steven G. Kargl PR fortran/67805 * array.c (gfc_match_array_constructor): Check for error from type spec matching. * decl.c (char_len_param_value): Check for valid of charlen parameter. Reap dead code dating to 2008. match.c (gfc_match_type_spec): Special case the keyword use in REAL. 2015-10-24 Steven G. Kargl PR fortran/67805 * gfortran.dg/pr67805.f90: New testcase. * gfortran.dg/array_constructor_26.f03: Update testcase. * gfortran.dg/array_constructor_27.f03: Ditto. * gfortran.dg/char_type_len_2.f90: Ditto. * gfortran.dg/pr67802.f90: Ditto. * gfortran.dg/used_before_typed_3.f90: Ditto. From-SVN: r229287 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/array.c | 8 ++- gcc/fortran/decl.c | 67 +++++++++++++++------- gcc/fortran/match.c | 5 ++ gcc/testsuite/gfortran.dg/array_constructor_26.f03 | 1 - gcc/testsuite/gfortran.dg/array_constructor_27.f03 | 1 - gcc/testsuite/gfortran.dg/char_type_len_2.f90 | 7 ++- gcc/testsuite/gfortran.dg/large_real_kind_3.F90 | 1 - gcc/testsuite/gfortran.dg/pr67802.f90 | 18 +++--- gcc/testsuite/gfortran.dg/pr67805.f90 | 37 ++++++++++++ gcc/testsuite/gfortran.dg/used_before_typed_3.f90 | 4 +- 11 files changed, 119 insertions(+), 39 deletions(-) rewrite gcc/testsuite/gfortran.dg/pr67802.f90 (67%) create mode 100644 gcc/testsuite/gfortran.dg/pr67805.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7ed2bc58c34..67d1fb0313e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2015-10-24 Steven G. Kargl + + PR fortran/67805 + * array.c (gfc_match_array_constructor): Check for error from type + spec matching. + * decl.c (char_len_param_value): Check for valid of charlen parameter. + Reap dead code dating to 2008. + match.c (gfc_match_type_spec): Special case the keyword use in REAL. + 2015-10-23 Mikhail Maltsev * trans-common.c (create_common): Adjust to use flag_checking. diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index 276737b4121..2355a980a61 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -1080,7 +1080,8 @@ gfc_match_array_constructor (gfc_expr **result) /* Try to match an optional "type-spec ::" */ gfc_clear_ts (&ts); gfc_new_undo_checkpoint (changed_syms); - if (gfc_match_type_spec (&ts) == MATCH_YES) + m = gfc_match_type_spec (&ts); + if (m == MATCH_YES) { seen_ts = (gfc_match (" ::") == MATCH_YES); @@ -1102,6 +1103,11 @@ gfc_match_array_constructor (gfc_expr **result) } } } + else if (m == MATCH_ERROR) + { + gfc_restore_last_undo_checkpoint (); + goto cleanup; + } if (seen_ts) gfc_drop_last_undo_checkpoint (); diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index c7526772e80..200a1287057 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -715,36 +715,59 @@ char_len_param_value (gfc_expr **expr, bool *deferred) if ((*expr)->expr_type == EXPR_FUNCTION) { - if ((*expr)->value.function.actual - && (*expr)->value.function.actual->expr->symtree) + if ((*expr)->ts.type == BT_INTEGER + || ((*expr)->ts.type == BT_UNKNOWN + && strcmp((*expr)->symtree->name, "null") != 0)) + return MATCH_YES; + + goto syntax; + } + else if ((*expr)->expr_type == EXPR_CONSTANT) + { + /* F2008, 4.4.3.1: The length is a type parameter; its kind is + processor dependent and its value is greater than or equal to zero. + F2008, 4.4.3.2: If the character length parameter value evaluates + to a negative value, the length of character entities declared + is zero. */ + + if ((*expr)->ts.type == BT_INTEGER) { - gfc_expr *e; - e = (*expr)->value.function.actual->expr; - if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE - && e->expr_type == EXPR_VARIABLE) - { - if (e->symtree->n.sym->ts.type == BT_UNKNOWN) - goto syntax; - if (e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.u.cl - && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN) - goto syntax; - } + if (mpz_cmp_si ((*expr)->value.integer, 0) < 0) + mpz_set_si ((*expr)->value.integer, 0); } + else + goto syntax; } + else if ((*expr)->expr_type == EXPR_ARRAY) + goto syntax; + else if ((*expr)->expr_type == EXPR_VARIABLE) + { + gfc_expr *e; + + e = gfc_copy_expr (*expr); + + /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']", + which causes an ICE if gfc_reduce_init_expr() is called. */ + if (e->ref && e->ref->u.ar.type == AR_UNKNOWN + && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) + goto syntax; + + gfc_reduce_init_expr (e); + + if ((e->ref && e->ref->u.ar.type != AR_ELEMENT) + || (!e->ref && e->expr_type == EXPR_ARRAY)) + { + gfc_free_expr (e); + goto syntax; + } - /* F2008, 4.4.3.1: The length is a type parameter; its kind is processor - dependent and its value is greater than or equal to zero. - F2008, 4.4.3.2: If the character length parameter value evaluates to - a negative value, the length of character entities declared is zero. */ - if ((*expr)->expr_type == EXPR_CONSTANT - && mpz_cmp_si ((*expr)->value.integer, 0) < 0) - mpz_set_si ((*expr)->value.integer, 0); + gfc_free_expr (e); + } return m; syntax: - gfc_error ("Conflict in attributes of function argument at %C"); + gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where); return MATCH_ERROR; } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 74f26b7b7fe..dda2d5ab1da 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1939,6 +1939,11 @@ kind_selector: if (m == MATCH_NO) m = MATCH_YES; /* No kind specifier found. */ + /* gfortran may have matched REAL(a=1), which is the keyword form of the + intrinsic procedure. */ + if (ts->type == BT_REAL && m == MATCH_ERROR) + m = MATCH_NO; + return m; } diff --git a/gcc/testsuite/gfortran.dg/array_constructor_26.f03 b/gcc/testsuite/gfortran.dg/array_constructor_26.f03 index ac5dc90cc8c..9993099af91 100644 --- a/gcc/testsuite/gfortran.dg/array_constructor_26.f03 +++ b/gcc/testsuite/gfortran.dg/array_constructor_26.f03 @@ -11,7 +11,6 @@ MODULE WinData integer :: i TYPE TWindowData CHARACTER (MAX_FLD_HED, 1) :: DWFdHd(MAXFLD) = [(" ", i = 1, MAXFLD)] - ! { dg-error "no IMPLICIT type" "" { target *-*-* } 13 } ! { dg-error "specification expression" "" { target *-*-* } 13 } END TYPE TWindowData END MODULE WinData diff --git a/gcc/testsuite/gfortran.dg/array_constructor_27.f03 b/gcc/testsuite/gfortran.dg/array_constructor_27.f03 index 8068364ce4a..21adac82ad4 100644 --- a/gcc/testsuite/gfortran.dg/array_constructor_27.f03 +++ b/gcc/testsuite/gfortran.dg/array_constructor_27.f03 @@ -9,7 +9,6 @@ implicit none type t character (a) :: arr (1) = [ "a" ] - ! { dg-error "no IMPLICIT type" "" { target *-*-* } 11 } ! { dg-error "specification expression" "" { target *-*-* } 11 } end type t diff --git a/gcc/testsuite/gfortran.dg/char_type_len_2.f90 b/gcc/testsuite/gfortran.dg/char_type_len_2.f90 index e4fab80205e..bfa7945dbc6 100644 --- a/gcc/testsuite/gfortran.dg/char_type_len_2.f90 +++ b/gcc/testsuite/gfortran.dg/char_type_len_2.f90 @@ -1,8 +1,11 @@ ! { dg-do compile } ! PR31251 Non-integer character length leads to segfault ! Submitted by Jerry DeLisle - character(len=2.3) :: s ! { dg-error "must be of INTEGER type" } - character(kind=1,len=4.3) :: t ! { dg-error "must be of INTEGER type" } +! +! Updated to deal with the fix for PR fortran/67805. +! + character(len=2.3) :: s ! { dg-error "INTEGER expression expected" } + character(kind=1,len=4.3) :: t ! { dg-error "INTEGER expression expected" } character(len=,,7.2,kind=1) :: u ! { dg-error "Syntax error in CHARACTER declaration" } character(len=7,kind=2) :: v ! ! { dg-error "Kind 2 is not supported for CHARACTER" } character(kind=2) :: w ! ! { dg-error "Kind 2 is not supported for CHARACTER" } diff --git a/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 b/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 index 0660b497a69..128376963ba 100644 --- a/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 +++ b/gcc/testsuite/gfortran.dg/large_real_kind_3.F90 @@ -1,6 +1,5 @@ ! { dg-do run } ! { dg-require-effective-target fortran_large_real } -! { dg-xfail-if "" { "*-*-freebsd*" } { "*" } { "" } } ! Testing erf and erfc library calls on large real kinds (larger than kind=8) implicit none diff --git a/gcc/testsuite/gfortran.dg/pr67802.f90 b/gcc/testsuite/gfortran.dg/pr67802.f90 dissimilarity index 67% index 6095016ca09..2ccd8c51116 100644 --- a/gcc/testsuite/gfortran.dg/pr67802.f90 +++ b/gcc/testsuite/gfortran.dg/pr67802.f90 @@ -1,9 +1,9 @@ -! { dg-do compile } -! PR fortran/67802 -! Original code contribute by gerhard.steinmetz.fortran at t-online.de -program p - character(1.) :: c1 = ' ' ! { dg-error "must be of INTEGER" } - character(1d1) :: c2 = ' ' ! { dg-error "must be of INTEGER" } - character((0.,1.)) :: c3 = ' ' ! { dg-error "must be of INTEGER" } - character(.true.) :: c4 = ' ' ! { dg-error "must be of INTEGER" } -end program p +! { dg-do compile } +! PR fortran/67802 +! Original code contribute by gerhard.steinmetz.fortran at t-online.de +program p + character(1.) :: c1 = ' ' ! { dg-error "INTEGER expression expected" } + character(1d1) :: c2 = ' ' ! { dg-error "INTEGER expression expected" } + character((0.,1.)) :: c3 = ' ' ! { dg-error "INTEGER expression expected" } + character(.true.) :: c4 = ' ' ! { dg-error "INTEGER expression expected" } +end program p diff --git a/gcc/testsuite/gfortran.dg/pr67805.f90 b/gcc/testsuite/gfortran.dg/pr67805.f90 new file mode 100644 index 00000000000..7371991717d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr67805.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! PR fortran/67805 +! Original code contributed by Gerhard Steinmetz +! gerhard dot steinmetz dot fortran at t-online dot de +! +subroutine p + integer, parameter :: n = 1 + integer, parameter :: m(3) = [1, 2, 3] + character(len=1) s(2) + s = [character((m(1))) :: 'x', 'y'] ! OK. + s = [character(m(1)) :: 'x', 'y'] ! OK. + s = [character(m) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + + ! The next line should case an error, but causes an ICE. + s = [character(m(2:3)) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + + call foo(s) + s = [character('') :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character(['']) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([.true.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([.false.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([1.]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([1d1]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([(0.,1.)]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character([null()]) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + s = [character(null()) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + call foo(s) +end subroutine p + +subroutine q + print *, '1: ', [character(.true.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '2: ', [character(.false.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '3: ', [character(1.) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '4: ', [character(1d1) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '5: ', [character((0.,1.)) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" } + print *, '6: ', [character(null()) :: 'x', 'y'] ! { dg-error "INTEGER expression expected" }. +end subroutine q diff --git a/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 b/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 index 5654d97688d..ef2c679e082 100644 --- a/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 +++ b/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 @@ -17,14 +17,14 @@ CONTAINS test1 = "foobar" END FUNCTION test1 - CHARACTER(len=x) FUNCTION test2 (x) ! { dg-bogus "used before|of INTEGER" } + CHARACTER(len=x) FUNCTION test2 (x) ! { dg-error "of INTEGER" } IMPLICIT INTEGER(a-z) test2 = "foobar" END FUNCTION test2 END MODULE testmod -CHARACTER(len=i) FUNCTION test3 (i) ! { dg-bogus "used before|of INTEGER" } +CHARACTER(len=i) FUNCTION test3 (i) ! i is IMPLICIT INTEGER by default test3 = "foobar" END FUNCTION test3 -- 2.11.4.GIT