re PR fortran/29892 (substring out of bounds: Missing variable name for variables with parameter attribute)

PR fortran/29892
	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use a locus in
	the call to gfc_trans_runtime_check.
	* trans-array.c (gfc_trans_array_bound_check): Try harder to find
	the variable or function name for the runtime error message.
	(gfc_trans_dummy_array_bias): Use a locus in the call to
	gfc_trans_runtime_check

	PR fortran/29973
	* resolve.c (resolve_actual_arglist): Remove the special case for
	CHAR.
	* intrinsic.c (add_functions): Remove the special case for CHAR.

	PR fortran/29711
	* error.c (error_print): Handle printf-style position specifiers,
	of the form "%3$d".

	PR fortran/29973
	* gfortran.dg/specifics_1.f90: Remove check for CHAR.
	* gfortran.dg/specifics_2.f90: Remove check for CHAR.
	* gfortran.dg/specifics_3.f90: Remove.
	* gfortran.fortran-torture/execute/specifics.f90: Remove test
	for CHAR.

Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r119747

gcc/fortran/ChangeLog

@@ -1,3 +1,27 @@
+2006-12-11  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29892
+	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Use a locus in
+	the call to gfc_trans_runtime_check.
+	* trans-array.c (gfc_trans_array_bound_check): Try harder to find
+	the variable or function name for the runtime error message.
+	(gfc_trans_dummy_array_bias): Use a locus in the call to
+	gfc_trans_runtime_check
+
+2006-12-11  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29973
+	* resolve.c (resolve_actual_arglist): Remove the special case for
+	CHAR.
+	* intrinsic.c (add_functions): Remove the special case for CHAR.
+
+2006-12-11  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+	    Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/29711
+	* error.c (error_print): Handle printf-style position specifiers,
+	of the form "%3$d".
+
 2006-12-10  Thomas Koenig  <Thomas.Koenig@online.de>
 
 	PR libfortran/29568

gcc/fortran/error.c

@@ -378,69 +378,150 @@ show_loci (locus * l1, locus * l2)
 static void ATTRIBUTE_GCC_GFC(2,0)
 error_print (const char *type, const char *format0, va_list argp)
 {
-  char c, c_arg[MAX_ARGS], *cp_arg[MAX_ARGS];
-  int n, have_l1, i_arg[MAX_ARGS];
+  enum { TYPE_CURRENTLOC, TYPE_LOCUS, TYPE_INTEGER, TYPE_CHAR, TYPE_STRING,
+	 NOTYPE };
+  struct
+  {
+    int type;
+    int pos;
+    union
+    {
+      int intval;
+      char charval;
+      const char * stringval;
+    } u;
+  } arg[MAX_ARGS], spec[MAX_ARGS];
+  /* spec is the array of specifiers, in the same order as they
+     appear in the format string.  arg is the array of arguments,
+     in the same order as they appear in the va_list.  */
+
+  char c;
+  int i, n, have_l1, pos, maxpos;
   locus *l1, *l2, *loc;
   const char *format;
 
-  l1 = l2 = loc = NULL;
+  l1 = l2 = NULL;
 
   have_l1 = 0;
+  pos = -1;
+  maxpos = -1;
 
   n = 0;
   format = format0;
 
+  for (i = 0; i < MAX_ARGS; i++)
+    {
+      arg[i].type = NOTYPE;
+      spec[i].pos = -1;
+    }
+
+  /* First parse the format string for position specifiers.  */
   while (*format)
     {
       c = *format++;
-      if (c == '%')
+      if (c != '%')
+	continue;
+
+      if (*format == '%')
+	continue;
+
+      if (ISDIGIT (*format))
 	{
-	  c = *format++;
+	  /* This is a position specifier.  For example, the number
+	     12 in the format string "%12$d", which specifies the third
+	     argument of the va_list, formatted in %d format.
+	     For details, see "man 3 printf".  */
+	  pos = atoi(format) - 1;
+	  gcc_assert (pos >= 0);
+	  while (ISDIGIT(*format))
+	    format++;
+	  gcc_assert (*format++ == '$');
+	}
+      else
+	pos++;
 
-	  switch (c)
-	    {
-	    case '%':
-	      break;
+      c = *format++;
 
-	    case 'L':
+      if (pos > maxpos)
+	maxpos = pos;
+
+      switch (c)
+	{
+	  case 'C':
+	    arg[pos].type = TYPE_CURRENTLOC;
+	    break;
+
+	  case 'L':
+	    arg[pos].type = TYPE_LOCUS;
+	    break;
+
+	  case 'd':
+	  case 'i':
+	    arg[pos].type = TYPE_INTEGER;
+	    break;
+
+	  case 'c':
+	    arg[pos].type = TYPE_CHAR;
+	    break;
+
+	  case 's':
+	    arg[pos].type = TYPE_STRING;
+	    break;
+
+	  default:
+	    gcc_unreachable ();
+	}
+
+      spec[n++].pos = pos;
+    }
+
+  /* Then convert the values for each %-style argument.  */
+  for (pos = 0; pos <= maxpos; pos++)
+    {
+      gcc_assert (arg[pos].type != NOTYPE);
+      switch (arg[pos].type)
+	{
+	  case TYPE_CURRENTLOC:
+	    loc = &gfc_current_locus;
+	    /* Fall through.  */
+
+	  case TYPE_LOCUS:
+	    if (arg[pos].type == TYPE_LOCUS)
 	      loc = va_arg (argp, locus *);
-	      /* Fall through */
 
-	    case 'C':
-	      if (c == 'C')
-		loc = &gfc_current_locus;
+	    if (have_l1)
+	      {
+		l2 = loc;
+		arg[pos].u.stringval = "(2)";
+	      }
+	    else
+	      {
+		l1 = loc;
+		have_l1 = 1;
+		arg[pos].u.stringval = "(1)";
+	      }
+	    break;
 
-	      if (have_l1)
-		{
-		  l2 = loc;
-		}
-	      else
-		{
-		  l1 = loc;
-		  have_l1 = 1;
-		}
-	      break;
+	  case TYPE_INTEGER:
+	    arg[pos].u.intval = va_arg (argp, int);
+	    break;
 
-	    case 'd':
-	    case 'i':
-	      i_arg[n++] = va_arg (argp, int);
-	      break;
+	  case TYPE_CHAR:
+	    arg[pos].u.charval = (char) va_arg (argp, int);
+	    break;
 
-	    case 'c':
-	      c_arg[n++] = va_arg (argp, int);
-	      break;
+	  case TYPE_STRING:
+	    arg[pos].u.stringval = (const char *) va_arg (argp, char *);
+	    break;
 
-	    case 's':
-	      cp_arg[n++] = va_arg (argp, char *);
-	      break;
-
-	    case '\0':
-	      format--;
-	      break;
-	    }
+	  default:
+	    gcc_unreachable ();
 	}
     }
 
+  for (n = 0; spec[n].pos >= 0; n++)
+    spec[n].u = arg[spec[n].pos].u;
+
   /* Show the current loci if we have to.  */
   if (have_l1)
     show_loci (l1, l2);
@@ -464,6 +545,16 @@ error_print (const char *type, const char *format0, va_list argp)
 	}
 
       format++;
+      if (ISDIGIT(*format))
+	{
+	  /* This is a position specifier.  See comment above.  */
+	  while (ISDIGIT(*format))
+	    format++;
+	    
+	  /* Skip over the dollar sign.  */
+	  format++;
+	}
+	
       switch (*format)
 	{
 	case '%':
@@ -471,26 +562,18 @@ error_print (const char *type, const char *format0, va_list argp)
 	  break;
 
 	case 'c':
-	  error_char (c_arg[n++]);
+	  error_char (spec[n++].u.charval);
 	  break;
 
 	case 's':
-	  error_string (cp_arg[n++]);
+	case 'C':		/* Current locus */
+	case 'L':		/* Specified locus */
+	  error_string (spec[n++].u.stringval);
 	  break;
 
 	case 'd':
 	case 'i':
-	  error_integer (i_arg[n++]);
-	  break;
-
-	case 'C':		/* Current locus */
-	case 'L':		/* Specified locus */
-	  error_string (have_l1 ? "(2)" : "(1)");
-	  have_l1 = 1;
-	  break;
-
-	case '\0':
-	  format--;
+	  error_integer (spec[n++].u.intval);
 	  break;
 	}
     }

gcc/fortran/intrinsic.c

@@ -200,7 +200,7 @@ do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
    Argument list:
       char *     name of function
       int        whether function is elemental
-      int        If the function can be used as an actual argument [1] [2]
+      int        If the function can be used as an actual argument [1]
       bt         return type of function
       int        kind of return type of function
       int        Fortran standard version
@@ -221,10 +221,7 @@ do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
      determined by its presence on the 13.6 list in Fortran 2003.  The
      following intrinsics, which are GNU extensions, are considered allowed
      as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG
-     ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT.
- [2] The value 2 is used in this field for CHAR, which is allowed as an
-     actual argument in F2003, but not in F95. It is the only such
-     intrinsic function.  */
+     ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT.  */
 
 static void
 add_sym (const char *name, int elemental, int actual_ok, bt type, int kind,
@@ -1180,7 +1177,7 @@ add_functions (void)
 
   make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
 
-  add_sym_2 ("char", 1, 2, BT_CHARACTER, dc, GFC_STD_F77,
+  add_sym_2 ("char", ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77,
 	     gfc_check_char, gfc_simplify_char, gfc_resolve_char,
 	     i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
 

gcc/fortran/resolve.c

@@ -881,12 +881,6 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	      gfc_error ("Intrinsic '%s' at %L is not allowed as an "
 			 "actual argument", sym->name, &e->where);
 	    }
-	  else if (sym->attr.intrinsic && actual_ok == 2)
-	  /* We need a special case for CHAR, which is the only intrinsic
-	     function allowed as actual argument in F2003 and not allowed
-	     in F95.  */
-	    gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CHAR intrinsic "
-			    "allowed as actual argument at %L", &e->where);
 
 	  if (sym->attr.contained && !sym->attr.use_assoc
 	      && sym->ns->proc_name->attr.flavor != FL_MODULE)

gcc/fortran/trans-array.c

@@ -1851,18 +1851,47 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
   tree fault;
   tree tmp;
   char *msg;
+  const char * name = NULL;
 
   if (!flag_bounds_check)
     return index;
 
   index = gfc_evaluate_now (index, &se->pre);
 
+  /* We find a name for the error message.  */
+  if (se->ss)
+    name = se->ss->expr->symtree->name;
+
+  if (!name && se->loop && se->loop->ss && se->loop->ss->expr
+      && se->loop->ss->expr->symtree)
+    name = se->loop->ss->expr->symtree->name;
+
+  if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
+      && se->loop->ss->loop_chain->expr
+      && se->loop->ss->loop_chain->expr->symtree)
+    name = se->loop->ss->loop_chain->expr->symtree->name;
+
+  if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
+      && se->loop->ss->loop_chain->expr->symtree)
+    name = se->loop->ss->loop_chain->expr->symtree->name;
+
+  if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
+    {
+      if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
+	  && se->loop->ss->expr->value.function.name)
+	name = se->loop->ss->expr->value.function.name;
+      else
+	if (se->loop->ss->type == GFC_SS_CONSTRUCTOR
+	    || se->loop->ss->type == GFC_SS_SCALAR)
+	  name = "unnamed constant";
+    }
+
   /* Check lower bound.  */
   tmp = gfc_conv_array_lbound (descriptor, n);
   fault = fold_build2 (LT_EXPR, boolean_type_node, index, tmp);
-  if (se->ss)
+  if (name)
     asprintf (&msg, "%s for array '%s', lower bound of dimension %d exceeded",
-	      gfc_msg_fault, se->ss->expr->symtree->name, n+1);
+	      gfc_msg_fault, name, n+1);
   else
     asprintf (&msg, "%s, lower bound of dimension %d exceeded",
 	      gfc_msg_fault, n+1);
@@ -1872,9 +1901,9 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
   /* Check upper bound.  */
   tmp = gfc_conv_array_ubound (descriptor, n);
   fault = fold_build2 (GT_EXPR, boolean_type_node, index, tmp);
-  if (se->ss)
+  if (name)
     asprintf (&msg, "%s for array '%s', upper bound of dimension %d exceeded",
-	      gfc_msg_fault, se->ss->expr->symtree->name, n+1);
+	      gfc_msg_fault, name, n+1);
   else
     asprintf (&msg, "%s, upper bound of dimension %d exceeded",
 	      gfc_msg_fault, n+1);
@@ -3928,7 +3957,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
               tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
 	      asprintf (&msg, "%s for dimension %d of array '%s'",
 			gfc_msg_bounds, n+1, sym->name);
-	      gfc_trans_runtime_check (tmp, msg, &block, NULL);
+	      gfc_trans_runtime_check (tmp, msg, &block, &loc);
 	      gfc_free (msg);
 	    }
 	}

gcc/fortran/trans-intrinsic.c

@@ -777,7 +777,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
-          gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL);
+          gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where);
         }
     }
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,12 @@
+2006-12-11  Francois-Xavier Coudert  <coudert@clipper.ens.fr>
+
+	PR fortran/29973
+	* gfortran.dg/specifics_1.f90: Remove check for CHAR.
+	* gfortran.dg/specifics_2.f90: Remove check for CHAR.
+	* gfortran.dg/specifics_3.f90: Remove.
+	* gfortran.fortran-torture/execute/specifics.f90: Remove test
+	for CHAR.
+
 2006-12-10  Thomas Koenig  <Thomas.Koenig@online.de>
 
 	Backport from mainline

gcc/testsuite/gfortran.dg/specifics_1.f90

@@ -145,12 +145,6 @@ subroutine test_len(fn,val,res)
   if (res .ne. fn(val)) call abort
 end subroutine
 
-subroutine test_char(fn,val,res)
-  integer val
-  character(len=1) fn, res
-  if (res .ne. fn(val)) call abort
-end subroutine
-
 subroutine test_index(fn,val1,val2,res)
   integer fn, res
   character(len=*) val1, val2
@@ -235,7 +229,6 @@ program specifics
   intrinsic mod
   intrinsic len
   intrinsic index
-  intrinsic char
 
   intrinsic aimag
   intrinsic dimag
@@ -319,7 +312,6 @@ program specifics
   call test_iabs (iabs, -7, iabs(-7))
   call test_idim (mod, 5, 2, mod(5,2))
   call test_len (len, "foobar", len("foobar"))
-  call test_char (char, 47, char(47))
   call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar"))
 
 end program

gcc/testsuite/gfortran.dg/specifics_2.f90

@@ -1,7 +1,7 @@
 ! { dg-do compile }
 ! This is the list of intrinsics allowed as actual arguments
  intrinsic abs,acos,acosh,aimag,aint,alog,alog10,amod,anint,asin,asinh,atan,&
- atan2,atanh,cabs,ccos,cexp,char,clog,conjg,cos,cosh,csin,csqrt,dabs,dacos,&
+ atan2,atanh,cabs,ccos,cexp,clog,conjg,cos,cosh,csin,csqrt,dabs,dacos,&
  dacosh,dasin,dasinh,datan,datan2,datanh,dconjg,dcos,dcosh,ddim,dexp,dim,&
  dimag,dint,dlog,dlog10,dmod,dnint,dprod,dsign,dsin,dsinh,dsqrt,dtan,dtanh,&
  exp,iabs,idim,idnint,index,isign,len,mod,nint,sign,sin,sinh,sqrt,tan,&
@@ -24,7 +24,6 @@
   call foo(cabs)
   call foo(ccos)
   call foo(cexp)
-  call foo(char)
   call foo(clog)
   call foo(conjg)
   call foo(cos)

gcc/testsuite/gfortran.dg/specifics_3.f90

@@ -1,5 +0,0 @@
-! { dg-do compile }
-! { dg-options "-std=f95" }
-  intrinsic char
-  call foo(char) ! { dg-error "Fortran 2003: CHAR intrinsic allowed as actual argument" }
-  end

gcc/testsuite/gfortran.fortran-torture/execute/specifics.f90

@@ -138,12 +138,6 @@ subroutine test_len(fn,val,res)
   if (res .ne. fn(val)) call abort
 end subroutine
 
-subroutine test_char(fn,val,res)
-  integer val
-  character(len=1) fn, res
-  if (res .ne. fn(val)) call abort
-end subroutine
-
 subroutine test_index(fn,val1,val2,res)
   integer fn, res
   character(len=*) val1, val2
@@ -228,7 +222,6 @@ program specifics
   intrinsic mod
   intrinsic len
   intrinsic index
-  intrinsic char
 
   intrinsic aimag
   intrinsic dimag
@@ -312,7 +305,6 @@ program specifics
   call test_iabs (iabs, -7, iabs(-7))
   call test_idim (mod, 5, 2, mod(5,2))
   call test_len (len, "foobar", len("foobar"))
-  call test_char (char, 47, char(47))
   call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar"))
 
 end program