[flang] Adjust %REF/%VAL semantic checking

flang/include/flang/Parser/parse-tree.h

@@ -3194,7 +3194,7 @@ WRAPPER_CLASS(AltReturnSpec, Label);
 //         expr | variable | procedure-name | proc-component-ref |
 //         alt-return-spec
 struct ActualArg {
-  WRAPPER_CLASS(PercentRef, Variable); // %REF(v) extension
+  WRAPPER_CLASS(PercentRef, Expr); // %REF(x) extension
   WRAPPER_CLASS(PercentVal, Expr); // %VAL(x) extension
   UNION_CLASS_BOILERPLATE(ActualArg);
   ActualArg(Expr &&x) : u{common::Indirection<Expr>(std::move(x))} {}

flang/lib/Parser/program-parsers.cpp

@@ -472,8 +472,8 @@ TYPE_PARSER(construct<ActualArg>(expr) ||
     construct<ActualArg>(Parser<AltReturnSpec>{}) ||
     extension<LanguageFeature::PercentRefAndVal>(
         "nonstandard usage: %REF"_port_en_US,
-        construct<ActualArg>(construct<ActualArg::PercentRef>(
-            "%REF" >> parenthesized(variable)))) ||
+        construct<ActualArg>(
+            construct<ActualArg::PercentRef>("%REF" >> parenthesized(expr)))) ||
     extension<LanguageFeature::PercentRefAndVal>(
         "nonstandard usage: %VAL"_port_en_US,
         construct<ActualArg>(

flang/lib/Semantics/check-call.cpp

@@ -35,7 +35,8 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
         "Keyword '%s=' may not appear in a reference to a procedure with an implicit interface"_err_en_US,
         *kw);
   }
-  if (auto type{arg.GetType()}) {
+  auto type{arg.GetType()};
+  if (type) {
     if (type->IsAssumedType()) {
       messages.Say(
           "Assumed type actual argument requires an explicit interface"_err_en_US);
@@ -49,6 +50,11 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
       }
     }
   }
+  if (arg.isPercentVal() &&
+      (!type || !type->IsLengthlessIntrinsicType() || arg.Rank() != 0)) {
+    messages.Say(
+        "%VAL argument must be a scalar numeric or logical expression"_err_en_US);
+  }
   if (const auto *expr{arg.UnwrapExpr()}) {
     if (IsBOZLiteral(*expr)) {
       messages.Say("BOZ argument requires an explicit interface"_err_en_US);
@@ -314,7 +320,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     SemanticsContext &context, evaluate::FoldingContext &foldingContext,
     const Scope *scope, const evaluate::SpecificIntrinsic *intrinsic,
     bool allowActualArgumentConversions, bool extentErrors,
-    const characteristics::Procedure &procedure) {
+    const characteristics::Procedure &procedure,
+    const evaluate::ActualArgument &arg) {
 
   // Basic type & rank checking
   parser::ContextualMessages &messages{foldingContext.messages()};
@@ -939,11 +946,25 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
     }
   }
 
-  // Breaking change warnings
+  // Warning for breaking F'2023 change with character allocatables
   if (intrinsic && dummy.intent != common::Intent::In) {
     WarnOnDeferredLengthCharacterScalar(
         context, &actual, messages.at(), dummyName.c_str());
   }
+
+  // %VAL() and %REF() checking for explicit interface
+  if ((arg.isPercentRef() || arg.isPercentVal()) &&
+      dummy.IsPassedByDescriptor(procedure.IsBindC())) {
+    messages.Say(
+        "%VAL or %REF are not allowed for %s that must be passed by means of a descriptor"_err_en_US,
+        dummyName);
+  }
+  if (arg.isPercentVal() &&
+      (!actualType.type().IsLengthlessIntrinsicType() ||
+          actualType.Rank() != 0)) {
+    messages.Say(
+        "%VAL argument must be a scalar numeric or logical expression"_err_en_US);
+  }
 }
 
 static void CheckProcedureArg(evaluate::ActualArgument &arg,
@@ -1152,7 +1173,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
                       object.type.Rank() == 0 && proc.IsElemental()};
                   CheckExplicitDataArg(object, dummyName, *expr, *type,
                       isElemental, context, foldingContext, scope, intrinsic,
-                      allowActualArgumentConversions, extentErrors, proc);
+                      allowActualArgumentConversions, extentErrors, proc, arg);
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                     IsBOZLiteral(*expr)) {
                   // ok

flang/lib/Semantics/expression.cpp

@@ -4187,13 +4187,13 @@ void ArgumentAnalyzer::Analyze(
           },
           [&](const parser::AltReturnSpec &label) {
             if (!isSubroutine) {
-              context_.Say("alternate return specification may not appear on"
-                           " function reference"_err_en_US);
+              context_.Say(
+                  "alternate return specification may not appear on function reference"_err_en_US);
             }
             actual = ActualArgument(label.v);
           },
           [&](const parser::ActualArg::PercentRef &percentRef) {
-            actual = AnalyzeVariable(percentRef.v);
+            actual = AnalyzeExpr(percentRef.v);
             if (actual.has_value()) {
               actual->set_isPercentRef();
             }
@@ -4202,12 +4202,6 @@ void ArgumentAnalyzer::Analyze(
             actual = AnalyzeExpr(percentVal.v);
             if (actual.has_value()) {
               actual->set_isPercentVal();
-              std::optional<DynamicType> type{actual->GetType()};
-              if (!type || !type->IsLengthlessIntrinsicType() ||
-                  actual->Rank() != 0) {
-                context_.SayAt(percentVal.v,
-                    "%VAL argument must be a scalar numerical or logical expression"_err_en_US);
-              }
             }
           },
       },

flang/test/Semantics/call40.f90

@@ -9,15 +9,22 @@ subroutine val_errors(array, string, polymorphic, derived)
   character(*) :: string
   type(t) :: derived
   type(*) :: polymorphic
-  !ERROR: %VAL argument must be a scalar numerical or logical expression
+  interface
+    subroutine foo5(a)
+      integer a(:)
+    end
+  end interface
+  !ERROR: %VAL argument must be a scalar numeric or logical expression
   call foo1(%val(array))
-  !ERROR: %VAL argument must be a scalar numerical or logical expression
+  !ERROR: %VAL argument must be a scalar numeric or logical expression
   call foo2(%val(string))
-  !ERROR: %VAL argument must be a scalar numerical or logical expression
+  !ERROR: %VAL argument must be a scalar numeric or logical expression
   call foo3(%val(derived))
-  !ERROR: %VAL argument must be a scalar numerical or logical expression
   !ERROR: Assumed type actual argument requires an explicit interface
+  !ERROR: %VAL argument must be a scalar numeric or logical expression
   call foo4(%val(polymorphic))
+  !ERROR: %VAL or %REF are not allowed for dummy argument 'a=' that must be passed by means of a descriptor
+  call foo5(%ref(array))
 end subroutine
 
 subroutine val_ok()