[flang] Handle type-bound procedures with alternate returns

[PeteSteinfeld]

Summary

If you specify a type-bound procedure with an alternate return, there
will be no symbol associated with that dummy argument. In such cases,
the compiler's list of dummy arguments will contain a nullptr. In our
analysis of the PASS arguments of type-bound procedures, we were
assuming that all dummy arguments had non-null symbols associated with
them and were using that assumption to get the name of the dummy
argument. This caused the compiler to try to dereference a nullptr.

I fixed this by explicitly checking for a nullptr and, in such cases, emitting
an error message. I also added tests that contain type-bound procedures with
alternate returns in both legal and illegal constructs to ensure that semantic
analysis is working for them.

[tskeith]

flang/lib/Semantics/check-declarations.cpp

1363–1370

It's a little more readable to follow the pattern of: if (error condition) { report error; return; }

[PeteSteinfeld]

flang/lib/Semantics/check-declarations.cpp

1363–1370

Thanks, Tim. I'll change it.

[klausler]

I verified that the default passed-object dummy argument is indeed the first dummy argument in F,2018, not the first named dummy argument (which would have made sense too).

flang/lib/Semantics/check-declarations.cpp

if (dummyArgs.empty()) {
               ? "Procedure component '%s' with no dummy arguments"
                 " must have NOPASS attribute"_err_en_US
               : "Procedure binding '%s' with no dummy arguments"
                 " must have NOPASS attribute"_err_en_US,
           name);
       context_.SetError(*interface);
       return;
     }
+    Symbol *argSym{dummyArgs[0]};
+    if (argSym) {
       passName = dummyArgs[0]->name();
+    } else {
+      messages_.Say(interface->name(),
+          "Cannot use an alternate return as the passed-object dummy "
+          "argument"_err_en_US);
+      return;
+    }
   }
   std::optional<int> passArgIndex{};
   for (std::size_t i{0}; i < dummyArgs.size(); ++i) {
     if (dummyArgs[i] && dummyArgs[i]->name() == *passName) {
       passArgIndex = i;
       break;
     }
   }

flang/test/Semantics/bindings01.f90

module m1
   end type t
 
 contains
   subroutine mp(x)
     class(t),intent(in) :: x
   end subroutine
 end module m1
 
-module t2
+module m2
   type parent
     real realField
   contains
     !ERROR: Procedure binding 'proc' with no dummy arguments must have NOPASS attribute
     procedure proc
   end type parent
   type,extends(parent) :: child
   contains
     !ERROR: Procedure binding 'proc' with no dummy arguments must have NOPASS attribute
     procedure proc
   end type child
 contains
   subroutine proc 
   end subroutine
-end module t2
+end module m2
+
+module m3
+  type t
+  contains
+    procedure b
+  end type
+contains
+  !ERROR: Cannot use an alternate return as the passed-object dummy argument
+  subroutine b(*)
+    return 1
+  end subroutine
+end module m3
+
+module m4
+  type t
+  contains
+    procedure b
+  end type
+contains
+  ! Check to see that alternate returns work with default PASS arguments
+  subroutine b(this, *)
+    class(t) :: this
+    return 1
+  end subroutine
+end module m4
+
+module m5
+  type t
+  contains
+    !ERROR: Passed-object dummy argument 'passarg' of procedure 'b' must be of type 't' but is 'INTEGER(4)'
+    procedure, pass(passArg) ::  b
+  end type
+contains
+  subroutine b(*, passArg)
+    integer :: passArg
+    return 1
+  end subroutine
+end module m5
+
+module m6
+  type t
+  contains
+    !ERROR: Passed-object dummy argument 'passarg' of procedure 'b' must be polymorphic because 't' is extensible
+    procedure, pass(passArg) ::  b
+  end type
+contains
+  subroutine b(*, passArg)
+    type(t) :: passArg
+    return 1
+  end subroutine
+end module m6
+
+module m7
+  type t
+  contains
+  ! Check to see that alternate returns work with PASS arguments
+    procedure, pass(passArg) ::  b
+  end type
+contains
+  subroutine b(*, passArg)
+    class(t) :: passArg
+    return 1
+  end subroutine
+end module m7
 
 program test
   use m1
   type,extends(t) :: t2
   end type
   type(t2) a
   call a%tbp
 end program