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

1 files changed, 70 insertions, 1 deletions

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.  */