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)
+{
+ int src_len, result_len;
+ int i;
+ src_len = src->value.character.length;
+ result_len = gfc_target_expr_size (result);
+
+ 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
+