From d0de29332e023dd68f923713896c4f43ae959de9 Mon Sep 17 00:00:00 2001 From: CentOS Sources Date: Nov 05 2019 19:44:23 +0000 Subject: import gcc-toolset-9-gcc-9.1.1-2.4.el8 --- diff --git a/.gcc-toolset-9-gcc.metadata b/.gcc-toolset-9-gcc.metadata new file mode 100644 index 0000000..dd25f2a --- /dev/null +++ b/.gcc-toolset-9-gcc.metadata @@ -0,0 +1,4 @@ +7f4348418dc3efefd357b32a2b5c8010211ab284 SOURCES/doxygen-1.8.0.src.tar.gz +186c672996b17fd7ea17a188a2ed927d9e52a835 SOURCES/gcc-9.1.1-20190605.tar.xz +c5a2b201bf05229647e73203c0bf2d9679d4d21f SOURCES/isl-0.16.1.tar.bz2 +5ef03ca7aee134fe7dfecb6c9d048799f0810278 SOURCES/mpc-0.8.1.tar.gz diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5a8f8c1 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +SOURCES/doxygen-1.8.0.src.tar.gz +SOURCES/gcc-9.1.1-20190605.tar.xz +SOURCES/isl-0.16.1.tar.bz2 +SOURCES/mpc-0.8.1.tar.gz 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 new file mode 100644 index 0000000..8d6247d --- /dev/null +++ b/SOURCES/0001-Default-widths-for-i-f-and-g-format-specifiers-in-fo.patch @@ -0,0 +1,873 @@ +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 new file mode 100644 index 0000000..42f4fd3 --- /dev/null +++ b/SOURCES/0002-Allow-duplicate-declarations.patch @@ -0,0 +1,219 @@ +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/0003-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch b/SOURCES/0003-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch new file mode 100644 index 0000000..abec1ac --- /dev/null +++ b/SOURCES/0003-Convert-LOGICAL-to-INTEGER-for-arithmetic-ops-and-vi.patch @@ -0,0 +1,298 @@ +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 new file mode 100644 index 0000000..66a63b7 --- /dev/null +++ b/SOURCES/0004-Allow-CHARACTER-literals-in-assignments-and-data-sta.patch @@ -0,0 +1,860 @@ +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/0005-dec-comparisons.patch b/SOURCES/0005-dec-comparisons.patch new file mode 100644 index 0000000..0110209 --- /dev/null +++ b/SOURCES/0005-dec-comparisons.patch @@ -0,0 +1,658 @@ +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 new file mode 100644 index 0000000..e3ad8d0 --- /dev/null +++ b/SOURCES/0006-Allow-blank-format-items-in-format-strings.patch @@ -0,0 +1,150 @@ +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/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch b/SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch new file mode 100644 index 0000000..a70ca2b --- /dev/null +++ b/SOURCES/0007-Allow-more-than-one-character-as-argument-to-ICHAR.patch @@ -0,0 +1,78 @@ +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/0008-Allow-non-integer-substring-indexes.patch b/SOURCES/0008-Allow-non-integer-substring-indexes.patch new file mode 100644 index 0000000..b165df8 --- /dev/null +++ b/SOURCES/0008-Allow-non-integer-substring-indexes.patch @@ -0,0 +1,158 @@ +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/0009-Allow-old-style-initializers-in-derived-types.patch b/SOURCES/0009-Allow-old-style-initializers-in-derived-types.patch new file mode 100644 index 0000000..d9a3a9e --- /dev/null +++ b/SOURCES/0009-Allow-old-style-initializers-in-derived-types.patch @@ -0,0 +1,185 @@ +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 new file mode 100644 index 0000000..e4bde41 --- /dev/null +++ b/SOURCES/0010-Allow-string-length-and-kind-to-be-specified-on-a-pe.patch @@ -0,0 +1,587 @@ +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/0011-Allow-non-logical-expressions-in-IF-statements.patch b/SOURCES/0011-Allow-non-logical-expressions-in-IF-statements.patch new file mode 100644 index 0000000..7152a0b --- /dev/null +++ b/SOURCES/0011-Allow-non-logical-expressions-in-IF-statements.patch @@ -0,0 +1,378 @@ +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 new file mode 100644 index 0000000..3b67735 --- /dev/null +++ b/SOURCES/0012-Support-type-promotion-in-calls-to-intrinsics.patch @@ -0,0 +1,2151 @@ +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 new file mode 100644 index 0000000..8c88c18 --- /dev/null +++ b/SOURCES/0013-Add-the-SEQUENCE-attribute-by-default-if-it-s-not-pr.patch @@ -0,0 +1,262 @@ +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 new file mode 100644 index 0000000..f808856 --- /dev/null +++ b/SOURCES/0014-Fill-in-missing-array-dimensions-using-the-lower-bou.patch @@ -0,0 +1,181 @@ +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 new file mode 100644 index 0000000..8f12dcf --- /dev/null +++ b/SOURCES/0015-Allow-automatics-in-equivalence.patch @@ -0,0 +1,358 @@ +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 new file mode 100644 index 0000000..7a283ba --- /dev/null +++ b/SOURCES/0016-Suppress-warning-with-Wno-overwrite-recursive.patch @@ -0,0 +1,49 @@ +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/doxygen-1.7.1-config.patch b/SOURCES/doxygen-1.7.1-config.patch new file mode 100644 index 0000000..f6be5b9 --- /dev/null +++ b/SOURCES/doxygen-1.7.1-config.patch @@ -0,0 +1,95 @@ +diff -up doxygen-1.7.1/addon/doxywizard/Makefile.in.config doxygen-1.7.1/addon/doxywizard/Makefile.in +--- doxygen-1.7.1/addon/doxywizard/Makefile.in.config 2010-05-23 16:51:31.000000000 +0200 ++++ doxygen-1.7.1/addon/doxywizard/Makefile.in 2010-07-19 13:38:33.000000000 +0200 +@@ -10,8 +10,6 @@ + # See the GNU General Public License for more details. + # + +-QMAKE=qmake $(MKSPECS) +- + all: Makefile.doxywizard + $(MAKE) -f Makefile.doxywizard + +@@ -29,11 +27,11 @@ distclean: Makefile.doxywizard + $(RM) Makefile.doxywizard + + install: +- $(INSTTOOL) -d $(INSTALL)/bin +- $(INSTTOOL) -m 755 ../../bin/doxywizard $(INSTALL)/bin +- $(INSTTOOL) -d $(INSTALL)/$(MAN1DIR) ++ $(INSTTOOL) -d $(DESTDIR)$(INSTALL)/bin ++ $(INSTTOOL) -m 755 ../../bin/doxywizard $(DESTDIR)$(INSTALL)/bin ++ $(INSTTOOL) -d $(DESTDIR)$(INSTALL)/$(MAN1DIR) + cat ../../doc/doxywizard.1 | sed -e "s/DATE/$(DATE)/g" -e "s/VERSION/$(VERSION)/g" > doxywizard.1 +- $(INSTTOOL) -m 644 doxywizard.1 $(INSTALL)/$(MAN1DIR)/doxywizard.1 ++ $(INSTTOOL) -m 644 doxywizard.1 $(DESTDIR)$(INSTALL)/$(MAN1DIR)/doxywizard.1 + rm doxywizard.1 + + FORCE: +diff -up doxygen-1.7.1/configure.config doxygen-1.7.1/configure +--- doxygen-1.7.1/configure.config 2010-06-25 11:46:38.000000000 +0200 ++++ doxygen-1.7.1/configure 2010-07-19 12:03:53.000000000 +0200 +@@ -268,9 +268,10 @@ if test "$f_wizard" = YES; then + if test -z "$QTDIR"; then + echo " QTDIR environment variable not set!" + echo -n " Checking for Qt..." +- for d in /usr/{lib,share,qt}/{qt-4,qt4,qt,qt*,4} /usr; do ++ for d in /usr/{lib64,lib,share,qt}/{qt-4,qt4,qt,qt*,4} /usr; do + if test -x "$d/bin/qmake"; then + QTDIR=$d ++ QMAKE=$d/bin/qmake + fi + done + else +@@ -485,6 +486,8 @@ INSTTOOL = $f_insttool + DOXYDOCS = .. + DOCDIR = $f_docdir + QTDIR = $QTDIR ++QMAKE = $QMAKE ++MAN1DIR = share/man/man1 + EOF + + if test "$f_dot" != NO; then +diff -up doxygen-1.7.1/Makefile.in.config doxygen-1.7.1/Makefile.in +--- doxygen-1.7.1/Makefile.in.config 2009-08-20 21:41:13.000000000 +0200 ++++ doxygen-1.7.1/Makefile.in 2010-07-19 12:03:53.000000000 +0200 +@@ -44,8 +44,6 @@ distclean: clean + + DATE=$(shell date "+%B %Y") + +-MAN1DIR = man/man1 +- + install: doxywizard_install + $(INSTTOOL) -d $(DESTDIR)/$(INSTALL)/bin + $(INSTTOOL) -m 755 bin/doxygen $(DESTDIR)/$(INSTALL)/bin +diff -up doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf.config doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf +--- doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf.config 2008-12-06 14:16:20.000000000 +0100 ++++ doxygen-1.7.1/tmake/lib/linux-g++/tmake.conf 2010-07-19 12:03:53.000000000 +0200 +@@ -11,7 +11,7 @@ TMAKE_CC = gcc + TMAKE_CFLAGS = -pipe + TMAKE_CFLAGS_WARN_ON = -Wall -W -fno-exceptions + TMAKE_CFLAGS_WARN_OFF = +-TMAKE_CFLAGS_RELEASE = -O2 ++TMAKE_CFLAGS_RELEASE = $(RPM_OPT_FLAGS) + TMAKE_CFLAGS_DEBUG = -g + TMAKE_CFLAGS_SHLIB = -fPIC + TMAKE_CFLAGS_YACC = -Wno-unused -Wno-parentheses +@@ -27,12 +27,12 @@ TMAKE_CXXFLAGS_YACC = $$TMAKE_CFLAGS_YAC + + TMAKE_INCDIR = + TMAKE_LIBDIR = +-TMAKE_INCDIR_X11 = /usr/X11R6/include +-TMAKE_LIBDIR_X11 = /usr/X11R6/lib +-TMAKE_INCDIR_QT = $(QTDIR)/include +-TMAKE_LIBDIR_QT = $(QTDIR)/lib +-TMAKE_INCDIR_OPENGL = /usr/X11R6/include +-TMAKE_LIBDIR_OPENGL = /usr/X11R6/lib ++TMAKE_INCDIR_X11 = ++TMAKE_LIBDIR_X11 = ++TMAKE_INCDIR_QT = ++TMAKE_LIBDIR_QT = ++TMAKE_INCDIR_OPENGL = ++TMAKE_LIBDIR_OPENGL = + + TMAKE_LINK = g++ + TMAKE_LINK_SHLIB = g++ diff --git a/SOURCES/doxygen-1.7.5-timestamp.patch b/SOURCES/doxygen-1.7.5-timestamp.patch new file mode 100644 index 0000000..efbd992 --- /dev/null +++ b/SOURCES/doxygen-1.7.5-timestamp.patch @@ -0,0 +1,63 @@ +diff -up doxygen-1.7.5/src/configoptions.cpp.timestamp doxygen-1.7.5/src/configoptions.cpp +--- doxygen-1.7.5/src/configoptions.cpp.timestamp 2011-08-03 15:54:50.000000000 +0200 ++++ doxygen-1.7.5/src/configoptions.cpp 2011-08-23 12:55:56.000000000 +0200 +@@ -1173,6 +1173,14 @@ void addConfigOptions(Config *cfg) + cs->setWidgetType(ConfigString::File); + cs->addDependency("GENERATE_HTML"); + //---- ++ cb = cfg->addBool( ++ "HTML_TIMESTAMP", ++ "If the HTML_TIMESTAMP tag is set to YES then the generated HTML\n" ++ "documentation will contain the timesstamp.", ++ FALSE ++ ); ++ cb->addDependency("GENERATE_HTML"); ++ //---- + cs = cfg->addString( + "HTML_STYLESHEET", + "The HTML_STYLESHEET tag can be used to specify a user-defined cascading\n" +diff -up doxygen-1.7.5/src/config.xml.timestamp doxygen-1.7.5/src/config.xml +--- doxygen-1.7.5/src/config.xml.timestamp 2011-08-03 15:54:48.000000000 +0200 ++++ doxygen-1.7.5/src/config.xml 2011-08-23 12:55:56.000000000 +0200 +@@ -819,6 +819,11 @@ The HTML_FOOTER tag can be used to speci + each generated HTML page. If it is left blank doxygen will generate a + standard footer. + ' defval='' depends='GENERATE_HTML'/> ++