[flang] Support extension intrinsic function variations on ABS

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

Differential Revision: https://reviews.llvm.org/D117155

flang/docs/Extensions.md

@@ -199,6 +199,7 @@ end
 * 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
 

flang/lib/Evaluate/fold-integer.cpp

@@ -413,7 +413,7 @@ Expr<Type<TypeCategory::Integer, KIND>> FoldIntrinsicFunction(
   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()};

flang/lib/Evaluate/fold-real.cpp

@@ -64,7 +64,7 @@ Expr<Type<TypeCategory::Real, KIND>> FoldIntrinsicFunction(
             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>(

flang/lib/Evaluate/intrinsics-library.cpp

@@ -202,13 +202,12 @@ template <typename HostT, LibraryVersion> struct HostRuntimeLibrary {
 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"),

flang/lib/Evaluate/intrinsics.cpp

@@ -87,11 +87,13 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind,
     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;
 };
 
@@ -914,6 +916,9 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"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"},
@@ -988,9 +993,18 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"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}},
@@ -1036,6 +1050,9 @@ static const SpecificIntrinsicInterface specificIntrinsicFunction[]{
     {{"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[]{
@@ -1424,6 +1441,9 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
     case KindCode::nullPointerType:
       argOk = true;
       break;
+    case KindCode::exactKind:
+      argOk = type->kind() == d.typePattern.exactKindValue;
+      break;
     default:
       CRASH_NO_CASE;
     }
@@ -1694,6 +1714,9 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
       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:

flang/test/Evaluate/folding02.f90

@@ -261,4 +261,18 @@ module m
     (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