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

re PR fortran/33529 (Non-litteral CHARACTER kind values matching is wrong) 

PR fortran/33529

	* decl.c (match_char_kind): New function.
	(match_char_spec): Use match_char_kind.

	* gfortran.dg/char_type_len_2.f90: Adjust error message.
	* gfortran.dg/char_decl_2.f90: New test.

From-SVN: r129012
This commit is contained in:
Francois-Xavier Coudert 2007-10-04 15:08:14 +00:00 committed by François-Xavier Coudert
parent 9e8a672069
commit 187de1ed2b
5 changed files with 102 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2007-10-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/33529
* decl.c (match_char_kind): New function.
(match_char_spec): Use match_char_kind.
2007-10-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/33502

127
gcc/fortran/decl.c
View File

@ -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 = <int> [ , LEN = <len-param> ] ). */
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;
}

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2007-10-04 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
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 <rguenther@suse.de>
PR middle-end/33641

4
gcc/testsuite/gfortran.dg/char_decl_2.f90 Normal file
View File

@ -0,0 +1,4 @@
! { dg-do run }
character (kind=kind("a")) :: u
if (kind(u) /= kind("a")) call abort
end

8
gcc/testsuite/gfortran.dg/char_type_len_2.f90
View File

@ -2,7 +2,9 @@
! PR31251 Non-integer character length leads to segfault
! Submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>
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