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

1 files changed, 58 insertions, 0 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 8fae444..7a27d04 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -922,6 +922,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)
 {
   if (double_check (a, 0) == FAILURE)