[flang] Support extension intrinsic function variations on ABS

[klausler]

Summary

Accept the legacy specific intrinsic names BABS, IIABS, JIABS,
KIABS, and ZABS as well.

[jeanPerier]

LGTM

flang/docs/Extensions.md

* We support some combinations of specific procedures in generic
   if an actual argument acceptable to one could not be passed to
   the other & vice versa because exactly one is polymorphic or
   exactly one is unlimited polymorphic).
 * External unit 0 is predefined and connected to the standard error output,
   and defined as `ERROR_UNIT` in the intrinsic `ISO_FORTRAN_ENV` module.
 * Objects in blank COMMON may be initialized.
 * Multiple specifications of the SAVE attribute on the same object
   are allowed, with a warning.
+* Specific intrinsic functions BABS, IIABS, JIABS, KIABS, ZABS, and CDABS.
 
 ### Extensions supported when enabled by options
 
 * C-style backslash escape sequences in quoted CHARACTER literals
   (but not Hollerith) [-fbackslash]
 * Logical abbreviations `.T.`, `.F.`, `.N.`, `.A.`, `.O.`, and `.X.`
   [-flogical-abbreviations]
 * `.XOR.` as a synonym for `.NEQV.` [-fxor-operator]

flang/lib/Evaluate/fold-integer.cpp

Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
     FoldingContext &context,
     FunctionRef<Type<TypeCategory::Integer, KIND>> &&funcRef) {
   using T = Type<TypeCategory::Integer, KIND>;
   using Int4 = Type<TypeCategory::Integer, 4>;
   ActualArguments &args{funcRef.arguments()};
   auto *intrinsic{std::get_if<SpecificIntrinsic>(&funcRef.proc().u)};
   CHECK(intrinsic);
   std::string name{intrinsic->name};
-  if (name == "abs") {
+  if (name == "abs") { // incl. babs, iiabs, jiaabs, & kiabs
     return FoldElementalIntrinsic<T, T>(context, std::move(funcRef),
         ScalarFunc<T, T>([&context](const Scalar<T> &i) -> Scalar<T> {
           typename Scalar<T>::ValueWithOverflow j{i.ABS()};
           if (j.overflow) {
             context.messages().Say(
                 "abs(integer(kind=%d)) folding overflowed"_en_US, KIND);
           }
           return j.value;

flang/lib/Evaluate/fold-real.cpp

if (args.size() == 2) { // elemental
         return FoldElementalIntrinsic<T, Int4, T>(
             context, std::move(funcRef), *callable);
       } else {
         context.messages().Say(
             "%s(integer(kind=4), real(kind=%d)) cannot be folded on host"_en_US,
             name, KIND);
       }
     }
-  } else if (name == "abs") {
+  } else if (name == "abs") { // incl. zabs & cdabs
     // Argument can be complex or real
     if (auto *x{UnwrapExpr<Expr<SomeReal>>(args[0])}) {
       return FoldElementalIntrinsic<T, T>(
           context, std::move(funcRef), &Scalar<T>::ABS);
     } else if (auto *z{UnwrapExpr<Expr<SomeComplex>>(args[0])}) {
       return FoldElementalIntrinsic<T, ComplexT>(context, std::move(funcRef),
           ScalarFunc<T, ComplexT>([](const Scalar<ComplexT> &z) -> Scalar<T> {
             return z.ABS().value;

flang/lib/Evaluate/intrinsics-library.cpp

template <typename HostT, LibraryVersion> struct HostRuntimeLibrary {
   // When specialized, this class holds a static constexpr table containing
   // all the HostRuntimeLibrary for functions of library LibraryVersion
   // that returns a value of type HostT.
 };
 
 using HostRuntimeMap = common::StaticMultimapView<HostRuntimeFunction>;
 
 // Map numerical intrinsic to  <cmath>/<complex> functions
+// (Note: ABS() is folded in fold-real.cpp.)
 template <typename HostT>
 struct HostRuntimeLibrary<HostT, LibraryVersion::Libm> {
   using F = FuncPointer<HostT, HostT>;
   using F2 = FuncPointer<HostT, HostT, HostT>;
-  using ComplexToRealF = FuncPointer<HostT, const std::complex<HostT> &>;
   static constexpr HostRuntimeFunction table[]{
-      FolderFactory<ComplexToRealF, ComplexToRealF{std::abs}>::Create("abs"),
       FolderFactory<F, F{std::acos}>::Create("acos"),
       FolderFactory<F, F{std::acosh}>::Create("acosh"),
       FolderFactory<F, F{std::asin}>::Create("asin"),
       FolderFactory<F, F{std::asinh}>::Create("asinh"),
       FolderFactory<F, F{std::atan}>::Create("atan"),
       FolderFactory<F2, F2{std::atan2}>::Create("atan2"),
       FolderFactory<F, F{std::atanh}>::Create("atanh"),
       FolderFactory<F, F{std::cos}>::Create("cos"),

flang/lib/Evaluate/intrinsics.cpp

ENUM_CLASS(KindCode, none, defaultIntegerKind,
     kindArg, // this argument is KIND=
     effectiveKind, // for function results: "kindArg" value, possibly defaulted
     dimArg, // this argument is DIM=
     likeMultiply, // for DOT_PRODUCT and MATMUL
     subscript, // address-sized integer
     size, // default KIND= for SIZE(), UBOUND, &c.
     addressable, // for PRESENT(), &c.; anything (incl. procedure) but BOZ
     nullPointerType, // for ASSOCIATED(NULL())
+    exactKind, // a single explicit exactKindValue
 )
 
 struct TypePattern {
   CategorySet categorySet;
   KindCode kindCode{KindCode::none};
+  int exactKindValue{0}; // for KindCode::exactBind
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 };
 
 // Abbreviations for argument and result patterns in the intrinsic prototypes:
 
 // Match specific kinds of intrinsic types
 static constexpr TypePattern DefaultInt{IntType, KindCode::defaultIntegerKind};
 static constexpr TypePattern DefaultReal{RealType, KindCode::defaultRealKind};
static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
              {"a3", DefaultReal, Rank::elemental, Optionality::repeats}},
          DefaultReal},
         "min", true, true},
     {{"amod", {{"a", DefaultReal}, {"p", DefaultReal}}, DefaultReal}, "mod"},
     {{"anint", {{"a", DefaultReal}}, DefaultReal}},
     {{"asin", {{"x", DefaultReal}}, DefaultReal}},
     {{"atan", {{"x", DefaultReal}}, DefaultReal}},
     {{"atan2", {{"y", DefaultReal}, {"x", DefaultReal}}, DefaultReal}},
+    {{"babs", {{"a", TypePattern{IntType, KindCode::exactKind, 1}}},
+         TypePattern{IntType, KindCode::exactKind, 1}},
+        "abs"},
     {{"cabs", {{"a", DefaultComplex}}, DefaultReal}, "abs"},
     {{"ccos", {{"a", DefaultComplex}}, DefaultComplex}, "cos"},
     {{"cdabs", {{"a", DoublePrecisionComplex}}, DoublePrecision}, "abs"},
     {{"cdcos", {{"a", DoublePrecisionComplex}}, DoublePrecisionComplex}, "cos"},
     {{"cdexp", {{"a", DoublePrecisionComplex}}, DoublePrecisionComplex}, "exp"},
     {{"cdlog", {{"a", DoublePrecisionComplex}}, DoublePrecisionComplex}, "log"},
     {{"cdsin", {{"a", DoublePrecisionComplex}}, DoublePrecisionComplex}, "sin"},
     {{"cdsqrt", {{"a", DoublePrecisionComplex}}, DoublePrecisionComplex},
static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"dtanh", {{"x", DoublePrecision}}, DoublePrecision}, "tanh"},
     {{"exp", {{"x", DefaultReal}}, DefaultReal}},
     {{"float", {{"i", AnyInt}}, DefaultReal}, "real", true},
     {{"iabs", {{"a", DefaultInt}}, DefaultInt}, "abs"},
     {{"idim", {{"x", DefaultInt}, {"y", DefaultInt}}, DefaultInt}, "dim"},
     {{"idint", {{"a", AnyReal}}, DefaultInt}, "int", true},
     {{"idnint", {{"a", DoublePrecision}}, DefaultInt}, "nint"},
     {{"ifix", {{"a", AnyReal}}, DefaultInt}, "int", true},
+    {{"iiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 2}}},
+         TypePattern{IntType, KindCode::exactKind, 2}},
+        "abs"},
     {{"index", {{"string", DefaultChar}, {"substring", DefaultChar}},
         DefaultInt}},
     {{"isign", {{"a", DefaultInt}, {"b", DefaultInt}}, DefaultInt}, "sign"},
+    {{"jiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 4}}},
+         TypePattern{IntType, KindCode::exactKind, 4}},
+        "abs"},
+    {{"kiabs", {{"a", TypePattern{IntType, KindCode::exactKind, 8}}},
+         TypePattern{IntType, KindCode::exactKind, 8}},
+        "abs"},
     {{"len", {{"string", DefaultChar, Rank::anyOrAssumedRank}}, DefaultInt,
         Rank::scalar}},
     {{"lge", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
          DefaultLogical},
         "lge", true},
     {{"lgt", {{"string_a", DefaultChar}, {"string_b", DefaultChar}},
          DefaultLogical},
         "lgt", true},
static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"nint", {{"a", DefaultReal}}, DefaultInt}},
     {{"sign", {{"a", DefaultReal}, {"b", DefaultReal}}, DefaultReal}},
     {{"sin", {{"x", DefaultReal}}, DefaultReal}},
     {{"sinh", {{"x", DefaultReal}}, DefaultReal}},
     {{"sngl", {{"a", AnyReal}}, DefaultReal}, "real", true},
     {{"sqrt", {{"x", DefaultReal}}, DefaultReal}},
     {{"tan", {{"x", DefaultReal}}, DefaultReal}},
     {{"tanh", {{"x", DefaultReal}}, DefaultReal}},
+    {{"zabs", {{"a", TypePattern{ComplexType, KindCode::exactKind, 8}}},
+         TypePattern{RealType, KindCode::exactKind, 8}},
+        "abs"},
 };
 
 static const IntrinsicInterface intrinsicSubroutine[]{
     {"abort", {}, {}, Rank::elemental, IntrinsicClass::impureSubroutine},
     {"cpu_time",
         {{"time", AnyReal, Rank::scalar, Optionality::required,
             common::Intent::Out}},
         {}, Rank::elemental, IntrinsicClass::impureSubroutine},
case KindCode::effectiveKind:
       common::die("INTERNAL: KindCode::effectiveKind appears on argument '%s' "
                   "for intrinsic '%s'",
           d.keyword, name);
       break;
     case KindCode::addressable:
     case KindCode::nullPointerType:
       argOk = true;
       break;
+    case KindCode::exactKind:
+      argOk = type->kind() == d.typePattern.exactKindValue;
+      break;
     default:
       CRASH_NO_CASE;
     }
     if (!argOk) {
       messages.Say(
           "Actual argument for '%s=' has bad type or kind '%s'"_err_en_US,
           d.keyword, type->AsFortran());
       return std::nullopt;
case KindCode::size:
           DynamicType{TypeCategory::Integer, defaults.sizeIntegerKind()};
       break;
     case KindCode::teamType:
       CHECK(result.categorySet == DerivedType);
       CHECK(*category == TypeCategory::Derived);
       resultType = DynamicType{
           GetBuiltinDerivedType(builtinsScope, "__builtin_team_type")};
       break;
+    case KindCode::exactKind:
+      resultType = DynamicType{*category, result.exactKindValue};
+      break;
     case KindCode::defaultCharKind:
     case KindCode::typeless:
     case KindCode::any:
     case KindCode::kindArg:
     case KindCode::dimArg:
       common::die(
           "INTERNAL: bad KindCode appears on intrinsic '%s' result", name);
       break;

flang/test/Evaluate/folding02.f90

! Test exponentiation by real or complex folding (it is using host runtime)
   TEST_R8(pow, (0.5_8**3.14_8), &
     1.1343989441464509548840311481399112381041049957275390625e-1_8)
   TEST_C4(pow, ((0.5_4, 0.6_4)**(0.74_4, -1.1_4)), &
     (1.32234990596771240234375_4,1.73712027072906494140625_4))
   TEST_C8(pow, ((0.5_8, 0.6_8)**(0.74_8, -1.1_8)), &
     (1.3223499632715445262221010125358588993549346923828125_8, &
      1.7371201007364975854585509296157397329807281494140625_8))
 
+! Extension specific intrinsic variants of ABS
+  logical, parameter, test_babs1 = kind(babs(-1_1)) == 1
+  logical, parameter, test_babs2 = babs(-1_1) == 1_1
+  logical, parameter, test_iiabs1 = kind(iiabs(-1_2)) == 2
+  logical, parameter, test_iiabs2 = iiabs(-1_2) == 1_2
+  logical, parameter, test_jiabs1 = kind(jiabs(-1_4)) == 4
+  logical, parameter, test_jiabs2 = jiabs(-1_4) == 1_4
+  logical, parameter, test_kiabs1 = kind(kiabs(-1_8)) == 8
+  logical, parameter, test_kiabs2 = kiabs(-1_8) == 1_8
+  logical, parameter, test_zabs1 = kind(zabs((3._8,4._8))) == 8
+  logical, parameter, test_zabs2 = zabs((3._8,4._8)) == 5_8
+  logical, parameter, test_cdabs1 = kind(cdabs((3._8,4._8))) == kind(1.d0)
+  logical, parameter, test_cdabs2 = cdabs((3._8,4._8)) == real(5, kind(1.d0))
+
 end