diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index d9e368b6848..488d280f7a6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2007-10-04 Francois-Xavier Coudert + + PR fortran/33529 + * decl.c (match_char_kind): New function. + (match_char_spec): Use match_char_kind. + 2007-10-04 Francois-Xavier Coudert PR fortran/33502 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index a507137441f..d0eb0ef4a5f 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1886,20 +1886,80 @@ no_match: } +static match +match_char_kind (int * kind, int * is_iso_c) +{ + locus where; + gfc_expr *e; + match m, n; + const char *msg; + + m = MATCH_NO; + e = NULL; + where = gfc_current_locus; + + n = gfc_match_init_expr (&e); + if (n == MATCH_NO) + gfc_error ("Expected initialization expression at %C"); + if (n != MATCH_YES) + return MATCH_ERROR; + + if (e->rank != 0) + { + gfc_error ("Expected scalar initialization expression at %C"); + m = MATCH_ERROR; + goto no_match; + } + + msg = gfc_extract_int (e, kind); + *is_iso_c = e->ts.is_iso_c; + if (msg != NULL) + { + gfc_error (msg); + m = MATCH_ERROR; + goto no_match; + } + + gfc_free_expr (e); + + /* Ignore errors to this point, if we've gotten here. This means + we ignore the m=MATCH_ERROR from above. */ + if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0) + { + gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind); + m = MATCH_ERROR; + } + else + /* All tests passed. */ + m = MATCH_YES; + + if (m == MATCH_ERROR) + gfc_current_locus = where; + + /* Return what we know from the test(s). */ + return m; + +no_match: + gfc_free_expr (e); + gfc_current_locus = where; + return m; +} + /* Match the various kind/length specifications in a CHARACTER declaration. We don't return MATCH_NO. */ static match match_char_spec (gfc_typespec *ts) { - int kind, seen_length; + int kind, seen_length, is_iso_c; gfc_charlen *cl; gfc_expr *len; match m; - gfc_expr *kind_expr = NULL; - kind = gfc_default_character_kind; + len = NULL; seen_length = 0; + kind = 0; + is_iso_c = 0; /* Try the old-style specification first. */ old_char_selector = 0; @@ -1923,7 +1983,7 @@ match_char_spec (gfc_typespec *ts) /* Try the weird case: ( KIND = [ , LEN = ] ). */ if (gfc_match (" kind =") == MATCH_YES) { - m = gfc_match_small_int_expr(&kind, &kind_expr); + m = match_char_kind (&kind, &is_iso_c); if (m == MATCH_ERROR) goto done; @@ -1959,13 +2019,8 @@ match_char_spec (gfc_typespec *ts) if (gfc_match (" , kind =") != MATCH_YES) goto syntax; - gfc_match_small_int_expr(&kind, &kind_expr); - - if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0) - { - gfc_error ("Kind %d is not a CHARACTER kind at %C", kind); - return MATCH_YES; - } + if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR) + goto done; goto rparen; } @@ -1987,7 +2042,7 @@ match_char_spec (gfc_typespec *ts) gfc_match (" kind ="); /* Gobble optional text. */ - m = gfc_match_small_int_expr(&kind, &kind_expr); + m = match_char_kind (&kind, &is_iso_c); if (m == MATCH_ERROR) goto done; if (m == MATCH_NO) @@ -2006,23 +2061,9 @@ syntax: return m; done: - if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0) - { - gfc_error ("Kind %d is not a CHARACTER kind at %C", kind); - m = MATCH_ERROR; - } - - if (seen_length == 1 && len != NULL - && len->ts.type != BT_INTEGER && len->ts.type != BT_UNKNOWN) - { - gfc_error ("Expression at %C must be of INTEGER type"); - m = MATCH_ERROR; - } - if (m != MATCH_YES) { gfc_free_expr (len); - gfc_free_expr (kind_expr); return m; } @@ -2037,30 +2078,24 @@ done: cl->length = len; ts->cl = cl; - ts->kind = kind; + ts->kind = kind == 0 ? gfc_default_character_kind : kind; /* We have to know if it was a c interoperable kind so we can do accurate type checking of bind(c) procs, etc. */ - if (kind_expr != NULL) - { - /* Mark this as c interoperable if being declared with one - of the named constants from iso_c_binding. */ - ts->is_c_interop = kind_expr->ts.is_iso_c; - gfc_free_expr (kind_expr); - } + if (kind != 0) + /* Mark this as c interoperable if being declared with one + of the named constants from iso_c_binding. */ + ts->is_c_interop = is_iso_c; else if (len != NULL) - { - /* Here, we might have parsed something such as: - character(c_char) - In this case, the parsing code above grabs the c_char when - looking for the length (line 1690, roughly). it's the last - testcase for parsing the kind params of a character variable. - However, it's not actually the length. this seems like it - could be an error. - To see if the user used a C interop kind, test the expr - of the so called length, and see if it's C interoperable. */ - ts->is_c_interop = len->ts.is_iso_c; - } + /* Here, we might have parsed something such as: character(c_char) + In this case, the parsing code above grabs the c_char when + looking for the length (line 1690, roughly). it's the last + testcase for parsing the kind params of a character variable. + However, it's not actually the length. this seems like it + could be an error. + To see if the user used a C interop kind, test the expr + of the so called length, and see if it's C interoperable. */ + ts->is_c_interop = len->ts.is_iso_c; return MATCH_YES; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5f1e3d7eaa3..6e5dba07d78 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2007-10-04 Francois-Xavier Coudert + + PR fortran/33529 + * gfortran.dg/char_type_len_2.f90: Adjust error message. + * gfortran.dg/char_decl_2.f90: New test. + 2007-10-04 Richard Guenther PR middle-end/33641 diff --git a/gcc/testsuite/gfortran.dg/char_decl_2.f90 b/gcc/testsuite/gfortran.dg/char_decl_2.f90 new file mode 100644 index 00000000000..ffce6b158e2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_decl_2.f90 @@ -0,0 +1,4 @@ +! { dg-do run } + character (kind=kind("a")) :: u + if (kind(u) /= kind("a")) call abort + end diff --git a/gcc/testsuite/gfortran.dg/char_type_len_2.f90 b/gcc/testsuite/gfortran.dg/char_type_len_2.f90 index a5cb835b028..e4fab80205e 100644 --- a/gcc/testsuite/gfortran.dg/char_type_len_2.f90 +++ b/gcc/testsuite/gfortran.dg/char_type_len_2.f90 @@ -2,7 +2,9 @@ ! 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" } - 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 a CHARACTER kind" } + character(kind=1,len=4.3) :: t ! { dg-error "must be of INTEGER type" } + 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" } + character(kind=2,len=7) :: x ! ! { dg-error "Kind 2 is not supported for CHARACTER" } end