[flang] Lower TYPE(*) as fir.box<none>

This patch lowers `TYPE(*)` correctly to fir.box<none>.

Reviewed By: jeanPerier

Differential Revision: https://reviews.llvm.org/D135141

6 files changed, 34 insertions, 12 deletions

diff --git a/flang/docs/PolymorphicEntities.md b/flang/docs/PolymorphicEntities.md
index 362b899..8993112 100644
--- a/flang/docs/PolymorphicEntities.md
+++ b/flang/docs/PolymorphicEntities.md
@@ -104,8 +104,13 @@ func.func @bar(%x : !fir.class<none>)
 Assumed type is added in Fortran 2018 and it is available only for dummy
 arguments. It's mainly used for interfaces to non-Fortran code and is similar
 to C's `void`.
+An entity that is declared using the `TYPE(*)` type specifier is assumed-type
+and is an unlimited polymorphic entity. It is not declared to have a type, and
+is not considered to have the same declared type as any other entity,
+including another unlimited polymorphic entity. Its dynamic type and type
+parameters are assumed from its effective argument (7.3.2.2 - 3).
 
-Assumed-type is represented as `!fir.type<*>`.
+Assumed-type is represented in FIR as `!fir.box<none>`.
 
 ### SELECT TYPE construct
 
diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h
index 482fec5..5246071 100644
--- a/flang/include/flang/Optimizer/Dialect/FIRType.h
+++ b/flang/include/flang/Optimizer/Dialect/FIRType.h
@@ -307,10 +307,19 @@ inline bool BaseBoxType::classof(mlir::Type type) {
   return type.isa<fir::BoxType, fir::ClassType>();
 }
 
-/// Return a fir.box<T> or fir.class<T> if the type is polymorphic.
+/// Return true iff `ty` is none or fir.array<none>.
+inline bool isNoneOrSeqNone(mlir::Type type) {
+  if (auto seqTy = type.dyn_cast<fir::SequenceType>())
+    return seqTy.getEleTy().isa<mlir::NoneType>();
+  return type.isa<mlir::NoneType>();
+}
+
+/// Return a fir.box<T> or fir.class<T> if the type is polymorphic. If the type
+/// is polymorphic and assumed shape return fir.box<T>.
 inline mlir::Type wrapInClassOrBoxType(mlir::Type eleTy,
-                                       bool isPolymorphic = false) {
-  if (isPolymorphic)
+                                       bool isPolymorphic = false,
+                                       bool isAssumedType = false) {
+  if (isPolymorphic && !isAssumedType)
     return fir::ClassType::get(eleTy);
   return fir::BoxType::get(eleTy);
 }
diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h
index 3f30cab..c497966 100644
--- a/flang/include/flang/Semantics/tools.h
+++ b/flang/include/flang/Semantics/tools.h
@@ -183,6 +183,7 @@ std::optional<parser::Message> WhyNotModifiable(SourceName, const SomeExpr &,
     const Scope &, bool vectorSubscriptIsOk = false);
 const Symbol *IsExternalInPureContext(const Symbol &, const Scope &);
 bool HasCoarray(const parser::Expr &);
+bool IsAssumedType(const Symbol &);
 bool IsPolymorphic(const Symbol &);
 bool IsPolymorphicAllocatable(const Symbol &);
 // Return an error if component symbol is not accessible from scope (7.5.4.8(2))
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 583a519..510cb60 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -859,8 +859,8 @@ private:
       type = fir::HeapType::get(type);
     if (obj.attrs.test(Attrs::Pointer))
       type = fir::PointerType::get(type);
-    mlir::Type boxType =
-        fir::wrapInClassOrBoxType(type, obj.type.type().IsPolymorphic());
+    mlir::Type boxType = fir::wrapInClassOrBoxType(
+        type, obj.type.type().IsPolymorphic(), obj.type.type().IsAssumedType());
 
     if (obj.attrs.test(Attrs::Allocatable) || obj.attrs.test(Attrs::Pointer)) {
       // Pass as fir.ref<fir.box> or fir.ref<fir.class>
@@ -957,14 +957,16 @@ private:
     const auto *resTypeAndShape{result.GetTypeAndShape()};
     bool resIsPolymorphic =
         resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
+    bool resIsAssumedType =
+        resTypeAndShape && resTypeAndShape->type().IsAssumedType();
     if (!bounds.empty())
       mlirType = fir::SequenceType::get(bounds, mlirType);
     if (result.attrs.test(Attr::Allocatable))
       mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),
-                                           resIsPolymorphic);
+                                           resIsPolymorphic, resIsAssumedType);
     if (result.attrs.test(Attr::Pointer))
       mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
-                                           resIsPolymorphic);
+                                           resIsPolymorphic, resIsAssumedType);
 
     if (fir::isa_char(mlirType)) {
       // Character scalar results must be passed as arguments in lowering so
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index f575480..4b57f14 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -1059,6 +1059,13 @@ bool HasCoarray(const parser::Expr &expression) {
   return false;
 }
 
+bool IsAssumedType(const Symbol &symbol) {
+  if (const DeclTypeSpec * type{symbol.GetType()}) {
+    return type->IsAssumedType();
+  }
+  return false;
+}
+
 bool IsPolymorphic(const Symbol &symbol) {
   if (const DeclTypeSpec * type{symbol.GetType()}) {
     return type->IsPolymorphic();
diff --git a/flang/test/Lower/polymorphic-types.f90 b/flang/test/Lower/polymorphic-types.f90
index 17008d1..49175ec 100644
--- a/flang/test/Lower/polymorphic-types.f90
+++ b/flang/test/Lower/polymorphic-types.f90
@@ -158,19 +158,17 @@ contains
 ! Test assumed type argument types
 ! ------------------------------------------------------------------------------
 
-  ! Follow up patch will add a `fir.assumed_type` attribute to the types in the
-  ! two tests below.
   subroutine assumed_type_dummy(a) bind(c)
     type(*) :: a
   end subroutine assumed_type_dummy
 
   ! CHECK-LABEL: func.func @assumed_type_dummy(
-  ! CHECK-SAME: %{{.*}}: !fir.class<none>
+  ! CHECK-SAME: %{{.*}}: !fir.box<none>
 
   subroutine assumed_type_dummy_array(a) bind(c)
     type(*) :: a(:)
   end subroutine assumed_type_dummy_array
 
   ! CHECK-LABEL: func.func @assumed_type_dummy_array(
-  ! CHECK-SAME: %{{.*}}: !fir.class<!fir.array<?xnone>>
+  ! CHECK-SAME: %{{.*}}: !fir.box<!fir.array<?xnone>>
 end module