diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md --- a/flang/docs/Extensions.md +++ b/flang/docs/Extensions.md @@ -199,6 +199,7 @@ * 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 diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp --- a/flang/lib/Evaluate/fold-integer.cpp +++ b/flang/lib/Evaluate/fold-integer.cpp @@ -413,7 +413,7 @@ auto *intrinsic{std::get_if(&funcRef.proc().u)}; CHECK(intrinsic); std::string name{intrinsic->name}; - if (name == "abs") { + if (name == "abs") { // incl. babs, iiabs, jiaabs, & kiabs return FoldElementalIntrinsic(context, std::move(funcRef), ScalarFunc([&context](const Scalar &i) -> Scalar { typename Scalar::ValueWithOverflow j{i.ABS()}; diff --git a/flang/lib/Evaluate/fold-real.cpp b/flang/lib/Evaluate/fold-real.cpp --- a/flang/lib/Evaluate/fold-real.cpp +++ b/flang/lib/Evaluate/fold-real.cpp @@ -64,7 +64,7 @@ name, KIND); } } - } else if (name == "abs") { + } else if (name == "abs") { // incl. zabs & cdabs // Argument can be complex or real if (auto *x{UnwrapExpr>(args[0])}) { return FoldElementalIntrinsic( diff --git a/flang/lib/Evaluate/intrinsics-library.cpp b/flang/lib/Evaluate/intrinsics-library.cpp --- a/flang/lib/Evaluate/intrinsics-library.cpp +++ b/flang/lib/Evaluate/intrinsics-library.cpp @@ -202,13 +202,12 @@ using HostRuntimeMap = common::StaticMultimapView; // Map numerical intrinsic to / functions +// (Note: ABS() is folded in fold-real.cpp.) template struct HostRuntimeLibrary { using F = FuncPointer; using F2 = FuncPointer; - using ComplexToRealF = FuncPointer &>; static constexpr HostRuntimeFunction table[]{ - FolderFactory::Create("abs"), FolderFactory::Create("acos"), FolderFactory::Create("acosh"), FolderFactory::Create("asin"), diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -87,11 +87,13 @@ 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 @@ {{"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 @@ {{"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 @@ {{"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 @@ case KindCode::nullPointerType: argOk = true; break; + case KindCode::exactKind: + argOk = type->kind() == d.typePattern.exactKindValue; + break; default: CRASH_NO_CASE; } @@ -1694,6 +1714,9 @@ 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: diff --git a/flang/test/Evaluate/folding02.f90 b/flang/test/Evaluate/folding02.f90 --- a/flang/test/Evaluate/folding02.f90 +++ b/flang/test/Evaluate/folding02.f90 @@ -261,4 +261,18 @@ (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