diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -472,7 +472,8 @@ std::optional 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. diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp --- a/flang/lib/Evaluate/characteristics.cpp +++ b/flang/lib/Evaluate/characteristics.cpp @@ -149,7 +149,13 @@ std::optional 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, diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -819,10 +819,21 @@ 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; diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp --- a/flang/lib/Evaluate/intrinsics.cpp +++ b/flang/lib/Evaluate/intrinsics.cpp @@ -2410,6 +2410,8 @@ SpecificCall HandleNull(ActualArguments &, FoldingContext &) const; std::optional HandleC_F_Pointer( ActualArguments &, FoldingContext &) const; + std::optional 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; @@ -2435,7 +2437,7 @@ return true; } // special cases - return name == "null"; + return name == "__builtin_c_loc" || name == "null"; } bool IntrinsicProcTable::Implementation::IsIntrinsicSubroutine( const std::string &name) const { @@ -2691,6 +2693,78 @@ } } +static bool CheckForCoindexedObject(FoldingContext &context, + const std::optional &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 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) { @@ -2751,21 +2825,6 @@ return ok; } -static bool CheckForCoindexedObject(FoldingContext &context, - const std::optional &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 &atomArg, const std::optional &valueArg, @@ -3013,8 +3072,12 @@ "RANDOM_SEED must have either 1 or no arguments"_err_en_US); } } - } else if (call.name == "null") { - return HandleNull(arguments, context); + } 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) { diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1555,9 +1555,11 @@ } 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; } diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -734,7 +734,8 @@ } } -bool IsInteroperableIntrinsicType(const DynamicType &type) { +bool IsInteroperableIntrinsicType( + const DynamicType &type, bool checkCharLength) { switch (type.category()) { case TypeCategory::Integer: return true; @@ -744,7 +745,10 @@ 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; diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -216,7 +216,7 @@ DIE("unexpected alternative in DataRef"); } else if (!symbol.attrs().test(semantics::Attr::INTRINSIC)) { if (symbol.has()) { - 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{ProcedureDesignator{symbol}}; } @@ -229,7 +229,7 @@ return Expr{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))}) { diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90 --- a/flang/module/__fortran_builtins.f90 +++ b/flang/module/__fortran_builtins.f90 @@ -12,6 +12,7 @@ ! standard names of the procedures. module __Fortran_builtins + intrinsic :: __builtin_c_loc intrinsic :: __builtin_c_f_pointer intrinsic :: sizeof ! extension @@ -42,8 +43,6 @@ 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, & diff --git a/flang/test/Lower/HLFIR/intrinsic-module-procedures.f90 b/flang/test/Lower/HLFIR/intrinsic-module-procedures.f90 --- a/flang/test/Lower/HLFIR/intrinsic-module-procedures.f90 +++ b/flang/test/Lower/HLFIR/intrinsic-module-procedures.f90 @@ -8,7 +8,7 @@ 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( diff --git a/flang/test/Semantics/c_loc01.f90 b/flang/test/Semantics/c_loc01.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Semantics/c_loc01.f90 @@ -0,0 +1,37 @@ +! 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