diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 512e8134c93..bf87e6ad396 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2005-04-25 Paul Brook + Steven G. Kargl + + PR fortran/20879 + * check.c (gfc_check_ichar_iachar): New function. + * instinsic.h (gfc_check_ichar_iachar): Add prototype. + * intrinsic.c (add_functions): Use it. + * primary.c (match_varspec, gfc_match_rvalue): Clear incorrect + character expression lengths. + 2005-04-24 Tobias Schl"uter PR fortran/20059 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 8fae4449fbf..7a27d04c13f 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -921,6 +921,64 @@ gfc_check_ibset (gfc_expr * i, gfc_expr * pos) } +try +gfc_check_ichar_iachar (gfc_expr * c) +{ + int i; + + if (type_check (c, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + /* Check that the argument is length one. Non-constant lengths + can't be checked here, so assume thay are ok. */ + if (c->ts.cl && c->ts.cl->length) + { + /* If we already have a length for this expression then use it. */ + if (c->ts.cl->length->expr_type != EXPR_CONSTANT) + return SUCCESS; + i = mpz_get_si (c->ts.cl->length->value.integer); + } + else if (c->expr_type == EXPR_VARIABLE || c->expr_type == EXPR_SUBSTRING) + { + gfc_expr *start; + gfc_expr *end; + gfc_ref *ref; + + /* Substring references don't have the charlength set. */ + ref = c->ref; + while (ref && ref->type != REF_SUBSTRING) + ref = ref->next; + + gcc_assert (ref == NULL || ref->type == REF_SUBSTRING); + + if (!ref) + return SUCCESS; + + start = ref->u.ss.start; + end = ref->u.ss.end; + + gcc_assert (start); + if (end == NULL || end->expr_type != EXPR_CONSTANT + || start->expr_type != EXPR_CONSTANT) + return SUCCESS; + + i = mpz_get_si (end->value.integer) + 1 + - mpz_get_si (start->value.integer); + } + else + return SUCCESS; + + if (i != 1) + { + gfc_error ("Argument of %s at %L must be of length one", + gfc_current_intrinsic, &c->where); + return FAILURE; + } + + return SUCCESS; +} + + try gfc_check_idnint (gfc_expr * a) { diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 7336e63d552..0b50cdcaa11 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -1342,7 +1342,7 @@ add_functions (void) make_generic ("huge", GFC_ISYM_NONE, GFC_STD_F95); add_sym_1 ("iachar", 1, 1, BT_INTEGER, di, GFC_STD_F95, - NULL, gfc_simplify_iachar, NULL, + gfc_check_ichar_iachar, gfc_simplify_iachar, NULL, c, BT_CHARACTER, dc, REQUIRED); make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95); @@ -1384,7 +1384,7 @@ add_functions (void) make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95); add_sym_1 ("ichar", 1, 0, BT_INTEGER, di, GFC_STD_F77, - NULL, gfc_simplify_ichar, gfc_resolve_ichar, + gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar, c, BT_CHARACTER, dc, REQUIRED); make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index bf2c80a0c7e..15171d1aa14 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -63,6 +63,7 @@ try gfc_check_iand (gfc_expr *, gfc_expr *); try gfc_check_ibclr (gfc_expr *, gfc_expr *); try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *); try gfc_check_ibset (gfc_expr *, gfc_expr *); +try gfc_check_ichar_iachar (gfc_expr *); try gfc_check_idnint (gfc_expr *); try gfc_check_ieor (gfc_expr *, gfc_expr *); try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 992bc5f0af7..38f9939201f 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1516,6 +1516,9 @@ check_substring: if (primary->expr_type == EXPR_CONSTANT) primary->expr_type = EXPR_SUBSTRING; + if (substring) + primary->ts.cl = NULL; + break; case MATCH_NO: @@ -1989,6 +1992,8 @@ gfc_match_rvalue (gfc_expr ** result) } e->ts = sym->ts; + if (e->ref) + e->ts.cl = NULL; m = MATCH_YES; break; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f58b43c1ac7..479f1f45aad 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2005-04-25 Paul Brook + Steven G. Kargl + + PR fortran/20879 + * gfortran.dg/ichar_1.f90: New file. + 2005-04-24 Jakub Jelinek PR middle-end/20991 diff --git a/gcc/testsuite/gfortran.dg/ichar_1.f90 b/gcc/testsuite/gfortran.dg/ichar_1.f90 new file mode 100644 index 00000000000..e63b57a8cf8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ichar_1.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! PR20879 +! Check that we reject expressions longer than one character for the +! ICHAR and IACHAR intrinsics. + +! Assumed length variables are special because the frontend doesn't have +! an expression for their length +subroutine test (c) + character(len=*) :: c + integer i + i = ichar(c) + i = ichar(c(2:)) + i = ichar(c(:1)) +end subroutine + +program ichar_1 + integer i + integer, parameter :: j = 2 + character(len=8) :: c = 'abcd' + character(len=1) :: g1(2) + character(len=1) :: g2(2,2) + character*1, parameter :: s1 = 'e' + character*2, parameter :: s2 = 'ef' + + if (ichar(c(3:3)) /= 97) call abort + if (ichar(c(:1)) /= 97) call abort + if (ichar(c(j:j)) /= 98) call abort + if (ichar(s1) /= 101) call abort + if (ichar('f') /= 102) call abort + g1(1) = 'a' + if (ichar(g1(1)) /= 97) call abort + if (ichar(g1(1)(:)) /= 97) call abort + g2(1,1) = 'a' + if (ichar(g2(1,1)) /= 97) call abort + + i = ichar(c) ! { dg-error "must be of length one" "" } + i = ichar(c(:)) ! { dg-error "must be of length one" "" } + i = ichar(s2) ! { dg-error "must be of length one" "" } + i = ichar(c(1:2)) ! { dg-error "must be of length one" "" } + i = ichar(c(1:)) ! { dg-error "must be of length one" "" } + i = ichar('abc') ! { dg-error "must be of length one" "" } + + ! ichar and iachar use the same checking routines. DO a couple of tests to + ! make sure it's not totally broken. + + if (ichar(c(3:3)) /= 97) call abort + i = ichar(c) ! { dg-error "must be of length one" "" } + + call test(g1(1)) +end program ichar_1