[flang] Define ERF, ERFC and ERFC_SCALED intrinsics with Q and D prefix (#125217)

`ERF`, `ERFC` and `ERFC_SCALED` intrinsics prefixed by `Q` and `D` are
missing. Codes such as `CP2K`(https://github.com/cp2k/cp2k) and
`TurboRVB`(https://github.com/sissaschool/turborvb) use these intrinsics
just like defined in the GNU standard and here:
https://www.ibm.com/docs/fr/xl-fortran-aix/16.1.0?topic=reference-intrinsic-procedures
These intrinsics are based on the existing intrinsics but apply a
restriction on the type kind.

- `DERF`, `DERFC` and `DERFC_SCALED` are for double précision only.
- `QERF`, `QERFC` and `QERFC_SCALED` are for quad précision only.

11 files changed, 176 insertions, 5 deletions

diff --git a/flang/docs/Intrinsics.md b/flang/docs/Intrinsics.md
index c5c45c2..b09de8e 100644
--- a/flang/docs/Intrinsics.md
+++ b/flang/docs/Intrinsics.md
@@ -241,8 +241,14 @@ BESSEL_Y0(REAL(k) X) -> REAL(k)
 BESSEL_Y1(REAL(k) X) -> REAL(k)
 BESSEL_YN(INTEGER(n) N, REAL(k) X) -> REAL(k)
 ERF(REAL(k) X) -> REAL(k)
+DERF(REAL(8) X) -> REAL(8)
+QERF(REAL(16) X) -> REAL(16)
 ERFC(REAL(k) X) -> REAL(k)
+DERFC(REAL(8) X) -> REAL(8)
+QERFC(REAL(16) X) -> REAL(16)
 ERFC_SCALED(REAL(k) X) -> REAL(k)
+DERFC_SCALED(REAL(8) X) -> REAL(8)
+QERFC_SCALED(REAL(16) X) -> REAL(16)
 FRACTION(REAL(k) X) -> REAL(k)
 GAMMA(REAL(k) X) -> REAL(k)
 HYPOT(REAL(k) X, REAL(k) Y) -> REAL(k) = SQRT(X*X+Y*Y) without spurious overflow
@@ -810,7 +816,7 @@ otherwise an error message will be produced by f18 when attempting to fold relat
 
 | C/C++ Host Type | Intrinsic Functions with Host Standard C++ Library Based Folding Support |
 | --- | --- |
-| float, double and long double | ACOS, ACOSH, ASINH, ATAN, ATAN2, ATANH, COS, COSH, ERF, ERFC, EXP, GAMMA, HYPOT, LOG, LOG10, LOG_GAMMA, MOD, SIN, SQRT, SINH, SQRT, TAN, TANH |
+| float, double and long double | ACOS, ACOSH, ASINH, ATAN, ATAN2, ATANH, COS, COSH, DERF, DERFC, ERF, ERFC, EXP, GAMMA, HYPOT, LOG, LOG10, LOG_GAMMA, MOD, QERF, QERFC, SIN, SQRT, SINH, SQRT, TAN, TANH |
 | std::complex for float, double and long double| ACOS, ACOSH, ASIN, ASINH, ATAN, ATANH, COS, COSH, EXP, LOG, SIN, SINH, SQRT, TAN, TANH |
 
 On top of the default usage of C++ standard library functions for folding described
@@ -829,7 +835,7 @@ types related to host float and double types.
 
 | C/C++ Host Type | Additional Intrinsic Function Folding Support with Libpgmath (Optional) |
 | --- | --- |
-|float and double| BESSEL_J0, BESSEL_J1, BESSEL_JN (elemental only), BESSEL_Y0, BESSEL_Y1, BESSEL_Yn (elemental only), ERFC_SCALED |
+|float and double| BESSEL_J0, BESSEL_J1, BESSEL_JN (elemental only), BESSEL_Y0, BESSEL_Y1, BESSEL_Yn (elemental only), DERFC_SCALED, ERFC_SCALED, QERFC_SCALED |
 
 Libpgmath comes in three variants (precise, relaxed and fast). So far, only the
 precise version is used for intrinsic function folding in f18. It guarantees the greatest numerical precision.
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index ae77dc8d..2f34b12 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -8,6 +8,7 @@
 
 #include "flang/Evaluate/intrinsics.h"
 #include "flang/Common/enum-set.h"
+#include "flang/Common/float128.h"
 #include "flang/Common/idioms.h"
 #include "flang/Evaluate/check-expression.h"
 #include "flang/Evaluate/common.h"
@@ -83,7 +84,7 @@ static constexpr CategorySet AnyType{IntrinsicType | DerivedType};
 
 ENUM_CLASS(KindCode, none, defaultIntegerKind,
     defaultRealKind, // is also the default COMPLEX kind
-    doublePrecision, defaultCharKind, defaultLogicalKind,
+    doublePrecision, quadPrecision, defaultCharKind, defaultLogicalKind,
     greaterOrEqualToKind, // match kind value greater than or equal to a single
                           // explicit kind value
     any, // matches any kind value; each instance is independent
@@ -139,6 +140,7 @@ static constexpr TypePattern DoublePrecision{
     RealType, KindCode::doublePrecision};
 static constexpr TypePattern DoublePrecisionComplex{
     ComplexType, KindCode::doublePrecision};
+static constexpr TypePattern QuadPrecision{RealType, KindCode::quadPrecision};
 static constexpr TypePattern SubscriptInt{IntType, KindCode::subscript};
 
 // Match any kind of some intrinsic or derived types
@@ -1199,6 +1201,9 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
          DoublePrecision},
         "dim"},
     {{"derf", {{"x", DoublePrecision}}, DoublePrecision}, "erf"},
+    {{"derfc", {{"x", DoublePrecision}}, DoublePrecision}, "erfc"},
+    {{"derfc_scaled", {{"x", DoublePrecision}}, DoublePrecision},
+        "erfc_scaled"},
     {{"dexp", {{"x", DoublePrecision}}, DoublePrecision}, "exp"},
     {{"dfloat", {{"a", AnyInt}}, DoublePrecision}, "real", true},
     {{"dim", {{"x", DefaultReal}, {"y", DefaultReal}}, DefaultReal}},
@@ -1299,6 +1304,9 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
         "min", true, true},
     {{"mod", {{"a", DefaultInt}, {"p", DefaultInt}}, DefaultInt}},
     {{"nint", {{"a", DefaultReal}}, DefaultInt}},
+    {{"qerf", {{"x", QuadPrecision}}, QuadPrecision}, "erf"},
+    {{"qerfc", {{"x", QuadPrecision}}, QuadPrecision}, "erfc"},
+    {{"qerfc_scaled", {{"x", QuadPrecision}}, QuadPrecision}, "erfc_scaled"},
     {{"sign", {{"a", DefaultReal}, {"b", DefaultReal}}, DefaultReal}},
     {{"sin", {{"x", DefaultReal}}, DefaultReal}},
     {{"sinh", {{"x", DefaultReal}}, DefaultReal}},
@@ -2033,6 +2041,9 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
     case KindCode::doublePrecision:
       argOk = type->kind() == defaults.doublePrecisionKind();
       break;
+    case KindCode::quadPrecision:
+      argOk = type->kind() == defaults.quadPrecisionKind();
+      break;
     case KindCode::defaultCharKind:
       argOk = type->kind() == defaults.GetDefaultKind(TypeCategory::Character);
       break;
@@ -2343,6 +2354,18 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       CHECK(FloatingType.test(*category));
       resultType = DynamicType{*category, defaults.doublePrecisionKind()};
       break;
+    case KindCode::quadPrecision:
+      CHECK(result.categorySet == CategorySet{*category});
+      CHECK(FloatingType.test(*category));
+      resultType = DynamicType{*category, defaults.quadPrecisionKind()};
+      if (!context.targetCharacteristics().CanSupportType(
+              *category, defaults.quadPrecisionKind())) {
+        messages.Say(
+            "%s(KIND=%jd) type not supported on this target."_err_en_US,
+            parser::ToUpperCaseLetters(EnumToString(*category)),
+            defaults.quadPrecisionKind());
+      }
+      break;
     case KindCode::defaultLogicalKind:
       CHECK(result.categorySet == LogicalType);
       CHECK(*category == TypeCategory::Logical);
@@ -3341,6 +3364,7 @@ static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
   case KindCode::defaultIntegerKind:
     break;
   case KindCode::doublePrecision:
+  case KindCode::quadPrecision:
   case KindCode::defaultRealKind:
     category = TypeCategory::Real;
     break;
@@ -3349,6 +3373,8 @@ static DynamicType GetReturnType(const SpecificIntrinsicInterface &interface,
   }
   int kind{interface.result.kindCode == KindCode::doublePrecision
           ? defaults.doublePrecisionKind()
+          : interface.result.kindCode == KindCode::quadPrecision
+          ? defaults.quadPrecisionKind()
           : defaults.GetDefaultKind(category)};
   return DynamicType{category, kind};
 }
@@ -3589,6 +3615,8 @@ DynamicType IntrinsicProcTable::Implementation::GetSpecificType(
   TypeCategory category{set.LeastElement().value()};
   if (pattern.kindCode == KindCode::doublePrecision) {
     return DynamicType{category, defaults_.doublePrecisionKind()};
+  } else if (pattern.kindCode == KindCode::quadPrecision) {
+    return DynamicType{category, defaults_.quadPrecisionKind()};
   } else if (category == TypeCategory::Character) {
     // All character arguments to specific intrinsic functions are
     // assumed-length.
diff --git a/flang/test/Lower/Intrinsics/erf.f90 b/flang/test/Lower/Intrinsics/erf.f90
new file mode 100644
index 0000000..b76ea174
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/erf.f90
@@ -0,0 +1,16 @@
+! RUN: bbc -emit-fir %s -o - --math-runtime=fast | FileCheck --check-prefixes=ALL,FAST %s
+! RUN: %flang_fc1 -emit-fir -mllvm -math-runtime=fast %s -o - | FileCheck --check-prefixes=ALL,FAST %s
+! RUN: bbc -emit-fir %s -o - --math-runtime=relaxed | FileCheck --check-prefixes=ALL,RELAXED %s
+! RUN: %flang_fc1 -emit-fir -mllvm -math-runtime=relaxed %s -o - | FileCheck --check-prefixes=ALL,RELAXED %s
+! RUN: bbc -emit-fir %s -o - --math-runtime=precise | FileCheck --check-prefixes=ALL,PRECISE %s
+! RUN: %flang_fc1 -emit-fir -mllvm -math-runtime=precise %s -o - | FileCheck --check-prefixes=ALL,PRECISE %s
+
+function dtest_real8(x)
+  real(8) :: x, dtest_real8
+  dtest_real8 = derf(x)
+end function
+
+! ALL-LABEL: @_QPdtest_real8
+! FAST: {{%[A-Za-z0-9._]+}} = math.erf {{%[A-Za-z0-9._]+}} {{.*}}: f64
+! RELAXED: {{%[A-Za-z0-9._]+}} = math.erf {{%[A-Za-z0-9._]+}} {{.*}}: f64
+! PRECISE: {{%[A-Za-z0-9._]+}} = fir.call @erf({{%[A-Za-z0-9._]+}}) {{.*}}: (f64) -> f64
diff --git a/flang/test/Lower/Intrinsics/erf_real16.f90 b/flang/test/Lower/Intrinsics/erf_real16.f90
index da40816..e9cc617 100644
--- a/flang/test/Lower/Intrinsics/erf_real16.f90
+++ b/flang/test/Lower/Intrinsics/erf_real16.f90
@@ -4,6 +4,8 @@
 ! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
 
 ! CHECK: fir.call @_FortranAErfF128({{.*}}){{.*}}: (f128) -> f128
-  real(16) :: a, b
+! CHECK: fir.call @_FortranAErfF128({{.*}}){{.*}}: (f128) -> f128
+  real(16) :: a, b, c
   b = erf(a)
+  c = qerf(a)
 end
diff --git a/flang/test/Lower/Intrinsics/erfc.f90 b/flang/test/Lower/Intrinsics/erfc.f90
index 164e958..c02e252 100644
--- a/flang/test/Lower/Intrinsics/erfc.f90
+++ b/flang/test/Lower/Intrinsics/erfc.f90
@@ -24,3 +24,13 @@ end function
 ! FAST: {{%[A-Za-z0-9._]+}} = math.erfc {{%[A-Za-z0-9._]+}} {{.*}}: f64
 ! RELAXED: {{%[A-Za-z0-9._]+}} = math.erfc {{%[A-Za-z0-9._]+}} {{.*}}: f64
 ! PRECISE: {{%[A-Za-z0-9._]+}} = fir.call @erfc({{%[A-Za-z0-9._]+}}) {{.*}}: (f64) -> f64
+
+function dtest_real8(x)
+  real(8) :: x, dtest_real8
+  dtest_real8 = derfc(x)
+end function
+
+! ALL-LABEL: @_QPdtest_real8
+! FAST: {{%[A-Za-z0-9._]+}} = math.erfc {{%[A-Za-z0-9._]+}} {{.*}}: f64
+! RELAXED: {{%[A-Za-z0-9._]+}} = math.erfc {{%[A-Za-z0-9._]+}} {{.*}}: f64
+! PRECISE: {{%[A-Za-z0-9._]+}} = fir.call @erfc({{%[A-Za-z0-9._]+}}) {{.*}}: (f64) -> f64
diff --git a/flang/test/Lower/Intrinsics/erfc_real16.f90 b/flang/test/Lower/Intrinsics/erfc_real16.f90
index 7e3daa2..d63c4d8 100644
--- a/flang/test/Lower/Intrinsics/erfc_real16.f90
+++ b/flang/test/Lower/Intrinsics/erfc_real16.f90
@@ -4,6 +4,8 @@
 ! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
 
 ! CHECK: fir.call @_FortranAErfcF128({{.*}}){{.*}}: (f128) -> f128
-  real(16) :: a, b
+! CHECK: fir.call @_FortranAErfcF128({{.*}}){{.*}}: (f128) -> f128
+  real(16) :: a, b, c
   b = erfc(a)
+  c = qerfc(a)
 end
diff --git a/flang/test/Lower/Intrinsics/erfc_scaled.f90 b/flang/test/Lower/Intrinsics/erfc_scaled.f90
index ab5e90c..f30f316 100644
--- a/flang/test/Lower/Intrinsics/erfc_scaled.f90
+++ b/flang/test/Lower/Intrinsics/erfc_scaled.f90
@@ -21,3 +21,14 @@ function erfc_scaled8(x)
 ! CHECK: %[[a1:.*]] = fir.load %[[x]] : !fir.ref<f64>
 ! CHECK: %{{.*}} = fir.call @_FortranAErfcScaled8(%[[a1]]) {{.*}}: (f64) -> f64
 end function erfc_scaled8
+
+
+! CHECK-LABEL: func @_QPderfc_scaled8(
+! CHECK-SAME: %[[x:[^:]+]]: !fir.ref<f64>{{.*}}) -> f64
+function derfc_scaled8(x)
+  real(kind=8) :: derfc_scaled8
+  real(kind=8) :: x
+  derfc_scaled8 = derfc_scaled(x);
+! CHECK: %[[a1:.*]] = fir.load %[[x]] : !fir.ref<f64>
+! CHECK: %{{.*}} = fir.call @_FortranAErfcScaled8(%[[a1]]) {{.*}}: (f64) -> f64
+end function derfc_scaled8
diff --git a/flang/test/Lower/Intrinsics/erfc_scaled_real16.f90 b/flang/test/Lower/Intrinsics/erfc_scaled_real16.f90
new file mode 100644
index 0000000..15c22e6
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/erfc_scaled_real16.f90
@@ -0,0 +1,9 @@
+! REQUIRES: flang-supports-f128-math
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: bbc --math-runtime=precise -emit-fir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
+
+! CHECK: fir.call @_FortranAErfcScaled16({{.*}}) {{.*}}: (f128) -> f128
+  real(16) :: a, b
+  b = qerfc_scaled(a)
+end
diff --git a/flang/test/Semantics/erf.f90 b/flang/test/Semantics/erf.f90
new file mode 100644
index 0000000..591b4c3
--- /dev/null
+++ b/flang/test/Semantics/erf.f90
@@ -0,0 +1,29 @@
+! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck --check-prefix=ERROR %s
+
+function derf8_error4(x)
+  real(kind=8) :: derf8_error4
+  real(kind=4) :: x
+  derf8_error4 = derf(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(4)'
+end function derf8_error4
+
+function derf8_error16(x)
+  real(kind=8) :: derf8_error16
+  real(kind=16) :: x
+  derf8_error16 = derf(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(16)'
+end function derf8_error16
+
+function qerf16_error4(x)
+  real(kind=16) :: qerf16_error4
+  real(kind=4) :: x
+  qerf16_error4 = qerf(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(4)'
+end function qerf16_error4
+
+function qerf16_error8(x)
+  real(kind=16) :: qerf16_error8
+  real(kind=8) :: x
+  qerf16_error8 = qerf(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(8)'
+end function qerf16_error8
diff --git a/flang/test/Semantics/erfc.f90 b/flang/test/Semantics/erfc.f90
new file mode 100644
index 0000000..ae3273b
--- /dev/null
+++ b/flang/test/Semantics/erfc.f90
@@ -0,0 +1,29 @@
+! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck --check-prefix=ERROR %s
+
+function derfc8_error4(x)
+  real(kind=8) :: derfc8_error4
+  real(kind=4) :: x
+  derfc8_error4 = derfc(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(4)'
+end function derfc8_error4
+
+function derfc8_error16(x)
+  real(kind=8) :: derfc8_error16
+  real(kind=16) :: x
+  derfc8_error16 = derfc(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(16)'
+end function derfc8_error16
+
+function qerfc16_error4(x)
+  real(kind=16) :: qerfc16_error4
+  real(kind=4) :: x
+  qerfc16_error4 = qerfc(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(4)'
+end function qerfc16_error4
+
+function qerfc16_error8(x)
+  real(kind=16) :: qerfc16_error8
+  real(kind=8) :: x
+  qerfc16_error8 = qerfc(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(8)'
+end function qerfc16_error8
diff --git a/flang/test/Semantics/erfc_scaled.f90 b/flang/test/Semantics/erfc_scaled.f90
new file mode 100644
index 0000000..5e6cd50
--- /dev/null
+++ b/flang/test/Semantics/erfc_scaled.f90
@@ -0,0 +1,29 @@
+! RUN: not %flang_fc1 -fsyntax-only %s 2>&1 | FileCheck --check-prefix=ERROR %s
+
+function derfc_scaled8_error4(x)
+  real(kind=8) :: derfc_scaled8_error4
+  real(kind=4) :: x
+  derfc_scaled8_error4 = derfc_scaled(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(4)'
+end function derfc_scaled8_error4
+
+function derfc_scaled8_error16(x)
+  real(kind=8) :: derfc_scaled8_error16
+  real(kind=16) :: x
+  derfc_scaled8_error16 = derfc_scaled(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(16)'
+end function derfc_scaled8_error16
+
+function qerfc_scaled16_error4(x)
+  real(kind=16) :: qerfc_scaled16_error4
+  real(kind=4) :: x
+  qerfc_scaled16_error4 = qerfc_scaled(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(4)'
+end function qerfc_scaled16_error4
+
+function qerfc_scaled16_error8(x)
+  real(kind=16) :: qerfc_scaled16_error8
+  real(kind=8) :: x
+  qerfc_scaled16_error8 = qerfc_scaled(x);
+! ERROR: Actual argument for 'x=' has bad type or kind 'REAL(8)'
+end function qerfc_scaled16_error8