[flang-commits] [flang] [flang] Implement C_F_STRPOINTER (Fortran 2023) (PR #176973)

[Andre Kuhlenschmidt via flang-commits]

================
@@ -3251,6 +3253,184 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
   }
 }
 
+// Subroutine C_F_STRPOINTER from intrinsic module ISO_C_BINDING (18.2.3.5)
+// C_F_STRPOINTER(CSTRARRAY, FSTRPTR [,NCHARS]) or
+// C_F_STRPOINTER(CSTRPTR, FSTRPTR, NCHARS)
+std::optional<SpecificCall>
+IntrinsicProcTable::Implementation::HandleC_F_Strpointer(
+    ActualArguments &arguments, FoldingContext &context) const {
+  characteristics::Procedure::Attrs attrs;
+  attrs.set(characteristics::Procedure::Attr::Subroutine);
+  // The first argument can be either CSTRARRAY or CSTRPTR - we use a generic
+  // keyword since they're mutually exclusive
+  static const char *const keywords[]{
+      "cstrarray", "fstrptr", "nchars", nullptr};
+  characteristics::DummyArguments dummies;
+  if (CheckAndRearrangeArguments(arguments, context.messages(), keywords, 2)) {
+    CHECK(arguments.size() == 3);
+    const bool hasNchars{arguments[2].has_value()};
+
+    // Check first argument (CSTRARRAY or CSTRPTR) and optional third argument
+    // (NCHARS)
+    if (const auto *expr{arguments[0].value().UnwrapExpr()}) {
+      // General semantic checks will catch an actual argument that's not
+      // scalar.
+      const auto at{arguments[0]->sourceLocation()};
+      if (const auto type{expr->GetType()}) {
+        if (type->category() == TypeCategory::Derived &&
+            !type->IsPolymorphic() &&
+            (type->GetDerivedTypeSpec().typeSymbol().name() ==
+                    "__builtin_c_ptr" ||
+                type->GetDerivedTypeSpec().typeSymbol().name() ==
+                    "__builtin_c_devptr")) {
+          // First argument is C_PTR (CSTRPTR form)
+          if (!hasNchars) {
+            context.messages().Say(at,
+                "NCHARS= argument is required when CSTRPTR= appears in C_F_STRPOINTER()"_err_en_US);
+          }
+          characteristics::DummyDataObject cstrptr{
+              characteristics::TypeAndShape{*type}};
+          cstrptr.intent = common::Intent::In;
+          dummies.emplace_back("cstrptr"s, std::move(cstrptr));
+        } else if (type->category() == TypeCategory::Character) {
+          // First argument should be CSTRARRAY - rank-1 character array
+          if (type->kind() != 1) {
+            context.messages().Say(at,
+                "CSTRARRAY= argument to C_F_STRPOINTER() must be of kind C_CHAR"_err_en_US);
+          }
+          if (expr->Rank() != 1) {
+            context.messages().Say(at,
+                "CSTRARRAY= argument to C_F_STRPOINTER() must be a rank-one array"_err_en_US);
+          }
+          if (const auto len{type->GetCharLength()}) {
+            if (const auto constLen{ToInt64(*len)}) {
+              if (*constLen != 1) {
+                context.messages().Say(at,
+                    "CSTRARRAY= argument to C_F_STRPOINTER() must have length type parameter equal to one"_err_en_US);
+              }
+            }
+          }
+          // Check if CSTRARRAY is assumed-size and NCHARS is absent
+          if (auto shape{GetShape(context, *expr)}) {
+            if (shape->size() == 1) {
+              const auto &extentExpr{(*shape)[0]};
+              const auto extentInt{ToInt64(extentExpr)};
+              if ((!extentInt || *extentInt < 0) && !hasNchars) {
+                context.messages().Say(at,
+                    "NCHARS= argument is required when CSTRARRAY= is assumed-size in C_F_STRPOINTER()"_err_en_US);
+              }
+            }
+          }
+          // Check if NCHARS > size(CSTRARRAY) at compile time
+          if (hasNchars && arguments[2]) {
----------------
akuhlens wrote:

Either `arguments[2]` is always true or the initialization of `hasNchars` is borked.

https://github.com/llvm/llvm-project/pull/176973