From: peter klausler Date: Mon, 1 Jul 2019 20:22:22 +0000 (-0700) Subject: [flang] Add LOC()/%LOC() intrinsics X-Git-Tag: llvmorg-12-init~9537^2~1015 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=8e93226e743fdde97e199e978059cfe52709a003;p=platform%2Fupstream%2Fllvm.git [flang] Add LOC()/%LOC() intrinsics Original-commit: flang-compiler/f18@3a6b90c9f5c1a21a40323e56e2c26f6161d2f79c Reviewed-on: https://github.com/flang-compiler/f18/pull/538 Tree-same-pre-rewrite: false --- diff --git a/flang/documentation/Extensions.md b/flang/documentation/Extensions.md index a3b694b..6fc76e3 100644 --- a/flang/documentation/Extensions.md +++ b/flang/documentation/Extensions.md @@ -33,7 +33,8 @@ Extensions, deletions, and legacy features supported by default * Leading comma allowed before I/O item list * Empty parentheses allowed in `PROGRAM P()` * Missing parentheses allowed in `FUNCTION F` -* Cray based `POINTER(p,x)` +* Cray based `POINTER(p,x)` and `LOC()` intrinsic (with `%LOC()` as + an alias) * Arithmetic `IF`. (Which branch should NaN take? Fall through?) * `ASSIGN` statement, assigned `GO TO`, and assigned format * `PAUSE` statement diff --git a/flang/lib/evaluate/intrinsics.cc b/flang/lib/evaluate/intrinsics.cc index 58e6fc7..64ec571 100644 --- a/flang/lib/evaluate/intrinsics.cc +++ b/flang/lib/evaluate/intrinsics.cc @@ -82,6 +82,7 @@ ENUM_CLASS(KindCode, none, defaultIntegerKind, effectiveKind, // for function results: same "kindArg", possibly defaulted dimArg, // this argument is DIM= likeMultiply, // for DOT_PRODUCT and MATMUL + subscript, // address-sized integer ) struct TypePattern { @@ -106,6 +107,7 @@ static constexpr TypePattern DoublePrecision{ RealType, KindCode::doublePrecision}; static constexpr TypePattern DoublePrecisionComplex{ ComplexType, KindCode::doublePrecision}; +static constexpr TypePattern SubscriptInt{IntType, KindCode::subscript}; // Match any kind of some intrinsic or derived types static constexpr TypePattern AnyInt{IntType, KindCode::any}; @@ -443,6 +445,8 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ {"lgt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, {"lle", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, {"llt", {{"string_a", SameChar}, {"string_b", SameChar}}, DefaultLogical}, + {"loc", {{"x", Anything, Rank::anyOrAssumedRank}}, SubscriptInt, + Rank::scalar}, {"log", {{"x", SameFloating}}, SameFloating}, {"log10", {{"x", SameReal}}, SameReal}, {"logical", {{"l", AnyLogical}, DefaultingKIND}, KINDLogical}, @@ -650,13 +654,15 @@ static const IntrinsicInterface genericIntrinsicFunction[]{ // TODO: Non-standard intrinsic functions // AND, OR, XOR, LSHIFT, RSHIFT, SHIFT, ZEXT, IZEXT, // COSD, SIND, TAND, ACOSD, ASIND, ATAND, ATAN2D, COMPL, -// DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, LOC, +// DCMPLX, EQV, NEQV, INT8, JINT, JNINT, KNINT, // QCMPLX, DREAL, DFLOAT, QEXT, QFLOAT, QREAL, DNUM, // INUM, JNUM, KNUM, QNUM, RNUM, RAN, RANF, ILEN, SIZEOF, // MCLOCK, SECNDS, COTAN, IBCHNG, ISHA, ISHC, ISHL, IXOR // IARG, IARGC, NARGS, NUMARG, BADDRESS, IADDR, CACHESIZE, // EOF, FP_CLASS, INT_PTR_KIND, ISNAN, MALLOC // probably more (these are PGI + Intel, possibly incomplete) +// TODO: Optionally warn on use of non-standard intrinsics: +// LOC, probably others // The following table contains the intrinsic functions listed in // Tables 16.2 and 16.3 in Fortran 2018. The "unrestricted" functions @@ -1193,6 +1199,12 @@ std::optional IntrinsicInterface::Match( resultType = actualForDummy[0]->GetType()->ResultTypeForMultiply( *actualForDummy[1]->GetType()); break; + case KindCode::subscript: + CHECK(result.categorySet == IntType); + CHECK(*category == TypeCategory::Integer); + resultType = + DynamicType{TypeCategory::Integer, defaults.subscriptIntegerKind()}; + break; case KindCode::typeless: case KindCode::teamType: case KindCode::any: @@ -1451,6 +1463,14 @@ static bool ApplySpecificChecks( messages.Say( "Arguments of ASSOCIATED() must be a POINTER and an optional valid target"_err_en_US); } + } else if (name == "loc") { + if (const auto &arg{call.arguments[0]}) { + ok = GetLastSymbol(arg->UnwrapExpr()) != nullptr; + } + if (!ok) { + messages.Say( + "Argument of LOC() must be an object or procedure"_err_en_US); + } } else if (name == "present") { if (const auto &arg{call.arguments[0]}) { if (const auto *expr{arg->UnwrapExpr()}) { diff --git a/flang/lib/evaluate/tools.h b/flang/lib/evaluate/tools.h index 224c538..44640c6 100644 --- a/flang/lib/evaluate/tools.h +++ b/flang/lib/evaluate/tools.h @@ -612,6 +612,9 @@ struct TypeKindVisitor { template const semantics::Symbol *GetLastSymbol(const A &) { return nullptr; } +template const semantics::Symbol *GetLastSymbol(const std::variant &); +template const semantics::Symbol *GetLastSymbol(const std::optional &); +template const semantics::Symbol *GetLastSymbol(const A *); inline const semantics::Symbol *GetLastSymbol(const Symbol &x) { return &x; } inline const semantics::Symbol *GetLastSymbol(const Component &x) { return &x.GetLastSymbol(); @@ -639,7 +642,10 @@ inline const semantics::Symbol *GetLastSymbol(const ProcedureRef &x) { return GetLastSymbol(x.proc()); } template const semantics::Symbol *GetLastSymbol(const Expr &x) { - return std::visit([](const auto &y) { return GetLastSymbol(y); }, x.u); + return GetLastSymbol(x.u); +} +template const semantics::Symbol *GetLastSymbol(const std::variant &u) { + return std::visit([](const auto &x) { return GetLastSymbol(x); }, u); } template const semantics::Symbol *GetLastSymbol(const std::optional &x) { @@ -649,6 +655,13 @@ const semantics::Symbol *GetLastSymbol(const std::optional &x) { return nullptr; } } +template const semantics::Symbol *GetLastSymbol(const A *p) { + if (p != nullptr) { + return GetLastSymbol(*p); + } else { + return nullptr; + } +} // Convenience: If GetLastSymbol() succeeds on the argument, return its // set of attributes, otherwise the empty set. diff --git a/flang/lib/evaluate/variable.cc b/flang/lib/evaluate/variable.cc index 714057b..825441d 100644 --- a/flang/lib/evaluate/variable.cc +++ b/flang/lib/evaluate/variable.cc @@ -319,6 +319,8 @@ template Expr Designator::LEN() const { } Expr ProcedureDesignator::LEN() const { + // TODO pmk: this needs more thought for assumed-length + // character functions, &c. return std::visit( common::visitors{ [](const Symbol *s) { return SymbolLEN(*s); }, @@ -326,7 +328,7 @@ Expr ProcedureDesignator::LEN() const { return c.value().LEN(); }, [](const auto &) { - // TODO intrinsics? + // TODO: intrinsics CRASH_NO_CASE; return AsExpr(Constant{0}); }, diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc index d729ba5..d394c1b 100644 --- a/flang/lib/semantics/expression.cc +++ b/flang/lib/semantics/expression.cc @@ -1646,8 +1646,17 @@ MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::NOT &x) { return std::nullopt; } -MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &) { - Say("TODO: %LOC unimplemented"_err_en_US); +MaybeExpr ExpressionAnalyzer::Analyze(const parser::Expr::PercentLoc &x) { + // Represent %LOC() exactly as if it had been a call to the LOC() extension + // intrinsic function. + // Use the actual source for the name of the call for error reporting. + if (MaybeExpr arg{Analyze(x.v.value())}) { + parser::CharBlock at{GetContextualMessages().at()}; + CHECK(at[0] == '%'); + parser::CharBlock loc{at.begin() + 1, at.end()}; + return MakeFunctionRef( + loc, ActualArguments{ActualArgument{std::move(*arg)}}); + } return std::nullopt; }