[flang] Fix call to CHECK() on overriding an erroneous type-bound procedure

You can define a base type with a type-bound procedure which is erroneously
missing a NOPASS attribute and then define another type that extends the base
type and overrides the erroneous procedure.  In this case, when we perform
semantic checking on the overriding procedure, we verify the "pass index" of
the overriding procedure.  The attempt to get the procedure's pass index fails
a call to CHECK().

I fixed this by calling SetError() on the symbol of the overridden procedure in
the base type.  Then, I check HasError() before executing the code that invokes
the failing call to CHECK().  I also added a test that will cause the compiler
to fail the call to CHECK() without this change.

Differential Revision: https://reviews.llvm.org/D98355
This commit is contained in:
Peter Steinfeld 2021-03-10 08:09:57 -08:00
parent f47a84bc33
commit 40e261803b
2 changed files with 19 additions and 1 deletions

View File

@ -1356,6 +1356,7 @@ void CheckHelper::CheckPassArg(
: "Procedure binding '%s' with no dummy arguments"
" must have NOPASS attribute"_err_en_US,
name);
context_.SetError(*interface);
return;
}
passName = dummyArgs[0]->name();
@ -1480,7 +1481,7 @@ void CheckHelper::CheckProcBinding(
SayWithDeclaration(*overridden,
"A type-bound procedure and its override must have compatible interfaces"_err_en_US);
}
} else {
} else if (!context_.HasError(binding.symbol())) {
int passIndex{bindingChars->FindPassIndex(binding.passName())};
int overriddenPassIndex{
overriddenChars->FindPassIndex(overriddenBinding->passName())};

View File

@ -132,6 +132,23 @@ contains
end subroutine
end module m1
module t2
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
program test
use m1
type,extends(t) :: t2