From: Mark Eggleston <mark.eggleston@codethink.com>
Date: Thu, 3 Oct 2019 09:40:23 +0000 (+0000)
Subject: Character typenames in errors and warnings
X-Git-Tag: upstream/12.2.0~21427
X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=f61e54e59cda5a2e281d525d3f87ffa179fae1ae;p=platform%2Fupstream%2Fgcc.git

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

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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e57cc72..10de7b9 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,17 @@
+2019-10-03 Mark Eggleston <mark.eggleston@codethink.com>
+
+	* gfortran.dg/bad_operands.f90: New test.
+	* gfortran.dg/character mismatch.f90: New test.
+	* gfortran.dg/compare_interfaces.f90: New test.
+	* gfortran.dg/hollerith_to_char_parameter_1.f90: New test.
+	* gfortran.dg/hollerith_to_char_parameter_2.f90: New test.
+	* gfortran.dg/widechar_intrinsics_1.f90: Checked for specific character
+	type names instead of "Type of argument".
+	* gfortran.dg/widechar_intrinsics_2.f90: Checked for specific character
+	type names instead of "Type of argument".
+	* gfortran.dg/widechar_intrinsics_3.f90: Checked for specific character
+	type names instead of "Type of argument".
+
 2019-10-02  Joseph Myers  <joseph@codesourcery.com>
 
 	* gcc.dg/cr-decimal-dig-2.c: New test.
diff --git a/gcc/testsuite/gfortran.dg/bad_operands.f90 b/gcc/testsuite/gfortran.dg/bad_operands.f90
new file mode 100644
index 0000000..e82a07f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bad_operands.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+!
+! Test case contributed by Mark Eggleston  <mark.eggleston@codethink.com>
+
+program test
+  integer(4) :: x
+  
+  x = x // "rubbish"       ! { dg-error "INTEGER\\(4\\)/CHARACTER\\(7\\)" }
+  x = 4_"more rubbish" + 6 ! { dg-error "CHARACTER\\(12,4\\)/INTEGER\\(4\\)" }
+end program
diff --git a/gcc/testsuite/gfortran.dg/character_mismatch.f90 b/gcc/testsuite/gfortran.dg/character_mismatch.f90
new file mode 100644
index 0000000..e161946
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/character_mismatch.f90
@@ -0,0 +1,76 @@
+! { dg-do compile }
+!
+! Test case contributed by Mark Eggleston  <mark.eggleston@codethink.com>
+
+program test
+  use iso_fortran_env
+  implicit none
+  integer, parameter :: ucs4 = selected_char_kind('ISO_10646')
+  integer :: x
+  character(len=7) :: s = "abcd123"
+  character(4, ucs4) :: s4 = char(int(z'20ac'), ucs4) // ucs4_"100"
+
+  x = s
+  x = "string"
+  x = "A longer string" // " plus a bit"
+  x = s // s
+  x = s // "a bit more"
+  x = "prefix:" // s
+  x = s4
+  x = ucs4_"string"
+  x = ucs4_"A longer string" // ucs4_" plus a bit"
+  x = s4 // s4
+  x = s4 // ucs4_"a bit more"
+  x = ucs4_"prefix:" // s4
+
+  call f(s)
+  call f("string")
+  call f("A longer string" // " plus a bit")
+  call f(s // s)
+  call f(s // "a bit more")
+  call f("a string:" // s)
+
+  call f(s4)
+  call f(ucs4_"string")
+  call f(ucs4_"A longer string" // ucs4_" plus a bit")
+  call f(s4 // s4)
+  call f(s4 // ucs4_"a bit more")
+  call f(ucs4_"a string:" // s4)
+
+  write(*,*) "" // ucs4_""
+
+contains
+  subroutine f(y)
+    integer, intent(in) :: y
+
+    write(*,*) y
+  end subroutine f
+
+end program
+
+! { dg-error "CHARACTER\\(7\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 13 }
+! { dg-error "CHARACTER\\(6\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 14 }
+! { dg-error "CHARACTER\\(26\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 15 }
+! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 16 }
+! { dg-error "CHARACTER\\(17\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 17 }
+! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 18 }
+! { dg-error "CHARACTER\\(4,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 19 }
+! { dg-error "CHARACTER\\(6,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 20 }
+! { dg-error "CHARACTER\\(26,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 21 }
+! { dg-error "CHARACTER\\(8,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 22 }
+! { dg-error "CHARACTER\\(14,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 23 }
+! { dg-error "CHARACTER\\(11,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 24 }
+! { dg-error "CHARACTER\\(7\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 26 }
+! { dg-error "CHARACTER\\(6\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 27 }
+! { dg-error "CHARACTER\\(26\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 28 }
+! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 29 }
+! { dg-error "CHARACTER\\(17\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 30 }
+! { dg-error "CHARACTER\\(16\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 31 }
+! { dg-error "CHARACTER\\(4,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 33 }
+! { dg-error "CHARACTER\\(6,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 34 }
+! { dg-error "CHARACTER\\(26,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 35 }
+! { dg-error "CHARACTER\\(8,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 36 }
+! { dg-error "CHARACTER\\(14,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 37 }
+! { dg-error "CHARACTER\\(13,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 38 }
+! { dg-error "CHARACTER\\(0\\)/CHARACTER\\(0,4\\)" "operand type mismatch" { target \*-\*-\* } 40 }
+
diff --git a/gcc/testsuite/gfortran.dg/compare_interfaces.f90 b/gcc/testsuite/gfortran.dg/compare_interfaces.f90
new file mode 100644
index 0000000..cb2cbb7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/compare_interfaces.f90
@@ -0,0 +1,73 @@
+! { dg-do compile }
+!
+! Contributed by Mark Eggleston  <mark.eggleston@codethink.co.uk>
+
+subroutine f(a, b)
+  integer :: a
+  real :: b
+
+  write(*,*) a, b
+end subroutine
+
+subroutine g(a, b)
+  integer :: a
+  character(*) :: b
+
+  write(*,*) a, b
+end subroutine
+
+subroutine h
+  interface
+    subroutine f(a, b)  ! { dg-error "\\(CHARACTER\\(\\*\\)/REAL\\(4\\)\\)" }
+      integer :: a
+      character(*) :: b
+    end subroutine
+    subroutine g(a, b)  ! { dg-error "\\(REAL\\(4\\)/CHARACTER\\(\\*\\)\\)" }
+      integer :: a
+      real :: b
+    end subroutine
+  end interface
+
+  call f(6, 6.0)
+  call g(6, "abcdef")
+end subroutine
+
+subroutine f4(a, b)
+  integer :: a
+  real :: b
+
+  write(*,*) a, b
+end subroutine
+
+subroutine g4(a, b)
+  integer :: a
+  character(*,4) :: b
+
+  write(*,*) a, b
+end subroutine
+
+subroutine h4
+  interface
+    subroutine f4(a, b)  ! { dg-error "\\(CHARACTER\\(\\*,4\\)/REAL\\(4\\)\\)" }
+      integer :: a
+      character(*,4) :: b
+    end subroutine
+    subroutine g4(a, b)  ! { dg-error "REAL\\(4\\)/CHARACTER\\(\\*,4\\)" }
+      integer :: a
+      real :: b
+    end subroutine
+  end interface
+
+  call f4(6, 6.0) 
+  call g4(6, 4_"abcdef")
+end subroutine
+
+program test
+  call h
+  call h4
+end program
+
+! { dg-error "passed REAL\\(4\\) to CHARACTER\\(\\*\\)" "type mismatch" { target \*-\*-\* } 31 }
+! { dg-error "passed CHARACTER\\(6\\) to REAL\\(4\\)" "type mismatch" { target \*-\*-\* } 32 }
+! { dg-error "passed REAL\\(4\\) to CHARACTER\\(\\*,4\\)" "type mismatch" { target \*-\*-\* } 61 }
+! { dg-error "passed CHARACTER\\(6,4\\) to REAL\\(4\\)" "type mismatch" { target \*-\*-\* } 62 }
diff --git a/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90 b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90
new file mode 100644
index 0000000..4c50be4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_1.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! { dg-options "-Wconversion -std=legacy" }
+!
+! Test case contributed by Mark Eggleston  <mark.eggleston@codethink.com>
+
+program test
+  character(*), parameter :: h = 5hABCDE ! { dg-warning "HOLLERITH to CHARACTER\\(\\*\\)" }
+
+  write(*,*) h
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90 b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90
new file mode 100644
index 0000000..1d5bc6c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/hollerith_to_char_parameter_2.f90
@@ -0,0 +1,12 @@
+! { dg-do compile }
+!
+! Test case contributed by Mark Eggleston  <mark.eggleston@codethink.com>
+
+program test
+  character(*), parameter :: h = 5hABCDE ! { dg-warning "HOLLERITH to CHARACTER\\(\\*\\)" }
+
+  write(*,*) h
+end program
+
+! { dg-warning "Legacy Extension" "extension" { target \*-\*-\* } 6 }
+
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
index cb98042..259ed1b 100644
--- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
+++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_1.f90
@@ -15,18 +15,18 @@
   call date_and_time(s4, t4, u4) ! { dg-error "must be of kind 1" }
 
   call get_command(s1)
-  call get_command(s4) ! { dg-error "Type of argument" }
+  call get_command(s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
 
   call get_command_argument(1, s1)
-  call get_command_argument(1, s4) ! { dg-error "Type of argument" }
+  call get_command_argument(1, s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
 
   call get_environment_variable("PATH", s1)
   call get_environment_variable(s1)
   call get_environment_variable(s1, t1)
-  call get_environment_variable(4_"PATH", s1) ! { dg-error "Type of argument" }
-  call get_environment_variable(s4) ! { dg-error "Type of argument" }
-  call get_environment_variable(s1, t4) ! { dg-error "Type of argument" }
-  call get_environment_variable(s4, t1) ! { dg-error "Type of argument" }
+  call get_environment_variable(4_"PATH", s1) ! { dg-error "'CHARACTER\\(4,4\\)' to 'CHARACTER\\(\\*\\)'" }
+  call get_environment_variable(s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
+  call get_environment_variable(s1, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
+  call get_environment_variable(s4, t1) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
 
   print *, lge(s1,t1)
   print *, lge(s1,"foo")
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
index 0a1d449..db4fc3c 100644
--- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
+++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_2.f90
@@ -38,9 +38,9 @@ program failme
   call getcwd (s4, i) ! { dg-error "must be of kind" }
 
   call getenv (s1, t1)
-  call getenv (s1, t4) ! { dg-error "Type of argument" }
-  call getenv (s4, t1) ! { dg-error "Type of argument" }
-  call getenv (s4, t4) ! { dg-error "Type of argument" }
+  call getenv (s1, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
+  call getenv (s4, t1) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
+  call getenv (s4, t4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
 
   call getarg (i, s1)
   call getarg (i, s4) ! { dg-error "must be of kind" }
@@ -115,8 +115,8 @@ program failme
 
   call system (s1)
   call system (s1, i)
-  call system (s4) ! { dg-error "Type of argument" }
-  call system (s4, i) ! { dg-error "Type of argument" }
+  call system (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
+  call system (s4, i) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
 
   call ttynam (i, s1)
   call ttynam (i, s4) ! { dg-error "must be of kind" }
diff --git a/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90 b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
index 7073b89..7995c36 100644
--- a/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
+++ b/gcc/testsuite/gfortran.dg/widechar_intrinsics_3.f90
@@ -35,7 +35,7 @@ program failme
   print *, fputc (i, s4) ! { dg-error "must be of kind" }
 
   print *, getcwd (s1)
-  print *, getcwd (s4) ! { dg-error "Type of argument" }
+  print *, getcwd (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
 
   print *, hostnm (s1)
   print *, hostnm (s4) ! { dg-error "must be of kind" }
@@ -61,7 +61,7 @@ program failme
   print *, symlnk (s4, t4) ! { dg-error "must be of kind" }
 
   print *, system (s1)
-  print *, system (s4) ! { dg-error "Type of argument" }
+  print *, system (s4) ! { dg-error "'CHARACTER\\(20,4\\)' to 'CHARACTER\\(\\*\\)'" }
 
   print *, unlink (s1)
   print *, unlink (s4) ! { dg-error "must be of kind" }