From 7420e95a0ebb2401d67ad405670fb6a8d33f02da Mon Sep 17 00:00:00 2001 From: Jim MacArthur 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 +