From 91b35405493f90d5d176b3e237e2f3e1c3ff4746 Mon Sep 17 00:00:00 2001 From: Jakub Jelinek Date: Mon, 4 Jul 2022 15:37:15 +0200 Subject: [PATCH] Fix up RHEL/ELN Fortran patches. --- gcc12-fortran-fdec-add-missing-indexes.patch | 181 -- gcc12-fortran-fdec-ichar.patch | 78 - gcc12-fortran-fdec-non-integer-index.patch | 158 -- gcc12-fortran-fdec-old-init.patch | 185 -- gcc12-fortran-fdec-override-kind.patch | 18 +- gcc12-fortran-fdec-promotion.patch | 2093 ------------------ gcc12-fortran-fdec-sequence.patch | 262 --- 7 files changed, 9 insertions(+), 2966 deletions(-) delete mode 100644 gcc12-fortran-fdec-add-missing-indexes.patch delete mode 100644 gcc12-fortran-fdec-ichar.patch delete mode 100644 gcc12-fortran-fdec-non-integer-index.patch delete mode 100644 gcc12-fortran-fdec-old-init.patch delete mode 100644 gcc12-fortran-fdec-promotion.patch delete mode 100644 gcc12-fortran-fdec-sequence.patch diff --git a/gcc12-fortran-fdec-add-missing-indexes.patch b/gcc12-fortran-fdec-add-missing-indexes.patch deleted file mode 100644 index 529868f..0000000 --- a/gcc12-fortran-fdec-add-missing-indexes.patch +++ /dev/null @@ -1,181 +0,0 @@ -From 7001d522d0273658d9e1fb12ca104d56bfcae34d Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Fri, 22 Jan 2021 15:06:08 +0000 -Subject: [PATCH 10/10] Fill in missing array dimensions using the lower bound - -Use -fdec-add-missing-indexes to enable feature. Also enabled by fdec. ---- - gcc/fortran/lang.opt | 8 ++++++++ - gcc/fortran/options.cc | 1 + - gcc/fortran/resolve.cc | 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 019c798cf09..f27de88ea3f 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. -@@ -460,6 +464,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.cc b/gcc/fortran/options.cc -index 050f56fdc25..c3b2822685d 100644 ---- a/gcc/fortran/options.cc -+++ b/gcc/fortran/options.cc -@@ -84,6 +84,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_non_logical_if, value, value); - SET_BITFLAG (flag_dec_promotion, value, value); - SET_BITFLAG (flag_dec_sequence, value, value); -+ SET_BITFLAG (flag_dec_add_missing_indexes, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc -index fe7d0cc5944..0efeedab46e 100644 ---- a/gcc/fortran/resolve.cc -+++ b/gcc/fortran/resolve.cc -@@ -4806,6 +4806,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.27.0 - diff --git a/gcc12-fortran-fdec-ichar.patch b/gcc12-fortran-fdec-ichar.patch deleted file mode 100644 index 900b054..0000000 --- a/gcc12-fortran-fdec-ichar.patch +++ /dev/null @@ -1,78 +0,0 @@ -From f883ac209b0feea860354cb4ef7ff06dc8063fab Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Fri, 22 Jan 2021 12:53:35 +0000 -Subject: [PATCH 03/10] Allow more than one character as argument to ICHAR - -Use -fdec to enable. ---- - gcc/fortran/check.cc | 2 +- - gcc/fortran/simplify.cc | 4 ++-- - .../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.cc b/gcc/fortran/check.cc -index 82db8e4e1b2..623c1cc470e 100644 ---- a/gcc/fortran/check.cc -+++ b/gcc/fortran/check.cc -@@ -3157,7 +3157,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.cc b/gcc/fortran/simplify.cc -index 23317a2e2d9..9900572424f 100644 ---- a/gcc/fortran/simplify.cc -+++ b/gcc/fortran/simplify.cc -@@ -3261,7 +3261,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; -@@ -3459,7 +3459,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.27.0 - diff --git a/gcc12-fortran-fdec-non-integer-index.patch b/gcc12-fortran-fdec-non-integer-index.patch deleted file mode 100644 index 2c168fe..0000000 --- a/gcc12-fortran-fdec-non-integer-index.patch +++ /dev/null @@ -1,158 +0,0 @@ -From 67aef262311d6a746786ee0f59748ccaa7e1e711 Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Fri, 22 Jan 2021 13:09:54 +0000 -Subject: [PATCH 04/10] Allow non-integer substring indexes - -Use -fdec-non-integer-index compiler flag to enable. Also enabled by -fdec. ---- - gcc/fortran/lang.opt | 4 ++++ - gcc/fortran/options.cc | 1 + - gcc/fortran/resolve.cc | 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 c4da248f07c..d527c106bd6 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -489,6 +489,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.cc b/gcc/fortran/options.cc -index f19ba87f8a0..9a042f64881 100644 ---- a/gcc/fortran/options.cc -+++ b/gcc/fortran/options.cc -@@ -78,6 +78,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_blank_format_item, value, value); - SET_BITFLAG (flag_dec_char_conversions, value, value); - SET_BITFLAG (flag_dec_duplicates, value, value); -+ SET_BITFLAG (flag_dec_non_integer_index, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc -index 4b90cb59902..bc0df0fdb99 100644 ---- a/gcc/fortran/resolve.cc -+++ b/gcc/fortran/resolve.cc -@@ -5131,6 +5131,16 @@ gfc_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", -@@ -5160,6 +5170,16 @@ gfc_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.27.0 - diff --git a/gcc12-fortran-fdec-old-init.patch b/gcc12-fortran-fdec-old-init.patch deleted file mode 100644 index d5661c8..0000000 --- a/gcc12-fortran-fdec-old-init.patch +++ /dev/null @@ -1,185 +0,0 @@ -From 8bcc0f85ed1718c0dd9033ad4a34df181aabaffe Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Fri, 22 Jan 2021 13:11:06 +0000 -Subject: [PATCH 05/10] Allow old-style initializers in derived types - -This allows simple declarations in derived types and structures, such as: - LOGICAL*1 NIL /0/ -Only single value expressions are allowed at the moment. - -Use -fdec-old-init to enable. Also enabled by -fdec. ---- - gcc/fortran/decl.cc | 27 +++++++++++++++---- - gcc/fortran/lang.opt | 4 +++ - gcc/fortran/options.cc | 1 + - ...ec_derived_types_initialised_old_style_1.f | 25 +++++++++++++++++ - ...ec_derived_types_initialised_old_style_2.f | 25 +++++++++++++++++ - ...ec_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.cc b/gcc/fortran/decl.cc -index 723915822f3..5c8c1b7981b 100644 ---- a/gcc/fortran/decl.cc -+++ b/gcc/fortran/decl.cc -@@ -2827,12 +2827,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 d527c106bd6..25cc948699b 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -493,6 +493,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.cc b/gcc/fortran/options.cc -index 9a042f64881..d6bd36c3a8a 100644 ---- a/gcc/fortran/options.cc -+++ b/gcc/fortran/options.cc -@@ -79,6 +79,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_char_conversions, value, value); - SET_BITFLAG (flag_dec_duplicates, value, value); - SET_BITFLAG (flag_dec_non_integer_index, value, value); -+ SET_BITFLAG (flag_dec_old_init, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f -new file mode 100644 -index 00000000000..eac4f9bfcf1 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_1.f -@@ -0,0 +1,25 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test old style initializers in derived types -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ PROGRAM spec_in_var -+ TYPE STRUCT1 -+ INTEGER*4 ID /8/ -+ INTEGER*4 TYPE /5/ -+ INTEGER*8 DEFVAL /0/ -+ CHARACTER*(5) NAME /'tests'/ -+ LOGICAL*1 NIL /0/ -+ END TYPE STRUCT1 -+ -+ TYPE (STRUCT1) SINST -+ -+ IF(SINST%ID.NE.8) STOP 1 -+ IF(SINST%TYPE.NE.5) STOP 2 -+ IF(SINST%DEFVAL.NE.0) STOP 3 -+ IF(SINST%NAME.NE.'tests') STOP 4 -+ IF(SINST%NIL) STOP 5 -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f -new file mode 100644 -index 00000000000..d904c8b2974 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_2.f -@@ -0,0 +1,25 @@ -+! { dg-do run } -+! { dg-options "-std=legacy -fdec-old-init" } -+! -+! Test old style initializers in derived types -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ PROGRAM spec_in_var -+ TYPE STRUCT1 -+ INTEGER*4 ID /8/ -+ INTEGER*4 TYPE /5/ -+ INTEGER*8 DEFVAL /0/ -+ CHARACTER*(5) NAME /'tests'/ -+ LOGICAL*1 NIL /0/ -+ END TYPE STRUCT1 -+ -+ TYPE (STRUCT1) SINST -+ -+ IF(SINST%ID.NE.8) STOP 1 -+ IF(SINST%TYPE.NE.5) STOP 2 -+ IF(SINST%DEFVAL.NE.0) STOP 3 -+ IF(SINST%NAME.NE.'tests') STOP 4 -+ IF(SINST%NIL) STOP 5 -+ END -diff --git a/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f -new file mode 100644 -index 00000000000..58c2b4b66cf ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_derived_types_initialised_old_style_3.f -@@ -0,0 +1,26 @@ -+! { dg-do compile } -+! { dg-options "-std=legacy -fdec -fno-dec-old-init" } -+! -+! Test old style initializers in derived types -+! -+! Contributed by Jim MacArthur -+! Modified by Mark Eggleston -+! -+ -+ PROGRAM spec_in_var -+ TYPE STRUCT1 -+ INTEGER*4 ID /8/ ! { dg-error "Invalid old style initialization" } -+ INTEGER*4 TYPE /5/ ! { dg-error "Invalid old style initialization" } -+ INTEGER*8 DEFVAL /0/ ! { dg-error "Invalid old style initialization" } -+ CHARACTER*(5) NAME /'tests'/ ! { dg-error "Invalid old style initialization" } -+ LOGICAL*1 NIL /0/ ! { dg-error "Invalid old style initialization" } -+ END TYPE STRUCT1 -+ -+ TYPE (STRUCT1) SINST -+ -+ IF(SINST%ID.NE.8) STOP 1 ! { dg-error "'id' at \\(1\\) is not a member" } -+ IF(SINST%TYPE.NE.5) STOP 2 ! { dg-error "'type' at \\(1\\) is not a member" } -+ IF(SINST%DEFVAL.NE.0) STOP 3 ! { dg-error "'defval' at \\(1\\) is not a member" } -+ IF(SINST%NAME.NE.'tests') STOP 4 ! { dg-error "'name' at \\(1\\) is not a member" } -+ IF(SINST%NIL) STOP 5 ! { dg-error "'nil' at \\(1\\) is not a member" } -+ END --- -2.27.0 - diff --git a/gcc12-fortran-fdec-override-kind.patch b/gcc12-fortran-fdec-override-kind.patch index 4df6ead..370fa56 100644 --- a/gcc12-fortran-fdec-override-kind.patch +++ b/gcc12-fortran-fdec-override-kind.patch @@ -281,25 +281,25 @@ diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 25cc948699b..4a269ebb22d 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt -@@ -493,6 +493,10 @@ fdec-non-integer-index - Fortran Var(flag_dec_non_integer_index) - Enable support for non-integer substring indexes. +@@ -502,6 +502,10 @@ fdec-math + Fortran Var(flag_dec_math) + Enable legacy math intrinsics for compatibility. +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. + fdec-structure + Fortran Var(flag_dec_structure) + Enable support for DEC STRUCTURE/RECORD. diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index d6bd36c3a8a..edbab483b36 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc -@@ -80,6 +80,7 @@ set_dec_flags (int value) +@@ -78,6 +78,7 @@ set_dec_flags (int value) + SET_BITFLAG (flag_dec_blank_format_item, value, value); + SET_BITFLAG (flag_dec_char_conversions, value, value); SET_BITFLAG (flag_dec_duplicates, value, value); - SET_BITFLAG (flag_dec_non_integer_index, value, value); - SET_BITFLAG (flag_dec_old_init, value, value); + SET_BITFLAG (flag_dec_override_kind, value, value); } diff --git a/gcc12-fortran-fdec-promotion.patch b/gcc12-fortran-fdec-promotion.patch deleted file mode 100644 index 870d62a..0000000 --- a/gcc12-fortran-fdec-promotion.patch +++ /dev/null @@ -1,2093 +0,0 @@ -From 7a27318818e359a277f2fa5f7dc3932d0fb950f5 Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Fri, 22 Jan 2021 14:58:07 +0000 -Subject: [PATCH 08/10] Support type promotion in calls to intrinsics - -Use -fdec-promotion or -fdec to enable this feature. - -Merged 2 commits: worked on by Ben Brewer , -Francisco Redondo Marchena and -Jeff Law - -Re-worked by Mark Eggleston ---- - gcc/fortran/check.cc | 71 +++++- - gcc/fortran/intrinsic.cc | 5 + - gcc/fortran/iresolve.cc | 91 ++++--- - gcc/fortran/lang.opt | 4 + - gcc/fortran/options.cc | 1 + - gcc/fortran/simplify.cc | 240 ++++++++++++++---- - ...trinsic_int_real_array_const_promotion_1.f | 18 ++ - ...trinsic_int_real_array_const_promotion_2.f | 18 ++ - ...trinsic_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 +++++++++ - .../gfortran.dg/dec_kind_promotion-1.f | 40 +++ - .../gfortran.dg/dec_kind_promotion-2.f | 40 +++ - .../gfortran.dg/dec_kind_promotion-3.f | 39 +++ - 22 files changed, 1639 insertions(+), 80 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.cc b/gcc/fortran/check.cc -index 623c1cc470e..e20a834a860 100644 ---- a/gcc/fortran/check.cc -+++ b/gcc/fortran/check.cc -@@ -1396,12 +1396,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; - -@@ -3724,6 +3752,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) - { -@@ -3748,7 +3811,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); - } - - -@@ -5121,6 +5187,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.cc b/gcc/fortran/intrinsic.cc -index e68eff8bdbb..81b3a24c2be 100644 ---- a/gcc/fortran/intrinsic.cc -+++ b/gcc/fortran/intrinsic.cc -@@ -4467,6 +4467,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.cc b/gcc/fortran/iresolve.cc -index e17fe45f080..b9cdaff2499 100644 ---- a/gcc/fortran/iresolve.cc -+++ b/gcc/fortran/iresolve.cc -@@ -834,19 +834,22 @@ gfc_resolve_dble (gfc_expr *f, gfc_expr - 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), -@@ -1622,14 +1625,17 @@ gfc_resolve_minmax (const char *name, gf - /* 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); - } - -@@ -2130,19 +2136,22 @@ gfc_resolve_minval (gfc_expr *f, gfc_exp - 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), -@@ -2153,19 +2162,22 @@ gfc_resolve_mod (gfc_expr *f, gfc_expr * - 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), -@@ -2543,9 +2555,26 @@ gfc_resolve_shift (gfc_expr *f, gfc_expr - - - 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), - gfc_type_abi_kind (&a->ts)); -diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt -index d886c2f33ed..4ca2f93f2df 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -505,6 +505,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.cc b/gcc/fortran/options.cc -index a946c86790a..15079c7e95a 100644 ---- a/gcc/fortran/options.cc -+++ b/gcc/fortran/options.cc -@@ -82,6 +82,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_old_init, value, value); - SET_BITFLAG (flag_dec_override_kind, value, value); - SET_BITFLAG (flag_dec_non_logical_if, value, value); -+ SET_BITFLAG (flag_dec_promotion, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc -index 9900572424f..3419e06fec2 100644 ---- a/gcc/fortran/simplify.cc -+++ b/gcc/fortran/simplify.cc -@@ -2333,39 +2333,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"); -@@ -4953,6 +4993,76 @@ 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: -@@ -5912,7 +6022,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; - -@@ -5942,16 +6054,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"); -@@ -5964,7 +6084,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; - -@@ -5991,28 +6113,36 @@ gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) - 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"); -@@ -7578,27 +7708,41 @@ gfc_expr * - gfc_simplify_sign (gfc_expr *x, gfc_expr *y) - { - gfc_expr *result; -+ bool neg; - - if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) - return NULL; - - result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where); - -+ switch (y->ts.type) -+ { -+ case BT_INTEGER: -+ neg = (mpz_sgn (y->value.integer) < 0); -+ break; -+ -+ case BT_REAL: -+ neg = (mpfr_sgn (y->value.real) < 0); -+ break; -+ -+ default: -+ gfc_internal_error ("Bad type in gfc_simplify_sign"); -+ } -+ - switch (x->ts.type) - { - case BT_INTEGER: - mpz_abs (result->value.integer, x->value.integer); -- if (mpz_sgn (y->value.integer) < 0) -+ if (neg) - mpz_neg (result->value.integer, result->value.integer); - break; - - case BT_REAL: -- if (flag_sign_zero) -+ if (flag_sign_zero && y->ts.type == BT_REAL) - mpfr_copysign (result->value.real, x->value.real, y->value.real, -- GFC_RND_MODE); -+ GFC_RND_MODE); - else -- mpfr_setsign (result->value.real, x->value.real, -- mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE); -+ mpfr_setsign (result->value.real, x->value.real, neg, GFC_RND_MODE); - break; - - default: -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f -new file mode 100644 -index 00000000000..25763852139 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_1.f -@@ -0,0 +1,18 @@ -+! { dg-do compile } -+! { dg-options "-fdec" } -+! -+! Test promotion between integers and reals for mod and modulo where -+! A is a constant array and P is zero. -+! -+! Compilation errors are expected -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ program promotion_int_real_array_const -+ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } -+ a = mod([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } -+ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } -+ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f -new file mode 100644 -index 00000000000..b78a46054f4 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_2.f -@@ -0,0 +1,18 @@ -+! { dg-do compile } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals for mod and modulo where -+! A is a constant array and P is zero. -+! -+! Compilation errors are expected -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ program promotion_int_real_array_const -+ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } -+ a = mod([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } -+ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "shall not be zero" } -+ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "shall not be zero" } -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f -new file mode 100644 -index 00000000000..318ab5db97e ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_array_const_promotion_3.f -@@ -0,0 +1,18 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-promotion" } -+! -+! Test promotion between integers and reals for mod and modulo where -+! A is a constant array and P is zero. -+! -+! Compilation errors are expected -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ program promotion_int_real_array_const -+ real a(2) = mod([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } -+ a = mod([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'mod'" } -+ real b(2) = modulo([12, 34], 0.0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } -+ b = modulo([12.0, 34.0], 0)*4 ! { dg-error "'a' and 'p' arguments of 'modulo'" } -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f -new file mode 100644 -index 00000000000..27eb2582bb2 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_1.f -@@ -0,0 +1,90 @@ -+! { dg-do run } -+! { dg-options "-fdec -finit-real=snan" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real_const -+ ! array_nan 4th position value is NAN -+ REAL array_nan(4) -+ DATA array_nan(1)/-4.0/ -+ DATA array_nan(2)/3.0/ -+ DATA array_nan(3)/-2/ -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ m_i = MOD(4, 3) -+ if (m_i .ne. 1) STOP 1 -+ m_r = MOD(4.0, 3.0) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 2 -+ m_r = MOD(4, 3.0) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(4.0, 3) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ -+ md_i = MODULO(4, 3) -+ if (md_i .ne. 1) STOP 5 -+ md_r = MODULO(4.0, 3.0) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 6 -+ md_r = MODULO(4, 3.0) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 7 -+ md_r = MODULO(4.0, 3) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 8 -+ -+ d_i = DIM(4, 3) -+ if (d_i .ne. 1) STOP 9 -+ d_r = DIM(4.0, 3.0) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 10 -+ d_r = DIM(4.0, 3) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 11 -+ d_r = DIM(3, 4.0) -+ if (abs(d_r) > 1.0D-6) STOP 12 -+ -+ s_i = SIGN(-4, 3) -+ if (s_i .ne. 4) STOP 13 -+ s_r = SIGN(4.0, -3.0) -+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14 -+ s_r = SIGN(4.0, -3) -+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 -+ s_r = SIGN(-4, 3.0) -+ if (abs(s_r - 4.0) > 1.0D-6) STOP 16 -+ -+ mx_i = MAX(-4, -3, 2, 1) -+ if (mx_i .ne. 2) STOP 17 -+ mx_r = MAX(-4.0, -3.0, 2.0, 1.0) -+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 18 -+ mx_r = MAX(-4, -3.0, 2.0, 1) -+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 19 -+ mx_i = MAXLOC(array_nan, 1) -+ if (mx_i .ne. 2) STOP 20 -+ -+ mn_i = MIN(-4, -3, 2, 1) -+ if (mn_i .ne. -4) STOP 21 -+ mn_r = MIN(-4.0, -3.0, 2.0, 1.0) -+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22 -+ mn_r = MIN(-4, -3.0, 2.0, 1) -+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23 -+ mn_i = MINLOC(array_nan, 1) -+ if (mn_i .ne. 1) STOP 24 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f -new file mode 100644 -index 00000000000..bdd017b7280 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_2.f -@@ -0,0 +1,90 @@ -+! { dg-do run } -+! { dg-options "-fdec-promotion -finit-real=snan" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real_const -+ ! array_nan 4th position value is NAN -+ REAL array_nan(4) -+ DATA array_nan(1)/-4.0/ -+ DATA array_nan(2)/3.0/ -+ DATA array_nan(3)/-2/ -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ m_i = MOD(4, 3) -+ if (m_i .ne. 1) STOP 1 -+ m_r = MOD(4.0, 3.0) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 2 -+ m_r = MOD(4, 3.0) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(4.0, 3) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ -+ md_i = MODULO(4, 3) -+ if (md_i .ne. 1) STOP 5 -+ md_r = MODULO(4.0, 3.0) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 6 -+ md_r = MODULO(4, 3.0) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 7 -+ md_r = MODULO(4.0, 3) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 8 -+ -+ d_i = DIM(4, 3) -+ if (d_i .ne. 1) STOP 9 -+ d_r = DIM(4.0, 3.0) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 10 -+ d_r = DIM(4.0, 3) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 11 -+ d_r = DIM(3, 4.0) -+ if (abs(d_r) > 1.0D-6) STOP 12 -+ -+ s_i = SIGN(-4, 3) -+ if (s_i .ne. 4) STOP 13 -+ s_r = SIGN(4.0, -3.0) -+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14 -+ s_r = SIGN(4.0, -3) -+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 -+ s_r = SIGN(-4, 3.0) -+ if (abs(s_r - 4.0) > 1.0D-6) STOP 16 -+ -+ mx_i = MAX(-4, -3, 2, 1) -+ if (mx_i .ne. 2) STOP 17 -+ mx_r = MAX(-4.0, -3.0, 2.0, 1.0) -+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 18 -+ mx_r = MAX(-4, -3.0, 2.0, 1) -+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 19 -+ mx_i = MAXLOC(array_nan, 1) -+ if (mx_i .ne. 2) STOP 20 -+ -+ mn_i = MIN(-4, -3, 2, 1) -+ if (mn_i .ne. -4) STOP 21 -+ mn_r = MIN(-4.0, -3.0, 2.0, 1.0) -+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22 -+ mn_r = MIN(-4, -3.0, 2.0, 1) -+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23 -+ mn_i = MINLOC(array_nan, 1) -+ if (mn_i .ne. 1) STOP 24 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f -new file mode 100644 -index 00000000000..ce90a5667d6 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_const_promotion_3.f -@@ -0,0 +1,92 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-promotion -finit-real=snan" } -+! -+! Test that there is no promotion between integers and reals in -+! intrinsic operations. -+! -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real_const -+ ! array_nan 4th position value is NAN -+ REAL array_nan(4) -+ DATA array_nan(1)/-4.0/ -+ DATA array_nan(2)/3.0/ -+ DATA array_nan(3)/-2/ -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ m_i = MOD(4, 3) -+ if (m_i .ne. 1) STOP 1 -+ m_r = MOD(4.0, 3.0) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 2 -+ m_r = MOD(4, 3.0) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(4.0, 3) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ -+ md_i = MODULO(4, 3) -+ if (md_i .ne. 1) STOP 5 -+ md_r = MODULO(4.0, 3.0) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 6 -+ md_r = MODULO(4, 3.0) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 7 -+ md_r = MODULO(4.0, 3) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 8 -+ -+ d_i = DIM(4, 3) -+ if (d_i .ne. 1) STOP 9 -+ d_r = DIM(4.0, 3.0) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 10 -+ d_r = DIM(4.0, 3) ! { dg-error "'x' and 'y' arguments" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 11 -+ d_r = DIM(3, 4.0) ! { dg-error "'x' and 'y' arguments" } -+ if (abs(d_r) > 1.0D-6) STOP 12 -+ -+ s_i = SIGN(-4, 3) -+ if (s_i .ne. 4) STOP 13 -+ s_r = SIGN(4.0, -3.0) -+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 14 -+ s_r = SIGN(4.0, -3) ! { dg-error "'b' argument" } -+ if (abs(s_r - (-4.0)) > 1.0D-6) STOP 15 -+ s_r = SIGN(-4, 3.0) ! { dg-error "'b' argument" } -+ if (abs(s_r - 4.0) > 1.0D-6) STOP 16 -+ -+ mx_i = MAX(-4, -3, 2, 1) -+ if (mx_i .ne. 2) STOP 17 -+ mx_r = MAX(-4.0, -3.0, 2.0, 1.0) -+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 18 -+ mx_r = MAX(-4, -3.0, 2.0, 1) ! { dg-error "'a2' argument" } -+ if (abs(mx_r - 2.0) > 1.0D-6) STOP 19 -+ mx_i = MAXLOC(array_nan, 1) -+ if (mx_i .ne. 2) STOP 20 -+ -+ mn_i = MIN(-4, -3, 2, 1) -+ if (mn_i .ne. -4) STOP 21 -+ mn_r = MIN(-4.0, -3.0, 2.0, 1.0) -+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 22 -+ mn_r = MIN(-4, -3.0, 2.0, 1) ! { dg-error "'a2' argument" } -+ if (abs(mn_r - (-4.0)) > 1.0D-6) STOP 23 -+ mn_i = MINLOC(array_nan, 1) -+ if (mn_i .ne. 1) STOP 24 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f -new file mode 100644 -index 00000000000..5c2cd931a4b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_1.f -@@ -0,0 +1,130 @@ -+! { dg-do run } -+! { dg-options "-fdec" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real -+ REAL l/0.0/ -+ INTEGER a_i/4/ -+ INTEGER*4 a2_i/4/ -+ INTEGER b_i/3/ -+ INTEGER*8 b2_i/3/ -+ INTEGER x_i/2/ -+ INTEGER y_i/1/ -+ REAL a_r/4.0/ -+ REAL*4 a2_r/4.0/ -+ REAL b_r/3.0/ -+ REAL*8 b2_r/3.0/ -+ REAL x_r/2.0/ -+ REAL y_r/1.0/ -+ -+ REAL array_nan(4) -+ DATA array_nan(1)/-4.0/ -+ DATA array_nan(2)/3.0/ -+ DATA array_nan(3)/-2/ -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ ! array_nan 4th position value is NAN -+ array_nan(4) = 0/l -+ -+ m_i = MOD(a_i, b_i) -+ if (m_i .ne. 1) STOP 1 -+ m_i = MOD(a2_i, b2_i) -+ if (m_i .ne. 1) STOP 2 -+ m_r = MOD(a_r, b_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(a2_r, b2_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ m_r = MOD(a_i, b_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_r, b_i) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 -+ -+ md_i = MODULO(a_i, b_i) -+ if (md_i .ne. 1) STOP 7 -+ md_i = MODULO(a2_i, b2_i) -+ if (md_i .ne. 1) STOP 8 -+ md_r = MODULO(a_r, b_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 -+ md_r = MODULO(a2_r, b2_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 -+ md_r = MODULO(a_i, b_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_r, b_i) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 -+ -+ d_i = DIM(a_i, b_i) -+ if (d_i .ne. 1) STOP 13 -+ d_i = DIM(a2_i, b2_i) -+ if (d_i .ne. 1) STOP 14 -+ d_r = DIM(a_r, b_r) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 -+ d_r = DIM(a2_r, b2_r) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 -+ d_r = DIM(a_r, b_i) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_i, a_r) -+ if (abs(d_r) > 1.0D-6) STOP 18 -+ -+ s_i = SIGN(-a_i, b_i) -+ if (s_i .ne. 4) STOP 19 -+ s_i = SIGN(-a2_i, b2_i) -+ if (s_i .ne. 4) STOP 20 -+ s_r = SIGN(a_r, -b_r) -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 -+ s_r = SIGN(a2_r, -b2_r) -+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 -+ s_r = SIGN(a_r, -b_i) -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 -+ s_r = SIGN(-a_i, b_r) -+ if (abs(s_r - a_r) > 1.0D-6) STOP 24 -+ -+ mx_i = MAX(-a_i, -b_i, x_i, y_i) -+ if (mx_i .ne. x_i) STOP 25 -+ mx_i = MAX(-a2_i, -b2_i, x_i, y_i) -+ if (mx_i .ne. x_i) STOP 26 -+ mx_r = MAX(-a_r, -b_r, x_r, y_r) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27 -+ mx_r = MAX(-a_r, -b_r, x_r, y_r) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28 -+ mx_r = MAX(-a_i, -b_r, x_r, y_i) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29 -+ mx_i = MAXLOC(array_nan, 1) -+ if (mx_i .ne. 2) STOP 30 -+ -+ mn_i = MIN(-a_i, -b_i, x_i, y_i) -+ if (mn_i .ne. -a_i) STOP 31 -+ mn_i = MIN(-a2_i, -b2_i, x_i, y_i) -+ if (mn_i .ne. -a2_i) STOP 32 -+ mn_r = MIN(-a_r, -b_r, x_r, y_r) -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 -+ mn_r = MIN(-a2_r, -b2_r, x_r, y_r) -+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 -+ mn_r = MIN(-a_i, -b_r, x_r, y_i) -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 -+ mn_i = MINLOC(array_nan, 1) -+ if (mn_i .ne. 1) STOP 36 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f -new file mode 100644 -index 00000000000..d64d468f7d1 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_2.f -@@ -0,0 +1,130 @@ -+! { dg-do run } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real -+ REAL l/0.0/ -+ INTEGER a_i/4/ -+ INTEGER*4 a2_i/4/ -+ INTEGER b_i/3/ -+ INTEGER*8 b2_i/3/ -+ INTEGER x_i/2/ -+ INTEGER y_i/1/ -+ REAL a_r/4.0/ -+ REAL*4 a2_r/4.0/ -+ REAL b_r/3.0/ -+ REAL*8 b2_r/3.0/ -+ REAL x_r/2.0/ -+ REAL y_r/1.0/ -+ -+ REAL array_nan(4) -+ DATA array_nan(1)/-4.0/ -+ DATA array_nan(2)/3.0/ -+ DATA array_nan(3)/-2/ -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ ! array_nan 4th position value is NAN -+ array_nan(4) = 0/l -+ -+ m_i = MOD(a_i, b_i) -+ if (m_i .ne. 1) STOP 1 -+ m_i = MOD(a2_i, b2_i) -+ if (m_i .ne. 1) STOP 2 -+ m_r = MOD(a_r, b_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(a2_r, b2_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ m_r = MOD(a_i, b_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_r, b_i) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 -+ -+ md_i = MODULO(a_i, b_i) -+ if (md_i .ne. 1) STOP 7 -+ md_i = MODULO(a2_i, b2_i) -+ if (md_i .ne. 1) STOP 8 -+ md_r = MODULO(a_r, b_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 -+ md_r = MODULO(a2_r, b2_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 -+ md_r = MODULO(a_i, b_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_r, b_i) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 -+ -+ d_i = DIM(a_i, b_i) -+ if (d_i .ne. 1) STOP 13 -+ d_i = DIM(a2_i, b2_i) -+ if (d_i .ne. 1) STOP 14 -+ d_r = DIM(a_r, b_r) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 -+ d_r = DIM(a2_r, b2_r) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 -+ d_r = DIM(a_r, b_i) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_i, a_r) -+ if (abs(d_r) > 1.0D-6) STOP 18 -+ -+ s_i = SIGN(-a_i, b_i) -+ if (s_i .ne. 4) STOP 19 -+ s_i = SIGN(-a2_i, b2_i) -+ if (s_i .ne. 4) STOP 20 -+ s_r = SIGN(a_r, -b_r) -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 -+ s_r = SIGN(a2_r, -b2_r) -+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 -+ s_r = SIGN(a_r, -b_i) -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 -+ s_r = SIGN(-a_i, b_r) -+ if (abs(s_r - a_r) > 1.0D-6) STOP 24 -+ -+ mx_i = MAX(-a_i, -b_i, x_i, y_i) -+ if (mx_i .ne. x_i) STOP 25 -+ mx_i = MAX(-a2_i, -b2_i, x_i, y_i) -+ if (mx_i .ne. x_i) STOP 26 -+ mx_r = MAX(-a_r, -b_r, x_r, y_r) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27 -+ mx_r = MAX(-a_r, -b_r, x_r, y_r) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28 -+ mx_r = MAX(-a_i, -b_r, x_r, y_i) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29 -+ mx_i = MAXLOC(array_nan, 1) -+ if (mx_i .ne. 2) STOP 30 -+ -+ mn_i = MIN(-a_i, -b_i, x_i, y_i) -+ if (mn_i .ne. -a_i) STOP 31 -+ mn_i = MIN(-a2_i, -b2_i, x_i, y_i) -+ if (mn_i .ne. -a2_i) STOP 32 -+ mn_r = MIN(-a_r, -b_r, x_r, y_r) -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 -+ mn_r = MIN(-a2_r, -b2_r, x_r, y_r) -+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 -+ mn_r = MIN(-a_i, -b_r, x_r, y_i) -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 -+ mn_i = MINLOC(array_nan, 1) -+ if (mn_i .ne. 1) STOP 36 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f -new file mode 100644 -index 00000000000..0708b666633 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_3.f -@@ -0,0 +1,130 @@ -+! { dg-do compile } -+! { dg-options "-fdec -fno-dec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real -+ REAL l/0.0/ -+ INTEGER a_i/4/ -+ INTEGER*4 a2_i/4/ -+ INTEGER b_i/3/ -+ INTEGER*8 b2_i/3/ -+ INTEGER x_i/2/ -+ INTEGER y_i/1/ -+ REAL a_r/4.0/ -+ REAL*4 a2_r/4.0/ -+ REAL b_r/3.0/ -+ REAL*8 b2_r/3.0/ -+ REAL x_r/2.0/ -+ REAL y_r/1.0/ -+ -+ REAL array_nan(4) -+ DATA array_nan(1)/-4.0/ -+ DATA array_nan(2)/3.0/ -+ DATA array_nan(3)/-2/ -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ ! array_nan 4th position value is NAN -+ array_nan(4) = 0/l -+ -+ m_i = MOD(a_i, b_i) -+ if (m_i .ne. 1) STOP 1 -+ m_i = MOD(a2_i, b2_i) -+ if (m_i .ne. 1) STOP 2 -+ m_r = MOD(a_r, b_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(a2_r, b2_r) -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ m_r = MOD(a_i, b_r) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 -+ -+ md_i = MODULO(a_i, b_i) -+ if (md_i .ne. 1) STOP 7 -+ md_i = MODULO(a2_i, b2_i) -+ if (md_i .ne. 1) STOP 8 -+ md_r = MODULO(a_r, b_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 -+ md_r = MODULO(a2_r, b2_r) -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 -+ md_r = MODULO(a_i, b_r) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_r, b_i) ! { dg-error "'a' and 'p' arguments" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 -+ -+ d_i = DIM(a_i, b_i) -+ if (d_i .ne. 1) STOP 13 -+ d_i = DIM(a2_i, b2_i) -+ if (d_i .ne. 1) STOP 14 -+ d_r = DIM(a_r, b_r) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 -+ d_r = DIM(a2_r, b2_r) -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 -+ d_r = DIM(a_r, b_i) ! { dg-error "'x' and 'y' arguments" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_i, a_r) ! { dg-error "'x' and 'y' arguments" } -+ if (abs(d_r) > 1.0D-6) STOP 18 -+ -+ s_i = SIGN(-a_i, b_i) -+ if (s_i .ne. 4) STOP 19 -+ s_i = SIGN(-a2_i, b2_i) ! { dg-error "'b' argument" } -+ if (s_i .ne. 4) STOP 20 -+ s_r = SIGN(a_r, -b_r) -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 -+ s_r = SIGN(a2_r, -b2_r) ! { dg-error "'b' argument" } -+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 -+ s_r = SIGN(a_r, -b_i) ! { dg-error "'b' argument" } -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 -+ s_r = SIGN(-a_i, b_r) ! { dg-error "'b' argument" } -+ if (abs(s_r - a_r) > 1.0D-6) STOP 24 -+ -+ mx_i = MAX(-a_i, -b_i, x_i, y_i) -+ if (mx_i .ne. x_i) STOP 25 -+ mx_i = MAX(-a2_i, -b2_i, x_i, y_i) -+ if (mx_i .ne. x_i) STOP 26 -+ mx_r = MAX(-a_r, -b_r, x_r, y_r) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27 -+ mx_r = MAX(-a_r, -b_r, x_r, y_r) -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28 -+ mx_r = MAX(-a_i, -b_r, x_r, y_i) ! { dg-error "'a2' argument" } -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29 -+ mx_i = MAXLOC(array_nan, 1) -+ if (mx_i .ne. 2) STOP 30 -+ -+ mn_i = MIN(-a_i, -b_i, x_i, y_i) -+ if (mn_i .ne. -a_i) STOP 31 -+ mn_i = MIN(-a2_i, -b2_i, x_i, y_i) -+ if (mn_i .ne. -a2_i) STOP 32 -+ mn_r = MIN(-a_r, -b_r, x_r, y_r) -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 -+ mn_r = MIN(-a2_r, -b2_r, x_r, y_r) -+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 -+ mn_r = MIN(-a_i, -b_r, x_r, y_i) ! { dg-error "'a2' argument" } -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 -+ mn_i = MINLOC(array_nan, 1) -+ if (mn_i .ne. 1) STOP 36 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f -new file mode 100644 -index 00000000000..efa4f236410 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_4.f -@@ -0,0 +1,118 @@ -+! { dg-do compile } -+! { dg-options "-fdec" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real -+ REAL l/0.0/ -+ LOGICAL a_l -+ LOGICAL*4 a2_l -+ LOGICAL b_l -+ LOGICAL*8 b2_l -+ LOGICAL x_l -+ LOGICAL y_l -+ CHARACTER a_c -+ CHARACTER*4 a2_c -+ CHARACTER b_c -+ CHARACTER*8 b2_c -+ CHARACTER x_c -+ CHARACTER y_c -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ m_i = MOD(a_l, b_l) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 1 -+ m_i = MOD(a2_l, b2_l) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 2 -+ m_r = MOD(a_c, b_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(a2_c, b2_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ m_r = MOD(a_l, b_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_c, b_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 -+ -+ md_i = MODULO(a_l, b_l) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 7 -+ md_i = MODULO(a2_l, b2_l) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 8 -+ md_r = MODULO(a_c, b_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 -+ md_r = MODULO(a2_c, b2_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 -+ md_r = MODULO(a_l, b_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_c, b_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 -+ -+ d_i = DIM(a_l, b_l) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 13 -+ d_i = DIM(a2_l, b2_l) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 14 -+ d_r = DIM(a_c, b_c) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 -+ d_r = DIM(a2_c, b2_c) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 -+ d_r = DIM(a_c, b_l) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_l, a_c) ! { dg-error "" } -+ if (abs(d_r) > 1.0D-6) STOP 18 -+ -+ s_i = SIGN(-a_l, b_l) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 19 -+ s_i = SIGN(-a2_l, b2_l) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 20 -+ s_r = SIGN(a_c, -b_c) ! { dg-error "" } -+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 21 ! { dg-error "" } -+ s_r = SIGN(a2_c, -b2_c) ! { dg-error "" } -+ if (abs(s_r - (-a2_c)) > 1.0D-6) STOP 22 ! { dg-error "" } -+ s_r = SIGN(a_c, -b_l) ! { dg-error "" } -+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 23 ! { dg-error "" } -+ s_r = SIGN(-a_l, b_c) ! { dg-error "" } -+ if (abs(s_r - a_c) > 1.0D-6) STOP 24 ! { dg-error "" } -+ -+ mx_i = MAX(-a_l, -b_l, x_l, y_l) ! { dg-error "" } -+ if (mx_i .ne. x_l) STOP 25 ! { dg-error "" } -+ mx_i = MAX(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } -+ if (mx_i .ne. x_l) STOP 26 ! { dg-error "" } -+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mx_r - x_c) > 1.0D-6) STOP 27 ! { dg-error "" } -+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mx_r - x_c) > 1.0D-6) STOP 28 ! { dg-error "" } -+ mx_r = MAX(-a_l, -b_c, x_c, y_l) ! { dg-error "" } -+ if (abs(mx_r - x_c) > 1.0D-6) STOP 29 ! { dg-error "" } -+ -+ mn_i = MIN(-a_l, -b_l, x_l, y_l) ! { dg-error "" } -+ if (mn_i .ne. -a_l) STOP 31 ! { dg-error "" } -+ mn_i = MIN(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } -+ if (mn_i .ne. -a2_l) STOP 32 ! { dg-error "" } -+ mn_r = MIN(-a_c, -b_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 33 ! { dg-error "" } -+ mn_r = MIN(-a2_c, -b2_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mn_r - (-a2_c)) > 1.0D-6) STOP 34 ! { dg-error "" } -+ mn_r = MIN(-a_l, -b_c, x_c, y_l) ! { dg-error "" } -+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 35 ! { dg-error "" } -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f -new file mode 100644 -index 00000000000..d023af5086d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_5.f -@@ -0,0 +1,118 @@ -+! { dg-do compile } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real -+ REAL l/0.0/ -+ LOGICAL a_l -+ LOGICAL*4 a2_l -+ LOGICAL b_l -+ LOGICAL*8 b2_l -+ LOGICAL x_l -+ LOGICAL y_l -+ CHARACTER a_c -+ CHARACTER*4 a2_c -+ CHARACTER b_c -+ CHARACTER*8 b2_c -+ CHARACTER x_c -+ CHARACTER y_c -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ m_i = MOD(a_l, b_l) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 1 -+ m_i = MOD(a2_l, b2_l) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 2 -+ m_r = MOD(a_c, b_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(a2_c, b2_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ m_r = MOD(a_l, b_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_c, b_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 -+ -+ md_i = MODULO(a_l, b_l) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 7 -+ md_i = MODULO(a2_l, b2_l) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 8 -+ md_r = MODULO(a_c, b_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 -+ md_r = MODULO(a2_c, b2_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 -+ md_r = MODULO(a_l, b_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_c, b_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 -+ -+ d_i = DIM(a_l, b_l) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 13 -+ d_i = DIM(a2_l, b2_l) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 14 -+ d_r = DIM(a_c, b_c) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 -+ d_r = DIM(a2_c, b2_c) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 -+ d_r = DIM(a_c, b_l) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_l, a_c) ! { dg-error "" } -+ if (abs(d_r) > 1.0D-6) STOP 18 -+ -+ s_i = SIGN(-a_l, b_l) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 19 -+ s_i = SIGN(-a2_l, b2_l) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 20 -+ s_r = SIGN(a_c, -b_c) ! { dg-error "" } -+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 21 ! { dg-error "" } -+ s_r = SIGN(a2_c, -b2_c) ! { dg-error "" } -+ if (abs(s_r - (-a2_c)) > 1.0D-6) STOP 22 ! { dg-error "" } -+ s_r = SIGN(a_c, -b_l) ! { dg-error "" } -+ if (abs(s_r - (-a_c)) > 1.0D-6) STOP 23 ! { dg-error "" } -+ s_r = SIGN(-a_l, b_c) ! { dg-error "" } -+ if (abs(s_r - a_c) > 1.0D-6) STOP 24 ! { dg-error "" } -+ -+ mx_i = MAX(-a_l, -b_l, x_l, y_l) ! { dg-error "" } -+ if (mx_i .ne. x_l) STOP 25 ! { dg-error "" } -+ mx_i = MAX(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } -+ if (mx_i .ne. x_l) STOP 26 ! { dg-error "" } -+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mx_r - x_c) > 1.0D-6) STOP 27 ! { dg-error "" } -+ mx_r = MAX(-a_c, -b_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mx_r - x_c) > 1.0D-6) STOP 28 ! { dg-error "" } -+ mx_r = MAX(-a_l, -b_c, x_c, y_l) ! { dg-error "" } -+ if (abs(mx_r - x_c) > 1.0D-6) STOP 29 ! { dg-error "" } -+ -+ mn_i = MIN(-a_l, -b_l, x_l, y_l) ! { dg-error "" } -+ if (mn_i .ne. -a_l) STOP 31 ! { dg-error "" } -+ mn_i = MIN(-a2_l, -b2_l, x_l, y_l) ! { dg-error "" } -+ if (mn_i .ne. -a2_l) STOP 32 ! { dg-error "" } -+ mn_r = MIN(-a_c, -b_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 33 ! { dg-error "" } -+ mn_r = MIN(-a2_c, -b2_c, x_c, y_c) ! { dg-error "" } -+ if (abs(mn_r - (-a2_c)) > 1.0D-6) STOP 34 ! { dg-error "" } -+ mn_r = MIN(-a_l, -b_c, x_c, y_l) ! { dg-error "" } -+ if (abs(mn_r - (-a_c)) > 1.0D-6) STOP 35 ! { dg-error "" } -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f -new file mode 100644 -index 00000000000..00f8fb88f1b ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_6.f -@@ -0,0 +1,118 @@ -+! { dg-do compile } -+! { dg-options "-fdec" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real -+ REAL l/0.0/ -+ INTEGER a_i/4/ -+ INTEGER*4 a2_i/4/ -+ CHARACTER b_c -+ CHARACTER*8 b2_c -+ INTEGER x_i/2/ -+ CHARACTER y_c -+ REAL a_r/4.0/ -+ REAL*4 a2_r/4.0/ -+ LOGICAL b_l -+ LOGICAL*8 b2_l -+ REAL x_r/2.0/ -+ LOGICAL y_l -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ m_i = MOD(a_i, b_c) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 1 -+ m_i = MOD(a2_i, b2_c) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 2 -+ m_r = MOD(a_r, b_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(a2_r, b2_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ m_r = MOD(a_i, b_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_r, b_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 -+ -+ md_i = MODULO(a_i, b_c) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 7 -+ md_i = MODULO(a2_i, b2_c) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 8 -+ md_r = MODULO(a_r, b_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 -+ md_r = MODULO(a2_r, b2_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 -+ md_r = MODULO(a_i, b_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_r, b_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 -+ -+ d_i = DIM(a_i, b_c) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 13 -+ d_i = DIM(a2_i, b2_c) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 14 -+ d_r = DIM(a_r, b_l) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 -+ d_r = DIM(a2_r, b2_l) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 -+ d_r = DIM(a_r, b_c) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_c, a_r) ! { dg-error "" } -+ if (abs(d_r) > 1.0D-6) STOP 18 -+ -+ s_i = SIGN(-a_i, b_c) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 19 -+ s_i = SIGN(-a2_i, b2_c) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 20 -+ s_r = SIGN(a_r, -b_l) ! { dg-error "" } -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 -+ s_r = SIGN(a2_r, -b2_l) ! { dg-error "" } -+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 -+ s_r = SIGN(a_r, -b_c) ! { dg-error "" } -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 -+ s_r = SIGN(-a_i, b_l) ! { dg-error "" } -+ if (abs(s_r - a_r) > 1.0D-6) STOP 24 -+ -+ mx_i = MAX(-a_i, -b_c, x_i, y_c) ! { dg-error "" } -+ if (mx_i .ne. x_i) STOP 25 -+ mx_i = MAX(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } -+ if (mx_i .ne. x_i) STOP 26 -+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27 -+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28 -+ mx_r = MAX(-a_i, -b_l, x_r, y_c) ! { dg-error "" } -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29 -+ -+ mn_i = MIN(-a_i, -b_c, x_i, y_c) ! { dg-error "" } -+ if (mn_i .ne. -a_i) STOP 31 -+ mn_i = MIN(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } -+ if (mn_i .ne. -a2_i) STOP 32 -+ mn_r = MIN(-a_r, -b_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 -+ mn_r = MIN(-a2_r, -b2_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 -+ mn_r = MIN(-a_i, -b_l, x_r, y_c) ! { dg-error "" } -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f -new file mode 100644 -index 00000000000..1d4150d81c0 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_intrinsic_int_real_promotion_7.f -@@ -0,0 +1,118 @@ -+! { dg-do compile } -+! { dg-options "-fdec-promotion" } -+! -+! Test promotion between integers and reals in intrinsic operations. -+! These operations are: mod, modulo, dim, sign, min, max, minloc and -+! maxloc. -+! -+! Contributed by Francisco Redondo Marchena -+! and Jeff Law -+! Modified by Mark Eggleston -+! -+ PROGRAM promotion_int_real -+ REAL l/0.0/ -+ INTEGER a_i/4/ -+ INTEGER*4 a2_i/4/ -+ CHARACTER b_c -+ CHARACTER*8 b2_c -+ INTEGER x_i/2/ -+ CHARACTER y_c -+ REAL a_r/4.0/ -+ REAL*4 a2_r/4.0/ -+ LOGICAL b_l -+ LOGICAL*8 b2_l -+ REAL x_r/2.0/ -+ LOGICAL y_l -+ -+ INTEGER m_i/0/ -+ REAL m_r/0.0/ -+ -+ INTEGER md_i/0/ -+ REAL md_r/0.0/ -+ -+ INTEGER d_i/0/ -+ REAL d_r/0.0/ -+ -+ INTEGER s_i/0/ -+ REAL s_r/0.0/ -+ -+ INTEGER mn_i/0/ -+ REAL mn_r/0.0/ -+ -+ INTEGER mx_i/0/ -+ REAL mx_r/0.0/ -+ -+ m_i = MOD(a_i, b_c) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 1 -+ m_i = MOD(a2_i, b2_c) ! { dg-error "" } -+ if (m_i .ne. 1) STOP 2 -+ m_r = MOD(a_r, b_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 3 -+ m_r = MOD(a2_r, b2_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 4 -+ m_r = MOD(a_i, b_l) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 5 -+ m_r = MOD(a_r, b_c) ! { dg-error "" } -+ if (abs(m_r - 1.0) > 1.0D-6) STOP 6 -+ -+ md_i = MODULO(a_i, b_c) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 7 -+ md_i = MODULO(a2_i, b2_c) ! { dg-error "" } -+ if (md_i .ne. 1) STOP 8 -+ md_r = MODULO(a_r, b_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 9 -+ md_r = MODULO(a2_r, b2_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 10 -+ md_r = MODULO(a_i, b_l) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 11 -+ md_r = MODULO(a_r, b_c) ! { dg-error "" } -+ if (abs(md_r - 1.0) > 1.0D-6) STOP 12 -+ -+ d_i = DIM(a_i, b_c) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 13 -+ d_i = DIM(a2_i, b2_c) ! { dg-error "" } -+ if (d_i .ne. 1) STOP 14 -+ d_r = DIM(a_r, b_l) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 15 -+ d_r = DIM(a2_r, b2_l) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 16 -+ d_r = DIM(a_r, b_c) ! { dg-error "" } -+ if (abs(d_r - 1.0) > 1.0D-6) STOP 17 -+ d_r = DIM(b_c, a_r) ! { dg-error "" } -+ if (abs(d_r) > 1.0D-6) STOP 18 -+ -+ s_i = SIGN(-a_i, b_c) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 19 -+ s_i = SIGN(-a2_i, b2_c) ! { dg-error "" } -+ if (s_i .ne. 4) STOP 20 -+ s_r = SIGN(a_r, -b_l) ! { dg-error "" } -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 21 -+ s_r = SIGN(a2_r, -b2_l) ! { dg-error "" } -+ if (abs(s_r - (-a2_r)) > 1.0D-6) STOP 22 -+ s_r = SIGN(a_r, -b_c) ! { dg-error "" } -+ if (abs(s_r - (-a_r)) > 1.0D-6) STOP 23 -+ s_r = SIGN(-a_i, b_l) ! { dg-error "" } -+ if (abs(s_r - a_r) > 1.0D-6) STOP 24 -+ -+ mx_i = MAX(-a_i, -b_c, x_i, y_c) ! { dg-error "" } -+ if (mx_i .ne. x_i) STOP 25 -+ mx_i = MAX(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } -+ if (mx_i .ne. x_i) STOP 26 -+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 27 -+ mx_r = MAX(-a_r, -b_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 28 -+ mx_r = MAX(-a_i, -b_l, x_r, y_c) ! { dg-error "" } -+ if (abs(mx_r - x_r) > 1.0D-6) STOP 29 -+ -+ mn_i = MIN(-a_i, -b_c, x_i, y_c) ! { dg-error "" } -+ if (mn_i .ne. -a_i) STOP 31 -+ mn_i = MIN(-a2_i, -b2_c, x_i, y_c) ! { dg-error "" } -+ if (mn_i .ne. -a2_i) STOP 32 -+ mn_r = MIN(-a_r, -b_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 33 -+ mn_r = MIN(-a2_r, -b2_l, x_r, y_l) ! { dg-error "" } -+ if (abs(mn_r - (-a2_r)) > 1.0D-6) STOP 34 -+ mn_r = MIN(-a_i, -b_l, x_r, y_c) ! { dg-error "" } -+ if (abs(mn_r - (-a_r)) > 1.0D-6) STOP 35 -+ END PROGRAM -diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f -new file mode 100644 -index 00000000000..435bf98350c ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-1.f -@@ -0,0 +1,40 @@ -+!{ dg-do run } -+!{ dg-options "-fdec" } -+! -+! integer types of a smaller kind than expected should be -+! accepted by type specific intrinsic functions -+! -+! Contributed by Mark Eggleston -+! -+ program test_small_type_promtion -+ implicit none -+ integer(1) :: a = 1 -+ integer :: i -+ if (iiabs(-9_1).ne.9) stop 1 -+ if (iabs(-9_1).ne.9) stop 2 -+ if (iabs(-9_2).ne.9) stop 3 -+ if (jiabs(-9_1).ne.9) stop 4 -+ if (jiabs(-9_2).ne.9) stop 5 -+ if (iishft(1_1, 2).ne.4) stop 6 -+ if (jishft(1_1, 2).ne.4) stop 7 -+ if (jishft(1_2, 2).ne.4) stop 8 -+ if (kishft(1_1, 2).ne.4) stop 9 -+ if (kishft(1_2, 2).ne.4) stop 10 -+ if (kishft(1_4, 2).ne.4) stop 11 -+ if (imod(17_1, 3).ne.2) stop 12 -+ if (jmod(17_1, 3).ne.2) stop 13 -+ if (jmod(17_2, 3).ne.2) stop 14 -+ if (kmod(17_1, 3).ne.2) stop 15 -+ if (kmod(17_2, 3).ne.2) stop 16 -+ if (kmod(17_4, 3).ne.2) stop 17 -+ if (inot(5_1).ne.-6) stop 18 -+ if (jnot(5_1).ne.-6) stop 19 -+ if (jnot(5_2).ne.-6) stop 20 -+ if (knot(5_1).ne.-6) stop 21 -+ if (knot(5_2).ne.-6) stop 22 -+ if (knot(5_4).ne.-6) stop 23 -+ if (isign(-77_1, 1).ne.77) stop 24 -+ if (isign(-77_1, -1).ne.-77) stop 25 -+ if (isign(-77_2, 1).ne.77) stop 26 -+ if (isign(-77_2, -1).ne.-77) stop 27 -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f -new file mode 100644 -index 00000000000..7b1697ca665 ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-2.f -@@ -0,0 +1,40 @@ -+!{ dg-do run } -+!{ dg-options "-fdec-intrinsic-ints -fdec-promotion" } -+! -+! integer types of a smaller kind than expected should be -+! accepted by type specific intrinsic functions -+! -+! Contributed by Mark Eggleston -+! -+ program test_small_type_promtion -+ implicit none -+ integer(1) :: a = 1 -+ integer :: i -+ if (iiabs(-9_1).ne.9) stop 1 -+ if (iabs(-9_1).ne.9) stop 2 -+ if (iabs(-9_2).ne.9) stop 3 -+ if (jiabs(-9_1).ne.9) stop 4 -+ if (jiabs(-9_2).ne.9) stop 5 -+ if (iishft(1_1, 2).ne.4) stop 6 -+ if (jishft(1_1, 2).ne.4) stop 7 -+ if (jishft(1_2, 2).ne.4) stop 8 -+ if (kishft(1_1, 2).ne.4) stop 9 -+ if (kishft(1_2, 2).ne.4) stop 10 -+ if (kishft(1_4, 2).ne.4) stop 11 -+ if (imod(17_1, 3).ne.2) stop 12 -+ if (jmod(17_1, 3).ne.2) stop 13 -+ if (jmod(17_2, 3).ne.2) stop 14 -+ if (kmod(17_1, 3).ne.2) stop 15 -+ if (kmod(17_2, 3).ne.2) stop 16 -+ if (kmod(17_4, 3).ne.2) stop 17 -+ if (inot(5_1).ne.-6) stop 18 -+ if (jnot(5_1).ne.-6) stop 19 -+ if (jnot(5_2).ne.-6) stop 20 -+ if (knot(5_1).ne.-6) stop 21 -+ if (knot(5_2).ne.-6) stop 22 -+ if (knot(5_4).ne.-6) stop 23 -+ if (isign(-77_1, 1).ne.77) stop 24 -+ if (isign(-77_1, -1).ne.-77) stop 25 -+ if (isign(-77_2, 1).ne.77) stop 26 -+ if (isign(-77_2, -1).ne.-77) stop 27 -+ end program -diff --git a/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f -new file mode 100644 -index 00000000000..db8dff6c55d ---- /dev/null -+++ b/gcc/testsuite/gfortran.dg/dec_kind_promotion-3.f -@@ -0,0 +1,39 @@ -+!{ dg-do compile } -+!{ dg-options "-fdec -fno-dec-promotion" } -+! -+! integer types of a smaller kind than expected should be -+! accepted by type specific intrinsic functions -+! -+! Contributed by Mark Eggleston -+! -+ program test_small_type_promtion -+ integer(1) :: a = 1 -+ integer :: i -+ if (iiabs(-9_1).ne.9) stop 1 -+ if (iabs(-9_1).ne.9) stop 2 ! { dg-error "type mismatch in argument" } -+ if (iabs(-9_2).ne.9) stop 3 ! { dg-error "type mismatch in argument" } -+ if (jiabs(-9_1).ne.9) stop 4 -+ if (jiabs(-9_2).ne.9) stop 5 -+ if (iishft(1_1, 2).ne.4) stop 6 -+ if (jishft(1_1, 2).ne.4) stop 7 -+ if (jishft(1_2, 2).ne.4) stop 8 -+ if (kishft(1_1, 2).ne.4) stop 9 -+ if (kishft(1_2, 2).ne.4) stop 10 -+ if (kishft(1_4, 2).ne.4) stop 11 -+ if (imod(17_1, 3).ne.2) stop 12 -+ if (jmod(17_1, 3).ne.2) stop 13 -+ if (jmod(17_2, 3).ne.2) stop 14 -+ if (kmod(17_1, 3).ne.2) stop 15 -+ if (kmod(17_2, 3).ne.2) stop 16 -+ if (kmod(17_4, 3).ne.2) stop 17 -+ if (inot(5_1).ne.-6) stop 18 -+ if (jnot(5_1).ne.-6) stop 19 -+ if (jnot(5_2).ne.-6) stop 20 -+ if (knot(5_1).ne.-6) stop 21 -+ if (knot(5_2).ne.-6) stop 22 -+ if (knot(5_4).ne.-6) stop 23 -+ if (isign(-77_1, 1).ne.77) stop 24 ! { dg-error "type mismatch in argument" } -+ if (isign(-77_1, -1).ne.-77) stop 25 ! { dg-error "type mismatch in argument" } -+ if (isign(-77_2, 1).ne.77) stop 26 ! { dg-error "type mismatch in argument" } -+ if (isign(-77_2, -1).ne.-77) stop 27 ! { dg-error "type mismatch in argument" } -+ end program --- -2.27.0 - diff --git a/gcc12-fortran-fdec-sequence.patch b/gcc12-fortran-fdec-sequence.patch deleted file mode 100644 index d79348e..0000000 --- a/gcc12-fortran-fdec-sequence.patch +++ /dev/null @@ -1,262 +0,0 @@ -From bb76446db10c21860a4e19569ce3e350d8a2b59f Mon Sep 17 00:00:00 2001 -From: Mark Eggleston -Date: Fri, 22 Jan 2021 15:00:44 +0000 -Subject: [PATCH 09/10] Add the SEQUENCE attribute by default if it's not - present. - -Use -fdec-sequence to enable this feature. Also enabled by -fdec. ---- - gcc/fortran/lang.opt | 4 ++ - gcc/fortran/options.cc | 1 + - gcc/fortran/resolve.cc | 13 ++++- - ...dd_SEQUENCE_to_COMMON_block_by_default_1.f | 57 +++++++++++++++++++ - ...dd_SEQUENCE_to_COMMON_block_by_default_2.f | 57 +++++++++++++++++++ - ...dd_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 4ca2f93f2df..019c798cf09 100644 ---- a/gcc/fortran/lang.opt -+++ b/gcc/fortran/lang.opt -@@ -509,6 +509,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.cc b/gcc/fortran/options.cc -index 15079c7e95a..050f56fdc25 100644 ---- a/gcc/fortran/options.cc -+++ b/gcc/fortran/options.cc -@@ -83,6 +83,7 @@ set_dec_flags (int value) - SET_BITFLAG (flag_dec_override_kind, value, value); - SET_BITFLAG (flag_dec_non_logical_if, value, value); - SET_BITFLAG (flag_dec_promotion, value, value); -+ SET_BITFLAG (flag_dec_sequence, value, value); - } - - /* Finalize DEC flags. */ -diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc -index 07dd039f3bf..fe7d0cc5944 100644 ---- a/gcc/fortran/resolve.cc -+++ b/gcc/fortran/resolve.cc -@@ -978,9 +978,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.27.0 -