[flang] Check dummy arguments of BIND(C) procedures

Declaration checking in semantics was only examining symbols with explicit BIND(C) attributes; extend it to also check dummy arguments to such procedures. Differential Revision: https://reviews.llvm.org/D145746
llvm · Mar 10, 2023 · 199402c · 199402c
1 parent a1db3e6
commit 199402c
Show file tree

Hide file tree

Showing 7 changed files with 108 additions and 31 deletions.
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
@@ -557,6 +557,9 @@ end module
   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

diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
@@ -254,7 +254,9 @@ void CheckHelper::Check(const Symbol &symbol) {
   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::Check(const Symbol &symbol) {
 
 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::CheckGlobalName(const Symbol &symbol) {
 }
 
 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 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
       }
     }
   }
-  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,40 +2263,84 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
       context_.SetError(symbol);
     }
   }
-  if (symbol.detailsIf<ObjectEntityDetails>()) {
-    if (!symbol.owner().IsModule()) {
+  if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    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<ProcEntityDetails>()}) {
     if (!proc->procInterface() ||
         !proc->procInterface()->attrs().test(Attr::BIND_C)) {
       messages_.Say(symbol.name(),
           "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<SubprogramDetails>()}) {
+    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<DerivedTypeDetails>()}) {
     if (derived->sequence()) { // C1801
       messages_.Say(symbol.name(),

diff --git a/flang/module/iso_c_binding.f90 b/flang/module/iso_c_binding.f90
@@ -64,7 +64,7 @@ module iso_c_binding
     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

diff --git a/flang/module/omp_lib.h b/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

diff --git a/flang/test/Lower/call-by-value.f90 b/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

diff --git a/flang/test/Semantics/bind-c11.f90 b/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
diff --git a/flang/test/Semantics/modfile04.f90 b/flang/test/Semantics/modfile04.f90
@@ -7,7 +7,7 @@ module m1
 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 module m3
 !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)