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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 512e8134c93fac78fa244c3871394575043132d6..bf87e6ad396a7c18ff655ff1e1067eb6246709c4 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 8fae4449fbffd0de1595de55c388ae490e44b29a..7a27d04c13f3d772637ce92de0db44ab5fc426ca 100644 (file)
--- 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 7336e63d55296d5491e6ea7e1e683c782c7d94a0..0b50cdcaa11151be389fd0eaea66dac98bf3e66e 100644 (file)
--- 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 bf2c80a0c7e9dfb91067c8532538dc04379563de..15171d1aa1434c36a4cd0f58e1a89f3d03e40956 100644 (file)
--- 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 992bc5f0af7982067d0c57042d996f1893a2bf5a..38f9939201f3b8ea423bbbe25577e51c015cc037 100644 (file)
--- 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 f58b43c1ac77320200581c0a5041decfe5b44e72..479f1f45aadd829f02551bc5b8f55f193a567c65 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/ichar_1.f90 b/gcc/testsuite/gfortran.dg/ichar_1.f90
new file mode 100644 (file)
index 0000000..e63b57a
--- /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