[flang] Accept BOZ literals for some actual arguments

[klausler]

Summary

Consistent with previously documented policy, in which
BOZ literals are accepted in non-standard-conforming circumstances
where they can be converted to an unambiguous known numeric type,
allow BOZ literals to be passed as an actual argument in a reference
to a procedure whose explicit interface has a corresponding dummy
argument with a numeric type to which the BOZ literal may be
converted. Improve error messages associated with BOZ literal
actual arguments, too: don't emit multiple errors.

flang/docs/Extensions.md

* $ and \ edit descriptors are supported in FORMAT to suppress newline
   output on user prompts.
 * Tabs in format strings (not `FORMAT` statements) are allowed on output.
 * REAL and DOUBLE PRECISION variable and bounds in DO loops
 * Integer literals without explicit kind specifiers that are out of range
   for the default kind of INTEGER are assumed to have the least larger kind
   that can hold them, if one exists.
 * BOZ literals can be used as INTEGER values in contexts where the type is
   unambiguous: the right hand sides of assigments and initializations
-  of INTEGER entities, and as actual arguments to a few intrinsic functions
-  (ACHAR, BTEST, CHAR).  BOZ literals are interpreted as default INTEGER
+  of INTEGER entities, as actual arguments to a few intrinsic functions
+  (ACHAR, BTEST, CHAR), and as actual arguments of references to
+  procedures with explicit interfaces whose corresponding dummy
+  argument has a numeric type to which the BOZ literal may be
+  converted.  BOZ literals are interpreted as default INTEGER only
   when they appear as the first items of array constructors with no
   explicit type.  Otherwise, they generally cannot be used if the type would
   not be known (e.g., `IAND(X'1',X'2')`).
 * BOZ literals can also be used as REAL values in some contexts where the
   type is unambiguous, such as initializations of REAL parameters.
 * EQUIVALENCE of numeric and character sequences (a ubiquitous extension)
 * Values for whole anonymous parent components in structure constructors
   (e.g., `EXTENDEDTYPE(PARENTTYPE(1,2,3))` rather than `EXTENDEDTYPE(1,2,3)`

flang/lib/Evaluate/intrinsics.cpp

for (std::size_t j{0}; j < dummies; ++j) {
     if (!type) {
       CHECK(arg->Rank() == 0);
       const Expr<SomeType> &expr{DEREF(arg->UnwrapExpr())};
       if (IsBOZLiteral(expr)) {
         if (d.typePattern.kindCode == KindCode::typeless ||
             d.rank == Rank::elementalOrBOZ) {
           continue;
         } else {
-          const IntrinsicDummyArgument &nextParam{dummy[j + 1]};
+          const IntrinsicDummyArgument *nextParam{
+              j + 1 < dummies ? &dummy[j + 1] : nullptr};
+          if (nextParam && nextParam->rank == Rank::elementalOrBOZ) {
             messages.Say(
                 "Typeless (BOZ) not allowed for both '%s=' & '%s=' arguments"_err_en_US, // C7109
-              d.keyword, nextParam.keyword);
+                d.keyword, nextParam->keyword);
+          } else {
+            messages.Say(
+                "Typeless (BOZ) not allowed for '%s=' argument"_err_en_US,
+                d.keyword);
+          }
         }
       } else {
         // NULL(), procedure, or procedure pointer
         CHECK(IsProcedurePointerTarget(expr));
         if (d.typePattern.kindCode == KindCode::addressable ||
             d.rank == Rank::reduceOperation) {
           continue;
         } else if (d.typePattern.kindCode == KindCode::nullPointerType) {

flang/lib/Evaluate/tools.cpp

return std::visit(
         }
         return std::nullopt;
       },
       std::move(x.u));
 }
 
 std::optional<Expr<SomeType>> ConvertToType(
     const DynamicType &type, Expr<SomeType> &&x) {
+  if (type.IsTypelessIntrinsicArgument()) {
+    return std::nullopt;
+  }
   switch (type.category()) {
   case TypeCategory::Integer:
     if (auto *boz{std::get_if<BOZLiteralConstant>(&x.u)}) {
       // Extension to C7109: allow BOZ literals to appear in integer contexts
       // when the type is unambiguous.
       return Expr<SomeType>{
           ConvertToKind<TypeCategory::Integer>(type.kind(), std::move(*boz))};
     }

flang/lib/Semantics/check-call.cpp

if (const auto *expr{arg.UnwrapExpr()}) {
     }
   } else {
     messages.Say(
         "Assumed-type argument may not be forwarded as procedure %s"_err_en_US,
         dummyName);
   }
 }
 
+// Allow BOZ literal actual arguments when they can be converted to a known
+// dummy argument type
+static void ConvertBOZLiteralArg(
+    evaluate::ActualArgument &arg, const evaluate::DynamicType &type) {
+  if (auto *expr{arg.UnwrapExpr()}) {
+    if (IsBOZLiteral(*expr)) {
+      if (auto converted{evaluate::ConvertToType(type, SomeExpr{*expr})}) {
+        arg = std::move(*converted);
+      }
+    }
+  }
+}
+
 static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
     const characteristics::DummyArgument &dummy,
     const characteristics::Procedure &proc, evaluate::FoldingContext &context,
     const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
     bool allowIntegerConversions) {
   auto &messages{context.messages()};
   std::string dummyName{"dummy argument"};
   if (!dummy.name.empty()) {
     dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
   }
   std::visit(
       common::visitors{
           [&](const characteristics::DummyDataObject &object) {
+            ConvertBOZLiteralArg(arg, object.type.type());
             if (auto *expr{arg.UnwrapExpr()}) {
               if (auto type{characteristics::TypeAndShape::Characterize(
                       *expr, context)}) {
                 arg.set_dummyIntent(object.intent);
                 bool isElemental{object.type.Rank() == 0 && proc.IsElemental()};
                 CheckExplicitDataArg(object, dummyName, *expr, *type,
                     isElemental, context, scope, intrinsic,
                     allowIntegerConversions);
return !CheckExplicitInterface(
               .AnyFatalError();
 }
 
 void CheckArguments(const characteristics::Procedure &proc,
     evaluate::ActualArguments &actuals, evaluate::FoldingContext &context,
     const Scope &scope, bool treatingExternalAsImplicit,
     const evaluate::SpecificIntrinsic *intrinsic) {
   bool explicitInterface{proc.HasExplicitInterface()};
+  parser::ContextualMessages &messages{context.messages()};
+  if (!explicitInterface || treatingExternalAsImplicit) {
+    parser::Messages buffer;
+    {
+      auto restorer{messages.SetMessages(buffer)};
+      for (auto &actual : actuals) {
+        if (actual) {
+          CheckImplicitInterfaceArg(*actual, messages);
+        }
+      }
+    }
+    if (!buffer.empty()) {
+      if (auto *msgs{messages.messages()}) {
+        msgs->Annex(std::move(buffer));
+      }
+      return; // don't pile on
+    }
+  }
   if (explicitInterface) {
     auto buffer{
         CheckExplicitInterface(proc, actuals, context, scope, intrinsic)};
     if (treatingExternalAsImplicit && !buffer.empty()) {
-      if (auto *msg{context.messages().Say(
+      if (auto *msg{messages.Say(
               "Warning: if the procedure's interface were explicit, this reference would be in error:"_en_US)}) {
         buffer.AttachTo(*msg);
       }
     }
-    if (auto *msgs{context.messages().messages()}) {
-      msgs->Merge(std::move(buffer));
-    }
-  }
-  if (!explicitInterface || treatingExternalAsImplicit) {
-    for (auto &actual : actuals) {
-      if (actual) {
-        CheckImplicitInterfaceArg(*actual, context.messages());
-      }
+    if (auto *msgs{messages.messages()}) {
+      msgs->Annex(std::move(buffer));
     }
   }
 }
 } // namespace Fortran::semantics

flang/test/Semantics/boz-literal-constants.f90

 ! RUN: %python %S/test_errors.py %s %flang_fc1
 ! Confirm enforcement of constraints and restrictions in 7.7
 ! C7107, C7108, C7109
 
 subroutine bozchecks
   ! Type declaration statements
   integer :: f, realpart = B"0101", img = B"1111", resint
   logical :: resbit
   complex :: rescmplx
   real :: dbl, e
+  interface
+    subroutine explicit(n, x, c)
+      integer :: n
+      real :: x
+      character :: c
+    end subroutine
+  end interface
   ! C7107
   !ERROR: Invalid digit ('a') in BOZ literal 'b"110a"'
   integer, parameter :: a = B"110A"
   !ERROR: Invalid digit ('2') in BOZ literal 'b"1232"'
   integer, parameter :: b = B"1232"
   !ERROR: BOZ literal 'b"010101010101010101010101011111111111111111111111111111111111111111111111111111111111111111111111111111111111000000000000000000000000000000000000"' too large
   integer, parameter :: b1 = B"010101010101010101010101011111111111111111111&
                               &111111111111111111111111111111111111111111111&
subroutine bozchecks
   res = MERGE_BITS(13,3,11)
   res = MERGE_BITS(B"1101",3,11)
   !ERROR: Typeless (BOZ) not allowed for both 'i=' & 'j=' arguments
   res = MERGE_BITS(B"1101",B"0011",11)
   !ERROR: Typeless (BOZ) not allowed for both 'i=' & 'j=' arguments
   res = MERGE_BITS(B"1101",B"0011",B"1011")
   res = MERGE_BITS(B"1101",3,B"1011")
 
+  !ERROR: Typeless (BOZ) not allowed for 'x=' argument
+  res = KIND(z'feedface')
+
   res = REAL(B"1101")
 
+  !Ok
+  call explicit(z'deadbeef', o'666', 'a')
+
+  !ERROR: Actual argument 'z'55'' associated with dummy argument 'c=' is not a variable or typed expression
+  call explicit(z'deadbeef', o'666', b'01010101')
+
   !ERROR: BOZ argument requires an explicit interface
   call implictSub(Z'12345')
 
   !ERROR: Output item must not be a BOZ literal constant
   print "(Z18)", Z"76543210"
 end subroutine