Fix for regression introduced by PR #1036 (issue #1137).

yaoliu-hnc · bryanpkc · commit ac600218a7d1 · 2021-10-08T14:19:25.000+08:00
When the entry returns adjustable length character without POINTER attribute,
   the field NEWARG of the return variable is not set which causes that
   the return variable in dummy arguments is not replaced,
   and the field CVLEN of the return variable also needs to be replaced.
diff --git a/test/f90_correct/inc/en05.mk b/test/f90_correct/inc/en05.mk
@@ -0,0 +1,22 @@
+#
+# 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
+#
+
+$(TEST): run
+
+
+build:  $(SRC)/$(TEST).f90
+	-$(RM) $(TEST).$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.*
+	@echo ------------------------------------ building test $@
+	-$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX)
+	-$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX)
+
+
+run:
+	@echo ------------------------------------ executing test $(TEST)
+	$(TEST).$(EXESUFFIX)
+
+verify: ;
+
diff --git a/test/f90_correct/lit/en05.sh b/test/f90_correct/lit/en05.sh
@@ -0,0 +1,9 @@
+#
+# 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
+
+# Shared lit script for each tests. Run bash commands that run tests with make.
+
+# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t
+# RUN: cat %t | FileCheck %S/runmake
diff --git a/test/f90_correct/src/en04.f90 b/test/f90_correct/src/en04.f90
@@ -37,6 +37,21 @@ function f5 ()
   e5 = (/1,2,3,4,5/)
 end function
 
+function f6 (n)
+  integer :: n
+  character(n) :: f6, e6
+entry e6 (n)
+  e6 = "hello1"
+end function
+
+function f7 (n)
+  integer :: n
+  character(n), pointer :: f7, e7
+entry e7 (n)
+  allocate(e7)
+  e7 = "hello2"
+end function
+
 program test
   interface
     function f1 ()
@@ -69,10 +84,27 @@ function f5 ()
     function e5 ()
       integer, dimension(:), pointer :: e5
     end function
+    function f6 (n)
+      integer :: n
+      character(n) :: f6
+    end function
+    function e6 (n)
+      integer :: n
+      character(n) :: e6
+    end function
+    function f7 (n)
+      integer :: n
+      character(n), pointer :: f7
+    end function
+    function e7 (n)
+      integer :: n
+      character(n), pointer :: e7
+    end function
   end interface
 
-  integer, parameter :: n = 10
+  integer, parameter :: n = 14
   integer :: rslts(n), expect(n)
+  character(6), pointer :: p
 
   rslts = 0
   expect = 1
@@ -86,6 +118,18 @@ function e5 ()
   if (all(e4() == (/1,2,3,4/))) rslts(8) = 1
   if (all(f5() == (/1,2,3,4,5/))) rslts(9) = 1
   if (all(e5() == (/1,2,3,4,5/))) rslts(10) = 1
+  if (len(f6(6)) == 6 .and. f6(6) == "hello1") rslts(11) = 1
+  if (len(e6(6)) == 6 .and. e6(6) == "hello1") rslts(12) = 1
+  p => f7(6)
+  if (associated(p)) then
+    if (len(p) == 6 .and. p == "hello2") rslts(13) = 1
+    deallocate(p)
+  endif
+  p => e7(6)
+  if (associated(p)) then
+    if (len(p) == 6 .and. p == "hello2") rslts(14) = 1
+    deallocate(p)
+  endif
 
   call check(rslts, expect, n)
 end program
diff --git a/test/f90_correct/src/en05.f90 b/test/f90_correct/src/en05.f90
@@ -0,0 +1,84 @@
+!
+! 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
+!
+! Test the fix for introduced error, in which the entry returns adjustable
+! length character.
+
+function f1(n)
+  integer :: n
+  character(n) :: f1, e1
+  f1 = "AB"
+  return
+entry e1(n)
+  e1 = "XYZ"
+end function
+
+function f2(n)
+  integer :: n
+  character(n), pointer :: f2, e2
+  allocate(f2)
+  f2 = "AB"
+  return
+entry e2(n)
+  allocate(e2)
+  e2 = "XYZ"
+end function
+
+function f3(n)
+  integer :: n
+  character(n), dimension(2, 2) :: f3, e3
+  f3 = "AB"
+  return
+entry e3(n)
+  e3 = "XYZ"
+end function
+
+program p
+  interface
+    function f1(n)
+      integer :: n
+      character(n) :: f1
+    end function
+    function e1(n)
+      integer :: n
+      character(n) :: e1
+    end function
+    function f2(n)
+      integer :: n
+      character(n), pointer :: f2
+    end function
+    function e2(n)
+      integer :: n
+      character(n), pointer :: e2
+    end function
+    function f3(n)
+      integer :: n
+      character(n), dimension(2, 2) :: f3
+    end function
+    function e3(n)
+      integer :: n
+      character(n), dimension(2, 2) :: e3
+    end function
+  end interface
+  character(:), pointer :: cp
+
+  if (len(f1(2)) /= 2 .or. f1(2) /= "AB") STOP 1
+  if (len(e1(3)) /= 3 .or. e1(6) /= "XYZ") STOP 2
+
+  cp => f2(2)
+  if (.not. associated(cp)) STOP 3
+  if (len(cp) /= 2 .or. cp /= "AB") STOP 4
+  deallocate(cp)
+
+  cp => e2(3)
+  if (.not. associated(cp)) STOP 5
+  if (len(cp) /= 3 .or. cp /= "XYZ") STOP 6
+  deallocate(cp)
+
+  if (len(f3(2)) /= 2 .or. any(f3(2) /= "AB")) STOP 7
+  if (len(e3(3)) /= 3 .or. any(e3(3) /= "XYZ")) STOP 8
+
+  print *, "PASS"
+end program
diff --git a/tools/flang1/flang1exe/lowersym.c b/tools/flang1/flang1exe/lowersym.c
@@ -1239,21 +1239,32 @@ replace_fval_in_params(SPTR entry, SPTR entrysame)
   SPTR fval, fvalsame, newdsc, newdscsame, newarg, newargsame;
   int params, narg, i;
 
+  narg = PARAMCTG(entry);
+  if (narg == 0)
+    return;
+  params = DPDSCG(entry);
   fval = FVALG(entry);
   fvalsame = FVALG(entrysame);
   newdsc = NEWDSCG(fval);
   newarg = NEWARGG(fval);
+  /* If the return variable is an adjustable length character without POINTER
+   * attribute, its NEWARG keeps SPTR_NULL(see init_newargs in bblock.c), and
+   * itself will be put into dummy parameters(see newargs_for_entry in
+   * dpm_out.c), so we match and replace the return variable directly.
+   */
+  if (newarg == SPTR_NULL)
+    newarg = fval;
   newdscsame = NEWDSCG(fvalsame);
   newargsame = NEWARGG(fvalsame);
-  params = DPDSCG(entry);
-  narg = PARAMCTG(entry);
+  if (newargsame == SPTR_NULL)
+    newargsame = fvalsame;
   for (i = 0; i < narg; i++) {
     int arg = aux.dpdsc_base[params + i];
-    if (arg != 0 && arg == newarg) {
+    if (arg != SPTR_NULL && arg == newarg) {
       aux.dpdsc_base[params + i] = newargsame;
       continue;
     }
-    if (arg != 0 && arg == newdsc) {
+    if (arg != SPTR_NULL && arg == newdsc) {
       aux.dpdsc_base[params + i] = newdscsame;
       continue;
     }
@@ -1318,6 +1329,11 @@ replace_fval_in_ast(SPTR fval, SPTR fvalsame)
   var_same = SDSCG(fvalsame);
   add_replace_map(var, var_same);
   replace_sptr_in_ast(var);
+
+  var = CVLENG(fval);
+  var_same = CVLENG(fvalsame);
+  add_replace_map(var, var_same);
+  replace_sptr_in_ast(var);
 }
 
 extern int pghpf_type_sptr;
