[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 (file)
--- 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 (file)
--- 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<SpecificCall> 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 (file)
--- a/flang/lib/evaluate/tools.h
+++ b/flang/lib/evaluate/tools.h
@@ -612,6 +612,9 @@ struct TypeKindVisitor {
 template<typename A> const semantics::Symbol *GetLastSymbol(const A &) {
   return nullptr;
 }
+template<typename... A> const semantics::Symbol *GetLastSymbol(const std::variant<A...> &);
+template<typename A> const semantics::Symbol *GetLastSymbol(const std::optional<A> &);
+template<typename A> 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<typename T> const semantics::Symbol *GetLastSymbol(const Expr<T> &x) {
-  return std::visit([](const auto &y) { return GetLastSymbol(y); }, x.u);
+  return GetLastSymbol(x.u);
+}
+template<typename... A> const semantics::Symbol *GetLastSymbol(const std::variant<A...> &u) {
+  return std::visit([](const auto &x) { return GetLastSymbol(x); }, u);
 }
 template<typename A>
 const semantics::Symbol *GetLastSymbol(const std::optional<A> &x) {
@@ -649,6 +655,13 @@ const semantics::Symbol *GetLastSymbol(const std::optional<A> &x) {
     return nullptr;
   }
 }
+template<typename A> 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 (file)
--- a/flang/lib/evaluate/variable.cc
+++ b/flang/lib/evaluate/variable.cc
@@ -319,6 +319,8 @@ template<typename T> Expr<SubscriptInteger> Designator<T>::LEN() const {
 }
 
 Expr<SubscriptInteger> 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<SubscriptInteger> ProcedureDesignator::LEN() const {
             return c.value().LEN();
           },
           [](const auto &) {
-            // TODO intrinsics?
+            // TODO: intrinsics
             CRASH_NO_CASE;
             return AsExpr(Constant<SubscriptInteger>{0});
           },

diff --git a/flang/lib/semantics/expression.cc b/flang/lib/semantics/expression.cc
index d729ba5..d394c1b 100644 (file)
--- 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;
 }