From 7420e95a0ebb2401d67ad405670fb6a8d33f02da Mon Sep 17 00:00:00 2001

From: Jim MacArthur <jim.macarthur@codethink.co.uk>

Date: Thu, 4 Feb 2016 17:18:30 +0000

Subject: [PATCH 04/23] Allow conversion between Hollerith constants and

 CHARACTER and INTEGER

Warnings are raised when this happens.

This feature is enabled with the `-std=extra-legacy` compiler flag.

        0004-Allow-conversion-between-Hollerith-constants-and-CHA.patch

diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c

index 8fa305c..fc1be48 100644

--- a/gcc/fortran/arith.c

+++ b/gcc/fortran/arith.c

@@ -2562,6 +2562,34 @@ hollerith2representation (gfc_expr *resu

 }

+/* 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;

+  size_t i;

+  src_len = src->value.character.length;

+  gfc_target_expr_size (result, &result_len);

+

+  if (src_len > result_len)

+    gfc_warning (0, "The character constant at %L is too long to convert 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 *

@@ -2577,6 +2605,19 @@ gfc_hollerith2int (gfc_expr *src, int ki

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

diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h

index 85aca5b..1f56aea 100644

--- a/gcc/fortran/arith.h

+++ b/gcc/fortran/arith.h

@@ -83,6 +83,7 @@ gfc_expr *gfc_hollerith2complex (gfc_expr *, int);

 gfc_expr *gfc_hollerith2character (gfc_expr *, int);

 gfc_expr *gfc_hollerith2logical (gfc_expr *, int);

 gfc_expr *gfc_character2character (gfc_expr *, int);

+gfc_expr *gfc_character2int (gfc_expr *, int);

 #endif /* GFC_ARITH_H  */

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c

index f304154..ed3d440 100644

--- a/gcc/fortran/check.c

+++ b/gcc/fortran/check.c

@@ -2643,9 +2643,14 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,

 }

+/* This is the check function for the argument to the INT intrinsic */

 bool

 gfc_check_int (gfc_expr *x, gfc_expr *kind)

 {

+  if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)

+      && x->ts.type == BT_CHARACTER)

+    return true;

+

   if (!numeric_check (x, 0))

     return false;

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c

index 2f60fe8..371f5b8 100644

--- a/gcc/fortran/intrinsic.c

+++ b/gcc/fortran/intrinsic.c

@@ -3928,6 +3928,17 @@ add_conversions (void)

 	  add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,

 		    BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);

 	}

+

+  /* Oracle allows character values to be converted to integers,

+     similar to Hollerith-Integer conversion - the first characters will

+     be turned into ascii values. */

+  if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)

+    {

+      /* 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);

+    }

 }

@@ -5008,6 +5019,15 @@ gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)

 			     gfc_typename (&from_ts), gfc_typename (ts),

 			     &expr->where);

 	}

+      else if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)

+	       && from_ts.type == BT_CHARACTER

+	       && ts->type == BT_INTEGER)

+	{

+	  if (warn_conversion_extra || warn_conversion)

+	    gfc_warning_now (0, "Conversion from %s to %s at %L",

+			     gfc_typename (&from_ts), gfc_typename (ts),

+			     &expr->where);

+	}

       else

         gcc_unreachable ();

     }

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c

index d09cfa6..07c8c9a 100644

--- a/gcc/fortran/resolve.c

+++ b/gcc/fortran/resolve.c

@@ -3803,6 +3803,30 @@ lookup_uop_fuzzy (const char *op, gfc_symtree *uop)

   return gfc_closest_fuzzy_match (op, candidates);

 }

+/* Return true if TYPE is character based, false otherwise.  */

+

+static int

+is_character_based (bt type)

+{

+  return type == BT_CHARACTER || type == BT_HOLLERITH;

+}

+

+/* If E is a logical, convert it to an integer and issue a warning

+   for the conversion.  */

+

+static void

+convert_logical_to_integer (gfc_expr *e)

+{

+  if (e->ts.type == BT_LOGICAL)

+    {

+      /* Convert to INTEGER */

+      gfc_typespec t;

+      t.type = BT_INTEGER;

+      t.kind = 1;

+      gfc_convert_type_warn (e, &t, 2, 1);

+    }

+}

+

 /* Resolve an operator expression node.  This can involve replacing the

    operation with a user defined function call.  */

@@ -3976,6 +4000,38 @@ resolve_operator (gfc_expr *e)

     case INTRINSIC_EQ_OS:

     case INTRINSIC_NE:

     case INTRINSIC_NE_OS:

+

+      if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)

+	{

+	  convert_logical_to_integer (op1);

+	  convert_logical_to_integer (op2);

+	}

+

+      /* If you're comparing hollerith contants to character expresisons,

+	 convert the hollerith constant */

+      if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)

+	  && is_character_based (op1->ts.type)

+	  && is_character_based (op2->ts.type))

+	{

+	  gfc_typespec ts;

+	  ts.type = BT_CHARACTER;

+	  ts.kind = op1->ts.kind;

+	  if (op1->ts.type == BT_HOLLERITH)

+	  {

+	    gfc_convert_type_warn (op1, &ts, 2, 1);

+	    gfc_warning (0, "Promoting argument for comparison from HOLLERITH "

+	                 "to CHARACTER at %L", &op1->where);

+	  }

+	  ts.type = BT_CHARACTER;

+	  ts.kind = op2->ts.kind;

+	  if (op2->ts.type == BT_HOLLERITH)

+	  {

+	    gfc_convert_type_warn (op2, &ts, 2, 1);

+	    gfc_warning (0, "Promoting argument for comparison from HOLLERITH "

+                         "to CHARACTER at %L", &op2->where);

+	  }

+	}

+

       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER

 	  && op1->ts.kind == op2->ts.kind)

 	{

@@ -3984,6 +4040,29 @@ resolve_operator (gfc_expr *e)

 	  break;

 	}

+      /* Numeric to hollerith comparisons */

+      if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)

+	  && gfc_numeric_ts (&op1->ts)

+	  && (op2->ts.type == BT_HOLLERITH || op2->ts.type == BT_CHARACTER))

+	{

+	  gfc_warning (0, "Promoting argument for comparison from character type to INTEGER at %L", &op2->where);

+	  gfc_typespec ts;

+	  ts.type = BT_INTEGER;

+	  ts.kind = 4;

+	  gfc_convert_type_warn (op2, &ts, 2, 1);

+	}

+

+      if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)

+	  && gfc_numeric_ts (&op2->ts)

+	  && (op1->ts.type == BT_HOLLERITH || op1->ts.type == BT_CHARACTER))

+	{

+	  gfc_warning (0, "Promoting argument for comparison from character type to INTEGER at %L", &op1->where);

+	  gfc_typespec ts;

+	  ts.type = BT_INTEGER;

+	  ts.kind = 4;

+	  gfc_convert_type_warn (op1, &ts, 2, 1);

+	}

+

       if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts))

 	{

 	  gfc_type_convert_binary (e, 1);

@@ -4188,7 +4267,6 @@ bad_op:

   return false;

 }

-

 /************** Array resolution subroutines **************/

 enum compare_result

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c

index 3c85c52..e03384c 100644

--- a/gcc/fortran/simplify.c

+++ b/gcc/fortran/simplify.c

@@ -7987,10 +7987,19 @@ 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_CHARACTER:

+	  f = gfc_character2character;

+	  break;

+

+	case BT_INTEGER:

+	  f = gfc_character2int;

+	  break;

+

+	default:

+	  goto oops;

+	}

       break;

     default:

diff --git a/gcc/testsuite/gfortran.dg/hollerith-character-comparison.f90 b/gcc/testsuite/gfortran.dg/hollerith-character-comparison.f90

new file mode 100644

index 0000000..9c462b9

--- /dev/null

+++ b/gcc/testsuite/gfortran.dg/hollerith-character-comparison.f90

@@ -0,0 +1,15 @@

+       ! { dg-options "-std=extra-legacy" }

+

+      program convert

+      REAL*4 a

+      INTEGER*4 b

+      b = 1000

+      print *, 4HJMAC.eq.4HJMAC ! { dg-warning "Promoting argument for comparison from HOLLERITH to CHARACTER at" }

+      print *, 4HJMAC.eq."JMAC" ! { dg-warning "Promoting argument for comparison from HOLLERITH to CHARACTER at" }

+      print *, 4HJMAC.eq."JMAN" ! { dg-warning "Promoting argument for comparison from HOLLERITH to CHARACTER at" }

+      print *, "JMAC".eq.4HJMAN !  { dg-warning "Promoting argument for comparison from HOLLERITH to CHARACTER at" }

+      print *, "AAAA".eq.5HAAAAA ! { dg-warning "Promoting argument for comparison from HOLLERITH to CHARACTER at" }

+      print *, "BBBBB".eq.5HBBBB ! { dg-warning "Promoting argument for comparison from HOLLERITH to CHARACTER at" }

+

+      end program

+

diff --git a/gcc/testsuite/gfortran.dg/hollerith-int-comparison.f90 b/gcc/testsuite/gfortran.dg/hollerith-int-comparison.f90

new file mode 100644

index 0000000..f44c1f8

--- /dev/null

+++ b/gcc/testsuite/gfortran.dg/hollerith-int-comparison.f90

@@ -0,0 +1,11 @@

+       ! { dg-options "-std=extra-legacy" }

+

+      program convert

+      INTEGER*4 b

+      b = 5HRIVET ! { dg-warning "Legacy Extension: Hollerith constant|Conversion from HOLLERITH to INTEGER|too long to convert" }

+      print *, 4HJMAC.eq.400 ! { dg-warning "Legacy Extension: Hollerith constant|Promoting argument for comparison from character|Conversion from HOLLERITH to INTEGER" }

+      print *, 4HRIVE.eq.1163282770 ! { dg-warning "Legacy Extension: Hollerith constant|Promoting argument for comparison from character|Conversion from HOLLERITH to INTEGER" }

+      print *, b

+      print *, 1163282770.eq.4HRIVE ! { dg-warning "Legacy Extension: Hollerith constant|Promoting argument for comparison from character|Conversion from HOLLERITH to INTEGER" }

+      end program

+