diff --git a/.gcc-toolset-10-gcc.metadata b/.gcc-toolset-10-gcc.metadata index 0b7bb04..24c852b 100644 --- a/.gcc-toolset-10-gcc.metadata +++ b/.gcc-toolset-10-gcc.metadata @@ -1,5 +1,5 @@ 7f4348418dc3efefd357b32a2b5c8010211ab284 SOURCES/doxygen-1.8.0.src.tar.gz -19a2803c35999e08af82cdbfc7e7502ad2fe7b59 SOURCES/gcc-10.2.1-20200804.tar.xz +3efb3a5c6f09afa1b8395983d633a7bc8da53900 SOURCES/gcc-10.2.1-20201102.tar.xz c5a2b201bf05229647e73203c0bf2d9679d4d21f SOURCES/isl-0.16.1.tar.bz2 5ef03ca7aee134fe7dfecb6c9d048799f0810278 SOURCES/mpc-0.8.1.tar.gz 6ec33952e824e837fef0e829c93d39d6a507082f SOURCES/newlib-cygwin-50e2a63b04bdd018484605fbb954fd1bd5147fa0.tar.xz diff --git a/.gitignore b/.gitignore index 4e4be14..98ff5bf 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ SOURCES/doxygen-1.8.0.src.tar.gz -SOURCES/gcc-10.2.1-20200804.tar.xz +SOURCES/gcc-10.2.1-20201102.tar.xz SOURCES/isl-0.16.1.tar.bz2 SOURCES/mpc-0.8.1.tar.gz SOURCES/newlib-cygwin-50e2a63b04bdd018484605fbb954fd1bd5147fa0.tar.xz diff --git a/SOURCES/0001-Allow-duplicate-declarations.patch b/SOURCES/0001-Allow-duplicate-declarations.patch new file mode 100644 index 0000000..939d200 --- /dev/null +++ b/SOURCES/0001-Allow-duplicate-declarations.patch @@ -0,0 +1,215 @@ +From 1926e1725a6cfba844e72dd3aed83b9aa3eb09dd Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 08:32:04 +0000 +Subject: [PATCH 01/10] Allow duplicate declarations. + +Enabled by -fdec-duplicates and -fdec. + +Some fixes by Jim MacArthur +Addition of -fdec-duplicates by Mark Eggleston +--- + gcc/fortran/lang.opt | 4 ++++ + gcc/fortran/options.c | 1 + + gcc/fortran/symbol.c | 21 +++++++++++++++++++-- + gcc/testsuite/gfortran.dg/duplicate_type_4.f90 | 13 +++++++++++++ + gcc/testsuite/gfortran.dg/duplicate_type_5.f90 | 13 +++++++++++++ + gcc/testsuite/gfortran.dg/duplicate_type_6.f90 | 13 +++++++++++++ + gcc/testsuite/gfortran.dg/duplicate_type_7.f90 | 13 +++++++++++++ + gcc/testsuite/gfortran.dg/duplicate_type_8.f90 | 12 ++++++++++++ + gcc/testsuite/gfortran.dg/duplicate_type_9.f90 | 12 ++++++++++++ + 9 files changed, 100 insertions(+), 2 deletions(-) + create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_4.f90 + create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_5.f90 + create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_6.f90 + create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_7.f90 + create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_8.f90 + create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_9.f90 + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index da4b1aa879a..6275dc3deff 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -465,6 +465,10 @@ Fortran Var(flag_dec_char_conversions) + Enable the use of character literals in assignments and data statements + for non-character variables. + ++fdec-duplicates ++Fortran Var(flag_dec_duplicates) ++Allow varibles to be duplicated in the type specification matches. ++ + fdec-include + Fortran Var(flag_dec_include) + Enable legacy parsing of INCLUDE as statement. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index 4cc8a908417..75181ca6442 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -77,6 +77,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_format_defaults, value, value); + SET_BITFLAG (flag_dec_blank_format_item, value, value); + SET_BITFLAG (flag_dec_char_conversions, value, value); ++ SET_BITFLAG (flag_dec_duplicates, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c +index 96e4cee3040..92f2ce21cca 100644 +--- a/gcc/fortran/symbol.c ++++ b/gcc/fortran/symbol.c +@@ -1995,6 +1995,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) +@@ -2007,6 +2009,23 @@ gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) + else if (sym->attr.function && sym->attr.result) + gfc_error ("Symbol %qs at %L already has basic type of %s", + sym->ns->proc_name->name, where, gfc_basic_typename (type)); ++ else if (flag_dec_duplicates) ++ { ++ /* 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)); +@@ -2020,8 +2039,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 00000000000..cdd29ea8846 +--- /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/gcc/testsuite/gfortran.dg/duplicate_type_5.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_5.f90 +new file mode 100644 +index 00000000000..00f931809aa +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/duplicate_type_5.f90 +@@ -0,0 +1,13 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test case contributed by Mark Eggleston ++! ++ ++program test ++ implicit none ++ integer :: x ++ integer :: x ++ x = 42 ++ if (x /= 42) stop 1 ++end program test +diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_6.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_6.f90 +new file mode 100644 +index 00000000000..f0df27e323c +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/duplicate_type_6.f90 +@@ -0,0 +1,13 @@ ++! { dg-do run } ++! { dg-options "-std=legacy -fdec-duplicates" } ++! ++! Test case contributed by Mark Eggleston ++! ++ ++program test ++ implicit none ++ integer :: x ++ integer :: x ++ x = 42 ++ if (x /= 42) stop 1 ++end program test +diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_7.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_7.f90 +new file mode 100644 +index 00000000000..f32472ff586 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/duplicate_type_7.f90 +@@ -0,0 +1,13 @@ ++! { dg-do run } ++! { dg-options "-fdec-duplicates" } ++! ++! Test case contributed by Mark Eggleston ++! ++ ++program test ++ implicit none ++ integer :: x ++ integer :: x! { dg-warning "Legacy Extension" } ++ x = 42 ++ if (x /= 42) stop 1 ++end program test +diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_8.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_8.f90 +new file mode 100644 +index 00000000000..23c94add179 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/duplicate_type_8.f90 +@@ -0,0 +1,12 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-duplicates" } ++! ++! Test case contributed by Mark Eggleston ++! ++ ++integer function foo () ++ implicit none ++ integer :: x ++ integer :: x ! { dg-error "basic type of" } ++ x = 42 ++end function foo +diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_9.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_9.f90 +new file mode 100644 +index 00000000000..d5edee4d8ee +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/duplicate_type_9.f90 +@@ -0,0 +1,12 @@ ++! { dg-do compile } ++! { dg-options "-fdec-duplicates -fno-dec-duplicates" } ++! ++! Test case contributed by Mark Eggleston ++! ++ ++integer function foo () ++ implicit none ++ integer :: x ++ integer :: x ! { dg-error "basic type of" } ++ x = 42 ++end function foo +-- +2.11.0 + diff --git a/SOURCES/0001-Default-widths-for-i-f-and-g-format-specifiers-in-fo.patch b/SOURCES/0001-Default-widths-for-i-f-and-g-format-specifiers-in-fo.patch deleted file mode 100644 index 8d6247d..0000000 --- a/SOURCES/0001-Default-widths-for-i-f-and-g-format-specifiers-in-fo.patch +++ /dev/null @@ -1,873 +0,0 @@ -From f3e3034684c7ac44a14c70d6a248d8acee303176 Mon Sep 17 00:00:00 2001 -From: law -Date: Thu, 10 May 2018 11:48:34 +0100 -Subject: [PATCH 01/16] Default widths for i, f and g format specifiers in - format strings. - -Enabled using -fdec. - -The behaviour 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 - -Addition by Mark Eggleston : - -Use -fdec-format-defaults to enable this feature. Also enabled using -fdec. ---- - gcc/fortran/io.c | 31 +++++++++++-- - gcc/fortran/lang.opt | 4 ++ - gcc/fortran/options.c | 1 + - .../gfortran.dg/fmt_f_default_field_width_1.f90 | 43 ++++++++++++++++++ - .../gfortran.dg/fmt_f_default_field_width_2.f90 | 46 +++++++++++++++++++ - .../gfortran.dg/fmt_f_default_field_width_3.f90 | 28 ++++++++++++ - .../gfortran.dg/fmt_g_default_field_width_1.f90 | 48 ++++++++++++++++++++ - .../gfortran.dg/fmt_g_default_field_width_2.f90 | 52 ++++++++++++++++++++++ - .../gfortran.dg/fmt_g_default_field_width_3.f90 | 31 +++++++++++++ - .../gfortran.dg/fmt_i_default_field_width_1.f90 | 38 ++++++++++++++++ - .../gfortran.dg/fmt_i_default_field_width_2.f90 | 42 +++++++++++++++++ - .../gfortran.dg/fmt_i_default_field_width_3.f90 | 35 +++++++++++++++ - libgfortran/io/format.c | 35 +++++++++++++++ - libgfortran/io/io.h | 50 +++++++++++++++++++++ - libgfortran/io/read.c | 6 +++ - libgfortran/io/write.c | 22 +++++---- - libgfortran/io/write_float.def | 37 ++++++++++++--- - 17 files changed, 531 insertions(+), 18 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/fmt_f_default_field_width_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_f_default_field_width_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_f_default_field_width_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_g_default_field_width_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_g_default_field_width_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_g_default_field_width_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_i_default_field_width_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_i_default_field_width_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/fmt_i_default_field_width_3.f90 - -diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c -index 9828897852a..57117579627 100644 ---- a/gcc/fortran/io.c -+++ b/gcc/fortran/io.c -@@ -903,6 +903,13 @@ data_desc: - - if (u != FMT_POSINT) - { -+ if (flag_dec_format_defaults) -+ { -+ /* 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), -@@ -1027,6 +1034,13 @@ data_desc: - goto fail; - if (t != FMT_ZERO && t != FMT_POSINT) - { -+ if (flag_dec_format_defaults) -+ { -+ /* 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; - } -@@ -1096,8 +1110,17 @@ data_desc: - goto fail; - if (t != FMT_ZERO && t != FMT_POSINT) - { -- error = nonneg_required; -- goto syntax; -+ if (flag_dec_format_defaults) -+ { -+ /* 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) - { -@@ -4368,8 +4391,8 @@ get_io_list: - } - - /* See if we want to use defaults for missing exponents in real transfers -- and other DEC runtime extensions. */ -- if (flag_dec) -+ and other DEC runtime extensions. */ -+ if (flag_dec_format_defaults) - dt->dec_ext = 1; - - /* A full IO statement has been matched. Check the constraints. spec_end is -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 9151d02c491..26e82601b62 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -444,6 +444,10 @@ fdec-include - Fortran Var(flag_dec_include) - Enable legacy parsing of INCLUDE as statement. - -+fdec-format-defaults -+Fortran Var(flag_dec_format_defaults) -+Enable default widths for i, f and g format specifiers. -+ - fdec-intrinsic-ints - Fortran Var(flag_dec_intrinsic_ints) - Enable kind-specific variants of integer intrinsic functions. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index 02970d59066..4f91486e977 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -74,6 +74,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_static, value, value); - SET_BITFLAG (flag_dec_math, value, value); - SET_BITFLAG (flag_dec_include, value, value); -+ SET_BITFLAG (flag_dec_format_defaults, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_1.f90 b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_1.f90 -new file mode 100644 -index 00000000000..49c77155761 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_1.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:") stop 1 -+ -+ real_4 = 0.00000018 -+ write(buffer, '(A, F, A)') ':',real_4,':' -+ print *,buffer -+ if (buffer.ne.": 0.0000002:") stop 2 -+ -+ real_8 = 4.18 -+ write(buffer, '(A, F, A)') ':',real_8,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 27) stop 3 -+ -+ real_16 = 4.18 -+ write(buffer, '(A, F, A)') ':',real_16,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 44) stop 4 -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_2.f90 b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_2.f90 -new file mode 100644 -index 00000000000..1c2ec0413a7 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_2.f90 -@@ -0,0 +1,46 @@ -+! { dg-do run } -+! { dg-options -fdec-format-defaults } -+! -+! 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. -+! -+! Test case added by Mark Eggleston to check -+! use of -fdec-format-defaults -+! -+ 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:") stop 1 -+ -+ real_4 = 0.00000018 -+ write(buffer, '(A, F, A)') ':',real_4,':' -+ print *,buffer -+ if (buffer.ne.": 0.0000002:") stop 2 -+ -+ real_8 = 4.18 -+ write(buffer, '(A, F, A)') ':',real_8,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 27) stop 3 -+ -+ real_16 = 4.18 -+ write(buffer, '(A, F, A)') ':',real_16,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 44) stop 4 -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_3.f90 b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_3.f90 -new file mode 100644 -index 00000000000..e513063189b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_f_default_field_width_3.f90 -@@ -0,0 +1,28 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-format-defaults" } -+! -+! Test case for the default field widths not enabled. -+! -+! Test case added by Mark Eggleston to check -+! use of -fno-dec-format-defaults -+! -+ -+ 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,':' ! { dg-error "Nonnegative width required" } -+ -+ real_4 = 0.00000018 -+ write(buffer, '(A, F, A)') ':',real_4,':' ! { dg-error "Nonnegative width required" } -+ -+ real_8 = 4.18 -+ write(buffer, '(A, F, A)') ':',real_8,':' ! { dg-error "Nonnegative width required" } -+ -+ real_16 = 4.18 -+ write(buffer, '(A, F, A)') ':',real_16,':' ! { dg-error "Nonnegative width required" } -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_1.f90 b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_1.f90 -new file mode 100644 -index 00000000000..6e2ad141d4a ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_1.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 :") stop 1 -+ -+ real_4 = 0.00000018 -+ write(buffer, '(A, G, A)') ':',real_4,':' -+ print *,buffer -+ if (buffer.ne.": 0.1800000E-06:") stop 2 -+ -+ real_4 = 18000000.4 -+ write(buffer, '(A, G, A)') ':',real_4,':' -+ print *,buffer -+ if (buffer.ne.": 0.1800000E+08:") stop 3 -+ -+ real_8 = 4.18 -+ write(buffer, '(A, G, A)') ':',real_8,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 27) stop 4 -+ -+ real_16 = 4.18 -+ write(buffer, '(A, G, A)') ':',real_16,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 44) stop 5 -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_2.f90 b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_2.f90 -new file mode 100644 -index 00000000000..7b218af8610 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_2.f90 -@@ -0,0 +1,52 @@ -+! { dg-do run } -+! { dg-options -fdec-format-defaults } -+! -+! 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. -+! -+! Test case added by Mark Eggleston to check -+! use of -fdec-format-defaults -+! -+ -+ 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 :") stop 1 -+ -+ real_4 = 0.00000018 -+ write(buffer, '(A, G, A)') ':',real_4,':' -+ print *,buffer -+ if (buffer.ne.": 0.1800000E-06:") stop 2 -+ -+ real_4 = 18000000.4 -+ write(buffer, '(A, G, A)') ':',real_4,':' -+ print *,buffer -+ if (buffer.ne.": 0.1800000E+08:") stop 3 -+ -+ real_8 = 4.18 -+ write(buffer, '(A, G, A)') ':',real_8,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 27) stop 4 -+ -+ real_16 = 4.18 -+ write(buffer, '(A, G, A)') ':',real_16,':' -+ print *,buffer -+ len = len_trim(buffer) -+ if (len /= 44) stop 5 -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_3.f90 b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_3.f90 -new file mode 100644 -index 00000000000..e255c2f94a0 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_g_default_field_width_3.f90 -@@ -0,0 +1,31 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-format-defaults" } -+! -+! Test case for the default field widths not enabled. -+! -+! Test case added by Mark Eggleston to check -+! use of -fno-dec-format-defaults -+! -+ -+ 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,':' ! { dg-error "Positive width required" } -+ -+ real_4 = 0.00000018 -+ write(buffer, '(A, G, A)') ':',real_4,':' ! { dg-error "Positive width required" } -+ -+ real_4 = 18000000.4 -+ write(buffer, '(A, G, A)') ':',real_4,':' ! { dg-error "Positive width required" } -+ -+ real_8 = 4.18 -+ write(buffer, '(A, G, A)') ':',real_8,':' ! { dg-error "Positive width required" } -+ -+ real_16 = 4.18 -+ write(buffer, '(A, G, A)') ':',real_16,':' ! { dg-error "Positive width required" } -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_1.f90 b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_1.f90 -new file mode 100644 -index 00000000000..0d32d240394 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_1.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:") stop 1 -+ -+ read(buffer, '(A1, I, A1)') colon, integer_4, colon -+ if (integer_4.ne.12340) stop 2 -+ -+ integer_2 = -99 -+ write(buffer, '(A, I, A)') ':',integer_2,':' -+ print *,buffer -+ if (buffer.ne.": -99:") stop 3 -+ -+ integer_8 = -11112222 -+ write(buffer, '(A, I, A)') ':',integer_8,':' -+ print *,buffer -+ if (buffer.ne.": -11112222:") stop 4 -+ -+! 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) stop 5 -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_2.f90 b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_2.f90 -new file mode 100644 -index 00000000000..6cee3f86809 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_2.f90 -@@ -0,0 +1,42 @@ -+! { dg-do run } -+! { dg-options -fdec-format-defaults } -+! -+! 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. -+! -+! Test case added by Mark Eggleston to check -+! use of -fdec-format-defaults -+! -+ -+ 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:") stop 1 -+ -+ read(buffer, '(A1, I, A1)') colon, integer_4, colon -+ if (integer_4.ne.12340) stop 2 -+ -+ integer_2 = -99 -+ write(buffer, '(A, I, A)') ':',integer_2,':' -+ print *,buffer -+ if (buffer.ne.": -99:") stop 3 -+ -+ integer_8 = -11112222 -+ write(buffer, '(A, I, A)') ':',integer_8,':' -+ print *,buffer -+ if (buffer.ne.": -11112222:") stop 4 -+ -+! 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) stop 5 -+end -diff --git a/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_3.f90 b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_3.f90 -new file mode 100644 -index 00000000000..3a6684b3c4d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/fmt_i_default_field_width_3.f90 -@@ -0,0 +1,35 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-format-defaults" } -+! -+! 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. -+! -+! Test case added by Mark Eggleston to check -+! use of -fdec-format-defaults -+! -+ -+ character(50) :: buffer -+ character(1) :: colon -+ -+ integer*2 :: integer_2 -+ integer*4 :: integer_4 -+ integer*8 :: integer_8 -+ -+ write(buffer, '(A, I, A)') ':',12340,':' ! { dg-error "Nonnegative width required" } -+ -+ read(buffer, '(A1, I, A1)') colon, integer_4, colon ! { dg-error "Nonnegative width required" } -+ if (integer_4.ne.12340) stop 2 -+ -+ integer_2 = -99 -+ write(buffer, '(A, I, A)') ':',integer_2,':' ! { dg-error "Nonnegative width required" } -+ -+ integer_8 = -11112222 -+ write(buffer, '(A, I, A)') ':',integer_8,':' ! { dg-error "Nonnegative width required" } -+ -+! 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 ! { dg-error "Nonnegative width required" } -+end -diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c -index 688764785da..e798d9bda87 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; - } -@@ -1100,6 +1121,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; - } -@@ -1108,6 +1136,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 5caaea280f0..f5e63797ba1 100644 ---- a/libgfortran/io/io.h -+++ b/libgfortran/io/io.h -@@ -1011,6 +1011,56 @@ 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 - - extern void -diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c -index 52ffb4639ac..be9f6cb6f76 100644 ---- a/libgfortran/io/read.c -+++ b/libgfortran/io/read.c -@@ -635,6 +635,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 c8811e200e0..4ef35561fdd 100644 ---- a/libgfortran/io/write.c -+++ b/libgfortran/io/write.c -@@ -685,9 +685,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; -@@ -720,6 +719,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); - -@@ -846,6 +848,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; -@@ -1206,13 +1210,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); - } - } - -@@ -1227,13 +1231,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); - } - } - -@@ -1247,13 +1251,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); - } - } - -@@ -1491,7 +1495,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 c63db4e77ef..daa16679f53 100644 ---- a/libgfortran/io/write_float.def -+++ b/libgfortran/io/write_float.def -@@ -113,7 +113,8 @@ determine_precision (st_parameter_dt * dtp, const fnode * f, int len) - 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, const fnode *f, char *buffer, - 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; - -@@ -960,6 +970,11 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, - 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:\ -@@ -1035,7 +1050,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, - 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\ -@@ -1045,7 +1061,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, - 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);\ - }\ - }\ - -@@ -1059,6 +1076,16 @@ get_float_string (st_parameter_dt *dtp, const fnode *f, const char *source, - { - 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) - { --- -2.11.0 - diff --git a/SOURCES/0002-Allow-duplicate-declarations.patch b/SOURCES/0002-Allow-duplicate-declarations.patch deleted file mode 100644 index 42f4fd3..0000000 --- a/SOURCES/0002-Allow-duplicate-declarations.patch +++ /dev/null @@ -1,219 +0,0 @@ -From dd2c3c5e8e8370d6e08a87b7122b8fbe4ddf7dde Mon Sep 17 00:00:00 2001 -From: Mark Doffman -Date: Tue, 23 Jun 2015 22:59:08 +0000 -Subject: [PATCH 02/16] Allow duplicate declarations. - -Enabled by -fdec-duplicates and -fdec. - -Some fixes by Jim MacArthur -Addition of -fdec-duplicates by Mark Eggleston ---- - gcc/fortran/lang.opt | 4 ++++ - gcc/fortran/options.c | 1 + - gcc/fortran/symbol.c | 23 ++++++++++++++++++++--- - gcc/testsuite/gfortran.dg/duplicate_type_4.f90 | 13 +++++++++++++ - gcc/testsuite/gfortran.dg/duplicate_type_5.f90 | 13 +++++++++++++ - gcc/testsuite/gfortran.dg/duplicate_type_6.f90 | 13 +++++++++++++ - gcc/testsuite/gfortran.dg/duplicate_type_7.f90 | 13 +++++++++++++ - gcc/testsuite/gfortran.dg/duplicate_type_8.f90 | 12 ++++++++++++ - gcc/testsuite/gfortran.dg/duplicate_type_9.f90 | 12 ++++++++++++ - 9 files changed, 101 insertions(+), 3 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_4.f90 - create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_5.f90 - create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_6.f90 - create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_7.f90 - create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_8.f90 - create mode 100644 gcc/testsuite/gfortran.dg/duplicate_type_9.f90 - -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 26e82601b62..491d81ccaa5 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -440,6 +440,10 @@ fdec - Fortran Var(flag_dec) - Enable all DEC language extensions. - -+fdec-duplicates -+Fortran Var(flag_dec_duplicates) -+Allow varibles to be duplicated in the type specification matches. -+ - fdec-include - Fortran Var(flag_dec_include) - Enable legacy parsing of INCLUDE as statement. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index 4f91486e977..f93db8b6d7c 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -75,6 +75,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_math, value, value); - SET_BITFLAG (flag_dec_include, value, value); - SET_BITFLAG (flag_dec_format_defaults, value, value); -+ SET_BITFLAG (flag_dec_duplicates, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c -index ec753229a98..4247b5b60c8 100644 ---- a/gcc/fortran/symbol.c -+++ b/gcc/fortran/symbol.c -@@ -1995,6 +1995,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) -@@ -2004,9 +2006,26 @@ 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 (flag_dec_duplicates) -+ { -+ /* 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)); -+ where, gfc_basic_typename (type)); - return false; - } - -@@ -2017,8 +2036,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 00000000000..cdd29ea8846 ---- /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/gcc/testsuite/gfortran.dg/duplicate_type_5.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_5.f90 -new file mode 100644 -index 00000000000..00f931809aa ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/duplicate_type_5.f90 -@@ -0,0 +1,13 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program test -+ implicit none -+ integer :: x -+ integer :: x -+ x = 42 -+ if (x /= 42) stop 1 -+end program test -diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_6.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_6.f90 -new file mode 100644 -index 00000000000..f0df27e323c ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/duplicate_type_6.f90 -@@ -0,0 +1,13 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec-duplicates" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program test -+ implicit none -+ integer :: x -+ integer :: x -+ x = 42 -+ if (x /= 42) stop 1 -+end program test -diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_7.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_7.f90 -new file mode 100644 -index 00000000000..f32472ff586 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/duplicate_type_7.f90 -@@ -0,0 +1,13 @@ -+! { dg-do run } -+! { dg-options "-fdec-duplicates" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program test -+ implicit none -+ integer :: x -+ integer :: x! { dg-warning "Legacy Extension" } -+ x = 42 -+ if (x /= 42) stop 1 -+end program test -diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_8.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_8.f90 -new file mode 100644 -index 00000000000..23c94add179 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/duplicate_type_8.f90 -@@ -0,0 +1,12 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-duplicates" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+integer function foo () -+ implicit none -+ integer :: x -+ integer :: x ! { dg-error "basic type of" } -+ x = 42 -+end function foo -diff --git a/gcc/testsuite/gfortran.dg/duplicate_type_9.f90 b/gcc/testsuite/gfortran.dg/duplicate_type_9.f90 -new file mode 100644 -index 00000000000..d5edee4d8ee ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/duplicate_type_9.f90 -@@ -0,0 +1,12 @@ -+! { dg-do compile } -+! { dg-options "-fdec-duplicates -fno-dec-duplicates" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+integer function foo () -+ implicit none -+ integer :: x -+ integer :: x ! { dg-error "basic type of" } -+ x = 42 -+end function foo --- -2.11.0 - diff --git a/SOURCES/0002-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch b/SOURCES/0002-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch new file mode 100644 index 0000000..252d9d9 --- /dev/null +++ b/SOURCES/0002-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch @@ -0,0 +1,305 @@ +From cb3a42eb8e7ca26714c8dea383f2111230fdc0b5 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 08:51:11 +0000 +Subject: [PATCH 02/10] 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 -flogical-as-integer flag. + +Note: using this feature will disable bitwise logical operations enabled by +-fdec. +--- + gcc/fortran/lang.opt | 4 ++ + gcc/fortran/resolve.c | 55 +++++++++++++++++++++- + .../logical_to_integer_and_vice_versa_1.f | 31 ++++++++++++ + .../logical_to_integer_and_vice_versa_2.f | 31 ++++++++++++ + .../logical_to_integer_and_vice_versa_3.f | 33 +++++++++++++ + .../logical_to_integer_and_vice_versa_4.f | 33 +++++++++++++ + 6 files changed, 186 insertions(+), 1 deletion(-) + create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f + create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f + create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f + create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index 6275dc3deff..5257da74b06 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -493,6 +493,10 @@ fdec-static + Fortran Var(flag_dec_static) + Enable DEC-style STATIC and AUTOMATIC attributes. + ++flogical-as-integer ++Fortran Var(flag_logical_as_integer) ++Convert from integer to logical or logical to integer for arithmetic operations. ++ + fdefault-double-8 + Fortran Var(flag_default_double) + Set the default double precision kind to an 8 byte wide type. +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 354702bda0b..6e70eaf8812 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -3880,7 +3880,6 @@ lookup_uop_fuzzy (const char *op, gfc_symtree *uop) + return gfc_closest_fuzzy_match (op, candidates); + } + +- + /* Callback finding an impure function as an operand to an .and. or + .or. expression. Remember the last function warned about to + avoid double warnings when recursing. */ +@@ -3940,6 +3939,22 @@ convert_hollerith_to_character (gfc_expr *e) + } + } + ++/* 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); ++ } ++} ++ + /* Convert to numeric and issue a warning for the conversion. */ + + static void +@@ -3952,6 +3967,22 @@ convert_to_numeric (gfc_expr *a, gfc_expr *b) + gfc_convert_type_warn (a, &t, 2, 1); + } + ++/* 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. */ + +@@ -4037,6 +4068,12 @@ resolve_operator (gfc_expr *e) + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: ++ if (flag_logical_as_integer) ++ { ++ convert_logical_to_integer (op1); ++ convert_logical_to_integer (op2); ++ } ++ + if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) + { + gfc_type_convert_binary (e, 1); +@@ -4073,6 +4110,13 @@ resolve_operator (gfc_expr *e) + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: ++ ++ if (flag_logical_as_integer) ++ { ++ 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; +@@ -4123,6 +4167,9 @@ resolve_operator (gfc_expr *e) + goto simplify_op; + } + ++ if (flag_logical_as_integer) ++ convert_integer_to_logical (op1); ++ + if (op1->ts.type == BT_LOGICAL) + { + e->ts.type = BT_LOGICAL; +@@ -4163,6 +4210,12 @@ resolve_operator (gfc_expr *e) + convert_hollerith_to_character (op2); + } + ++ if (flag_logical_as_integer) ++ { ++ convert_logical_to_integer (op1); ++ convert_logical_to_integer (op2); ++ } ++ + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER + && op1->ts.kind == op2->ts.kind) + { +diff --git a/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f +new file mode 100644 +index 00000000000..938a91d9e9a +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f +@@ -0,0 +1,31 @@ ++! { dg-do run } ++! { dg-options "-std=legacy -flogical-as-integer" } ++! ++! Test conversion between logical and integer for logical operators ++! ++! Test case contributed by Jim MacArthur ++! Modified for -flogical-as-integer by Mark Eggleston ++! ++! ++ 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/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f +new file mode 100644 +index 00000000000..9f146202ba5 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f +@@ -0,0 +1,31 @@ ++! { dg-do compile } ++! { dg-options "-std=legacy -flogical-as-integer -fno-logical-as-integer" } ++! ++! Based on logical_to_integer_and_vice_versa_1.f but with option disabled ++! to test for error messages. ++! ++! Test case contributed by by Mark Eggleston ++! ++! ++ 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 ! { dg-error "Operands of logical operator" } ++ if ((ineg.AND.lpos).NE.0) STOP 4 ! { dg-error "Operands of logical operator" } ++ ires = (.true..AND.0) ! { dg-error "Operands of logical operator" } ++ if (ires.NE.0) STOP 5 ++ ires = (1.AND..false.) ! { dg-error "Operands of logical operator" } ++ if (ires.EQ.1) STOP 6 ++ ++ ! Test Integers converted to Logicals ++ if (lpos.EQ.ineg) STOP 7 ! { dg-error "Operands of comparison operator" } ++ if (ineg.EQ.lpos) STOP 8 ! { dg-error "Operands of comparison operator" } ++ lres = (.true..EQ.0) ! { dg-error "Operands of comparison operator" } ++ if (lres) STOP 9 ++ lres = (1.EQ..false.) ! { dg-error "Operands of comparison operator" } ++ if (lres) STOP 10 ++ END +diff --git a/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f +new file mode 100644 +index 00000000000..446873eb2dc +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f +@@ -0,0 +1,33 @@ ++! { dg-do compile } ++! { dg-options "-std=legacy -flogical-as-integer" } ++! ++! Test conversion between logical and integer for logical operators ++! ++ program test ++ logical f /.false./ ++ logical t /.true./ ++ real x ++ ++ x = 7.7 ++ x = x + t*3.0 ++ if (abs(x - 10.7).gt.0.00001) stop 1 ++ x = x + .false.*5.0 ++ if (abs(x - 10.7).gt.0.00001) stop 2 ++ x = x - .true.*5.0 ++ if (abs(x - 5.7).gt.0.00001) stop 3 ++ x = x + t ++ if (abs(x - 6.7).gt.0.00001) stop 4 ++ x = x + f ++ if (abs(x - 6.7).gt.0.00001) stop 5 ++ x = x - t ++ if (abs(x - 5.7).gt.0.00001) stop 6 ++ x = x - f ++ if (abs(x - 5.7).gt.0.00001) stop 7 ++ x = x**.true. ++ if (abs(x - 5.7).gt.0.00001) stop 8 ++ x = x**.false. ++ if (abs(x - 1.0).gt.0.00001) stop 9 ++ x = x/t ++ if (abs(x - 1.0).gt.0.00001) stop 10 ++ if ((x/.false.).le.huge(x)) stop 11 ++ end +diff --git a/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f +new file mode 100644 +index 00000000000..4301a4988d8 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f +@@ -0,0 +1,33 @@ ++! { dg-do compile } ++! { dg-options "-std=legacy -flogical-as-integer -fno-logical-as-integer" } ++! ++! Test conversion between logical and integer for logical operators ++! ++ program test ++ logical f /.false./ ++ logical t /.true./ ++ real x ++ ++ x = 7.7 ++ x = x + t*3.0 ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 10.7).gt.0.00001) stop 1 ++ x = x + .false.*5.0 ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 10.7).gt.0.00001) stop 2 ++ x = x - .true.*5.0 ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 5.7).gt.0.00001) stop 3 ++ x = x + t ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 6.7).gt.0.00001) stop 4 ++ x = x + f ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 6.7).gt.0.00001) stop 5 ++ x = x - t ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 5.7).gt.0.00001) stop 6 ++ x = x - f ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 5.7).gt.0.00001) stop 7 ++ x = x**.true. ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 5.7).gt.0.00001) stop 8 ++ x = x**.false. ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 1.0).gt.0.00001) stop 9 ++ x = x/t ! { dg-error "Operands of binary numeric" } ++ if (abs(x - 1.0).gt.0.00001) stop 10 ++ if ((x/.false.).le.huge(x)) stop 11 ! { dg-error "Operands of binary numeric" } ++ end +-- +2.11.0 + diff --git a/SOURCES/0003-Allow-more-than-one-character-as-argument-to-ICHAR.patch b/SOURCES/0003-Allow-more-than-one-character-as-argument-to-ICHAR.patch new file mode 100644 index 0000000..cebc5eb --- /dev/null +++ b/SOURCES/0003-Allow-more-than-one-character-as-argument-to-ICHAR.patch @@ -0,0 +1,78 @@ +From 2de74ecd251387201ab78f614e73f67c8ad89033 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 08:52:58 +0000 +Subject: [PATCH 03/10] Allow more than one character as argument to ICHAR + +Use -fdec to enable. +--- + gcc/fortran/check.c | 2 +- + gcc/fortran/simplify.c | 4 ++-- + gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f | 21 +++++++++++++++++++++ + 3 files changed, 24 insertions(+), 3 deletions(-) + create mode 100644 gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f + +diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c +index 148a3269815..4c0b83e8e6f 100644 +--- a/gcc/fortran/check.c ++++ b/gcc/fortran/check.c +@@ -3154,7 +3154,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) + else + return true; + +- if (i != 1) ++ if (i != 1 && !flag_dec) + { + 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 eb8b2afeb29..248fe05ee48 100644 +--- a/gcc/fortran/simplify.c ++++ b/gcc/fortran/simplify.c +@@ -3229,7 +3229,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 && !flag_dec) + { + gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; +@@ -3427,7 +3427,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 && !flag_dec) + { + 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_1.f b/gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f +new file mode 100644 +index 00000000000..85efccecc0f +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f +@@ -0,0 +1,21 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test ICHAR and IACHAR with more than one character as argument ++! ++! Test case contributed by Jim MacArthur ++! Modified by Mark Eggleston ++! ++ 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 +-- +2.11.0 + diff --git a/SOURCES/0003-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch b/SOURCES/0003-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch deleted file mode 100644 index abec1ac..0000000 --- a/SOURCES/0003-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch +++ /dev/null @@ -1,298 +0,0 @@ -From 6a3faecd0b1eed41e865bdab721cc3a60492845d Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Wed, 7 Oct 2015 16:31:18 -0400 -Subject: [PATCH 03/16] 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 -flogical-as-integer flag. - -Note: using this feature will disable bitwise logical operations enabled by --fdec. ---- - gcc/fortran/lang.opt | 4 ++ - gcc/fortran/resolve.c | 55 +++++++++++++++++++++- - .../logical_to_integer_and_vice_versa_1.f | 31 ++++++++++++ - .../logical_to_integer_and_vice_versa_2.f | 31 ++++++++++++ - .../logical_to_integer_and_vice_versa_3.f | 33 +++++++++++++ - .../logical_to_integer_and_vice_versa_4.f | 33 +++++++++++++ - 6 files changed, 186 insertions(+), 1 deletion(-) - create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f - create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f - create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f - create mode 100644 gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f - -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 491d81ccaa5..13a8e9778bb 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -468,6 +468,10 @@ fdec-static - Fortran Var(flag_dec_static) - Enable DEC-style STATIC and AUTOMATIC attributes. - -+flogical-as-integer -+Fortran Var(flag_logical_as_integer) -+Convert from integer to logical or logical to integer for arithmetic operations. -+ - fdefault-double-8 - Fortran Var(flag_default_double) - Set the default double precision kind to an 8 byte wide type. -diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c -index 8232deb8170..32b8d504ff6 100644 ---- a/gcc/fortran/resolve.c -+++ b/gcc/fortran/resolve.c -@@ -3838,7 +3838,6 @@ lookup_uop_fuzzy (const char *op, gfc_symtree *uop) - return gfc_closest_fuzzy_match (op, candidates); - } - -- - /* Callback finding an impure function as an operand to an .and. or - .or. expression. Remember the last function warned about to - avoid double warnings when recursing. */ -@@ -3873,6 +3872,37 @@ impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, - return 0; - } - -+/* 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. */ -+ -+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. */ -@@ -3938,6 +3968,12 @@ resolve_operator (gfc_expr *e) - case INTRINSIC_TIMES: - case INTRINSIC_DIVIDE: - case INTRINSIC_POWER: -+ if (flag_logical_as_integer) -+ { -+ convert_logical_to_integer (op1); -+ convert_logical_to_integer (op2); -+ } -+ - if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) - { - gfc_type_convert_binary (e, 1); -@@ -3974,6 +4010,13 @@ resolve_operator (gfc_expr *e) - case INTRINSIC_OR: - case INTRINSIC_EQV: - case INTRINSIC_NEQV: -+ -+ if (flag_logical_as_integer) -+ { -+ 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; -@@ -4024,6 +4067,9 @@ resolve_operator (gfc_expr *e) - goto simplify_op; - } - -+ if (flag_logical_as_integer) -+ convert_integer_to_logical (op1); -+ - if (op1->ts.type == BT_LOGICAL) - { - e->ts.type = BT_LOGICAL; -@@ -4055,6 +4101,13 @@ resolve_operator (gfc_expr *e) - case INTRINSIC_EQ_OS: - case INTRINSIC_NE: - case INTRINSIC_NE_OS: -+ -+ if (flag_logical_as_integer) -+ { -+ convert_logical_to_integer (op1); -+ convert_logical_to_integer (op2); -+ } -+ - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER - && op1->ts.kind == op2->ts.kind) - { -diff --git a/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f -new file mode 100644 -index 00000000000..938a91d9e9a ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_1.f -@@ -0,0 +1,31 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -flogical-as-integer" } -+! -+! Test conversion between logical and integer for logical operators -+! -+! Test case contributed by Jim MacArthur -+! Modified for -flogical-as-integer by Mark Eggleston -+! -+! -+ 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/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f -new file mode 100644 -index 00000000000..9f146202ba5 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_2.f -@@ -0,0 +1,31 @@ -+! { dg-do compile } -+! { dg-options "-std=legacy -flogical-as-integer -fno-logical-as-integer" } -+! -+! Based on logical_to_integer_and_vice_versa_1.f but with option disabled -+! to test for error messages. -+! -+! Test case contributed by by Mark Eggleston -+! -+! -+ 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 ! { dg-error "Operands of logical operator" } -+ if ((ineg.AND.lpos).NE.0) STOP 4 ! { dg-error "Operands of logical operator" } -+ ires = (.true..AND.0) ! { dg-error "Operands of logical operator" } -+ if (ires.NE.0) STOP 5 -+ ires = (1.AND..false.) ! { dg-error "Operands of logical operator" } -+ if (ires.EQ.1) STOP 6 -+ -+ ! Test Integers converted to Logicals -+ if (lpos.EQ.ineg) STOP 7 ! { dg-error "Operands of comparison operator" } -+ if (ineg.EQ.lpos) STOP 8 ! { dg-error "Operands of comparison operator" } -+ lres = (.true..EQ.0) ! { dg-error "Operands of comparison operator" } -+ if (lres) STOP 9 -+ lres = (1.EQ..false.) ! { dg-error "Operands of comparison operator" } -+ if (lres) STOP 10 -+ END -diff --git a/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f -new file mode 100644 -index 00000000000..446873eb2dc ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_3.f -@@ -0,0 +1,33 @@ -+! { dg-do compile } -+! { dg-options "-std=legacy -flogical-as-integer" } -+! -+! Test conversion between logical and integer for logical operators -+! -+ program test -+ logical f /.false./ -+ logical t /.true./ -+ real x -+ -+ x = 7.7 -+ x = x + t*3.0 -+ if (abs(x - 10.7).gt.0.00001) stop 1 -+ x = x + .false.*5.0 -+ if (abs(x - 10.7).gt.0.00001) stop 2 -+ x = x - .true.*5.0 -+ if (abs(x - 5.7).gt.0.00001) stop 3 -+ x = x + t -+ if (abs(x - 6.7).gt.0.00001) stop 4 -+ x = x + f -+ if (abs(x - 6.7).gt.0.00001) stop 5 -+ x = x - t -+ if (abs(x - 5.7).gt.0.00001) stop 6 -+ x = x - f -+ if (abs(x - 5.7).gt.0.00001) stop 7 -+ x = x**.true. -+ if (abs(x - 5.7).gt.0.00001) stop 8 -+ x = x**.false. -+ if (abs(x - 1.0).gt.0.00001) stop 9 -+ x = x/t -+ if (abs(x - 1.0).gt.0.00001) stop 10 -+ if ((x/.false.).le.huge(x)) stop 11 -+ end -diff --git a/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f -new file mode 100644 -index 00000000000..4301a4988d8 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/logical_to_integer_and_vice_versa_4.f -@@ -0,0 +1,33 @@ -+! { dg-do compile } -+! { dg-options "-std=legacy -flogical-as-integer -fno-logical-as-integer" } -+! -+! Test conversion between logical and integer for logical operators -+! -+ program test -+ logical f /.false./ -+ logical t /.true./ -+ real x -+ -+ x = 7.7 -+ x = x + t*3.0 ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 10.7).gt.0.00001) stop 1 -+ x = x + .false.*5.0 ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 10.7).gt.0.00001) stop 2 -+ x = x - .true.*5.0 ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 5.7).gt.0.00001) stop 3 -+ x = x + t ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 6.7).gt.0.00001) stop 4 -+ x = x + f ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 6.7).gt.0.00001) stop 5 -+ x = x - t ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 5.7).gt.0.00001) stop 6 -+ x = x - f ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 5.7).gt.0.00001) stop 7 -+ x = x**.true. ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 5.7).gt.0.00001) stop 8 -+ x = x**.false. ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 1.0).gt.0.00001) stop 9 -+ x = x/t ! { dg-error "Operands of binary numeric" } -+ if (abs(x - 1.0).gt.0.00001) stop 10 -+ if ((x/.false.).le.huge(x)) stop 11 ! { dg-error "Operands of binary numeric" } -+ end --- -2.11.0 - diff --git a/SOURCES/0004-Allow-CHARACTER-literals-in-assignments-and-data-sta.patch b/SOURCES/0004-Allow-CHARACTER-literals-in-assignments-and-data-sta.patch deleted file mode 100644 index 66a63b7..0000000 --- a/SOURCES/0004-Allow-CHARACTER-literals-in-assignments-and-data-sta.patch +++ /dev/null @@ -1,860 +0,0 @@ -From c1d6c81730ffda61eff8fccf4d0c7efa3ae6fd8d Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Thu, 4 Feb 2016 17:18:30 +0000 -Subject: [PATCH 04/16] Allow CHARACTER literals in assignments and data - statements - -Warnings are raised when this happens. - -Enable using -fdec-char-as-int or -fdec ---- - gcc/fortran/arith.c | 96 +++++++++++++++++++++- - gcc/fortran/arith.h | 4 + - gcc/fortran/expr.c | 5 ++ - gcc/fortran/intrinsic.c | 32 +++++++- - gcc/fortran/lang.opt | 5 ++ - gcc/fortran/options.c | 1 + - gcc/fortran/resolve.c | 11 ++- - gcc/fortran/simplify.c | 29 ++++++- - gcc/fortran/trans-const.c | 3 +- - .../dec_char_conversion_in_assignment_1.f90 | 61 ++++++++++++++ - .../dec_char_conversion_in_assignment_2.f90 | 61 ++++++++++++++ - .../dec_char_conversion_in_assignment_3.f90 | 61 ++++++++++++++ - .../gfortran.dg/dec_char_conversion_in_data_1.f90 | 69 ++++++++++++++++ - .../gfortran.dg/dec_char_conversion_in_data_2.f90 | 69 ++++++++++++++++ - .../gfortran.dg/dec_char_conversion_in_data_3.f90 | 69 ++++++++++++++++ - gcc/testsuite/gfortran.dg/hollerith5.f90 | 5 +- - gcc/testsuite/gfortran.dg/hollerith_legacy.f90 | 2 +- - .../gfortran.dg/no_char_to_int_assign.f90 | 20 +++++ - 18 files changed, 589 insertions(+), 14 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/no_char_to_int_assign.f90 - -diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c -index f2d311c044c..7e6d6dd3bb8 100644 ---- a/gcc/fortran/arith.c -+++ b/gcc/fortran/arith.c -@@ -2553,11 +2553,11 @@ hollerith2representation (gfc_expr *result, gfc_expr *src) - src_len = src->representation.length - src->ts.u.pad; - gfc_target_expr_size (result, &result_len); - -- if (src_len > result_len) -+ if (src_len > result_len && warn_character_truncation) - { -- gfc_warning (0, -- "The Hollerith constant at %L is too long to convert to %qs", -- &src->where, gfc_typename(&result->ts)); -+ gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L " -+ "is truncated in conversion to %qs", &src->where, -+ gfc_typename(&result->ts)); - } - - result->representation.string = XCNEWVEC (char, result_len + 1); -@@ -2572,6 +2572,36 @@ hollerith2representation (gfc_expr *result, gfc_expr *src) - } - - -+/* Helper function to set the representation in a character conversion. -+ This assumes that the ts.type and ts.kind of the result have already -+ been set. */ -+ -+static void -+character2representation (gfc_expr *result, gfc_expr *src) -+{ -+ size_t src_len, result_len; -+ int i; -+ src_len = src->value.character.length; -+ gfc_target_expr_size (result, &result_len); -+ -+ if (src_len > result_len && warn_character_truncation) -+ gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is " -+ "is truncated in conversion to %s", &src->where, -+ gfc_typename(&result->ts)); -+ -+ result->representation.string = XCNEWVEC (char, result_len + 1); -+ -+ for (i = 0; i < MIN (result_len, src_len); i++) -+ result->representation.string[i] = (char) src->value.character.string[i]; -+ -+ if (src_len < result_len) -+ memset (&result->representation.string[src_len], ' ', -+ result_len - src_len); -+ -+ result->representation.string[result_len] = '\0'; /* For debugger */ -+ result->representation.length = result_len; -+} -+ - /* Convert Hollerith to integer. The constant will be padded or truncated. */ - - gfc_expr * -@@ -2587,6 +2617,19 @@ gfc_hollerith2int (gfc_expr *src, int kind) - return result; - } - -+/* Convert character to integer. The constant will be padded or truncated. */ -+ -+gfc_expr * -+gfc_character2int (gfc_expr *src, int kind) -+{ -+ gfc_expr *result; -+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where); -+ -+ character2representation (result, src); -+ gfc_interpret_integer (kind, (unsigned char *) result->representation.string, -+ result->representation.length, result->value.integer); -+ return result; -+} - - /* Convert Hollerith to real. The constant will be padded or truncated. */ - -@@ -2603,6 +2646,21 @@ gfc_hollerith2real (gfc_expr *src, int kind) - return result; - } - -+/* Convert character to real. The constant will be padded or truncated. */ -+ -+gfc_expr * -+gfc_character2real (gfc_expr *src, int kind) -+{ -+ gfc_expr *result; -+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where); -+ -+ character2representation (result, src); -+ gfc_interpret_float (kind, (unsigned char *) result->representation.string, -+ result->representation.length, result->value.real); -+ -+ return result; -+} -+ - - /* Convert Hollerith to complex. The constant will be padded or truncated. */ - -@@ -2619,6 +2677,21 @@ gfc_hollerith2complex (gfc_expr *src, int kind) - return result; - } - -+/* Convert character to complex. The constant will be padded or truncated. */ -+ -+gfc_expr * -+gfc_character2complex (gfc_expr *src, int kind) -+{ -+ gfc_expr *result; -+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where); -+ -+ character2representation (result, src); -+ gfc_interpret_complex (kind, (unsigned char *) result->representation.string, -+ result->representation.length, result->value.complex); -+ -+ return result; -+} -+ - - /* Convert Hollerith to character. */ - -@@ -2654,3 +2727,18 @@ gfc_hollerith2logical (gfc_expr *src, int kind) - - return result; - } -+ -+/* Convert character to logical. The constant will be padded or truncated. */ -+ -+gfc_expr * -+gfc_character2logical (gfc_expr *src, int kind) -+{ -+ gfc_expr *result; -+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where); -+ -+ character2representation (result, src); -+ gfc_interpret_logical (kind, (unsigned char *) result->representation.string, -+ result->representation.length, &result->value.logical); -+ -+ return result; -+} -diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h -index e06c7059885..13ffd8d0b6c 100644 ---- a/gcc/fortran/arith.h -+++ b/gcc/fortran/arith.h -@@ -82,7 +82,11 @@ gfc_expr *gfc_hollerith2real (gfc_expr *, int); - gfc_expr *gfc_hollerith2complex (gfc_expr *, int); - gfc_expr *gfc_hollerith2character (gfc_expr *, int); - gfc_expr *gfc_hollerith2logical (gfc_expr *, int); -+gfc_expr *gfc_character2int (gfc_expr *, int); -+gfc_expr *gfc_character2real (gfc_expr *, int); -+gfc_expr *gfc_character2complex (gfc_expr *, int); - gfc_expr *gfc_character2character (gfc_expr *, int); -+gfc_expr *gfc_character2logical (gfc_expr *, int); - - #endif /* GFC_ARITH_H */ - -diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c -index 474e9ecc401..77600a5f2e8 100644 ---- a/gcc/fortran/expr.c -+++ b/gcc/fortran/expr.c -@@ -3695,6 +3695,11 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform, - || rvalue->ts.type == BT_HOLLERITH) - return true; - -+ if (flag_dec_char_conversions && (gfc_numeric_ts (&lvalue->ts) -+ || lvalue->ts.type == BT_LOGICAL) -+ && rvalue->ts.type == BT_CHARACTER) -+ return true; -+ - if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL) - return true; - -diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c -index c21fbddd5fb..e94d5d3225f 100644 ---- a/gcc/fortran/intrinsic.c -+++ b/gcc/fortran/intrinsic.c -@@ -4017,6 +4017,28 @@ add_conversions (void) - add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind, - BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); - } -+ -+ /* Flang allows character conversions similar to Hollerith conversions -+ - the first characters will be turned into ascii values. */ -+ if (flag_dec_char_conversions) -+ { -+ /* Character-Integer conversions. */ -+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++) -+ add_conv (BT_CHARACTER, gfc_default_character_kind, -+ BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); -+ /* Character-Real conversions. */ -+ for (i = 0; gfc_real_kinds[i].kind != 0; i++) -+ add_conv (BT_CHARACTER, gfc_default_character_kind, -+ BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); -+ /* Character-Complex conversions. */ -+ for (i = 0; gfc_real_kinds[i].kind != 0; i++) -+ add_conv (BT_CHARACTER, gfc_default_character_kind, -+ BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); -+ /* Character-Logical conversions. */ -+ for (i = 0; gfc_logical_kinds[i].kind != 0; i++) -+ add_conv (BT_CHARACTER, gfc_default_character_kind, -+ BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); -+ } - } - - -@@ -5128,8 +5150,16 @@ 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 (flag_dec_char_conversions && from_ts.type == BT_CHARACTER -+ && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) -+ { -+ if (warn_conversion) -+ gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L", -+ gfc_typename (&from_ts), gfc_typename (ts), -+ &expr->where); -+ } - else -- gcc_unreachable (); -+ gcc_unreachable (); - } - - /* Insert a pre-resolved function call to the right function. */ -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 13a8e9778bb..5746b99b1d4 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -444,6 +444,11 @@ fdec-duplicates - Fortran Var(flag_dec_duplicates) - Allow varibles to be duplicated in the type specification matches. - -+fdec-char-conversions -+Fortran Var(flag_dec_char_conversions) -+Enable the use of character literals in assignments and data statements -+for non-character variables. -+ - fdec-include - Fortran Var(flag_dec_include) - Enable legacy parsing of INCLUDE as statement. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index f93db8b6d7c..e97b1568810 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -76,6 +76,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_include, value, value); - SET_BITFLAG (flag_dec_format_defaults, value, value); - SET_BITFLAG (flag_dec_duplicates, value, value); -+ SET_BITFLAG (flag_dec_char_conversions, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c -index 32b8d504ff6..43559185481 100644 ---- a/gcc/fortran/resolve.c -+++ b/gcc/fortran/resolve.c -@@ -4320,7 +4320,6 @@ bad_op: - return false; - } - -- - /************** Array resolution subroutines **************/ - - enum compare_result -@@ -10498,6 +10497,16 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) - lhs = code->expr1; - rhs = code->expr2; - -+ if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) -+ && rhs->ts.type == BT_CHARACTER -+ && rhs->expr_type != EXPR_CONSTANT) -+ { -+ gfc_error ("Cannot convert CHARACTER into %s at %L", -+ gfc_typename (&lhs->ts), -+ &rhs->where); -+ return false; -+ } -+ - if (rhs->is_boz - && !gfc_notify_std (GFC_STD_GNU, "BOZ literal at %L outside " - "a DATA statement and outside INT/REAL/DBLE/CMPLX", -diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c -index 6c1f4bd4fce..7d7e3f22f73 100644 ---- a/gcc/fortran/simplify.c -+++ b/gcc/fortran/simplify.c -@@ -8457,10 +8457,31 @@ gfc_convert_constant (gfc_expr *e, bt type, int kind) - break; - - case BT_CHARACTER: -- if (type == BT_CHARACTER) -- f = gfc_character2character; -- else -- goto oops; -+ switch (type) -+ { -+ case BT_INTEGER: -+ f = gfc_character2int; -+ break; -+ -+ case BT_REAL: -+ f = gfc_character2real; -+ break; -+ -+ case BT_COMPLEX: -+ f = gfc_character2complex; -+ break; -+ -+ case BT_CHARACTER: -+ f = gfc_character2character; -+ break; -+ -+ case BT_LOGICAL: -+ f = gfc_character2logical; -+ break; -+ -+ default: -+ goto oops; -+ } - break; - - default: -diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c -index 432d12bf168..b155e35cbdd 100644 ---- a/gcc/fortran/trans-const.c -+++ b/gcc/fortran/trans-const.c -@@ -25,6 +25,7 @@ along with GCC; see the file COPYING3. If not see - #include "coretypes.h" - #include "tree.h" - #include "gfortran.h" -+#include "options.h" - #include "trans.h" - #include "fold-const.h" - #include "stor-layout.h" -@@ -330,7 +331,7 @@ gfc_conv_constant_to_tree (gfc_expr * expr) - gfc_get_int_type (expr->ts.kind), - gfc_build_string_const (expr->representation.length, - expr->representation.string)); -- if (!integer_zerop (tmp) && !integer_onep (tmp)) -+ if (!integer_zerop (tmp) && !integer_onep (tmp) && warn_surprising) - gfc_warning (0, "Assigning value other than 0 or 1 to LOGICAL" - " has undefined result at %L", &expr->where); - return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp); -diff --git a/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_1.f90 b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_1.f90 -new file mode 100644 -index 00000000000..d504f92fbbc ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_1.f90 -@@ -0,0 +1,61 @@ -+! { dg-do run } -+! { dg-options "-fdec -Wsurprising -Wcharacter-truncation" } -+! -+! Modified by Mark Eggleston -+! -+program test -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ a = '1234' -+ b = '1234' -+ c = '12341234' -+ d = '1234' ! { dg-warning "undefined result" } -+ e = 4h1234 -+ f = 4h1234 -+ g = 8h12341234 -+ h = 4h1234 ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 1 -+ if (b.ne.f) stop 2 -+ if (c.ne.g) stop 3 -+ if (d.neqv.h) stop 4 -+ -+ ! padded values -+ a = '12' -+ b = '12' -+ c = '12234' -+ d = '124' ! { dg-warning "undefined result" } -+ e = 2h12 -+ f = 2h12 -+ g = 5h12234 -+ h = 3h123 ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+ -+ ! truncated values -+ a = '123478' ! { dg-warning "truncated in" } -+ b = '123478' ! { dg-warning "truncated in" } -+ c = '12341234987' ! { dg-warning "truncated in" } -+ d = '1234abc' ! { dg-warning "truncated in|undefined result" } -+ e = 6h123478 ! { dg-warning "truncated in" } -+ f = 6h123478 ! { dg-warning "truncated in" } -+ g = 11h12341234987 ! { dg-warning "truncated in" } -+ h = 7h1234abc ! { dg-warning "truncated in|undefined result" } -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+ -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_2.f90 b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_2.f90 -new file mode 100644 -index 00000000000..737ddc664de ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_2.f90 -@@ -0,0 +1,61 @@ -+! { dg-do run } -+! { dg-options "-fdec-char-conversions -std=legacy -Wcharacter-truncation -Wsurprising" } -+! -+! Modified by Mark Eggleston -+! -+program test -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ a = '1234' -+ b = '1234' -+ c = '12341234' -+ d = '1234' ! { dg-warning "undefined result" } -+ e = 4h1234 -+ f = 4h1234 -+ g = 8h12341234 -+ h = 4h1234 ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 1 -+ if (b.ne.f) stop 2 -+ if (c.ne.g) stop 3 -+ if (d.neqv.h) stop 4 -+ -+ ! padded values -+ a = '12' -+ b = '12' -+ c = '12234' -+ d = '124' ! { dg-warning "undefined result" } -+ e = 2h12 -+ f = 2h12 -+ g = 5h12234 -+ h = 3h123 ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+ -+ ! truncated values -+ a = '123478' ! { dg-warning "truncated in" } -+ b = '123478' ! { dg-warning "truncated in" } -+ c = '12341234987' ! { dg-warning "truncated in" } -+ d = '1234abc' ! { dg-warning "truncated in|undefined result" } -+ e = 6h123478 ! { dg-warning "truncated in" } -+ f = 6h123478 ! { dg-warning "truncated in" } -+ g = 11h12341234987 ! { dg-warning "truncated in" } -+ h = 7h1234abc ! { dg-warning "truncated in|undefined result" } -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+ -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_3.f90 b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_3.f90 -new file mode 100644 -index 00000000000..0ec494c4a92 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_assignment_3.f90 -@@ -0,0 +1,61 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-char-conversions" } -+! -+! Modified by Mark Eggleston -+! -+program test -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ a = '1234' ! { dg-error "Cannot convert" } -+ b = '1234' ! { dg-error "Cannot convert" } -+ c = '12341234' ! { dg-error "Cannot convert" } -+ d = '1234' ! { dg-error "Cannot convert" } -+ e = 4h1234 -+ f = 4h1234 -+ g = 8h12341234 -+ h = 4h1234 -+ -+ if (a.ne.e) stop 1 -+ if (b.ne.f) stop 2 -+ if (c.ne.g) stop 3 -+ if (d.neqv.h) stop 4 -+ -+ ! padded values -+ a = '12' ! { dg-error "Cannot convert" } -+ b = '12' ! { dg-error "Cannot convert" } -+ c = '12234' ! { dg-error "Cannot convert" } -+ d = '124' ! { dg-error "Cannot convert" } -+ e = 2h12 -+ f = 2h12 -+ g = 5h12234 -+ h = 3h123 -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+ -+ ! truncated values -+ a = '123478' ! { dg-error "Cannot convert" } -+ b = '123478' ! { dg-error "Cannot convert" } -+ c = '12341234987' ! { dg-error "Cannot convert" } -+ d = '1234abc' ! { dg-error "Cannot convert" } -+ e = 6h123478 ! -+ f = 6h123478 ! -+ g = 11h12341234987 ! -+ h = 7h1234abc ! -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+ -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_1.f90 b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_1.f90 -new file mode 100644 -index 00000000000..c493be9314b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_1.f90 -@@ -0,0 +1,69 @@ -+! { dg-do run } -+! { dg-options "-fdec -Wsurprising" } -+! -+! Modified by Mark Eggleston -+! -+ -+subroutine normal -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '1234', '1234', '12341234', '1234' / ! { dg-warning "undefined result" } -+ data e, f, g, h / 4h1234, 4h1234, 8h12341234, 4h1234 / ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 1 -+ if (b.ne.f) stop 2 -+ if (c.ne.g) stop 3 -+ if (d.neqv.h) stop 4 -+end subroutine -+ -+subroutine padded -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '12', '12', '12334', '123' / ! { dg-warning "undefined result" } -+ data e, f, g, h / 2h12, 2h12, 5h12334, 3h123 / ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+end subroutine -+ -+subroutine truncated -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '123478', '123478', '1234123498', '12345' / ! { dg-warning "too long|undefined result" } -+ data e, f, g, h / 6h123478, 6h123478, 10h1234123498, 5h12345 / ! { dg-warning "too long|undefined result" } -+ -+ if (a.ne.e) stop 9 -+ if (b.ne.f) stop 10 -+ if (c.ne.g) stop 11 -+ if (d.neqv.h) stop 12 -+end subroutine -+ -+program test -+ call normal -+ call padded -+ call truncated -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_2.f90 b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_2.f90 -new file mode 100644 -index 00000000000..c7d8e241cec ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_2.f90 -@@ -0,0 +1,69 @@ -+! { dg-do run } -+! { dg-options "-fdec-char-conversions -std=legacy -Wsurprising" } -+! -+! Modified by Mark Eggleston -+! -+ -+subroutine normal -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '1234', '1234', '12341234', '1234' / ! { dg-warning "undefined result" } -+ data e, f, g, h / 4h1234, 4h1234, 8h12341234, 4h1234 / ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 1 -+ if (b.ne.f) stop 2 -+ if (c.ne.g) stop 3 -+ if (d.neqv.h) stop 4 -+end subroutine -+ -+subroutine padded -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '12', '12', '12334', '123' / ! { dg-warning "undefined result" } -+ data e, f, g, h / 2h12, 2h12, 5h12334, 3h123 / ! { dg-warning "undefined result" } -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+end subroutine -+ -+subroutine truncated -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '123478', '123478', '1234123498', '12345' / ! { dg-warning "too long|undefined result" } -+ data e, f, g, h / 6h123478, 6h123478, 10h1234123498, 5h12345 / ! { dg-warning "too long|undefined result" } -+ -+ if (a.ne.e) stop 9 -+ if (b.ne.f) stop 10 -+ if (c.ne.g) stop 11 -+ if (d.neqv.h) stop 12 -+end subroutine -+ -+program test -+ call normal -+ call padded -+ call truncated -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_3.f90 b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_3.f90 -new file mode 100644 -index 00000000000..e7d084b5ffc ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_char_conversion_in_data_3.f90 -@@ -0,0 +1,69 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-char-conversions" } -+! -+! Modified by Mark Eggleston -+! -+ -+subroutine normal -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '1234', '1234', '12341234', '1234' / ! { dg-error "Incompatible types" } -+ data e, f, g, h / 4h1234, 4h1234, 8h12341234, 4h1234 / -+ -+ if (a.ne.e) stop 1 -+ if (b.ne.f) stop 2 -+ if (c.ne.g) stop 3 -+ if (d.neqv.h) stop 4 -+end subroutine -+ -+subroutine padded -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '12', '12', '12334', '123' / ! { dg-error "Incompatible types" } -+ data e, f, g, h / 2h12, 2h12, 5h12334, 3h123 / -+ -+ if (a.ne.e) stop 5 -+ if (b.ne.f) stop 6 -+ if (c.ne.g) stop 7 -+ if (d.neqv.h) stop 8 -+end subroutine -+ -+subroutine truncated -+ integer(4) :: a -+ real(4) :: b -+ complex(4) :: c -+ logical(4) :: d -+ integer(4) :: e -+ real(4) :: f -+ complex(4) :: g -+ logical(4) :: h -+ -+ data a, b, c, d / '123478', '123478', '1234123498', '12345' / ! { dg-error "Incompatible types" } -+ data e, f, g, h / 6h123478, 6h123478, 10h1234123498, 5h12345 / -+ -+ if (a.ne.e) stop 9 -+ if (b.ne.f) stop 10 -+ if (c.ne.g) stop 11 -+ if (d.neqv.h) stop 12 -+end subroutine -+ -+program test -+ call normal -+ call padded -+ call truncated -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/hollerith5.f90 b/gcc/testsuite/gfortran.dg/hollerith5.f90 -index ebd0a117c4f..d17f9ae40cf 100644 ---- a/gcc/testsuite/gfortran.dg/hollerith5.f90 -+++ b/gcc/testsuite/gfortran.dg/hollerith5.f90 -@@ -1,8 +1,9 @@ - ! { dg-do compile } -+ ! { dg-options "-Wsurprising" } - implicit none - logical b - b = 4Habcd ! { dg-warning "has undefined result" } - end - --! { dg-warning "Hollerith constant" "const" { target *-*-* } 4 } --! { dg-warning "Conversion" "conversion" { target *-*-* } 4 } -+! { dg-warning "Hollerith constant" "const" { target *-*-* } 5 } -+! { dg-warning "Conversion" "conversion" { target *-*-* } 5 } -diff --git a/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 b/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 -index c3322498345..9d7e989b552 100644 ---- a/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 -+++ b/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 -@@ -1,5 +1,5 @@ - ! { dg-do compile } --! { dg-options "-std=legacy" } -+! { dg-options "-std=legacy -Wsurprising" } - ! PR15966, PR18781 & PR16531 - implicit none - complex(kind=8) x(2) -diff --git a/gcc/testsuite/gfortran.dg/no_char_to_int_assign.f90 b/gcc/testsuite/gfortran.dg/no_char_to_int_assign.f90 -new file mode 100644 -index 00000000000..ccfcc9ae512 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/no_char_to_int_assign.f90 -@@ -0,0 +1,20 @@ -+! { dg-do compile } -+! { dg-options "-fdec-char-conversions" } -+! -+! Test character to int conversion in DATA types -+! -+! Test case contributed by Mark Eggleston -+! -+program test -+ integer a -+ real b -+ complex c -+ logical d -+ character e -+ -+ e = "A" -+ a = e ! { dg-error "Cannot convert" } -+ b = e ! { dg-error "Cannot convert" } -+ c = e ! { dg-error "Cannot convert" } -+ d = e ! { dg-error "Cannot convert" } -+end program --- -2.11.0 - diff --git a/SOURCES/0004-Allow-non-integer-substring-indexes.patch b/SOURCES/0004-Allow-non-integer-substring-indexes.patch new file mode 100644 index 0000000..c0b893e --- /dev/null +++ b/SOURCES/0004-Allow-non-integer-substring-indexes.patch @@ -0,0 +1,158 @@ +From e61c233e6af3c392f5ac7d3f927b3fa8a55c6076 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 09:11:38 +0000 +Subject: [PATCH 04/10] Allow non-integer substring indexes + +Use -fdec-non-integer-index compiler flag to enable. Also enabled by -fdec. +--- + gcc/fortran/lang.opt | 4 ++++ + gcc/fortran/options.c | 1 + + gcc/fortran/resolve.c | 20 ++++++++++++++++++++ + .../dec_not_integer_substring_indexes_1.f | 18 ++++++++++++++++++ + .../dec_not_integer_substring_indexes_2.f | 18 ++++++++++++++++++ + .../dec_not_integer_substring_indexes_3.f | 18 ++++++++++++++++++ + 6 files changed, 79 insertions(+) + create mode 100644 gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index 5257da74b06..0fea012b7b6 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -485,6 +485,10 @@ fdec-math + Fortran Var(flag_dec_math) + Enable legacy math intrinsics for compatibility. + ++fdec-non-integer-index ++Fortran Var(flag_dec_non_integer_index) ++Enable support for non-integer substring indexes. ++ + fdec-structure + Fortran Var(flag_dec_structure) + Enable support for DEC STRUCTURE/RECORD. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index 75181ca6442..8c79a0bd122 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -78,6 +78,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_blank_format_item, value, value); + SET_BITFLAG (flag_dec_char_conversions, value, value); + SET_BITFLAG (flag_dec_duplicates, value, value); ++ SET_BITFLAG (flag_dec_non_integer_index, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 6e70eaf8812..044eed22c76 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -5087,6 +5087,16 @@ resolve_substring (gfc_ref *ref, bool *equal_length) + if (!gfc_resolve_expr (ref->u.ss.start)) + return false; + ++ /* In legacy mode, allow non-integer string indexes by converting */ ++ if (flag_dec_non_integer_index && 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", +@@ -5116,6 +5126,16 @@ resolve_substring (gfc_ref *ref, bool *equal_length) + if (!gfc_resolve_expr (ref->u.ss.end)) + return false; + ++ /* Non-integer string index endings, as for start */ ++ if (flag_dec_non_integer_index && 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_1.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_1.f +new file mode 100644 +index 00000000000..0be28abaa4b +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_1.f +@@ -0,0 +1,18 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test not integer substring indexes ++! ++! Test case contributed by Mark Eggleston ++! ++ PROGRAM not_integer_substring_indexes ++ CHARACTER*5 st/'Tests'/ ++ REAL ir/1.0/ ++ REAL ir2/4.0/ ++ ++ if (st(ir:4).ne.'Test') stop 1 ++ if (st(1:ir2).ne.'Test') stop 2 ++ if (st(1.0:4).ne.'Test') stop 3 ++ if (st(1:4.0).ne.'Test') stop 4 ++ if (st(2.5:4).ne.'est') stop 5 ++ END +diff --git a/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f +new file mode 100644 +index 00000000000..3cf05296d0c +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f +@@ -0,0 +1,18 @@ ++! { dg-do run } ++! { dg-options "-fdec-non-integer-index" } ++! ++! Test not integer substring indexes ++! ++! Test case contributed by Mark Eggleston ++! ++ PROGRAM not_integer_substring_indexes ++ CHARACTER*5 st/'Tests'/ ++ REAL ir/1.0/ ++ REAL ir2/4.0/ ++ ++ if (st(ir:4).ne.'Test') stop 1 ++ if (st(1:ir2).ne.'Test') stop 2 ++ if (st(1.0:4).ne.'Test') stop 3 ++ if (st(1:4.0).ne.'Test') stop 4 ++ if (st(2.5:4).ne.'est') stop 5 ++ END +diff --git a/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f +new file mode 100644 +index 00000000000..703de995897 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f +@@ -0,0 +1,18 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-non-integer-index" } ++! ++! Test not integer substring indexes ++! ++! Test case contributed by Mark Eggleston ++! ++ PROGRAM not_integer_substring_indexes ++ CHARACTER*5 st/'Tests'/ ++ REAL ir/1.0/ ++ REAL ir2/4.0/ ++ ++ if (st(ir:4).ne.'Test') stop 1 ! { dg-error "Substring start index" } ++ if (st(1:ir2).ne.'Test') stop 2 ! { dg-error "Substring end index" } ++ if (st(1.0:4).ne.'Test') stop 3 ! { dg-error "Substring start index" } ++ if (st(1:4.0).ne.'Test') stop 4 ! { dg-error "Substring end index" } ++ if (st(2.5:4).ne.'est') stop 5 ! { dg-error "Substring start index" } ++ END +-- +2.11.0 + diff --git a/SOURCES/0005-Allow-old-style-initializers-in-derived-types.patch b/SOURCES/0005-Allow-old-style-initializers-in-derived-types.patch new file mode 100644 index 0000000..7cc97cf --- /dev/null +++ b/SOURCES/0005-Allow-old-style-initializers-in-derived-types.patch @@ -0,0 +1,185 @@ +From 3a023e34ad6f2aca23079f9306ab6a56c7448896 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 09:18:37 +0000 +Subject: [PATCH 05/10] 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. + +Use -fdec-old-init to enable. Also enabled by -fdec. +--- + gcc/fortran/decl.c | 27 ++++++++++++++++++---- + gcc/fortran/lang.opt | 4 ++++ + gcc/fortran/options.c | 1 + + .../dec_derived_types_initialised_old_style_1.f | 25 ++++++++++++++++++++ + .../dec_derived_types_initialised_old_style_2.f | 25 ++++++++++++++++++++ + .../dec_derived_types_initialised_old_style_3.f | 26 +++++++++++++++++++++ + 6 files changed, 103 insertions(+), 5 deletions(-) + create mode 100644 gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f + +diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c +index 36326f77569..72194bda4a8 100644 +--- a/gcc/fortran/decl.c ++++ b/gcc/fortran/decl.c +@@ -2813,12 +2813,29 @@ 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 (flag_dec_old_init) ++ { ++ /* 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/fortran/lang.opt b/gcc/fortran/lang.opt +index 0fea012b7b6..7c53be28a20 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -489,6 +489,10 @@ fdec-non-integer-index + Fortran Var(flag_dec_non_integer_index) + Enable support for non-integer substring indexes. + ++fdec-old-init ++Fortran Var(flag_dec_old_init) ++Enable support for old style initializers in derived types. ++ + fdec-structure + Fortran Var(flag_dec_structure) + Enable support for DEC STRUCTURE/RECORD. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index 8c79a0bd122..c1c7f0bb671 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -79,6 +79,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_char_conversions, value, value); + SET_BITFLAG (flag_dec_duplicates, value, value); + SET_BITFLAG (flag_dec_non_integer_index, value, value); ++ SET_BITFLAG (flag_dec_old_init, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f +new file mode 100644 +index 00000000000..eac4f9bfcf1 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f +@@ -0,0 +1,25 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test old style initializers in derived types ++! ++! Contributed by Jim MacArthur ++! Modified by Mark Eggleston ++! ++ 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/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f +new file mode 100644 +index 00000000000..d904c8b2974 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f +@@ -0,0 +1,25 @@ ++! { dg-do run } ++! { dg-options "-std=legacy -fdec-old-init" } ++! ++! Test old style initializers in derived types ++! ++! Contributed by Jim MacArthur ++! Modified by Mark Eggleston ++! ++ 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/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f +new file mode 100644 +index 00000000000..58c2b4b66cf +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f +@@ -0,0 +1,26 @@ ++! { dg-do compile } ++! { dg-options "-std=legacy -fdec -fno-dec-old-init" } ++! ++! Test old style initializers in derived types ++! ++! Contributed by Jim MacArthur ++! Modified by Mark Eggleston ++! ++ ++ PROGRAM spec_in_var ++ TYPE STRUCT1 ++ INTEGER*4 ID /8/ ! { dg-error "Invalid old style initialization" } ++ INTEGER*4 TYPE /5/ ! { dg-error "Invalid old style initialization" } ++ INTEGER*8 DEFVAL /0/ ! { dg-error "Invalid old style initialization" } ++ CHARACTER*(5) NAME /'tests'/ ! { dg-error "Invalid old style initialization" } ++ LOGICAL*1 NIL /0/ ! { dg-error "Invalid old style initialization" } ++ END TYPE STRUCT1 ++ ++ TYPE (STRUCT1) SINST ++ ++ IF(SINST%ID.NE.8) STOP 1 ! { dg-error "'id' at \\(1\\) is not a member" } ++ IF(SINST%TYPE.NE.5) STOP 2 ! { dg-error "'type' at \\(1\\) is not a member" } ++ IF(SINST%DEFVAL.NE.0) STOP 3 ! { dg-error "'defval' at \\(1\\) is not a member" } ++ IF(SINST%NAME.NE.'tests') STOP 4 ! { dg-error "'name' at \\(1\\) is not a member" } ++ IF(SINST%NIL) STOP 5 ! { dg-error "'nil' at \\(1\\) is not a member" } ++ END +-- +2.11.0 + diff --git a/SOURCES/0005-dec-comparisons.patch b/SOURCES/0005-dec-comparisons.patch deleted file mode 100644 index 0110209..0000000 --- a/SOURCES/0005-dec-comparisons.patch +++ /dev/null @@ -1,658 +0,0 @@ -From 6946d3e3e6a1d839772f4c59a5ab08901111800c Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Thu, 23 May 2019 09:42:26 +0100 -Subject: [PATCH 05/16] dec comparisons - -Allow comparison of Hollerith constants with numeric and character -expressions. Also allow comparison of character literalsa with numeric -expressions. - -Enable using -fdec-comparisons or -fdec ---- - gcc/fortran/intrinsic.c | 5 +- - gcc/fortran/invoke.texi | 32 +++++++++++-- - gcc/fortran/lang.opt | 5 ++ - gcc/fortran/options.c | 1 + - gcc/fortran/resolve.c | 53 +++++++++++++++++++++- - .../gfortran.dg/dec-comparison-character_1.f90 | 18 ++++++++ - .../gfortran.dg/dec-comparison-character_2.f90 | 18 ++++++++ - .../gfortran.dg/dec-comparison-character_3.f90 | 17 +++++++ - .../gfortran.dg/dec-comparison-complex_1.f90 | 22 +++++++++ - .../gfortran.dg/dec-comparison-complex_2.f90 | 22 +++++++++ - .../gfortran.dg/dec-comparison-complex_3.f90 | 22 +++++++++ - gcc/testsuite/gfortran.dg/dec-comparison-int_1.f90 | 31 +++++++++++++ - gcc/testsuite/gfortran.dg/dec-comparison-int_2.f90 | 31 +++++++++++++ - gcc/testsuite/gfortran.dg/dec-comparison-int_3.f90 | 21 +++++++++ - .../gfortran.dg/dec-comparison-real_1.f90 | 31 +++++++++++++ - .../gfortran.dg/dec-comparison-real_2.f90 | 31 +++++++++++++ - .../gfortran.dg/dec-comparison-real_3.f90 | 31 +++++++++++++ - gcc/testsuite/gfortran.dg/dec-comparison.f90 | 41 +++++++++++++++++ - 18 files changed, 424 insertions(+), 8 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-character_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-character_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-character_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-complex_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-complex_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-complex_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-int_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-int_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-int_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-real_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-real_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison-real_3.f90 - create mode 100644 gcc/testsuite/gfortran.dg/dec-comparison.f90 - -diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c -index e94d5d3225f..6d47ae3105f 100644 ---- a/gcc/fortran/intrinsic.c -+++ b/gcc/fortran/intrinsic.c -@@ -4020,7 +4020,7 @@ add_conversions (void) - - /* Flang allows character conversions similar to Hollerith conversions - - the first characters will be turned into ascii values. */ -- if (flag_dec_char_conversions) -+ if (flag_dec_char_conversions || flag_dec_comparisons) - { - /* Character-Integer conversions. */ - for (i = 0; gfc_integer_kinds[i].kind != 0; i++) -@@ -5150,7 +5150,8 @@ 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 (flag_dec_char_conversions && from_ts.type == BT_CHARACTER -+ else if ((flag_dec_char_conversions || flag_dec_comparisons) -+ && from_ts.type == BT_CHARACTER - && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) - { - if (warn_conversion) -diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi -index 8364c67b2df..d101b01e301 100644 ---- a/gcc/fortran/invoke.texi -+++ b/gcc/fortran/invoke.texi -@@ -117,15 +117,16 @@ by type. Explanations are in the following sections. - @item Fortran Language Options - @xref{Fortran Dialect Options,,Options controlling Fortran dialect}. - @gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol ---fd-lines-as-comments @gol ---fdec -fdec-structure -fdec-intrinsic-ints -fdec-static -fdec-math @gol ---fdec-include -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol ---fdefault-real-10 -fdefault-real-16 -fdollar-ok -ffixed-line-length-@var{n} @gol -+-fd-lines-as-comments -fdec -fdec-structure -fdec-intrinsic-ints @gol -+-fdec-static -fdec-math -fdec-include -fdec-format-defaults @gol -+-fdec-add-missing-indexes -fdec-blank-format-item -fdec-comparisons @gol -+-fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 -fdefault-real-10 @gol -+-fdefault-real-16 -fdollar-ok -ffixed-line-length-@var{n} @gol - -ffixed-line-length-none -fpad-source -ffree-form -ffree-line-length-@var{n} @gol - -ffree-line-length-none -fimplicit-none -finteger-4-integer-8 @gol - -fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check @gol - -fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol ---freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std} -+-freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std} @gol - -ftest-forall-temp - } - -@@ -283,6 +284,27 @@ Enable parsing of INCLUDE as a statement in addition to parsing it as - INCLUDE line. When parsed as INCLUDE statement, INCLUDE does not have to - be on a single line and can use line continuations. - -+@item -fdec-add-missing-indexes -+@opindex @code{fdec-add-missing-indexes} -+Enable the insertion of missing dimensions using the lower bounds of those -+dimensions. -+ -+@item -fdec-format-defaults -+@opindex @code{fdec-format-defaults} -+Enable format specifiers F, G and I to be used without width specifiers, -+default widths will be used instead. -+ -+@item -fdec-blank-format-item -+@opindex @code{fdec-blank-format-item} -+Enable a blank format item at the end of a format specification i.e. nothing -+following the final comma. -+ -+@item -fdec-comparisons -+@opindex @code{fdec-comparisons} -+Enable comparison of Hollerith constants and character literals with numeric and -+character expressions. Also enable comparison of Hollerith constants with numeric -+expressions. -+ - @item -fdollar-ok - @opindex @code{fdollar-ok} - @cindex @code{$} -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 5746b99b1d4..a957b90707f 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -449,6 +449,11 @@ Fortran Var(flag_dec_char_conversions) - Enable the use of character literals in assignments and data statements - for non-character variables. - -+fdec-comparisons -+Fortran Var(flag_dec_comparisons) -+Enable the use of hollerith constants in comparisons. Also enables comparison -+of character literals and numeric vaiables. -+ - fdec-include - Fortran Var(flag_dec_include) - Enable legacy parsing of INCLUDE as statement. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index e97b1568810..b652be70f3d 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -77,6 +77,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_format_defaults, value, value); - SET_BITFLAG (flag_dec_duplicates, value, value); - SET_BITFLAG (flag_dec_char_conversions, value, value); -+ SET_BITFLAG (flag_dec_comparisons, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c -index 43559185481..c8b6333874b 100644 ---- a/gcc/fortran/resolve.c -+++ b/gcc/fortran/resolve.c -@@ -3888,6 +3888,30 @@ convert_integer_to_logical (gfc_expr *e) - } - } - -+/* 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 hollerith, convert it to character and issue a warning -+ for the conversion. */ -+ -+static void -+convert_hollerith_to_character (gfc_expr *e) -+{ -+ if (e->ts.type == BT_HOLLERITH) -+ { -+ gfc_typespec t; -+ t.type = BT_CHARACTER; -+ t.kind = e->ts.kind; -+ 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. */ - -@@ -3904,6 +3928,17 @@ convert_logical_to_integer (gfc_expr *e) - } - } - -+/* Convert to numeric and issue a warning for the conversion. */ -+ -+static void -+convert_to_numeric (gfc_expr *a, gfc_expr *b) -+{ -+ gfc_typespec t; -+ t.type = b->ts.type; -+ t.kind = b->ts.kind; -+ gfc_convert_type_warn (a, &t, 2, 1); -+} -+ - /* Resolve an operator expression node. This can involve replacing the - operation with a user defined function call. */ - -@@ -4108,6 +4143,13 @@ resolve_operator (gfc_expr *e) - convert_logical_to_integer (op2); - } - -+ if (flag_dec_comparisons && is_character_based (op1->ts.type) -+ && is_character_based (op2->ts.type)) -+ { -+ convert_hollerith_to_character (op1); -+ convert_hollerith_to_character (op2); -+ } -+ - if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER - && op1->ts.kind == op2->ts.kind) - { -@@ -4116,6 +4158,15 @@ resolve_operator (gfc_expr *e) - break; - } - -+ if (flag_dec_comparisons && is_character_based (op1->ts.type) -+ && op1->expr_type == EXPR_CONSTANT && gfc_numeric_ts (&op2->ts)) -+ convert_to_numeric (op1, op2); -+ -+ if (flag_dec_comparisons && gfc_numeric_ts (&op1->ts) -+ && is_character_based (op2->ts.type) -+ && op2->expr_type == EXPR_CONSTANT) -+ convert_to_numeric (op2, op1); -+ - if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) - { - gfc_type_convert_binary (e, 1); -@@ -10499,7 +10550,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) - - if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) - && rhs->ts.type == BT_CHARACTER -- && rhs->expr_type != EXPR_CONSTANT) -+ && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) - { - gfc_error ("Cannot convert CHARACTER into %s at %L", - gfc_typename (&lhs->ts), -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-character_1.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-character_1.f90 -new file mode 100644 -index 00000000000..d8209163a0e ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-character_1.f90 -@@ -0,0 +1,18 @@ -+! { dg-do run } -+! { dg-options "-fdec -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ character(4) :: c = 4HJMAC ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.ne.4HJMAC) stop 1 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.ne."JMAC") stop 2 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.eq."JMAN") stop 3 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if ("JMAC".eq.4HJMAN) stop 4 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if ("AAAA".eq.5HAAAAA) stop 5 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if ("BBBBB".eq.5HBBBB ) stop 6 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.ne.c) stop 7 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (c.ne.4HJMAC) stop 8 ! { dg-warning "HOLLERITH to CHARACTER" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-character_2.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-character_2.f90 -new file mode 100644 -index 00000000000..7332acbaf5c ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-character_2.f90 -@@ -0,0 +1,18 @@ -+! { dg-do run } -+! { dg-options "-fdec-comparisons -std=legacy -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ character(4) :: c = 4HJMAC ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.ne.4HJMAC) stop 1 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.ne."JMAC") stop 2 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.eq."JMAN") stop 3 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if ("JMAC".eq.4HJMAN) stop 4 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if ("AAAA".eq.5HAAAAA) stop 5 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if ("BBBBB".eq.5HBBBB ) stop 6 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (4HJMAC.ne.c) stop 7 ! { dg-warning "HOLLERITH to CHARACTER" } -+ if (c.ne.4HJMAC) stop 8 ! { dg-warning "HOLLERITH to CHARACTER" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-character_3.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-character_3.f90 -new file mode 100644 -index 00000000000..c20c012478a ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-character_3.f90 -@@ -0,0 +1,17 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-comparisons" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ character(4) :: c = 4HJMAC -+ if (4HJMAC.ne.4HJMAC) stop 1 ! { dg-error "Operands of comparison" } -+ if (4HJMAC.ne."JMAC") stop 2 ! { dg-error "Operands of comparison" } -+ if (4HJMAC.eq."JMAN") stop 3 ! { dg-error "Operands of comparison" } -+ if ("JMAC".eq.4HJMAN) stop 4 ! { dg-error "Operands of comparison" } -+ if ("AAAA".eq.5HAAAAA) stop 5 ! { dg-error "Operands of comparison" } -+ if ("BBBBB".eq.5HBBBB ) stop 6 ! { dg-error "Operands of comparison" } -+ if (4HJMAC.ne.c) stop 7 ! { dg-error "Operands of comparison" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-complex_1.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-complex_1.f90 -new file mode 100644 -index 00000000000..3495f2ae414 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-complex_1.f90 -@@ -0,0 +1,22 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ complex(4) :: a -+ complex(4) :: b -+ a = 8HABCDABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCDABCD", b); -+ ! Hollerith constants -+ if (a.ne.8HABCDABCD) stop 1 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.eq.8HABCEABCE) stop 2 ! { dg-warning "Conversion from HOLLERITH" } -+ if (8HABCDABCD.ne.b) stop 3 ! { dg-warning "Conversion from HOLLERITH" } -+ if (8HABCEABCE.eq.b) stop 4 ! { dg-warning "Conversion from HOLLERITH" } -+ ! Character literals -+ if (a.ne."ABCDABCD") stop 5 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.eq."ABCEABCE") stop 6 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCDABCD".ne.b) stop 7 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCEABCE".eq.b) stop 8 ! { dg-warning "Conversion from CHARACTER" } -+end program -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-complex_2.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-complex_2.f90 -new file mode 100644 -index 00000000000..c38042cc600 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-complex_2.f90 -@@ -0,0 +1,22 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec-comparisons -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ complex(4) :: a -+ complex(4) :: b -+ a = 8HABCDABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCDABCD", b); -+ ! Hollerith constants -+ if (a.ne.8HABCDABCD) stop 1 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.eq.8HABCEABCE) stop 2 ! { dg-warning "Conversion from HOLLERITH" } -+ if (8HABCDABCD.ne.b) stop 3 ! { dg-warning "Conversion from HOLLERITH" } -+ if (8HABCEABCE.eq.b) stop 4 ! { dg-warning "Conversion from HOLLERITH" } -+ ! Character literals -+ if (a.ne."ABCDABCD") stop 5 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.eq."ABCEABCE") stop 6 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCDABCD".ne.b) stop 7 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCEABCE".eq.b) stop 8 ! { dg-warning "Conversion from CHARACTER" } -+end program -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-complex_3.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-complex_3.f90 -new file mode 100644 -index 00000000000..9b27fc4d502 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-complex_3.f90 -@@ -0,0 +1,22 @@ -+! { dg-do compile } -+! { dg-options "-std=legacy -fdec -fno-dec-comparisons -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ complex(4) :: a -+ complex(4) :: b -+ a = 8HABCDABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCDABCD", b); -+ ! Hollerith constants -+ if (a.ne.8HABCDABCD) stop 1 ! { dg-error "Operands of comparison" } -+ if (a.eq.8HABCEABCE) stop 2 ! { dg-error "Operands of comparison" } -+ if (8HABCDABCD.ne.b) stop 3 ! { dg-error "Operands of comparison" } -+ if (8HABCEABCE.eq.b) stop 4 ! { dg-error "Operands of comparison" } -+ ! character literals -+ if (a.ne."ABCDABCD") stop 5 ! { dg-error "Operands of comparison" } -+ if (a.eq."ABCEABCE") stop 6 ! { dg-error "Operands of comparison" } -+ if ("ABCDABCD".ne.b) stop 7 ! { dg-error "Operands of comparison" } -+ if ("ABCEABCE".eq.b) stop 8 ! { dg-error "Operands of comparison" } -+end program -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-int_1.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-int_1.f90 -new file mode 100644 -index 00000000000..c93b61e29cf ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-int_1.f90 -@@ -0,0 +1,31 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ integer(4) :: a -+ integer(4) :: b -+ a = 4HABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCD", b) -+ ! Hollerith constants -+ if (a.ne.4HABCD) stop 1 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.eq.4HABCE) stop 2 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCD.ne.b) stop 3 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.eq.b) stop 4 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.lt.a) stop 5 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.gt.4HABCE) stop 6 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.le.a) stop 7 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.ge.4HABCE) stop 8 ! { dg-warning "Conversion from HOLLERITH" } -+ ! Character literals -+ if (a.ne."ABCD") stop 9 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.eq."ABCE") stop 10 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCD".ne.b) stop 11 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".eq.b) stop 12 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".lt.a) stop 13 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.gt."ABCE") stop 14 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".le.a) stop 15 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.ge."ABCE") stop 16 ! { dg-warning "Conversion from CHARACTER" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-int_2.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-int_2.f90 -new file mode 100644 -index 00000000000..cd1ae783d41 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-int_2.f90 -@@ -0,0 +1,31 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec-comparisons -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ integer(4) :: a -+ integer(4) :: b -+ a = 4HABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCD", b) -+ ! Hollerith constants -+ if (a.ne.4HABCD) stop 1 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.eq.4HABCE) stop 2 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCD.ne.b) stop 3 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.eq.b) stop 4 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.lt.a) stop 5 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.gt.4HABCE) stop 6 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.le.a) stop 7 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.ge.4HABCE) stop 8 ! { dg-warning "Conversion from HOLLERITH" } -+ ! Character literals -+ if (a.ne."ABCD") stop 9 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.eq."ABCE") stop 10 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCD".ne.b) stop 11 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".eq.b) stop 12 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".lt.a) stop 13 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.gt."ABCE") stop 14 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".le.a) stop 15 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.ge."ABCE") stop 16 ! { dg-warning "Conversion from CHARACTER" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-int_3.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-int_3.f90 -new file mode 100644 -index 00000000000..b350075afe7 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-int_3.f90 -@@ -0,0 +1,21 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-comparisons -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ integer(4) :: a -+ integer(4) :: b -+ a = 4HABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCD", b) -+ if (a.ne.4HABCD) stop 1 ! { dg-error "Operands of comparison" } -+ if (a.eq.4HABCE) stop 2 ! { dg-error "Operands of comparison" } -+ if (4HABCD.ne.b) stop 3 ! { dg-error "Operands of comparison" } -+ if (4HABCE.eq.b) stop 4 ! { dg-error "Operands of comparison" } -+ if (4HABCE.lt.a) stop 5 ! { dg-error "Operands of comparison" } -+ if (a.gt.4HABCE) stop 6 ! { dg-error "Operands of comparison" } -+ if (4HABCE.le.a) stop 7 ! { dg-error "Operands of comparison" } -+ if (a.ge.4HABCE) stop 8 ! { dg-error "Operands of comparison" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-real_1.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-real_1.f90 -new file mode 100644 -index 00000000000..08b66aaebfd ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-real_1.f90 -@@ -0,0 +1,31 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ real(4) :: a -+ real(4) :: b -+ a = 4HABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCD", b) -+ ! Hollerith constants -+ if (a.ne.4HABCD) stop 1 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.eq.4HABCE) stop 2 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCD.ne.b) stop 3 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.eq.b) stop 4 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.lt.a) stop 5 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.gt.4HABCE) stop 6 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.le.a) stop 7 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.ge.4HABCE) stop 8 ! { dg-warning "Conversion from HOLLERITH" } -+ ! Character literals -+ if (a.ne."ABCD") stop 9 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.eq."ABCE") stop 10 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCD".ne.b) stop 11 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".eq.b) stop 12 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".lt.a) stop 13 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.gt."ABCE") stop 14 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".le.a) stop 15 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.ge."ABCE") stop 16 ! { dg-warning "Conversion from CHARACTER" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-real_2.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-real_2.f90 -new file mode 100644 -index 00000000000..244abb84868 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-real_2.f90 -@@ -0,0 +1,31 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec-comparisons -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ real(4) :: a -+ real(4) :: b -+ a = 4HABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCD", b) -+ ! Hollerith constants -+ if (a.ne.4HABCD) stop 1 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.eq.4HABCE) stop 2 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCD.ne.b) stop 3 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.eq.b) stop 4 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.lt.a) stop 5 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.gt.4HABCE) stop 6 ! { dg-warning "Conversion from HOLLERITH" } -+ if (4HABCE.le.a) stop 7 ! { dg-warning "Conversion from HOLLERITH" } -+ if (a.ge.4HABCE) stop 8 ! { dg-warning "Conversion from HOLLERITH" } -+ ! Character literals -+ if (a.ne."ABCD") stop 9 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.eq."ABCE") stop 10 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCD".ne.b) stop 11 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".eq.b) stop 12 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".lt.a) stop 13 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.gt."ABCE") stop 14 ! { dg-warning "Conversion from CHARACTER" } -+ if ("ABCE".le.a) stop 15 ! { dg-warning "Conversion from CHARACTER" } -+ if (a.ge."ABCE") stop 16 ! { dg-warning "Conversion from CHARACTER" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison-real_3.f90 b/gcc/testsuite/gfortran.dg/dec-comparison-real_3.f90 -new file mode 100644 -index 00000000000..111c648f08c ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison-real_3.f90 -@@ -0,0 +1,31 @@ -+! { dg-do compile } -+! { dg-options "-std=legacy -fdec -fno-dec-comparisons -Wconversion" } -+! -+! Test case contributed by Mark Eggleston -+! -+ -+program convert -+ real(4) :: a -+ real(4) :: b -+ a = 4HABCD ! { dg-warning "Conversion from HOLLERITH" } -+ b = transfer("ABCD", b) -+ ! Hollerith constants -+ if (a.ne.4HABCD) stop 1 ! { dg-error "Operands of comparison" } -+ if (a.eq.4HABCE) stop 2 ! { dg-error "Operands of comparison" } -+ if (4HABCD.ne.b) stop 3 ! { dg-error "Operands of comparison" } -+ if (4HABCE.eq.b) stop 4 ! { dg-error "Operands of comparison" } -+ if (4HABCE.lt.a) stop 5 ! { dg-error "Operands of comparison" } -+ if (a.gt.4HABCE) stop 6 ! { dg-error "Operands of comparison" } -+ if (4HABCE.le.a) stop 7 ! { dg-error "Operands of comparison" } -+ if (a.ge.4HABCE) stop 8 ! { dg-error "Operands of comparison" } -+ ! Character literals -+ if (a.ne."ABCD") stop 9 ! { dg-error "Operands of comparison" } -+ if (a.eq."ABCE") stop 10 ! { dg-error "Operands of comparison" } -+ if ("ABCD".ne.b) stop 11 ! { dg-error "Operands of comparison" } -+ if ("ABCE".eq.b) stop 12 ! { dg-error "Operands of comparison" } -+ if ("ABCE".lt.a) stop 13 ! { dg-error "Operands of comparison" } -+ if (a.gt."ABCE") stop 14 ! { dg-error "Operands of comparison" } -+ if ("ABCE".le.a) stop 15 ! { dg-error "Operands of comparison" } -+ if (a.ge."ABCE") stop 16 ! { dg-error "Operands of comparison" } -+end program -+ -diff --git a/gcc/testsuite/gfortran.dg/dec-comparison.f90 b/gcc/testsuite/gfortran.dg/dec-comparison.f90 -new file mode 100644 -index 00000000000..b0b28e55111 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec-comparison.f90 -@@ -0,0 +1,41 @@ -+! { dg-do compile } -+! { dg-options "-fdec" } -+! -+! Test case contributed by Mark Eggleston -+! -+! Hollerith constants and character literals are allowed in comparisons, -+! check that character variables can not be compared with numeric variables. -+ -+program convert -+ character(4) :: a = 4hJMAC -+ integer(4) :: b = "JMAC" -+ real(4) :: c = "JMAC" -+ complex(4) :: d = "JMACJMAC" -+ ! integers -+ if (a.ne.b) stop 1 ! { dg-error "Operands of comparison" } -+ if (b.eq.a) stop 2 ! { dg-error "Operands of comparison" } -+ if (a.ge.b) stop 3 ! { dg-error "Operands of comparison" } -+ if (b.ge.a) stop 4 ! { dg-error "Operands of comparison" } -+ if (a.gt.b) stop 5 ! { dg-error "Operands of comparison" } -+ if (b.gt.a) stop 6 ! { dg-error "Operands of comparison" } -+ if (a.le.b) stop 3 ! { dg-error "Operands of comparison" } -+ if (b.le.a) stop 4 ! { dg-error "Operands of comparison" } -+ if (a.lt.b) stop 5 ! { dg-error "Operands of comparison" } -+ if (b.lt.a) stop 6 ! { dg-error "Operands of comparison" } -+ ! reals -+ if (a.ne.c) stop 7 ! { dg-error "Operands of comparison" } -+ if (c.eq.a) stop 8 ! { dg-error "Operands of comparison" } -+ if (a.ge.c) stop 9 ! { dg-error "Operands of comparison" } -+ if (c.ge.a) stop 10 ! { dg-error "Operands of comparison" } -+ if (a.gt.c) stop 11 ! { dg-error "Operands of comparison" } -+ if (c.gt.a) stop 12 ! { dg-error "Operands of comparison" } -+ if (a.le.c) stop 13 ! { dg-error "Operands of comparison" } -+ if (c.le.a) stop 14 ! { dg-error "Operands of comparison" } -+ if (a.lt.c) stop 15 ! { dg-error "Operands of comparison" } -+ if (c.lt.a) stop 16 ! { dg-error "Operands of comparison" } -+ ! complexes -+ a = "JMACJMAC" -+ if (a.ne.d) stop 17 ! { dg-error "Operands of comparison" } -+ if (d.eq.a) stop 18 ! { dg-error "Operands of comparison" } -+end program -+ --- -2.11.0 - diff --git a/SOURCES/0006-Allow-blank-format-items-in-format-strings.patch b/SOURCES/0006-Allow-blank-format-items-in-format-strings.patch deleted file mode 100644 index e3ad8d0..0000000 --- a/SOURCES/0006-Allow-blank-format-items-in-format-strings.patch +++ /dev/null @@ -1,150 +0,0 @@ -From 8a5920d930429f91b269d9265323bf2507a6b8e5 Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Thu, 4 Feb 2016 16:59:41 +0000 -Subject: [PATCH 06/16] 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. - -Test written by: Francisco Redondo Marchena - -Use -fdec-blank-format-item to enable. Also enabled by -fdec. ---- - gcc/fortran/io.c | 10 ++++++++++ - gcc/fortran/lang.opt | 4 ++++ - gcc/fortran/options.c | 1 + - gcc/testsuite/gfortran.dg/dec_format_empty_item_1.f | 19 +++++++++++++++++++ - gcc/testsuite/gfortran.dg/dec_format_empty_item_2.f | 19 +++++++++++++++++++ - gcc/testsuite/gfortran.dg/dec_format_empty_item_3.f | 19 +++++++++++++++++++ - 6 files changed, 72 insertions(+) - create mode 100644 gcc/testsuite/gfortran.dg/dec_format_empty_item_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_format_empty_item_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_format_empty_item_3.f - -diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c -index 57117579627..5b355952840 100644 ---- a/gcc/fortran/io.c -+++ b/gcc/fortran/io.c -@@ -756,6 +756,16 @@ format_item_1: - error = unexpected_end; - goto syntax; - -+ case FMT_RPAREN: -+ /* Oracle allows a blank format item. */ -+ if (flag_dec_blank_format_item) -+ goto finished; -+ else -+ { -+ error = unexpected_element; -+ goto syntax; -+ } -+ - default: - error = unexpected_element; - goto syntax; -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index a957b90707f..3d8aaeaaf44 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -440,6 +440,10 @@ fdec - Fortran Var(flag_dec) - Enable all DEC language extensions. - -+fdec-blank-format-item -+Fortran Var(flag_dec_blank_format_item) -+Enable the use of blank format items in format strings. -+ - fdec-duplicates - Fortran Var(flag_dec_duplicates) - Allow varibles to be duplicated in the type specification matches. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index b652be70f3d..a8c2cf71c3b 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -78,6 +78,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_duplicates, value, value); - SET_BITFLAG (flag_dec_char_conversions, value, value); - SET_BITFLAG (flag_dec_comparisons, value, value); -+ SET_BITFLAG (flag_dec_blank_format_item, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/testsuite/gfortran.dg/dec_format_empty_item_1.f b/gcc/testsuite/gfortran.dg/dec_format_empty_item_1.f -new file mode 100644 -index 00000000000..ed27c18944b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_format_empty_item_1.f -@@ -0,0 +1,19 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test blank/empty format items in format string -+! -+! Test case contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ 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/gcc/testsuite/gfortran.dg/dec_format_empty_item_2.f b/gcc/testsuite/gfortran.dg/dec_format_empty_item_2.f -new file mode 100644 -index 00000000000..2793cb16225 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_format_empty_item_2.f -@@ -0,0 +1,19 @@ -+! { dg-do run } -+! { dg-options "-fdec-blank-format-item" } -+! -+! Test blank/empty format items in format string -+! -+! Test case contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ 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/gcc/testsuite/gfortran.dg/dec_format_empty_item_3.f b/gcc/testsuite/gfortran.dg/dec_format_empty_item_3.f -new file mode 100644 -index 00000000000..499db922876 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_format_empty_item_3.f -@@ -0,0 +1,19 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-blank-format-item" } -+! -+! Test blank/empty format items in format string -+! -+! Test case contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ PROGRAM blank_format_items -+ INTEGER A/0/ -+ -+ OPEN(1, status="scratch") -+ WRITE(1, 10) 100 ! { dg-error "FORMAT label 10 at \\(1\\) not defined" } -+ REWIND(1) -+ READ(1, 10) A ! { dg-error "FORMAT label 10 at \\(1\\) not defined" } -+ IF (a.NE.100) STOP 1 -+ PRINT 10, A ! { dg-error "FORMAT label 10 at \\(1\\) not defined" } -+10 FORMAT( I5,) ! { dg-error "Unexpected element" } -+ END --- -2.11.0 - diff --git a/SOURCES/0006-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch b/SOURCES/0006-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch new file mode 100644 index 0000000..9b7b9b4 --- /dev/null +++ b/SOURCES/0006-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch @@ -0,0 +1,588 @@ +From 7057f7dcb2b7ded072e0f628add2a0bcae517635 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 09:28:01 +0000 +Subject: [PATCH 06/10] Allow string length and kind to be specified on a per + variable basis. + +This allows kind/length to be mixed with array specification in +declarations. + +e.g. + + INTEGER*4 x*2, y*8 + CHARACTER names*20(10) + REAL v(100)*8, vv*4(50) + +The per-variable size overrides the kind or length specified for the type. + +Use -fdec-override-kind to enable. Also enabled by -fdec. + +Note: this feature is a merger of two previously separate features. + +Now accepts named constants as kind parameters: + + INTEGER A + PARAMETER (A=2) + INTEGER B*(A) + +Contributed by Mark Eggleston + +Now rejects invalid kind parameters and prints error messages: + + INTEGER X*3 + +caused an internal compiler error. + +Contributed by Mark Eggleston +--- + gcc/fortran/decl.c | 156 ++++++++++++++++----- + gcc/fortran/lang.opt | 4 + + gcc/fortran/options.c | 1 + + .../dec_mixed_char_array_declaration_1.f | 13 ++ + .../dec_mixed_char_array_declaration_2.f | 13 ++ + .../dec_mixed_char_array_declaration_3.f | 13 ++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f | 31 ++++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f | 31 ++++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f | 31 ++++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f | 14 ++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f | 19 +++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f | 19 +++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f | 15 ++ + gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f | 14 ++ + 14 files changed, 340 insertions(+), 34 deletions(-) + create mode 100644 gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f + +diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c +index 72194bda4a8..d2ea3e5070e 100644 +--- a/gcc/fortran/decl.c ++++ b/gcc/fortran/decl.c +@@ -1210,6 +1210,54 @@ 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; ++ gfc_expr *expr = NULL; ++ ++ m = gfc_match_char ('*'); ++ if (m != MATCH_YES) ++ return m; ++ ++ m = gfc_match_small_literal_int (length, NULL); ++ if (m == MATCH_YES || m == MATCH_ERROR) ++ return m; ++ ++ if (gfc_match_char ('(') == MATCH_NO) ++ return MATCH_ERROR; ++ ++ m = gfc_match_expr (&expr); ++ if (m == MATCH_YES) ++ { ++ m = MATCH_ERROR; // Assume error ++ if (gfc_expr_check_typed (expr, gfc_current_ns, false)) ++ { ++ if ((expr->expr_type == EXPR_CONSTANT) ++ && (expr->ts.type == BT_INTEGER)) ++ { ++ *length = mpz_get_si(expr->value.integer); ++ m = MATCH_YES; ++ } ++ } ++ ++ if (m == MATCH_YES) ++ { ++ if (gfc_match_char (')') == MATCH_NO) ++ m = MATCH_ERROR; ++ } ++ } ++ ++ if (expr != NULL) ++ gfc_free_expr (expr); ++ 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 +@@ -2437,6 +2485,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 +@@ -2447,7 +2524,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; +@@ -2456,11 +2533,15 @@ variable_decl (int elem) + match m; + bool t; + gfc_symbol *sym; ++ match cl_match; ++ match kind_match; ++ int overridden_kind; + char c; + + 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 +@@ -2513,6 +2594,28 @@ 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 (flag_dec_override_kind) ++ { ++ 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. */ + m = gfc_match_array_spec (&as, true, true); + if (m == MATCH_ERROR) +@@ -2653,40 +2756,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 +@@ -2788,6 +2863,19 @@ 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 (gfc_validate_kind (sym->ts.type, sym->ts.kind, true) < 0) ++ { ++ gfc_error ("Kind %d not supported for type %s at %C", ++ sym->ts.kind, gfc_basic_typename (sym->ts.type)); ++ return MATCH_ERROR; ++ } ++ } ++ + if (!check_function_name (name)) + { + m = MATCH_ERROR; +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index 7c53be28a20..b378f467e2f 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -489,6 +489,10 @@ fdec-non-integer-index + Fortran Var(flag_dec_non_integer_index) + Enable support for non-integer substring indexes. + ++fdec-override-kind ++Fortran Var(flag_dec_override_kind) ++Enable support for per variable kind specification. ++ + fdec-old-init + Fortran Var(flag_dec_old_init) + Enable support for old style initializers in derived types. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index c1c7f0bb671..fac23e83d70 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -80,6 +80,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_duplicates, value, value); + SET_BITFLAG (flag_dec_non_integer_index, value, value); + SET_BITFLAG (flag_dec_old_init, value, value); ++ SET_BITFLAG (flag_dec_override_kind, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f +new file mode 100644 +index 00000000000..706ea4112a4 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f +@@ -0,0 +1,13 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test character declaration with mixed string length and array specification ++! ++! Contributed by Jim MacArthur ++! Modified by Mark Eggleston ++! ++ 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/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f +new file mode 100644 +index 00000000000..26d2acf01de +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f +@@ -0,0 +1,13 @@ ++! { dg-do run } ++! { dg-options "-fdec-override-kind" } ++! ++! Test character declaration with mixed string length and array specification ++! ++! Contributed by Jim MacArthur ++! Modified by Mark Eggleston ++! ++ 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/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f +new file mode 100644 +index 00000000000..76e4f0bdb93 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f +@@ -0,0 +1,13 @@ ++! { dg-do compile } ++! { dg-options "-fdec-override-kind -fno-dec-override-kind" } ++! ++! Test character declaration with mixed string length and array specification ++! ++! Contributed by Jim MacArthur ++! Modified by Mark Eggleston ++! ++ PROGRAM character_declaration ++ CHARACTER ASPEC_SLENGTH*2 (5) /'01','02','03','04','05'/ ! { dg-error "Syntax error" } ++ CHARACTER SLENGTH_ASPEC(5)*2 /'01','02','03','04','05'/ ++ if (ASPEC_SLENGTH(3).NE.SLENGTH_ASPEC(3)) STOP 1 ! { dg-error " Operands of comparison operator" } ++ END +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f +new file mode 100644 +index 00000000000..edd0f5874b7 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f +@@ -0,0 +1,31 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test kind specification in variable not in type ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer*8 ai*1, bi*4, ci ++ real*4 ar*4, br*8, cr ++ ++ ai = 1 ++ ar = 1.0 ++ bi = 2 ++ br = 2.0 ++ ci = 3 ++ cr = 3.0 ++ ++ if (ai .ne. 1) stop 1 ++ if (abs(ar - 1.0) > 1.0D-6) stop 2 ++ if (bi .ne. 2) stop 3 ++ if (abs(br - 2.0) > 1.0D-6) stop 4 ++ if (ci .ne. 3) stop 5 ++ if (abs(cr - 3.0) > 1.0D-6) stop 6 ++ if (kind(ai) .ne. 1) stop 7 ++ if (kind(ar) .ne. 4) stop 8 ++ if (kind(bi) .ne. 4) stop 9 ++ if (kind(br) .ne. 8) stop 10 ++ if (kind(ci) .ne. 8) stop 11 ++ if (kind(cr) .ne. 4) stop 12 ++ end +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f +new file mode 100644 +index 00000000000..bfaba584dbb +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f +@@ -0,0 +1,31 @@ ++! { dg-do run } ++! { dg-options "-fdec-override-kind" } ++! ++! Test kind specification in variable not in type ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer*8 ai*1, bi*4, ci ++ real*4 ar*4, br*8, cr ++ ++ ai = 1 ++ ar = 1.0 ++ bi = 2 ++ br = 2.0 ++ ci = 3 ++ cr = 3.0 ++ ++ if (ai .ne. 1) stop 1 ++ if (abs(ar - 1.0) > 1.0D-6) stop 2 ++ if (bi .ne. 2) stop 3 ++ if (abs(br - 2.0) > 1.0D-6) stop 4 ++ if (ci .ne. 3) stop 5 ++ if (abs(cr - 3.0) > 1.0D-6) stop 6 ++ if (kind(ai) .ne. 1) stop 7 ++ if (kind(ar) .ne. 4) stop 8 ++ if (kind(bi) .ne. 4) stop 9 ++ if (kind(br) .ne. 8) stop 10 ++ if (kind(ci) .ne. 8) stop 11 ++ if (kind(cr) .ne. 4) stop 12 ++ end +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f +new file mode 100644 +index 00000000000..5ff434e7466 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f +@@ -0,0 +1,31 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-override-kind" } ++! ++! Test kind specification in variable not in type ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer*8 ai*1, bi*4, ci ! { dg-error "Syntax error" } ++ real*4 ar*4, br*8, cr ! { dg-error "Syntax error" } ++ ++ ai = 1 ++ ar = 1.0 ++ bi = 2 ++ br = 2.0 ++ ci = 3 ++ cr = 3.0 ++ ++ if (ai .ne. 1) stop 1 ++ if (abs(ar - 1.0) > 1.0D-6) stop 2 ++ if (bi .ne. 2) stop 3 ++ if (abs(br - 2.0) > 1.0D-6) stop 4 ++ if (ci .ne. 3) stop 5 ++ if (abs(cr - 3.0) > 1.0D-6) stop 6 ++ if (kind(ai) .ne. 1) stop 7 ++ if (kind(ar) .ne. 4) stop 8 ++ if (kind(bi) .ne. 4) stop 9 ++ if (kind(br) .ne. 8) stop 10 ++ if (kind(ci) .ne. 8) stop 11 ++ if (kind(cr) .ne. 4) stop 12 ++ end +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f +new file mode 100644 +index 00000000000..c01980e8b9d +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f +@@ -0,0 +1,14 @@ ++! { dg-do compile } ++! ++! Test kind specification in variable not in type. The per variable ++! kind specification is not enabled so these should fail ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer a ++ parameter(a=2) ++ integer b*(a) ! { dg-error "Syntax error" } ++ real c*(8) ! { dg-error "Syntax error" } ++ logical d*1_1 ! { dg-error "Syntax error" } ++ end +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f +new file mode 100644 +index 00000000000..e2f39da3f4f +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f +@@ -0,0 +1,19 @@ ++! { dg-do run } ++! { dg-options "-fdec-override-kind" } ++! ++! Test kind specification in variable not in type ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer a ++ parameter(a=2) ++ integer b*(a) ++ real c*(8) ++ logical d*(1_1) ++ character e*(a) ++ if (kind(b).ne.2) stop 1 ++ if (kind(c).ne.8) stop 2 ++ if (kind(d).ne.1) stop 3 ++ if (len(e).ne.2) stop 4 ++ end +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f +new file mode 100644 +index 00000000000..569747874e3 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f +@@ -0,0 +1,19 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test kind specification in variable not in type ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer a ++ parameter(a=2) ++ integer b*(a) ++ real c*(8) ++ logical d*(1_1) ++ character e*(a) ++ if (kind(b).ne.2) stop 1 ++ if (kind(c).ne.8) stop 2 ++ if (kind(d).ne.1) stop 3 ++ if (len(e).ne.2) stop 4 ++ end +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f +new file mode 100644 +index 00000000000..b975bfd15c5 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f +@@ -0,0 +1,15 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-override-kind" } ++! ++! Test kind specification in variable not in type as the per variable ++! kind specification is not enables these should fail ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer a ++ parameter(a=2) ++ integer b*(a) ! { dg-error "Syntax error" } ++ real c*(8) ! { dg-error "Syntax error" } ++ logical d*1_1 ! { dg-error "Syntax error" } ++ end +diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f +new file mode 100644 +index 00000000000..85732e0bd85 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f +@@ -0,0 +1,14 @@ ++! { dg-do compile } ++! { dg-options "-fdec" } ++! ++! Check that invalid kind values are rejected. ++! ++! Contributed by Mark Eggleston ++! ++ program spec_in_var ++ integer a ++ parameter(a=3) ++ integer b*(a) ! { dg-error "Kind 3 not supported" } ++ real c*(78) ! { dg-error "Kind 78 not supported" } ++ logical d*(*) ! { dg-error "Invalid character" } ++ end +-- +2.11.0 + 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 deleted file mode 100644 index a70ca2b..0000000 --- a/SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch +++ /dev/null @@ -1,78 +0,0 @@ -From d15e5e207e2a6b46edee2f2b5d3e4c1cc7cdb80f Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Mon, 5 Oct 2015 13:45:15 +0100 -Subject: [PATCH 07/16] Allow more than one character as argument to ICHAR - -Use -fdec to enable.. ---- - gcc/fortran/check.c | 2 +- - gcc/fortran/simplify.c | 4 ++-- - gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f | 21 +++++++++++++++++++++ - 3 files changed, 24 insertions(+), 3 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f - -diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c -index a04f0d66655..0ba4d0a031f 100644 ---- a/gcc/fortran/check.c -+++ b/gcc/fortran/check.c -@@ -2603,7 +2603,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) - else - return true; - -- if (i != 1) -+ if (i != 1 && !flag_dec) - { - 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 7d7e3f22f73..7aff256c6b3 100644 ---- a/gcc/fortran/simplify.c -+++ b/gcc/fortran/simplify.c -@@ -3229,7 +3229,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 && !flag_dec) - { - gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); - return &gfc_bad_expr; -@@ -3427,7 +3427,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 && !flag_dec) - { - 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_1.f b/gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f -new file mode 100644 -index 00000000000..85efccecc0f ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_ichar_with_string_1.f -@@ -0,0 +1,21 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test ICHAR and IACHAR with more than one character as argument -+! -+! Test case contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ 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 --- -2.11.0 - diff --git a/SOURCES/0007-Allow-non-logical-expressions-in-IF-statements.patch b/SOURCES/0007-Allow-non-logical-expressions-in-IF-statements.patch new file mode 100644 index 0000000..11254b1 --- /dev/null +++ b/SOURCES/0007-Allow-non-logical-expressions-in-IF-statements.patch @@ -0,0 +1,378 @@ +From a47308b5badceb8038fcf5edd2b93f33f2d7997e Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 09:31:05 +0000 +Subject: [PATCH 07/10] Allow non-logical expressions in IF statements + +Use -fdec-non-logical-if to enable feature. Also enabled using -fdec. +--- + gcc/fortran/lang.opt | 4 ++ + gcc/fortran/options.c | 1 + + gcc/fortran/resolve.c | 60 ++++++++++++++++++---- + ...ec_logical_expressions_if_statements_blocks_1.f | 25 +++++++++ + ...ec_logical_expressions_if_statements_blocks_2.f | 25 +++++++++ + ...ec_logical_expressions_if_statements_blocks_3.f | 25 +++++++++ + ...ec_logical_expressions_if_statements_blocks_4.f | 45 ++++++++++++++++ + ...ec_logical_expressions_if_statements_blocks_5.f | 45 ++++++++++++++++ + ...ec_logical_expressions_if_statements_blocks_6.f | 45 ++++++++++++++++ + 9 files changed, 266 insertions(+), 9 deletions(-) + create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index b378f467e2f..0a6b4263e22 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -493,6 +493,10 @@ fdec-override-kind + Fortran Var(flag_dec_override_kind) + Enable support for per variable kind specification. + ++fdec-non-logical-if ++Fortran Var(flag_dec_non_logical_if) ++Enable support for non-logical expressions in if statements. ++ + fdec-old-init + Fortran Var(flag_dec_old_init) + Enable support for old style initializers in derived types. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index fac23e83d70..86b28cfe3e6 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -81,6 +81,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_non_integer_index, value, value); + SET_BITFLAG (flag_dec_old_init, value, value); + SET_BITFLAG (flag_dec_override_kind, value, value); ++ SET_BITFLAG (flag_dec_non_logical_if, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 044eed22c76..e4bb0e79c80 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -10721,10 +10721,31 @@ 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 (flag_dec_non_logical_if && 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; ++ if (warn_conversion_extra) ++ { ++ gfc_warning (OPT_Wconversion_extra, "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: +@@ -12019,11 +12040,32 @@ 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 (flag_dec_non_logical_if ++ && 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; ++ if (warn_conversion_extra) ++ { ++ gfc_warning (OPT_Wconversion_extra, "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_1.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_1.f +new file mode 100644 +index 00000000000..0101db893ca +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_1.f +@@ -0,0 +1,25 @@ ++! { dg-do run } ++! { dg-options "-fdec -Wconversion-extra" } ++! ++! Allow logical expressions in if statements and blocks ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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 +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..876f4e09508 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_2.f +@@ -0,0 +1,25 @@ ++! { dg-do run } ++! { dg-options "-fdec-non-logical-if -Wconversion-extra" } ++! ++! Allow logical expressions in if statements and blocks ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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 +diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f +new file mode 100644 +index 00000000000..35cb4c51b8d +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f +@@ -0,0 +1,25 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-non-logical-if" } ++! ++! Allow logical expressions in if statements and blocks ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ PROGRAM logical_exp_if_st_bl ++ INTEGER ipos/1/ ++ INTEGER ineg/0/ ++ ++ ! Test non logical variables ++ if (ineg) STOP 1 ! { dg-error "IF clause at" } ++ if (0) STOP 2 ! { dg-error "IF clause at" } ++ ++ ! Test non logical expressions in if statements ++ if (MOD(ipos, 1)) STOP 3 ! { dg-error "IF clause at" } ++ ++ ! Test non logical expressions in if blocks ++ if (MOD(2 * ipos, 2)) then ! { dg-error "IF clause at" } ++ STOP 4 ++ endif ++ END +diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f +new file mode 100644 +index 00000000000..7b60b60827f +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f +@@ -0,0 +1,45 @@ ++! { dg-do run } ++! { dg-options "-fdec -Wconversion-extra" } ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ function othersub1() ++ integer*4 othersub1 ++ othersub1 = 9 ++ end ++ ++ function othersub2() ++ integer*4 othersub2 ++ othersub2 = 0 ++ end ++ ++ program MAIN ++ integer*4 othersub1 ++ integer*4 othersub2 ++ integer a /1/ ++ integer b /2/ ++ ++ if (othersub1()) then ! { dg-warning "if it evaluates to nonzero" } ++ write(*,*) "OK" ++ else ++ stop 1 ++ end if ++ if (othersub2()) then ! { dg-warning "if it evaluates to nonzero" } ++ stop 2 ++ else ++ write(*,*) "OK" ++ end if ++ if (a-b) then ! { dg-warning "if it evaluates to nonzero" } ++ write(*,*) "OK" ++ else ++ stop 3 ++ end if ++ if (b-(a+1)) then ! { dg-warning "if it evaluates to nonzero" } ++ stop 3 ++ else ++ write(*,*) "OK" ++ end if ++ end ++ +diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f +new file mode 100644 +index 00000000000..80336f48ca1 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f +@@ -0,0 +1,45 @@ ++! { dg-do run } ++! { dg-options "-fdec-non-logical-if -Wconversion-extra" } ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ function othersub1() ++ integer*4 othersub1 ++ othersub1 = 9 ++ end ++ ++ function othersub2() ++ integer*4 othersub2 ++ othersub2 = 0 ++ end ++ ++ program MAIN ++ integer*4 othersub1 ++ integer*4 othersub2 ++ integer a /1/ ++ integer b /2/ ++ ++ if (othersub1()) then ! { dg-warning "Non-LOGICAL type in IF statement" } ++ write(*,*) "OK" ++ else ++ stop 1 ++ end if ++ if (othersub2()) then ! { dg-warning "Non-LOGICAL type in IF statement" } ++ stop 2 ++ else ++ write(*,*) "OK" ++ end if ++ if (a-b) then ! { dg-warning "Non-LOGICAL type in IF statement" } ++ write(*,*) "OK" ++ else ++ stop 3 ++ end if ++ if (b-(a+1)) then ! { dg-warning "Non-LOGICAL type in IF statement" } ++ stop 3 ++ else ++ write(*,*) "OK" ++ end if ++ end ++ +diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f +new file mode 100644 +index 00000000000..e1125ca717a +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f +@@ -0,0 +1,45 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-non-logical-if" } ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ function othersub1() ++ integer*4 othersub1 ++ othersub1 = 9 ++ end ++ ++ function othersub2() ++ integer*4 othersub2 ++ othersub2 = 0 ++ end ++ ++ program MAIN ++ integer*4 othersub1 ++ integer*4 othersub2 ++ integer a /1/ ++ integer b /2/ ++ ++ if (othersub1()) then ! { dg-error "IF clause at" } ++ write(*,*) "OK" ++ else ++ stop 1 ++ end if ++ if (othersub2()) then ! { dg-error "IF clause at" } ++ stop 2 ++ else ++ write(*,*) "OK" ++ end if ++ if (a-b) then ! { dg-error "IF clause at" } ++ write(*,*) "OK" ++ else ++ stop 3 ++ end if ++ if (b-(a+1)) then ! { dg-error "IF clause at" } ++ stop 3 ++ else ++ write(*,*) "OK" ++ end if ++ end ++ +-- +2.11.0 + diff --git a/SOURCES/0008-Allow-non-integer-substring-indexes.patch b/SOURCES/0008-Allow-non-integer-substring-indexes.patch deleted file mode 100644 index b165df8..0000000 --- a/SOURCES/0008-Allow-non-integer-substring-indexes.patch +++ /dev/null @@ -1,158 +0,0 @@ -From 96563a652406d3c8471d75e6527ba634fa013400 Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Mon, 5 Oct 2015 14:05:03 +0100 -Subject: [PATCH 08/16] Allow non-integer substring indexes - -Use -fdec-non-integer-index compiler flag to enable. Also enabled by -fdec. ---- - gcc/fortran/lang.opt | 4 ++++ - gcc/fortran/options.c | 1 + - gcc/fortran/resolve.c | 20 ++++++++++++++++++++ - .../dec_not_integer_substring_indexes_1.f | 18 ++++++++++++++++++ - .../dec_not_integer_substring_indexes_2.f | 18 ++++++++++++++++++ - .../dec_not_integer_substring_indexes_3.f | 18 ++++++++++++++++++ - 6 files changed, 79 insertions(+) - create mode 100644 gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f - -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 3d8aaeaaf44..772cf5e81f1 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -474,6 +474,10 @@ fdec-math - Fortran Var(flag_dec_math) - Enable legacy math intrinsics for compatibility. - -+fdec-non-integer-index -+Fortran Var(flag_dec_non_integer_index) -+Enable support for non-integer substring indexes. -+ - fdec-structure - Fortran Var(flag_dec_structure) - Enable support for DEC STRUCTURE/RECORD. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index a8c2cf71c3b..e0ef03e6cc5 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -79,6 +79,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_char_conversions, value, value); - SET_BITFLAG (flag_dec_comparisons, value, value); - SET_BITFLAG (flag_dec_blank_format_item, value, value); -+ SET_BITFLAG (flag_dec_non_integer_index, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c -index c8b6333874b..04679d3a15d 100644 ---- a/gcc/fortran/resolve.c -+++ b/gcc/fortran/resolve.c -@@ -4992,6 +4992,16 @@ resolve_substring (gfc_ref *ref, bool *equal_length) - if (!gfc_resolve_expr (ref->u.ss.start)) - return false; - -+ /* In legacy mode, allow non-integer string indexes by converting */ -+ if (flag_dec_non_integer_index && 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", -@@ -5021,6 +5031,16 @@ resolve_substring (gfc_ref *ref, bool *equal_length) - if (!gfc_resolve_expr (ref->u.ss.end)) - return false; - -+ /* Non-integer string index endings, as for start */ -+ if (flag_dec_non_integer_index && 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_1.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_1.f -new file mode 100644 -index 00000000000..0be28abaa4b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_1.f -@@ -0,0 +1,18 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test not integer substring indexes -+! -+! Test case contributed by Mark Eggleston -+! -+ PROGRAM not_integer_substring_indexes -+ CHARACTER*5 st/'Tests'/ -+ REAL ir/1.0/ -+ REAL ir2/4.0/ -+ -+ if (st(ir:4).ne.'Test') stop 1 -+ if (st(1:ir2).ne.'Test') stop 2 -+ if (st(1.0:4).ne.'Test') stop 3 -+ if (st(1:4.0).ne.'Test') stop 4 -+ if (st(2.5:4).ne.'est') stop 5 -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f -new file mode 100644 -index 00000000000..3cf05296d0c ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_2.f -@@ -0,0 +1,18 @@ -+! { dg-do run } -+! { dg-options "-fdec-non-integer-index" } -+! -+! Test not integer substring indexes -+! -+! Test case contributed by Mark Eggleston -+! -+ PROGRAM not_integer_substring_indexes -+ CHARACTER*5 st/'Tests'/ -+ REAL ir/1.0/ -+ REAL ir2/4.0/ -+ -+ if (st(ir:4).ne.'Test') stop 1 -+ if (st(1:ir2).ne.'Test') stop 2 -+ if (st(1.0:4).ne.'Test') stop 3 -+ if (st(1:4.0).ne.'Test') stop 4 -+ if (st(2.5:4).ne.'est') stop 5 -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f -new file mode 100644 -index 00000000000..703de995897 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_not_integer_substring_indexes_3.f -@@ -0,0 +1,18 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-non-integer-index" } -+! -+! Test not integer substring indexes -+! -+! Test case contributed by Mark Eggleston -+! -+ PROGRAM not_integer_substring_indexes -+ CHARACTER*5 st/'Tests'/ -+ REAL ir/1.0/ -+ REAL ir2/4.0/ -+ -+ if (st(ir:4).ne.'Test') stop 1 ! { dg-error "Substring start index" } -+ if (st(1:ir2).ne.'Test') stop 2 ! { dg-error "Substring end index" } -+ if (st(1.0:4).ne.'Test') stop 3 ! { dg-error "Substring start index" } -+ if (st(1:4.0).ne.'Test') stop 4 ! { dg-error "Substring end index" } -+ if (st(2.5:4).ne.'est') stop 5 ! { dg-error "Substring start index" } -+ END --- -2.11.0 - diff --git a/SOURCES/0008-Support-type-promotion-in-calls-to-intrinsics.patch b/SOURCES/0008-Support-type-promotion-in-calls-to-intrinsics.patch new file mode 100644 index 0000000..614c5cf --- /dev/null +++ b/SOURCES/0008-Support-type-promotion-in-calls-to-intrinsics.patch @@ -0,0 +1,2150 @@ +From f68aa5f6a6d710f12005ca2ee34f27d6a8a68745 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 09:38:24 +0000 +Subject: [PATCH 08/10] Support type promotion in calls to intrinsics + +Use -fdec-promotion or -fdec to enable this feature. + +Merged 2 commits: worked on by Ben Brewer , +Francisco Redondo Marchena + +Re-worked by Mark Eggleston +--- + gcc/fortran/check.c | 71 +++++- + gcc/fortran/intrinsic.c | 5 + + gcc/fortran/iresolve.c | 91 ++++--- + gcc/fortran/lang.opt | 4 + + gcc/fortran/options.c | 1 + + gcc/fortran/simplify.c | 266 ++++++++++++++++----- + ...ec_intrinsic_int_real_array_const_promotion_1.f | 18 ++ + ...ec_intrinsic_int_real_array_const_promotion_2.f | 18 ++ + ...ec_intrinsic_int_real_array_const_promotion_3.f | 18 ++ + .../dec_intrinsic_int_real_const_promotion_1.f | 90 +++++++ + .../dec_intrinsic_int_real_const_promotion_2.f | 90 +++++++ + .../dec_intrinsic_int_real_const_promotion_3.f | 92 +++++++ + .../dec_intrinsic_int_real_promotion_1.f | 130 ++++++++++ + .../dec_intrinsic_int_real_promotion_2.f | 130 ++++++++++ + .../dec_intrinsic_int_real_promotion_3.f | 130 ++++++++++ + .../dec_intrinsic_int_real_promotion_4.f | 118 +++++++++ + .../dec_intrinsic_int_real_promotion_5.f | 118 +++++++++ + .../dec_intrinsic_int_real_promotion_6.f | 118 +++++++++ + .../dec_intrinsic_int_real_promotion_7.f | 118 +++++++++ + gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f | 40 ++++ + gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f | 40 ++++ + gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f | 39 +++ + 22 files changed, 1654 insertions(+), 91 deletions(-) + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f + +diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c +index 4c0b83e8e6f..d428068674f 100644 +--- a/gcc/fortran/check.c ++++ b/gcc/fortran/check.c +@@ -1393,12 +1393,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_promotion) ++ return check_int_real_promotion (a, p); ++ + if (!int_or_real_check (a, 0)) + return false; + +@@ -3716,6 +3744,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) + { +@@ -3740,7 +3803,10 @@ gfc_check_min_max (gfc_actual_arglist *arg) + return false; + } + +- return check_rest (x->ts.type, x->ts.kind, arg); ++ if (flag_dec_promotion && x->ts.type != BT_CHARACTER) ++ return check_rest_int_real (arg); ++ else ++ return check_rest (x->ts.type, x->ts.kind, arg); + } + + +@@ -5112,6 +5178,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr *shift) + bool + gfc_check_sign (gfc_expr *a, gfc_expr *b) + { ++ if (flag_dec_promotion) ++ return check_int_real_promotion (a, b); ++ + if (!int_or_real_check (a, 0)) + return false; + +diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c +index 30f9f14572b..1591f9dfc2f 100644 +--- a/gcc/fortran/intrinsic.c ++++ b/gcc/fortran/intrinsic.c +@@ -4430,6 +4430,11 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, + if (ts.kind == 0) + ts.kind = actual->expr->ts.kind; + ++ /* If kind promotion is allowed don't check for kind if it is smaller */ ++ if (flag_dec_promotion && ts.type == BT_INTEGER) ++ if (actual->expr->ts.kind < ts.kind) ++ ts.kind = actual->expr->ts.kind; ++ + if (!gfc_compare_types (&ts, &actual->expr->ts)) + { + if (error_flag) +diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c +index 73769615c20..df8a2fd4119 100644 +--- a/gcc/fortran/iresolve.c ++++ b/gcc/fortran/iresolve.c +@@ -817,19 +817,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); +@@ -1610,14 +1613,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); + } + +@@ -2110,19 +2116,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); +@@ -2132,19 +2141,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), +@@ -2519,9 +2531,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/lang.opt b/gcc/fortran/lang.opt +index 0a6b4263e22..aceef2aa180 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -501,6 +501,10 @@ fdec-old-init + Fortran Var(flag_dec_old_init) + Enable support for old style initializers in derived types. + ++fdec-promotion ++Fortran Var(flag_dec_promotion) ++Add support for type promotion in intrinsic arguments. ++ + fdec-structure + Fortran Var(flag_dec_structure) + Enable support for DEC STRUCTURE/RECORD. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index 86b28cfe3e6..82e5c9edf4b 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -82,6 +82,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_old_init, value, value); + SET_BITFLAG (flag_dec_override_kind, value, value); + SET_BITFLAG (flag_dec_non_logical_if, value, value); ++ SET_BITFLAG (flag_dec_promotion, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c +index 248fe05ee48..cebc811b233 100644 +--- a/gcc/fortran/simplify.c ++++ b/gcc/fortran/simplify.c +@@ -2301,39 +2301,79 @@ 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"); +@@ -4921,13 +4961,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) + { + 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: +@@ -5876,7 +5990,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; + +@@ -5887,18 +6003,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"); + } +@@ -5906,16 +6022,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"); +@@ -5928,7 +6052,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; + +@@ -5939,44 +6065,52 @@ 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"); +@@ -7532,27 +7666,41 @@ 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) ++ if (flag_sign_zero && y->ts.type == BT_REAL) + mpfr_copysign (result->value.real, x->value.real, y->value.real, +- GFC_RND_MODE); ++ 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_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f +new file mode 100644 +index 00000000000..25763852139 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f +@@ -0,0 +1,18 @@ ++! { 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 ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_array_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f +new file mode 100644 +index 00000000000..b78a46054f4 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f +@@ -0,0 +1,18 @@ ++! { dg-do compile } ++! { dg-options "-fdec-promotion" } ++! ++! Test promotion between integers and reals for mod and modulo where ++! A is a constant array and P is zero. ++! ++! Compilation errors are expected ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_array_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f +new file mode 100644 +index 00000000000..318ab5db97e +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f +@@ -0,0 +1,18 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-promotion" } ++! ++! Test promotion between integers and reals for mod and modulo where ++! A is a constant array and P is zero. ++! ++! Compilation errors are expected ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ program promotion_int_real_array_const ++ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } ++ a = mod([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } ++ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } ++ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } ++ end program +diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f +new file mode 100644 +index 00000000000..27eb2582bb2 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f +@@ -0,0 +1,90 @@ ++! { dg-do run } ++! { 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. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f +new file mode 100644 +index 00000000000..bdd017b7280 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f +@@ -0,0 +1,90 @@ ++! { dg-do run } ++! { dg-options "-fdec-promotion -finit-real=snan" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f +new file mode 100644 +index 00000000000..ce90a5667d6 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f +@@ -0,0 +1,92 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-promotion -finit-real=snan" } ++! ++! Test that there is no promotion between integers and reals in ++! intrinsic operations. ++! ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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) ! { dg-error "'a' and 'p' arguments" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 ++ m_r = MOD(4.0, 3) ! { dg-error "'a' and 'p' arguments" } ++ 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) ! { dg-error "'a' and 'p' arguments" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 7 ++ md_r = MODULO(4.0, 3) ! { dg-error "'a' and 'p' arguments" } ++ 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) ! { dg-error "'x' and 'y' arguments" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 11 ++ d_r = DIM(3, 4.0) ! { dg-error "'x' and 'y' arguments" } ++ 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) ! { dg-error "'b' argument" } ++ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 ++ s_r = SIGN(-4, 3.0) ! { dg-error "'b' argument" } ++ 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) ! { dg-error "'a2' argument" } ++ 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) ! { dg-error "'a2' argument" } ++ 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_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f +new file mode 100644 +index 00000000000..5c2cd931a4b +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f +@@ -0,0 +1,130 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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/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 00000000000..d64d468f7d1 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f +@@ -0,0 +1,130 @@ ++! { dg-do run } ++! { dg-options "-fdec-promotion" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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/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 00000000000..0708b666633 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f +@@ -0,0 +1,130 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-promotion" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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) ! { dg-error "'a' and 'p' arguments" } ++ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 ++ m_r = MOD(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } ++ 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) ! { dg-error "'a' and 'p' arguments" } ++ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 ++ md_r = MODULO(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } ++ 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) ! { dg-error "'x' and 'y' arguments" } ++ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 ++ d_r = DIM(b_i, a_r) ! { dg-error "'x' and 'y' arguments" } ++ 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) ! { dg-error "'b' argument" } ++ 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) ! { dg-error "'b' argument" } ++ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 ++ s_r = SIGN(a_r, -b_i) ! { dg-error "'b' argument" } ++ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 ++ s_r = SIGN(-a_i, b_r) ! { dg-error "'b' argument" } ++ 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) ! { dg-error "'a2' argument" } ++ 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) ! { dg-error "'a2' argument" } ++ 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/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f +new file mode 100644 +index 00000000000..efa4f236410 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f +@@ -0,0 +1,118 @@ ++! { 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. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_5.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f +new file mode 100644 +index 00000000000..d023af5086d +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f +@@ -0,0 +1,118 @@ ++! { dg-do compile } ++! { dg-options "-fdec-promotion" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_6.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f +new file mode 100644 +index 00000000000..00f8fb88f1b +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f +@@ -0,0 +1,118 @@ ++! { 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. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_7.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f +new file mode 100644 +index 00000000000..1d4150d81c0 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f +@@ -0,0 +1,118 @@ ++! { dg-do compile } ++! { dg-options "-fdec-promotion" } ++! ++! Test promotion between integers and reals in intrinsic operations. ++! These operations are: mod, modulo, dim, sign, min, max, minloc and ++! maxloc. ++! ++! Contributed by Francisco Redondo Marchena ++! and Jeff Law ++! Modified by Mark Eggleston ++! ++ 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_kind_promotion-1.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f +new file mode 100644 +index 00000000000..435bf98350c +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f +@@ -0,0 +1,40 @@ ++!{ dg-do run } ++!{ dg-options "-fdec" } ++! ++! integer types of a smaller kind than expected should be ++! accepted by type specific intrinsic functions ++! ++! Contributed by Mark Eggleston ++! ++ program test_small_type_promtion ++ implicit none ++ integer(1) :: a = 1 ++ integer :: i ++ if (iiabs(-9_1).ne.9) stop 1 ++ if (iabs(-9_1).ne.9) stop 2 ++ if (iabs(-9_2).ne.9) stop 3 ++ if (jiabs(-9_1).ne.9) stop 4 ++ if (jiabs(-9_2).ne.9) stop 5 ++ if (iishft(1_1, 2).ne.4) stop 6 ++ if (jishft(1_1, 2).ne.4) stop 7 ++ if (jishft(1_2, 2).ne.4) stop 8 ++ if (kishft(1_1, 2).ne.4) stop 9 ++ if (kishft(1_2, 2).ne.4) stop 10 ++ if (kishft(1_4, 2).ne.4) stop 11 ++ if (imod(17_1, 3).ne.2) stop 12 ++ if (jmod(17_1, 3).ne.2) stop 13 ++ if (jmod(17_2, 3).ne.2) stop 14 ++ if (kmod(17_1, 3).ne.2) stop 15 ++ if (kmod(17_2, 3).ne.2) stop 16 ++ if (kmod(17_4, 3).ne.2) stop 17 ++ if (inot(5_1).ne.-6) stop 18 ++ if (jnot(5_1).ne.-6) stop 19 ++ if (jnot(5_2).ne.-6) stop 20 ++ if (knot(5_1).ne.-6) stop 21 ++ if (knot(5_2).ne.-6) stop 22 ++ if (knot(5_4).ne.-6) stop 23 ++ if (isign(-77_1, 1).ne.77) stop 24 ++ if (isign(-77_1, -1).ne.-77) stop 25 ++ if (isign(-77_2, 1).ne.77) stop 26 ++ if (isign(-77_2, -1).ne.-77) stop 27 ++ end program +diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f +new file mode 100644 +index 00000000000..7b1697ca665 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f +@@ -0,0 +1,40 @@ ++!{ dg-do run } ++!{ dg-options "-fdec-intrinsic-ints -fdec-promotion" } ++! ++! integer types of a smaller kind than expected should be ++! accepted by type specific intrinsic functions ++! ++! Contributed by Mark Eggleston ++! ++ program test_small_type_promtion ++ implicit none ++ integer(1) :: a = 1 ++ integer :: i ++ if (iiabs(-9_1).ne.9) stop 1 ++ if (iabs(-9_1).ne.9) stop 2 ++ if (iabs(-9_2).ne.9) stop 3 ++ if (jiabs(-9_1).ne.9) stop 4 ++ if (jiabs(-9_2).ne.9) stop 5 ++ if (iishft(1_1, 2).ne.4) stop 6 ++ if (jishft(1_1, 2).ne.4) stop 7 ++ if (jishft(1_2, 2).ne.4) stop 8 ++ if (kishft(1_1, 2).ne.4) stop 9 ++ if (kishft(1_2, 2).ne.4) stop 10 ++ if (kishft(1_4, 2).ne.4) stop 11 ++ if (imod(17_1, 3).ne.2) stop 12 ++ if (jmod(17_1, 3).ne.2) stop 13 ++ if (jmod(17_2, 3).ne.2) stop 14 ++ if (kmod(17_1, 3).ne.2) stop 15 ++ if (kmod(17_2, 3).ne.2) stop 16 ++ if (kmod(17_4, 3).ne.2) stop 17 ++ if (inot(5_1).ne.-6) stop 18 ++ if (jnot(5_1).ne.-6) stop 19 ++ if (jnot(5_2).ne.-6) stop 20 ++ if (knot(5_1).ne.-6) stop 21 ++ if (knot(5_2).ne.-6) stop 22 ++ if (knot(5_4).ne.-6) stop 23 ++ if (isign(-77_1, 1).ne.77) stop 24 ++ if (isign(-77_1, -1).ne.-77) stop 25 ++ if (isign(-77_2, 1).ne.77) stop 26 ++ if (isign(-77_2, -1).ne.-77) stop 27 ++ end program +diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f +new file mode 100644 +index 00000000000..db8dff6c55d +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f +@@ -0,0 +1,39 @@ ++!{ dg-do compile } ++!{ dg-options "-fdec -fno-dec-promotion" } ++! ++! integer types of a smaller kind than expected should be ++! accepted by type specific intrinsic functions ++! ++! Contributed by Mark Eggleston ++! ++ program test_small_type_promtion ++ integer(1) :: a = 1 ++ integer :: i ++ if (iiabs(-9_1).ne.9) stop 1 ++ if (iabs(-9_1).ne.9) stop 2 ! { dg-error "type mismatch in argument" } ++ if (iabs(-9_2).ne.9) stop 3 ! { dg-error "type mismatch in argument" } ++ if (jiabs(-9_1).ne.9) stop 4 ++ if (jiabs(-9_2).ne.9) stop 5 ++ if (iishft(1_1, 2).ne.4) stop 6 ++ if (jishft(1_1, 2).ne.4) stop 7 ++ if (jishft(1_2, 2).ne.4) stop 8 ++ if (kishft(1_1, 2).ne.4) stop 9 ++ if (kishft(1_2, 2).ne.4) stop 10 ++ if (kishft(1_4, 2).ne.4) stop 11 ++ if (imod(17_1, 3).ne.2) stop 12 ++ if (jmod(17_1, 3).ne.2) stop 13 ++ if (jmod(17_2, 3).ne.2) stop 14 ++ if (kmod(17_1, 3).ne.2) stop 15 ++ if (kmod(17_2, 3).ne.2) stop 16 ++ if (kmod(17_4, 3).ne.2) stop 17 ++ if (inot(5_1).ne.-6) stop 18 ++ if (jnot(5_1).ne.-6) stop 19 ++ if (jnot(5_2).ne.-6) stop 20 ++ if (knot(5_1).ne.-6) stop 21 ++ if (knot(5_2).ne.-6) stop 22 ++ if (knot(5_4).ne.-6) stop 23 ++ if (isign(-77_1, 1).ne.77) stop 24 ! { dg-error "type mismatch in argument" } ++ if (isign(-77_1, -1).ne.-77) stop 25 ! { dg-error "type mismatch in argument" } ++ if (isign(-77_2, 1).ne.77) stop 26 ! { dg-error "type mismatch in argument" } ++ if (isign(-77_2, -1).ne.-77) stop 27 ! { dg-error "type mismatch in argument" } ++ end program +-- +2.11.0 + diff --git a/SOURCES/0009-Add-the-SEQUENCE-attribute-by-default-if-it-s-not.patch b/SOURCES/0009-Add-the-SEQUENCE-attribute-by-default-if-it-s-not.patch new file mode 100644 index 0000000..192de6f --- /dev/null +++ b/SOURCES/0009-Add-the-SEQUENCE-attribute-by-default-if-it-s-not.patch @@ -0,0 +1,262 @@ +From fa06ba3a82777721696d78a5718804e508b5bb55 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 09:39:48 +0000 +Subject: [PATCH 09/10] Add the SEQUENCE attribute by default if it's not + present. + +Use -fdec-sequence to enable this feature. Also enabled by -fdec. +--- + gcc/fortran/lang.opt | 4 ++ + gcc/fortran/options.c | 1 + + gcc/fortran/resolve.c | 13 +++-- + ...dec_add_SEQUENCE_to_COMMON_block_by_default_1.f | 57 ++++++++++++++++++++++ + ...dec_add_SEQUENCE_to_COMMON_block_by_default_2.f | 57 ++++++++++++++++++++++ + ...dec_add_SEQUENCE_to_COMMON_block_by_default_3.f | 57 ++++++++++++++++++++++ + 6 files changed, 186 insertions(+), 3 deletions(-) + create mode 100644 gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_1.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f + create mode 100644 gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index aceef2aa180..ca2c0e17350 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -505,6 +505,10 @@ fdec-promotion + Fortran Var(flag_dec_promotion) + Add support for type promotion in intrinsic arguments. + ++fdec-sequence ++Fortran Var(flag_dec_sequence) ++Add the SEQUENCE attribute by default if it's not present. ++ + fdec-structure + Fortran Var(flag_dec_structure) + Enable support for DEC STRUCTURE/RECORD. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index 82e5c9edf4b..9f594c6b4a3 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -83,6 +83,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_override_kind, value, value); + SET_BITFLAG (flag_dec_non_logical_if, value, value); + SET_BITFLAG (flag_dec_promotion, value, value); ++ SET_BITFLAG (flag_dec_sequence, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index e4bb0e79c80..10547704455 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -971,9 +971,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 (flag_dec_sequence) ++ /* 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_1.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_1.f +new file mode 100644 +index 00000000000..fe7b39625eb +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_1.f +@@ -0,0 +1,57 @@ ++! { dg-do run } ++! { dg-options "-fdec" } ++! ++! Test add default SEQUENCE attribute derived types appearing in ++! COMMON blocks and EQUIVALENCE statements. ++! ++! Contributed by Francisco Redondo Marchena ++! Modified by Mark Eggleston ++! ++ MODULE SEQ ++ TYPE STRUCT1 ++ INTEGER*4 ID ++ INTEGER*4 TYPE ++ INTEGER*8 DEFVAL ++ CHARACTER*(4) NAME ++ LOGICAL*1 NIL ++ END TYPE STRUCT1 ++ END MODULE ++ ++ SUBROUTINE A ++ USE SEQ ++ TYPE (STRUCT1) S ++ COMMON /BLOCK1/ S ++ IF (S%ID.NE.5) STOP 1 ++ IF (S%TYPE.NE.1000) STOP 2 ++ IF (S%DEFVAL.NE.-99) STOP 3 ++ IF (S%NAME.NE."JANE") STOP 4 ++ IF (S%NIL.NEQV..FALSE.) STOP 5 ++ END SUBROUTINE ++ ++ PROGRAM sequence_att_common ++ USE SEQ ++ IMPLICIT NONE ++ TYPE (STRUCT1) S1 ++ TYPE (STRUCT1) S2 ++ TYPE (STRUCT1) S3 ++ ++ EQUIVALENCE (S1,S2) ++ COMMON /BLOCK1/ S3 ++ ++ S1%ID = 5 ++ S1%TYPE = 1000 ++ S1%DEFVAL = -99 ++ S1%NAME = "JANE" ++ S1%NIL = .FALSE. ++ ++ IF (S2%ID.NE.5) STOP 1 ++ IF (S2%TYPE.NE.1000) STOP 2 ++ IF (S2%DEFVAL.NE.-99) STOP 3 ++ IF (S2%NAME.NE."JANE") STOP 4 ++ IF (S2%NIL.NEQV..FALSE.) STOP 5 ++ ++ S3 = S1 ++ ++ CALL A ++ ++ END +diff --git a/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f +new file mode 100644 +index 00000000000..83512f0f3a2 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f +@@ -0,0 +1,57 @@ ++! { dg-do run } ++! { dg-options "-fdec-sequence" } ++! ++! Test add default SEQUENCE attribute derived types appearing in ++! COMMON blocks and EQUIVALENCE statements. ++! ++! Contributed by Francisco Redondo Marchena ++! Modified by Mark Eggleston ++! ++ MODULE SEQ ++ TYPE STRUCT1 ++ INTEGER*4 ID ++ INTEGER*4 TYPE ++ INTEGER*8 DEFVAL ++ CHARACTER*(4) NAME ++ LOGICAL*1 NIL ++ END TYPE STRUCT1 ++ END MODULE ++ ++ SUBROUTINE A ++ USE SEQ ++ TYPE (STRUCT1) S ++ COMMON /BLOCK1/ S ++ IF (S%ID.NE.5) STOP 1 ++ IF (S%TYPE.NE.1000) STOP 2 ++ IF (S%DEFVAL.NE.-99) STOP 3 ++ IF (S%NAME.NE."JANE") STOP 4 ++ IF (S%NIL.NEQV..FALSE.) STOP 5 ++ END SUBROUTINE ++ ++ PROGRAM sequence_att_common ++ USE SEQ ++ IMPLICIT NONE ++ TYPE (STRUCT1) S1 ++ TYPE (STRUCT1) S2 ++ TYPE (STRUCT1) S3 ++ ++ EQUIVALENCE (S1,S2) ++ COMMON /BLOCK1/ S3 ++ ++ S1%ID = 5 ++ S1%TYPE = 1000 ++ S1%DEFVAL = -99 ++ S1%NAME = "JANE" ++ S1%NIL = .FALSE. ++ ++ IF (S2%ID.NE.5) STOP 1 ++ IF (S2%TYPE.NE.1000) STOP 2 ++ IF (S2%DEFVAL.NE.-99) STOP 3 ++ IF (S2%NAME.NE."JANE") STOP 4 ++ IF (S2%NIL.NEQV..FALSE.) STOP 5 ++ ++ S3 = S1 ++ ++ CALL A ++ ++ END +diff --git a/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f +new file mode 100644 +index 00000000000..26cd59f9090 +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f +@@ -0,0 +1,57 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-sequence" } ++! ++! Test add default SEQUENCE attribute derived types appearing in ++! COMMON blocks and EQUIVALENCE statements. ++! ++! Contributed by Francisco Redondo Marchena ++! Modified by Mark Eggleston ++! ++ MODULE SEQ ++ TYPE STRUCT1 ++ INTEGER*4 ID ++ INTEGER*4 TYPE ++ INTEGER*8 DEFVAL ++ CHARACTER*(4) NAME ++ LOGICAL*1 NIL ++ END TYPE STRUCT1 ++ END MODULE ++ ++ SUBROUTINE A ++ USE SEQ ++ TYPE (STRUCT1) S ! { dg-error "Derived type variable" } ++ COMMON /BLOCK1/ S ++ IF (S%ID.NE.5) STOP 1 ++ IF (S%TYPE.NE.1000) STOP 2 ++ IF (S%DEFVAL.NE.-99) STOP 3 ++ IF (S%NAME.NE."JANE") STOP 4 ++ IF (S%NIL.NEQV..FALSE.) STOP 5 ++ END SUBROUTINE ++ ++ PROGRAM sequence_att_common ++ USE SEQ ++ IMPLICIT NONE ++ TYPE (STRUCT1) S1 ++ TYPE (STRUCT1) S2 ++ TYPE (STRUCT1) S3 ! { dg-error "Derived type variable" } ++ ++ EQUIVALENCE (S1,S2) ! { dg-error "Derived type variable" } ++ COMMON /BLOCK1/ S3 ++ ++ S1%ID = 5 ++ S1%TYPE = 1000 ++ S1%DEFVAL = -99 ++ S1%NAME = "JANE" ++ S1%NIL = .FALSE. ++ ++ IF (S2%ID.NE.5) STOP 1 ++ IF (S2%TYPE.NE.1000) STOP 2 ++ IF (S2%DEFVAL.NE.-99) STOP 3 ++ IF (S2%NAME.NE."JANE") STOP 4 ++ IF (S2%NIL.NEQV..FALSE.) STOP 5 ++ ++ S3 = S1 ++ ++ CALL A ++ ++ END +-- +2.11.0 + diff --git a/SOURCES/0009-Allow-old-style-initializers-in-derived-types.patch b/SOURCES/0009-Allow-old-style-initializers-in-derived-types.patch deleted file mode 100644 index d9a3a9e..0000000 --- a/SOURCES/0009-Allow-old-style-initializers-in-derived-types.patch +++ /dev/null @@ -1,185 +0,0 @@ -From 772fea9acdac79164f3496f54ef4f63dd2562a0c Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Thu, 4 Feb 2016 16:00:30 +0000 -Subject: [PATCH 09/16] 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. - -Use -fdec-old-init to enable. Also enabled by -fdec. ---- - gcc/fortran/decl.c | 27 ++++++++++++++++++---- - gcc/fortran/lang.opt | 4 ++++ - gcc/fortran/options.c | 1 + - .../dec_derived_types_initialised_old_style_1.f | 25 ++++++++++++++++++++ - .../dec_derived_types_initialised_old_style_2.f | 25 ++++++++++++++++++++ - .../dec_derived_types_initialised_old_style_3.f | 26 +++++++++++++++++++++ - 6 files changed, 103 insertions(+), 5 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f - -diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c -index 66f1094aa3d..cdf161a7efa 100644 ---- a/gcc/fortran/decl.c -+++ b/gcc/fortran/decl.c -@@ -2739,12 +2739,29 @@ 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 (flag_dec_old_init) -+ { -+ /* 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/fortran/lang.opt b/gcc/fortran/lang.opt -index 772cf5e81f1..610d91b6cfd 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -478,6 +478,10 @@ fdec-non-integer-index - Fortran Var(flag_dec_non_integer_index) - Enable support for non-integer substring indexes. - -+fdec-old-init -+Fortran Var(flag_dec_old_init) -+Enable support for old style initializers in derived types. -+ - fdec-structure - Fortran Var(flag_dec_structure) - Enable support for DEC STRUCTURE/RECORD. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index e0ef03e6cc5..0aa16825980 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -80,6 +80,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_comparisons, value, value); - SET_BITFLAG (flag_dec_blank_format_item, value, value); - SET_BITFLAG (flag_dec_non_integer_index, value, value); -+ SET_BITFLAG (flag_dec_old_init, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f -new file mode 100644 -index 00000000000..eac4f9bfcf1 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f -@@ -0,0 +1,25 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test old style initializers in derived types -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ 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/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f -new file mode 100644 -index 00000000000..d904c8b2974 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f -@@ -0,0 +1,25 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec-old-init" } -+! -+! Test old style initializers in derived types -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ 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/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f -new file mode 100644 -index 00000000000..58c2b4b66cf ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f -@@ -0,0 +1,26 @@ -+! { dg-do compile } -+! { dg-options "-std=legacy -fdec -fno-dec-old-init" } -+! -+! Test old style initializers in derived types -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ -+ PROGRAM spec_in_var -+ TYPE STRUCT1 -+ INTEGER*4 ID /8/ ! { dg-error "Invalid old style initialization" } -+ INTEGER*4 TYPE /5/ ! { dg-error "Invalid old style initialization" } -+ INTEGER*8 DEFVAL /0/ ! { dg-error "Invalid old style initialization" } -+ CHARACTER*(5) NAME /'tests'/ ! { dg-error "Invalid old style initialization" } -+ LOGICAL*1 NIL /0/ ! { dg-error "Invalid old style initialization" } -+ END TYPE STRUCT1 -+ -+ TYPE (STRUCT1) SINST -+ -+ IF(SINST%ID.NE.8) STOP 1 ! { dg-error "'id' at \\(1\\) is not a member" } -+ IF(SINST%TYPE.NE.5) STOP 2 ! { dg-error "'type' at \\(1\\) is not a member" } -+ IF(SINST%DEFVAL.NE.0) STOP 3 ! { dg-error "'defval' at \\(1\\) is not a member" } -+ IF(SINST%NAME.NE.'tests') STOP 4 ! { dg-error "'name' at \\(1\\) is not a member" } -+ IF(SINST%NIL) STOP 5 ! { dg-error "'nil' at \\(1\\) is not a member" } -+ END --- -2.11.0 - diff --git a/SOURCES/0010-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch b/SOURCES/0010-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch deleted file mode 100644 index e4bde41..0000000 --- a/SOURCES/0010-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch +++ /dev/null @@ -1,587 +0,0 @@ -From 08e63b85674f146b5f242906d7d5f063b2abd31c Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Wed, 7 Oct 2015 17:04:06 -0400 -Subject: [PATCH 10/16] Allow string length and kind to be specified on a per - variable basis. - -This allows kind/length to be mixed with array specification in -declarations. - -e.g. - - INTEGER*4 x*2, y*8 - CHARACTER names*20(10) - REAL v(100)*8, vv*4(50) - -The per-variable size overrides the kind or length specified for the type. - -Use -fdec-override-kind to enable. Also enabled by -fdec. - -Note: this feature is a merger of two previously separate features. - -Now accepts named constants as kind parameters: - - INTEGER A - PARAMETER (A=2) - INTEGER B*(A) - -Contributed by Mark Eggleston - -Now rejects invalid kind parameters and prints error messages: - - INTEGER X*3 - -caused an internal compiler error. - -Contributed by Mark Eggleston ---- - gcc/fortran/decl.c | 156 ++++++++++++++++----- - gcc/fortran/lang.opt | 4 + - gcc/fortran/options.c | 1 + - .../dec_mixed_char_array_declaration_1.f | 13 ++ - .../dec_mixed_char_array_declaration_2.f | 13 ++ - .../dec_mixed_char_array_declaration_3.f | 13 ++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f | 31 ++++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f | 31 ++++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f | 31 ++++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f | 14 ++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f | 19 +++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f | 19 +++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f | 15 ++ - gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f | 14 ++ - 14 files changed, 340 insertions(+), 34 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f - -diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c -index cdf161a7efa..eb26bf3bc2d 100644 ---- a/gcc/fortran/decl.c -+++ b/gcc/fortran/decl.c -@@ -1153,6 +1153,54 @@ 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; -+ gfc_expr *expr = NULL; -+ -+ m = gfc_match_char ('*'); -+ if (m != MATCH_YES) -+ return m; -+ -+ m = gfc_match_small_literal_int (length, NULL); -+ if (m == MATCH_YES || m == MATCH_ERROR) -+ return m; -+ -+ if (gfc_match_char ('(') == MATCH_NO) -+ return MATCH_ERROR; -+ -+ m = gfc_match_expr (&expr); -+ if (m == MATCH_YES) -+ { -+ m = MATCH_ERROR; // Assume error -+ if (gfc_expr_check_typed (expr, gfc_current_ns, false)) -+ { -+ if ((expr->expr_type == EXPR_CONSTANT) -+ && (expr->ts.type == BT_INTEGER)) -+ { -+ *length = mpz_get_si(expr->value.integer); -+ m = MATCH_YES; -+ } -+ } -+ -+ if (m == MATCH_YES) -+ { -+ if (gfc_match_char (')') == MATCH_NO) -+ m = MATCH_ERROR; -+ } -+ } -+ -+ if (expr != NULL) -+ gfc_free_expr (expr); -+ 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 -@@ -2390,6 +2438,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 -@@ -2400,7 +2477,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; -@@ -2409,10 +2486,14 @@ variable_decl (int elem) - match m; - 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 -@@ -2461,6 +2542,28 @@ 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 (flag_dec_override_kind) -+ { -+ 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. */ - m = gfc_match_array_spec (&as, true, true); - if (m == MATCH_ERROR) -@@ -2579,40 +2682,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 -@@ -2714,6 +2789,19 @@ 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 (gfc_validate_kind (sym->ts.type, sym->ts.kind, true) < 0) -+ { -+ gfc_error ("Kind %d not supported for type %s at %C", -+ sym->ts.kind, gfc_basic_typename (sym->ts.type)); -+ return MATCH_ERROR; -+ } -+ } -+ - if (!check_function_name (name)) - { - m = MATCH_ERROR; -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 610d91b6cfd..38d31e620bf 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -478,6 +478,10 @@ fdec-non-integer-index - Fortran Var(flag_dec_non_integer_index) - Enable support for non-integer substring indexes. - -+fdec-override-kind -+Fortran Var(flag_dec_override_kind) -+Enable support for per variable kind specification. -+ - fdec-old-init - Fortran Var(flag_dec_old_init) - Enable support for old style initializers in derived types. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index 0aa16825980..720fd25b570 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -81,6 +81,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_blank_format_item, value, value); - SET_BITFLAG (flag_dec_non_integer_index, value, value); - SET_BITFLAG (flag_dec_old_init, value, value); -+ SET_BITFLAG (flag_dec_override_kind, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f -new file mode 100644 -index 00000000000..706ea4112a4 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_1.f -@@ -0,0 +1,13 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test character declaration with mixed string length and array specification -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ 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/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f -new file mode 100644 -index 00000000000..26d2acf01de ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_2.f -@@ -0,0 +1,13 @@ -+! { dg-do run } -+! { dg-options "-fdec-override-kind" } -+! -+! Test character declaration with mixed string length and array specification -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ 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/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f -new file mode 100644 -index 00000000000..76e4f0bdb93 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_mixed_char_array_declaration_3.f -@@ -0,0 +1,13 @@ -+! { dg-do compile } -+! { dg-options "-fdec-override-kind -fno-dec-override-kind" } -+! -+! Test character declaration with mixed string length and array specification -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ PROGRAM character_declaration -+ CHARACTER ASPEC_SLENGTH*2 (5) /'01','02','03','04','05'/ ! { dg-error "Syntax error" } -+ CHARACTER SLENGTH_ASPEC(5)*2 /'01','02','03','04','05'/ -+ if (ASPEC_SLENGTH(3).NE.SLENGTH_ASPEC(3)) STOP 1 ! { dg-error " Operands of comparison operator" } -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f -new file mode 100644 -index 00000000000..edd0f5874b7 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_1.f -@@ -0,0 +1,31 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test kind specification in variable not in type -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer*8 ai*1, bi*4, ci -+ real*4 ar*4, br*8, cr -+ -+ ai = 1 -+ ar = 1.0 -+ bi = 2 -+ br = 2.0 -+ ci = 3 -+ cr = 3.0 -+ -+ if (ai .ne. 1) stop 1 -+ if (abs(ar - 1.0) > 1.0D-6) stop 2 -+ if (bi .ne. 2) stop 3 -+ if (abs(br - 2.0) > 1.0D-6) stop 4 -+ if (ci .ne. 3) stop 5 -+ if (abs(cr - 3.0) > 1.0D-6) stop 6 -+ if (kind(ai) .ne. 1) stop 7 -+ if (kind(ar) .ne. 4) stop 8 -+ if (kind(bi) .ne. 4) stop 9 -+ if (kind(br) .ne. 8) stop 10 -+ if (kind(ci) .ne. 8) stop 11 -+ if (kind(cr) .ne. 4) stop 12 -+ end -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f -new file mode 100644 -index 00000000000..bfaba584dbb ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_2.f -@@ -0,0 +1,31 @@ -+! { dg-do run } -+! { dg-options "-fdec-override-kind" } -+! -+! Test kind specification in variable not in type -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer*8 ai*1, bi*4, ci -+ real*4 ar*4, br*8, cr -+ -+ ai = 1 -+ ar = 1.0 -+ bi = 2 -+ br = 2.0 -+ ci = 3 -+ cr = 3.0 -+ -+ if (ai .ne. 1) stop 1 -+ if (abs(ar - 1.0) > 1.0D-6) stop 2 -+ if (bi .ne. 2) stop 3 -+ if (abs(br - 2.0) > 1.0D-6) stop 4 -+ if (ci .ne. 3) stop 5 -+ if (abs(cr - 3.0) > 1.0D-6) stop 6 -+ if (kind(ai) .ne. 1) stop 7 -+ if (kind(ar) .ne. 4) stop 8 -+ if (kind(bi) .ne. 4) stop 9 -+ if (kind(br) .ne. 8) stop 10 -+ if (kind(ci) .ne. 8) stop 11 -+ if (kind(cr) .ne. 4) stop 12 -+ end -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f -new file mode 100644 -index 00000000000..5ff434e7466 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_3.f -@@ -0,0 +1,31 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-override-kind" } -+! -+! Test kind specification in variable not in type -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer*8 ai*1, bi*4, ci ! { dg-error "Syntax error" } -+ real*4 ar*4, br*8, cr ! { dg-error "Syntax error" } -+ -+ ai = 1 -+ ar = 1.0 -+ bi = 2 -+ br = 2.0 -+ ci = 3 -+ cr = 3.0 -+ -+ if (ai .ne. 1) stop 1 -+ if (abs(ar - 1.0) > 1.0D-6) stop 2 -+ if (bi .ne. 2) stop 3 -+ if (abs(br - 2.0) > 1.0D-6) stop 4 -+ if (ci .ne. 3) stop 5 -+ if (abs(cr - 3.0) > 1.0D-6) stop 6 -+ if (kind(ai) .ne. 1) stop 7 -+ if (kind(ar) .ne. 4) stop 8 -+ if (kind(bi) .ne. 4) stop 9 -+ if (kind(br) .ne. 8) stop 10 -+ if (kind(ci) .ne. 8) stop 11 -+ if (kind(cr) .ne. 4) stop 12 -+ end -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f -new file mode 100644 -index 00000000000..c01980e8b9d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_4.f -@@ -0,0 +1,14 @@ -+! { dg-do compile } -+! -+! Test kind specification in variable not in type. The per variable -+! kind specification is not enabled so these should fail -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer a -+ parameter(a=2) -+ integer b*(a) ! { dg-error "Syntax error" } -+ real c*(8) ! { dg-error "Syntax error" } -+ logical d*1_1 ! { dg-error "Syntax error" } -+ end -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f -new file mode 100644 -index 00000000000..e2f39da3f4f ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_5.f -@@ -0,0 +1,19 @@ -+! { dg-do run } -+! { dg-options "-fdec-override-kind" } -+! -+! Test kind specification in variable not in type -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer a -+ parameter(a=2) -+ integer b*(a) -+ real c*(8) -+ logical d*(1_1) -+ character e*(a) -+ if (kind(b).ne.2) stop 1 -+ if (kind(c).ne.8) stop 2 -+ if (kind(d).ne.1) stop 3 -+ if (len(e).ne.2) stop 4 -+ end -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f -new file mode 100644 -index 00000000000..569747874e3 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_6.f -@@ -0,0 +1,19 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test kind specification in variable not in type -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer a -+ parameter(a=2) -+ integer b*(a) -+ real c*(8) -+ logical d*(1_1) -+ character e*(a) -+ if (kind(b).ne.2) stop 1 -+ if (kind(c).ne.8) stop 2 -+ if (kind(d).ne.1) stop 3 -+ if (len(e).ne.2) stop 4 -+ end -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f -new file mode 100644 -index 00000000000..b975bfd15c5 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_7.f -@@ -0,0 +1,15 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-override-kind" } -+! -+! Test kind specification in variable not in type as the per variable -+! kind specification is not enables these should fail -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer a -+ parameter(a=2) -+ integer b*(a) ! { dg-error "Syntax error" } -+ real c*(8) ! { dg-error "Syntax error" } -+ logical d*1_1 ! { dg-error "Syntax error" } -+ end -diff --git a/gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f -new file mode 100644 -index 00000000000..85732e0bd85 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_spec_in_variable_8.f -@@ -0,0 +1,14 @@ -+! { dg-do compile } -+! { dg-options "-fdec" } -+! -+! Check that invalid kind values are rejected. -+! -+! Contributed by Mark Eggleston -+! -+ program spec_in_var -+ integer a -+ parameter(a=3) -+ integer b*(a) ! { dg-error "Kind 3 not supported" } -+ real c*(78) ! { dg-error "Kind 78 not supported" } -+ logical d*(*) ! { dg-error "Invalid character" } -+ end --- -2.11.0 - diff --git a/SOURCES/0010-Fill-in-missing-array-dimensions-using-the-lower-bou.patch b/SOURCES/0010-Fill-in-missing-array-dimensions-using-the-lower-bou.patch new file mode 100644 index 0000000..e2423a9 --- /dev/null +++ b/SOURCES/0010-Fill-in-missing-array-dimensions-using-the-lower-bou.patch @@ -0,0 +1,181 @@ +From 21fd7a71d28847103921036595e0dbeac125aa44 Mon Sep 17 00:00:00 2001 +From: Mark Eggleston +Date: Mon, 3 Feb 2020 10:56:36 +0000 +Subject: [PATCH 10/10] Fill in missing array dimensions using the lower bound + +Use -fdec-add-missing-indexes to enable feature. Also enabled by fdec. +--- + gcc/fortran/lang.opt | 8 ++++++++ + gcc/fortran/options.c | 1 + + gcc/fortran/resolve.c | 24 ++++++++++++++++++++++++ + gcc/testsuite/gfortran.dg/array_6.f90 | 23 +++++++++++++++++++++++ + gcc/testsuite/gfortran.dg/array_7.f90 | 23 +++++++++++++++++++++++ + gcc/testsuite/gfortran.dg/array_8.f90 | 23 +++++++++++++++++++++++ + 6 files changed, 102 insertions(+) + create mode 100644 gcc/testsuite/gfortran.dg/array_6.f90 + create mode 100644 gcc/testsuite/gfortran.dg/array_7.f90 + create mode 100644 gcc/testsuite/gfortran.dg/array_8.f90 + +diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt +index ca2c0e17350..eb58f00f1c0 100644 +--- a/gcc/fortran/lang.opt ++++ b/gcc/fortran/lang.opt +@@ -281,6 +281,10 @@ Wmissing-include-dirs + Fortran + ; Documented in C/C++ + ++Wmissing-index ++Fortran Var(warn_missing_index) Warning LangEnabledBy(Fortran,Wall) ++Warn that the lower bound of a missing index will be used. ++ + Wuse-without-only + Fortran Var(warn_use_without_only) Warning + Warn about USE statements that have no ONLY qualifier. +@@ -456,6 +460,10 @@ fdec + Fortran Var(flag_dec) + Enable all DEC language extensions. + ++fdec-add-missing-indexes ++Fortran Var(flag_dec_add_missing_indexes) ++Enable the addition of missing indexes using their lower bounds. ++ + fdec-blank-format-item + Fortran Var(flag_dec_blank_format_item) + Enable the use of blank format items in format strings. +diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c +index 9f594c6b4a3..92dd74af21d 100644 +--- a/gcc/fortran/options.c ++++ b/gcc/fortran/options.c +@@ -84,6 +84,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_non_logical_if, value, value); + SET_BITFLAG (flag_dec_promotion, value, value); + SET_BITFLAG (flag_dec_sequence, value, value); ++ SET_BITFLAG (flag_dec_add_missing_indexes, value, value); + } + + /* Finalize DEC flags. */ +diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c +index 10547704455..2818d220975 100644 +--- a/gcc/fortran/resolve.c ++++ b/gcc/fortran/resolve.c +@@ -4771,6 +4771,30 @@ compare_spec_to_ref (gfc_array_ref *ar) + if (ar->type == AR_FULL) + return true; + ++ if (flag_dec_add_missing_indexes && as->rank > ar->dimen) ++ { ++ /* Add in the missing dimensions, assuming they are the lower bound ++ of that dimension if not specified. */ ++ int j; ++ if (warn_missing_index) ++ { ++ gfc_warning (OPT_Wmissing_index, "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 00000000000..5c26e18ab3e +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/array_6.f90 +@@ -0,0 +1,23 @@ ++! { dg-do run } ++! { dg-options "-fdec -Wmissing-index" }! ++! Checks that under-specified arrays (referencing arrays with fewer ++! dimensions than the array spec) generates a warning. ++! ++! Contributed by Jim MacArthur ++! Updated by Mark Eggleston ++! ++ ++program under_specified_array ++ integer chessboard(8,8) ++ integer chessboard3d(8,8,3:5) ++ chessboard(3,1) = 5 ++ chessboard(3,2) = 55 ++ chessboard3d(4,1,3) = 6 ++ chessboard3d(4,1,4) = 66 ++ chessboard3d(4,4,3) = 7 ++ chessboard3d(4,4,4) = 77 ++ ++ if (chessboard(3).ne.5) stop 1 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } ++ if (chessboard3d(4).ne.6) stop 2 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } ++ if (chessboard3d(4,4).ne.7) stop 3 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } ++end program +diff --git a/gcc/testsuite/gfortran.dg/array_7.f90 b/gcc/testsuite/gfortran.dg/array_7.f90 +new file mode 100644 +index 00000000000..5588a5bd02d +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/array_7.f90 +@@ -0,0 +1,23 @@ ++! { dg-do run } ++! { dg-options "-fdec-add-missing-indexes -Wmissing-index" }! ++! Checks that under-specified arrays (referencing arrays with fewer ++! dimensions than the array spec) generates a warning. ++! ++! Contributed by Jim MacArthur ++! Updated by Mark Eggleston ++! ++ ++program under_specified_array ++ integer chessboard(8,8) ++ integer chessboard3d(8,8,3:5) ++ chessboard(3,1) = 5 ++ chessboard(3,2) = 55 ++ chessboard3d(4,1,3) = 6 ++ chessboard3d(4,1,4) = 66 ++ chessboard3d(4,4,3) = 7 ++ chessboard3d(4,4,4) = 77 ++ ++ if (chessboard(3).ne.5) stop 1 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } ++ if (chessboard3d(4).ne.6) stop 2 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } ++ if (chessboard3d(4,4).ne.7) stop 3 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } ++end program +diff --git a/gcc/testsuite/gfortran.dg/array_8.f90 b/gcc/testsuite/gfortran.dg/array_8.f90 +new file mode 100644 +index 00000000000..f0d2ef5e37d +--- /dev/null ++++ b/gcc/testsuite/gfortran.dg/array_8.f90 +@@ -0,0 +1,23 @@ ++! { dg-do compile } ++! { dg-options "-fdec -fno-dec-add-missing-indexes" }! ++! Checks that under-specified arrays (referencing arrays with fewer ++! dimensions than the array spec) generates a warning. ++! ++! Contributed by Jim MacArthur ++! Updated by Mark Eggleston ++! ++ ++program under_specified_array ++ integer chessboard(8,8) ++ integer chessboard3d(8,8,3:5) ++ chessboard(3,1) = 5 ++ chessboard(3,2) = 55 ++ chessboard3d(4,1,3) = 6 ++ chessboard3d(4,1,4) = 66 ++ chessboard3d(4,4,3) = 7 ++ chessboard3d(4,4,4) = 77 ++ ++ if (chessboard(3).ne.5) stop 1 ! { dg-error "Rank mismatch" } ++ if (chessboard3d(4).ne.6) stop 2 ! { dg-error "Rank mismatch" } ++ if (chessboard3d(4,4).ne.7) stop 3 ! { dg-error "Rank mismatch" } ++end program +-- +2.11.0 + diff --git a/SOURCES/0011-Allow-non-logical-expressions-in-IF-statements.patch b/SOURCES/0011-Allow-non-logical-expressions-in-IF-statements.patch deleted file mode 100644 index 7152a0b..0000000 --- a/SOURCES/0011-Allow-non-logical-expressions-in-IF-statements.patch +++ /dev/null @@ -1,378 +0,0 @@ -From f6197d0e59059a172f68a697e25cd585ad158937 Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Wed, 11 Nov 2015 15:37:00 +0000 -Subject: [PATCH 11/16] Allow non-logical expressions in IF statements - -Use -fdec-non-logical-if to enable feature. Also enabled using -fdec. ---- - gcc/fortran/lang.opt | 4 ++ - gcc/fortran/options.c | 1 + - gcc/fortran/resolve.c | 60 ++++++++++++++++++---- - ...ec_logical_expressions_if_statements_blocks_1.f | 25 +++++++++ - ...ec_logical_expressions_if_statements_blocks_2.f | 25 +++++++++ - ...ec_logical_expressions_if_statements_blocks_3.f | 25 +++++++++ - ...ec_logical_expressions_if_statements_blocks_4.f | 45 ++++++++++++++++ - ...ec_logical_expressions_if_statements_blocks_5.f | 45 ++++++++++++++++ - ...ec_logical_expressions_if_statements_blocks_6.f | 45 ++++++++++++++++ - 9 files changed, 266 insertions(+), 9 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f - -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 38d31e620bf..fa2851ae837 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -482,6 +482,10 @@ fdec-override-kind - Fortran Var(flag_dec_override_kind) - Enable support for per variable kind specification. - -+fdec-non-logical-if -+Fortran Var(flag_dec_non_logical_if) -+Enable support for non-logical expressions in if statements. -+ - fdec-old-init - Fortran Var(flag_dec_old_init) - Enable support for old style initializers in derived types. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index 720fd25b570..7b04a681f7b 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -82,6 +82,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_non_integer_index, value, value); - SET_BITFLAG (flag_dec_old_init, value, value); - SET_BITFLAG (flag_dec_override_kind, value, value); -+ SET_BITFLAG (flag_dec_non_logical_if, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c -index 04679d3a15d..a90f7f849b5 100644 ---- a/gcc/fortran/resolve.c -+++ b/gcc/fortran/resolve.c -@@ -10398,10 +10398,31 @@ 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 (flag_dec_non_logical_if && 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; -+ if (warn_conversion_extra) -+ { -+ gfc_warning (OPT_Wconversion_extra, "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: -@@ -11690,11 +11711,32 @@ 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 (flag_dec_non_logical_if -+ && 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; -+ if (warn_conversion_extra) -+ { -+ gfc_warning (OPT_Wconversion_extra, "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_1.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_1.f -new file mode 100644 -index 00000000000..0101db893ca ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_1.f -@@ -0,0 +1,25 @@ -+! { dg-do run } -+! { dg-options "-fdec -Wconversion-extra" } -+! -+! Allow logical expressions in if statements and blocks -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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 -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..876f4e09508 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_2.f -@@ -0,0 +1,25 @@ -+! { dg-do run } -+! { dg-options "-fdec-non-logical-if -Wconversion-extra" } -+! -+! Allow logical expressions in if statements and blocks -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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 -diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f -new file mode 100644 -index 00000000000..35cb4c51b8d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_3.f -@@ -0,0 +1,25 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-non-logical-if" } -+! -+! Allow logical expressions in if statements and blocks -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM logical_exp_if_st_bl -+ INTEGER ipos/1/ -+ INTEGER ineg/0/ -+ -+ ! Test non logical variables -+ if (ineg) STOP 1 ! { dg-error "IF clause at" } -+ if (0) STOP 2 ! { dg-error "IF clause at" } -+ -+ ! Test non logical expressions in if statements -+ if (MOD(ipos, 1)) STOP 3 ! { dg-error "IF clause at" } -+ -+ ! Test non logical expressions in if blocks -+ if (MOD(2 * ipos, 2)) then ! { dg-error "IF clause at" } -+ STOP 4 -+ endif -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f -new file mode 100644 -index 00000000000..7b60b60827f ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_4.f -@@ -0,0 +1,45 @@ -+! { dg-do run } -+! { dg-options "-fdec -Wconversion-extra" } -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ function othersub1() -+ integer*4 othersub1 -+ othersub1 = 9 -+ end -+ -+ function othersub2() -+ integer*4 othersub2 -+ othersub2 = 0 -+ end -+ -+ program MAIN -+ integer*4 othersub1 -+ integer*4 othersub2 -+ integer a /1/ -+ integer b /2/ -+ -+ if (othersub1()) then ! { dg-warning "if it evaluates to nonzero" } -+ write(*,*) "OK" -+ else -+ stop 1 -+ end if -+ if (othersub2()) then ! { dg-warning "if it evaluates to nonzero" } -+ stop 2 -+ else -+ write(*,*) "OK" -+ end if -+ if (a-b) then ! { dg-warning "if it evaluates to nonzero" } -+ write(*,*) "OK" -+ else -+ stop 3 -+ end if -+ if (b-(a+1)) then ! { dg-warning "if it evaluates to nonzero" } -+ stop 3 -+ else -+ write(*,*) "OK" -+ end if -+ end -+ -diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f -new file mode 100644 -index 00000000000..80336f48ca1 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_5.f -@@ -0,0 +1,45 @@ -+! { dg-do run } -+! { dg-options "-fdec-non-logical-if -Wconversion-extra" } -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ function othersub1() -+ integer*4 othersub1 -+ othersub1 = 9 -+ end -+ -+ function othersub2() -+ integer*4 othersub2 -+ othersub2 = 0 -+ end -+ -+ program MAIN -+ integer*4 othersub1 -+ integer*4 othersub2 -+ integer a /1/ -+ integer b /2/ -+ -+ if (othersub1()) then ! { dg-warning "Non-LOGICAL type in IF statement" } -+ write(*,*) "OK" -+ else -+ stop 1 -+ end if -+ if (othersub2()) then ! { dg-warning "Non-LOGICAL type in IF statement" } -+ stop 2 -+ else -+ write(*,*) "OK" -+ end if -+ if (a-b) then ! { dg-warning "Non-LOGICAL type in IF statement" } -+ write(*,*) "OK" -+ else -+ stop 3 -+ end if -+ if (b-(a+1)) then ! { dg-warning "Non-LOGICAL type in IF statement" } -+ stop 3 -+ else -+ write(*,*) "OK" -+ end if -+ end -+ -diff --git a/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f -new file mode 100644 -index 00000000000..e1125ca717a ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_logical_expressions_if_statements_blocks_6.f -@@ -0,0 +1,45 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-non-logical-if" } -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ function othersub1() -+ integer*4 othersub1 -+ othersub1 = 9 -+ end -+ -+ function othersub2() -+ integer*4 othersub2 -+ othersub2 = 0 -+ end -+ -+ program MAIN -+ integer*4 othersub1 -+ integer*4 othersub2 -+ integer a /1/ -+ integer b /2/ -+ -+ if (othersub1()) then ! { dg-error "IF clause at" } -+ write(*,*) "OK" -+ else -+ stop 1 -+ end if -+ if (othersub2()) then ! { dg-error "IF clause at" } -+ stop 2 -+ else -+ write(*,*) "OK" -+ end if -+ if (a-b) then ! { dg-error "IF clause at" } -+ write(*,*) "OK" -+ else -+ stop 3 -+ end if -+ if (b-(a+1)) then ! { dg-error "IF clause at" } -+ stop 3 -+ else -+ write(*,*) "OK" -+ end if -+ end -+ --- -2.11.0 - diff --git a/SOURCES/0012-Support-type-promotion-in-calls-to-intrinsics.patch b/SOURCES/0012-Support-type-promotion-in-calls-to-intrinsics.patch deleted file mode 100644 index 3b67735..0000000 --- a/SOURCES/0012-Support-type-promotion-in-calls-to-intrinsics.patch +++ /dev/null @@ -1,2151 +0,0 @@ -From 79bc3c8c15122dd929703f5ca7e468ffd46c3c3e Mon Sep 17 00:00:00 2001 -From: Francisco Redondo Marchena -Date: Mon, 9 Apr 2018 15:10:02 +0100 -Subject: [PATCH 12/16] Support type promotion in calls to intrinsics - -Use -fdec-promotion or -fdec to enable this feature. - -Merged 2 commits: worked on by Ben Brewer , -Francisco Redondo Marchena - -Re-worked by Mark Eggleston ---- - gcc/fortran/check.c | 71 +++++- - gcc/fortran/intrinsic.c | 5 + - gcc/fortran/iresolve.c | 91 ++++--- - gcc/fortran/lang.opt | 4 + - gcc/fortran/options.c | 1 + - gcc/fortran/simplify.c | 266 ++++++++++++++++----- - ...ec_intrinsic_int_real_array_const_promotion_1.f | 18 ++ - ...ec_intrinsic_int_real_array_const_promotion_2.f | 18 ++ - ...ec_intrinsic_int_real_array_const_promotion_3.f | 18 ++ - .../dec_intrinsic_int_real_const_promotion_1.f | 90 +++++++ - .../dec_intrinsic_int_real_const_promotion_2.f | 90 +++++++ - .../dec_intrinsic_int_real_const_promotion_3.f | 92 +++++++ - .../dec_intrinsic_int_real_promotion_1.f | 130 ++++++++++ - .../dec_intrinsic_int_real_promotion_2.f | 130 ++++++++++ - .../dec_intrinsic_int_real_promotion_3.f | 130 ++++++++++ - .../dec_intrinsic_int_real_promotion_4.f | 118 +++++++++ - .../dec_intrinsic_int_real_promotion_5.f | 118 +++++++++ - .../dec_intrinsic_int_real_promotion_6.f | 118 +++++++++ - .../dec_intrinsic_int_real_promotion_7.f | 118 +++++++++ - gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f | 40 ++++ - gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f | 40 ++++ - gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f | 40 ++++ - 22 files changed, 1655 insertions(+), 91 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f - -diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c -index 0ba4d0a031f..89416ba368d 100644 ---- a/gcc/fortran/check.c -+++ b/gcc/fortran/check.c -@@ -947,12 +947,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_promotion) -+ return check_int_real_promotion (a, p); -+ - if (!int_or_real_check (a, 0)) - return false; - -@@ -3126,6 +3154,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) - { -@@ -3150,7 +3213,10 @@ gfc_check_min_max (gfc_actual_arglist *arg) - return false; - } - -- return check_rest (x->ts.type, x->ts.kind, arg); -+ if (flag_dec_promotion && x->ts.type != BT_CHARACTER) -+ return check_rest_int_real (arg); -+ else -+ return check_rest (x->ts.type, x->ts.kind, arg); - } - - -@@ -4488,6 +4554,9 @@ gfc_check_shift (gfc_expr *i, gfc_expr *shift) - bool - gfc_check_sign (gfc_expr *a, gfc_expr *b) - { -+ if (flag_dec_promotion) -+ return check_int_real_promotion (a, b); -+ - if (!int_or_real_check (a, 0)) - return false; - -diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c -index 6d47ae3105f..a4b23bc244a 100644 ---- a/gcc/fortran/intrinsic.c -+++ b/gcc/fortran/intrinsic.c -@@ -4329,6 +4329,11 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, - if (ts.kind == 0) - ts.kind = actual->expr->ts.kind; - -+ /* If kind promotion is allowed don't check for kind if it is smaller */ -+ if (flag_dec_promotion && ts.type == BT_INTEGER) -+ if (actual->expr->ts.kind < ts.kind) -+ ts.kind = actual->expr->ts.kind; -+ - if (!gfc_compare_types (&ts, &actual->expr->ts)) - { - if (error_flag) -diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c -index 53338dda0a7..92d50c3deb9 100644 ---- a/gcc/fortran/iresolve.c -+++ b/gcc/fortran/iresolve.c -@@ -893,19 +893,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); -@@ -1669,14 +1672,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); - } - -@@ -2169,19 +2175,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); -@@ -2191,19 +2200,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), -@@ -2578,9 +2590,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/lang.opt b/gcc/fortran/lang.opt -index fa2851ae837..2a8f5f661a8 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -490,6 +490,10 @@ fdec-old-init - Fortran Var(flag_dec_old_init) - Enable support for old style initializers in derived types. - -+fdec-promotion -+Fortran Var(flag_dec_promotion) -+Add support for type promotion in intrinsic arguments. -+ - fdec-structure - Fortran Var(flag_dec_structure) - Enable support for DEC STRUCTURE/RECORD. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index 7b04a681f7b..7a2583a2076 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -83,6 +83,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_old_init, value, value); - SET_BITFLAG (flag_dec_override_kind, value, value); - SET_BITFLAG (flag_dec_non_logical_if, value, value); -+ SET_BITFLAG (flag_dec_promotion, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c -index 7aff256c6b3..cb5f93e293d 100644 ---- a/gcc/fortran/simplify.c -+++ b/gcc/fortran/simplify.c -@@ -2256,39 +2256,79 @@ 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"); -@@ -4886,13 +4926,87 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) - { - 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: -@@ -5841,7 +5955,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; - -@@ -5852,18 +5968,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"); - } -@@ -5871,16 +5987,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"); -@@ -5893,7 +6017,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; - -@@ -5904,44 +6030,52 @@ 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"); -@@ -7442,27 +7576,41 @@ 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) -+ if (flag_sign_zero && y->ts.type == BT_REAL) - mpfr_copysign (result->value.real, x->value.real, y->value.real, -- GFC_RND_MODE); -+ 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_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f -new file mode 100644 -index 00000000000..25763852139 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f -@@ -0,0 +1,18 @@ -+! { 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 -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_array_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f -new file mode 100644 -index 00000000000..b78a46054f4 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f -@@ -0,0 +1,18 @@ -+! { dg-do compile } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals for mod and modulo where -+! A is a constant array and P is zero. -+! -+! Compilation errors are expected -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_array_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f -new file mode 100644 -index 00000000000..318ab5db97e ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f -@@ -0,0 +1,18 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-promotion" } -+! -+! Test promotion between integers and reals for mod and modulo where -+! A is a constant array and P is zero. -+! -+! Compilation errors are expected -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ program promotion_int_real_array_const -+ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } -+ a = mod([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } -+ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } -+ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f -new file mode 100644 -index 00000000000..27eb2582bb2 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f -@@ -0,0 +1,90 @@ -+! { dg-do run } -+! { 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. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f -new file mode 100644 -index 00000000000..bdd017b7280 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f -@@ -0,0 +1,90 @@ -+! { dg-do run } -+! { dg-options "-fdec-promotion -finit-real=snan" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f -new file mode 100644 -index 00000000000..ce90a5667d6 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f -@@ -0,0 +1,92 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-promotion -finit-real=snan" } -+! -+! Test that there is no promotion between integers and reals in -+! intrinsic operations. -+! -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(4.0, 3) ! { dg-error "'a' and 'p' arguments" } -+ 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) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 7 -+ md_r = MODULO(4.0, 3) ! { dg-error "'a' and 'p' arguments" } -+ 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) ! { dg-error "'x' and 'y' arguments" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 11 -+ d_r = DIM(3, 4.0) ! { dg-error "'x' and 'y' arguments" } -+ 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) ! { dg-error "'b' argument" } -+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 -+ s_r = SIGN(-4, 3.0) ! { dg-error "'b' argument" } -+ 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) ! { dg-error "'a2' argument" } -+ 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) ! { dg-error "'a2' argument" } -+ 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_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f -new file mode 100644 -index 00000000000..5c2cd931a4b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f -@@ -0,0 +1,130 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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/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 00000000000..d64d468f7d1 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f -@@ -0,0 +1,130 @@ -+! { dg-do run } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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/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 00000000000..0708b666633 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f -@@ -0,0 +1,130 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } -+ 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) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } -+ 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) ! { dg-error "'x' and 'y' arguments" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_i, a_r) ! { dg-error "'x' and 'y' arguments" } -+ 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) ! { dg-error "'b' argument" } -+ 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) ! { dg-error "'b' argument" } -+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 -+ s_r = SIGN(a_r, -b_i) ! { dg-error "'b' argument" } -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 -+ s_r = SIGN(-a_i, b_r) ! { dg-error "'b' argument" } -+ 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) ! { dg-error "'a2' argument" } -+ 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) ! { dg-error "'a2' argument" } -+ 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/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f -new file mode 100644 -index 00000000000..efa4f236410 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f -@@ -0,0 +1,118 @@ -+! { 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. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_5.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f -new file mode 100644 -index 00000000000..d023af5086d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f -@@ -0,0 +1,118 @@ -+! { dg-do compile } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_6.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f -new file mode 100644 -index 00000000000..00f8fb88f1b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f -@@ -0,0 +1,118 @@ -+! { 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. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_7.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f -new file mode 100644 -index 00000000000..1d4150d81c0 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f -@@ -0,0 +1,118 @@ -+! { dg-do compile } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ 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_kind_promotion-1.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f -new file mode 100644 -index 00000000000..435bf98350c ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f -@@ -0,0 +1,40 @@ -+!{ dg-do run } -+!{ dg-options "-fdec" } -+! -+! integer types of a smaller kind than expected should be -+! accepted by type specific intrinsic functions -+! -+! Contributed by Mark Eggleston -+! -+ program test_small_type_promtion -+ implicit none -+ integer(1) :: a = 1 -+ integer :: i -+ if (iiabs(-9_1).ne.9) stop 1 -+ if (iabs(-9_1).ne.9) stop 2 -+ if (iabs(-9_2).ne.9) stop 3 -+ if (jiabs(-9_1).ne.9) stop 4 -+ if (jiabs(-9_2).ne.9) stop 5 -+ if (iishft(1_1, 2).ne.4) stop 6 -+ if (jishft(1_1, 2).ne.4) stop 7 -+ if (jishft(1_2, 2).ne.4) stop 8 -+ if (kishft(1_1, 2).ne.4) stop 9 -+ if (kishft(1_2, 2).ne.4) stop 10 -+ if (kishft(1_4, 2).ne.4) stop 11 -+ if (imod(17_1, 3).ne.2) stop 12 -+ if (jmod(17_1, 3).ne.2) stop 13 -+ if (jmod(17_2, 3).ne.2) stop 14 -+ if (kmod(17_1, 3).ne.2) stop 15 -+ if (kmod(17_2, 3).ne.2) stop 16 -+ if (kmod(17_4, 3).ne.2) stop 17 -+ if (inot(5_1).ne.-6) stop 18 -+ if (jnot(5_1).ne.-6) stop 19 -+ if (jnot(5_2).ne.-6) stop 20 -+ if (knot(5_1).ne.-6) stop 21 -+ if (knot(5_2).ne.-6) stop 22 -+ if (knot(5_4).ne.-6) stop 23 -+ if (isign(-77_1, 1).ne.77) stop 24 -+ if (isign(-77_1, -1).ne.-77) stop 25 -+ if (isign(-77_2, 1).ne.77) stop 26 -+ if (isign(-77_2, -1).ne.-77) stop 27 -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f -new file mode 100644 -index 00000000000..7b1697ca665 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f -@@ -0,0 +1,40 @@ -+!{ dg-do run } -+!{ dg-options "-fdec-intrinsic-ints -fdec-promotion" } -+! -+! integer types of a smaller kind than expected should be -+! accepted by type specific intrinsic functions -+! -+! Contributed by Mark Eggleston -+! -+ program test_small_type_promtion -+ implicit none -+ integer(1) :: a = 1 -+ integer :: i -+ if (iiabs(-9_1).ne.9) stop 1 -+ if (iabs(-9_1).ne.9) stop 2 -+ if (iabs(-9_2).ne.9) stop 3 -+ if (jiabs(-9_1).ne.9) stop 4 -+ if (jiabs(-9_2).ne.9) stop 5 -+ if (iishft(1_1, 2).ne.4) stop 6 -+ if (jishft(1_1, 2).ne.4) stop 7 -+ if (jishft(1_2, 2).ne.4) stop 8 -+ if (kishft(1_1, 2).ne.4) stop 9 -+ if (kishft(1_2, 2).ne.4) stop 10 -+ if (kishft(1_4, 2).ne.4) stop 11 -+ if (imod(17_1, 3).ne.2) stop 12 -+ if (jmod(17_1, 3).ne.2) stop 13 -+ if (jmod(17_2, 3).ne.2) stop 14 -+ if (kmod(17_1, 3).ne.2) stop 15 -+ if (kmod(17_2, 3).ne.2) stop 16 -+ if (kmod(17_4, 3).ne.2) stop 17 -+ if (inot(5_1).ne.-6) stop 18 -+ if (jnot(5_1).ne.-6) stop 19 -+ if (jnot(5_2).ne.-6) stop 20 -+ if (knot(5_1).ne.-6) stop 21 -+ if (knot(5_2).ne.-6) stop 22 -+ if (knot(5_4).ne.-6) stop 23 -+ if (isign(-77_1, 1).ne.77) stop 24 -+ if (isign(-77_1, -1).ne.-77) stop 25 -+ if (isign(-77_2, 1).ne.77) stop 26 -+ if (isign(-77_2, -1).ne.-77) stop 27 -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f -new file mode 100644 -index 00000000000..b9d550a5a48 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f -@@ -0,0 +1,40 @@ -+!{ dg-do compile } -+!{ dg-options "-fdec -fno-dec-promotion" } -+! -+! integer types of a smaller kind than expected should be -+! accepted by type specific intrinsic functions -+! -+! Contributed by Mark Eggleston -+! -+ program test_small_type_promtion -+ implicit none -+ integer(1) :: a = 1 -+ integer :: i -+ if (iiabs(-9_1).ne.9) stop 1 -+ if (iabs(-9_1).ne.9) stop 2 ! { dg-error "Type of argument" } -+ if (iabs(-9_2).ne.9) stop 3 ! { dg-error "Type of argument" } -+ if (jiabs(-9_1).ne.9) stop 4 -+ if (jiabs(-9_2).ne.9) stop 5 -+ if (iishft(1_1, 2).ne.4) stop 6 -+ if (jishft(1_1, 2).ne.4) stop 7 -+ if (jishft(1_2, 2).ne.4) stop 8 -+ if (kishft(1_1, 2).ne.4) stop 9 -+ if (kishft(1_2, 2).ne.4) stop 10 -+ if (kishft(1_4, 2).ne.4) stop 11 -+ if (imod(17_1, 3).ne.2) stop 12 -+ if (jmod(17_1, 3).ne.2) stop 13 -+ if (jmod(17_2, 3).ne.2) stop 14 -+ if (kmod(17_1, 3).ne.2) stop 15 -+ if (kmod(17_2, 3).ne.2) stop 16 -+ if (kmod(17_4, 3).ne.2) stop 17 -+ if (inot(5_1).ne.-6) stop 18 -+ if (jnot(5_1).ne.-6) stop 19 -+ if (jnot(5_2).ne.-6) stop 20 -+ if (knot(5_1).ne.-6) stop 21 -+ if (knot(5_2).ne.-6) stop 22 -+ if (knot(5_4).ne.-6) stop 23 -+ if (isign(-77_1, 1).ne.77) stop 24 ! { dg-error "Type of argument" } -+ if (isign(-77_1, -1).ne.-77) stop 25 ! { dg-error "Type of argument" } -+ if (isign(-77_2, 1).ne.77) stop 26 ! { dg-error "Type of argument" } -+ if (isign(-77_2, -1).ne.-77) stop 27 ! { dg-error "Type of argument" } -+ end program --- -2.11.0 - diff --git a/SOURCES/0013-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch b/SOURCES/0013-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch deleted file mode 100644 index 8c88c18..0000000 --- a/SOURCES/0013-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch +++ /dev/null @@ -1,262 +0,0 @@ -From aafd9c215d41b4a846c6724bc25025b124c65ec4 Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Wed, 18 Nov 2015 15:08:56 +0000 -Subject: [PATCH 13/16] Add the SEQUENCE attribute by default if it's not - present. - -Use -fdec-sequence to enable this feature. Also enabled by -fdec. ---- - gcc/fortran/lang.opt | 4 ++ - gcc/fortran/options.c | 1 + - gcc/fortran/resolve.c | 13 +++-- - ...dec_add_SEQUENCE_to_COMMON_block_by_default_1.f | 57 ++++++++++++++++++++++ - ...dec_add_SEQUENCE_to_COMMON_block_by_default_2.f | 57 ++++++++++++++++++++++ - ...dec_add_SEQUENCE_to_COMMON_block_by_default_3.f | 57 ++++++++++++++++++++++ - 6 files changed, 186 insertions(+), 3 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_1.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f - create mode 100644 gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f - -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index 2a8f5f661a8..ffd9ce6f270 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -494,6 +494,10 @@ fdec-promotion - Fortran Var(flag_dec_promotion) - Add support for type promotion in intrinsic arguments. - -+fdec-sequence -+Fortran Var(flag_dec_sequence) -+Add the SEQUENCE attribute by default if it's not present. -+ - fdec-structure - Fortran Var(flag_dec_structure) - Enable support for DEC STRUCTURE/RECORD. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index 7a2583a2076..b6fd327d057 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -84,6 +84,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_override_kind, value, value); - SET_BITFLAG (flag_dec_non_logical_if, value, value); - SET_BITFLAG (flag_dec_promotion, value, value); -+ SET_BITFLAG (flag_dec_sequence, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c -index a90f7f849b5..08627866c9c 100644 ---- a/gcc/fortran/resolve.c -+++ b/gcc/fortran/resolve.c -@@ -968,9 +968,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 (flag_dec_sequence) -+ /* 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_1.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_1.f -new file mode 100644 -index 00000000000..fe7b39625eb ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_1.f -@@ -0,0 +1,57 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test add default SEQUENCE attribute derived types appearing in -+! COMMON blocks and EQUIVALENCE statements. -+! -+! Contributed by Francisco Redondo Marchena -+! Modified by Mark Eggleston -+! -+ MODULE SEQ -+ TYPE STRUCT1 -+ INTEGER*4 ID -+ INTEGER*4 TYPE -+ INTEGER*8 DEFVAL -+ CHARACTER*(4) NAME -+ LOGICAL*1 NIL -+ END TYPE STRUCT1 -+ END MODULE -+ -+ SUBROUTINE A -+ USE SEQ -+ TYPE (STRUCT1) S -+ COMMON /BLOCK1/ S -+ IF (S%ID.NE.5) STOP 1 -+ IF (S%TYPE.NE.1000) STOP 2 -+ IF (S%DEFVAL.NE.-99) STOP 3 -+ IF (S%NAME.NE."JANE") STOP 4 -+ IF (S%NIL.NEQV..FALSE.) STOP 5 -+ END SUBROUTINE -+ -+ PROGRAM sequence_att_common -+ USE SEQ -+ IMPLICIT NONE -+ TYPE (STRUCT1) S1 -+ TYPE (STRUCT1) S2 -+ TYPE (STRUCT1) S3 -+ -+ EQUIVALENCE (S1,S2) -+ COMMON /BLOCK1/ S3 -+ -+ S1%ID = 5 -+ S1%TYPE = 1000 -+ S1%DEFVAL = -99 -+ S1%NAME = "JANE" -+ S1%NIL = .FALSE. -+ -+ IF (S2%ID.NE.5) STOP 1 -+ IF (S2%TYPE.NE.1000) STOP 2 -+ IF (S2%DEFVAL.NE.-99) STOP 3 -+ IF (S2%NAME.NE."JANE") STOP 4 -+ IF (S2%NIL.NEQV..FALSE.) STOP 5 -+ -+ S3 = S1 -+ -+ CALL A -+ -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f -new file mode 100644 -index 00000000000..83512f0f3a2 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_2.f -@@ -0,0 +1,57 @@ -+! { dg-do run } -+! { dg-options "-fdec-sequence" } -+! -+! Test add default SEQUENCE attribute derived types appearing in -+! COMMON blocks and EQUIVALENCE statements. -+! -+! Contributed by Francisco Redondo Marchena -+! Modified by Mark Eggleston -+! -+ MODULE SEQ -+ TYPE STRUCT1 -+ INTEGER*4 ID -+ INTEGER*4 TYPE -+ INTEGER*8 DEFVAL -+ CHARACTER*(4) NAME -+ LOGICAL*1 NIL -+ END TYPE STRUCT1 -+ END MODULE -+ -+ SUBROUTINE A -+ USE SEQ -+ TYPE (STRUCT1) S -+ COMMON /BLOCK1/ S -+ IF (S%ID.NE.5) STOP 1 -+ IF (S%TYPE.NE.1000) STOP 2 -+ IF (S%DEFVAL.NE.-99) STOP 3 -+ IF (S%NAME.NE."JANE") STOP 4 -+ IF (S%NIL.NEQV..FALSE.) STOP 5 -+ END SUBROUTINE -+ -+ PROGRAM sequence_att_common -+ USE SEQ -+ IMPLICIT NONE -+ TYPE (STRUCT1) S1 -+ TYPE (STRUCT1) S2 -+ TYPE (STRUCT1) S3 -+ -+ EQUIVALENCE (S1,S2) -+ COMMON /BLOCK1/ S3 -+ -+ S1%ID = 5 -+ S1%TYPE = 1000 -+ S1%DEFVAL = -99 -+ S1%NAME = "JANE" -+ S1%NIL = .FALSE. -+ -+ IF (S2%ID.NE.5) STOP 1 -+ IF (S2%TYPE.NE.1000) STOP 2 -+ IF (S2%DEFVAL.NE.-99) STOP 3 -+ IF (S2%NAME.NE."JANE") STOP 4 -+ IF (S2%NIL.NEQV..FALSE.) STOP 5 -+ -+ S3 = S1 -+ -+ CALL A -+ -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f -new file mode 100644 -index 00000000000..26cd59f9090 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_add_SEQUENCE_to_COMMON_block_by_default_3.f -@@ -0,0 +1,57 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-sequence" } -+! -+! Test add default SEQUENCE attribute derived types appearing in -+! COMMON blocks and EQUIVALENCE statements. -+! -+! Contributed by Francisco Redondo Marchena -+! Modified by Mark Eggleston -+! -+ MODULE SEQ -+ TYPE STRUCT1 -+ INTEGER*4 ID -+ INTEGER*4 TYPE -+ INTEGER*8 DEFVAL -+ CHARACTER*(4) NAME -+ LOGICAL*1 NIL -+ END TYPE STRUCT1 -+ END MODULE -+ -+ SUBROUTINE A -+ USE SEQ -+ TYPE (STRUCT1) S ! { dg-error "Derived type variable" } -+ COMMON /BLOCK1/ S -+ IF (S%ID.NE.5) STOP 1 -+ IF (S%TYPE.NE.1000) STOP 2 -+ IF (S%DEFVAL.NE.-99) STOP 3 -+ IF (S%NAME.NE."JANE") STOP 4 -+ IF (S%NIL.NEQV..FALSE.) STOP 5 -+ END SUBROUTINE -+ -+ PROGRAM sequence_att_common -+ USE SEQ -+ IMPLICIT NONE -+ TYPE (STRUCT1) S1 -+ TYPE (STRUCT1) S2 -+ TYPE (STRUCT1) S3 ! { dg-error "Derived type variable" } -+ -+ EQUIVALENCE (S1,S2) ! { dg-error "Derived type variable" } -+ COMMON /BLOCK1/ S3 -+ -+ S1%ID = 5 -+ S1%TYPE = 1000 -+ S1%DEFVAL = -99 -+ S1%NAME = "JANE" -+ S1%NIL = .FALSE. -+ -+ IF (S2%ID.NE.5) STOP 1 -+ IF (S2%TYPE.NE.1000) STOP 2 -+ IF (S2%DEFVAL.NE.-99) STOP 3 -+ IF (S2%NAME.NE."JANE") STOP 4 -+ IF (S2%NIL.NEQV..FALSE.) STOP 5 -+ -+ S3 = S1 -+ -+ CALL A -+ -+ END --- -2.11.0 - diff --git a/SOURCES/0014-Fill-in-missing-array-dimensions-using-the-lower-bou.patch b/SOURCES/0014-Fill-in-missing-array-dimensions-using-the-lower-bou.patch deleted file mode 100644 index f808856..0000000 --- a/SOURCES/0014-Fill-in-missing-array-dimensions-using-the-lower-bou.patch +++ /dev/null @@ -1,181 +0,0 @@ -From 60b2e0b9ad2057f256591f56d5433e9ca54bf56f Mon Sep 17 00:00:00 2001 -From: Jim MacArthur -Date: Fri, 26 Aug 2016 17:46:05 +0100 -Subject: [PATCH 14/16] Fill in missing array dimensions using the lower bound - -Use -fdec-add-missing-indexes to enable feature. Also enabled by fdec. ---- - gcc/fortran/lang.opt | 8 ++++++++ - gcc/fortran/options.c | 1 + - gcc/fortran/resolve.c | 24 ++++++++++++++++++++++++ - gcc/testsuite/gfortran.dg/array_6.f90 | 23 +++++++++++++++++++++++ - gcc/testsuite/gfortran.dg/array_7.f90 | 23 +++++++++++++++++++++++ - gcc/testsuite/gfortran.dg/array_8.f90 | 23 +++++++++++++++++++++++ - 6 files changed, 102 insertions(+) - create mode 100644 gcc/testsuite/gfortran.dg/array_6.f90 - create mode 100644 gcc/testsuite/gfortran.dg/array_7.f90 - create mode 100644 gcc/testsuite/gfortran.dg/array_8.f90 - -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index ffd9ce6f270..dca3fd27aa3 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -281,6 +281,10 @@ Wmissing-include-dirs - Fortran - ; Documented in C/C++ - -+Wmissing-index -+Fortran Var(warn_missing_index) Warning LangEnabledBy(Fortran,Wall) -+Warn that the lower bound of a missing index will be used. -+ - Wuse-without-only - Fortran Var(warn_use_without_only) Warning - Warn about USE statements that have no ONLY qualifier. -@@ -440,6 +444,10 @@ fdec - Fortran Var(flag_dec) - Enable all DEC language extensions. - -+fdec-add-missing-indexes -+Fortran Var(flag_dec_add_missing_indexes) -+Enable the addition of missing indexes using their lower bounds. -+ - fdec-blank-format-item - Fortran Var(flag_dec_blank_format_item) - Enable the use of blank format items in format strings. -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index b6fd327d057..f417f48f6a7 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -85,6 +85,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_non_logical_if, value, value); - SET_BITFLAG (flag_dec_promotion, value, value); - SET_BITFLAG (flag_dec_sequence, value, value); -+ SET_BITFLAG (flag_dec_add_missing_indexes, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c -index 08627866c9c..70093c952f6 100644 ---- a/gcc/fortran/resolve.c -+++ b/gcc/fortran/resolve.c -@@ -4676,6 +4676,30 @@ compare_spec_to_ref (gfc_array_ref *ar) - if (ar->type == AR_FULL) - return true; - -+ if (flag_dec_add_missing_indexes && as->rank > ar->dimen) -+ { -+ /* Add in the missing dimensions, assuming they are the lower bound -+ of that dimension if not specified. */ -+ int j; -+ if (warn_missing_index) -+ { -+ gfc_warning (OPT_Wmissing_index, "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 00000000000..5c26e18ab3e ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/array_6.f90 -@@ -0,0 +1,23 @@ -+! { dg-do run } -+! { dg-options "-fdec -Wmissing-index" }! -+! Checks that under-specified arrays (referencing arrays with fewer -+! dimensions than the array spec) generates a warning. -+! -+! Contributed by Jim MacArthur -+! Updated by Mark Eggleston -+! -+ -+program under_specified_array -+ integer chessboard(8,8) -+ integer chessboard3d(8,8,3:5) -+ chessboard(3,1) = 5 -+ chessboard(3,2) = 55 -+ chessboard3d(4,1,3) = 6 -+ chessboard3d(4,1,4) = 66 -+ chessboard3d(4,4,3) = 7 -+ chessboard3d(4,4,4) = 77 -+ -+ if (chessboard(3).ne.5) stop 1 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } -+ if (chessboard3d(4).ne.6) stop 2 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } -+ if (chessboard3d(4,4).ne.7) stop 3 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } -+end program -diff --git a/gcc/testsuite/gfortran.dg/array_7.f90 b/gcc/testsuite/gfortran.dg/array_7.f90 -new file mode 100644 -index 00000000000..5588a5bd02d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/array_7.f90 -@@ -0,0 +1,23 @@ -+! { dg-do run } -+! { dg-options "-fdec-add-missing-indexes -Wmissing-index" }! -+! Checks that under-specified arrays (referencing arrays with fewer -+! dimensions than the array spec) generates a warning. -+! -+! Contributed by Jim MacArthur -+! Updated by Mark Eggleston -+! -+ -+program under_specified_array -+ integer chessboard(8,8) -+ integer chessboard3d(8,8,3:5) -+ chessboard(3,1) = 5 -+ chessboard(3,2) = 55 -+ chessboard3d(4,1,3) = 6 -+ chessboard3d(4,1,4) = 66 -+ chessboard3d(4,4,3) = 7 -+ chessboard3d(4,4,4) = 77 -+ -+ if (chessboard(3).ne.5) stop 1 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } -+ if (chessboard3d(4).ne.6) stop 2 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } -+ if (chessboard3d(4,4).ne.7) stop 3 ! { dg-warning "Using the lower bound for unspecified dimensions in array reference" } -+end program -diff --git a/gcc/testsuite/gfortran.dg/array_8.f90 b/gcc/testsuite/gfortran.dg/array_8.f90 -new file mode 100644 -index 00000000000..f0d2ef5e37d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/array_8.f90 -@@ -0,0 +1,23 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-add-missing-indexes" }! -+! Checks that under-specified arrays (referencing arrays with fewer -+! dimensions than the array spec) generates a warning. -+! -+! Contributed by Jim MacArthur -+! Updated by Mark Eggleston -+! -+ -+program under_specified_array -+ integer chessboard(8,8) -+ integer chessboard3d(8,8,3:5) -+ chessboard(3,1) = 5 -+ chessboard(3,2) = 55 -+ chessboard3d(4,1,3) = 6 -+ chessboard3d(4,1,4) = 66 -+ chessboard3d(4,4,3) = 7 -+ chessboard3d(4,4,4) = 77 -+ -+ if (chessboard(3).ne.5) stop 1 ! { dg-error "Rank mismatch" } -+ if (chessboard3d(4).ne.6) stop 2 ! { dg-error "Rank mismatch" } -+ if (chessboard3d(4,4).ne.7) stop 3 ! { dg-error "Rank mismatch" } -+end program --- -2.11.0 - diff --git a/SOURCES/0015-Allow-automatics-in-equivalence.patch b/SOURCES/0015-Allow-automatics-in-equivalence.patch deleted file mode 100644 index 8f12dcf..0000000 --- a/SOURCES/0015-Allow-automatics-in-equivalence.patch +++ /dev/null @@ -1,358 +0,0 @@ -From e6f385f8258148890a097878a618b694be663db6 Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Tue, 11 Sep 2018 12:50:11 +0100 -Subject: [PATCH 15/16] Allow automatics in equivalence - -If a variable with an automatic attribute appears in an -equivalence statement the storage should be allocated on -the stack. - -Note: most of this patch was provided by Jeff Law . ---- - gcc/fortran/gfortran.h | 1 + - gcc/fortran/symbol.c | 4 +- - gcc/fortran/trans-common.c | 75 +++++++++++++++++++++++++-- - gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 | 36 +++++++++++++ - gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 | 38 ++++++++++++++ - gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 | 63 ++++++++++++++++++++++ - 6 files changed, 210 insertions(+), 7 deletions(-) - create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 - create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 - create mode 100644 gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 - -diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h -index 23d01b10728..eb2a29fea5f 100644 ---- a/gcc/fortran/gfortran.h -+++ b/gcc/fortran/gfortran.h -@@ -2993,6 +2993,7 @@ bool gfc_merge_new_implicit (gfc_typespec *); - void gfc_set_implicit_none (bool, bool, locus *); - void gfc_check_function_type (gfc_namespace *); - bool gfc_is_intrinsic_typename (const char *); -+bool check_conflict (symbol_attribute *, const char *, locus *); - - gfc_typespec *gfc_get_default_type (const char *, gfc_namespace *); - bool gfc_set_default_type (gfc_symbol *, int, gfc_namespace *); -diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c -index 4247b5b60c8..5fdb46c4b32 100644 ---- a/gcc/fortran/symbol.c -+++ b/gcc/fortran/symbol.c -@@ -407,7 +407,7 @@ gfc_check_function_type (gfc_namespace *ns) - goto conflict_std;\ - } - --static bool -+bool - check_conflict (symbol_attribute *attr, const char *name, locus *where) - { - static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", -@@ -544,7 +544,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) - conf (allocatable, elemental); - - conf (in_common, automatic); -- conf (in_equivalence, automatic); - conf (result, automatic); - conf (use_assoc, automatic); - conf (dummy, automatic); -@@ -4261,6 +4260,7 @@ save_symbol (gfc_symbol *sym) - return; - - if (sym->attr.in_common -+ || sym->attr.in_equivalence - || sym->attr.dummy - || sym->attr.result - || sym->attr.flavor != FL_VARIABLE) -diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c -index debdbd98ac0..a5fb230bb1b 100644 ---- a/gcc/fortran/trans-common.c -+++ b/gcc/fortran/trans-common.c -@@ -339,7 +339,7 @@ build_field (segment_info *h, tree union_type, record_layout_info rli) - /* Get storage for local equivalence. */ - - static tree --build_equiv_decl (tree union_type, bool is_init, bool is_saved) -+build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto) - { - tree decl; - char name[18]; -@@ -359,8 +359,8 @@ build_equiv_decl (tree union_type, bool is_init, bool is_saved) - DECL_ARTIFICIAL (decl) = 1; - DECL_IGNORED_P (decl) = 1; - -- if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) -- || is_saved) -+ if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) -+ || is_saved)) - TREE_STATIC (decl) = 1; - - TREE_ADDRESSABLE (decl) = 1; -@@ -611,6 +611,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) - tree decl; - bool is_init = false; - bool is_saved = false; -+ bool is_auto = false; - - /* Declare the variables inside the common block. - If the current common block contains any equivalence object, then -@@ -654,6 +655,10 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) - /* Has SAVE attribute. */ - if (s->sym->attr.save) - is_saved = true; -+ -+ /* Has AUTOMATIC attribute. */ -+ if (s->sym->attr.automatic) -+ is_auto = true; - } - - finish_record_layout (rli, true); -@@ -661,7 +666,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) - if (com) - decl = build_common_decl (com, union_type, is_init); - else -- decl = build_equiv_decl (union_type, is_init, is_saved); -+ decl = build_equiv_decl (union_type, is_init, is_saved, is_auto); - - if (is_init) - { -@@ -948,6 +953,61 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) - confirm_condition (f, eq1, n, eq2); - } - -+static void -+accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e) -+{ -+ symbol_attribute attr = e->expr->symtree->n.sym->attr; -+ -+ dummy_symbol->dummy |= attr.dummy; -+ dummy_symbol->pointer |= attr.pointer; -+ dummy_symbol->target |= attr.target; -+ dummy_symbol->external |= attr.external; -+ dummy_symbol->intrinsic |= attr.intrinsic; -+ dummy_symbol->allocatable |= attr.allocatable; -+ dummy_symbol->elemental |= attr.elemental; -+ dummy_symbol->recursive |= attr.recursive; -+ dummy_symbol->in_common |= attr.in_common; -+ dummy_symbol->result |= attr.result; -+ dummy_symbol->in_namelist |= attr.in_namelist; -+ dummy_symbol->optional |= attr.optional; -+ dummy_symbol->entry |= attr.entry; -+ dummy_symbol->function |= attr.function; -+ dummy_symbol->subroutine |= attr.subroutine; -+ dummy_symbol->dimension |= attr.dimension; -+ dummy_symbol->in_equivalence |= attr.in_equivalence; -+ dummy_symbol->use_assoc |= attr.use_assoc; -+ dummy_symbol->cray_pointer |= attr.cray_pointer; -+ dummy_symbol->cray_pointee |= attr.cray_pointee; -+ dummy_symbol->data |= attr.data; -+ dummy_symbol->value |= attr.value; -+ dummy_symbol->volatile_ |= attr.volatile_; -+ dummy_symbol->is_protected |= attr.is_protected; -+ dummy_symbol->is_bind_c |= attr.is_bind_c; -+ dummy_symbol->procedure |= attr.procedure; -+ dummy_symbol->proc_pointer |= attr.proc_pointer; -+ dummy_symbol->abstract |= attr.abstract; -+ dummy_symbol->asynchronous |= attr.asynchronous; -+ dummy_symbol->codimension |= attr.codimension; -+ dummy_symbol->contiguous |= attr.contiguous; -+ dummy_symbol->generic |= attr.generic; -+ dummy_symbol->automatic |= attr.automatic; -+ dummy_symbol->threadprivate |= attr.threadprivate; -+ dummy_symbol->omp_declare_target |= attr.omp_declare_target; -+ dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link; -+ dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin; -+ dummy_symbol->oacc_declare_create |= attr.oacc_declare_create; -+ dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr; -+ dummy_symbol->oacc_declare_device_resident -+ |= attr.oacc_declare_device_resident; -+ -+ /* Not strictly correct, but probably close enough. */ -+ if (attr.save > dummy_symbol->save) -+ dummy_symbol->save = attr.save; -+ if (attr.intent > dummy_symbol->intent) -+ dummy_symbol->intent = attr.intent; -+ if (attr.access > dummy_symbol->access) -+ dummy_symbol->access = attr.access; -+} - - /* Given a segment element, search through the equivalence lists for unused - conditions that involve the symbol. Add these rules to the segment. */ -@@ -965,9 +1025,12 @@ find_equivalence (segment_info *n) - eq = NULL; - - /* Search the equivalence list, including the root (first) element -- for the symbol that owns the segment. */ -+ for the symbol that owns the segment. */ -+ symbol_attribute dummy_symbol; -+ memset (&dummy_symbol, 0, sizeof (dummy_symbol)); - for (e2 = e1; e2; e2 = e2->eq) - { -+ accumulate_equivalence_attributes (&dummy_symbol, e2); - if (!e2->used && e2->expr->symtree->n.sym == n->sym) - { - eq = e2; -@@ -975,6 +1038,8 @@ find_equivalence (segment_info *n) - } - } - -+ check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where); -+ - /* Go to the next root element. */ - if (eq == NULL) - continue; -diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 -new file mode 100644 -index 00000000000..61bfd0738c5 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_1.f90 -@@ -0,0 +1,36 @@ -+! { dg-compile } -+ -+! Contributed by Mark Eggleston -+program test -+ call suba(0) -+ call subb(0) -+ call suba(1) -+ -+contains -+ subroutine suba(option) -+ integer, intent(in) :: option -+ integer, automatic :: a ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" } -+ integer :: b -+ integer :: c -+ equivalence (a, b) -+ if (option.eq.0) then -+ ! initialise a and c -+ a = 9 -+ c = 99 -+ if (a.ne.b) stop 1 -+ if (loc(a).ne.loc(b)) stop 2 -+ else -+ ! a should've been overwritten -+ if (a.eq.9) stop 3 -+ end if -+ end subroutine suba -+ -+ subroutine subb(dummy) -+ integer, intent(in) :: dummy -+ integer, automatic :: x ! { dg-error "AUTOMATIC at \\(1\\) is a DEC extension" } -+ integer :: y -+ x = 77 -+ y = 7 -+ end subroutine subb -+ -+end program test -diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 -new file mode 100644 -index 00000000000..406e718604a ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_2.f90 -@@ -0,0 +1,38 @@ -+! { dg-run } -+! { dg-options "-fdec-static" } -+ -+! Contributed by Mark Eggleston -+ -+program test -+ call suba(0) -+ call subb(0) -+ call suba(1) -+ -+contains -+ subroutine suba(option) -+ integer, intent(in) :: option -+ integer, automatic :: a -+ integer :: b -+ integer :: c -+ equivalence (a, b) -+ if (option.eq.0) then -+ ! initialise a and c -+ a = 9 -+ c = 99 -+ if (a.ne.b) stop 1 -+ if (loc(a).ne.loc(b)) stop 2 -+ else -+ ! a should've been overwritten -+ if (a.eq.9) stop 3 -+ end if -+ end subroutine suba -+ -+ subroutine subb(dummy) -+ integer, intent(in) :: dummy -+ integer, automatic :: x -+ integer :: y -+ x = 77 -+ y = 7 -+ end subroutine subb -+ -+end program test -diff --git a/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 b/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 -new file mode 100644 -index 00000000000..c67aa8c6ac1 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/auto_in_equiv_3.f90 -@@ -0,0 +1,63 @@ -+! { dg-run } -+! { dg-options "-fdec-static -fno-automatic" } -+ -+! Contributed by Mark Eggleston -+ -+! Storage is NOT on the static unless explicitly specified using the -+! DEC extension "automatic". The address of the first local variable -+! is used to determine that storage for the automatic local variable -+! is different to that of a local variable with no attributes. The -+! contents of the local variable in suba should be overwritten by the -+! call to subb. -+! -+program test -+ integer :: dummy -+ integer, parameter :: address = kind(loc(dummy)) -+ integer(address) :: ad1 -+ integer(address) :: ad2 -+ integer(address) :: ad3 -+ logical :: ok -+ -+ call suba(0, ad1) -+ call subb(0, ad2) -+ call suba(1, ad1) -+ call subc(0, ad3) -+ ok = (ad1.eq.ad3).and.(ad1.ne.ad2) -+ if (.not.ok) stop 4 -+ -+contains -+ subroutine suba(option, addr) -+ integer, intent(in) :: option -+ integer(address), intent(out) :: addr -+ integer, automatic :: a -+ integer :: b -+ equivalence (a, b) -+ addr = loc(a) -+ if (option.eq.0) then -+ ! initialise a and c -+ a = 9 -+ if (a.ne.b) stop 1 -+ if (loc(a).ne.loc(b)) stop 2 -+ else -+ ! a should've been overwritten -+ if (a.eq.9) stop 3 -+ end if -+ end subroutine suba -+ -+ subroutine subb(dummy, addr) -+ integer, intent(in) :: dummy -+ integer(address), intent(out) :: addr -+ integer :: x -+ addr = loc(x) -+ x = 77 -+ end subroutine subb -+ -+ subroutine subc(dummy, addr) -+ integer, intent(in) :: dummy -+ integer(address), intent(out) :: addr -+ integer, automatic :: y -+ addr = loc(y) -+ y = 77 -+ end subroutine subc -+ -+end program test --- -2.11.0 - diff --git a/SOURCES/0016-Suppress-warning-with-Wno-overwrite-recursive.patch b/SOURCES/0016-Suppress-warning-with-Wno-overwrite-recursive.patch deleted file mode 100644 index 7a283ba..0000000 --- a/SOURCES/0016-Suppress-warning-with-Wno-overwrite-recursive.patch +++ /dev/null @@ -1,49 +0,0 @@ -From 9bf3b68e118a749ab87f52649fd56aca059470e8 Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Tue, 16 Apr 2019 09:09:12 +0100 -Subject: [PATCH 16/16] Suppress warning with -Wno-overwrite-recursive - -The message "Warning: Flag '-fno-automatic' overwrites '-frecursive'" is -output by default when -fno-automatic and -frecursive are used together. -It warns that recursion may be broken, however if all the relavent variables -in the recursive procedure have automatic attributes the warning is -unnecessary so -Wno-overwrite-recursive can be used to suppress it. This -will allow compilation when warnings are regarded as errors. - -Suppress warning with -Wno-overwrite-recursive ---- - gcc/fortran/lang.opt | 4 ++++ - gcc/fortran/options.c | 2 +- - 2 files changed, 5 insertions(+), 1 deletion(-) - -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index dca3fd27aa3..e5074f614e3 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -293,6 +293,10 @@ Wopenmp-simd - Fortran - ; Documented in C - -+Woverwrite-recursive -+Fortran Warning Var(warn_overwrite_recursive) Init(1) -+Warn that -fno-automatic may break recursion. -+ - Wpedantic - Fortran - ; Documented in common.opt -diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c -index f417f48f6a7..6cbc64bf1ae 100644 ---- a/gcc/fortran/options.c -+++ b/gcc/fortran/options.c -@@ -418,7 +418,7 @@ gfc_post_options (const char **pfilename) - && flag_max_stack_var_size != 0) - gfc_warning_now (0, "Flag %<-fno-automatic%> overwrites %<-fmax-stack-var-size=%d%>", - flag_max_stack_var_size); -- else if (!flag_automatic && flag_recursive) -+ else if (!flag_automatic && flag_recursive && warn_overwrite_recursive) - gfc_warning_now (0, "Flag %<-fno-automatic%> overwrites %<-frecursive%>"); - else if (!flag_automatic && flag_openmp) - gfc_warning_now (0, "Flag %<-fno-automatic%> overwrites %<-frecursive%> implied by " --- -2.11.0 - diff --git a/SOURCES/gcc10-libstdc++-compat.patch b/SOURCES/gcc10-libstdc++-compat.patch index aed95ac..e14a9a2 100644 --- a/SOURCES/gcc10-libstdc++-compat.patch +++ b/SOURCES/gcc10-libstdc++-compat.patch @@ -9650,6 +9650,8 @@ +asm (".hidden _ZNSt15_Sp_counted_ptrIDnLN9__gnu_cxx12_Lock_policyE2EE10_M_disposeEv"); +asm (".hidden _ZNSt16_Sp_counted_baseILN9__gnu_cxx12_Lock_policyE2EE10_M_destroyEv"); +asm (".hidden _ZNSt16_Sp_counted_baseILN9__gnu_cxx12_Lock_policyE2EE10_M_releaseEv"); ++asm (".hidden _ZNSsC1ISaIcEEEPKcRKS0_"); ++asm (".hidden _ZNSsC2ISaIcEEEPKcRKS0_"); +#ifndef __s390x__ +asm (".hidden _ZNSt5dequeINSt10filesystem4pathESaIS1_EE16_M_push_back_auxIIRKS1_EEEvDpOT_"); +asm (".hidden _ZNSt5dequeINSt10filesystem4pathESaIS1_EE12emplace_backIJS1_EEERS1_DpOT_"); @@ -9693,8 +9695,6 @@ +#endif +asm (".hidden _ZNSt10unique_ptrINSt10filesystem4path5_List5_ImplENS2_13_Impl_deleterEED1Ev"); +asm (".hidden _ZNSt10unique_ptrINSt10filesystem4path5_List5_ImplENS2_13_Impl_deleterEED2Ev"); -+asm (".hidden _ZNSsC1EPKcRKSaIcE"); -+asm (".hidden _ZNSsC2EPKcRKSaIcE"); +asm (".hidden _ZNKSt10filesystem4path8filenameEv"); +asm (".hidden _ZNSt10filesystem4pathD2Ev"); +#ifdef __i386__ @@ -9705,7 +9705,7 @@ +#endif --- libstdc++-v3/src/nonshared17/cow-fs_path.cc.jj 2020-05-27 15:11:04.994304406 +0200 +++ libstdc++-v3/src/nonshared17/cow-fs_path.cc 2020-05-27 16:18:15.273367217 +0200 -@@ -0,0 +1,130 @@ +@@ -0,0 +1,132 @@ +// Copyright (C) 2019-2020 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free @@ -9759,6 +9759,7 @@ +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem16filesystem_error5_ImplESaIS2_ELN9__gnu_cxx12_Lock_policyE2EE14_M_get_deleterERKSt9type_info"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem16filesystem_error5_ImplESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED0Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem16filesystem_error5_ImplESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED1Ev"); ++asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem16filesystem_error5_ImplESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED2Ev"); +asm (".hidden _ZTISt11_Mutex_baseILN9__gnu_cxx12_Lock_policyE2EE"); +asm (".hidden _ZTISt16_Sp_counted_baseILN9__gnu_cxx12_Lock_policyE2EE"); +asm (".hidden _ZTISt23_Sp_counted_ptr_inplaceINSt10filesystem16filesystem_error5_ImplESaIS2_ELN9__gnu_cxx12_Lock_policyE2EE"); @@ -9796,7 +9797,6 @@ +asm (".hidden _ZNSsC1ERKSsjj"); +asm (".hidden _ZNSsC2ERKSsjj"); +asm (".hidden _ZSt10__mismatchINSt10filesystem4path8iteratorES2_N9__gnu_cxx5__ops19_Iter_equal_to_iterEESt4pairIT_T0_ES7_S7_S8_S8_T1_"); -+asm (".hidden _ZSt10__mismatchINSt10filesystem7__cxx114path8iteratorES3_N9__gnu_cxx5__ops19_Iter_equal_to_iterEESt4pairIT_T0_ES8_S8_S9_S9_T1_"); +#endif +asm (".hidden _ZTIZNSt10filesystem4path4_CvtIwE10_S_convertEPKwS4_E5_UCvt"); +asm (".hidden _ZTSZNSt10filesystem4path4_CvtIwE10_S_convertEPKwS4_E5_UCvt"); @@ -9835,6 +9835,8 @@ +asm (".hidden _ZNSt10filesystem4pathC2ERKS0_"); +asm (".hidden _ZNSt10filesystem4pathC1ESt17basic_string_viewIcSt11char_traitsIcEENS0_5_TypeE"); +asm (".hidden _ZNSt10filesystem4pathC2ESt17basic_string_viewIcSt11char_traitsIcEENS0_5_TypeE"); ++asm (".hidden _ZNSsC1ISaIcEEEPKcRKS0_"); ++asm (".hidden _ZNSsC2ISaIcEEEPKcRKS0_"); +#endif --- libstdc++-v3/src/nonshared17/memory_resource.cc.jj 2020-05-27 15:11:04.996304376 +0200 +++ libstdc++-v3/src/nonshared17/memory_resource.cc 2020-05-27 16:21:24.634581462 +0200 @@ -9912,7 +9914,7 @@ +asm (".hidden _ZNSt3pmr26synchronized_pool_resource7_TPoolsC2ERS0_RSt10lock_guardISt12shared_mutexE"); --- libstdc++-v3/src/nonshared17/fs_dir.cc.jj 2020-05-27 15:11:04.994304406 +0200 +++ libstdc++-v3/src/nonshared17/fs_dir.cc 2020-05-27 16:19:06.255617202 +0200 -@@ -0,0 +1,92 @@ +@@ -0,0 +1,94 @@ +// Copyright (C) 2019-2020 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free @@ -9970,11 +9972,13 @@ +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1128recursive_directory_iterator10_Dir_stackESaIS3_ELN9__gnu_cxx12_Lock_policyE2EE14_M_get_deleterERKSt9type_info"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1128recursive_directory_iterator10_Dir_stackESaIS3_ELN9__gnu_cxx12_Lock_policyE2EED0Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1128recursive_directory_iterator10_Dir_stackESaIS3_ELN9__gnu_cxx12_Lock_policyE2EED1Ev"); ++asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1128recursive_directory_iterator10_Dir_stackESaIS3_ELN9__gnu_cxx12_Lock_policyE2EED2Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx114_DirESaIS2_ELN9__gnu_cxx12_Lock_policyE2EE10_M_destroyEv"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx114_DirESaIS2_ELN9__gnu_cxx12_Lock_policyE2EE10_M_disposeEv"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx114_DirESaIS2_ELN9__gnu_cxx12_Lock_policyE2EE14_M_get_deleterERKSt9type_info"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx114_DirESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED0Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx114_DirESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED1Ev"); ++asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx114_DirESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED2Ev"); +asm (".hidden _ZNSt5dequeINSt10filesystem7__cxx114_DirESaIS2_EE12emplace_backIIS2_EEERS2_DpOT_"); +asm (".hidden _ZNSt5dequeINSt10filesystem7__cxx114_DirESaIS2_EE12emplace_backIJS2_EEERS2_DpOT_"); +asm (".hidden _ZNSt5dequeINSt10filesystem7__cxx114_DirESaIS2_EE16_M_push_back_auxIIRP11__dirstreamRKNS1_4pathEEEEvDpOT_"); @@ -10007,7 +10011,7 @@ +asm (".hidden _ZSt20__replacement_assertPKciS0_S0_"); --- libstdc++-v3/src/nonshared17/fs_path80.cc.jj 2020-05-27 15:11:04.994304406 +0200 +++ libstdc++-v3/src/nonshared17/fs_path80.cc 2020-05-27 15:11:04.994304406 +0200 -@@ -0,0 +1,36 @@ +@@ -0,0 +1,37 @@ +// Copyright (C) 2019-2020 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free @@ -10043,10 +10047,11 @@ +asm (".hidden _ZNSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEE9_M_mutateEjjPKcj"); +asm (".hidden _ZNSt7__cxx1112basic_stringIwSt11char_traitsIwESaIwEE6resizeEjw"); +asm (".hidden _ZNSt7__cxx1112basic_stringIwSt11char_traitsIwESaIwEE9_M_mutateEjjPKwj"); ++asm (".hidden _ZSt10__mismatchINSt10filesystem7__cxx114path8iteratorES3_N9__gnu_cxx5__ops19_Iter_equal_to_iterEESt4pairIT_T0_ES8_S8_S9_S9_T1_"); +#endif --- libstdc++-v3/src/nonshared17/cow-fs_dir.cc.jj 2020-05-27 15:11:04.993304421 +0200 +++ libstdc++-v3/src/nonshared17/cow-fs_dir.cc 2020-05-27 16:16:29.824918505 +0200 -@@ -0,0 +1,96 @@ +@@ -0,0 +1,98 @@ +// Copyright (C) 2019-2020 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free @@ -10104,11 +10109,13 @@ +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem28recursive_directory_iterator10_Dir_stackESaIS2_ELN9__gnu_cxx12_Lock_policyE2EE14_M_get_deleterERKSt9type_info"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem28recursive_directory_iterator10_Dir_stackESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED0Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem28recursive_directory_iterator10_Dir_stackESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED1Ev"); ++asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem28recursive_directory_iterator10_Dir_stackESaIS2_ELN9__gnu_cxx12_Lock_policyE2EED2Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem4_DirESaIS1_ELN9__gnu_cxx12_Lock_policyE2EE10_M_destroyEv"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem4_DirESaIS1_ELN9__gnu_cxx12_Lock_policyE2EE10_M_disposeEv"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem4_DirESaIS1_ELN9__gnu_cxx12_Lock_policyE2EE14_M_get_deleterERKSt9type_info"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem4_DirESaIS1_ELN9__gnu_cxx12_Lock_policyE2EED0Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem4_DirESaIS1_ELN9__gnu_cxx12_Lock_policyE2EED1Ev"); ++asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem4_DirESaIS1_ELN9__gnu_cxx12_Lock_policyE2EED2Ev"); +asm (".hidden _ZNSt5dequeINSt10filesystem4_DirESaIS1_EE12emplace_backIIS1_EEERS1_DpOT_"); +asm (".hidden _ZNSt5dequeINSt10filesystem4_DirESaIS1_EE12emplace_backIJS1_EEERS1_DpOT_"); +asm (".hidden _ZNSt5dequeINSt10filesystem4_DirESaIS1_EE16_M_push_back_auxIIRP11__dirstreamRKNS0_4pathEEEEvDpOT_"); @@ -10127,6 +10134,8 @@ +asm (".hidden _ZTVSt23_Sp_counted_ptr_inplaceINSt10filesystem28recursive_directory_iterator10_Dir_stackESaIS2_ELN9__gnu_cxx12_Lock_policyE2EE"); +asm (".hidden _ZTVSt23_Sp_counted_ptr_inplaceINSt10filesystem4_DirESaIS1_ELN9__gnu_cxx12_Lock_policyE2EE"); +asm (".hidden _ZZNSt19_Sp_make_shared_tag5_S_tiEvE5__tag"); ++asm (".hidden _ZNSsC1ISaIcEEEPKcRKS0_"); ++asm (".hidden _ZNSsC2ISaIcEEEPKcRKS0_"); +#if defined(__aarch64__) || defined(__x86_64__) || defined(__powerpc64__) +asm (".hidden _ZNSt5dequeINSt10filesystem4_DirESaIS1_EE17_M_reallocate_mapEmb"); +#endif @@ -10137,8 +10146,6 @@ +#if !defined(__s390x__) && !defined(__aarch64__) && !defined(__powerpc64__) +asm (".hidden _ZNSs4swapERSs"); +#endif -+asm (".hidden _ZNSsC1EPKcRKSaIcE"); -+asm (".hidden _ZNSsC2EPKcRKSaIcE"); +#ifdef __s390x__ +asm (".hidden _ZNSt10filesystem4pathC1ERKS0_"); +asm (".hidden _ZNSt10filesystem4pathC2ERKS0_"); @@ -10278,7 +10285,7 @@ + $(OPT_LDFLAGS) $(SECTION_LDFLAGS) $(AM_CXXFLAGS) $(LTLDFLAGS) -o $@ --- libstdc++-v3/src/nonshared17/fs_path.cc.jj 2020-05-27 15:11:04.995304391 +0200 +++ libstdc++-v3/src/nonshared17/fs_path.cc 2020-05-27 16:20:43.631184679 +0200 -@@ -0,0 +1,99 @@ +@@ -0,0 +1,100 @@ +// Copyright (C) 2019-2020 Free Software Foundation, Inc. +// +// This file is part of the GNU ISO C++ Library. This library is free @@ -10334,6 +10341,7 @@ +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1116filesystem_error5_ImplESaIS3_ELN9__gnu_cxx12_Lock_policyE2EE14_M_get_deleterERKSt9type_info"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1116filesystem_error5_ImplESaIS3_ELN9__gnu_cxx12_Lock_policyE2EED0Ev"); +asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1116filesystem_error5_ImplESaIS3_ELN9__gnu_cxx12_Lock_policyE2EED1Ev"); ++asm (".hidden _ZNSt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1116filesystem_error5_ImplESaIS3_ELN9__gnu_cxx12_Lock_policyE2EED2Ev"); +asm (".hidden _ZTISt11_Mutex_baseILN9__gnu_cxx12_Lock_policyE2EE"); +asm (".hidden _ZTISt16_Sp_counted_baseILN9__gnu_cxx12_Lock_policyE2EE"); +asm (".hidden _ZTISt23_Sp_counted_ptr_inplaceINSt10filesystem7__cxx1116filesystem_error5_ImplESaIS3_ELN9__gnu_cxx12_Lock_policyE2EE"); diff --git a/SOURCES/gcc10-pr96385.patch b/SOURCES/gcc10-pr96385.patch deleted file mode 100644 index 22fe68e..0000000 --- a/SOURCES/gcc10-pr96385.patch +++ /dev/null @@ -1,22 +0,0 @@ -2020-08-03 Richard Biener - - PR lto/96385 -libiberty/ - * simple-object-elf.c - (simple_object_elf_copy_lto_debug_sections): Localize global - UNDEFs and reuse the prevailing name. - ---- libiberty/simple-object-elf.c -+++ libiberty/simple-object-elf.c -@@ -1467,6 +1467,11 @@ simple_object_elf_copy_lto_debug_sections (simple_object_read *sobj, - && st_shndx < shnum - && pfnret[st_shndx - 1] == -1) - discard = 1; -+ /* We also need to remove global UNDEFs which can -+ cause link fails later. */ -+ else if (st_shndx == SHN_UNDEF -+ && ELF_ST_BIND (*st_info) == STB_GLOBAL) -+ discard = 1; - - if (discard) - { diff --git a/SPECS/gcc.spec b/SPECS/gcc.spec index 055f140..a32ada2 100644 --- a/SPECS/gcc.spec +++ b/SPECS/gcc.spec @@ -2,13 +2,13 @@ %{?scl:%global __strip %%{_scl_root}/usr/bin/strip} %{?scl:%global __objdump %%{_scl_root}/usr/bin/objdump} %{?scl:%scl_package gcc} -%global DATE 20200804 -%global gitrev 08d83635c2ab388f6139db6965e600b296ad85e6 +%global DATE 20201102 +%global gitrev 736fd853f0e75ad3f91bdc7156f6b4475a1b60c1 %global gcc_version 10.2.1 %global gcc_major 10 # Note, gcc_release must be integer, if you want to add suffixes to # %%{release}, append them after %%{gcc_release} on Release: line. -%global gcc_release 2 +%global gcc_release 7 %global nvptx_tools_gitrev 5f6f343a302d620b0868edab376c00b15741e39e %global newlib_cygwin_gitrev 50e2a63b04bdd018484605fbb954fd1bd5147fa0 %global mpc_version 0.8.1 @@ -123,7 +123,7 @@ Summary: GCC version 10 Name: %{?scl_prefix}gcc Version: %{gcc_version} -Release: %{gcc_release}%{?dist} +Release: %{gcc_release}.1%{?dist} # libgcc, libgfortran, libgomp, libstdc++ and crtstuff have # GCC Runtime Exception. License: GPLv3+ and GPLv3+ with exceptions and GPLv2+ with exceptions and LGPLv2+ and BSD @@ -310,29 +310,22 @@ Patch10: gcc10-rh1574936.patch Patch11: gcc10-d-shared-libphobos.patch Patch12: gcc10-pr94540.patch Patch13: gcc10-pr96383.patch -Patch14: gcc10-pr96385.patch Patch1000: gcc10-libstdc++-compat.patch Patch1002: gcc10-isl-dl2.patch Patch1003: gcc10-libgfortran-compat.patch Patch1004: gcc10-libgfortran-compat-2.patch -Patch3001: 0001-Default-widths-for-i-f-and-g-format-specifiers-in-fo.patch -Patch3002: 0002-Allow-duplicate-declarations.patch -Patch3003: 0003-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch -Patch3004: 0004-Allow-CHARACTER-literals-in-assignments-and-data-sta.patch -Patch3005: 0005-dec-comparisons.patch -Patch3006: 0006-Allow-blank-format-items-in-format-strings.patch -Patch3007: 0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch -Patch3008: 0008-Allow-non-integer-substring-indexes.patch -Patch3009: 0009-Allow-old-style-initializers-in-derived-types.patch -Patch3010: 0010-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch -Patch3011: 0011-Allow-non-logical-expressions-in-IF-statements.patch -Patch3012: 0012-Support-type-promotion-in-calls-to-intrinsics.patch -Patch3013: 0013-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch -Patch3014: 0014-Fill-in-missing-array-dimensions-using-the-lower-bou.patch -Patch3015: 0015-Allow-automatics-in-equivalence.patch -Patch3016: 0016-Suppress-warning-with-Wno-overwrite-recursive.patch +Patch3001: 0001-Allow-duplicate-declarations.patch +Patch3002: 0002-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch +Patch3003: 0003-Allow-more-than-one-character-as-argument-to-ICHAR.patch +Patch3004: 0004-Allow-non-integer-substring-indexes.patch +Patch3005: 0005-Allow-old-style-initializers-in-derived-types.patch +Patch3006: 0006-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch +Patch3007: 0007-Allow-non-logical-expressions-in-IF-statements.patch +Patch3008: 0008-Support-type-promotion-in-calls-to-intrinsics.patch +Patch3009: 0009-Add-the-SEQUENCE-attribute-by-default-if-it-s-not.patch +Patch3010: 0010-Fill-in-missing-array-dimensions-using-the-lower-bou.patch %if 0%{?rhel} > 7 %global nonsharedver 80 @@ -662,7 +655,6 @@ to NVidia PTX capable devices if available. %patch11 -p0 -b .d-shared-libphobos~ %patch12 -p0 -b .pr94540~ %patch13 -p0 -b .pr96383~ -%patch14 -p0 -b .pr96385~ %patch1000 -p0 -b .libstdc++-compat~ %if %{build_isl} @@ -671,7 +663,6 @@ to NVidia PTX capable devices if available. %patch1003 -p0 -b .libgfortran-compat~ %patch1004 -p0 -b .libgfortran-compat-2~ -%if 0 %patch3001 -p1 -b .fortran01~ %patch3002 -p1 -b .fortran02~ %patch3003 -p1 -b .fortran03~ @@ -682,13 +673,6 @@ to NVidia PTX capable devices if available. %patch3008 -p1 -b .fortran08~ %patch3009 -p1 -b .fortran09~ %patch3010 -p1 -b .fortran10~ -%patch3011 -p1 -b .fortran11~ -%patch3012 -p1 -b .fortran12~ -%patch3013 -p1 -b .fortran13~ -%patch3014 -p1 -b .fortran14~ -%patch3015 -p1 -b .fortran15~ -%patch3016 -p1 -b .fortran16~ -%endif echo 'Red Hat %{version}-%{gcc_release}' > gcc/DEV-PHASE @@ -2617,6 +2601,15 @@ fi %endif %changelog +* Tue Nov 03 2020 Marek Polacek 10.2.1-7.1 +- adjust some libstdc++_nonshared.a symbol + +* Tue Nov 03 2020 Marek Polacek 10.2.1-7 +- update from Fedora gcc 10.2.1-7 (#1878887) + +* Mon Aug 17 2020 Marek Polacek 10.2.1-2.1 +- re-apply Fortran patches + * Tue Aug 4 2020 Marek Polacek 10.2.1-2 - update from Fedora gcc 10.2.1-2 - emit debug info for C/C++ external function declarations used in the TU