[flang] Fix semantic analysis for PDT component init

[peixin]

Summary

The PDT component init should be folded during semantic analysis when
the component init has constant kind/lan and does not have derived type
parameter in shape and constant expression.

[klausler]

flang/lib/Evaluate/tools.cpp

1564

return evaluate::IsActuallyConstant(type->numericTypeSpec().kind());

1575

IsConstantExpr will return true for a type parameter (see 10.1.12 (10)) whether it is constant or not. Use IsActuallyConstant() instead, as suggested above.

flang/lib/Semantics/resolve-names.cpp

6693

This doesn't make sense to me. Even if the kind and length of the component are constant, the default initialization of the component may still depend on type parameters.

flang/test/Semantics/init01.f90

64

This error message is now wrong.

[peixin]

Address all the comments.

[peixin]

@klausler Is there any possibility that these init can be folded elsewhere to skip these complicated checks?

flang/lib/Evaluate/tools.cpp

1564

Thanks. Fixed.

1575

Got it. Thanks.

[jeanPerier]

What is the motivation of this folding: is it required for semantics check, or does it lead to better code ?

flang/lib/Semantics/resolve-names.cpp

6695

Going through a string version of the expression is a bit unusual... Maybe you could achieve something similar by collecting the symbols in the init expressions (CollectSymbols) and checking if any of the symbols have the TypeParamDetails.

[peixin]

In D126473#3577760, @jeanPerier wrote:

What is the motivation of this folding: is it required for semantics check, or does it lead to better code ?

It will result in fatal internal error when collecting host association variables if not folded. Here is the example:

program m
  integer :: i
  call sub()
contains
  subroutine sub()
    type my_type (k, l)
      integer, KIND :: k = 4
      integer, LEN :: l = 2
      integer :: x = 10
      real :: y = 20
    end type
  end
end

$ flang-new test.f90 

fatal internal error: node has not been analyzed:
Expr -> LiteralConstant -> IntLiteralConstant = '10'

flang/lib/Semantics/resolve-names.cpp

6695

Going through a string version of the expression is a bit unusual...

Agree. This is only the initial try and it definitely needs better solution. I will take a deeper dive for PDT init semantic analysis and also try as you suggested later.

[jeanPerier]

It will result in fatal internal error when collecting host association variables if not folded. Here is the example: ....

Ah, thanks. In that case, the issue is with the lowering code, it should not unconditionally expect an expression when visiting the parse tree symbols. Your fix is workaring around the issue for the cases where the init expressions does not depends on the kind parameters, but the crash will still occur for types like:

subroutine sub()
  type my_type (k)
    integer, KIND :: k
    integer :: x = k
  end type
end

I do not think anything really need to fold the init expression of un-instantiated PDTs. The lowering visit that is looking for symbols in internal procedure should just ignore if the expression is not analyzed.
I went ahead a pushed a lowering fix for review: https://reviews.llvm.org/D127735

[peixin]

In D126473#3581232, @jeanPerier wrote:

It will result in fatal internal error when collecting host association variables if not folded. Here is the example: ....

Ah, thanks. In that case, the issue is with the lowering code, it should not unconditionally expect an expression when visiting the parse tree symbols. Your fix is workaring around the issue for the cases where the init expressions does not depends on the kind parameters, but the crash will still occur for types like:

subroutine sub()
  type my_type (k)
    integer, KIND :: k
    integer :: x = k
  end type
end

I do not think anything really need to fold the init expression of un-instantiated PDTs. The lowering visit that is looking for symbols in internal procedure should just ignore if the expression is not analyzed.
I went ahead a pushed a lowering fix for review: https://reviews.llvm.org/D127735

Got it. Thanks for the fix.

flang/include/flang/Evaluate/tools.h

 const Symbol &GetUsedModule(const UseDetails &);
 const Symbol *FindFunctionResult(const Symbol &);
 
 // Type compatibility predicate: are x and y effectively the same type?
 // Uses DynamicType::IsTkCompatible(), which handles the case of distinct
 // but identical derived types.
 bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
 
+bool HasConstantKindAndLen(const Symbol &);
+
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/lib/Evaluate/tools.cpp

if (auto xDt{evaluate::DynamicType::From(*x)}) {
       if (auto yDt{evaluate::DynamicType::From(*y)}) {
         return xDt->IsTkCompatibleWith(*yDt);
       }
     }
   }
   return false;
 }
 
+bool HasConstantKindAndLen(const Symbol &sym) {
+  if (const DeclTypeSpec * type{sym.GetType()}) {
+    if (type->category() == DeclTypeSpec::Numeric) {
+      return evaluate::IsActuallyConstant(type->numericTypeSpec().kind());
+    } else if (type->category() == DeclTypeSpec::Logical) {
+      return evaluate::IsActuallyConstant(type->logicalTypeSpec().kind());
+    } else if (type->category() == DeclTypeSpec::Character) {
+      if (evaluate::IsActuallyConstant(type->characterTypeSpec().kind())) {
+        if (const auto &length{
+                type->characterTypeSpec().length().GetExplicit()}) {
+          return evaluate::IsActuallyConstant(*length);
+        }
+      }
+    }
+  }
+  return false;
+}
+
 } // namespace Fortran::semantics

flang/lib/Semantics/resolve-names.cpp

if (name.symbol) {
     Symbol &ultimate{name.symbol->GetUltimate()};
     if (!context().HasError(ultimate) && !context().HasError(name.symbol)) {
       if (IsPointer(ultimate)) {
         Say(name,
             "'%s' is a pointer but is not initialized like one"_err_en_US);
       } else if (auto *details{ultimate.detailsIf<ObjectEntityDetails>()}) {
         CHECK(!details->init());
         Walk(expr);
-        if (ultimate.owner().IsParameterizedDerivedType()) {
+        bool hasTypeParamInInit{false};
+        if (const Symbol * owner{ultimate.owner().symbol()}) {
+          if (const auto *dtDetails{owner->detailsIf<DerivedTypeDetails>()}) {
+            for (std::size_t i{0}; i < dtDetails->paramDecls().size(); ++i) {
+              std::string exprStr = expr.thing.value().source.ToString();
+              std::string paramStr =
+                  dtDetails->paramDecls()[i].get().name().ToString();
+              // Check if the constant expression has type parameters. Be aware
+              // of the kind/len intrinsics such as the expression of
+              // "int(kind(0), kind(kind))", in which only the last "kind" is
+              // the type parameter.
+              if (exprStr.size() < paramStr.size()) {
+                continue;
+              }
+              for (std::size_t j{0}; j <= exprStr.size() - paramStr.size();
+                   j = j + paramStr.size()) {
+                if (exprStr.find(paramStr, j) != std::string::npos &&
+                    (exprStr.find(paramStr, j) + paramStr.size() >=
+                            exprStr.size() ||
+                        exprStr.at(exprStr.find(paramStr, j) +
+                            paramStr.size()) != '(')) {
+                  hasTypeParamInInit = true;
+                  break;
+                }
+              }
+              // Check if the shape has the type parameters. The constant
+              // expression such as "kind(kind)" has been folded before.
+              for (const auto &elem : details->shape()) {
+                if (elem.lbound().isExplicit()) {
+                  if (paramStr.compare(
+                          (*elem.lbound().GetExplicit()).AsFortran()) == 0) {
+                    hasTypeParamInInit = true;
+                    break;
+                  }
+                }
+                if (elem.ubound().isExplicit()) {
+                  if (paramStr.compare(
+                          (*elem.ubound().GetExplicit()).AsFortran()) == 0) {
+                    hasTypeParamInInit = true;
+                    break;
+                  }
+                }
+              }
+              if (hasTypeParamInInit) {
+                break;
+              }
+            }
+          }
+        }
+        if (ultimate.owner().IsParameterizedDerivedType() &&
+            (!semantics::HasConstantKindAndLen(*name.symbol) ||
+                hasTypeParamInInit)) {
           // Save the expression for per-instantiation analysis.
           details->set_unanalyzedPDTComponentInit(&expr.thing.value());
         } else {
           if (MaybeExpr folded{EvaluateNonPointerInitializer(
                   ultimate, expr, expr.thing.value().source)}) {
             details->set_init(std::move(*folded));
           }
         }

flang/test/Semantics/init01.f90

subroutine components(n)
   type :: t1
 !ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
     real :: x1(2) = [1., 2., 3.]
   end type
   type :: t2(kind, len)
     integer, kind :: kind
     integer, len :: len
 !ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
-!ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
     real :: x1(2) = [1., 2., 3.]
 !ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
     real :: x2(kind) = [1., 2., 3.]
 !ERROR: Dimension 1 of initialized object has extent 2, but initialization expression has extent 3
 !ERROR: Shape of initialized object 'x3' must be constant
     real :: x3(len) = [1., 2., 3.]
     real, pointer :: p1(:) => a1
 !ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
 !ERROR: An initial data target may not be a reference to an object 'a2' that lacks the SAVE attribute
     real, pointer :: p2 => a2

flang/test/Semantics/init02.f90

+! RUN: %flang_fc1 -fdebug-dump-parse-tree %s 2>&1 | FileCheck %s --check-prefix=SEMA_ON
+! RUN: %flang_fc1 -fdebug-dump-parse-tree-no-sema %s 2>&1 | FileCheck %s --check-prefix=SEMA_OFF
+
+!-----------------
+! EXPECTEED OUTPUT
+!-----------------
+
+!SEMA_ON:      Name = 'a0'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr -> Designator -> DataRef -> Name = 'kind'
+!SEMA_ON:      Name = 'a1'
+!SEMA_ON-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_ON-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr = '2_4'
+!SEMA_ON-NEXT: | | LiteralConstant -> IntLiteralConstant = '2'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr -> FunctionReference -> Call
+!SEMA_ON-NEXT: | ProcedureDesignator -> Name = 'int'
+!SEMA_ON-NEXT: | ActualArgSpec
+!SEMA_ON-NEXT: | | ActualArg -> Expr -> FunctionReference -> Call
+!SEMA_ON-NEXT: | | | ProcedureDesignator -> Name = 'kind'
+!SEMA_ON-NEXT: | | | ActualArgSpec
+!SEMA_ON-NEXT: | | | | ActualArg -> Expr -> LiteralConstant -> IntLiteralConstant = '0'
+!SEMA_ON-NEXT: | ActualArgSpec
+!SEMA_ON-NEXT: | | ActualArg -> Expr -> FunctionReference -> Call
+!SEMA_ON-NEXT: | | | ProcedureDesignator -> Name = 'kind'
+!SEMA_ON-NEXT: | | | ActualArgSpec
+!SEMA_ON-NEXT: | | | | ActualArg -> Expr -> Designator -> DataRef -> Name = 'kind'
+!SEMA_ON:      Name = 'a2'
+!SEMA_ON-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_ON-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr = 'int(kind,kind=4)'
+!SEMA_ON-NEXT: | | Designator -> DataRef -> Name = 'kind'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr -> ArrayConstructor -> AcSpec
+!SEMA_ON-NEXT: | AcValue -> Expr -> LiteralConstant -> IntLiteralConstant = '1'
+!SEMA_ON-NEXT: | AcValue -> Expr -> LiteralConstant -> IntLiteralConstant = '2'
+!SEMA_ON:      Name = 'a3'
+!SEMA_ON-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_ON-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr = 'int(kind,kind=4)'
+!SEMA_ON-NEXT: | | Designator -> DataRef -> Name = 'kind'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr -> Designator -> DataRef -> Name = 'l'
+!SEMA_ON:      Name = 'a4'
+!SEMA_ON-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_ON-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr = '4_4'
+!SEMA_ON-NEXT: | | FunctionReference -> Call
+!SEMA_ON-NEXT: | | | ProcedureDesignator -> Name = 'kind'
+!SEMA_ON-NEXT: | | | ActualArgSpec
+!SEMA_ON-NEXT: | | | | ActualArg -> Expr = 'int(kind,kind=4)'
+!SEMA_ON-NEXT: | | | | | Designator -> DataRef -> Name = 'kind'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr = '2_4'
+!SEMA_ON-NEXT: | LiteralConstant -> IntLiteralConstant = '2'
+!SEMA_ON:      Name = 'x'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr = '10_4'
+!SEMA_ON-NEXT: | LiteralConstant -> IntLiteralConstant = '10'
+!SEMA_ON:      Name = 'll'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr = '.true._4'
+!SEMA_ON-NEXT: | LiteralConstant -> LogicalLiteralConstant
+!SEMA_ON-NEXT: | | bool
+!SEMA_ON:      Name = 'r'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr = '1._4'
+!SEMA_ON-NEXT: | LiteralConstant -> RealLiteralConstant
+!SEMA_ON-NEXT: | | Real = '1.0'
+!SEMA_ON:      Name = 'c'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr = '(2._4,1._4)'
+!SEMA_ON-NEXT: | LiteralConstant -> ComplexLiteralConstant
+!SEMA_ON-NEXT: | | ComplexPart -> SignedRealLiteralConstant
+!SEMA_ON-NEXT: | | | RealLiteralConstant
+!SEMA_ON-NEXT: | | | | Real = '2.0'
+!SEMA_ON-NEXT: | | ComplexPart -> SignedRealLiteralConstant
+!SEMA_ON-NEXT: | | | RealLiteralConstant
+!SEMA_ON-NEXT: | | | | Real = '1.0'
+!SEMA_ON:      Name = 's'
+!SEMA_ON-NEXT: Initialization -> Constant -> Expr = '"s"'
+!SEMA_ON-NEXT: | LiteralConstant -> CharLiteralConstant
+!SEMA_ON-NEXT: | | string = 's'
+
+!SEMA_OFF:      Name = 'a0'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> Designator -> DataRef -> Name = 'kind'
+!SEMA_OFF:      Name = 'a1'
+!SEMA_OFF-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_OFF-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr -> LiteralConstant -> IntLiteralConstant = '2'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> FunctionReference -> Call
+!SEMA_OFF-NEXT: | ProcedureDesignator -> Name = 'int'
+!SEMA_OFF-NEXT: | ActualArgSpec
+!SEMA_OFF-NEXT: | | ActualArg -> Expr -> FunctionReference -> Call
+!SEMA_OFF-NEXT: | | | ProcedureDesignator -> Name = 'kind'
+!SEMA_OFF-NEXT: | | | ActualArgSpec
+!SEMA_OFF-NEXT: | | | | ActualArg -> Expr -> LiteralConstant -> IntLiteralConstant = '0'
+!SEMA_OFF-NEXT: | ActualArgSpec
+!SEMA_OFF-NEXT: | | ActualArg -> Expr -> FunctionReference -> Call
+!SEMA_OFF-NEXT: | | | ProcedureDesignator -> Name = 'kind'
+!SEMA_OFF-NEXT: | | | ActualArgSpec
+!SEMA_OFF-NEXT: | | | | ActualArg -> Expr -> Designator -> DataRef -> Name = 'kind'
+!SEMA_OFF:      Name = 'a2'
+!SEMA_OFF-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_OFF-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr -> Designator -> DataRef -> Name = 'kind'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> ArrayConstructor -> AcSpec
+!SEMA_OFF-NEXT: | AcValue -> Expr -> LiteralConstant -> IntLiteralConstant = '1'
+!SEMA_OFF-NEXT: | AcValue -> Expr -> LiteralConstant -> IntLiteralConstant = '2'
+!SEMA_OFF:      Name = 'a3'
+!SEMA_OFF-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_OFF-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr -> Designator -> DataRef -> Name = 'kind'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> Designator -> DataRef -> Name = 'l'
+!SEMA_OFF:      Name = 'a4'
+!SEMA_OFF-NEXT: ComponentArraySpec -> ExplicitShapeSpec
+!SEMA_OFF-NEXT: | SpecificationExpr -> Scalar -> Integer -> Expr -> FunctionReference -> Call
+!SEMA_OFF-NEXT: | | ProcedureDesignator -> Name = 'kind'
+!SEMA_OFF-NEXT: | | ActualArgSpec
+!SEMA_OFF-NEXT: | | | ActualArg -> Expr -> Designator -> DataRef -> Name = 'kind'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> LiteralConstant -> IntLiteralConstant = '2'
+!SEMA_OFF:      Name = 'x'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> LiteralConstant -> IntLiteralConstant = '10'
+!SEMA_OFF:      Name = 'll'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> LiteralConstant -> LogicalLiteralConstant
+!SEMA_OFF-NEXT: | bool
+!SEMA_OFF:      Name = 'r'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> LiteralConstant -> RealLiteralConstant
+!SEMA_OFF-NEXT: | Real = '1.0'
+!SEMA_OFF:      Name = 'c'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> LiteralConstant -> ComplexLiteralConstant
+!SEMA_OFF-NEXT: | ComplexPart -> SignedRealLiteralConstant
+!SEMA_OFF-NEXT: | | RealLiteralConstant
+!SEMA_OFF-NEXT: | | | Real = '2.0'
+!SEMA_OFF-NEXT: | ComplexPart -> SignedRealLiteralConstant
+!SEMA_OFF-NEXT: | | RealLiteralConstant
+!SEMA_OFF-NEXT: | | | Real = '1.0'
+!SEMA_OFF:      Name = 's'
+!SEMA_OFF-NEXT: Initialization -> Constant -> Expr -> LiteralConstant -> CharLiteralConstant
+!SEMA_OFF-NEXT: | string = 's'
+
+subroutine sub()
+  type my_type (kind, l)
+    integer, KIND :: kind = 4
+    integer, LEN :: l = 4
+    integer :: a0 = kind
+    integer :: a1(2) = int(kind(0), kind(kind))
+    integer :: a2(kind) = [1, 2]
+    integer :: a3(kind) = l
+    integer :: a4(kind(kind)) = 2
+    integer :: x = 10
+    logical :: ll = .true.
+    real :: r = 1.0
+    complex :: c = (2.0, 1.0)
+    character :: s = "s"
+  end type
+end