[flang-commits] [flang] a88cee1 - [flang] Semantics for ISO_C_BINDING's C_LOC()
Peter Klausler via flang-commits
flang-commits at lists.llvm.org
Mon May 8 15:58:15 PDT 2023
Author: Peter Klausler
Date: 2023-05-08T15:58:09-07:00
New Revision: a88cee1fd06dd633fc6551d242c55f4235d4862d
URL: https://github.com/llvm/llvm-project/commit/a88cee1fd06dd633fc6551d242c55f4235d4862d
DIFF: https://github.com/llvm/llvm-project/commit/a88cee1fd06dd633fc6551d242c55f4235d4862d.diff
LOG: [flang] Semantics for ISO_C_BINDING's C_LOC()
Make __builtin_c_loc() into an intrinsic function and verify the
special semantic requirements on its actual arguments.
Differential Revision: https://reviews.llvm.org/D149988
Added:
flang/test/Semantics/c_loc01.f90
Modified:
flang/include/flang/Evaluate/type.h
flang/lib/Evaluate/characteristics.cpp
flang/lib/Evaluate/check-expression.cpp
flang/lib/Evaluate/intrinsics.cpp
flang/lib/Evaluate/tools.cpp
flang/lib/Evaluate/type.cpp
flang/lib/Semantics/expression.cpp
flang/module/__fortran_builtins.f90
flang/test/Lower/HLFIR/intrinsic-module-procedures.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h
index 4b13a3155ab00..2183b0dad5d1a 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -472,7 +472,8 @@ int SelectedCharKind(const std::string &, int defaultKind);
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.
diff --git a/flang/lib/Evaluate/characteristics.cpp b/flang/lib/Evaluate/characteristics.cpp
index b8cb822866dbf..62b1573010f95 100644
--- a/flang/lib/Evaluate/characteristics.cpp
+++ b/flang/lib/Evaluate/characteristics.cpp
@@ -149,7 +149,13 @@ std::optional<TypeAndShape> TypeAndShape::Characterize(
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,
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index d307af6a9e14c..206e9578a28b8 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -819,10 +819,21 @@ class IsContiguousHelper
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
index 649d46886e98d..7b7ce78e9cbe8 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2410,6 +2410,8 @@ class IntrinsicProcTable::Implementation {
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;
@@ -2435,7 +2437,7 @@ bool IntrinsicProcTable::Implementation::IsIntrinsicFunction(
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 @@ IntrinsicProcTable::Implementation::HandleC_F_Pointer(
}
}
+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) {
@@ -2751,21 +2825,6 @@ static bool CheckDimAgainstCorank(SpecificCall &call, FoldingContext &context) {
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,
@@ -3013,8 +3072,12 @@ std::optional<SpecificCall> IntrinsicProcTable::Implementation::Probe(
"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
index 5d7129b32fc0b..b9fb511b47cba 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -1555,9 +1555,11 @@ bool IsBuiltinDerivedType(const DerivedTypeSpec *derived, const char *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;
}
diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp
index 83a4ee5c45887..0b9292a18d3fa 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -734,7 +734,8 @@ std::optional<DynamicType> ComparisonType(
}
}
-bool IsInteroperableIntrinsicType(const DynamicType &type) {
+bool IsInteroperableIntrinsicType(
+ const DynamicType &type, bool checkCharLength) {
switch (type.category()) {
case TypeCategory::Integer:
return true;
@@ -744,7 +745,10 @@ bool IsInteroperableIntrinsicType(const DynamicType &type) {
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
index 5ec83344d03d0..1440147feecdf 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -216,7 +216,7 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
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}};
}
@@ -229,7 +229,7 @@ MaybeExpr ExpressionAnalyzer::Designate(DataRef &&ref) {
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))}) {
diff --git a/flang/module/__fortran_builtins.f90 b/flang/module/__fortran_builtins.f90
index a22aa4699f7ad..1dee77e3c10cf 100644
--- 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
index 40bb39e967265..7a124e2886510 100644
--- 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
index 0000000000000..02f32e3801d91
--- /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
More information about the flang-commits
mailing list