[flang] Handle instantiation of procedure pointer components
We were not instantiating procedure pointer components. If the instantiation
contained errors, we were not reporting them. This resulted in internal errors
in later processing.
I fixed this by adding code in .../lib/Semantics/type.cpp in
InstantiateComponent() to handle a component with ProcEntityDetails. I also
added several tests for various good and bad instantiations of procedure
pointer components.
Differential Revision: https://reviews.llvm.org/D100341
GitOrigin-RevId: bef63dc88a0a8e9294519140279de941996c96c8
diff --git a/lib/Semantics/type.cpp b/lib/Semantics/type.cpp
index 40b434b..99c48b3 100644
--- a/lib/Semantics/type.cpp
+++ b/lib/Semantics/type.cpp
@@ -369,6 +369,15 @@
: evaluate::NonPointerInitializationExpr(
newSymbol, std::move(*init), foldingContext());
}
+ } else if (auto *procDetails{newSymbol.detailsIf<ProcEntityDetails>()}) {
+ // We have a procedure pointer. Instantiate its return type
+ if (const DeclTypeSpec * returnType{InstantiateType(newSymbol)}) {
+ ProcInterface &interface{procDetails->interface()};
+ if (!interface.symbol()) {
+ // Don't change the type for interfaces based on symbols
+ interface.set_type(*returnType);
+ }
+ }
}
}
diff --git a/test/Semantics/resolve105.f90 b/test/Semantics/resolve105.f90
new file mode 100644
index 0000000..53ce999
--- /dev/null
+++ b/test/Semantics/resolve105.f90
@@ -0,0 +1,82 @@
+! RUN: %S/test_errors.sh %s %t %f18
+! Test instantiation of components that are procedure pointers.
+!
+program test
+ type dtype(kindParam)
+ integer, kind :: kindParam = 4
+ !ERROR: KIND parameter value (66) of intrinsic type REAL did not resolve to a supported value
+ !ERROR: KIND parameter value (55) of intrinsic type REAL did not resolve to a supported value
+ procedure (real(kindParam)), pointer, nopass :: field => null()
+ end type
+
+ type base(kindParam)
+ integer, kind :: kindParam = 4
+ !ERROR: KIND parameter value (77) of intrinsic type REAL did not resolve to a supported value
+ procedure (real(kindParam)), pointer, nopass :: field => null()
+ end type
+ type dependentType(kindParam)
+ integer, kind :: kindParam = 4
+ procedure (type(base(kindParam))), pointer, nopass :: field => null()
+ end type
+
+ ! OK unless entities are declared with the default type
+ type badDefaultType(kindParam)
+ integer, kind :: kindParam = 99
+ !ERROR: KIND parameter value (99) of intrinsic type REAL did not resolve to a supported value
+ !ERROR: KIND parameter value (44) of intrinsic type REAL did not resolve to a supported value
+ procedure (real(kindParam)), pointer, nopass :: field => null()
+ end type
+
+ type parent(kindParam)
+ integer, kind :: kindParam = 4
+ !ERROR: KIND parameter value (33) of intrinsic type REAL did not resolve to a supported value
+ !ERROR: KIND parameter value (88) of intrinsic type REAL did not resolve to a supported value
+ procedure (real(kindParam)), pointer, nopass :: parentField => null()
+ end type
+ type, extends(parent) :: child
+ integer :: field
+ end type child
+contains
+ subroutine testGoodDefault(arg)
+ type(dtype) :: arg
+ if (associated(arg%field)) stop 'fail'
+ end subroutine testGoodDefault
+
+ subroutine testStar(arg)
+ type(dtype(*)),intent(inout) :: arg
+ if (associated(arg%field)) stop 'fail'
+ end subroutine testStar
+
+ subroutine testBadDeclaration(arg)
+ type(dtype(66)) :: arg
+ if (associated(arg%field)) stop 'fail'
+ end subroutine testBadDeclaration
+
+ subroutine testBadLocalDeclaration()
+ type(dtype(55)) :: local
+ if (associated(local%field)) stop 'fail'
+ end subroutine testBadLocalDeclaration
+
+ subroutine testDependent()
+ type(dependentType(77)) :: local
+ end subroutine testDependent
+
+ subroutine testBadDefault()
+ type(badDefaultType) :: local
+ end subroutine testBadDefault
+
+ subroutine testBadDefaultWithBadDeclaration()
+ type(badDefaultType(44)) :: local
+ end subroutine testBadDefaultWithBadDeclaration
+
+ subroutine testBadDefaultWithGoodDeclaration()
+ type(badDefaultType(4)) :: local
+ end subroutine testBadDefaultWithGoodDeclaration
+
+ subroutine testExtended()
+ type(child(33)) :: local1
+ type(child(4)) :: local2
+ type(parent(88)) :: local3
+ type(parent(8)) :: local4
+ end subroutine testExtended
+end program test
