Allow CHARACTER literals in assignments and data statements.

Allows character literals to used to assign values to non-character variables
in the same way that Hollerith constants are used. In addition character
literals can be used in data statements just like Hollerith constants.

Warnings of such use are output to discourage this usage as it is a non-standard
legacy feature and must be explicitly enabled.
 
Enabled by -fdec and -fdec-char-conversions.


Co-Authored-By: Jim MacArthur <jim.macarthur@codethink.co.uk>

From-SVN: r277975

12 files changed, 264 insertions, 33 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f13444f..18e4c02 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,33 @@
+2019-11-08  Mark Eggleston  <mark.eggleston@codethink.com>
+	Jim MacArthur  <jim.macarthur@codethink.co.uk>
+
+	* arith.c (hollerith2representation): Use OPT_Wcharacter_truncation in
+	call to gfc_warning.  Add character2representation, gfc_character2int,
+	gfc_character2real, gfc_character2complex and gfc_character2logical.
+	* arith.h: Add prototypes for gfc_character2int, gfc_character2real,
+	gfc_character2complex and gfc_character2logical.
+	* expr.c (gfc_check_assign): Return true if left hand side is numeric
+	or logical and the right hand side is character and of kind=1.
+	* gfortran.texi: Add -fdec-char-conversions.
+	* intrinsic.c (add_conversions): Add conversions from character to
+	integer, real, complex and logical types for their supported kinds.
+	(gfc_convert_type_warn): Reorder if..else if.. sequence so that warnings
+	are produced for conversion to logical.
+	* invoke.texi: Add option to list of options.
+	* invoke.texi: Add Character conversion subsection to Extensions
+	section.
+	* lang.opt: Add new option.
+	* options.c (set_dec_flags): Add SET_BITFLAG for
+	flag_dec_char_conversions.
+	* resolve.c (resolve_ordindary_assign): Issue error if the left hand
+	side is numeric or logical and the right hand side is a character
+	variable.
+	* simplify.c (gfc_convert_constant): Assign the conversion function
+	depending on destination type.
+	* trans-const.c (gfc_constant_to_tree): Use OPT_Wsurprising in
+	gfc_warning allowing the warning to be switched off only if
+	flag_dec_char_conversions is enabled.
+
 2019-11-08  Tobias Burnus  <tobias@codesourcery.com
 
 	PR fortran/91253
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c
index ff279db..10b3e5c 100644
--- a/gcc/fortran/arith.c
+++ b/gcc/fortran/arith.c
@@ -2510,9 +2510,9 @@ hollerith2representation (gfc_expr *result, gfc_expr *src)
 
   if (src_len > result_len)
     {
-      gfc_warning (0,
-		   "The Hollerith constant at %L is too long to convert to %qs",
-		   &src->where, gfc_typename(&result->ts));
+      gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
+		   "is truncated in conversion to %qs", &src->where,
+		   gfc_typename(&result->ts));
     }
 
   result->representation.string = XCNEWVEC (char, result_len + 1);
@@ -2527,6 +2527,36 @@ hollerith2representation (gfc_expr *result, gfc_expr *src)
 }
 
 
+/* Helper function to set the representation in a character conversion.
+   This assumes that the ts.type and ts.kind of the result have already
+   been set.  */
+
+static void
+character2representation (gfc_expr *result, gfc_expr *src)
+{
+  size_t src_len, result_len;
+  int i;
+  src_len = src->value.character.length;
+  gfc_target_expr_size (result, &result_len);
+
+  if (src_len > result_len)
+    gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
+		 "truncated in conversion to %s", &src->where,
+		 gfc_typename(&result->ts));
+
+  result->representation.string = XCNEWVEC (char, result_len + 1);
+
+  for (i = 0; i < MIN (result_len, src_len); i++)
+    result->representation.string[i] = (char) src->value.character.string[i];
+
+  if (src_len < result_len)
+    memset (&result->representation.string[src_len], ' ',
+	    result_len - src_len);
+
+  result->representation.string[result_len] = '\0'; /* For debugger.  */
+  result->representation.length = result_len;
+}
+
 /* Convert Hollerith to integer. The constant will be padded or truncated.  */
 
 gfc_expr *
@@ -2542,8 +2572,21 @@ gfc_hollerith2int (gfc_expr *src, int kind)
   return result;
 }
 
+/* Convert character to integer.  The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_character2int (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
+
+  character2representation (result, src);
+  gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
+			 result->representation.length, result->value.integer);
+  return result;
+}
 
-/* Convert Hollerith to real. The constant will be padded or truncated.  */
+/* Convert Hollerith to real.  The constant will be padded or truncated.  */
 
 gfc_expr *
 gfc_hollerith2real (gfc_expr *src, int kind)
@@ -2558,6 +2601,21 @@ gfc_hollerith2real (gfc_expr *src, int kind)
   return result;
 }
 
+/* Convert character to real.  The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_character2real (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
+
+  character2representation (result, src);
+  gfc_interpret_float (kind, (unsigned char *) result->representation.string,
+		       result->representation.length, result->value.real);
+
+  return result;
+}
+
 
 /* Convert Hollerith to complex. The constant will be padded or truncated.  */
 
@@ -2574,6 +2632,21 @@ gfc_hollerith2complex (gfc_expr *src, int kind)
   return result;
 }
 
+/* Convert character to complex. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_character2complex (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
+
+  character2representation (result, src);
+  gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
+			 result->representation.length, result->value.complex);
+
+  return result;
+}
+
 
 /* Convert Hollerith to character.  */
 
@@ -2609,3 +2682,18 @@ gfc_hollerith2logical (gfc_expr *src, int kind)
 
   return result;
 }
+
+/* Convert character to logical. The constant will be padded or truncated.  */
+
+gfc_expr *
+gfc_character2logical (gfc_expr *src, int kind)
+{
+  gfc_expr *result;
+  result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
+
+  character2representation (result, src);
+  gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
+			 result->representation.length, &result->value.logical);
+
+  return result;
+}
diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h
index 39366ca..85c8b8c 100644
--- a/gcc/fortran/arith.h
+++ b/gcc/fortran/arith.h
@@ -77,7 +77,11 @@ gfc_expr *gfc_hollerith2real (gfc_expr *, int);
 gfc_expr *gfc_hollerith2complex (gfc_expr *, int);
 gfc_expr *gfc_hollerith2character (gfc_expr *, int);
 gfc_expr *gfc_hollerith2logical (gfc_expr *, int);
+gfc_expr *gfc_character2int (gfc_expr *, int);
+gfc_expr *gfc_character2real (gfc_expr *, int);
+gfc_expr *gfc_character2complex (gfc_expr *, int);
 gfc_expr *gfc_character2character (gfc_expr *, int);
+gfc_expr *gfc_character2logical (gfc_expr *, int);
 
 #endif /* GFC_ARITH_H  */
 
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index c508890..9e3c8c4 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3722,6 +3722,12 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform,
 	  || rvalue->ts.type == BT_HOLLERITH)
 	return true;
 
+      if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts)
+	  || lvalue->ts.type == BT_LOGICAL)
+	  && rvalue->ts.type == BT_CHARACTER
+	  && rvalue->ts.kind == gfc_default_character_kind)
+	return true;
+
       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
 	return true;
 
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 02d30e1..a34ac5a 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -1600,6 +1600,7 @@ additional compatibility extensions along with those enabled by
 * Unary operators::
 * Implicitly convert LOGICAL and INTEGER values::
 * Hollerith constants support::
+* Character conversion::
 * Cray pointers::
 * CONVERT specifier::
 * OpenMP::
@@ -1955,6 +1956,30 @@ obtained by using the @code{TRANSFER} statement, as in this example.
 @end smallexample
 
 
+@node Character conversion
+@subsection Character conversion
+@cindex conversion, to character
+
+Allowing character literals to be used in a similar way to Hollerith constants
+is a non-standard extension.  This feature is enabled using
+-fdec-char-conversions and only applies to character literals of @code{kind=1}.
+
+Character literals can be used in @code{DATA} statements and assignments with
+numeric (@code{INTEGER}, @code{REAL}, or @code{COMPLEX}) or @code{LOGICAL}
+variables. Like Hollerith constants they are copied byte-wise fashion. The
+constant will be padded with spaces or truncated to fit the size of the
+variable in which it is stored.
+
+Examples:
+@smallexample
+      integer*4 x
+      data x / 'abcd' /
+
+      x = 'A'       ! Will be padded.
+      x = 'ab1234'  ! Will be truncated.
+@end smallexample
+
+
 @node Cray pointers
 @subsection Cray pointers
 @cindex pointer, Cray
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index ac5af10..572967f 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4025,6 +4025,29 @@ add_conversions (void)
 	  add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
 		    BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
 	}
+
+  /* DEC legacy feature allows character conversions similar to Hollerith
+     conversions - the character data will transferred on a byte by byte
+     basis.  */
+  if (flag_dec_char_conversions)
+    {
+      /* Character-Integer conversions.  */
+      for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+	add_conv (BT_CHARACTER, gfc_default_character_kind,
+		  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
+      /* Character-Real conversions.  */
+      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+	add_conv (BT_CHARACTER, gfc_default_character_kind,
+		  BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
+      /* Character-Complex conversions.  */
+      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+	add_conv (BT_CHARACTER, gfc_default_character_kind,
+		  BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
+      /* Character-Logical conversions.  */
+      for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
+	add_conv (BT_CHARACTER, gfc_default_character_kind,
+		  BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
+    }
 }
 
 
@@ -5119,8 +5142,10 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
   /* At this point, a conversion is necessary. A warning may be needed.  */
   if ((gfc_option.warn_std & sym->standard) != 0)
     {
+      const char *type_name = is_char_constant ? gfc_typename (expr)
+					       : gfc_typename (&from_ts);
       gfc_warning_now (0, "Extension: Conversion from %s to %s at %L",
-		       gfc_typename (&from_ts), gfc_dummy_typename (ts),
+		       type_name, gfc_dummy_typename (ts),
 		       &expr->where);
     }
   else if (wflag)
@@ -5135,14 +5160,14 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
 	     If range checking was disabled, but -Wconversion enabled,
 	     a non range checked warning is generated below.  */
 	}
-      else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL)
+      else if (flag_dec_char_conversions && from_ts.type == BT_CHARACTER
+	       && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL))
 	{
-	  /* Do nothing. This block exists only to simplify the other
-	     else-if expressions.
-	       LOGICAL <> LOGICAL    no warning, independent of kind values
-	       LOGICAL <> INTEGER    extension, warned elsewhere
-	       LOGICAL <> REAL       invalid, error generated elsewhere
-	       LOGICAL <> COMPLEX    invalid, error generated elsewhere  */
+	  const char *type_name = is_char_constant ? gfc_typename (expr)
+						   : gfc_typename (&from_ts);
+	  gfc_warning_now (OPT_Wconversion, "Nonstandard conversion from %s "
+			   "to %s at %L", type_name, gfc_typename (ts),
+			   &expr->where);
 	}
       else if (from_ts.type == ts->type
 	       || (from_ts.type == BT_INTEGER && ts->type == BT_REAL)
@@ -5159,7 +5184,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
 				 "conversion from %s to %s at %L",
 				 gfc_typename (&from_ts), gfc_typename (ts),
 				 &expr->where);
-	      else if (warn_conversion_extra)
+	      else
 		gfc_warning_now (OPT_Wconversion_extra, "Conversion from %s to %s "
 				 "at %L", gfc_typename (&from_ts),
 				 gfc_typename (ts), &expr->where);
@@ -5171,7 +5196,7 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
 	{
 	  /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL
 	     usually comes with a loss of information, regardless of kinds.  */
-	  if (warn_conversion && expr->expr_type != EXPR_CONSTANT)
+	  if (expr->expr_type != EXPR_CONSTANT)
 	    gfc_warning_now (OPT_Wconversion, "Possible change of value in "
 			     "conversion from %s to %s at %L",
 			     gfc_typename (&from_ts), gfc_typename (ts),
@@ -5180,13 +5205,21 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
       else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH)
 	{
 	  /* 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_dummy_typename (ts),
-			     &expr->where);
+	  gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L",
+			   gfc_typename (&from_ts), gfc_dummy_typename (ts),
+			   &expr->where);
+	}
+      else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL)
+	{
+	  /* Do nothing. This block exists only to simplify the other
+	     else-if expressions.
+	       LOGICAL <> LOGICAL    no warning, independent of kind values
+	       LOGICAL <> INTEGER    extension, warned elsewhere
+	       LOGICAL <> REAL       invalid, error generated elsewhere
+	       LOGICAL <> COMPLEX    invalid, error generated elsewhere  */
 	}
       else
-        gcc_unreachable ();
+	gcc_unreachable ();
     }
 
   /* Insert a pre-resolved function call to the right function.  */
@@ -5244,8 +5277,7 @@ bad:
     }
 
   gfc_internal_error ("Cannot convert %qs to %qs at %L", type_name,
-		      gfc_typename (ts),
-		      &expr->where);
+		      gfc_typename (ts), &expr->where);
   /* Not reached */
 }
 
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 1d5cec1..46ee3c9 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -118,9 +118,9 @@ by type.  Explanations are in the following sections.
 @xref{Fortran Dialect Options,,Options controlling Fortran dialect}.
 @gccoptlist{-fall-intrinsics -fallow-argument-mismatch -fallow-invalid-boz @gol
 -fbackslash -fcray-pointer -fd-lines-as-code -fd-lines-as-comments -fdec @gol
--fdec-structure-fdec-intrinsic-ints -fdec-static -fdec-math -fdec-include @gol
--fdec-format-defaults -fdec-blank-format-item -fdefault-double-8 @gol
--fdefault-integer-8 -fdefault-real-8 -fdefault-real-10 @gol
+-fdec-char-conversions -fdec-structure -fdec-intrinsic-ints -fdec-static @gol
+-fdec-math -fdec-include -fdec-format-defaults -fdec-blank-format-item @gol
+-fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 -fdefault-real-10 @gol
 -fdefault-real-16 -fdollar-ok -ffixed-line-length-@var{n} @gol
 -ffixed-line-length-none -fpad-source -ffree-form @gol
 -ffree-line-length-@var{n} -ffree-line-length-none -fimplicit-none @gol
@@ -273,14 +273,19 @@ For details on GNU Fortran's implementation of these extensions see the
 full documentation.
 
 Other flags enabled by this switch are:
-@option{-fdollar-ok} @option{-fcray-pointer} @option{-fdec-structure}
-@option{-fdec-intrinsic-ints} @option{-fdec-static} @option{-fdec-math}
-@option{-fdec-include} @option{-fdec-blank-format-item}
+@option{-fdollar-ok} @option{-fcray-pointer} @option{-fdec-char-conversions}
+@option{-fdec-structure} @option{-fdec-intrinsic-ints} @option{-fdec-static}
+@option{-fdec-math} @option{-fdec-include} @option{-fdec-blank-format-item}
 @option{-fdec-format-defaults}
 
 If @option{-fd-lines-as-code}/@option{-fd-lines-as-comments} are unset, then
 @option{-fdec} also sets @option{-fd-lines-as-comments}.
 
+@item -fdec-char-conversions
+@opindex @code{fdec-char-conversions}
+Enable the use of character literals in assignments and data statements
+for non-character variables.
+
 @item -fdec-structure
 @opindex @code{fdec-structure}
 Enable DEC @code{STRUCTURE} and @code{RECORD} as well as @code{UNION},
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 35b1206..5fcd1ff 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -460,6 +460,11 @@ fdec-blank-format-item
 Fortran Var(flag_dec_blank_format_item)
 Enable the use of blank format items in format strings.
 
+fdec-char-conversions
+Fortran Var(flag_dec_char_conversions)
+Enable the use of character literals in assignments and data statements
+for non-character variables.
+
 fdec-include
 Fortran Var(flag_dec_include)
 Enable legacy parsing of INCLUDE as statement.
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index c875ec1..305c57d 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -76,6 +76,7 @@ set_dec_flags (int value)
   SET_BITFLAG (flag_dec_include, value, value);
   SET_BITFLAG (flag_dec_format_defaults, value, value);
   SET_BITFLAG (flag_dec_blank_format_item, value, value);
+  SET_BITFLAG (flag_dec_char_conversions, value, value);
 }
 
 /* Finalize DEC flags.  */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 218c2ed..a39b954 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10689,6 +10689,18 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
   lhs = code->expr1;
   rhs = code->expr2;
 
+  if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
+      && rhs->ts.type == BT_CHARACTER
+      && rhs->expr_type != EXPR_CONSTANT)
+    {
+      /* Use of -fdec-char-conversions allows assignment of character data
+	 to non-character variables.  This not permited for nonconstant
+	 strings.  */
+      gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs),
+		 gfc_typename (lhs), &rhs->where);
+      return false;
+    }
+
   /* Handle the case of a BOZ literal on the RHS.  */
   if (rhs->ts.type == BT_BOZ)
     {
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index fa5aefe..2eb1943 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -8522,10 +8522,31 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind)
       break;
 
     case BT_CHARACTER:
-      if (type == BT_CHARACTER)
-	f = gfc_character2character;
-      else
-	goto oops;
+      switch (type)
+	{
+	case BT_INTEGER:
+	  f = gfc_character2int;
+	  break;
+
+	case BT_REAL:
+	  f = gfc_character2real;
+	  break;
+
+	case BT_COMPLEX:
+	  f = gfc_character2complex;
+	  break;
+
+	case BT_CHARACTER:
+	  f = gfc_character2character;
+	  break;
+
+	case BT_LOGICAL:
+	  f = gfc_character2logical;
+	  break;
+
+	default:
+	  goto oops;
+	}
       break;
 
     default:
diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c
index 432d12b..7ce0263 100644
--- a/gcc/fortran/trans-const.c
+++ b/gcc/fortran/trans-const.c
@@ -25,6 +25,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "coretypes.h"
 #include "tree.h"
 #include "gfortran.h"
+#include "options.h"
 #include "trans.h"
 #include "fold-const.h"
 #include "stor-layout.h"
@@ -331,8 +332,9 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
 			gfc_build_string_const (expr->representation.length,
 						expr->representation.string));
 	  if (!integer_zerop (tmp) && !integer_onep (tmp))
-	    gfc_warning (0, "Assigning value other than 0 or 1 to LOGICAL"
-			 " has undefined result at %L", &expr->where);
+	    gfc_warning (flag_dec_char_conversions ? OPT_Wsurprising : 0,
+			 "Assigning value other than 0 or 1 to LOGICAL has "
+			 "undefined result at %L", &expr->where);
 	  return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
 	}
       else