[flang] Fix ICE for passing a label for non alternate return arguments

[unterumarmung]

Summary

When we pass an alternate return specifier to a regular (not an asterisk)
dummy argument, flang would throw an internal compiler error of
derefencing a null pointer.
To avoid the ICE, a check was added.

[awarzynski]

Thanks for posting this @unterumarmung! Makes sense to me, but I'd rather defer to somebody with more experience in this area. Let me add a couple more reviewers!

[kiranchandramohan]

Thanks @unterumarmung for this patch. I have a couple of minor comments.

I have two questions in general. I. can understand if you would like to skip these questions.
-> Are these issues from some internal testsuite?
-> Is this hobby work or official contribution?

flang/lib/Semantics/check-call.cpp

700–706

Isn't this error applicable to DummyProcedure too?

703

Nit: Should it be Alternate return label instead of label?

705

Nit: Sometimes we prefer not to use early returns. Please wait for another opinion.

[unterumarmung]

flang/lib/Semantics/check-call.cpp

700–706

I thought about it too! But there's already an error for this code:

fortran
module m
    contains
      subroutine s3(v)
        integer, intent(in) :: v
      end subroutine s3
      subroutine s(x)
        procedure(s3) :: x
      end
      subroutine s2
        call s(*42)
        42 stop
      end
  end module m

error: Semantic errors in a.f90
./a.f90:10:9: error: Assumed-type argument may not be forwarded as procedure dummy argument 'x='
          call s(*42)
          ^^^^^^^^^^^

Yet, the error message is not totally correct. Should I add the check to DummyProcedure also?

703

Nice suggestion, will fix

[unterumarmung]

Rebased, removed useless restorer, address review comment

[unterumarmung]

@kiranchandramohan, we've replied in Slack

[kiranchandramohan]

flang/lib/Semantics/check-call.cpp

700–706

Yes, i think it is useful here as well.

705

Can you remove the early return by using a nested if?

[unterumarmung]

Rebased, addressed review comments

[unterumarmung]

flang/lib/Semantics/check-call.cpp

700–706

Done

705

Fixed

[kiranchandramohan]

LGTM. Thanks for this patch. In case there are comments from other reviewers, please wait for a day before you submit.

flang/lib/Semantics/check-call.cpp

690

Nit: can't -> cannot

[unterumarmung]

Rebased, fixed the nit

flang/lib/Semantics/check-call.cpp

static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
     bool allowIntegerConversions) {
   auto &messages{context.messages()};
   std::string dummyName{"dummy argument"};
   if (!dummy.name.empty()) {
     dummyName += " '"s + parser::ToLowerCaseLetters(dummy.name) + "='";
   }
   auto restorer{
       messages.SetLocation(arg.sourceLocation().value_or(messages.at()))};
+  auto checkActualArgForLabel = [&](evaluate::ActualArgument &arg) {
+    if (arg.isAlternateReturn()) {
+      messages.Say(
+          "Alternate return label '%d' cannot be associated with %s"_err_en_US,
+          arg.GetLabel(), dummyName);
+      return true;
+    } else {
+      return false;
+    }
+  };
   common::visit(
       common::visitors{
           [&](const characteristics::DummyDataObject &object) {
+            if (!checkActualArgForLabel(arg)) {
               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()};
+                  bool isElemental{
+                      object.type.Rank() == 0 && proc.IsElemental()};
                   CheckExplicitDataArg(object, dummyName, *expr, *type,
                       isElemental, context, scope, intrinsic,
                       allowIntegerConversions);
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                     IsBOZLiteral(*expr)) {
                   // ok
                 } else if (object.type.type().IsTypelessIntrinsicArgument() &&
                     evaluate::IsNullPointer(*expr)) {
                   // ok, ASSOCIATED(NULL())
                 } else if ((object.attrs.test(characteristics::DummyDataObject::
                                     Attr::Pointer) ||
                                object.attrs.test(characteristics::
                                        DummyDataObject::Attr::Optional)) &&
                     evaluate::IsNullPointer(*expr)) {
                   // ok, FOO(NULL())
                 } else {
                   messages.Say(
                       "Actual argument '%s' associated with %s is not a variable or typed expression"_err_en_US,
                       expr->AsFortran(), dummyName);
                 }
               } else {
                 const Symbol &assumed{DEREF(arg.GetAssumedTypeDummy())};
                 if (!object.type.type().IsAssumedType()) {
                   messages.Say(
                       "Assumed-type '%s' may be associated only with an assumed-type %s"_err_en_US,
                       assumed.name(), dummyName);
                 } else if (object.type.attrs().test(evaluate::characteristics::
                                    TypeAndShape::Attr::AssumedRank) &&
                     !IsAssumedShape(assumed) &&
                     !evaluate::IsAssumedRank(assumed)) {
                   messages.Say( // C711
                       "Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US,
                       assumed.name(), dummyName);
                 }
               }
+            }
           },
           [&](const characteristics::DummyProcedure &dummy) {
+            if (!checkActualArgForLabel(arg)) {
               CheckProcedureArg(arg, proc, dummy, dummyName, context);
+            }
           },
           [&](const characteristics::AlternateReturn &) {
             // All semantic checking is done elsewhere
           },
       },
       dummy.u);
 }
 

flang/test/Semantics/call26.f90

+! RUN: %python %S/test_errors.py %s %flang_fc1
+module m
+  contains
+    subroutine simple_arg(x)
+      integer, intent(in) :: x
+    end subroutine simple_arg
+    subroutine procedure_arg(x)
+      procedure(simple_arg) :: x
+    end subroutine procedure_arg
+    subroutine s
+      !ERROR: Alternate return label '42' cannot be associated with dummy argument 'x='
+      call simple_arg(*42)
+      !ERROR: Alternate return label '42' cannot be associated with dummy argument 'x='
+      call procedure_arg(*42)
+      42 stop
+    end subroutine s
+end module m