| //===-- runtime/findloc.cpp -----------------------------------------------===// |
| // |
| // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. |
| // See https://llvm.org/LICENSE.txt for license information. |
| // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception |
| // |
| //===----------------------------------------------------------------------===// |
| |
| // Implements FINDLOC for all required operand types and shapes and result |
| // integer kinds. |
| |
| #include "reduction-templates.h" |
| #include "flang/Common/long-double.h" |
| #include "flang/Runtime/character.h" |
| #include "flang/Runtime/reduction.h" |
| #include <cinttypes> |
| #include <complex> |
| |
| namespace Fortran::runtime { |
| |
| template <TypeCategory CAT1, int KIND1, TypeCategory CAT2, int KIND2> |
| struct Equality { |
| using Type1 = CppTypeFor<CAT1, KIND1>; |
| using Type2 = CppTypeFor<CAT2, KIND2>; |
| bool operator()(const Descriptor &array, const SubscriptValue at[], |
| const Descriptor &target) const { |
| return *array.Element<Type1>(at) == *target.OffsetElement<Type2>(); |
| } |
| }; |
| |
| template <int KIND1, int KIND2> |
| struct Equality<TypeCategory::Complex, KIND1, TypeCategory::Complex, KIND2> { |
| using Type1 = CppTypeFor<TypeCategory::Complex, KIND1>; |
| using Type2 = CppTypeFor<TypeCategory::Complex, KIND2>; |
| bool operator()(const Descriptor &array, const SubscriptValue at[], |
| const Descriptor &target) const { |
| const Type1 &xz{*array.Element<Type1>(at)}; |
| const Type2 &tz{*target.OffsetElement<Type2>()}; |
| return xz.real() == tz.real() && xz.imag() == tz.imag(); |
| } |
| }; |
| |
| template <int KIND1, TypeCategory CAT2, int KIND2> |
| struct Equality<TypeCategory::Complex, KIND1, CAT2, KIND2> { |
| using Type1 = CppTypeFor<TypeCategory::Complex, KIND1>; |
| using Type2 = CppTypeFor<CAT2, KIND2>; |
| bool operator()(const Descriptor &array, const SubscriptValue at[], |
| const Descriptor &target) const { |
| const Type1 &z{*array.Element<Type1>(at)}; |
| return z.imag() == 0 && z.real() == *target.OffsetElement<Type2>(); |
| } |
| }; |
| |
| template <TypeCategory CAT1, int KIND1, int KIND2> |
| struct Equality<CAT1, KIND1, TypeCategory::Complex, KIND2> { |
| using Type1 = CppTypeFor<CAT1, KIND1>; |
| using Type2 = CppTypeFor<TypeCategory::Complex, KIND2>; |
| bool operator()(const Descriptor &array, const SubscriptValue at[], |
| const Descriptor &target) const { |
| const Type2 &z{*target.OffsetElement<Type2>()}; |
| return *array.Element<Type1>(at) == z.real() && z.imag() == 0; |
| } |
| }; |
| |
| template <int KIND> struct CharacterEquality { |
| using Type = CppTypeFor<TypeCategory::Character, KIND>; |
| bool operator()(const Descriptor &array, const SubscriptValue at[], |
| const Descriptor &target) const { |
| return CharacterScalarCompare<Type>(array.Element<Type>(at), |
| target.OffsetElement<Type>(), |
| array.ElementBytes() / static_cast<unsigned>(KIND), |
| target.ElementBytes() / static_cast<unsigned>(KIND)) == 0; |
| } |
| }; |
| |
| struct LogicalEquivalence { |
| bool operator()(const Descriptor &array, const SubscriptValue at[], |
| const Descriptor &target) const { |
| return IsLogicalElementTrue(array, at) == |
| IsLogicalElementTrue(target, at /*ignored*/); |
| } |
| }; |
| |
| template <typename EQUALITY> class LocationAccumulator { |
| public: |
| LocationAccumulator( |
| const Descriptor &array, const Descriptor &target, bool back) |
| : array_{array}, target_{target}, back_{back} { |
| Reinitialize(); |
| } |
| void Reinitialize() { |
| // per standard: result indices are all zero if no data |
| for (int j{0}; j < rank_; ++j) { |
| location_[j] = 0; |
| } |
| } |
| template <typename A> void GetResult(A *p, int zeroBasedDim = -1) { |
| if (zeroBasedDim >= 0) { |
| *p = location_[zeroBasedDim] - |
| array_.GetDimension(zeroBasedDim).LowerBound() + 1; |
| } else { |
| for (int j{0}; j < rank_; ++j) { |
| p[j] = location_[j] - array_.GetDimension(j).LowerBound() + 1; |
| } |
| } |
| } |
| template <typename IGNORED> bool AccumulateAt(const SubscriptValue at[]) { |
| if (equality_(array_, at, target_)) { |
| for (int j{0}; j < rank_; ++j) { |
| location_[j] = at[j]; |
| } |
| return back_; |
| } else { |
| return true; |
| } |
| } |
| |
| private: |
| const Descriptor &array_; |
| const Descriptor &target_; |
| const bool back_{false}; |
| const int rank_{array_.rank()}; |
| SubscriptValue location_[maxRank]; |
| const EQUALITY equality_{}; |
| }; |
| |
| template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT> |
| struct TotalNumericFindlocHelper { |
| template <int TARGET_KIND> struct Functor { |
| void operator()(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, int dim, const Descriptor *mask, |
| bool back, Terminator &terminator) const { |
| using Eq = Equality<XCAT, XKIND, TARGET_CAT, TARGET_KIND>; |
| using Accumulator = LocationAccumulator<Eq>; |
| Accumulator accumulator{x, target, back}; |
| DoTotalReduction<void>(x, dim, mask, accumulator, "FINDLOC", terminator); |
| ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, |
| void>(kind, terminator, accumulator, result); |
| } |
| }; |
| }; |
| |
| template <TypeCategory CAT, |
| template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT> |
| class HELPER> |
| struct NumericFindlocHelper { |
| template <int KIND> struct Functor { |
| void operator()(TypeCategory targetCat, int targetKind, Descriptor &result, |
| const Descriptor &x, const Descriptor &target, int kind, int dim, |
| const Descriptor *mask, bool back, Terminator &terminator) const { |
| switch (targetCat) { |
| case TypeCategory::Integer: |
| ApplyIntegerKind< |
| HELPER<CAT, KIND, TypeCategory::Integer>::template Functor, void>( |
| targetKind, terminator, result, x, target, kind, dim, mask, back, |
| terminator); |
| break; |
| case TypeCategory::Real: |
| ApplyFloatingPointKind< |
| HELPER<CAT, KIND, TypeCategory::Real>::template Functor, void>( |
| targetKind, terminator, result, x, target, kind, dim, mask, back, |
| terminator); |
| break; |
| case TypeCategory::Complex: |
| ApplyFloatingPointKind< |
| HELPER<CAT, KIND, TypeCategory::Complex>::template Functor, void>( |
| targetKind, terminator, result, x, target, kind, dim, mask, back, |
| terminator); |
| break; |
| default: |
| terminator.Crash( |
| "FINDLOC: bad target category %d for array category %d", |
| static_cast<int>(targetCat), static_cast<int>(CAT)); |
| } |
| } |
| }; |
| }; |
| |
| template <int KIND> struct CharacterFindlocHelper { |
| void operator()(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, const Descriptor *mask, bool back, |
| Terminator &terminator) { |
| using Accumulator = LocationAccumulator<CharacterEquality<KIND>>; |
| Accumulator accumulator{x, target, back}; |
| DoTotalReduction<void>(x, 0, mask, accumulator, "FINDLOC", terminator); |
| ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, void>( |
| kind, terminator, accumulator, result); |
| } |
| }; |
| |
| static void LogicalFindlocHelper(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, const Descriptor *mask, bool back, |
| Terminator &terminator) { |
| using Accumulator = LocationAccumulator<LogicalEquivalence>; |
| Accumulator accumulator{x, target, back}; |
| DoTotalReduction<void>(x, 0, mask, accumulator, "FINDLOC", terminator); |
| ApplyIntegerKind<LocationResultHelper<Accumulator>::template Functor, void>( |
| kind, terminator, accumulator, result); |
| } |
| |
| extern "C" { |
| void RTNAME(Findloc)(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, const char *source, int line, |
| const Descriptor *mask, bool back) { |
| int rank{x.rank()}; |
| SubscriptValue extent[1]{rank}; |
| result.Establish(TypeCategory::Integer, kind, nullptr, 1, extent, |
| CFI_attribute_allocatable); |
| result.GetDimension(0).SetBounds(1, extent[0]); |
| Terminator terminator{source, line}; |
| if (int stat{result.Allocate()}) { |
| terminator.Crash( |
| "FINDLOC: could not allocate memory for result; STAT=%d", stat); |
| } |
| CheckIntegerKind(terminator, kind, "FINDLOC"); |
| auto xType{x.type().GetCategoryAndKind()}; |
| auto targetType{target.type().GetCategoryAndKind()}; |
| RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value()); |
| switch (xType->first) { |
| case TypeCategory::Integer: |
| ApplyIntegerKind<NumericFindlocHelper<TypeCategory::Integer, |
| TotalNumericFindlocHelper>::template Functor, |
| void>(xType->second, terminator, targetType->first, targetType->second, |
| result, x, target, kind, 0, mask, back, terminator); |
| break; |
| case TypeCategory::Real: |
| ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Real, |
| TotalNumericFindlocHelper>::template Functor, |
| void>(xType->second, terminator, targetType->first, targetType->second, |
| result, x, target, kind, 0, mask, back, terminator); |
| break; |
| case TypeCategory::Complex: |
| ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Complex, |
| TotalNumericFindlocHelper>::template Functor, |
| void>(xType->second, terminator, targetType->first, targetType->second, |
| result, x, target, kind, 0, mask, back, terminator); |
| break; |
| case TypeCategory::Character: |
| RUNTIME_CHECK(terminator, |
| targetType->first == TypeCategory::Character && |
| targetType->second == xType->second); |
| ApplyCharacterKind<CharacterFindlocHelper, void>(xType->second, terminator, |
| result, x, target, kind, mask, back, terminator); |
| break; |
| case TypeCategory::Logical: |
| RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical); |
| LogicalFindlocHelper(result, x, target, kind, mask, back, terminator); |
| break; |
| default: |
| terminator.Crash( |
| "FINDLOC: Bad data type code (%d) for array", x.type().raw()); |
| } |
| } |
| } // extern "C" |
| |
| // FINDLOC with DIM= |
| |
| template <TypeCategory XCAT, int XKIND, TypeCategory TARGET_CAT> |
| struct PartialNumericFindlocHelper { |
| template <int TARGET_KIND> struct Functor { |
| void operator()(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, int dim, const Descriptor *mask, |
| bool back, Terminator &terminator) const { |
| using Eq = Equality<XCAT, XKIND, TARGET_CAT, TARGET_KIND>; |
| using Accumulator = LocationAccumulator<Eq>; |
| Accumulator accumulator{x, target, back}; |
| ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, |
| void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC", |
| accumulator); |
| } |
| }; |
| }; |
| |
| template <int KIND> struct PartialCharacterFindlocHelper { |
| void operator()(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, int dim, const Descriptor *mask, |
| bool back, Terminator &terminator) { |
| using Accumulator = LocationAccumulator<CharacterEquality<KIND>>; |
| Accumulator accumulator{x, target, back}; |
| ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, |
| void>(kind, terminator, result, x, dim, mask, terminator, "FINDLOC", |
| accumulator); |
| } |
| }; |
| |
| static void PartialLogicalFindlocHelper(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, int dim, const Descriptor *mask, |
| bool back, Terminator &terminator) { |
| using Accumulator = LocationAccumulator<LogicalEquivalence>; |
| Accumulator accumulator{x, target, back}; |
| ApplyIntegerKind<PartialLocationHelper<Accumulator>::template Functor, void>( |
| kind, terminator, result, x, dim, mask, terminator, "FINDLOC", |
| accumulator); |
| } |
| |
| extern "C" { |
| void RTNAME(FindlocDim)(Descriptor &result, const Descriptor &x, |
| const Descriptor &target, int kind, int dim, const char *source, int line, |
| const Descriptor *mask, bool back) { |
| Terminator terminator{source, line}; |
| CheckIntegerKind(terminator, kind, "FINDLOC"); |
| auto xType{x.type().GetCategoryAndKind()}; |
| auto targetType{target.type().GetCategoryAndKind()}; |
| RUNTIME_CHECK(terminator, xType.has_value() && targetType.has_value()); |
| switch (xType->first) { |
| case TypeCategory::Integer: |
| ApplyIntegerKind<NumericFindlocHelper<TypeCategory::Integer, |
| PartialNumericFindlocHelper>::template Functor, |
| void>(xType->second, terminator, targetType->first, targetType->second, |
| result, x, target, kind, dim, mask, back, terminator); |
| break; |
| case TypeCategory::Real: |
| ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Real, |
| PartialNumericFindlocHelper>::template Functor, |
| void>(xType->second, terminator, targetType->first, targetType->second, |
| result, x, target, kind, dim, mask, back, terminator); |
| break; |
| case TypeCategory::Complex: |
| ApplyFloatingPointKind<NumericFindlocHelper<TypeCategory::Complex, |
| PartialNumericFindlocHelper>::template Functor, |
| void>(xType->second, terminator, targetType->first, targetType->second, |
| result, x, target, kind, dim, mask, back, terminator); |
| break; |
| case TypeCategory::Character: |
| RUNTIME_CHECK(terminator, |
| targetType->first == TypeCategory::Character && |
| targetType->second == xType->second); |
| ApplyCharacterKind<PartialCharacterFindlocHelper, void>(xType->second, |
| terminator, result, x, target, kind, dim, mask, back, terminator); |
| break; |
| case TypeCategory::Logical: |
| RUNTIME_CHECK(terminator, targetType->first == TypeCategory::Logical); |
| PartialLogicalFindlocHelper( |
| result, x, target, kind, dim, mask, back, terminator); |
| break; |
| default: |
| terminator.Crash( |
| "FINDLOC: Bad data type code (%d) for array", x.type().raw()); |
| } |
| } |
| } // extern "C" |
| } // namespace Fortran::runtime |