From e2d5a8775571794822d6acb2008b03c41951f05f Mon Sep 17 00:00:00 2001 From: CentOS Sources Date: Thu, 1 Aug 2019 23:05:20 -0400 Subject: [PATCH] import gcc-toolset-9-gcc-9.1.1-1.el8 --- .gcc-toolset-9-gcc.metadata | 4 + .gitignore | 4 + ...eated-compatible-type-specifications.patch | 81 + ...-int-conversions-with-spaces-instead.patch | 106 + SOURCES/0003-Add-std-extra-legacy.patch | 54 + ...-between-Hollerith-constants-and-CHA.patch | 318 + ...comparisons-between-INTEGER-and-REAL.patch | 1143 ++ ...blank-format-items-in-format-strings.patch | 70 + ...n-one-character-as-argument-to-ICHAR.patch | 77 + ...-Allow-non-integer-substring-indexes.patch | 81 + ...to-INTEGER-for-arithmetic-ops-and-vi.patch | 111 + ...ng-length-and-array-specification-in.patch | 158 + ...to-int-conversions-in-DATA-statement.patch | 52 + ...-style-initializers-in-derived-types.patch | 94 + ...llow-per-variable-kind-specification.patch | 129 + ...logical-expressions-in-IF-statements.patch | 143 + ...ntrinsics-with-smaller-types-than-sp.patch | 277 + ...-attribute-by-default-if-it-s-not-pr.patch | 68 + ...array-dimensions-using-the-lower-bou.patch | 62 + ...0019-Add-tests-for-AUTOMATIC-keyword.patch | 35 + ...or-certain-field-descriptors-in-form.patch | 516 + SOURCES/doxygen-1.7.1-config.patch | 95 + SOURCES/doxygen-1.7.5-timestamp.patch | 63 + SOURCES/doxygen-1.8.0-rh856725.patch | 15 + SOURCES/gcc8-fortran-equivalence.patch | 202 + SOURCES/gcc8-fortran-fdec-include-doc.patch | 30 + SOURCES/gcc8-fortran-fdec-include.patch | 687 + SOURCES/gcc8-fortran-fpad-source.patch | 144 + SOURCES/gcc8-fortran-pr87919-2.patch | 87 + SOURCES/gcc8-fortran-pr87919.patch | 419 + SOURCES/gcc8-fortranlines.patch | 36 + SOURCES/gcc9-Wno-format-security.patch | 27 + SOURCES/gcc9-alt-compat-test.patch | 49 + SOURCES/gcc9-d-shared-libphobos.patch | 20 + SOURCES/gcc9-foffload-default.patch | 122 + SOURCES/gcc9-hack.patch | 126 + SOURCES/gcc9-i386-libgomp.patch | 11 + SOURCES/gcc9-isl-dl.patch | 715 + SOURCES/gcc9-isl-dl2.patch | 71 + SOURCES/gcc9-libgfortran-compat.patch | 584 + SOURCES/gcc9-libgomp-omp_h-multilib.patch | 17 + SOURCES/gcc9-libstdc++-compat.patch | 12093 ++++++++++++++++ SOURCES/gcc9-libstdc++-docs.patch | 24 + SOURCES/gcc9-libtool-no-rpath.patch | 27 + SOURCES/gcc9-no-add-needed.patch | 37 + SOURCES/gcc9-pr90303.patch | 39 + SOURCES/gcc9-rh1574936.patch | 31 + SOURCES/gcc9-sparc-config-detection.patch | 40 + SPECS/gcc.spec | 2522 ++++ 49 files changed, 21916 insertions(+) create mode 100644 .gcc-toolset-9-gcc.metadata create mode 100644 .gitignore create mode 100644 SOURCES/0001-Allow-repeated-compatible-type-specifications.patch create mode 100644 SOURCES/0002-Pad-character-to-int-conversions-with-spaces-instead.patch create mode 100644 SOURCES/0003-Add-std-extra-legacy.patch create mode 100644 SOURCES/0004-Allow-conversion-between-Hollerith-constants-and-CHA.patch create mode 100644 SOURCES/0005-Allow-comparisons-between-INTEGER-and-REAL.patch create mode 100644 SOURCES/0006-Allow-blank-format-items-in-format-strings.patch create mode 100644 SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch create mode 100644 SOURCES/0008-Allow-non-integer-substring-indexes.patch create mode 100644 SOURCES/0009-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch create mode 100644 SOURCES/0010-Allow-mixed-string-length-and-array-specification-in.patch create mode 100644 SOURCES/0011-Allow-character-to-int-conversions-in-DATA-statement.patch create mode 100644 SOURCES/0012-Allow-old-style-initializers-in-derived-types.patch create mode 100644 SOURCES/0013-Allow-per-variable-kind-specification.patch create mode 100644 SOURCES/0014-Allow-non-logical-expressions-in-IF-statements.patch create mode 100644 SOURCES/0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch create mode 100644 SOURCES/0017-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch create mode 100644 SOURCES/0018-Fill-in-missing-array-dimensions-using-the-lower-bou.patch create mode 100644 SOURCES/0019-Add-tests-for-AUTOMATIC-keyword.patch create mode 100644 SOURCES/0022-Default-values-for-certain-field-descriptors-in-form.patch create mode 100644 SOURCES/doxygen-1.7.1-config.patch create mode 100644 SOURCES/doxygen-1.7.5-timestamp.patch create mode 100644 SOURCES/doxygen-1.8.0-rh856725.patch create mode 100644 SOURCES/gcc8-fortran-equivalence.patch create mode 100644 SOURCES/gcc8-fortran-fdec-include-doc.patch create mode 100644 SOURCES/gcc8-fortran-fdec-include.patch create mode 100644 SOURCES/gcc8-fortran-fpad-source.patch create mode 100644 SOURCES/gcc8-fortran-pr87919-2.patch create mode 100644 SOURCES/gcc8-fortran-pr87919.patch create mode 100644 SOURCES/gcc8-fortranlines.patch create mode 100644 SOURCES/gcc9-Wno-format-security.patch create mode 100644 SOURCES/gcc9-alt-compat-test.patch create mode 100644 SOURCES/gcc9-d-shared-libphobos.patch create mode 100644 SOURCES/gcc9-foffload-default.patch create mode 100644 SOURCES/gcc9-hack.patch create mode 100644 SOURCES/gcc9-i386-libgomp.patch create mode 100644 SOURCES/gcc9-isl-dl.patch create mode 100644 SOURCES/gcc9-isl-dl2.patch create mode 100644 SOURCES/gcc9-libgfortran-compat.patch create mode 100644 SOURCES/gcc9-libgomp-omp_h-multilib.patch create mode 100644 SOURCES/gcc9-libstdc++-compat.patch create mode 100644 SOURCES/gcc9-libstdc++-docs.patch create mode 100644 SOURCES/gcc9-libtool-no-rpath.patch create mode 100644 SOURCES/gcc9-no-add-needed.patch create mode 100644 SOURCES/gcc9-pr90303.patch create mode 100644 SOURCES/gcc9-rh1574936.patch create mode 100644 SOURCES/gcc9-sparc-config-detection.patch create mode 100644 SPECS/gcc.spec diff --git a/.gcc-toolset-9-gcc.metadata b/.gcc-toolset-9-gcc.metadata new file mode 100644 index 0000000..e02f06c --- /dev/null +++ b/.gcc-toolset-9-gcc.metadata @@ -0,0 +1,4 @@ +7f4348418dc3efefd357b32a2b5c8010211ab284 SOURCES/doxygen-1.8.0.src.tar.gz +574d80f9840124e0ad45b84e8a59b29419726ce8 SOURCES/gcc-9.1.1-20190503.tar.xz +c5a2b201bf05229647e73203c0bf2d9679d4d21f SOURCES/isl-0.16.1.tar.bz2 +5ef03ca7aee134fe7dfecb6c9d048799f0810278 SOURCES/mpc-0.8.1.tar.gz diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..217feb2 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +SOURCES/doxygen-1.8.0.src.tar.gz +SOURCES/gcc-9.1.1-20190503.tar.xz +SOURCES/isl-0.16.1.tar.bz2 +SOURCES/mpc-0.8.1.tar.gz diff --git a/SOURCES/0001-Allow-repeated-compatible-type-specifications.patch b/SOURCES/0001-Allow-repeated-compatible-type-specifications.patch new file mode 100644 index 0000000..4dc58b5 --- /dev/null +++ b/SOURCES/0001-Allow-repeated-compatible-type-specifications.patch @@ -0,0 +1,81 @@ +From f96f2f273741ea19311c6e7a6f556c09b6ff9415 Mon Sep 17 00:00:00 2001 +From: Mark Doffman +Date: Tue, 23 Jun 2015 22:59:08 +0000 +Subject: [PATCH 01/23] Allow repeated compatible type specifications. + +Add a check to see if a repeated type specification is compatible +with the previous specification. Only create an error on incompatible +type specifications for the same symbol. + +Some fixes by Jim MacArthur +--- + + 0001-Allow-repeated-compatible-type-specifications.patch + + 0015-Allow-redefinition-of-types-for-procedures.patch + + 0021-Correct-internal-fault-in-select_type_9.f90.patch + + +diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c +index ec43e63..67ad504 100644 +--- a/gcc/fortran/symbol.c ++++ b/gcc/fortran/symbol.c +@@ -1877,6 +1877,8 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) + if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name) + type = sym->ns->proc_name->ts.type; + ++ flavor = sym->attr.flavor; ++ + if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type) + && !(gfc_state_stack->previous && gfc_state_stack->previous->previous + && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) +@@ -1886,6 +1888,20 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) + gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " + "use-associated at %L", sym->name, where, sym->module, + &sym->declared_at); ++ else if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ { ++ /* Ignore temporaries and class/procedure names */ ++ if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS || sym->ts.type == BT_PROCEDURE) ++ return false; ++ ++ if (gfc_compare_types (&sym->ts, ts) ++ && (flavor == FL_UNKNOWN || flavor == FL_VARIABLE || flavor == FL_PROCEDURE)) ++ { ++ return gfc_notify_std (GFC_STD_LEGACY, ++ "Symbol '%qs' at %L already has basic type of %s", sym->name, ++ where, gfc_basic_typename (type)); ++ } ++ } + else + gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, + where, gfc_basic_typename (type)); +@@ -1899,8 +1915,6 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) + return false; + } + +- flavor = sym->attr.flavor; +- + if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE + || flavor == FL_LABEL + || (flavor == FL_PROCEDURE && sym->attr.subroutine) +diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_4.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_4.f90 +new file mode 100644 +index 0000000..cdd29ea +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/duplicate_type_4.f90 +@@ -0,0 +1,13 @@ ++! { dg-do compile } ++! { dg-options "-std=f95" } ++ ++! PR fortran/30239 ++! Check for errors when a symbol gets declared a type twice, even if it ++! is the same. ++ ++INTEGER FUNCTION foo () ++ IMPLICIT NONE ++ INTEGER :: x ++ INTEGER :: x ! { dg-error "basic type of" } ++ x = 42 ++END FUNCTION foo diff --git a/SOURCES/0002-Pad-character-to-int-conversions-with-spaces-instead.patch b/SOURCES/0002-Pad-character-to-int-conversions-with-spaces-instead.patch new file mode 100644 index 0000000..c0b375c --- /dev/null +++ b/SOURCES/0002-Pad-character-to-int-conversions-with-spaces-instead.patch @@ -0,0 +1,106 @@ +From 40d6590b03a9f92c19b7097b1cae296276d6ce22 Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Mon, 28 Sep 2015 16:06:30 +0100 +Subject: [PATCH 02/23] Pad character-to-int conversions with spaces instead of + zeros. + +The pad character is 'undefined' or 'processor dependent' depending on which +standard you read. This makes it 0x20 which matches the Oracle Fortran +compiler. One of the tests tests this undefined behaviour, so I had to modify +it. + + 0002-Pad-character-to-int-conversions-with-spaces-instead.patch + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index 4808c27..93908f8 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -428,6 +428,10 @@ fdec + Fortran Var(flag_dec) + Enable all DEC language extensions. + ++fdec-pad-with-spaces ++Fortran Var(flag_dec_pad_with_spaces) ++For character to integer conversions, use spaces for the pad rather than NUL. ++ + fdec-intrinsic-ints + Fortran Var(flag_dec_intrinsic_ints) + Enable kind-specific variants of integer intrinsic functions. +diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c +index d12ae5f..09da1d2 100644 +--- a/gcc/fortran/simplify.c ++++ b/gcc/fortran/simplify.c +@@ -6623,7 +6623,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) + /* Allocate the buffer to store the binary version of the source. */ + buffer_size = MAX (source_size, result_size); + buffer = (unsigned char*)alloca (buffer_size); +- memset (buffer, 0, buffer_size); ++ memset (buffer, (flag_dec_pad_with_spaces ? 0x20 : 0x0), buffer_size); + + /* Now write source to the buffer. */ + gfc_target_encode_expr (source, buffer, buffer_size); +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_20.f90 +@@ -0,0 +1,62 @@ ++! { dg-do compile } ++! { dg-options "-fdump-tree-optimized -O -fdec-pad-with-spaces" } ++! ++! PR fortran/46974 ++ ++program test ++ use ISO_C_BINDING ++ implicit none ++ type(c_ptr) :: m ++ integer(c_intptr_t) :: a ++ integer(transfer(transfer(4_c_intptr_t, c_null_ptr),1_c_intptr_t)) :: b ++ a = transfer (transfer("ABCE", m), 1_c_intptr_t) ++ print '(z8)', a ++ if ( int(z'45434241') /= a & ++ .and. int(z'41424345') /= a & ++ .and. int(z'4142434520202020',kind=8) /= a & ++ .and. int(z'2020202045434241',kind=8) /= a ) & ++ call i_do_not_exist() ++end program test ++ ++! Examples contributed by Steve Kargl and James Van Buskirk ++ ++subroutine bug1 ++ use ISO_C_BINDING ++ implicit none ++ type(c_ptr) :: m ++ type mytype ++ integer a, b, c ++ end type mytype ++ type(mytype) x ++ print *, transfer(32512, x) ! Works. ++ print *, transfer(32512, m) ! Caused ICE. ++end subroutine bug1 ++ ++subroutine bug6 ++ use ISO_C_BINDING ++ implicit none ++ interface ++ function fun() ++ use ISO_C_BINDING ++ implicit none ++ type(C_FUNPTR) fun ++ end function fun ++ end interface ++ type(C_PTR) array(2) ++ type(C_FUNPTR) result ++ integer(C_INTPTR_T), parameter :: const(*) = [32512,32520] ++ ++ result = fun() ++ array = transfer([integer(C_INTPTR_T)::32512,32520],array) ++! write(*,*) transfer(result,const) ++! write(*,*) transfer(array,const) ++end subroutine bug6 ++ ++function fun() ++ use ISO_C_BINDING ++ implicit none ++ type(C_FUNPTR) fun ++ fun = transfer(32512_C_INTPTR_T,fun) ++end function fun ++ ++! { dg-final { scan-tree-dump-times "i_do_not_exist" 0 "optimized" } } diff --git a/SOURCES/0003-Add-std-extra-legacy.patch b/SOURCES/0003-Add-std-extra-legacy.patch new file mode 100644 index 0000000..193d3aa --- /dev/null +++ b/SOURCES/0003-Add-std-extra-legacy.patch @@ -0,0 +1,54 @@ +From d1bb76287ec58fdde7ced70088559136555bd7bd Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Fri, 11 Dec 2015 17:04:09 +0000 +Subject: [PATCH 03/23] Add -std=extra-legacy + + + 0003-Add-std-extra-legacy.patch + + 0023-Add-a-full-stop-to-the-std-extra-legacy-help-text.patch + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index 4421ce4..4808c27 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -790,6 +790,10 @@ std=legacy + Fortran + Accept extensions to support legacy code. + ++std=extra-legacy ++Fortran ++Accept even more legacy extensions, including things disallowed in f90. ++ + undef + Fortran + ; Documented in C +diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h +index c5ff992..dcc923b 100644 +--- a/gcc/fortran/libgfortran.h ++++ b/gcc/fortran/libgfortran.h +@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. + Note that no features were obsoleted nor deleted in F2003. + Please remember to keep those definitions in sync with + gfortran.texi. */ ++#define GFC_STD_EXTRA_LEGACY (1<<13) /* Even more backward compatibility. */ + #define GFC_STD_F2018_DEL (1<<12) /* Deleted in F2018. */ + #define GFC_STD_F2018_OBS (1<<11) /* Obsolescent in F2018. */ + #define GFC_STD_F2018 (1<<10) /* New in F2018. */ +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index 1af76aa..9ebf8e3 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -733,6 +733,12 @@ gfc_handle_option (size_t scode, const char *arg, int value, + gfc_option.warn_std = 0; + break; + ++ case OPT_std_extra_legacy: ++ set_default_std_flags (); ++ gfc_option.warn_std = 0; ++ gfc_option.allow_std |= GFC_STD_EXTRA_LEGACY; ++ break; ++ + case OPT_fshort_enums: + /* Handled in language-independent code. */ + break; diff --git a/SOURCES/0004-Allow-conversion-between-Hollerith-constants-and-CHA.patch b/SOURCES/0004-Allow-conversion-between-Hollerith-constants-and-CHA.patch new file mode 100644 index 0000000..6b99600 --- /dev/null +++ b/SOURCES/0004-Allow-conversion-between-Hollerith-constants-and-CHA.patch @@ -0,0 +1,318 @@ +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 ++ diff --git a/SOURCES/0005-Allow-comparisons-between-INTEGER-and-REAL.patch b/SOURCES/0005-Allow-comparisons-between-INTEGER-and-REAL.patch new file mode 100644 index 0000000..b1e447d --- /dev/null +++ b/SOURCES/0005-Allow-comparisons-between-INTEGER-and-REAL.patch @@ -0,0 +1,1143 @@ +commit a2ddfaea2bbe8ea26c37c1d31db71c56855e10ce +Author: Francisco Redondo Marchena +Date: Mon Apr 9 15:10:02 2018 +0100 + + Add support for type promotion in intrinsic arguments + + This feature is supported by the DEC compiler and can be enabled + using the -fdec flag. + + Signed-off-by: Ben Brewer + + Tests written by: Francisco Redondo Marchena + Jeff Law + +diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c +index fd0b00a..423d2cb 100644 +--- a/gcc/fortran/check.c ++++ b/gcc/fortran/check.c +@@ -932,12 +932,40 @@ gfc_check_allocated (gfc_expr *array) + } + + ++/* Check function where both arguments must be real or integer ++ and warn if they are different types. */ ++ ++bool ++check_int_real_promotion (gfc_expr *a, gfc_expr *b) ++{ ++ gfc_expr *i; ++ ++ if (!int_or_real_check (a, 0)) ++ return false; ++ ++ if (!int_or_real_check (b, 1)) ++ return false; ++ ++ if (a->ts.type != b->ts.type) ++ { ++ i = (a->ts.type != BT_REAL ? a : b); ++ gfc_warning_now (OPT_Wconversion, "Conversion from INTEGER to REAL " ++ "at %L might lose precision", &i->where); ++ } ++ ++ return true; ++} ++ ++ + /* Common check function where the first argument must be real or + integer and the second argument must be the same as the first. */ + + bool + gfc_check_a_p (gfc_expr *a, gfc_expr *p) + { ++ if (flag_dec) ++ return check_int_real_promotion (a, p); ++ + if (!int_or_real_check (a, 0)) + return false; + +@@ -3140,6 +3168,41 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) + } + + ++/* Check function where all arguments of an argument list must be real ++ or integer. */ ++ ++static bool ++check_rest_int_real (gfc_actual_arglist *arglist) ++{ ++ gfc_actual_arglist *arg, *tmp; ++ gfc_expr *x; ++ int m, n; ++ ++ if (!min_max_args (arglist)) ++ return false; ++ ++ for (arg = arglist, n=1; arg; arg = arg->next, n++) ++ { ++ x = arg->expr; ++ if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) ++ { ++ gfc_error ("% argument of %qs intrinsic at %L must be " ++ "INTEGER or REAL", n, gfc_current_intrinsic, &x->where); ++ return false; ++ } ++ ++ for (tmp = arglist, m=1; tmp != arg; tmp = tmp->next, m++) ++ if (!gfc_check_conformance (tmp->expr, x, ++ "arguments 'a%d' and 'a%d' for " ++ "intrinsic '%s'", m, n, ++ gfc_current_intrinsic)) ++ return false; ++ } ++ ++ return true; ++} ++ ++ + bool + gfc_check_min_max (gfc_actual_arglist *arg) + { +@@ -3164,7 +3227,10 @@ gfc_check_min_max (gfc_actual_arglist *arg) + return false; + } + +- return check_rest (x->ts.type, x->ts.kind, arg); ++ if (flag_dec && x->ts.type != BT_CHARACTER) ++ return check_rest_int_real (arg); ++ else ++ return check_rest (x->ts.type, x->ts.kind, arg); + } + + +@@ -4426,6 +4492,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr *shift) + bool + gfc_check_sign (gfc_expr *a, gfc_expr *b) + { ++ if (flag_dec) ++ return check_int_real_promotion (a, b); ++ + if (!int_or_real_check (a, 0)) + return false; + +diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c +index f15b8f2..0932180 100644 +--- a/gcc/fortran/iresolve.c ++++ b/gcc/fortran/iresolve.c +@@ -892,19 +892,22 @@ gfc_resolve_dble (gfc_expr *f, gfc_expr *a) + void + gfc_resolve_dim (gfc_expr *f, gfc_expr *a, gfc_expr *p) + { +- f->ts.type = a->ts.type; + if (p != NULL) +- f->ts.kind = gfc_kind_max (a,p); +- else +- f->ts.kind = a->ts.kind; +- +- if (p != NULL && a->ts.kind != p->ts.kind) + { +- if (a->ts.kind == gfc_kind_max (a,p)) +- gfc_convert_type (p, &a->ts, 2); ++ f->ts.kind = gfc_kind_max (a,p); ++ if (a->ts.type == BT_REAL || p->ts.type == BT_REAL) ++ f->ts.type = BT_REAL; + else +- gfc_convert_type (a, &p->ts, 2); ++ f->ts.type = BT_INTEGER; ++ ++ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) ++ gfc_convert_type (a, &f->ts, 2); ++ ++ if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type) ++ gfc_convert_type (p, &f->ts, 2); + } ++ else ++ f->ts = a->ts; + + f->value.function.name + = gfc_get_string ("__dim_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); +@@ -1659,14 +1662,17 @@ gfc_resolve_minmax (const char *name, gfc_expr *f, gfc_actual_arglist *args) + /* Find the largest type kind. */ + for (a = args->next; a; a = a->next) + { ++ if (a->expr-> ts.type == BT_REAL) ++ f->ts.type = BT_REAL; ++ + if (a->expr->ts.kind > f->ts.kind) + f->ts.kind = a->expr->ts.kind; + } + +- /* Convert all parameters to the required kind. */ ++ /* Convert all parameters to the required type and/or kind. */ + for (a = args; a; a = a->next) + { +- if (a->expr->ts.kind != f->ts.kind) ++ if (a->expr->ts.type != f->ts.type || a->expr->ts.kind != f->ts.kind) + gfc_convert_type (a->expr, &f->ts, 2); + } + +@@ -2050,19 +2056,22 @@ gfc_resolve_minval (gfc_expr *f, gfc_expr *array, gfc_expr *dim, + void + gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p) + { +- f->ts.type = a->ts.type; + if (p != NULL) +- f->ts.kind = gfc_kind_max (a,p); +- else +- f->ts.kind = a->ts.kind; +- +- if (p != NULL && a->ts.kind != p->ts.kind) + { +- if (a->ts.kind == gfc_kind_max (a,p)) +- gfc_convert_type (p, &a->ts, 2); ++ f->ts.kind = gfc_kind_max (a,p); ++ if (a->ts.type == BT_REAL || p->ts.type == BT_REAL) ++ f->ts.type = BT_REAL; + else +- gfc_convert_type (a, &p->ts, 2); ++ f->ts.type = BT_INTEGER; ++ ++ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) ++ gfc_convert_type (a, &f->ts, 2); ++ ++ if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type) ++ gfc_convert_type (p, &f->ts, 2); + } ++ else ++ f->ts = a->ts; + + f->value.function.name + = gfc_get_string ("__mod_%c%d", gfc_type_letter (f->ts.type), f->ts.kind); +@@ -2072,19 +2081,22 @@ gfc_resolve_mod (gfc_expr *f, gfc_expr *a, gfc_expr *p) + void + gfc_resolve_modulo (gfc_expr *f, gfc_expr *a, gfc_expr *p) + { +- f->ts.type = a->ts.type; + if (p != NULL) +- f->ts.kind = gfc_kind_max (a,p); +- else +- f->ts.kind = a->ts.kind; +- +- if (p != NULL && a->ts.kind != p->ts.kind) + { +- if (a->ts.kind == gfc_kind_max (a,p)) +- gfc_convert_type (p, &a->ts, 2); ++ f->ts.kind = gfc_kind_max (a,p); ++ if (a->ts.type == BT_REAL || p->ts.type == BT_REAL) ++ f->ts.type = BT_REAL; + else +- gfc_convert_type (a, &p->ts, 2); ++ f->ts.type = BT_INTEGER; ++ ++ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) ++ gfc_convert_type (a, &f->ts, 2); ++ ++ if (p->ts.kind != f->ts.kind || p->ts.type != f->ts.type) ++ gfc_convert_type (p, &f->ts, 2); + } ++ else ++ f->ts = a->ts; + + f->value.function.name + = gfc_get_string ("__modulo_%c%d", gfc_type_letter (f->ts.type), +@@ -2455,9 +2467,26 @@ gfc_resolve_shift (gfc_expr *f, gfc_expr *i, gfc_expr *shift ATTRIBUTE_UNUSED) + + + void +-gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b ATTRIBUTE_UNUSED) ++gfc_resolve_sign (gfc_expr *f, gfc_expr *a, gfc_expr *b) + { +- f->ts = a->ts; ++ if (b != NULL) ++ { ++ f->ts.kind = gfc_kind_max (a, b); ++ if (a->ts.type == BT_REAL || b->ts.type == BT_REAL) ++ f->ts.type = BT_REAL; ++ else ++ f->ts.type = BT_INTEGER; ++ ++ if (a->ts.kind != f->ts.kind || a->ts.type != f->ts.type) ++ gfc_convert_type (a, &f->ts, 2); ++ ++ if (b->ts.kind != f->ts.kind || b->ts.type != f->ts.type) ++ gfc_convert_type (b, &f->ts, 2); ++ } ++ else ++ { ++ f->ts = a->ts; ++ } + f->value.function.name + = gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); + } +diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c +index 7603f30..2de9a29 100644 +--- a/gcc/fortran/simplify.c ++++ b/gcc/fortran/simplify.c +@@ -2254,39 +2254,78 @@ gfc_simplify_digits (gfc_expr *x) + } + + ++/* Simplify function which sets the floating-point value of ar from ++ the value of a independently if a is integer of real. */ ++ ++static void ++simplify_int_real_promotion (const gfc_expr *a, const gfc_expr *b, mpfr_t *ar) ++{ ++ if (a->ts.type == BT_REAL) ++ { ++ mpfr_init2 (*ar, (a->ts.kind * 8)); ++ mpfr_set (*ar, a->value.real, GFC_RND_MODE); ++ } ++ else ++ { ++ mpfr_init2 (*ar, (b->ts.kind * 8)); ++ mpfr_set_z (*ar, a->value.integer, GFC_RND_MODE); ++ } ++} ++ ++ ++/* Simplify function which promotes a and b arguments from integer to real if required in ++ ar and br floating-point values. This function returns true if a or b are reals and false ++ otherwise. */ ++ ++static bool ++simplify_int_real_promotion2 (const gfc_expr *a, const gfc_expr *b, mpfr_t *ar, mpfr_t *br) ++{ ++ if (a->ts.type != BT_REAL && b->ts.type != BT_REAL) ++ return false; ++ ++ simplify_int_real_promotion (a, b, ar); ++ simplify_int_real_promotion (b, a, br); ++ ++ return true; ++} ++ ++ + gfc_expr * + gfc_simplify_dim (gfc_expr *x, gfc_expr *y) + { + gfc_expr *result; + int kind; + ++ mpfr_t xr; ++ mpfr_t yr; ++ + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + +- kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; +- result = gfc_get_constant_expr (x->ts.type, kind, &x->where); +- +- switch (x->ts.type) ++ if ((x->ts.type != BT_REAL && x->ts.type != BT_INTEGER) ++ || (y->ts.type != BT_REAL && y->ts.type != BT_INTEGER)) + { +- case BT_INTEGER: +- if (mpz_cmp (x->value.integer, y->value.integer) > 0) +- mpz_sub (result->value.integer, x->value.integer, y->value.integer); +- else +- mpz_set_ui (result->value.integer, 0); +- +- break; +- +- case BT_REAL: +- if (mpfr_cmp (x->value.real, y->value.real) > 0) +- mpfr_sub (result->value.real, x->value.real, y->value.real, +- GFC_RND_MODE); +- else +- mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); ++ gfc_internal_error ("gfc_simplify_dim(): Bad arguments"); ++ return NULL; ++ } + +- break; ++ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; + +- default: +- gfc_internal_error ("gfc_simplify_dim(): Bad type"); ++ if (simplify_int_real_promotion2 (x, y, &xr, &yr)) ++ { ++ result = gfc_get_constant_expr (BT_REAL, kind, &x->where); ++ if (mpfr_cmp (xr, yr) > 0) ++ mpfr_sub (result->value.real, xr, yr, GFC_RND_MODE); ++ else ++ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE); ++ } ++ else ++ { ++ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); ++ if (mpz_cmp (x->value.integer, y->value.integer) > 0) ++ mpz_sub (result->value.integer, x->value.integer, y->value.integer); ++ else ++ mpz_set_ui (result->value.integer, 0); + } + + return range_check (result, "DIM"); +@@ -4881,13 +4920,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) + { + int ret; + ++ mpfr_t *arp; ++ mpfr_t *erp; ++ mpfr_t ar; ++ mpfr_t er; ++ ++ if (arg->ts.type != extremum->ts.type) ++ { ++ if (arg->ts.type == BT_REAL) ++ { ++ arp = &arg->value.real; ++ } ++ else ++ { ++ mpfr_init2 (ar, (arg->ts.kind * 8)); ++ mpfr_set_z (ar, arg->value.integer, GFC_RND_MODE); ++ arp = &ar; ++ } ++ ++ if (extremum->ts.type == BT_REAL) ++ { ++ erp = &extremum->value.real; ++ } ++ else ++ { ++ mpfr_init2 (er, (extremum->ts.kind * 8)); ++ mpfr_set_z (er, extremum->value.integer, GFC_RND_MODE); ++ erp = &er; ++ } ++ ++ if (mpfr_nan_p (*erp)) ++ { ++ ret = 1; ++ extremum->ts.type = arg->ts.type; ++ extremum->ts.kind = arg->ts.kind; ++ if (arg->ts.type == BT_INTEGER) ++ { ++ mpz_init2 (extremum->value.integer, (arg->ts.kind * 8)); ++ mpz_set (extremum->value.integer, arg->value.integer); ++ } ++ else ++ { ++ mpfr_init2 (extremum->value.real, (arg->ts.kind * 8)); ++ mpfr_set (extremum->value.real, *arp, GFC_RND_MODE); ++ } ++ } ++ else if (mpfr_nan_p (*arp)) ++ ret = -1; ++ else ++ { ++ ret = mpfr_cmp (*arp, *erp) * sign; ++ if (ret > 0) ++ { ++ extremum->ts.type = arg->ts.type; ++ extremum->ts.kind = arg->ts.kind; ++ if (arg->ts.type == BT_INTEGER) ++ { ++ mpz_init2 (extremum->value.integer, (arg->ts.kind * 8)); ++ mpz_set (extremum->value.integer, arg->value.integer); ++ } ++ else ++ { ++ mpfr_init2 (extremum->value.real, (arg->ts.kind * 8)); ++ mpfr_set (extremum->value.real, *arp, GFC_RND_MODE); ++ } ++ } ++ } ++ ++ return ret; ++ } ++ + switch (arg->ts.type) + { + case BT_INTEGER: + ret = mpz_cmp (arg->value.integer, + extremum->value.integer) * sign; + if (ret > 0) +- mpz_set (extremum->value.integer, arg->value.integer); ++ { ++ if (arg->ts.kind > extremum->ts.kind) ++ extremum->ts.kind = arg->ts.kind; ++ mpz_set (extremum->value.integer, arg->value.integer); ++ } + break; + + case BT_REAL: +@@ -5457,7 +5570,9 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) + gfc_expr *result; + int kind; + +- /* First check p. */ ++ mpfr_t ar; ++ mpfr_t pr; ++ + if (p->expr_type != EXPR_CONSTANT) + return NULL; + +@@ -5468,18 +5583,18 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + gfc_error ("Argument %qs of MOD at %L shall not be zero", +- "P", &p->where); ++ "P", &p->where); + return &gfc_bad_expr; + } +- break; ++ break; + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + gfc_error ("Argument %qs of MOD at %L shall not be zero", +- "P", &p->where); ++ "P", &p->where); + return &gfc_bad_expr; +- } +- break; ++ } ++ break; + default: + gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); + } +@@ -5487,16 +5602,24 @@ gfc_simplify_mod (gfc_expr *a, gfc_expr *p) + if (a->expr_type != EXPR_CONSTANT) + return NULL; + ++ if (a->ts.type != BT_REAL && a->ts.type != BT_INTEGER) ++ { ++ gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); ++ return NULL; ++ } ++ + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; +- result = gfc_get_constant_expr (a->ts.type, kind, &a->where); + +- if (a->ts.type == BT_INTEGER) +- mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); +- else ++ if (simplify_int_real_promotion2 (a, p, &ar, &pr)) + { ++ result = gfc_get_constant_expr (BT_REAL, kind, &a->where); + gfc_set_model_kind (kind); +- mpfr_fmod (result->value.real, a->value.real, p->value.real, +- GFC_RND_MODE); ++ mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE); ++ } ++ else ++ { ++ result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where); ++ mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); + } + + return range_check (result, "MOD"); +@@ -5509,7 +5632,9 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) + gfc_expr *result; + int kind; + +- /* First check p. */ ++ mpfr_t ar; ++ mpfr_t pr; ++ + if (p->expr_type != EXPR_CONSTANT) + return NULL; + +@@ -5520,44 +5645,50 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + gfc_error ("Argument %qs of MODULO at %L shall not be zero", +- "P", &p->where); ++ "P", &p->where); + return &gfc_bad_expr; + } +- break; ++ break; + case BT_REAL: + if (mpfr_cmp_ui (p->value.real, 0) == 0) + { + gfc_error ("Argument %qs of MODULO at %L shall not be zero", +- "P", &p->where); ++ "P", &p->where); + return &gfc_bad_expr; +- } +- break; ++ } ++ break; + default: + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + } + ++ if (a->ts.type != BT_REAL && a->ts.type != BT_INTEGER) ++ { ++ gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); ++ return NULL; ++ } ++ + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; +- result = gfc_get_constant_expr (a->ts.type, kind, &a->where); + +- if (a->ts.type == BT_INTEGER) +- mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); +- else ++ if (simplify_int_real_promotion2 (a, p, &ar, &pr)) + { ++ result = gfc_get_constant_expr (BT_REAL, kind, &a->where); + gfc_set_model_kind (kind); +- mpfr_fmod (result->value.real, a->value.real, p->value.real, +- GFC_RND_MODE); ++ mpfr_fmod (result->value.real, ar, pr, GFC_RND_MODE); + if (mpfr_cmp_ui (result->value.real, 0) != 0) +- { +- if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real)) +- mpfr_add (result->value.real, result->value.real, p->value.real, +- GFC_RND_MODE); +- } +- else +- mpfr_copysign (result->value.real, result->value.real, +- p->value.real, GFC_RND_MODE); ++ { ++ if (mpfr_signbit (ar) != mpfr_signbit (pr)) ++ mpfr_add (result->value.real, result->value.real, pr, GFC_RND_MODE); ++ } ++ else ++ mpfr_copysign (result->value.real, result->value.real, pr, GFC_RND_MODE); ++ } ++ else ++ { ++ result = gfc_get_constant_expr (BT_INTEGER, kind, &a->where); ++ mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + } + + return range_check (result, "MODULO"); +@@ -6976,27 +7107,40 @@ gfc_expr * + gfc_simplify_sign (gfc_expr *x, gfc_expr *y) + { + gfc_expr *result; ++ bool neg; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); + ++ switch (y->ts.type) ++ { ++ case BT_INTEGER: ++ neg = (mpz_sgn (y->value.integer) < 0); ++ break; ++ ++ case BT_REAL: ++ neg = (mpfr_sgn (y->value.real) < 0); ++ break; ++ ++ default: ++ gfc_internal_error ("Bad type in gfc_simplify_sign"); ++ } ++ + switch (x->ts.type) + { + case BT_INTEGER: + mpz_abs (result->value.integer, x->value.integer); +- if (mpz_sgn (y->value.integer) < 0) ++ if (neg) + mpz_neg (result->value.integer, result->value.integer); + break; + + case BT_REAL: +- if (flag_sign_zero) +- mpfr_copysign (result->value.real, x->value.real, y->value.real, +- GFC_RND_MODE); ++ if (flag_sign_zero && y->ts.type == BT_REAL) ++ mpfr_copysign (result->value.real, x->value.real, y->value.real, GFC_RND_MODE); + else +- mpfr_setsign (result->value.real, x->value.real, +- mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); ++ mpfr_setsign (result->value.real, x->value.real, neg, GFC_RND_MODE); + break; + + default: +diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion.f +new file mode 100644 +index 0000000..d77a46e +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion.f +@@ -0,0 +1,14 @@ ++! { dg-do compile } ++! { dg-options "-fdec" } ++! ++! Test promotion between integers and reals for mod and modulo where ++! A is a constant array and P is zero. ++! ++! Compilation errors are expected ++! ++ program promotion_int_real_array_const ++ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } ++ a = mod([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } ++ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } ++ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } ++ end program +diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f +new file mode 100644 +index 0000000..2784b34 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion.f +@@ -0,0 +1,86 @@ ++! { dg-do compile } ++! { dg-options "-fdec -finit-real=snan" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++ PROGRAM promotion_int_real_const ++ ! array_nan 4th position value is NAN ++ REAL array_nan(4) ++ DATA array_nan(1)/-4.0/ ++ DATA array_nan(2)/3.0/ ++ DATA array_nan(3)/-2/ ++ ++ INTEGER m_i/0/ ++ REAL m_r/0.0/ ++ ++ INTEGER md_i/0/ ++ REAL md_r/0.0/ ++ ++ INTEGER d_i/0/ ++ REAL d_r/0.0/ ++ ++ INTEGER s_i/0/ ++ REAL s_r/0.0/ ++ ++ INTEGER mn_i/0/ ++ REAL mn_r/0.0/ ++ ++ INTEGER mx_i/0/ ++ REAL mx_r/0.0/ ++ ++ m_i = MOD(4, 3) ++ if (m_i .ne. 1) STOP 1 ++ m_r = MOD(4.0, 3.0) ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 2 ++ m_r = MOD(4, 3.0) ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 ++ m_r = MOD(4.0, 3) ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 ++ ++ md_i = MODULO(4, 3) ++ if (md_i .ne. 1) STOP 5 ++ md_r = MODULO(4.0, 3.0) ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 6 ++ md_r = MODULO(4, 3.0) ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 7 ++ md_r = MODULO(4.0, 3) ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 8 ++ ++ d_i = DIM(4, 3) ++ if (d_i .ne. 1) STOP 9 ++ d_r = DIM(4.0, 3.0) ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 10 ++ d_r = DIM(4.0, 3) ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 11 ++ d_r = DIM(3, 4.0) ++ if (abs(d_r) > 1.0D-6) STOP 12 ++ ++ s_i = SIGN(-4, 3) ++ if (s_i .ne. 4) STOP 13 ++ s_r = SIGN(4.0, -3.0) ++ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14 ++ s_r = SIGN(4.0, -3) ++ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 ++ s_r = SIGN(-4, 3.0) ++ if (abs(s_r - 4.0) > 1.0D-6) STOP 16 ++ ++ mx_i = MAX(-4, -3, 2, 1) ++ if (mx_i .ne. 2) STOP 17 ++ mx_r = MAX(-4.0, -3.0, 2.0, 1.0) ++ if (abs(mx_r - 2.0) > 1.0D-6) STOP 18 ++ mx_r = MAX(-4, -3.0, 2.0, 1) ++ if (abs(mx_r - 2.0) > 1.0D-6) STOP 19 ++ mx_i = MAXLOC(array_nan, 1) ++ if (mx_i .ne. 2) STOP 20 ++ ++ mn_i = MIN(-4, -3, 2, 1) ++ if (mn_i .ne. -4) STOP 21 ++ mn_r = MIN(-4.0, -3.0, 2.0, 1.0) ++ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22 ++ mn_r = MIN(-4, -3.0, 2.0, 1) ++ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23 ++ mn_i = MINLOC(array_nan, 1) ++ if (mn_i .ne. 1) STOP 24 ++ END PROGRAM +diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f +new file mode 100644 +index 0000000..354c773 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-2.f +@@ -0,0 +1,114 @@ ++! { dg-do compile } ++! { dg-options "-fdec" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++ PROGRAM promotion_int_real ++ REAL l/0.0/ ++ LOGICAL a_l ++ LOGICAL*4 a2_l ++ LOGICAL b_l ++ LOGICAL*8 b2_l ++ LOGICAL x_l ++ LOGICAL y_l ++ CHARACTER a_c ++ CHARACTER*4 a2_c ++ CHARACTER b_c ++ CHARACTER*8 b2_c ++ CHARACTER x_c ++ CHARACTER y_c ++ ++ INTEGER m_i/0/ ++ REAL m_r/0.0/ ++ ++ INTEGER md_i/0/ ++ REAL md_r/0.0/ ++ ++ INTEGER d_i/0/ ++ REAL d_r/0.0/ ++ ++ INTEGER s_i/0/ ++ REAL s_r/0.0/ ++ ++ INTEGER mn_i/0/ ++ REAL mn_r/0.0/ ++ ++ INTEGER mx_i/0/ ++ REAL mx_r/0.0/ ++ ++ m_i = MOD(a_l, b_l) ! { dg-error "" } ++ if (m_i .ne. 1) STOP 1 ++ m_i = MOD(a2_l, b2_l) ! { dg-error "" } ++ if (m_i .ne. 1) STOP 2 ++ m_r = MOD(a_c, b_c) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 ++ m_r = MOD(a2_c, b2_c) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 ++ m_r = MOD(a_l, b_c) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 ++ m_r = MOD(a_c, b_l) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 ++ ++ md_i = MODULO(a_l, b_l) ! { dg-error "" } ++ if (md_i .ne. 1) STOP 7 ++ md_i = MODULO(a2_l, b2_l) ! { dg-error "" } ++ if (md_i .ne. 1) STOP 8 ++ md_r = MODULO(a_c, b_c) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 ++ md_r = MODULO(a2_c, b2_c) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 ++ md_r = MODULO(a_l, b_c) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 ++ md_r = MODULO(a_c, b_l) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 ++ ++ d_i = DIM(a_l, b_l) ! { dg-error "" } ++ if (d_i .ne. 1) STOP 13 ++ d_i = DIM(a2_l, b2_l) ! { dg-error "" } ++ if (d_i .ne. 1) STOP 14 ++ d_r = DIM(a_c, b_c) ! { dg-error "" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 ++ d_r = DIM(a2_c, b2_c) ! { dg-error "" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 ++ d_r = DIM(a_c, b_l) ! { dg-error "" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 ++ d_r = DIM(b_l, a_c) ! { dg-error "" } ++ if (abs(d_r) > 1.0D-6) STOP 18 ++ ++ s_i = SIGN(-a_l, b_l) ! { dg-error "" } ++ if (s_i .ne. 4) STOP 19 ++ s_i = SIGN(-a2_l, b2_l) ! { dg-error "" } ++ if (s_i .ne. 4) STOP 20 ++ s_r = SIGN(a_c, -b_c) ! { dg-error "" } ++ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 21 ! { dg-error "" } ++ s_r = SIGN(a2_c, -b2_c) ! { dg-error "" } ++ if (abs(s_r - (-a2_c)) > 1.0D-6) STOP 22 ! { dg-error "" } ++ s_r = SIGN(a_c, -b_l) ! { dg-error "" } ++ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 23 ! { dg-error "" } ++ s_r = SIGN(-a_l, b_c) ! { dg-error "" } ++ if (abs(s_r - a_c) > 1.0D-6) STOP 24 ! { dg-error "" } ++ ++ mx_i = MAX(-a_l, -b_l, x_l, y_l) ! { dg-error "" } ++ if (mx_i .ne. x_l) STOP 25 ! { dg-error "" } ++ mx_i = MAX(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } ++ if (mx_i .ne. x_l) STOP 26 ! { dg-error "" } ++ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } ++ if (abs(mx_r - x_c) > 1.0D-6) STOP 27 ! { dg-error "" } ++ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } ++ if (abs(mx_r - x_c) > 1.0D-6) STOP 28 ! { dg-error "" } ++ mx_r = MAX(-a_l, -b_c, x_c, y_l) ! { dg-error "" } ++ if (abs(mx_r - x_c) > 1.0D-6) STOP 29 ! { dg-error "" } ++ ++ mn_i = MIN(-a_l, -b_l, x_l, y_l) ! { dg-error "" } ++ if (mn_i .ne. -a_l) STOP 31 ! { dg-error "" } ++ mn_i = MIN(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } ++ if (mn_i .ne. -a2_l) STOP 32 ! { dg-error "" } ++ mn_r = MIN(-a_c, -b_c, x_c, y_c) ! { dg-error "" } ++ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 33 ! { dg-error "" } ++ mn_r = MIN(-a2_c, -b2_c, x_c, y_c) ! { dg-error "" } ++ if (abs(mn_r - (-a2_c)) > 1.0D-6) STOP 34 ! { dg-error "" } ++ mn_r = MIN(-a_l, -b_c, x_c, y_l) ! { dg-error "" } ++ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 35 ! { dg-error "" } ++ END PROGRAM +diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f +new file mode 100644 +index 0000000..92d1b45 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion-3.f +@@ -0,0 +1,114 @@ ++! { dg-do compile } ++! { dg-options "-fdec" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++ PROGRAM promotion_int_real ++ REAL l/0.0/ ++ INTEGER a_i/4/ ++ INTEGER*4 a2_i/4/ ++ CHARACTER b_c ++ CHARACTER*8 b2_c ++ INTEGER x_i/2/ ++ CHARACTER y_c ++ REAL a_r/4.0/ ++ REAL*4 a2_r/4.0/ ++ LOGICAL b_l ++ LOGICAL*8 b2_l ++ REAL x_r/2.0/ ++ LOGICAL y_l ++ ++ INTEGER m_i/0/ ++ REAL m_r/0.0/ ++ ++ INTEGER md_i/0/ ++ REAL md_r/0.0/ ++ ++ INTEGER d_i/0/ ++ REAL d_r/0.0/ ++ ++ INTEGER s_i/0/ ++ REAL s_r/0.0/ ++ ++ INTEGER mn_i/0/ ++ REAL mn_r/0.0/ ++ ++ INTEGER mx_i/0/ ++ REAL mx_r/0.0/ ++ ++ m_i = MOD(a_i, b_c) ! { dg-error "" } ++ if (m_i .ne. 1) STOP 1 ++ m_i = MOD(a2_i, b2_c) ! { dg-error "" } ++ if (m_i .ne. 1) STOP 2 ++ m_r = MOD(a_r, b_l) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 ++ m_r = MOD(a2_r, b2_l) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 ++ m_r = MOD(a_i, b_l) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 ++ m_r = MOD(a_r, b_c) ! { dg-error "" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 ++ ++ md_i = MODULO(a_i, b_c) ! { dg-error "" } ++ if (md_i .ne. 1) STOP 7 ++ md_i = MODULO(a2_i, b2_c) ! { dg-error "" } ++ if (md_i .ne. 1) STOP 8 ++ md_r = MODULO(a_r, b_l) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 ++ md_r = MODULO(a2_r, b2_l) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 ++ md_r = MODULO(a_i, b_l) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 ++ md_r = MODULO(a_r, b_c) ! { dg-error "" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 ++ ++ d_i = DIM(a_i, b_c) ! { dg-error "" } ++ if (d_i .ne. 1) STOP 13 ++ d_i = DIM(a2_i, b2_c) ! { dg-error "" } ++ if (d_i .ne. 1) STOP 14 ++ d_r = DIM(a_r, b_l) ! { dg-error "" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 ++ d_r = DIM(a2_r, b2_l) ! { dg-error "" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 ++ d_r = DIM(a_r, b_c) ! { dg-error "" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 ++ d_r = DIM(b_c, a_r) ! { dg-error "" } ++ if (abs(d_r) > 1.0D-6) STOP 18 ++ ++ s_i = SIGN(-a_i, b_c) ! { dg-error "" } ++ if (s_i .ne. 4) STOP 19 ++ s_i = SIGN(-a2_i, b2_c) ! { dg-error "" } ++ if (s_i .ne. 4) STOP 20 ++ s_r = SIGN(a_r, -b_l) ! { dg-error "" } ++ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 ++ s_r = SIGN(a2_r, -b2_l) ! { dg-error "" } ++ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 ++ s_r = SIGN(a_r, -b_c) ! { dg-error "" } ++ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 ++ s_r = SIGN(-a_i, b_l) ! { dg-error "" } ++ if (abs(s_r - a_r) > 1.0D-6) STOP 24 ++ ++ mx_i = MAX(-a_i, -b_c, x_i, y_c) ! { dg-error "" } ++ if (mx_i .ne. x_i) STOP 25 ++ mx_i = MAX(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } ++ if (mx_i .ne. x_i) STOP 26 ++ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } ++ if (abs(mx_r - x_r) > 1.0D-6) STOP 27 ++ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } ++ if (abs(mx_r - x_r) > 1.0D-6) STOP 28 ++ mx_r = MAX(-a_i, -b_l, x_r, y_c) ! { dg-error "" } ++ if (abs(mx_r - x_r) > 1.0D-6) STOP 29 ++ ++ mn_i = MIN(-a_i, -b_c, x_i, y_c) ! { dg-error "" } ++ if (mn_i .ne. -a_i) STOP 31 ++ mn_i = MIN(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } ++ if (mn_i .ne. -a2_i) STOP 32 ++ mn_r = MIN(-a_r, -b_l, x_r, y_l) ! { dg-error "" } ++ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 ++ mn_r = MIN(-a2_r, -b2_l, x_r, y_l) ! { dg-error "" } ++ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 ++ mn_r = MIN(-a_i, -b_l, x_r, y_c) ! { dg-error "" } ++ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 ++ END PROGRAM +diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f +new file mode 100644 +index 0000000..785331e +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion.f +@@ -0,0 +1,126 @@ ++! { dg-do compile } ++! { dg-options "-fdec" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++ PROGRAM promotion_int_real ++ REAL l/0.0/ ++ INTEGER a_i/4/ ++ INTEGER*4 a2_i/4/ ++ INTEGER b_i/3/ ++ INTEGER*8 b2_i/3/ ++ INTEGER x_i/2/ ++ INTEGER y_i/1/ ++ REAL a_r/4.0/ ++ REAL*4 a2_r/4.0/ ++ REAL b_r/3.0/ ++ REAL*8 b2_r/3.0/ ++ REAL x_r/2.0/ ++ REAL y_r/1.0/ ++ ++ REAL array_nan(4) ++ DATA array_nan(1)/-4.0/ ++ DATA array_nan(2)/3.0/ ++ DATA array_nan(3)/-2/ ++ ++ INTEGER m_i/0/ ++ REAL m_r/0.0/ ++ ++ INTEGER md_i/0/ ++ REAL md_r/0.0/ ++ ++ INTEGER d_i/0/ ++ REAL d_r/0.0/ ++ ++ INTEGER s_i/0/ ++ REAL s_r/0.0/ ++ ++ INTEGER mn_i/0/ ++ REAL mn_r/0.0/ ++ ++ INTEGER mx_i/0/ ++ REAL mx_r/0.0/ ++ ++ ! array_nan 4th position value is NAN ++ array_nan(4) = 0/l ++ ++ m_i = MOD(a_i, b_i) ++ if (m_i .ne. 1) STOP 1 ++ m_i = MOD(a2_i, b2_i) ++ if (m_i .ne. 1) STOP 2 ++ m_r = MOD(a_r, b_r) ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 ++ m_r = MOD(a2_r, b2_r) ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 ++ m_r = MOD(a_i, b_r) ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 ++ m_r = MOD(a_r, b_i) ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 ++ ++ md_i = MODULO(a_i, b_i) ++ if (md_i .ne. 1) STOP 7 ++ md_i = MODULO(a2_i, b2_i) ++ if (md_i .ne. 1) STOP 8 ++ md_r = MODULO(a_r, b_r) ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 ++ md_r = MODULO(a2_r, b2_r) ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 ++ md_r = MODULO(a_i, b_r) ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 ++ md_r = MODULO(a_r, b_i) ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 ++ ++ d_i = DIM(a_i, b_i) ++ if (d_i .ne. 1) STOP 13 ++ d_i = DIM(a2_i, b2_i) ++ if (d_i .ne. 1) STOP 14 ++ d_r = DIM(a_r, b_r) ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 ++ d_r = DIM(a2_r, b2_r) ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 ++ d_r = DIM(a_r, b_i) ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 ++ d_r = DIM(b_i, a_r) ++ if (abs(d_r) > 1.0D-6) STOP 18 ++ ++ s_i = SIGN(-a_i, b_i) ++ if (s_i .ne. 4) STOP 19 ++ s_i = SIGN(-a2_i, b2_i) ++ if (s_i .ne. 4) STOP 20 ++ s_r = SIGN(a_r, -b_r) ++ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 ++ s_r = SIGN(a2_r, -b2_r) ++ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 ++ s_r = SIGN(a_r, -b_i) ++ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 ++ s_r = SIGN(-a_i, b_r) ++ if (abs(s_r - a_r) > 1.0D-6) STOP 24 ++ ++ mx_i = MAX(-a_i, -b_i, x_i, y_i) ++ if (mx_i .ne. x_i) STOP 25 ++ mx_i = MAX(-a2_i, -b2_i, x_i, y_i) ++ if (mx_i .ne. x_i) STOP 26 ++ mx_r = MAX(-a_r, -b_r, x_r, y_r) ++ if (abs(mx_r - x_r) > 1.0D-6) STOP 27 ++ mx_r = MAX(-a_r, -b_r, x_r, y_r) ++ if (abs(mx_r - x_r) > 1.0D-6) STOP 28 ++ mx_r = MAX(-a_i, -b_r, x_r, y_i) ++ if (abs(mx_r - x_r) > 1.0D-6) STOP 29 ++ mx_i = MAXLOC(array_nan, 1) ++ if (mx_i .ne. 2) STOP 30 ++ ++ mn_i = MIN(-a_i, -b_i, x_i, y_i) ++ if (mn_i .ne. -a_i) STOP 31 ++ mn_i = MIN(-a2_i, -b2_i, x_i, y_i) ++ if (mn_i .ne. -a2_i) STOP 32 ++ mn_r = MIN(-a_r, -b_r, x_r, y_r) ++ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 ++ mn_r = MIN(-a2_r, -b2_r, x_r, y_r) ++ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 ++ mn_r = MIN(-a_i, -b_r, x_r, y_i) ++ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 ++ mn_i = MINLOC(array_nan, 1) ++ if (mn_i .ne. 1) STOP 36 ++ END PROGRAM diff --git a/SOURCES/0006-Allow-blank-format-items-in-format-strings.patch b/SOURCES/0006-Allow-blank-format-items-in-format-strings.patch new file mode 100644 index 0000000..8f855c5 --- /dev/null +++ b/SOURCES/0006-Allow-blank-format-items-in-format-strings.patch @@ -0,0 +1,70 @@ +From f50b0452c10d514860e08e1ea091b17aa97d6a90 Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Thu, 4 Feb 2016 16:59:41 +0000 +Subject: [PATCH 06/23] Allow blank format items in format strings + +This has to be written in a slightly verbose manner because GCC 7 +defaults to building with -Werror=implicit-fallthrough which prevents +us from just falling through to the default: case. + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + 0006-Allow-blank-format-items-in-format-strings.patch + +commit 8e205f3940a364318d0cd2197a9897142632b336 +Author: Jim MacArthur +Date: Thu Feb 4 16:59:41 2016 +0000 + + Allow blank format items in format strings + + This has to be written in a slightly verbose manner because GCC 7 + defaults to building with -Werror=implicit-fallthrough which prevents + us from just falling through to the default: case. + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c +index 0bec4ee39b2..d93dcfadd61 100644 +--- a/gcc/fortran/io.c ++++ b/gcc/fortran/io.c +@@ -752,6 +752,16 @@ format_item_1: + error = unexpected_end; + goto syntax; + ++ case FMT_RPAREN: ++ /* Oracle allows a blank format item. */ ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ goto finished; ++ else ++ { ++ error = unexpected_element; ++ goto syntax; ++ } ++ + default: + error = unexpected_element; + goto syntax; +diff --git a/gcc/testsuite/gfortran.dg/dec_format_empty_item.f b/gcc/testsuite/gfortran.dg/dec_format_empty_item.f +new file mode 100644 +index 00000000000..e817001e38a +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_format_empty_item.f +@@ -0,0 +1,16 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test blank/empty format items in format string ++! ++ PROGRAM blank_format_items ++ INTEGER A/0/ ++ ++ OPEN(1, status="scratch") ++ WRITE(1, 10) 100 ++ REWIND(1) ++ READ(1, 10) A ++ IF (a.NE.100) STOP 1 ++ PRINT 10, A ++10 FORMAT( I5,) ++ END diff --git a/SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch b/SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch new file mode 100644 index 0000000..f77dd34 --- /dev/null +++ b/SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch @@ -0,0 +1,77 @@ +From d75972937274489189a151a47da9b9aadfdefe8d Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Mon, 5 Oct 2015 13:45:15 +0100 +Subject: [PATCH 07/23] Allow more than one character as argument to ICHAR + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + +commit 44861a8907c8d849193287231a464d34fcce522d +Author: Jim MacArthur +Date: Mon Oct 5 13:45:15 2015 +0100 + + Allow more than one character as argument to ICHAR + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c +index 4f2d21610b9..38a90519c81 100644 +--- a/gcc/fortran/check.c ++++ b/gcc/fortran/check.c +@@ -2472,7 +2472,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) + else + return true; + +- if (i != 1) ++ if (i != 1 && !(gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)) + { + gfc_error ("Argument of %s at %L must be of length one", + gfc_current_intrinsic, &c->where); +diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c +index 80c96371ad9..6e05bb444ed 100644 +--- a/gcc/fortran/simplify.c ++++ b/gcc/fortran/simplify.c +@@ -2774,7 +2774,7 @@ gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind) + if (e->expr_type != EXPR_CONSTANT) + return NULL; + +- if (e->value.character.length != 1) ++ if (e->value.character.length != 1 && !(gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)) + { + gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; +@@ -2972,7 +2972,7 @@ gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind) + if (e->expr_type != EXPR_CONSTANT) + return NULL; + +- if (e->value.character.length != 1) ++ if (e->value.character.length != 1 && !(gfc_option.allow_std & GFC_STD_EXTRA_LEGACY)) + { + gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; +diff --git a/gcc/testsuite/gfortran.dg/dec_ichar_with_string.f b/gcc/testsuite/gfortran.dg/dec_ichar_with_string.f +new file mode 100644 +index 00000000000..c97746d4a4e +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_ichar_with_string.f +@@ -0,0 +1,18 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test ICHAR and IACHAR with more than one character as argument ++! ++ PROGRAM ichar_more_than_one_character ++ CHARACTER*4 st/'Test'/ ++ INTEGER i ++ ++ i = ICHAR(st) ++ if (i.NE.84) STOP 1 ++ i = IACHAR(st) ++ if (i.NE.84) STOP 2 ++ i = ICHAR('Test') ++ if (i.NE.84) STOP 3 ++ i = IACHAR('Test') ++ if (i.NE.84) STOP 4 ++ END diff --git a/SOURCES/0008-Allow-non-integer-substring-indexes.patch b/SOURCES/0008-Allow-non-integer-substring-indexes.patch new file mode 100644 index 0000000..c27f19b --- /dev/null +++ b/SOURCES/0008-Allow-non-integer-substring-indexes.patch @@ -0,0 +1,81 @@ +From a6e02ad7b8b66823629a9703af4662b8b4037e2b Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Mon, 5 Oct 2015 14:05:03 +0100 +Subject: [PATCH 08/23] Allow non-integer substring indexes + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + +commit 9f05bda69f21d7a7c17b58ff0b6392bfd1a06bae +Author: Jim MacArthur +Date: Mon Oct 5 14:05:03 2015 +0100 + + Allow non-integer substring indexes + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 84a4827a1b7..667cc5073e3 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -4680,6 +4680,17 @@ resolve_substring (gfc_ref *ref) + if (!gfc_resolve_expr (ref->u.ss.start)) + return false; + ++ /* In legacy mode, allow non-integer string indexes by converting */ ++ if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ && ref->u.ss.start->ts.type != BT_INTEGER ++ && gfc_numeric_ts (&ref->u.ss.start->ts)) ++ { ++ gfc_typespec t; ++ t.type = BT_INTEGER; ++ t.kind = ref->u.ss.start->ts.kind; ++ gfc_convert_type_warn (ref->u.ss.start, &t, 2, 1); ++ } ++ + if (ref->u.ss.start->ts.type != BT_INTEGER) + { + gfc_error ("Substring start index at %L must be of type INTEGER", +@@ -4709,6 +4720,17 @@ resolve_substring (gfc_ref *ref) + if (!gfc_resolve_expr (ref->u.ss.end)) + return false; + ++ /* Non-integer string index endings, as for start */ ++ if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ && ref->u.ss.end->ts.type != BT_INTEGER ++ && gfc_numeric_ts (&ref->u.ss.end->ts)) ++ { ++ gfc_typespec t; ++ t.type = BT_INTEGER; ++ t.kind = ref->u.ss.end->ts.kind; ++ gfc_convert_type_warn (ref->u.ss.end, &t, 2, 1); ++ } ++ + if (ref->u.ss.end->ts.type != BT_INTEGER) + { + gfc_error ("Substring end index at %L must be of type INTEGER", +diff --git a/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes.f +new file mode 100644 +index 00000000000..8f5c8eb3c0e +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes.f +@@ -0,0 +1,17 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test not integer substring indexes ++! ++ PROGRAM not_integer_substring_indexes ++ CHARACTER*5 st/'Tests'/ ++ CHARACTER*4 st2 ++ REAL ir/1.0/ ++ REAL ir2/4.0/ ++ ++ st2 = st(ir:4) ++ st2 = st(1:ir2) ++ st2 = st(1.0:4) ++ st2 = st(1:4.0) ++ st2 = st(1.5:4) ++ END diff --git a/SOURCES/0009-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch b/SOURCES/0009-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch new file mode 100644 index 0000000..2747d91 --- /dev/null +++ b/SOURCES/0009-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch @@ -0,0 +1,111 @@ +From 00f13a60974cb4145799593398cc61894326c222 Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Wed, 7 Oct 2015 16:31:18 -0400 +Subject: [PATCH 09/23] Convert LOGICAL to INTEGER for arithmetic ops, and vice + versa + +We allow converting LOGICAL types to INTEGER when doing arithmetic +operations, and converting INTEGER types to LOGICAL for use in +boolean operations. + +This feature is enabled with the `-std=extra-legacy` compiler flag. + +commit f40dbd54915de8155aad94bfa19c22f11b8a8eae +Author: Jim MacArthur +Date: Wed Oct 7 16:31:18 2015 -0400 + + Convert LOGICAL to INTEGER for arithmetic ops, and vice versa + + We allow converting LOGICAL types to INTEGER when doing arithmetic + operations, and converting INTEGER types to LOGICAL for use in + boolean operations. + + This feature is enabled with the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 667cc5073e3..33b441aa1bc 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -3623,6 +3623,22 @@ 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_integer_to_logical (gfc_expr *e) ++{ ++ if (e->ts.type == BT_INTEGER) ++ { ++ /* Convert to LOGICAL */ ++ gfc_typespec t; ++ t.type = BT_LOGICAL; ++ t.kind = 1; ++ gfc_convert_type_warn (e, &t, 2, 1); ++ } ++} ++ + /* If E is a logical, convert it to an integer and issue a warning + for the conversion. */ + +@@ -3733,6 +3749,12 @@ resolve_operator (gfc_expr *e) + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ { ++ convert_integer_to_logical (op1); ++ convert_integer_to_logical (op2); ++ } ++ + if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) + { + e->ts.type = BT_LOGICAL; +@@ -3774,6 +3796,11 @@ resolve_operator (gfc_expr *e) + break; + } + ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ { ++ convert_integer_to_logical (op1); ++ } ++ + if (op1->ts.type == BT_LOGICAL) + { + e->ts.type = BT_LOGICAL; +diff --git a/gcc/testsuite/gfortran.dg/dec_logical_to_integer_and_vice_versa.f b/gcc/testsuite/gfortran.dg/dec_logical_to_integer_and_vice_versa.f +new file mode 100644 +index 00000000000..7b9ec0d0cd2 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_to_integer_and_vice_versa.f +@@ -0,0 +1,27 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test convertion between logical and integer for logical operators ++! ++ PROGRAM logical_integer_conversion ++ LOGICAL lpos /.true./ ++ INTEGER ineg/0/ ++ INTEGER ires ++ LOGICAL lres ++ ++ ! Test Logicals converted to Integers ++ if ((lpos.AND.ineg).EQ.1) STOP 3 ++ if ((ineg.AND.lpos).NE.0) STOP 4 ++ ires = (.true..AND.0) ++ if (ires.NE.0) STOP 5 ++ ires = (1.AND..false.) ++ if (ires.EQ.1) STOP 6 ++ ++ ! Test Integers converted to Logicals ++ if (lpos.EQ.ineg) STOP 7 ++ if (ineg.EQ.lpos) STOP 8 ++ lres = (.true..EQ.0) ++ if (lres) STOP 9 ++ lres = (1.EQ..false.) ++ if (lres) STOP 10 ++ END diff --git a/SOURCES/0010-Allow-mixed-string-length-and-array-specification-in.patch b/SOURCES/0010-Allow-mixed-string-length-and-array-specification-in.patch new file mode 100644 index 0000000..a5194c2 --- /dev/null +++ b/SOURCES/0010-Allow-mixed-string-length-and-array-specification-in.patch @@ -0,0 +1,158 @@ +From e4c3d25a9133224535b3142ed31e8a8be1ad356b Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Wed, 7 Oct 2015 17:04:06 -0400 +Subject: [PATCH 10/23] Allow mixed string length and array specification in + character declarations. + +--- + + 0010-Allow-mixed-string-length-and-array-specification-in.patch + +commit 05124ea7df2ee14620d5c24ffe972db3dcab4f4e +Author: Jim MacArthur +Date: Wed Oct 7 17:04:06 2015 -0400 + + Allow mixed string length and array specification in character declarations. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c +index 6d3d28af127..c90f9de5a78 100644 +--- a/gcc/fortran/decl.c ++++ b/gcc/fortran/decl.c +@@ -2264,6 +2264,35 @@ check_function_name (char *name) + } + + ++static match ++match_character_length_clause (gfc_charlen **cl, bool *cl_deferred, int elem) ++{ ++ gfc_expr* char_len; ++ char_len = NULL; ++ ++ match m = match_char_length (&char_len, cl_deferred, false); ++ if (m == MATCH_YES) ++ { ++ *cl = gfc_new_charlen (gfc_current_ns, NULL); ++ (*cl)->length = char_len; ++ } ++ else if (m == MATCH_NO) ++ { ++ if (elem > 1 ++ && (current_ts.u.cl->length == NULL ++ || current_ts.u.cl->length->expr_type != EXPR_CONSTANT)) ++ { ++ *cl = gfc_new_charlen (gfc_current_ns, NULL); ++ (*cl)->length = gfc_copy_expr (current_ts.u.cl->length); ++ } ++ else ++ *cl = current_ts.u.cl; ++ ++ *cl_deferred = current_ts.deferred; ++ } ++ return m; ++} ++ + /* Match a variable name with an optional initializer. When this + subroutine is called, a variable is expected to be parsed next. + Depending on what is happening at the moment, updates either the +@@ -2274,7 +2303,7 @@ variable_decl (int elem) + { + char name[GFC_MAX_SYMBOL_LEN + 1]; + static unsigned int fill_id = 0; +- gfc_expr *initializer, *char_len; ++ gfc_expr *initializer; + gfc_array_spec *as; + gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ + gfc_charlen *cl; +@@ -2283,6 +2312,7 @@ variable_decl (int elem) + match m; + bool t; + gfc_symbol *sym; ++ match cl_match; + + initializer = NULL; + as = NULL; +@@ -2335,6 +2365,20 @@ variable_decl (int elem) + + var_locus = gfc_current_locus; + ++ ++ cl = NULL; ++ cl_deferred = false; ++ cl_match = MATCH_NO; ++ ++ /* Check for a character length clause before an array clause */ ++ if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ && current_ts.type == BT_CHARACTER) ++ { ++ cl_match = match_character_length_clause (&cl, &cl_deferred, elem); ++ if (cl_match == MATCH_ERROR) ++ goto cleanup; ++ } ++ + /* Now we could see the optional array spec. or character length. */ + m = gfc_match_array_spec (&as, true, true); + if (m == MATCH_ERROR) +@@ -2453,40 +2497,12 @@ variable_decl (int elem) + } + } + +- char_len = NULL; +- cl = NULL; +- cl_deferred = false; +- +- if (current_ts.type == BT_CHARACTER) ++ /* Second chance for a character length clause */ ++ if (cl_match == MATCH_NO && current_ts.type == BT_CHARACTER) + { +- switch (match_char_length (&char_len, &cl_deferred, false)) +- { +- case MATCH_YES: +- cl = gfc_new_charlen (gfc_current_ns, NULL); +- +- cl->length = char_len; +- break; +- +- /* Non-constant lengths need to be copied after the first +- element. Also copy assumed lengths. */ +- case MATCH_NO: +- if (elem > 1 +- && (current_ts.u.cl->length == NULL +- || current_ts.u.cl->length->expr_type != EXPR_CONSTANT)) +- { +- cl = gfc_new_charlen (gfc_current_ns, NULL); +- cl->length = gfc_copy_expr (current_ts.u.cl->length); +- } +- else +- cl = current_ts.u.cl; +- +- cl_deferred = current_ts.deferred; +- +- break; +- +- case MATCH_ERROR: +- goto cleanup; +- } ++ m = match_character_length_clause( &cl, &cl_deferred, elem ); ++ if (m == MATCH_ERROR) ++ goto cleanup; + } + + /* The dummy arguments and result of the abreviated form of MODULE +diff --git a/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration.f +new file mode 100644 +index 00000000000..69b110edb25 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration.f +@@ -0,0 +1,10 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test character declaration with mixed string length and array specification ++! ++ PROGRAM character_declaration ++ CHARACTER ASPEC_SLENGTH*2 (5) /'01','02','03','04','05'/ ++ CHARACTER SLENGTH_ASPEC(5)*2 /'01','02','03','04','05'/ ++ if (ASPEC_SLENGTH(3).NE.SLENGTH_ASPEC(3)) STOP 1 ++ END diff --git a/SOURCES/0011-Allow-character-to-int-conversions-in-DATA-statement.patch b/SOURCES/0011-Allow-character-to-int-conversions-in-DATA-statement.patch new file mode 100644 index 0000000..1130a94 --- /dev/null +++ b/SOURCES/0011-Allow-character-to-int-conversions-in-DATA-statement.patch @@ -0,0 +1,52 @@ +From ced1b6638459f33dc9f22a0cd959f97c05a62e22 Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Wed, 7 Oct 2015 18:23:31 -0400 +Subject: [PATCH 11/23] Allow character-to-int conversions in DATA statements + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + + 0011-Allow-character-to-int-conversions-in-DATA-statement.patch + +commit 11b148af8967669bcebd91ea6fdae28e9ec8e97c +Author: Jim MacArthur +Date: Wed Oct 7 18:23:31 2015 -0400 + + Allow character-to-int conversions in DATA statements + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c +index f347c753702..9982b8d0e85 100644 +--- a/gcc/fortran/expr.c ++++ b/gcc/fortran/expr.c +@@ -3294,6 +3294,10 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, + || rvalue->ts.type == BT_HOLLERITH) + return true; + ++ if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ && gfc_numeric_ts (&lvalue->ts) && rvalue->ts.type == BT_CHARACTER) ++ return true; ++ + if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) + return true; + +diff --git a/gcc/testsuite/gfortran.dg/dec_char_to_int_conversion_in_data.f b/gcc/testsuite/gfortran.dg/dec_char_to_int_conversion_in_data.f +new file mode 100644 +index 00000000000..e0e4f735243 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_char_to_int_conversion_in_data.f +@@ -0,0 +1,11 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test character to int conversion in DATA types ++! ++ PROGRAM char_int_data_type ++ INTEGER*1 ai(2) ++ ++ DATA ai/'1',1/ ++ if(ai(1).NE.49) STOP 1 ++ END diff --git a/SOURCES/0012-Allow-old-style-initializers-in-derived-types.patch b/SOURCES/0012-Allow-old-style-initializers-in-derived-types.patch new file mode 100644 index 0000000..a91db5b --- /dev/null +++ b/SOURCES/0012-Allow-old-style-initializers-in-derived-types.patch @@ -0,0 +1,94 @@ +From 5d5a6c9d8c5a8db252d972ec32dd70d2510404fb Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Thu, 4 Feb 2016 16:00:30 +0000 +Subject: [PATCH 12/23] Allow old-style initializers in derived types + +This allows simple declarations in derived types and structures, such as: + LOGICAL*1 NIL /0/ +Only single value expressions are allowed at the moment. + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + +commit a9ee9b2c45580d0e52670cec4d3d68095dabc178 +Author: Jim MacArthur +Date: Thu Feb 4 16:00:30 2016 +0000 + + Allow old-style initializers in derived types + + This allows simple declarations in derived types and structures, such as: + LOGICAL*1 NIL /0/ + Only single value expressions are allowed at the moment. + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c +index c90f9de5a78..3ad9c2c8b40 100644 +--- a/gcc/fortran/decl.c ++++ b/gcc/fortran/decl.c +@@ -2437,12 +2437,30 @@ variable_decl (int elem) + but not components of derived types. */ + else if (gfc_current_state () == COMP_DERIVED) + { +- gfc_error ("Invalid old style initialization for derived type " +- "component at %C"); +- m = MATCH_ERROR; +- goto cleanup; +- } ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ { ++ /* Attempt to match an old-style initializer which is a simple ++ integer or character expression; this will not work with ++ multiple values. */ ++ m = gfc_match_init_expr (&initializer); ++ if (m == MATCH_ERROR) ++ goto cleanup; ++ else if (m == MATCH_YES) ++ { ++ m = gfc_match ("/"); ++ if (m != MATCH_YES) ++ goto cleanup; ++ } ++ } ++ else + ++ { ++ gfc_error ("Invalid old style initialization for derived type " ++ "component at %C"); ++ m = MATCH_ERROR; ++ goto cleanup; ++ } ++ } + /* For structure components, read the initializer as a special + expression and let the rest of this function apply the initializer + as usual. */ +diff --git a/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style.f +new file mode 100644 +index 00000000000..eac7de987e8 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style.f +@@ -0,0 +1,22 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test old style initializers in derived types ++! ++ PROGRAM spec_in_var ++ TYPE STRUCT1 ++ INTEGER*4 ID /8/ ++ INTEGER*4 TYPE /5/ ++ INTEGER*8 DEFVAL /0/ ++ CHARACTER*(5) NAME /'tests'/ ++ LOGICAL*1 NIL /0/ ++ END TYPE STRUCT1 ++ ++ TYPE (STRUCT1) SINST ++ ++ if(SINST%ID.NE.8) STOP 1 ++ if(SINST%TYPE.NE.5) STOP 2 ++ if(SINST%DEFVAL.NE.0) STOP 3 ++ if(SINST%NAME.NE.'tests') STOP 4 ++ if(SINST%NIL) STOP 5 ++ END diff --git a/SOURCES/0013-Allow-per-variable-kind-specification.patch b/SOURCES/0013-Allow-per-variable-kind-specification.patch new file mode 100644 index 0000000..2dd665b --- /dev/null +++ b/SOURCES/0013-Allow-per-variable-kind-specification.patch @@ -0,0 +1,129 @@ +From 72d3915eadd1121d8b2f0be04fafc17e9232be81 Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Thu, 5 Nov 2015 18:57:53 +0000 +Subject: [PATCH 13/23] Allow per-variable kind specification. + + INTEGER*4 x*2, y*8 + +The per-variable sizes override the kind specified in the type. +At the moment, you can follow this with an array specification, so +INTEGER x*2(10) is OK, but not the other way round. + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + + 0013-Allow-per-variable-kind-specification.patch + + Allow per-variable kind specification. + + INTEGER*4 x*2, y*8 + + The per-variable sizes override the kind specified in the type. + At the moment, you can follow this with an array specification, so + INTEGER x*2(10) is OK, but not the other way round. + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c +index 3ad9c2c8b40..faa08d9c4bb 100644 +--- a/gcc/fortran/decl.c ++++ b/gcc/fortran/decl.c +@@ -1019,6 +1019,24 @@ syntax: + return MATCH_ERROR; + } + ++/* This matches the nonstandard kind given after a variable name, like: ++ INTEGER x*2, y*4 ++ The per-variable kind will override any kind given in the type ++ declaration. ++*/ ++ ++static match ++match_per_symbol_kind (int *length) ++{ ++ match m; ++ ++ m = gfc_match_char ('*'); ++ if (m != MATCH_YES) ++ return m; ++ ++ m = gfc_match_small_literal_int (length, NULL); ++ return m; ++} + + /* Special subroutine for finding a symbol. Check if the name is found + in the current name space. If not, and we're compiling a function or +@@ -2193,10 +2211,13 @@ variable_decl (int elem) + bool t; + gfc_symbol *sym; + match cl_match; ++ match kind_match; ++ int overridden_kind; + + initializer = NULL; + as = NULL; + cp_as = NULL; ++ kind_match = MATCH_NO; + + /* When we get here, we've just matched a list of attributes and + maybe a type and a double colon. The next thing we expect to see +@@ -2213,12 +2234,20 @@ variable_decl (int elem) + cl_match = MATCH_NO; + + /* Check for a character length clause before an array clause */ +- if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) +- && current_ts.type == BT_CHARACTER) ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) + { +- cl_match = match_character_length_clause (&cl, &cl_deferred, elem); +- if (cl_match == MATCH_ERROR) +- goto cleanup; ++ if (current_ts.type == BT_CHARACTER) ++ { ++ cl_match = match_character_length_clause (&cl, &cl_deferred, elem); ++ if (cl_match == MATCH_ERROR) ++ goto cleanup; ++ } ++ else ++ { ++ kind_match = match_per_symbol_kind (&overridden_kind); ++ if (kind_match == MATCH_ERROR) ++ goto cleanup; ++ } + } + + /* Now we could see the optional array spec. or character length. */ +@@ -2412,6 +2441,13 @@ variable_decl (int elem) + goto cleanup; + } + ++ if (kind_match == MATCH_YES) ++ { ++ gfc_find_symbol (name, gfc_current_ns, 1, &sym); ++ /* sym *must* be found at this point */ ++ sym->ts.kind = overridden_kind; ++ } ++ + if (!check_function_name (name)) + { + m = MATCH_ERROR; +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable.f +new file mode 100644 +index 00000000000..0341a176aca +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable.f +@@ -0,0 +1,12 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test kind specification in variable not in type ++! ++ PROGRAM spec_in_var ++ INTEGER ai*1/1/ ++ REAL ar*4/1.0/ ++ ++ if(ai.NE.1) STOP 1 ++ if(abs(ar - 1.0) > 1.0D-6) STOP 2 ++ END diff --git a/SOURCES/0014-Allow-non-logical-expressions-in-IF-statements.patch b/SOURCES/0014-Allow-non-logical-expressions-in-IF-statements.patch new file mode 100644 index 0000000..04fda43 --- /dev/null +++ b/SOURCES/0014-Allow-non-logical-expressions-in-IF-statements.patch @@ -0,0 +1,143 @@ +From 99c791361468b61976d6054e1ec1c81fe43e6559 Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Wed, 11 Nov 2015 15:37:00 +0000 +Subject: [PATCH 14/23] Allow non-logical expressions in IF statements + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + + 0014-Allow-non-logical-expressions-in-IF-statements.patch + + Allow non-logical expressions in IF statements + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Signed-off-by: Ben Brewer + Signed-off-by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 33b441aa1bc..f979915e856 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -9919,10 +9919,23 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) + switch (b->op) + { + case EXEC_IF: +- if (t && b->expr1 != NULL +- && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) +- gfc_error ("IF clause at %L requires a scalar LOGICAL expression", +- &b->expr1->where); ++ if (t && b->expr1 != NULL) ++ { ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY && b->expr1->ts.type != BT_LOGICAL) ++ { ++ gfc_expr* cast; ++ cast = gfc_ne (b->expr1, gfc_get_int_expr (1, &gfc_current_locus, 0), INTRINSIC_NE); ++ if (cast == NULL) ++ gfc_internal_error ("gfc_resolve_blocks(): Failed to cast to LOGICAL in IF"); ++ b->expr1 = cast; ++ gfc_warning (0, "Non-LOGICAL type in IF statement condition %L" ++ " will be true if it evaluates to nonzero", &b->expr1->where); ++ } ++ ++ if ((b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) ++ gfc_error ("IF clause at %L requires a scalar LOGICAL expression", ++ &b->expr1->where); ++ } + break; + + case EXEC_WHERE: +@@ -11182,11 +11195,23 @@ start: + break; + + case EXEC_IF: +- if (t && code->expr1 != NULL +- && (code->expr1->ts.type != BT_LOGICAL +- || code->expr1->rank != 0)) +- gfc_error ("IF clause at %L requires a scalar LOGICAL expression", +- &code->expr1->where); ++ if (t && code->expr1 != NULL) ++ { ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY && code->expr1->ts.type != BT_LOGICAL) ++ { ++ gfc_expr* cast; ++ cast = gfc_ne (code->expr1, gfc_get_int_expr (1, &gfc_current_locus, 0), INTRINSIC_NE); ++ if (cast == NULL) ++ gfc_internal_error ("gfc_resolve_code(): Failed to cast to LOGICAL in IF"); ++ code->expr1 = cast; ++ gfc_warning (0, "Non-LOGICAL type in IF statement condition %L" ++ " will be true if it evaluates to nonzero", &code->expr1->where); ++ } ++ ++ if ((code->expr1->ts.type != BT_LOGICAL || code->expr1->rank != 0)) ++ gfc_error ("IF clause at %L requires a scalar LOGICAL expression", ++ &code->expr1->where); ++ } + break; + + case EXEC_CALL: +diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks.f +new file mode 100644 +index 00000000000..ad23fcfc9af +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks.f +@@ -0,0 +1,21 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Allow logical expressions in if statements and blocks ++! ++ PROGRAM logical_exp_if_st_bl ++ INTEGER ipos/1/ ++ INTEGER ineg/0/ ++ ++ ! Test non logical variables ++ if (ineg) STOP 1 ! { dg-warning "if it evaluates to nonzero" } ++ if (0) STOP 2 ! { dg-warning "if it evaluates to nonzero" } ++ ++ ! Test non logical expressions in if statements ++ if (MOD(ipos, 1)) STOP 3 ! { dg-warning "if it evaluates to nonzero" } ++ ++ ! Test non logical expressions in if blocks ++ if (MOD(2 * ipos, 2)) then ! { dg-warning "if it evaluates to nonzero" } ++ STOP 4 ++ endif ++ END +commit cf72338b9468fad669b60600bcce7918a8d4591e +Author: Jeff Law +Date: Tue Jun 5 15:45:41 2018 -0600 + + Additional test for + + 0014-Allow-non-logical-expressions-in-IF-statements.patch + "Allow non-logical expressions in IF statements" + +diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks-2.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks-2.f +new file mode 100644 +index 00000000000..7da6aaceec7 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks-2.f +@@ -0,0 +1,23 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++ ++ function othersub1() ++ integer*4 othersub1 ++ othersub1 = 1 ++ end ++ function othersub2() ++ integer*4 othersub2 ++ othersub2 = 2 ++ end ++ program MAIN ++ integer*4 othersub1 ++ integer*4 othersub2 ++c the if (integer) works here ++ if (othersub2()) then ! { dg-warning "" } ++ write (*,*), 'othersub2 is true' ++c but fails in the "else if" ++ else if (othersub1()) then ! { dg-warning "" } ++ write (*,*), 'othersub2 is false, othersub1 is true' ++ endif ++ end ++ diff --git a/SOURCES/0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch b/SOURCES/0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch new file mode 100644 index 0000000..6c4a55e --- /dev/null +++ b/SOURCES/0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch @@ -0,0 +1,277 @@ +From 109b1eeba24e5091bf3bdb6caedf7101a9dcaa6a Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Wed, 18 Nov 2015 11:50:41 +0000 +Subject: [PATCH 16/23] Allow calls to intrinsics with smaller types than + specified + +This feature is enabled by the `-std=extra-legacy` compiler flag. +--- + + 0016-Allow-calls-to-intrinsics-with-smaller-types-than-sp.patch + +diff -Nrup a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h +--- a/gcc/fortran/gfortran.h 2018-06-05 11:59:14.269337049 -0600 ++++ b/gcc/fortran/gfortran.h 2018-06-05 11:59:52.830081690 -0600 +@@ -656,6 +656,13 @@ enum gfc_param_spec_type + SPEC_DEFERRED + }; + ++enum match_type ++{ ++ MATCH_EXACT, ++ MATCH_PROMOTABLE, ++ MATCH_INVALID ++}; ++ + /************************* Structures *****************************/ + + /* Used for keeping things in balanced binary trees. */ +@@ -3251,7 +3253,7 @@ bool gfc_add_interface (gfc_symbol *); + gfc_interface *gfc_current_interface_head (void); + void gfc_set_current_interface_head (gfc_interface *); + gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*); +-bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*); ++bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*, enum match_type mtype); + bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus); + bool gfc_has_vector_subscript (gfc_expr*); + gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op); +diff -Nrup a/gcc/fortran/interface.c b/gcc/fortran/interface.c +--- a/gcc/fortran/interface.c 2018-03-03 06:51:39.000000000 -0700 ++++ b/gcc/fortran/interface.c 2018-06-05 12:01:11.218559539 -0600 +@@ -682,7 +682,7 @@ gfc_compare_derived_types (gfc_symbol *d + /* Compare two typespecs, recursively if necessary. */ + + bool +-gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) ++gfc_compare_types_generic (gfc_typespec *ts1, gfc_typespec *ts2, enum match_type mtype) + { + /* See if one of the typespecs is a BT_VOID, which is what is being used + to allow the funcs like c_f_pointer to accept any pointer type. +@@ -721,12 +721,23 @@ gfc_compare_types (gfc_typespec *ts1, gf + return compare_union_types (ts1->u.derived, ts2->u.derived); + + if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS) +- return (ts1->kind == ts2->kind); ++ { ++ if (mtype == MATCH_PROMOTABLE) ++ return (ts1->kind >= ts2->kind); ++ else ++ return (ts1->kind == ts2->kind); ++ } ++ + + /* Compare derived types. */ + return gfc_type_compatible (ts1, ts2); + } + ++bool ++gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2) ++{ ++ return gfc_compare_types_generic (ts1, ts2, MATCH_EXACT); ++} + + static bool + compare_type (gfc_symbol *s1, gfc_symbol *s2) +@@ -743,7 +754,9 @@ compare_type (gfc_symbol *s1, gfc_symbol + return compare_type (s1, s2); + } + +- ++/* Given two symbols that are formal arguments, compare their ranks ++ and types. Returns nonzero if they have the same rank and type, ++ zero otherwise. */ + static bool + compare_rank (gfc_symbol *s1, gfc_symbol *s2) + { +@@ -2150,7 +2163,7 @@ argument_rank_mismatch (const char *name + + static bool + compare_parameter (gfc_symbol *formal, gfc_expr *actual, +- int ranks_must_agree, int is_elemental, locus *where) ++ int ranks_must_agree, int is_elemental, locus *where, enum match_type mtype) + { + gfc_ref *ref; + bool rank_check, is_pointer; +@@ -2242,7 +2255,7 @@ compare_parameter (gfc_symbol *formal, g + && actual->ts.type != BT_HOLLERITH + && formal->ts.type != BT_ASSUMED + && !(formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) +- && !gfc_compare_types (&formal->ts, &actual->ts) ++ && !gfc_compare_types_generic (&formal->ts, &actual->ts, mtype) + && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS + && gfc_compare_derived_types (formal->ts.u.derived, + CLASS_DATA (actual)->ts.u.derived))) +@@ -2792,7 +2805,8 @@ is_procptr_result (gfc_expr *expr) + static bool + compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, + int ranks_must_agree, int is_elemental, +- bool in_statement_function, locus *where) ++ bool in_statement_function, locus *where, ++ enum match_type mtype) + { + gfc_actual_arglist **new_arg, *a, *actual; + gfc_formal_arglist *f; +@@ -2918,7 +2932,7 @@ compare_actual_formal (gfc_actual_arglis + } + + if (!compare_parameter (f->sym, a->expr, ranks_must_agree, +- is_elemental, where)) ++ is_elemental, where, mtype)) + return false; + + /* TS 29113, 6.3p2. */ +@@ -3666,7 +3680,7 @@ gfc_procedure_use (gfc_symbol *sym, gfc_ + /* For a statement function, check that types and type parameters of actual + arguments and dummy arguments match. */ + if (!compare_actual_formal (ap, dummy_args, 0, sym->attr.elemental, +- sym->attr.proc == PROC_ST_FUNCTION, where)) ++ sym->attr.proc == PROC_ST_FUNCTION, where, MATCH_PROMOTABLE)) + return false; + + if (!check_intents (dummy_args, *ap)) +@@ -3715,7 +3730,7 @@ gfc_ppc_use (gfc_component *comp, gfc_ac + } + + if (!compare_actual_formal (ap, comp->ts.interface->formal, 0, +- comp->attr.elemental, false, where)) ++ comp->attr.elemental, false, where, MATCH_EXACT)) + return; + + check_intents (comp->ts.interface->formal, *ap); +@@ -3729,7 +3744,7 @@ gfc_ppc_use (gfc_component *comp, gfc_ac + GENERIC resolution. */ + + bool +-gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym) ++gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym, enum match_type mtype) + { + gfc_formal_arglist *dummy_args; + bool r; +@@ -3740,7 +3755,7 @@ gfc_arglist_matches_symbol (gfc_actual_a + dummy_args = gfc_sym_get_dummy_args (sym); + + r = !sym->attr.elemental; +- if (compare_actual_formal (args, dummy_args, r, !r, false, NULL)) ++ if (compare_actual_formal (args, dummy_args, r, !r, false, NULL, mtype)) + { + check_intents (dummy_args, *args); + if (warn_aliasing) +@@ -3766,7 +3781,8 @@ gfc_search_interface (gfc_interface *int + locus null_expr_loc; + gfc_actual_arglist *a; + bool has_null_arg = false; +- ++ enum match_type mtypes[] = { MATCH_EXACT, MATCH_PROMOTABLE }; ++ int i; + for (a = *ap; a; a = a->next) + if (a->expr && a->expr->expr_type == EXPR_NULL + && a->expr->ts.type == BT_UNKNOWN) +@@ -3776,38 +3792,43 @@ gfc_search_interface (gfc_interface *int + break; + } + +- for (; intr; intr = intr->next) ++ for (i=0; i<2; i++) + { ++ for (; intr; intr = intr->next) ++ { ++ if (intr->sym->attr.flavor == FL_DERIVED) ++ continue; + if (gfc_fl_struct (intr->sym->attr.flavor)) + continue; +- if (sub_flag && intr->sym->attr.function) +- continue; +- if (!sub_flag && intr->sym->attr.subroutine) ++ if (sub_flag && intr->sym->attr.function) ++ continue; ++ if (!sub_flag && intr->sym->attr.subroutine) + continue; + +- if (gfc_arglist_matches_symbol (ap, intr->sym)) +- { +- if (has_null_arg && null_sym) +- { +- gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity " +- "between specific functions %s and %s", +- &null_expr_loc, null_sym->name, intr->sym->name); +- return NULL; +- } +- else if (has_null_arg) ++ if (gfc_arglist_matches_symbol (ap, intr->sym, mtypes[i])) + { +- null_sym = intr->sym; +- continue; +- } ++ if (has_null_arg && null_sym) ++ { ++ gfc_error ("MOLD= required in NULL() argument at %L: Ambiguity " ++ "between specific functions %s and %s", ++ &null_expr_loc, null_sym->name, intr->sym->name); ++ return NULL; ++ } ++ else if (has_null_arg) ++ { ++ null_sym = intr->sym; ++ continue; ++ } + +- /* Satisfy 12.4.4.1 such that an elemental match has lower +- weight than a non-elemental match. */ +- if (intr->sym->attr.elemental) +- { +- elem_sym = intr->sym; +- continue; ++ /* Satisfy 12.4.4.1 such that an elemental match has lower ++ weight than a non-elemental match. */ ++ if (intr->sym->attr.elemental) ++ { ++ elem_sym = intr->sym; ++ continue; ++ } ++ return intr->sym; + } +- return intr->sym; + } + } + +@@ -3942,7 +3963,7 @@ matching_typebound_op (gfc_expr** tb_bas + + /* Check if this arglist matches the formal. */ + argcopy = gfc_copy_actual_arglist (args); +- matches = gfc_arglist_matches_symbol (&argcopy, target); ++ matches = gfc_arglist_matches_symbol (&argcopy, target, MATCH_EXACT); + gfc_free_actual_arglist (argcopy); + + /* Return if we found a match. */ +diff -Nrup a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c +--- a/gcc/fortran/intrinsic.c 2018-06-05 11:59:14.278336990 -0600 ++++ b/gcc/fortran/intrinsic.c 2018-06-05 11:59:52.831081683 -0600 +@@ -4229,6 +4229,16 @@ check_arglist (gfc_actual_arglist **ap, + if (ts.kind == 0) + ts.kind = actual->expr->ts.kind; + ++ /* ts.kind is the argument spec. actual is what was passed. */ ++ ++ if (actual->expr->ts.kind < ts.kind ++ && ts.type == BT_INTEGER) ++ { ++ /* If it was OK to overwrite ts.kind in the previous case, it ++ should be fine here... */ ++ ts.kind = actual->expr->ts.kind; ++ } ++ + if (!gfc_compare_types (&ts, &actual->expr->ts)) + { + if (error_flag) +diff -Nrup a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +--- a/gcc/fortran/resolve.c 2018-06-05 11:59:14.291336904 -0600 ++++ b/gcc/fortran/resolve.c 2018-06-05 11:59:52.833081670 -0600 +@@ -6055,7 +6055,7 @@ resolve_typebound_generic_call (gfc_expr + && gfc_sym_get_dummy_args (target) == NULL); + + /* Check if this arglist matches the formal. */ +- matches = gfc_arglist_matches_symbol (&args, target); ++ matches = gfc_arglist_matches_symbol (&args, target, MATCH_EXACT); + + /* Clean up and break out of the loop if we've found it. */ + gfc_free_actual_arglist (args); diff --git a/SOURCES/0017-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch b/SOURCES/0017-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch new file mode 100644 index 0000000..13ab77f --- /dev/null +++ b/SOURCES/0017-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch @@ -0,0 +1,68 @@ +From fdda38024c7151ca632cb338085af80ceb63ec4d Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Wed, 18 Nov 2015 15:08:56 +0000 +Subject: [PATCH 17/23] Add the SEQUENCE attribute by default if it's not + present. + +This feature is enabled by the `-std=extra-legacy` compiler flag. + + + 0017-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch + +commit 1635277d719de05fbd37a2887273ce893bf43198 +Author: Jim MacArthur +Date: Wed Nov 18 15:08:56 2015 +0000 + + Add the SEQUENCE attribute by default if it's not present. + + This feature is enabled by the `-std=extra-legacy` compiler flag. + + Test written by: Francisco Redondo Marchena + +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 2e60984b3bd..022b9230ec9 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -963,9 +963,16 @@ resolve_common_vars (gfc_common_head *common_block, bool named_common) + + if (!(csym->ts.u.derived->attr.sequence + || csym->ts.u.derived->attr.is_bind_c)) +- gfc_error_now ("Derived type variable %qs in COMMON at %L " +- "has neither the SEQUENCE nor the BIND(C) " +- "attribute", csym->name, &csym->declared_at); ++ { ++ if (gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ /* Assume sequence. */ ++ csym->ts.u.derived->attr.sequence = 1; ++ else ++ gfc_error_now ("Derived type variable '%s' in COMMON at %L " ++ "has neither the SEQUENCE nor the BIND(C) " ++ "attribute", csym->name, &csym->declared_at); ++ } ++ + if (csym->ts.u.derived->attr.alloc_comp) + gfc_error_now ("Derived type variable %qs in COMMON at %L " + "has an ultimate component that is " +diff --git a/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default.f +new file mode 100644 +index 00000000000..c0851c8bc77 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default.f +@@ -0,0 +1,17 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" } ++! ++! Test add default SEQUENCE attribute to COMMON blocks ++! ++ PROGRAM sequence_att_common ++ TYPE STRUCT1 ++ INTEGER*4 ID ++ INTEGER*4 TYPE ++ INTEGER*8 DEFVAL ++ CHARACTER*(4) NAME ++ LOGICAL*1 NIL ++ END TYPE STRUCT1 ++ ++ TYPE (STRUCT1) SINST ++ COMMON /BLOCK1/ SINST ++ END diff --git a/SOURCES/0018-Fill-in-missing-array-dimensions-using-the-lower-bou.patch b/SOURCES/0018-Fill-in-missing-array-dimensions-using-the-lower-bou.patch new file mode 100644 index 0000000..85ec1ad --- /dev/null +++ b/SOURCES/0018-Fill-in-missing-array-dimensions-using-the-lower-bou.patch @@ -0,0 +1,62 @@ +From b8527b8f03c4c50869c4f9a063f5c7686e58e5e9 Mon Sep 17 00:00:00 2001 +From: Jim MacArthur +Date: Fri, 26 Aug 2016 17:46:05 +0100 +Subject: [PATCH 18/23] Fill in missing array dimensions using the lower bound + +This feature is enabled by the `-fstd=extra-legacy` compiler flag +--- + + + 0018-Fill-in-missing-array-dimensions-using-the-lower-bou.patch + +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index a831f70..ac35357 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -4396,6 +4396,27 @@ compare_spec_to_ref (gfc_array_ref *ar) + if (ar->type == AR_FULL) + return true; + ++ if ((gfc_option.allow_std & GFC_STD_EXTRA_LEGACY) ++ && as->rank > ar->dimen) ++ { ++ /* Add in the missing dimensions, assuming they are the lower bound ++ of that dimension if not specified. */ ++ int j; ++ gfc_warning (0, "Using the lower bound for unspecified dimensions " ++ "in array reference at %L", &ar->where); ++ /* Other parts of the code iterate ar->start and ar->end from 0 to ++ ar->dimen, so it is safe to assume slots from ar->dimen upwards ++ are unused (i.e. there are no gaps; the specified indexes are ++ contiguous and start at zero */ ++ for(j = ar->dimen; j <= as->rank; j++) ++ { ++ ar->start[j] = gfc_copy_expr (as->lower[j]); ++ ar->end[j] = gfc_copy_expr (as->lower[j]); ++ ar->dimen_type[j] = DIMEN_ELEMENT; ++ } ++ ar->dimen = as->rank; ++ } ++ + if (as->rank != ar->dimen) + { + gfc_error ("Rank mismatch in array reference at %L (%d/%d)", +diff --git a/gcc/testsuite/gfortran.dg/array_6.f90 b/gcc/testsuite/gfortran.dg/array_6.f90 +new file mode 100644 +index 0000000..20752a1 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/array_6.f90 +@@ -0,0 +1,13 @@ ++! { dg-do compile } ++! { dg-options "-std=extra-legacy" }! ++! Checks that under-specified arrays (referencing arrays with fewer ++! dimensions than the array spec) generates a warning. ++! ++! Contributed by Jim MacArthur ++! ++ ++program under_specified_array ++ INTEGER chsbrd(8,8) ++ chsbrd(3,1) = 5 ++ print *, chsbrd(3) ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } ++end program diff --git a/SOURCES/0019-Add-tests-for-AUTOMATIC-keyword.patch b/SOURCES/0019-Add-tests-for-AUTOMATIC-keyword.patch new file mode 100644 index 0000000..2e24b14 --- /dev/null +++ b/SOURCES/0019-Add-tests-for-AUTOMATIC-keyword.patch @@ -0,0 +1,35 @@ +From 52e49e5edaf2c4de5974b42dd359c0f57546c640 Mon Sep 17 00:00:00 2001 +From: Mark Doffman +Date: Thu, 5 Jun 2014 20:47:51 +0000 +Subject: [PATCH 19/23] Add tests for AUTOMATIC keyword + +These tests were written by Mark Doffman for his own implementation of +the AUTOMATIC keyword. Since then, Fritz Reese's implementation was +merged upstream so we no longer carry Mark's patches but the tests +may add some useful extra test coverage. Or they might not. +--- + gcc/testsuite/gfortran.dg/automatic_1.f90 | 31 ++++++++++++++++++++++++++ + gcc/testsuite/gfortran.dg/automatic_common.f90 | 6 +++++ + gcc/testsuite/gfortran.dg/automatic_repeat.f90 | 8 +++++++ + gcc/testsuite/gfortran.dg/automatic_save.f90 | 8 +++++++ + 4 files changed, 53 insertions(+) + create mode 100644 gcc/testsuite/gfortran.dg/automatic_1.f90 + create mode 100644 gcc/testsuite/gfortran.dg/automatic_common.f90 + create mode 100644 gcc/testsuite/gfortran.dg/automatic_repeat.f90 + create mode 100644 gcc/testsuite/gfortran.dg/automatic_save.f90 + +diff --git a/gcc/testsuite/gfortran.dg/automatic_common.f90 b/gcc/testsuite/gfortran.dg/automatic_common.f90 +new file mode 100644 +index 0000000..5ec016f +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/automatic_common.f90 +@@ -0,0 +1,6 @@ ++! { dg-do compile } ++! { dg-options "-fdec-static" } ++! A common variable may not have the AUTOMATIC attribute. ++INTEGER, AUTOMATIC :: X ++COMMON /COM/ X ! { dg-error "conflicts with AUTOMATIC attribute" } ++END +-- +2.9.5 + diff --git a/SOURCES/0022-Default-values-for-certain-field-descriptors-in-form.patch b/SOURCES/0022-Default-values-for-certain-field-descriptors-in-form.patch new file mode 100644 index 0000000..b070abe --- /dev/null +++ b/SOURCES/0022-Default-values-for-certain-field-descriptors-in-form.patch @@ -0,0 +1,516 @@ +diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c +index d93dcfa..f47565c 100644 +--- a/gcc/fortran/io.c ++++ b/gcc/fortran/io.c +@@ -909,6 +909,13 @@ data_desc: + + if (u != FMT_POSINT) + { ++ if (flag_dec) ++ { ++ /* Assume a default width based on the variable size. */ ++ saved_token = u; ++ break; ++ } ++ + format_locus.nextc += format_string_pos; + gfc_error ("Positive width required in format " + "specifier %s at %L", token_to_string (t), +@@ -1030,6 +1037,13 @@ data_desc: + goto fail; + if (t != FMT_ZERO && t != FMT_POSINT) + { ++ if (flag_dec) ++ { ++ /* Assume the default width is expected here and continue lexing. */ ++ value = 0; /* It doesn't matter what we set the value to here. */ ++ saved_token = t; ++ break; ++ } + error = nonneg_required; + goto syntax; + } +@@ -1099,8 +1113,17 @@ data_desc: + goto fail; + if (t != FMT_ZERO && t != FMT_POSINT) + { +- error = nonneg_required; +- goto syntax; ++ if (flag_dec) ++ { ++ /* Assume the default width is expected here and continue lexing. */ ++ value = 0; /* It doesn't matter what we set the value to here. */ ++ saved_token = t; ++ } ++ else ++ { ++ error = nonneg_required; ++ goto syntax; ++ } + } + else if (is_input && t == FMT_ZERO) + { +diff --git a/gcc/testsuite/gfortran.dg/fmt_f_default_field_width.f90 b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width.f90 +new file mode 100644 +index 0000000..b087b8f +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width.f90 +@@ -0,0 +1,43 @@ ++! { dg-do run } ++! { dg-options -fdec } ++! ++! Test case for the default field widths enabled by the -fdec-format-defaults flag. ++! ++! This feature is not part of any Fortran standard, but it is supported by the ++! Oracle Fortran compiler and others. ++! ++! libgfortran uses printf() internally to implement FORMAT. If you print float ++! values to a higher precision than the type can actually store, the results ++! are implementation dependent: some platforms print zeros, others print random ++! numbers. Don't depend on this behaviour in tests because they will not be ++! portable. ++ ++ character(50) :: buffer ++ ++ real*4 :: real_4 ++ real*8 :: real_8 ++ real*16 :: real_16 ++ integer :: len ++ ++ real_4 = 4.18 ++ write(buffer, '(A, F, A)') ':',real_4,':' ++ print *,buffer ++ if (buffer.ne.": 4.1799998:") call abort ++ ++ real_4 = 0.00000018 ++ write(buffer, '(A, F, A)') ':',real_4,':' ++ print *,buffer ++ if (buffer.ne.": 0.0000002:") call abort ++ ++ real_8 = 4.18 ++ write(buffer, '(A, F, A)') ':',real_8,':' ++ print *,buffer ++ len = len_trim(buffer) ++ if (len /= 27) call abort ++ ++ real_16 = 4.18 ++ write(buffer, '(A, F, A)') ':',real_16,':' ++ print *,buffer ++ len = len_trim(buffer) ++ if (len /= 44) call abort ++end +diff --git a/gcc/testsuite/gfortran.dg/fmt_g_default_field_width.f90 b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width.f90 +new file mode 100644 +index 0000000..3d3a476 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width.f90 +@@ -0,0 +1,48 @@ ++! { dg-do run } ++! { dg-options -fdec } ++! ++! Test case for the default field widths enabled by the -fdec-format-defaults flag. ++! ++! This feature is not part of any Fortran standard, but it is supported by the ++! Oracle Fortran compiler and others. ++! ++! libgfortran uses printf() internally to implement FORMAT. If you print float ++! values to a higher precision than the type can actually store, the results ++! are implementation dependent: some platforms print zeros, others print random ++! numbers. Don't depend on this behaviour in tests because they will not be ++! portable. ++ ++ character(50) :: buffer ++ ++ real*4 :: real_4 ++ real*8 :: real_8 ++ real*16 :: real_16 ++ integer :: len ++ ++ real_4 = 4.18 ++ write(buffer, '(A, G, A)') ':',real_4,':' ++ print *,buffer ++ if (buffer.ne.": 4.180000 :") call abort ++ ++ real_4 = 0.00000018 ++ write(buffer, '(A, G, A)') ':',real_4,':' ++ print *,buffer ++ if (buffer.ne.": 0.1800000E-06:") call abort ++ ++ real_4 = 18000000.4 ++ write(buffer, '(A, G, A)') ':',real_4,':' ++ print *,buffer ++ if (buffer.ne.": 0.1800000E+08:") call abort ++ ++ real_8 = 4.18 ++ write(buffer, '(A, G, A)') ':',real_8,':' ++ print *,buffer ++ len = len_trim(buffer) ++ if (len /= 27) call abort ++ ++ real_16 = 4.18 ++ write(buffer, '(A, G, A)') ':',real_16,':' ++ print *,buffer ++ len = len_trim(buffer) ++ if (len /= 44) call abort ++end +diff --git a/gcc/testsuite/gfortran.dg/fmt_i_default_field_width.f90 b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width.f90 +new file mode 100644 +index 0000000..ac4e165 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width.f90 +@@ -0,0 +1,38 @@ ++! { dg-do run } ++! { dg-options -fdec } ++! ++! Test case for the default field widths enabled by the -fdec-format-defaults flag. ++! ++! This feature is not part of any Fortran standard, but it is supported by the ++! Oracle Fortran compiler and others. ++ ++ character(50) :: buffer ++ character(1) :: colon ++ ++ integer*2 :: integer_2 ++ integer*4 :: integer_4 ++ integer*8 :: integer_8 ++ ++ write(buffer, '(A, I, A)') ':',12340,':' ++ print *,buffer ++ if (buffer.ne.": 12340:") call abort ++ ++ read(buffer, '(A1, I, A1)') colon, integer_4, colon ++ if (integer_4.ne.12340) call abort ++ ++ integer_2 = -99 ++ write(buffer, '(A, I, A)') ':',integer_2,':' ++ print *,buffer ++ if (buffer.ne.": -99:") call abort ++ ++ integer_8 = -11112222 ++ write(buffer, '(A, I, A)') ':',integer_8,':' ++ print *,buffer ++ if (buffer.ne.": -11112222:") call abort ++ ++! If the width is 7 and there are 7 leading zeroes, the result should be zero. ++ integer_2 = 789 ++ buffer = '0000000789' ++ read(buffer, '(I)') integer_2 ++ if (integer_2.ne.0) call abort ++end +diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c +index c2abdd7..692b1ff 100644 +--- a/libgfortran/io/format.c ++++ b/libgfortran/io/format.c +@@ -956,12 +956,33 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) + *seen_dd = true; + if (u != FMT_POSINT && u != FMT_ZERO) + { ++ if (dtp->common.flags & IOPARM_DT_DEC_EXT) ++ { ++ tail->u.real.w = DEFAULT_WIDTH; ++ tail->u.real.d = 0; ++ tail->u.real.e = -1; ++ fmt->saved_token = u; ++ break; ++ } + fmt->error = nonneg_required; + goto finished; + } + } ++ else if (u == FMT_ZERO) ++ { ++ fmt->error = posint_required; ++ goto finished; ++ } + else if (u != FMT_POSINT) + { ++ if (dtp->common.flags & IOPARM_DT_DEC_EXT) ++ { ++ tail->u.real.w = DEFAULT_WIDTH; ++ tail->u.real.d = 0; ++ tail->u.real.e = -1; ++ fmt->saved_token = u; ++ break; ++ } + fmt->error = posint_required; + goto finished; + } +@@ -1099,6 +1120,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) + { + if (t != FMT_POSINT) + { ++ if (dtp->common.flags & IOPARM_DT_DEC_EXT) ++ { ++ tail->u.integer.w = DEFAULT_WIDTH; ++ tail->u.integer.m = -1; ++ fmt->saved_token = t; ++ break; ++ } + fmt->error = posint_required; + goto finished; + } +@@ -1107,6 +1135,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) + { + if (t != FMT_ZERO && t != FMT_POSINT) + { ++ if (dtp->common.flags & IOPARM_DT_DEC_EXT) ++ { ++ tail->u.integer.w = DEFAULT_WIDTH; ++ tail->u.integer.m = -1; ++ fmt->saved_token = t; ++ break; ++ } + fmt->error = nonneg_required; + goto finished; + } +diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h +index 5583183..d1d08e8 100644 +--- a/libgfortran/io/io.h ++++ b/libgfortran/io/io.h +@@ -981,5 +981,55 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k) + *p++ = c; + } + ++/* Used in width fields to indicate that the default should be used */ ++#define DEFAULT_WIDTH -1 ++ ++/* Defaults for certain format field descriptors. These are decided based on ++ * the type of the value being formatted. ++ * ++ * The behaviour here is modelled on the Oracle Fortran compiler. At the time ++ * of writing, the details were available at this URL: ++ * ++ * https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d ++ */ ++ ++static inline int ++default_width_for_integer (int kind) ++{ ++ switch (kind) ++ { ++ case 1: ++ case 2: return 7; ++ case 4: return 12; ++ case 8: return 23; ++ case 16: return 44; ++ default: return 0; ++ } ++} ++ ++static inline int ++default_width_for_float (int kind) ++{ ++ switch (kind) ++ { ++ case 4: return 15; ++ case 8: return 25; ++ case 16: return 42; ++ default: return 0; ++ } ++} ++ ++static inline int ++default_precision_for_float (int kind) ++{ ++ switch (kind) ++ { ++ case 4: return 7; ++ case 8: return 16; ++ case 16: return 33; ++ default: return 0; ++ } ++} ++ + #endif + +diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c +index 2c9de48..e911e35 100644 +--- a/libgfortran/io/read.c ++++ b/libgfortran/io/read.c +@@ -629,6 +629,12 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) + + w = f->u.w; + ++ /* This is a legacy extension, and the frontend will only allow such cases ++ * through when -fdec-format-defaults is passed. ++ */ ++ if (w == DEFAULT_WIDTH) ++ w = default_width_for_integer (length); ++ + p = read_block_form (dtp, &w); + + if (p == NULL) +diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c +index a7307a8..c8e52fb 100644 +--- a/libgfortran/io/write.c ++++ b/libgfortran/io/write.c +@@ -684,9 +684,8 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) + p[wlen - 1] = (n) ? 'T' : 'F'; + } + +- + static void +-write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) ++write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len) + { + int w, m, digits, nzero, nblank; + char *p; +@@ -719,6 +718,9 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) + /* Select a width if none was specified. The idea here is to always + print something. */ + ++ if (w == DEFAULT_WIDTH) ++ w = default_width_for_integer (len); ++ + if (w == 0) + w = ((digits < m) ? m : digits); + +@@ -845,6 +847,8 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source, + + /* Select a width if none was specified. The idea here is to always + print something. */ ++ if (w == DEFAULT_WIDTH) ++ w = default_width_for_integer (len); + + if (w == 0) + w = ((digits < m) ? m : digits) + nsign; +@@ -1187,13 +1191,13 @@ write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len) + if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) + { + p = btoa_big (source, itoa_buf, len, &n); +- write_boz (dtp, f, p, n); ++ write_boz (dtp, f, p, n, len); + } + else + { + n = extract_uint (source, len); + p = btoa (n, itoa_buf, sizeof (itoa_buf)); +- write_boz (dtp, f, p, n); ++ write_boz (dtp, f, p, n, len); + } + } + +@@ -1208,13 +1212,13 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len) + if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) + { + p = otoa_big (source, itoa_buf, len, &n); +- write_boz (dtp, f, p, n); ++ write_boz (dtp, f, p, n, len); + } + else + { + n = extract_uint (source, len); + p = otoa (n, itoa_buf, sizeof (itoa_buf)); +- write_boz (dtp, f, p, n); ++ write_boz (dtp, f, p, n, len); + } + } + +@@ -1228,13 +1232,13 @@ write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len) + if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) + { + p = ztoa_big (source, itoa_buf, len, &n); +- write_boz (dtp, f, p, n); ++ write_boz (dtp, f, p, n, len); + } + else + { + n = extract_uint (source, len); + p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf)); +- write_boz (dtp, f, p, n); ++ write_boz (dtp, f, p, n, len); + } + } + +@@ -1504,7 +1508,7 @@ size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind) + { + int size; + +- if (f->format == FMT_F && f->u.real.w == 0) ++ if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH) + { + switch (kind) + { +diff --git a/libgfortran/io/write_float.def b/libgfortran/io/write_float.def +index 7f0aa1d..73dc910 100644 +--- a/libgfortran/io/write_float.def ++++ b/libgfortran/io/write_float.def +@@ -113,7 +113,8 @@ determine_precision (st_parameter_dt * d + static void + build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer, + size_t size, int nprinted, int precision, int sign_bit, +- bool zero_flag, int npad, char *result, size_t *len) ++ bool zero_flag, int npad, int default_width, char *result, ++ size_t *len) + { + char *put; + char *digits; +@@ -132,8 +133,17 @@ build_float_string (st_parameter_dt *dtp + sign_t sign; + + ft = f->format; +- w = f->u.real.w; +- d = f->u.real.d; ++ if (f->u.real.w == DEFAULT_WIDTH) ++ /* This codepath can only be reached with -fdec-format-defaults. */ ++ { ++ w = default_width; ++ d = precision; ++ } ++ else ++ { ++ w = f->u.real.w; ++ d = f->u.real.d; ++ } + p = dtp->u.p.scale_factor; + *len = 0; + +@@ -959,6 +969,11 @@ determine_en_precision (st_parameter_dt + int save_scale_factor;\ + volatile GFC_REAL_ ## x temp;\ + save_scale_factor = dtp->u.p.scale_factor;\ ++ if (w == DEFAULT_WIDTH)\ ++ {\ ++ w = default_width;\ ++ d = precision;\ ++ }\ + switch (dtp->u.p.current_unit->round_status)\ + {\ + case ROUND_ZERO:\ +@@ -1034,7 +1049,8 @@ determine_en_precision (st_parameter_dt + nprinted = FDTOA(y,precision,m);\ + }\ + build_float_string (dtp, &newf, buffer, size, nprinted, precision,\ +- sign_bit, zero_flag, npad, result, res_len);\ ++ sign_bit, zero_flag, npad, default_width,\ ++ result, res_len);\ + dtp->u.p.scale_factor = save_scale_factor;\ + }\ + else\ +@@ -1044,7 +1060,8 @@ determine_en_precision (st_parameter_dt + else\ + nprinted = DTOA(y,precision,m);\ + build_float_string (dtp, f, buffer, size, nprinted, precision,\ +- sign_bit, zero_flag, npad, result, res_len);\ ++ sign_bit, zero_flag, npad, default_width,\ ++ result, res_len);\ + }\ + }\ + +@@ -1058,6 +1075,16 @@ get_float_string (st_parameter_dt *dtp, + { + int sign_bit, nprinted; + bool zero_flag; ++ int default_width = 0; ++ ++ if (f->u.real.w == DEFAULT_WIDTH) ++ /* This codepath can only be reached with -fdec-format-defaults. The default ++ * values are based on those used in the Oracle Fortran compiler. ++ */ ++ { ++ default_width = default_width_for_float (kind); ++ precision = default_precision_for_float (kind); ++ } + + switch (kind) + { diff --git a/SOURCES/doxygen-1.7.1-config.patch b/SOURCES/doxygen-1.7.1-config.patch new file mode 100644 index 0000000..f6be5b9 --- /dev/null +++ b/SOURCES/doxygen-1.7.1-config.patch @@ -0,0 +1,95 @@ +diff -up doxygen-1.7.1/addon/doxywizard/Makefile.in.config doxygen-1.7.1/addon/doxywizard/Makefile.in +--- doxygen-1.7.1/addon/doxywizard/Makefile.in.config 2010-05-23 16:51:31.000000000 +0200 ++++ doxygen-1.7.1/addon/doxywizard/Makefile.in 2010-07-19 13:38:33.000000000 +0200 +@@ -10,8 +10,6 @@ + # See the GNU General Public License for more details. + # + +-QMAKE=qmake $(MKSPECS) +- + all: Makefile.doxywizard + $(MAKE) -f Makefile.doxywizard + +@@ -29,11 +27,11 @@ distclean: Makefile.doxywizard + $(RM) Makefile.doxywizard + + install: +- $(INSTTOOL) -d $(INSTALL)/bin +- $(INSTTOOL) -m 755 ../../bin/doxywizard $(INSTALL)/bin +- $(INSTTOOL) -d $(INSTALL)/$(MAN1DIR) ++ $(INSTTOOL) -d $(DESTDIR)$(INSTALL)/bin ++ $(INSTTOOL) -m 755 ../../bin/doxywizard $(DESTDIR)$(INSTALL)/bin ++ $(INSTTOOL) -d $(DESTDIR)$(INSTALL)/$(MAN1DIR) + cat ../../doc/doxywizard.1 | sed -e "s/DATE/$(DATE)/g" -e "s/VERSION/$(VERSION)/g" > doxywizard.1 +- $(INSTTOOL) -m 644 doxywizard.1 $(INSTALL)/$(MAN1DIR)/doxywizard.1 ++ $(INSTTOOL) -m 644 doxywizard.1 $(DESTDIR)$(INSTALL)/$(MAN1DIR)/doxywizard.1 + rm doxywizard.1 + + FORCE: +diff -up doxygen-1.7.1/configure.config doxygen-1.7.1/configure +--- doxygen-1.7.1/configure.config 2010-06-25 11:46:38.000000000 +0200 ++++ doxygen-1.7.1/configure 2010-07-19 12:03:53.000000000 +0200 +@@ -268,9 +268,10 @@ if test "$f_wizard" = YES; then + if test -z "$QTDIR"; then + echo " QTDIR environment variable not set!" + echo -n " Checking for Qt..." +- for d in /usr/{lib,share,qt}/{qt-4,qt4,qt,qt*,4} /usr; do ++ for d in /usr/{lib64,lib,share,qt}/{qt-4,qt4,qt,qt*,4} /usr; do + if test -x "$d/bin/qmake"; then + QTDIR=$d ++ QMAKE=$d/bin/qmake + fi + done + else +@@ -485,6 +486,8 @@ INSTTOOL = $f_insttool + DOXYDOCS = .. + DOCDIR = $f_docdir + QTDIR = $QTDIR ++QMAKE = $QMAKE ++MAN1DIR = share/man/man1 + EOF + + if test "$f_dot" != NO; then +diff -up doxygen-1.7.1/Makefile.in.config doxygen-1.7.1/Makefile.in +--- doxygen-1.7.1/Makefile.in.config 2009-08-20 21:41:13.000000000 +0200 ++++ doxygen-1.7.1/Makefile.in 2010-07-19 12:03:53.000000000 +0200 +@@ -44,8 +44,6 @@ distclean: clean + + DATE=$(shell date "+%B %Y") + +-MAN1DIR = man/man1 +- + install: doxywizard_install + $(INSTTOOL) -d $(DESTDIR)/$(INSTALL)/bin + $(INSTTOOL) -m 755 bin/doxygen $(DESTDIR)/$(INSTALL)/bin +diff -up doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf.config doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf +--- doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf.config 2008-12-06 14:16:20.000000000 +0100 ++++ doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf 2010-07-19 12:03:53.000000000 +0200 +@@ -11,7 +11,7 @@ TMAKE_CC = gcc + TMAKE_CFLAGS = -pipe + TMAKE_CFLAGS_WARN_ON = -Wall -W -fno-exceptions + TMAKE_CFLAGS_WARN_OFF = +-TMAKE_CFLAGS_RELEASE = -O2 ++TMAKE_CFLAGS_RELEASE = $(RPM_OPT_FLAGS) + TMAKE_CFLAGS_DEBUG = -g + TMAKE_CFLAGS_SHLIB = -fPIC + TMAKE_CFLAGS_YACC = -Wno-unused -Wno-parentheses +@@ -27,12 +27,12 @@ TMAKE_CXXFLAGS_YACC = $$TMAKE_CFLAGS_YAC + + TMAKE_INCDIR = + TMAKE_LIBDIR = +-TMAKE_INCDIR_X11 = /usr/X11R6/include +-TMAKE_LIBDIR_X11 = /usr/X11R6/lib +-TMAKE_INCDIR_QT = $(QTDIR)/include +-TMAKE_LIBDIR_QT = $(QTDIR)/lib +-TMAKE_INCDIR_OPENGL = /usr/X11R6/include +-TMAKE_LIBDIR_OPENGL = /usr/X11R6/lib ++TMAKE_INCDIR_X11 = ++TMAKE_LIBDIR_X11 = ++TMAKE_INCDIR_QT = ++TMAKE_LIBDIR_QT = ++TMAKE_INCDIR_OPENGL = ++TMAKE_LIBDIR_OPENGL = + + TMAKE_LINK = g++ + TMAKE_LINK_SHLIB = g++ diff --git a/SOURCES/doxygen-1.7.5-timestamp.patch b/SOURCES/doxygen-1.7.5-timestamp.patch new file mode 100644 index 0000000..efbd992 --- /dev/null +++ b/SOURCES/doxygen-1.7.5-timestamp.patch @@ -0,0 +1,63 @@ +diff -up doxygen-1.7.5/src/configoptions.cpp.timestamp doxygen-1.7.5/src/configoptions.cpp +--- doxygen-1.7.5/src/configoptions.cpp.timestamp 2011-08-03 15:54:50.000000000 +0200 ++++ doxygen-1.7.5/src/configoptions.cpp 2011-08-23 12:55:56.000000000 +0200 +@@ -1173,6 +1173,14 @@ void addConfigOptions(Config *cfg) + cs->setWidgetType(ConfigString::File); + cs->addDependency("GENERATE_HTML"); + //---- ++ cb = cfg->addBool( ++ "HTML_TIMESTAMP", ++ "If the HTML_TIMESTAMP tag is set to YES then the generated HTML\n" ++ "documentation will contain the timesstamp.", ++ FALSE ++ ); ++ cb->addDependency("GENERATE_HTML"); ++ //---- + cs = cfg->addString( + "HTML_STYLESHEET", + "The HTML_STYLESHEET tag can be used to specify a user-defined cascading\n" +diff -up doxygen-1.7.5/src/config.xml.timestamp doxygen-1.7.5/src/config.xml +--- doxygen-1.7.5/src/config.xml.timestamp 2011-08-03 15:54:48.000000000 +0200 ++++ doxygen-1.7.5/src/config.xml 2011-08-23 12:55:56.000000000 +0200 +@@ -819,6 +819,11 @@ The HTML_FOOTER tag can be used to speci + each generated HTML page. If it is left blank doxygen will generate a + standard footer. + ' defval='' depends='GENERATE_HTML'/> ++