+2005-04-25 Paul Brook <paul@codesourcery.com>
+ Steven G. Kargl <kargls@comcast.net>
+
+ 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 <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/20059
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)
{
if (double_check (a, 0) == FAILURE)
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);
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);
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 *);
if (primary->expr_type == EXPR_CONSTANT)
primary->expr_type = EXPR_SUBSTRING;
+ if (substring)
+ primary->ts.cl = NULL;
+
break;
case MATCH_NO:
}
e->ts = sym->ts;
+ if (e->ref)
+ e->ts.cl = NULL;
m = MATCH_YES;
break;
}
+2005-04-25 Paul Brook <paul@codesourcery.com>
+ Steven G. Kargl <kargls@comcast.net>
+
+ PR fortran/20879
+ * gfortran.dg/ichar_1.f90: New file.
+
2005-04-24 Jakub Jelinek <jakub@redhat.com>
PR middle-end/20991
--- /dev/null
+! { 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