Character typenames in errors and warnings

    
Character type names now incorporate length, kind is only shown if
the default character is not being used.
    
Examples:
   
  character(7) is reported as CHARACTER(7)
  character(len=20,kind=4) is reported as CHARACTER(20,4)
   
dummy character variables with assumed length:
    
  character(*) is reported as CHARACTER(*)
  character(*,kind=4) is reported as CHARACTER(*,4)

From-SVN: r276505

10 files changed, 164 insertions, 45 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ea1177f..64812f2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,47 @@
+2019-10-03  Mark Eggleston  <mark.eggleston@codethink.com>
+
+	* array.c (check_element_type): Call gfc_typename with the gfc_expr
+	"expr" instead of its gfc_typespec "ts".
+	* check.c (gfc_check_co_reduce): Call gfc_typename with the gfc_expr
+	"a" instead of its gfc_typespec "ts".
+	(gfc_check_co_reduce): Call gfc_typename with the gfc_expr "a" instead
+	 of its gfc_typespec "ts".
+	(gfc_check_eoshift): Call gfc_typename with the gfc_expr "array"
+	instead of its gfc_typespec ts.
+	(gfc_check_same_type_as): In two calls to gfc_typename use "a" and "b"
+	of type gfc_expr instead of the "ts" fields of "a" and "b"
+	* decl.c (variable_decl): Call gfc_typename with the gfc_expr
+	"initializer" instead of its gfc_typespec "ts".
+	* expr.c (gfc_check_assign): Use "rvalue" and "lvalue" of type gfc_expr
+	in calls to gfc_typename instead of their "ts" fields of type
+	gfc_typespec.
+	(gfc_check_pointer_assign): Use "rvalue" and "lvalue" of type gfc_expr
+	in calls to gfc_typename instead of their "ts" fields of type
+	gfc_typespec.
+	* gfortran.h: Add prototypes for gfc_dummy_typename and a new function
+	gfc_typename for gfc_expr *.
+	*interface.c (gfc_check_dummy_characteristics): Use gfc_dummy_typename
+	for the dummy variable.
+	(compare_parameter): Use gfc_dummy_typename for the formal argument.
+	Use "actual" of type gfc_expr in call to gfc_typename for the actual
+	argument.
+	* intrinsic.c (check_arglist): Use gfc_dummy_typename for the formal
+	argument. Use expressions of type gfc_expr from the argument list to
+	call gfc_typename.
+	(gfc_convert_type_warn): New local variable "is_char_constant" set if
+	the expression type is a character constant. At the "bad" label
+	determine source type name by calling gfc_typename with either "expr"
+	for character constants or "from_ts" and use that in the warning
+	messages instead of the original call to gfc_typename.
+	* misc.c (gfc_typename): New function for gfc_expr *, use for where
+	character types are possible it can get the character length from
+        gfc_expr for character literals.
+	(gfc_dummy_typename): New functionfor gfc_typespec *, if no character
+	length is present the character type is assumed and the appropriate 
+	string is return otherwise it calls gfc_typename for gfc_typespec *.
+	(gfc_typespec): for character types construct the type name with length
+	and kind (if it is not default kind).
+
 2019-10-02  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/91784
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index ba8a816..3a504eb 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -1358,7 +1358,7 @@ check_element_type (gfc_expr *expr, bool convert)
 
   gfc_error ("Element in %s array constructor at %L is %s",
 	     gfc_typename (&constructor_ts), &expr->where,
-	     gfc_typename (&expr->ts));
+	     gfc_typename (expr));
 
   cons_state = CONS_BAD;
   return 1;
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 98203bc..87a8196 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2266,7 +2266,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
     {
       gfc_error ("The A argument at %L has type %s but the function passed as "
 		 "OPERATOR at %L returns %s",
-		 &a->where, gfc_typename (&a->ts), &op->where,
+		 &a->where, gfc_typename (a), &op->where,
 		 gfc_typename (&sym->result->ts));
       return false;
     }
@@ -2276,7 +2276,7 @@ gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
       gfc_error ("The function passed as OPERATOR at %L has arguments of type "
 		 "%s and %s but shall have type %s", &op->where,
 		 gfc_typename (&formal->sym->ts),
-		 gfc_typename (&formal->next->sym->ts), gfc_typename (&a->ts));
+		 gfc_typename (&formal->next->sym->ts), gfc_typename (a));
       return false;
     }
   if (op->rank || attr.allocatable || attr.pointer || formal->sym->as
@@ -2844,7 +2844,7 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
 		     "of type %qs", gfc_current_intrinsic_arg[2]->name,
 		     gfc_current_intrinsic, &array->where,
 		     gfc_current_intrinsic_arg[0]->name,
-		     gfc_typename (&array->ts));
+		     gfc_typename (array));
 	  return false;
 	}
     }
@@ -4808,7 +4808,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
 		   "cannot be of type %s",
 		   gfc_current_intrinsic_arg[0]->name,
 		   gfc_current_intrinsic,
-		   &a->where, gfc_typename (&a->ts));
+		   &a->where, gfc_typename (a));
         return false;
     }
 
@@ -4827,7 +4827,7 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
 		   "cannot be of type %s",
 		   gfc_current_intrinsic_arg[0]->name,
 		   gfc_current_intrinsic,
-		   &b->where, gfc_typename (&b->ts));
+		   &b->where, gfc_typename (b));
       return false;
     }
 
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 3ba61a0..96b6f3f 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2908,7 +2908,7 @@ variable_decl (int elem)
     {
       gfc_error ("Incompatible initialization between a derived type "
 		 "entity and an entity with %qs type at %C",
-		  gfc_typename (&initializer->ts));
+		  gfc_typename (initializer));
       m = MATCH_ERROR;
       goto cleanup;
     }
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 5d3480e..9f638fe 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3693,8 +3693,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
 	return true;
 
       gfc_error ("BOZ literal constant near %L cannot be assigned to a "
-		 "%qs variable", &rvalue->where, gfc_typename (&lvalue->ts));
-
+		 "%qs variable", &rvalue->where, gfc_typename (lvalue));
       return false;
     }
 
@@ -3726,7 +3725,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
       where = lvalue->where.lb ? &lvalue->where : &rvalue->where;
       gfc_error ("Incompatible types in DATA statement at %L; attempted "
 		 "conversion of %s to %s", where,
-		 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
+		 gfc_typename (rvalue), gfc_typename (lvalue));
 
       return false;
     }
@@ -4139,8 +4138,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue,
       else if (!suppress_type_test)
 	gfc_error ("Different types in pointer assignment at %L; "
 		   "attempted assignment of %s to %s", &lvalue->where,
-		   gfc_typename (&rvalue->ts),
-		   gfc_typename (&lvalue->ts));
+		   gfc_typename (rvalue), gfc_typename (lvalue));
       return false;
     }
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a70978b..d84d1fa 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2884,7 +2884,9 @@ void gfc_end_source_files (void);
 void gfc_clear_ts (gfc_typespec *);
 FILE *gfc_open_file (const char *);
 const char *gfc_basic_typename (bt);
+const char *gfc_dummy_typename (gfc_typespec *);
 const char *gfc_typename (gfc_typespec *);
+const char *gfc_typename (gfc_expr *);
 const char *gfc_op2string (gfc_intrinsic_op);
 const char *gfc_code2string (const mstring *, int);
 int gfc_string2code (const mstring *, const char *);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 08e4f06..3313e72 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1330,7 +1330,8 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
 	  || !compare_type_characteristics (s2, s1))
 	{
 	  snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
-		    s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts));
+		    s1->name, gfc_dummy_typename (&s1->ts),
+		    gfc_dummy_typename (&s2->ts));
 	  return false;
 	}
       if (!compare_rank (s1, s2))
@@ -2338,15 +2339,15 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 			       "and actual argument at %L (%s/%s).",
 			       &actual->where,
 			       &formal->declared_at,
-			       gfc_typename (&actual->ts),
-			       gfc_typename (&formal->ts));
+			       gfc_typename (actual),
+			       gfc_dummy_typename (&formal->ts));
 
 	      formal->error = 1;
 	    }
 	  else
 	    gfc_error_opt (0, "Type mismatch in argument %qs at %L; passed %s "
-			   "to %s", formal->name, where, gfc_typename (&actual->ts),
-			   gfc_typename (&formal->ts));
+			   "to %s", formal->name, where, gfc_typename (actual),
+			   gfc_dummy_typename (&formal->ts));
 	}
       return false;
     }
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 764e350..ac5af10 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4363,11 +4363,12 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
       if (!gfc_compare_types (&ts, &actual->expr->ts))
 	{
 	  if (error_flag)
-	    gfc_error ("Type of argument %qs in call to %qs at %L should "
-		       "be %s, not %s", gfc_current_intrinsic_arg[i]->name,
-		       gfc_current_intrinsic, &actual->expr->where,
-		       gfc_typename (&formal->ts),
-		       gfc_typename (&actual->expr->ts));
+	    gfc_error ("In call to %qs at %L, type mismatch in argument "
+		       "%qs; pass %qs to %qs", gfc_current_intrinsic,
+		       &actual->expr->where,
+		       gfc_current_intrinsic_arg[i]->name,
+		       gfc_typename (actual->expr),
+		       gfc_dummy_typename (&formal->ts));
 	  return false;
 	}
 
@@ -5076,6 +5077,8 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
   gfc_expr *new_expr;
   int rank;
   mpz_t *shape;
+  bool is_char_constant = (expr->expr_type == EXPR_CONSTANT)
+			  && (expr->ts.type == BT_CHARACTER);
 
   from_ts = expr->ts;		/* expr->ts gets clobbered */
 
@@ -5117,7 +5120,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
   if ((gfc_option.warn_std & sym->standard) != 0)
     {
       gfc_warning_now (0, "Extension: Conversion from %s to %s at %L",
-		       gfc_typename (&from_ts), gfc_typename (ts),
+		       gfc_typename (&from_ts), gfc_dummy_typename (ts),
 		       &expr->where);
     }
   else if (wflag)
@@ -5179,7 +5182,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
 	  /* If HOLLERITH is involved, all bets are off.  */
 	  if (warn_conversion)
 	    gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L",
-			     gfc_typename (&from_ts), gfc_typename (ts),
+			     gfc_typename (&from_ts), gfc_dummy_typename (ts),
 			     &expr->where);
 	}
       else
@@ -5231,15 +5234,17 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
   return true;
 
 bad:
+  const char *type_name = is_char_constant ? gfc_typename (expr)
+					   : gfc_typename (&from_ts);
   if (eflag == 1)
     {
-      gfc_error ("Cannot convert %s to %s at %L",
-		 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
+      gfc_error ("Cannot convert %s to %s at %L", type_name, gfc_typename (ts),
+		 &expr->where);
       return false;
     }
 
-  gfc_internal_error ("Cannot convert %qs to %qs at %L",
-		      gfc_typename (&from_ts), gfc_typename (ts),
+  gfc_internal_error ("Cannot convert %qs to %qs at %L", type_name,
+		      gfc_typename (ts),
 		      &expr->where);
   /* Not reached */
 }
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index eed203d..97df9ee 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -129,6 +129,7 @@ gfc_typename (gfc_typespec *ts)
   static int flag = 0;
   char *buffer;
   gfc_typespec *ts1;
+  gfc_charlen_t length = 0;
 
   buffer = flag ? buffer1 : buffer2;
   flag = !flag;
@@ -148,7 +149,13 @@ gfc_typename (gfc_typespec *ts)
       sprintf (buffer, "LOGICAL(%d)", ts->kind);
       break;
     case BT_CHARACTER:
-      sprintf (buffer, "CHARACTER(%d)", ts->kind);
+      if (ts->u.cl && ts->u.cl->length)
+	length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
+      if (ts->kind == gfc_default_character_kind)
+	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
+      else
+	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
+		 ts->kind);
       break;
     case BT_HOLLERITH:
       sprintf (buffer, "HOLLERITH");
@@ -186,6 +193,68 @@ gfc_typename (gfc_typespec *ts)
 }
 
 
+const char *
+gfc_typename (gfc_expr *ex)
+{
+  /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
+     add 19 for the extra width and 1 for '\0' */
+  static char buffer1[34];
+  static char buffer2[34];
+  static bool flag = false;
+  char *buffer;
+  gfc_charlen_t length;
+  buffer = flag ? buffer1 : buffer2;
+  flag = !flag;
+
+  if (ex->ts.type == BT_CHARACTER)
+    {
+      if (ex->ts.u.cl && ex->ts.u.cl->length)
+	length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
+      else
+	length = ex->value.character.length;
+      if (ex->ts.kind == gfc_default_character_kind)
+	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
+      else
+	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
+		 ex->ts.kind);
+      return buffer;
+    }
+  return gfc_typename(&ex->ts);
+}
+
+/* The type of a dummy variable can also be CHARACTER(*).  */
+
+const char *
+gfc_dummy_typename (gfc_typespec *ts)
+{
+  static char buffer1[15];  /* 15 for "CHARACTER(*,4)" + '\0'.  */
+  static char buffer2[15];
+  static bool flag = false;
+  char *buffer;
+
+  buffer = flag ? buffer1 : buffer2;
+  flag = !flag;
+
+  if (ts->type == BT_CHARACTER)
+    {
+      bool has_length = false;
+      if (ts->u.cl)
+	has_length = ts->u.cl->length != NULL;
+      if (!has_length)
+	{
+	  if (ts->kind == gfc_default_character_kind)
+	    sprintf(buffer, "CHARACTER(*)");
+	  else if (ts->kind < 10)
+	    sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
+	  else
+	    sprintf(buffer, "CHARACTER(*,?)");
+	  return buffer;
+	}
+    }
+  return gfc_typename(ts);
+}
+
+
 /* Given an mstring array and a code, locate the code in the table,
    returning a pointer to the string.  */
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index a792547..20ecafd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3980,7 +3980,7 @@ resolve_operator (gfc_expr *e)
 	}
 
       sprintf (msg, _("Operand of unary numeric operator %%<%s%%> at %%L is %s"),
-	       gfc_op2string (e->value.op.op), gfc_typename (&e->ts));
+	       gfc_op2string (e->value.op.op), gfc_typename (e));
       goto bad_op;
 
     case INTRINSIC_PLUS:
@@ -4002,8 +4002,8 @@ resolve_operator (gfc_expr *e)
       else
       	sprintf (msg,
 	       _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"),
-	       gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
-	       gfc_typename (&op2->ts));
+	       gfc_op2string (e->value.op.op), gfc_typename (op1),
+	       gfc_typename (op2));
       goto bad_op;
 
     case INTRINSIC_CONCAT:
@@ -4017,7 +4017,7 @@ resolve_operator (gfc_expr *e)
 
       sprintf (msg,
 	       _("Operands of string concatenation operator at %%L are %s/%s"),
-	       gfc_typename (&op1->ts), gfc_typename (&op2->ts));
+	       gfc_typename (op1), gfc_typename (op2));
       goto bad_op;
 
     case INTRINSIC_AND:
@@ -4059,8 +4059,8 @@ resolve_operator (gfc_expr *e)
 	}
 
       sprintf (msg, _("Operands of logical operator %%<%s%%> at %%L are %s/%s"),
-	       gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
-	       gfc_typename (&op2->ts));
+	       gfc_op2string (e->value.op.op), gfc_typename (op1),
+	       gfc_typename (op2));
 
       goto bad_op;
 
@@ -4082,7 +4082,7 @@ resolve_operator (gfc_expr *e)
 	}
 
       sprintf (msg, _("Operand of .not. operator at %%L is %s"),
-	       gfc_typename (&op1->ts));
+		      gfc_typename (op1));
       goto bad_op;
 
     case INTRINSIC_GT:
@@ -4168,7 +4168,7 @@ resolve_operator (gfc_expr *e)
 		    msg = "Inequality comparison for %s at %L";
 
 		  gfc_warning (OPT_Wcompare_reals, msg,
-			       gfc_typename (&op1->ts), &op1->where);
+			       gfc_typename (op1), &op1->where);
 		}
 	    }
 
@@ -4184,8 +4184,8 @@ resolve_operator (gfc_expr *e)
       else
 	sprintf (msg,
 		 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"),
-		 gfc_op2string (e->value.op.op), gfc_typename (&op1->ts),
-		 gfc_typename (&op2->ts));
+		 gfc_op2string (e->value.op.op), gfc_typename (op1),
+		 gfc_typename (op2));
 
       goto bad_op;
 
@@ -4203,12 +4203,12 @@ resolve_operator (gfc_expr *e)
 	}
       else if (op2 == NULL)
 	sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
-		 e->value.op.uop->name, gfc_typename (&op1->ts));
+		 e->value.op.uop->name, gfc_typename (op1));
       else
 	{
 	  sprintf (msg, _("Operands of user operator %%<%s%%> at %%L are %s/%s"),
-		   e->value.op.uop->name, gfc_typename (&op1->ts),
-		   gfc_typename (&op2->ts));
+		   e->value.op.uop->name, gfc_typename (op1),
+		   gfc_typename (op2));
 	  e->value.op.uop->op->sym->attr.referenced = 1;
 	}
 
@@ -8509,7 +8509,7 @@ resolve_select (gfc_code *code, bool select_type)
   if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER)
     {
       gfc_error ("Argument of SELECT statement at %L cannot be %s",
-		 &case_expr->where, gfc_typename (&case_expr->ts));
+		 &case_expr->where, gfc_typename (case_expr));
 
       /* Punt. Going on here just produce more garbage error messages.  */
       return;
@@ -8538,7 +8538,7 @@ resolve_select (gfc_code *code, bool select_type)
 					  case_expr->ts.kind) != ARITH_OK)
 	    gfc_warning (0, "Expression in CASE statement at %L is "
 			 "not in the range of %s", &cp->low->where,
-			 gfc_typename (&case_expr->ts));
+			 gfc_typename (case_expr));
 
 	  if (cp->high
 	      && cp->low != cp->high
@@ -8546,7 +8546,7 @@ resolve_select (gfc_code *code, bool select_type)
 					  case_expr->ts.kind) != ARITH_OK)
 	    gfc_warning (0, "Expression in CASE statement at %L is "
 			 "not in the range of %s", &cp->high->where,
-			 gfc_typename (&case_expr->ts));
+			 gfc_typename (case_expr));
 	}
 
   /* PR 19168 has a long discussion concerning a mismatch of the kinds