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

[klausler]

Summary

Declaration checking in semantics was only examining symbols with
explicit BIND(C) attributes; extend it to also check dummy arguments
to such procedures.

[clementval]

LGTM

flang/docs/Extensions.md

 
 * F18 allows a `USE` statement to reference a module that is defined later
   in the same compilation unit, so long as mutual dependencies do not form
   a cycle.
   This feature forestalls any risk of such a `USE` statement reading an
   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
   same type, a case that is technically implementation-defined.

flang/lib/Semantics/check-declarations.cpp

common::visit(
           [&](const DerivedTypeDetails &x) { CheckDerivedType(symbol, x); },
           [&](const GenericDetails &x) { CheckGeneric(symbol, x); },
           [](const auto &) {},
       },
       symbol.details());
   if (symbol.attrs().test(Attr::VOLATILE)) {
     CheckVolatile(symbol, derived);
   }
+  if (symbol.attrs().test(Attr::BIND_C)) {
     CheckBindC(symbol);
+  }
   CheckGlobalName(symbol);
   if (isDone) {
     return; // following checks do not apply
   }
   if (symbol.attrs().test(Attr::PROTECTED)) {
     if (symbol.owner().kind() != Scope::Kind::Module) { // C854
       messages_.Say(
           "A PROTECTED entity must be in the specification part of a module"_err_en_US);
messages_.Say(
         "Automatic data object '%s' may not appear in the specification part"
         " of a module"_err_en_US,
         symbol.name());
   }
 }
 
 void CheckHelper::CheckCommonBlock(const Symbol &symbol) {
   CheckGlobalName(symbol);
+  if (symbol.attrs().test(Attr::BIND_C)) {
     CheckBindC(symbol);
   }
+}
 
 void CheckHelper::CheckBindCFunctionResult(const Symbol &symbol) { // C1553
   if (!innermostSymbol_ || !IsBindCProcedure(*innermostSymbol_)) {
     return;
   }
   if (IsPointer(symbol) || IsAllocatable(symbol)) {
     messages_.Say(
         "BIND(C) function result cannot have ALLOCATABLE or POINTER attribute"_err_en_US);
if (!pair.second) {
         context_.SetError(symbol);
         context_.SetError(other);
       }
     }
   }
 }
 
 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).
+  }
   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) {
         ok &= ch == '_' || parser::IsLetter(ch) || parser::IsDecimalDigit(ch);
       }
       if (!ok) {
         messages_.Say(symbol.name(),
             "Symbol has a BIND(C) name that is not a valid C language identifier"_err_en_US);
         context_.SetError(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(),
           "A procedure pointer may not have a BIND attribute with a name"_err_en_US);
       context_.SetError(symbol);
     } else if (defClass == ProcedureDefinitionClass::None ||
         IsExternal(symbol)) {
     } else if (symbol.attrs().test(Attr::ABSTRACT)) {
       messages_.Say(symbol.name(),
           "An ABSTRACT interface may not have a BIND attribute with a name"_err_en_US);
       context_.SetError(symbol);
     } else if (defClass == ProcedureDefinitionClass::Internal ||
         defClass == ProcedureDefinitionClass::Dummy) {
       messages_.Say(symbol.name(),
           "An internal or dummy procedure may not have a BIND(C,NAME=) binding label"_err_en_US);
       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) {
+    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);
+        }
+      }
     }
     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);
-          }
-          context_.SetError(symbol);
-        }
-      } else if (!IsInteroperableIntrinsicType(*type)) {
+      const auto *derived{type->AsDerived()};
+      if (derived && !derived->typeSymbol().attrs().test(Attr::BIND_C)) {
+      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(),
           "A derived type with the BIND attribute cannot have the SEQUENCE attribute"_err_en_US);
       context_.SetError(symbol);
     } else if (!derived->paramDecls().empty()) { // C1802
       messages_.Say(symbol.name(),
           "A derived type with the BIND attribute has type parameter(s)"_err_en_US);

flang/module/iso_c_binding.f90

#else
     c_long_double = 16
 #endif
 
   integer, parameter :: &
     c_float_complex = c_float, &
     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
   character(kind=c_char, len=1), parameter :: c_null_char = achar(0)
   character(kind=c_char, len=1), parameter :: c_alert = achar(7)
   character(kind=c_char, len=1), parameter :: c_backspace = achar(8)
   character(kind=c_char, len=1), parameter :: c_form_feed = achar(12)
   character(kind=c_char, len=1), parameter :: c_new_line = achar(10)

flang/module/omp_lib.h

 !===-- module/omp_lib.h ------------------------------------------*- 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
 !
 !===------------------------------------------------------------------------===!
 
 !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
   integer, parameter :: omp_pause_resource_kind = omp_integer_kind
   integer, parameter :: omp_sync_hint_kind = omp_integer_kind
   integer, parameter :: omp_lock_hint_kind = omp_sync_hint_kind
   integer, parameter :: omp_event_handle_kind = omp_integer_kind
   integer, parameter :: omp_alloctrait_key_kind = omp_integer_kind

flang/test/Lower/call-by-value.f90

 ! Test for PassBy::Value
 ! 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
 
 ! CHECK-LABEL: func.func @test_integer_value(
 ! CHECK-SAME:                                %[[VAL_0:.*]]: i32 {fir.bindc_name = "x"}) attributes {fir.bindc_name = "test_integer_value"} {
 ! CHECK:         %[[VAL_1:.*]] = fir.alloca i32
 ! CHECK:         fir.store %[[VAL_0]] to %[[VAL_1]] : !fir.ref<i32>

flang/test/Semantics/bind-c11.f90

+! 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

flang/test/Semantics/modfile04.f90

 ! RUN: %python %S/test_modfile.py %s %flang_fc1
 ! modfile with subprograms
 
 module m1
   type :: t
   end type
 contains
 
   pure subroutine Ss(x, y) bind(c)
-    logical x
+    logical(1) x
     intent(inout) y
     intent(in) x
   end subroutine
 
   real function f1() result(x)
     x = 1.0
   end function
 

 end module m3
 
 !Expect: m1.mod
 !module m1
 !type::t
 !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)
 !real(4)::x
 !end
 !function f2(y)
 !complex(4)::y
 !real(4)::f2