[flang] Fix checking of argument passing for parameterized derived types

[PeteSteinfeld]

Summary

We were erroneously not taking into account the constant values of LEN type
parameters of parameterized derived types when checking for argument
compatibility. The required checks are identical to those for assignment
compatibility. Since argument compatibility is checked in .../lib/Evaluate and
assignment compatibility is checked in .../lib/Semantics, I moved the common
code into .../lib/Evaluate/tools.cpp and changed the assignment compatibility
checking code to call it.

After implementing these new checks, tests in resolve53.f90 were failing
because the tests were erroneous. I fixed these tests and added new tests
to call03.f90 to test argument passing of parameterized derived types more
completely.

[klausler]

flang/lib/Evaluate/tools.cpp

1181

I'm not sure that this is behaviorally identical with AreKindCompatible(), which only compares KIND type parameters and ignores LEN type parameters.

1185

You don't need to check that the expressions are "constant expressions" in the Fortran standard's sense if you're going to be extracting their actual integer constant values later with ToInt64(). I know that you didn't write this (at least not for this patch), but while you're moving this code we might as well simplify it.

const auto param2{type2.FindParameter(name)};
return !param2 || ToInt64(param1.GetExplicit()) == ToInt64(param2->GetExplicit();

The "evaluate::" namespace name isn't needed now that this code is in that namespace.

[PeteSteinfeld]

flang/lib/Evaluate/tools.cpp

1181

It's not identical in that it checks both KIND and LEN type parameters. My reading of the standard is that for objects of a parameterized derived type to be compatible, either in assignment statements or in argument passing, the constant values of the type parameters have to be equal. That's true for both KIND and LEN type parameters. For KIND parameters, the constant value is available at compile time. In this case, the checking for the expressions being compile time constants is unnecessary, but it doesn't do any harm. For LEN parameters, it's possible for the parameter to not have a constant expression available at compile time. In this case, checking must be deferred to run time, and we shouldn't emit error messages at compile time.

There was only one call to AreKindCompatible(), which I replaced, so I deleted that function.

1185

Thanks for the suggestion. The code is much cleaner with these changes.

[PeteSteinfeld]

flang/lib/Evaluate/tools.cpp

1185

Actually, except for the elimination of evaluate:: these changes don't work. We only want to do the comparison if we are able to get expressions for both of the parameters, and we only want to do the comparison when both of the parameters are constants. Also, we need to loop through all of the parameters unless we hit one where they are not equal.

flang/include/flang/Evaluate/tools.h

 // (E.g., for ASSOCIATE(x => y%z), ResolveAssociations(x) returns x,
 // while GetAssociationRoot(x) returns y.)
 const Symbol &ResolveAssociations(const Symbol &);
 const Symbol &GetAssociationRoot(const Symbol &);
 
 const Symbol *FindCommonBlockContaining(const Symbol &);
 int CountLenParameters(const DerivedTypeSpec &);
 int CountNonConstantLenParameters(const DerivedTypeSpec &);
+
+// 15.5.2.4(4), type compatibility for dummy and actual arguments.
+// Also used for assignment compatibility checking
+bool AreTypeParamCompatible(
+    const semantics::DerivedTypeSpec &, const semantics::DerivedTypeSpec &);
+
 const Symbol &GetUsedModule(const UseDetails &);
 const Symbol *FindFunctionResult(const Symbol &);
 
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/lib/Evaluate/tools.cpp

return std::count_if(
         } else if (const auto &expr{pair.second.GetExplicit()}) {
           return !IsConstantExpr(*expr);
         } else {
           return true;
         }
       });
 }
 
+// Are the type parameters of type1 compile-time compatible with the
+// corresponding kind type parameters of type2?  Return true if all constant
+// valued parameters are equal.
+// Used to check assignment statements and argument passing.  See 15.5.2.4(4)
+bool AreTypeParamCompatible(const semantics::DerivedTypeSpec &type1,
+    const semantics::DerivedTypeSpec &type2) {
+  for (const auto &[name, param1] : type1.parameters()) {
+    if (semantics::MaybeIntExpr paramExpr1{param1.GetExplicit()}) {
+      if (IsConstantExpr(*paramExpr1)) {
+        const semantics::ParamValue *param2{type2.FindParameter(name)};
+        if (param2) {
+          if (semantics::MaybeIntExpr paramExpr2{param2->GetExplicit()}) {
+            if (IsConstantExpr(*paramExpr2)) {
+              if (ToInt64(*paramExpr1) != ToInt64(*paramExpr2)) {
+                return false;
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+  return true;
+}
+
 const Symbol &GetUsedModule(const UseDetails &details) {
   return DEREF(details.symbol().owner().symbol());
 }
 
 static const Symbol *FindFunctionResult(
     const Symbol &original, UnorderedSymbolSet &seen) {
   const Symbol &root{GetAssociationRoot(original)};
   ;

flang/lib/Evaluate/type.cpp

if (AreSameDerivedType(*x, *y, inProgress)) {
       return true;
     } else {
       return isPolymorphic &&
           AreCompatibleDerivedTypes(x, GetParentTypeSpec(*y), true);
     }
   }
 }
 
-// Do the kind type parameters of type1 have the same values as the
-// corresponding kind type parameters of type2?
-static bool AreKindCompatible(const semantics::DerivedTypeSpec &type1,
-    const semantics::DerivedTypeSpec &type2) {
-  for (const auto &[name, param1] : type1.parameters()) {
-    if (param1.isKind()) {
-      const semantics::ParamValue *param2{type2.FindParameter(name)};
-      if (!PointeeComparison(&param1, param2)) {
-        return false;
-      }
-    }
-  }
-  return true;
-}
-
 // See 7.3.2.3 (5) & 15.5.2.4
 bool DynamicType::IsTkCompatibleWith(const DynamicType &that) const {
   if (IsUnlimitedPolymorphic()) {
     return true;
   } else if (that.IsUnlimitedPolymorphic()) {
     return false;
   } else if (category_ != that.category_) {
     return false;
   } else if (derived_) {
     return that.derived_ &&
         AreCompatibleDerivedTypes(derived_, that.derived_, IsPolymorphic()) &&
-        AreKindCompatible(*derived_, *that.derived_);
+        AreTypeParamCompatible(*derived_, *that.derived_);
   } else {
     return kind_ == that.kind_;
   }
 }
 
 std::optional<DynamicType> DynamicType::From(
     const semantics::DeclTypeSpec &type) {
   if (const auto *intrinsic{type.AsIntrinsic()}) {

flang/lib/Semantics/type.cpp

 //===-- lib/Semantics/type.cpp --------------------------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #include "flang/Semantics/type.h"
 #include "check-declarations.h"
 #include "compute-offsets.h"
 #include "flang/Evaluate/fold.h"
+#include "flang/Evaluate/tools.h"
 #include "flang/Parser/characters.h"
 #include "flang/Semantics/scope.h"
 #include "flang/Semantics/symbol.h"
 #include "flang/Semantics/tools.h"
 #include "llvm/Support/raw_ostream.h"
 
 namespace Fortran::semantics {
 

 // Objects of derived types might be assignment compatible if they are equal
 // with respect to everything other than their instantiated type parameters
 // and their constant instantiated type parameters have the same values.
 bool DerivedTypeSpec::MightBeAssignmentCompatibleWith(
     const DerivedTypeSpec &that) const {
   if (!RawEquals(that)) {
     return false;
   }
-  const std::map<SourceName, ParamValue> &theseParams{this->parameters()};
-  const std::map<SourceName, ParamValue> &thoseParams{that.parameters()};
-  auto thatIter{thoseParams.begin()};
-  for (const auto &[thisName, thisValue] : theseParams) {
-    CHECK(thatIter != thoseParams.end());
-    const ParamValue &thatValue{thatIter->second};
-    if (MaybeIntExpr thisExpr{thisValue.GetExplicit()}) {
-      if (evaluate::IsConstantExpr(*thisExpr)) {
-        if (MaybeIntExpr thatExpr{thatValue.GetExplicit()}) {
-          if (evaluate::IsConstantExpr(*thatExpr)) {
-            if (evaluate::ToInt64(*thisExpr) != evaluate::ToInt64(*thatExpr)) {
-              return false;
-            }
-          }
-        }
-      }
-    }
-    thatIter++;
-  }
-  return true;
+  return AreTypeParamCompatible(*this, that);
 }
 
 class InstantiateHelper {
 public:
   InstantiateHelper(Scope &scope) : scope_{scope} {}
   // Instantiate components from fromScope into scope_
   void InstantiateComponents(const Scope &);
 

flang/test/Semantics/call03.f90

 ! RUN: %S/test_errors.sh %s %t %flang_fc1
 ! Test 15.5.2.4 constraints and restrictions for non-POINTER non-ALLOCATABLE
 ! dummy arguments.
 
 module m01
   type :: t
   end type
   type :: pdt(n)
     integer, len :: n
   end type
+  type :: pdtWithDefault(n)
+    integer, len :: n = 3
+  end type
   type :: tbp
    contains
     procedure :: binding => subr01
   end type
   type :: final
    contains
     final :: subr02
   end type
subroutine test05 ! 15.5.2.4(2)
     type(final) :: x
     !ERROR: Actual argument associated with TYPE(*) dummy argument 'x=' may not have derived type 'final' with FINAL subroutine 'subr02'
     call typestar(x)
   end subroutine
 
   subroutine ch2(x)
     character(2), intent(in out) :: x
   end subroutine
+  subroutine pdtdefault (derivedArg)
+    !ERROR: Type parameter 'n' lacks a value and has no default
+    type(pdt) :: derivedArg
+  end subroutine pdtdefault
+  subroutine pdt3 (derivedArg)
+    type(pdt(4)) :: derivedArg
+  end subroutine pdt3
+  subroutine pdt4 (derivedArg)
+    type(pdt(*)) :: derivedArg
+  end subroutine pdt4
+  subroutine pdtWithDefaultDefault (derivedArg)
+    type(pdtWithDefault) :: derivedArg
+  end subroutine pdtWithDefaultdefault
+  subroutine pdtWithDefault3 (derivedArg)
+    type(pdtWithDefault(4)) :: derivedArg
+  end subroutine pdtWithDefault3
+  subroutine pdtWithDefault4 (derivedArg)
+    type(pdtWithDefault(*)) :: derivedArg
+  end subroutine pdtWithDefault4
   subroutine test06 ! 15.5.2.4(4)
+    !ERROR: Type parameter 'n' lacks a value and has no default
+    type(pdt) :: vardefault
+    type(pdt(3)) :: var3
+    type(pdt(4)) :: var4
+    type(pdtWithDefault) :: defaultVardefault
+    type(pdtWithDefault(3)) :: defaultVar3
+    type(pdtWithDefault(4)) :: defaultVar4
     character :: ch1
     ! The actual argument is converted to a padded expression.
     !ERROR: Actual argument associated with INTENT(IN OUT) dummy argument 'x=' must be definable
     call ch2(ch1)
+    call pdtdefault(vardefault)
+    call pdtdefault(var3)
+    call pdtdefault(var4) ! error
+    call pdt3(vardefault) ! error
+    !ERROR: Actual argument type 'pdt(n=3_4)' is not compatible with dummy argument type 'pdt(n=4_4)'
+    call pdt3(var3) ! error
+    call pdt3(var4)
+    call pdt4(vardefault)
+    call pdt4(var3)
+    call pdt4(var4)
+    call pdtWithDefaultdefault(defaultVardefault)
+    call pdtWithDefaultdefault(defaultVar3)
+    !ERROR: Actual argument type 'pdtwithdefault(n=4_4)' is not compatible with dummy argument type 'pdtwithdefault(n=3_4)'
+    call pdtWithDefaultdefault(defaultVar4) ! error
+    !ERROR: Actual argument type 'pdtwithdefault(n=3_4)' is not compatible with dummy argument type 'pdtwithdefault(n=4_4)'
+    call pdtWithDefault3(defaultVardefault) ! error
+    !ERROR: Actual argument type 'pdtwithdefault(n=3_4)' is not compatible with dummy argument type 'pdtwithdefault(n=4_4)'
+    call pdtWithDefault3(defaultVar3) ! error
+    call pdtWithDefault3(defaultVar4)
+    call pdtWithDefault4(defaultVardefault)
+    call pdtWithDefault4(defaultVar3)
+    call pdtWithDefault4(defaultVar4)
   end subroutine
 
   subroutine out01(x)
     type(alloc) :: x
   end subroutine
   subroutine test07(x) ! 15.5.2.4(6)
     type(alloc) :: x[*]
     !ERROR: Coindexed actual argument with ALLOCATABLE ultimate component '%a' must be associated with a dummy argument 'x=' with VALUE or INTENT(IN) attributes

flang/test/Semantics/resolve53.f90

module m15
   !ERROR: Generic 'g9' may not have specific procedures 's7' and 's8' as their interfaces are not distinguishable
   interface g9
     procedure s7
     procedure s8
   end interface
 
 contains
   subroutine s1(x)
-    type(t1(1, 4)) :: x
+    type(t1(1, 5)) :: x
   end
   subroutine s2(x)
     type(t1(2, 4)) :: x
   end
   subroutine s3(x)
     type(t1(l1=5)) :: x
   end
   subroutine s4(x)
     type(t3(1, 101, 2, 102, 3, 103, 4)) :: x
   end subroutine
   subroutine s5(x)
     type(t3) :: x
   end subroutine
   subroutine s6(x)
-    type(t3(1, 99, k2b=2, k2a=3, l2=*, l3=97, k3=4)) :: x
+    type(t3(1, 99, k2b=2, k2a=3, l2=*, l3=103, k3=4)) :: x
   end subroutine
   subroutine s7(x)
     type(t3(k1=1, l1=99, k2a=3, k2b=2, k3=4)) :: x
   end subroutine
   subroutine s8(x)
     type(t3(1, :, 3, :, 2, :, 4)), allocatable :: x
   end subroutine
   subroutine s9(x)