[flang] Semantics for ISO_C_BINDING's C_LOC()

[klausler]

Summary

Make __builtin_c_loc() into an intrinsic function and verify the
special semantic requirements on its actual arguments.

flang/include/flang/Evaluate/type.h

 // TargetCharactertics.
 
 // Given the dynamic types and kinds of two operands, determine the common
 // type to which they must be converted in order to be compared with
 // intrinsic OPERATOR(==) or .EQV.
 std::optional<DynamicType> ComparisonType(
     const DynamicType &, const DynamicType &);
 
-bool IsInteroperableIntrinsicType(const DynamicType &);
+bool IsInteroperableIntrinsicType(
+    const DynamicType &, bool checkCharLength = true);
 
 // Determine whether two derived type specs are sufficiently identical
 // to be considered the "same" type even if declared separately.
 bool AreSameDerivedType(
     const semantics::DerivedTypeSpec &x, const semantics::DerivedTypeSpec &y);
 
 // For generating "[extern] template class", &c. boilerplate
 #define EXPAND_FOR_EACH_INTEGER_KIND(M, P, S) \

flang/lib/Evaluate/characteristics.cpp

if (auto type{DynamicType::From(spec)}) {
     return Fold(context, TypeAndShape{std::move(*type)});
   } else {
     return std::nullopt;
   }
 }
 
 std::optional<TypeAndShape> TypeAndShape::Characterize(
     const ActualArgument &arg, FoldingContext &context) {
-  return Characterize(arg.UnwrapExpr(), context);
+  if (const auto *expr{arg.UnwrapExpr()}) {
+    return Characterize(*expr, context);
+  } else if (const Symbol * assumed{arg.GetAssumedTypeDummy()}) {
+    return Characterize(*assumed, context);
+  } else {
+    return std::nullopt;
+  }
 }
 
 bool TypeAndShape::IsCompatibleWith(parser::ContextualMessages &messages,
     const TypeAndShape &that, const char *thisIs, const char *thatIs,
     bool omitShapeConformanceCheck,
     enum CheckConformanceFlags::Flags flags) const {
   if (!type_.IsTkCompatibleWith(that.type_)) {
     messages.Say(

flang/lib/Evaluate/check-expression.cpp

public:
   }
   Result operator()(const Substring &) const { return std::nullopt; }
 
   Result operator()(const ProcedureRef &x) const {
     if (auto chars{
             characteristics::Procedure::Characterize(x.proc(), context_)}) {
       if (chars->functionResult) {
         const auto &result{*chars->functionResult};
-        return !result.IsProcedurePointer() &&
-            result.attrs.test(characteristics::FunctionResult::Attr::Pointer) &&
-            result.attrs.test(
-                characteristics::FunctionResult::Attr::Contiguous);
+        if (!result.IsProcedurePointer()) {
+          if (result.attrs.test(
+                  characteristics::FunctionResult::Attr::Contiguous)) {
+            return true;
+          }
+          if (!result.attrs.test(
+                  characteristics::FunctionResult::Attr::Pointer)) {
+            return true;
+          }
+          if (const auto *type{result.GetTypeAndShape()};
+              type && type->Rank() == 0) {
+            return true; // pointer to scalar
+          }
+          // Must be non-CONTIGUOUS pointer to array
+        }
       }
     }
     return std::nullopt;
   }
 
   Result operator()(const NullPointer &) const { return true; }
 
 private:

flang/lib/Evaluate/intrinsics.cpp

public:
 
   llvm::raw_ostream &Dump(llvm::raw_ostream &) const;
 
 private:
   DynamicType GetSpecificType(const TypePattern &) const;
   SpecificCall HandleNull(ActualArguments &, FoldingContext &) const;
   std::optional<SpecificCall> HandleC_F_Pointer(
       ActualArguments &, FoldingContext &) const;
+  std::optional<SpecificCall> HandleC_Loc(
+      ActualArguments &, FoldingContext &) const;
   const std::string &ResolveAlias(const std::string &name) const {
     auto iter{aliases_.find(name)};
     return iter == aliases_.end() ? name : iter->second;
   }
 
   common::IntrinsicTypeDefaultKinds defaults_;
   std::multimap<std::string, const IntrinsicInterface *> genericFuncs_;
   std::multimap<std::string, const SpecificIntrinsicInterface *> specificFuncs_;
bool IntrinsicProcTable::Implementation::IsIntrinsicFunction(
   if (specificRange.first != specificRange.second) {
     return true;
   }
   auto genericRange{genericFuncs_.equal_range(name)};
   if (genericRange.first != genericRange.second) {
     return true;
   }
   // special cases
-  return name == "null";
+  return name == "__builtin_c_loc" || name == "null";
 }
 bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine(
     const std::string &name) const {
   auto subrRange{subroutines_.equal_range(name)};
   if (subrRange.first != subrRange.second) {
     return true;
   }
   // special cases
return SpecificCall{
         SpecificIntrinsic{"__builtin_c_f_pointer"s,
             characteristics::Procedure{std::move(dummies), attrs}},
         std::move(arguments)};
   } else {
     return std::nullopt;
   }
 }
 
+static bool CheckForCoindexedObject(FoldingContext &context,
+    const std::optional<ActualArgument> &arg, const std::string &procName,
+    const std::string &argName) {
+  bool ok{true};
+  if (arg) {
+    if (ExtractCoarrayRef(arg->UnwrapExpr())) {
+      ok = false;
+      context.messages().Say(arg->sourceLocation(),
+          "'%s' argument to '%s' may not be a coindexed object"_err_en_US,
+          argName, procName);
+    }
+  }
+  return ok;
+}
+
+// Function C_LOC(X) from intrinsic module ISO_C_BINDING (18.2.3.6)
+std::optional<SpecificCall> IntrinsicProcTable::Implementation::HandleC_Loc(
+    ActualArguments &arguments, FoldingContext &context) const {
+  static const char *const keywords[]{"x", nullptr};
+  if (CheckAndRearrangeArguments(arguments, context.messages(), keywords)) {
+    CHECK(arguments.size() == 1);
+    CheckForCoindexedObject(context, arguments[0], "c_loc", "x");
+    const auto *expr{arguments[0].value().UnwrapExpr()};
+    if (expr &&
+        !(IsObjectPointer(*expr, context) ||
+            (IsVariable(*expr) && GetLastTarget(GetSymbolVector(*expr))))) {
+      context.messages().Say(arguments[0]->sourceLocation(),
+          "C_LOC() argument must be a data pointer or target"_err_en_US);
+    }
+    if (auto typeAndShape{characteristics::TypeAndShape::Characterize(
+            arguments[0], context)}) {
+      if (expr && !IsContiguous(*expr, context).value_or(true)) {
+        context.messages().Say(arguments[0]->sourceLocation(),
+            "C_LOC() argument must be contiguous"_err_en_US);
+      }
+      if (auto constExtents{AsConstantExtents(context, typeAndShape->shape())};
+          constExtents && GetSize(*constExtents) == 0) {
+        context.messages().Say(arguments[0]->sourceLocation(),
+            "C_LOC() argument may not be a zero-sized array"_err_en_US);
+      }
+      if (!(typeAndShape->type().category() != TypeCategory::Derived ||
+              typeAndShape->type().IsAssumedType() ||
+              (!typeAndShape->type().IsPolymorphic() &&
+                  CountNonConstantLenParameters(
+                      typeAndShape->type().GetDerivedTypeSpec()) == 0))) {
+        context.messages().Say(arguments[0]->sourceLocation(),
+            "C_LOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter"_err_en_US);
+      } else if (typeAndShape->type().knownLength().value_or(1) == 0) {
+        context.messages().Say(arguments[0]->sourceLocation(),
+            "C_LOC() argument may not be zero-length character"_err_en_US);
+      } else if (typeAndShape->type().category() != TypeCategory::Derived &&
+          !IsInteroperableIntrinsicType(typeAndShape->type())) {
+        context.messages().Say(arguments[0]->sourceLocation(),
+            "C_LOC() argument has non-interoperable intrinsic type, kind, or length"_warn_en_US);
+      }
+
+      return SpecificCall{SpecificIntrinsic{"__builtin_c_loc"s,
+                              characteristics::Procedure{
+                                  characteristics::FunctionResult{
+                                      DynamicType{GetBuiltinDerivedType(
+                                          builtinsScope_, "__builtin_c_ptr")}},
+                                  characteristics::DummyArguments{
+                                      characteristics::DummyArgument{"x"s,
+                                          characteristics::DummyDataObject{
+                                              std::move(*typeAndShape)}}},
+                                  characteristics::Procedure::Attrs{}}},
+          std::move(arguments)};
+    }
+  }
+  return std::nullopt;
+}
+
 static bool CheckForNonPositiveValues(FoldingContext &context,
     const ActualArgument &arg, const std::string &procName,
     const std::string &argName) {
   bool ok{true};
   if (arg.Rank() > 0) {
     if (const Expr<SomeType> *expr{arg.UnwrapExpr()}) {
       if (const auto *intExpr{std::get_if<Expr<SomeInteger>>(&expr->u)}) {
         std::visit(
if (const auto &dimArg{call.arguments[1]}) {
           }
         }
       }
     }
   }
   return ok;
 }
 
-static bool CheckForCoindexedObject(FoldingContext &context,
-    const std::optional<ActualArgument> &arg, const std::string &procName,
-    const std::string &argName) {
-  bool ok{true};
-  if (arg) {
-    if (ExtractCoarrayRef(arg->UnwrapExpr())) {
-      ok = false;
-      context.messages().Say(arg->sourceLocation(),
-          "'%s' argument to '%s' may not be a coindexed object"_err_en_US,
-          argName, procName);
-    }
-  }
-  return ok;
-}
-
 static bool CheckAtomicDefineAndRef(FoldingContext &context,
     const std::optional<ActualArgument> &atomArg,
     const std::optional<ActualArgument> &valueArg,
     const std::optional<ActualArgument> &statArg, const std::string &procName) {
   bool sameType{true};
   if (valueArg && atomArg) {
     // for atomic_define and atomic_ref, 'value' arg must be the same type as
     // 'atom', but it doesn't have to be the same kind
if (call.name == "__builtin_c_f_pointer") {
               Fortran::evaluate::MayBePassedAsAbsentOptional(*expr, context);
         }
       }
       if (arguments.size() - optionalCount > 1) {
         context.messages().Say(
             "RANDOM_SEED must have either 1 or no arguments"_err_en_US);
       }
     }
+  } else { // function
+    if (call.name == "__builtin_c_loc") {
+      return HandleC_Loc(arguments, context);
     } else if (call.name == "null") {
       return HandleNull(arguments, context);
     }
+  }
 
   if (call.isSubroutineCall) {
     auto subrRange{subroutines_.equal_range(call.name)};
     for (auto iter{subrRange.first}; iter != subrRange.second; ++iter) {
       if (auto specificCall{iter->second->Match(
               call, defaults_, arguments, context, builtinsScope_)}) {
         ApplySpecificChecks(*specificCall, context);
         return specificCall;

flang/lib/Evaluate/tools.cpp

bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *name) {
   } else {
     const auto &symbol{derived->typeSymbol()};
     return &symbol.owner() == symbol.owner().context().GetBuiltinsScope() &&
         symbol.name() == "__builtin_"s + name;
   }
 }
 
 bool IsBuiltinCPtr(const Symbol &symbol) {
-  if (const DeclTypeSpec *declType = symbol.GetType())
-    if (const DerivedTypeSpec *derived = declType->AsDerived())
+  if (const DeclTypeSpec *declType = symbol.GetType()) {
+    if (const DerivedTypeSpec *derived = declType->AsDerived()) {
       return IsIsoCType(derived);
+    }
+  }
   return false;
 }
 
 bool IsIsoCType(const DerivedTypeSpec *derived) {
   return IsBuiltinDerivedType(derived, "c_ptr") ||
       IsBuiltinDerivedType(derived, "c_funptr");
 }
 

flang/lib/Evaluate/type.cpp

case TypeCategory::Logical:
     default:
       return std::nullopt;
     }
   default:
     return std::nullopt;
   }
 }
 
-bool IsInteroperableIntrinsicType(const DynamicType &type) {
+bool IsInteroperableIntrinsicType(
+    const DynamicType &type, bool checkCharLength) {
   switch (type.category()) {
   case TypeCategory::Integer:
     return true;
   case TypeCategory::Real:
   case TypeCategory::Complex:
     return type.kind() >= 4; // no short or half floats
   case TypeCategory::Logical:
     return type.kind() == 1; // C_BOOL
   case TypeCategory::Character:
-    return type.kind() == 1 /* C_CHAR */ && type.knownLength().value_or(0) == 1;
+    if (checkCharLength && type.knownLength().value_or(0) != 1) {
+      return false;
+    }
+    return type.kind() == 1 /* C_CHAR */;
   default:
     // Derived types are tested in Semantics/check-declarations.cpp
     return false;
   }
 }
 
 } // namespace Fortran::evaluate

flang/lib/Semantics/expression.cpp

if (auto *component{std::get_if<Component>(&ref.u)}) {
       if (!CheckDataRef(ref)) {
         return std::nullopt;
       }
       return Expr<SomeType>{ProcedureDesignator{std::move(*component)}};
     } else if (!std::holds_alternative<SymbolRef>(ref.u)) {
       DIE("unexpected alternative in DataRef");
     } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) {
       if (symbol.has<semantics::GenericDetails>()) {
-        Say("'%s' is not a specific procedure"_err_en_US, symbol.name());
+        Say("'%s' is not a specific procedure"_err_en_US, last.name());
       } else {
         return Expr<SomeType>{ProcedureDesignator{symbol}};
       }
     } else if (auto interface{context_.intrinsics().IsSpecificIntrinsicFunction(
                    symbol.name().ToString())};
                interface && !interface->isRestrictedSpecific) {
       SpecificIntrinsic intrinsic{
           symbol.name().ToString(), std::move(*interface)};
       intrinsic.isRestrictedSpecific = interface->isRestrictedSpecific;
       return Expr<SomeType>{ProcedureDesignator{std::move(intrinsic)}};
     } else {
       Say("'%s' is not an unrestricted specific intrinsic procedure"_err_en_US,
-          symbol.name());
+          last.name());
     }
     return std::nullopt;
   } else if (MaybeExpr result{AsGenericExpr(std::move(ref))}) {
     return result;
   } else {
     if (!context_.HasError(last) && !context_.HasError(symbol)) {
       AttachDeclaration(
           Say("'%s' is not an object that can appear in an expression"_err_en_US,

flang/module/__fortran_builtins.f90

 !===-- module/__fortran_builtins.f90 ---------------------------------------===!
 !
 ! 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
 !
 !===------------------------------------------------------------------------===!
 
 ! These naming shenanigans prevent names from Fortran intrinsic modules
 ! from being usable on INTRINSIC statements, and force the program
 ! to USE the standard intrinsic modules in order to access the
 ! standard names of the procedures.
 module __Fortran_builtins
 
+  intrinsic :: __builtin_c_loc
   intrinsic :: __builtin_c_f_pointer
   intrinsic :: sizeof ! extension
 
   intrinsic :: selected_int_kind
   private :: selected_int_kind
   integer, parameter, private :: int64 = selected_int_kind(18)
 
   type, bind(c) :: __builtin_c_ptr
module __Fortran_builtins
 
   type :: __builtin_team_type
     integer(kind=int64) :: __id
   end type
 
   integer, parameter :: __builtin_atomic_int_kind = selected_int_kind(18)
   integer, parameter :: __builtin_atomic_logical_kind = __builtin_atomic_int_kind
 
-  procedure(type(__builtin_c_ptr)) :: __builtin_c_loc
-
   intrinsic :: __builtin_ieee_is_nan, __builtin_ieee_is_negative, &
     __builtin_ieee_is_normal
   intrinsic :: __builtin_ieee_next_after, __builtin_ieee_next_down, &
     __builtin_ieee_next_up
   intrinsic :: scale ! for ieee_scalb
   intrinsic :: __builtin_ieee_selected_real_kind
   intrinsic :: __builtin_ieee_support_datatype, &
     __builtin_ieee_support_denormal, __builtin_ieee_support_divide, &

flang/test/Lower/HLFIR/intrinsic-module-procedures.f90

 ! Test lowering of intrinsic module procedures to HLFIR. This
 ! test is not meant to test every intrinsic module procedure,
 ! it only tests that the HFLIR procedure reference lowering
 ! infrastructure properly detects and dispatches intrinsic module
 ! procedure calls.
 ! RUN: bbc -emit-fir -hlfir -o - %s | FileCheck %s
 
 subroutine foo(cptr, x)
   use iso_c_binding, only : c_ptr, c_loc
   type(c_ptr) :: cptr
-  integer :: x
+  integer, target :: x
   cptr = c_loc(x)
 end subroutine
 ! CHECK-LABEL: func.func @_QPfoo(
 ! CHECK:         %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}Ecptr"
 ! CHECK:         %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}Ex"
 ! CHECK:         %[[VAL_4:.*]] = fir.embox %[[VAL_3]]#1 : (!fir.ref<i32>) -> !fir.box<i32>
 ! CHECK:         %[[VAL_5:.*]] = fir.alloca !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
 ! CHECK:         %[[VAL_6:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
 ! CHECK:         %[[VAL_7:.*]] = fir.coordinate_of %[[VAL_5]], %[[VAL_6]] : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>, !fir.field) -> !fir.ref<i64>
 ! CHECK:         %[[VAL_8:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box<i32>) -> !fir.ref<i32>
 ! CHECK:         %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.ref<i32>) -> i64
 ! CHECK:         fir.store %[[VAL_9]] to %[[VAL_7]] : !fir.ref<i64>

flang/test/Semantics/c_loc01.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  use iso_c_binding
+  type haslen(L)
+    integer, len :: L
+  end type
+ contains
+  subroutine test(assumedType, poly, nclen)
+    type(*), target :: assumedType
+    class(*), target ::  poly
+    type(c_ptr) cp
+    real notATarget
+    procedure(sin), pointer :: pptr
+    real, target :: arr(3)
+    type(hasLen(1)), target :: clen
+    type(hasLen(*)), target :: nclen
+    character(2), target :: ch
+    !ERROR: C_LOC() argument must be a data pointer or target
+    cp = c_loc(notATarget)
+    !ERROR: C_LOC() argument must be a data pointer or target
+    cp = c_loc(pptr)
+    !ERROR: C_LOC() argument must be contiguous
+    cp = c_loc(arr(1:3:2))
+    !ERROR: C_LOC() argument may not be a zero-sized array
+    cp = c_loc(arr(3:1))
+    !ERROR: C_LOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter
+    cp = c_loc(poly)
+    cp = c_loc(clen) ! ok
+    !ERROR: C_LOC() argument must have an intrinsic type, assumed type, or non-polymorphic derived type with no non-constant length parameter
+    cp = c_loc(nclen)
+    !ERROR: C_LOC() argument may not be zero-length character
+    cp = c_loc(ch(2:1))
+    !WARNING: C_LOC() argument has non-interoperable intrinsic type, kind, or length
+    cp = c_loc(ch)
+    cp = c_loc(ch(1:1)) ! ok)
+  end
+end module