This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [PATCH/gfortran] Partial fix for PR fortran/20879
On Monday 25 April 2005 00:28, Tobias Schlüter wrote:
> Steve Kargl wrote:
> > --- 922,978 ----
> >
> >
> > try
> > + gfc_check_ichar_iachar (gfc_expr * c) /* sgk */
>
> The information from the comment is available via 'cvs ann'.
>
> > + case EXPR_VARIABLE:
> > + if (c->ref)
> > + {
> > + if (c->ref->type == REF_ARRAY && c->ts.cl && c->ts.cl->length
> > + && c->ts.cl->length->expr_type == EXPR_CONSTANT)
> > + i = mpz_get_si (c->ts.cl->length->value.integer);
> > + else if (c->ref->u.ss.start->expr_type == EXPR_CONSTANT
> > + && c->ref->u.ss.end->expr_type == EXPR_CONSTANT)
> > + i = mpz_get_si (c->ref->u.ss.end->value.integer)
> > + - mpz_get_si (c->ref->u.ss.start->value.integer) + 1;
> > + else
> > + return SUCCESS; /* Punt to tree level. */
>
> This is still wrong. You have to look through the reference chain, say
> something like
> CHARACTER*5 :: c(6)
> i = ichar(c(3)(1:1))
> is perfectly valid. Components would also be broken with this approach.
> And ss.start and ss.end can be NULL, say
> i = ichar(c(3)(:))
Most of the information is already there in the expression typespec. We just
need to make sure we don't leave the old(incorect) value when parsing a
substring reference.
Fixed as attached.
Tested on i686-linux.
Applied to mainline and 4.0-branch.
Paul
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.
testsuite/
* gfortran.dg/ichar_1.f90: New file.
Index: gcc/testsuite/gfortran.dg/ichar_1.f90
===================================================================
RCS file: gcc/testsuite/gfortran.dg/ichar_1.f90
diff -N gcc/testsuite/gfortran.dg/ichar_1.f90
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ gcc/testsuite/gfortran.dg/ichar_1.f90 24 Apr 2005 23:39:48 -0000
@@ -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
Index: gcc/fortran/check.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/check.c,v
retrieving revision 1.30
diff -u -p -r1.30 check.c
--- gcc/fortran/check.c 22 Mar 2005 22:08:14 -0000 1.30
+++ gcc/fortran/check.c 24 Apr 2005 22:58:50 -0000
@@ -922,6 +922,64 @@ gfc_check_ibset (gfc_expr * i, gfc_expr
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)
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.45
diff -u -p -r1.45 intrinsic.c
--- gcc/fortran/intrinsic.c 22 Mar 2005 22:08:14 -0000 1.45
+++ gcc/fortran/intrinsic.c 24 Apr 2005 21:35:27 -0000
@@ -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);
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.28
diff -u -p -r1.28 intrinsic.h
--- gcc/fortran/intrinsic.h 22 Mar 2005 22:08:14 -0000 1.28
+++ gcc/fortran/intrinsic.h 24 Apr 2005 21:35:27 -0000
@@ -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 *);
Index: gcc/fortran/primary.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/primary.c,v
retrieving revision 1.24
diff -u -p -r1.24 primary.c
--- gcc/fortran/primary.c 5 Mar 2005 23:35:44 -0000 1.24
+++ gcc/fortran/primary.c 24 Apr 2005 23:37:13 -0000
@@ -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;
}