[flang] Handle instantiation of procedure pointer components

[PeteSteinfeld]

Summary

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.

One of the tests caused a redundant context message to appear. I fixed this by
removing a call to set_instantiationContext() from
DerivedTypeSpec::Instantiate().

[klausler]

flang/lib/Semantics/type.cpp

299

Why is the scope's instantiation context no longer needing to be set? Are you somehow setting it elsewhere?

361

Are you sure that you're modifying a new ProcInterface created for this procedure pointer component's instantiation, or are you maybe modifying a ProcInterface shared by all instantiation?

[PeteSteinfeld]

flang/lib/Semantics/type.cpp

299

My mistake. I'll put this back.

361

When I look at the symbol table dump for a test program, I see an unmodified entry for the original derived type definition and modified entries for the instantiations. Correct me if I'm wrong, but that says that I'm not modifying the version that's shared by all instantiations. Note that the testExtended() subroutine in resolve105.f90 contains alternating good and band instantiations, and error messages are only produced by the bad instantiations.

Here's a fragment of a symbol table dump of a small test:

MainProgram scope: test size=0 alignment=1
  base: DerivedType components: field
  dependenttype: DerivedType components: dependentfield
  null, INTRINSIC, PURE (Function): ProcEntity
  testdependent (Subroutine): Subprogram ()
  DerivedType scope: base
    field, NOPASS, POINTER (Function): ProcEntity REAL(int(int(kindparam,kind=4),kind=8)) => NULL()
    kindparam: TypeParam type:INTEGER(4) Kind init:4_4
  DerivedType scope: dependenttype
    dependentfield, NOPASS, POINTER (Function): ProcEntity TYPE(base(kindparam=int(kindparam,kind=4))) => NULL()
    kindparam: TypeParam type:INTEGER(4) Kind init:4_4
  Subprogram scope: testdependent size=24 alignment=8
    local size=24 offset=0: ObjectEntity type: TYPE(dependenttype(kindparam=77_4))
    testdependent (Subroutine): HostAssoc
    DerivedType scope: size=24 alignment=8 instantiation of dependenttype(kindparam=77_4)
      dependentfield, NOPASS, POINTER (Function) size=24 offset=0: ProcEntity TYPE(base(kindparam=77_4))
      kindparam: TypeParam type:INTEGER(4) Kind init:77_4
      DerivedType scope: size=24 alignment=8 instantiation of base(kindparam=77_4)
        field, NOPASS, POINTER (Function) size=24 offset=0: ProcEntity REAL(4)
        kindparam: TypeParam type:INTEGER(4) Kind init:77_4

[PeteSteinfeld]

Responding to Peter's feedback by restoring the call to set_instantitationContext().

flang/lib/Semantics/type.cpp

void DerivedTypeSpec::Instantiate(
   parser::Message *contextMessage{nullptr};
   if (sep != '(') {
     desc += ')';
     contextMessage = new parser::Message{foldingContext.messages().at(),
         "instantiation of parameterized derived type '%s'"_en_US, desc};
     if (auto outer{containingScope.instantiationContext()}) {
       contextMessage->SetContext(outer.get());
     }
-    newScope.set_instantiationContext(contextMessage);
   }
   // Instantiate every non-parameter symbol from the original derived
   // type's scope into the new instance.
   newScope.AddSourceRange(typeScope.sourceRange());
   auto restorer2{foldingContext.messages().SetContext(contextMessage)};
   InstantiateHelper{context, newScope}.InstantiateComponents(typeScope);
 }
 
if (MaybeExpr & init{details->init()}) {
       // processed now so that those default initializers can be used
       // in PARAMETER structure constructors.
       auto restorer{foldingContext().messages().SetLocation(newSymbol.name())};
       init = IsPointer(newSymbol)
           ? evaluate::Fold(foldingContext(), std::move(*init))
           : 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);
+      }
+    }
   }
 }
 
 const DeclTypeSpec *InstantiateHelper::InstantiateType(const Symbol &symbol) {
   const DeclTypeSpec *type{symbol.GetType()};
   if (!type) {
     return nullptr; // error has occurred
   } else if (const DerivedTypeSpec * spec{type->AsDerived()}) {

flang/test/Semantics/resolve105.f90

+! 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