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

re PR fortran/20879 (argument to ICHAR must have length one)

Browse Source 
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.

Co-Authored-By: Steven G. Kargl <kargls@comcast.net>

From-SVN: r98686
This commit is contained in:
Paul Brook 2005-04-25 00:09:11 +00:00 committed by Paul Brook
parent 1fb2fbeb21
commit 860c8f3ba9
7 changed files with 132 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -1,3 +1,13 @@
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

58
gcc/fortran/check.c
View File

@ -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)
{

4
gcc/fortran/intrinsic.c
View File

@ -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);

1
gcc/fortran/intrinsic.h
View File

@ -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 *);

5
gcc/fortran/primary.c
View File

@ -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;
}

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
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

50
gcc/testsuite/gfortran.dg/ichar_1.f90 Normal file
View File

@ -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