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

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

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

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

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

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

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

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