[flang-commits] [flang] 5296292 - [flang] Fix checks for USE-associated UDDTIO & their character argument kinds

[Peter Klausler via flang-commits]

Author: Peter Klausler
Date: 2023-04-01T14:13:11-07:00
New Revision: 529629271736806f3ccda3ab086946bb6b963af1

URL: https://github.com/llvm/llvm-project/commit/529629271736806f3ccda3ab086946bb6b963af1
DIFF: https://github.com/llvm/llvm-project/commit/529629271736806f3ccda3ab086946bb6b963af1.diff

LOG: [flang] Fix checks for USE-associated UDDTIO & their character argument kinds

Call GetUltimate() before checking a user-defined derived type I/O specific
procedure so that the checks work on a USE-associated procedure.  And
require their character arguments to have the default CHARACTER kind.

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

Added: 
    

Modified: 
    flang/lib/Semantics/check-declarations.cpp
    flang/test/Semantics/io11.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index 5bd794f104d37..8091c1daddfaf 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -2624,10 +2624,18 @@ void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
   // Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg)
   if (CheckDioDummyIsData(subp, arg, argPosition)) {
     CheckDioDummyAttrs(subp, *arg, intent);
-    if (!IsAssumedLengthCharacter(*arg)) {
+    const DeclTypeSpec *type{arg ? arg->GetType() : nullptr};
+    const IntrinsicTypeSpec *intrinsic{type ? type->AsIntrinsic() : nullptr};
+    const auto kind{
+        intrinsic ? evaluate::ToInt64(intrinsic->kind()) : std::nullopt};
+    if (!IsAssumedLengthCharacter(*arg) ||
+        (!kind ||
+            *kind !=
+                context_.defaultKinds().GetDefaultKind(
+                    TypeCategory::Character))) {
       messages_.Say(arg->name(),
           "Dummy argument '%s' of a defined input/output procedure"
-          " must be assumed-length CHARACTER"_err_en_US,
+          " must be assumed-length CHARACTER of default kind"_err_en_US,
           arg->name());
     }
   }
@@ -2688,13 +2696,14 @@ void CheckHelper::CheckDioDummyAttrs(
 void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
     const GenericDetails &details, GenericKind::DefinedIo ioKind) {
   for (auto ref : details.specificProcs()) {
-    const auto *binding{ref->detailsIf<ProcBindingDetails>()};
-    const Symbol &specific{*(binding ? &binding->symbol() : &*ref)};
-    if (ref->attrs().test(Attr::NOPASS)) { // C774
+    const Symbol &ultimate{ref->GetUltimate()};
+    const auto *binding{ultimate.detailsIf<ProcBindingDetails>()};
+    const Symbol &specific{*(binding ? &binding->symbol() : &ultimate)};
+    if (ultimate.attrs().test(Attr::NOPASS)) { // C774
       messages_.Say("Defined input/output procedure '%s' may not have NOPASS "
                     "attribute"_err_en_US,
-          ref->name());
-      context_.SetError(*ref);
+          ultimate.name());
+      context_.SetError(ultimate);
     }
     if (const auto *subpDetails{specific.detailsIf<SubprogramDetails>()}) {
       const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()};

diff  --git a/flang/test/Semantics/io11.f90 b/flang/test/Semantics/io11.f90
index b5f26b606cddc..413283cdfc72b 100644
--- a/flang/test/Semantics/io11.f90
+++ b/flang/test/Semantics/io11.f90
@@ -331,12 +331,12 @@ module m15
   subroutine formattedReadProc(dtv, unit, iotype, vlist, iostat, iomsg)
     class(t), intent(inout) :: dtv
     integer, intent(in) :: unit
-    !ERROR: Dummy argument 'iotype' of a defined input/output procedure must be assumed-length CHARACTER
+    !ERROR: Dummy argument 'iotype' of a defined input/output procedure must be assumed-length CHARACTER of default kind
     character(len=5), intent(in) :: iotype ! Error, must be assumed length
     integer, intent(in) :: vlist(:)
     integer, intent(out) :: iostat
-    character(len=*), intent(inout) :: iomsg
-
+    !ERROR: Dummy argument 'iomsg' of a defined input/output procedure must be assumed-length CHARACTER of default kind
+    character(len=5), intent(inout) :: iomsg
     iostat = 343
     stop 'fail'
   end subroutine
@@ -667,3 +667,25 @@ subroutine unformattedReadProc2(dtv,unit,iostat,iomsg)
     read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%c
   end subroutine
 end subroutine
+
+module m26a
+  type t
+    integer n
+  end type
+ contains
+  subroutine unformattedRead(dtv,unit,iostat,iomsg)
+    class(t),intent(inout) :: dtv
+    integer,intent(in) :: unit
+    integer,intent(out) :: iostat
+    !ERROR: Dummy argument 'iomsg' of a defined input/output procedure must be assumed-length CHARACTER of default kind
+    character(kind=4,len=*),intent(inout) :: iomsg
+    !ERROR: Must have default kind(1) of CHARACTER type, but is CHARACTER(KIND=4,LEN=*)
+    read(unit,iotype,iostat=iostat,iomsg=iomsg) dtv%n
+  end subroutine
+end
+module m26b
+  use m26a
+  interface read(unformatted)
+    procedure unformattedRead
+  end interface
+end