Index: flang/docs/Extensions.md =================================================================== --- flang/docs/Extensions.md +++ flang/docs/Extensions.md @@ -557,6 +557,9 @@ obsolete module file from a previous compilation and then overwriting that file later. +* F18 allows `OPTIONAL` dummy arguments to interoperable procedures + unless they are `VALUE` (C865). + ## De Facto Standard Features * `EXTENDS_TYPE_OF()` returns `.TRUE.` if both of its arguments have the Index: flang/lib/Semantics/check-declarations.cpp =================================================================== --- flang/lib/Semantics/check-declarations.cpp +++ flang/lib/Semantics/check-declarations.cpp @@ -254,7 +254,9 @@ if (symbol.attrs().test(Attr::VOLATILE)) { CheckVolatile(symbol, derived); } - CheckBindC(symbol); + if (symbol.attrs().test(Attr::BIND_C)) { + CheckBindC(symbol); + } CheckGlobalName(symbol); if (isDone) { return; // following checks do not apply @@ -430,7 +432,9 @@ void CheckHelper::CheckCommonBlock(const Symbol &symbol) { CheckGlobalName(symbol); - CheckBindC(symbol); + if (symbol.attrs().test(Attr::BIND_C)) { + CheckBindC(symbol); + } } void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553 @@ -2218,13 +2222,16 @@ } void CheckHelper::CheckBindC(const Symbol &symbol) { - if (!symbol.attrs().test(Attr::BIND_C)) { - return; + bool isExplicitBindC{symbol.attrs().test(Attr::BIND_C)}; + if (isExplicitBindC) { + CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER); + CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL); + } else { + // symbol must be interoperable (e.g., dummy argument of interoperable + // procedure interface) but is not itself BIND(C). } - CheckConflicting(symbol, Attr::BIND_C, Attr::PARAMETER); - CheckConflicting(symbol, Attr::BIND_C, Attr::ELEMENTAL); if (const std::string * bindName{symbol.GetBindName()}; - bindName) { // BIND(C,NAME=...) + bindName) { // has a binding name if (!bindName->empty()) { bool ok{bindName->front() == '_' || parser::IsLetter(bindName->front())}; for (char ch : *bindName) { @@ -2237,7 +2244,7 @@ } } } - if (symbol.GetIsExplicitBindName()) { // C1552, C1529 + if (symbol.GetIsExplicitBindName()) { // BIND(C,NAME=...); C1552, C1529 auto defClass{ClassifyProcedure(symbol)}; if (IsProcedurePointer(symbol)) { messages_.Say(symbol.name(), @@ -2256,33 +2263,67 @@ context_.SetError(symbol); } } - if (symbol.detailsIf()) { - if (!symbol.owner().IsModule()) { + if (const auto *object{symbol.detailsIf()}) { + if (isExplicitBindC && !symbol.owner().IsModule()) { messages_.Say(symbol.name(), "A variable with BIND(C) attribute may only appear in the specification part of a module"_err_en_US); context_.SetError(symbol); } - if (auto extents{evaluate::GetConstantExtents(foldingContext_, symbol)}; - extents && evaluate::GetSize(*extents) == 0) { - SayWithDeclaration(symbol, symbol.name(), - "Interoperable array must have at least one element"_err_en_US); - } - if (const auto *type{symbol.GetType()}) { - if (const auto *derived{type->AsDerived()}) { - if (!derived->typeSymbol().attrs().test(Attr::BIND_C)) { - if (auto *msg{messages_.Say(symbol.name(), - "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)}) { - msg->Attach( - derived->typeSymbol().name(), "Non-interoperable type"_en_US); + if (auto shape{evaluate::GetShape(foldingContext_, symbol)}) { + if (evaluate::GetRank(*shape) == 0) { // 18.3.4 + if (isExplicitBindC && IsAllocatableOrPointer(symbol)) { + messages_.Say(symbol.name(), + "A scalar interoperable variable may not be ALLOCATABLE or POINTER"_err_en_US); + context_.SetError(symbol); + } + } else { // 18.3.5 + if (auto extents{ + evaluate::AsConstantExtents(foldingContext_, *shape)}) { + if (evaluate::GetSize(*extents) == 0) { + SayWithDeclaration(symbol, symbol.name(), + "Interoperable array must have at least one element"_err_en_US); + context_.SetError(symbol); } + } else if ((isExplicitBindC || symbol.attrs().test(Attr::VALUE)) && + !evaluate::IsExplicitShape(symbol) && !object->IsAssumedSize()) { + SayWithDeclaration(symbol, symbol.name(), + "BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute"_err_en_US); context_.SetError(symbol); } - } else if (!IsInteroperableIntrinsicType(*type)) { + } + } + if (const auto *type{symbol.GetType()}) { + const auto *derived{type->AsDerived()}; + if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) { + if (auto *msg{messages_.Say(symbol.name(), + "The derived type of a BIND(C) object must also be BIND(C)"_err_en_US)}) { + msg->Attach( + derived->typeSymbol().name(), "Non-interoperable type"_en_US); + } + context_.SetError(symbol); + } + if (type->IsAssumedType() || IsAssumedLengthCharacter(symbol)) { + // ok + } else if (IsAllocatableOrPointer(symbol) && + type->category() == DeclTypeSpec::Character && + type->characterTypeSpec().length().isDeferred()) { + // ok; F'2018 18.3.6 p2(6) + } else if (derived || IsInteroperableIntrinsicType(*type)) { + // F'2018 18.3.6 p2(4,5) + } else if (symbol.attrs().test(Attr::VALUE)) { + messages_.Say(symbol.name(), + "A BIND(C) VALUE dummy argument must have an interoperable type"_err_en_US); + context_.SetError(symbol); + } else { messages_.Say(symbol.name(), "A BIND(C) object must have an interoperable type"_err_en_US); context_.SetError(symbol); } } + if (IsOptional(symbol) && !symbol.attrs().test(Attr::VALUE)) { + messages_.Say(symbol.name(), + "An interoperable procedure with an OPTIONAL dummy argument might not be portable"_port_en_US); + } } else if (const auto *proc{symbol.detailsIf()}) { if (!proc->procInterface() || !proc->procInterface()->attrs().test(Attr::BIND_C)) { @@ -2290,6 +2331,16 @@ "An interface name with BIND attribute must be specified if the BIND attribute is specified in a procedure declaration statement"_err_en_US); context_.SetError(symbol); } + } else if (const auto *subp{symbol.detailsIf()}) { + for (const Symbol *dummy : subp->dummyArgs()) { + if (dummy) { + CheckBindC(*dummy); + } else { + messages_.Say(symbol.name(), + "A subprogram interface with the BIND attribute may not have an alternate return argument"_err_en_US); + context_.SetError(symbol); + } + } } else if (const auto *derived{symbol.detailsIf()}) { if (derived->sequence()) { // C1801 messages_.Say(symbol.name(), Index: flang/module/iso_c_binding.f90 =================================================================== --- flang/module/iso_c_binding.f90 +++ flang/module/iso_c_binding.f90 @@ -64,7 +64,7 @@ c_double_complex = c_double, & c_long_double_complex = c_long_double - integer, parameter :: c_bool = 1 ! TODO: or default LOGICAL? + integer, parameter :: c_bool = 1 integer, parameter :: c_char = 1 ! C characters with special semantics Index: flang/module/omp_lib.h =================================================================== --- flang/module/omp_lib.h +++ flang/module/omp_lib.h @@ -9,7 +9,7 @@ !dir$ free integer, parameter :: omp_integer_kind = selected_int_kind(9) ! 32-bit int - integer, parameter :: omp_logical_kind = kind(.true.) + integer, parameter :: omp_logical_kind = 1 ! C_BOOL integer, parameter :: omp_sched_kind = omp_integer_kind integer, parameter :: omp_proc_bind_kind = omp_integer_kind Index: flang/test/Lower/call-by-value.f90 =================================================================== --- flang/test/Lower/call-by-value.f90 +++ flang/test/Lower/call-by-value.f90 @@ -2,21 +2,23 @@ ! RUN: bbc -emit-fir %s -o - | FileCheck %s !CHECK-LABEL: func @_QQmain() -!CHECK: %[[LOGICAL:.*]] = fir.alloca !fir.logical<4> +!CHECK: %[[LOGICAL:.*]] = fir.alloca !fir.logical<1> !CHECK: %false = arith.constant false -!CHECK: %[[VALUE:.*]] = fir.convert %false : (i1) -> !fir.logical<4> +!CHECK: %[[VALUE:.*]] = fir.convert %false : (i1) -> !fir.logical<1> !CHECK: fir.store %[[VALUE]] to %[[LOGICAL]] !CHECK: %[[LOAD:.*]] = fir.load %[[LOGICAL]] !CHECK: fir.call @omp_set_nested(%[[LOAD]]) {{.*}}: {{.*}} program call_by_value + use iso_c_binding, only: c_bool interface subroutine omp_set_nested(enable) bind(c) - logical, value :: enable + import c_bool + logical(c_bool), value :: enable end subroutine omp_set_nested end interface - logical do_nested + logical(c_bool) do_nested do_nested = .FALSE. call omp_set_nested(do_nested) end program call_by_value Index: flang/test/Semantics/bind-c11.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/bind-c11.f90 @@ -0,0 +1,21 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 +module m + !ERROR: A scalar interoperable variable may not be ALLOCATABLE or POINTER + real, allocatable, bind(c) :: x1 + !ERROR: A scalar interoperable variable may not be ALLOCATABLE or POINTER + real, pointer, bind(c) :: x2 + !ERROR: BIND(C) array must have explicit shape or be assumed-size unless a dummy argument without the VALUE attribute + real, allocatable, bind(c) :: x3(:) + contains + subroutine s1(x) bind(c) + !ERROR: A BIND(C) VALUE dummy argument must have an interoperable type + logical(2), intent(in), value :: x + end + subroutine s2(x) bind(c) + !PORTABILITY: An interoperable procedure with an OPTIONAL dummy argument might not be portable + integer, intent(in), optional :: x + end + !ERROR: A subprogram interface with the BIND attribute may not have an alternate return argument + subroutine s3(*) bind(c) + end +end Index: flang/test/Semantics/modfile04.f90 =================================================================== --- flang/test/Semantics/modfile04.f90 +++ flang/test/Semantics/modfile04.f90 @@ -7,7 +7,7 @@ contains pure subroutine Ss(x, y) bind(c) - logical x + logical(1) x intent(inout) y intent(in) x end subroutine @@ -54,7 +54,7 @@ !end type !contains !pure subroutine ss(x,y) bind(c) -!logical(4),intent(in)::x +!logical(1),intent(in)::x !real(4),intent(inout)::y !end !function f1() result(x)