Fix error of processing entry statement.

test/f90_correct/inc/en03.mk

@@ -0,0 +1,28 @@
+#
+# 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
+#
+
+########## Make rule for test en03  ########
+
+
+en03: run
+
+
+build:  $(SRC)/en03.f90
+	-$(RM) en03.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.*
+	@echo ------------------------------------ building test $@
+	-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX)
+	-$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/en03.f90 -o en03.$(OBJX)
+	-$(FC) $(FFLAGS) $(LDFLAGS) en03.$(OBJX) check.$(OBJX) $(LIBS) -o en03.$(EXESUFFIX)
+
+
+run:
+	@echo ------------------------------------ executing test en03
+	en03.$(EXESUFFIX)
+
+verify: ;
+
+en03.run: run
+

test/f90_correct/inc/en04.mk

@@ -0,0 +1,23 @@
+#
+# 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 $@
+	-$(CC) -c $(CFLAGS) $(SRC)/check.c -o check.$(OBJX)
+	-$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/$(TEST).f90 -o $(TEST).$(OBJX)
+	-$(FC) $(FFLAGS) $(LDFLAGS) $(TEST).$(OBJX) check.$(OBJX) $(LIBS) -o $(TEST).$(EXESUFFIX)
+
+
+run:
+	@echo ------------------------------------ executing test $(TEST)
+	$(TEST).$(EXESUFFIX)
+
+verify: ;
+

test/f90_correct/lit/en03.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

test/f90_correct/lit/en04.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

test/f90_correct/src/en03.f90

@@ -0,0 +1,59 @@
+!
+! 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 entry for cases:
+! 1) Function return complex, entry return integer
+! 2) All entries return pointer
+
+function f1()
+  complex :: f1
+  integer :: e1
+  f1 = (1, 1)
+  return
+entry e1()
+  e1 = 2
+  return
+end function
+
+function f2()
+  integer, pointer :: f2, e2
+  allocate(f2)
+  f2 = 3
+  return
+entry e2()
+  allocate(e2)
+  e2 = 4
+  return
+end function
+
+program test
+  interface
+    function f1()
+      complex :: f1
+    end function
+    function e1()
+      integer :: e1
+    end function
+    function f2()
+      integer, pointer :: f2
+    end function
+    function e2()
+      integer, pointer :: e2
+    end function
+  end interface
+
+  integer, parameter :: n = 4
+  integer :: rslts(n), expect(n)
+
+  rslts = 0
+  expect = 1
+
+  if(f1() .eq. (1, 1)) rslts(1) = 1
+  if(e1() .eq. 2) rslts(2) = 1
+  if(f2() .eq. 3) rslts(3) = 1
+  if(e2() .eq. 4) rslts(4) = 1
+
+  call check(rslts, expect, n)
+end program

test/f90_correct/src/en04.f90

@@ -0,0 +1,91 @@
+!
+! 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 for all ENTRY points with the same return type identify the same variable
+
+function f1 ()
+  integer :: f1, e1
+entry e1 ()
+  e1 = 1
+end function
+
+function f2 ()
+  complex :: f2, e2
+entry e2 ()
+  e2 = (2, 2)
+end function
+
+function f3 ()
+  integer, pointer :: f3, e3
+entry e3 ()
+  allocate(e3)
+  e3 = 3
+end function
+
+function f4 ()
+  integer, dimension(4) :: f4, e4
+entry e4 ()
+  e4 = (/1,2,3,4/)
+end function
+
+function f5 ()
+  integer, dimension(:), pointer :: f5, e5
+entry e5 ()
+  allocate(e5(5))
+  e5 = (/1,2,3,4,5/)
+end function
+
+program test
+  interface
+    function f1 ()
+      integer :: f1
+    end function
+    function e1 ()
+      integer :: e1
+    end function
+    function f2 ()
+      complex :: f2
+    end function
+    function e2 ()
+      complex :: e2
+    end function
+    function f3 ()
+      integer, pointer :: f3
+    end function
+    function e3 ()
+      integer, pointer :: e3
+    end function
+    function f4 ()
+      integer, dimension(4) :: f4
+    end function
+    function e4 ()
+      integer, dimension(4) :: e4
+    end function
+    function f5 ()
+      integer, dimension(:), pointer :: f5
+    end function
+    function e5 ()
+      integer, dimension(:), pointer :: e5
+    end function
+  end interface
+
+  integer, parameter :: n = 10
+  integer :: rslts(n), expect(n)
+
+  rslts = 0
+  expect = 1
+  if (f1() == 1) rslts(1) = 1
+  if (e1() == 1) rslts(2) = 1
+  if (f2() == (2, 2)) rslts(3) = 1
+  if (e2() == (2, 2)) rslts(4) = 1
+  if (f3() == 3) rslts(5) = 1
+  if (e3() == 3) rslts(6) = 1
+  if (all(f4() == (/1,2,3,4/))) rslts(7) = 1
+  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
+
+  call check(rslts, expect, n)
+end program

tools/flang1/flang1exe/lowersym.c

@@ -1221,13 +1221,110 @@ lower_pointer_init(void)
   }
 } /* lower_pointer_init */
 
+/* When prepend_func_result_as_first_arg(semfin.c) has been called for an
+ * entry, the FVAL symbol and its descriptor symbol if exist are referred in
+ * the entry's dummy arguments.
+ * When we are going to identify all result variables of same dtype from
+ * different entry points with a single symbol, here we traverse all the dummy
+ * arguments, and replace the FVAL symbol and its descriptor symbol with this
+ * single symbol and corresponding descriptor symbol.
+ */
+static void
+replace_fval_in_params(SPTR entry, SPTR entrysame)
+{
+  SPTR fval, fvalsame, newdsc, newdscsame, newarg, newargsame;
+  int params, narg, i;
+
+  fval = FVALG(entry);
+  fvalsame = FVALG(entrysame);
+  newdsc = NEWDSCG(fval);
+  newarg = NEWARGG(fval);
+  newdscsame = NEWDSCG(fvalsame);
+  newargsame = NEWARGG(fvalsame);
+  params = DPDSCG(entry);
+  narg = PARAMCTG(entry);
+  for (i = 0; i < narg; i++) {
+    int arg = aux.dpdsc_base[params + i];
+    if (arg != 0 && arg == newarg) {
+      aux.dpdsc_base[params + i] = newargsame;
+      continue;
+    }
+    if (arg != 0 && arg == newdsc) {
+      aux.dpdsc_base[params + i] = newdscsame;
+      continue;
+    }
+  }
+}
+
+/* replace the symbol used in the ast of type A_ID taking advantage of the hash
+ * in the AST table
+ */
+static void
+replace_sptr_in_ast(SPTR sptr)
+{
+  SPTR newsptr;
+  int ast;
+
+  if (sptr <= NOSYM) {
+    return;
+  }
+  newsptr = LOWER_SYMBOL_REPLACE(sptr);
+  if (newsptr <= NOSYM) {
+    return;
+  }
+  ast = mk_id(sptr);
+  A_SPTRP(ast, newsptr);
+}
+
+static inline void
+add_replace_map(SPTR sptr, SPTR newsptr)
+{
+  if (sptr <= NOSYM || newsptr <= NOSYM) {
+    return;
+  }
+  LOWER_SYMBOL_REPLACE(sptr) = newsptr;
+}
+
+/* replace the fval symbol and associated symbols when the fval symbol is
+ * pointer or array
+ */
+static void
+replace_fval_in_ast(SPTR fval, SPTR fvalsame)
+{
+  SPTR var, var_same;
+
+  replace_sptr_in_ast(fval);
+
+  var = MIDNUMG(fval);
+  var_same = MIDNUMG(fvalsame);
+  add_replace_map(var, var_same);
+  replace_sptr_in_ast(var);
+
+  var = PTROFFG(fval);
+  var_same = PTROFFG(fvalsame);
+  add_replace_map(var, var_same);
+  replace_sptr_in_ast(var);
+
+  var = DESCRG(fval);
+  var_same = DESCRG(fvalsame);
+  add_replace_map(var, var_same);
+  replace_sptr_in_ast(var);
+
+  var = SDSCG(fval);
+  var_same = SDSCG(fvalsame);
+  add_replace_map(var, var_same);
+  replace_sptr_in_ast(var);
+}
+
 extern int pghpf_type_sptr;
 extern int pghpf_local_mode_sptr;
 
 void
 lower_init_sym(void)
 {
   int sym, dtype;
+  LOGICAL from_func;
+
   lowersym.sc = SC_LOCAL;
   lowersym.parallel_depth = 0;
   lowersym.task_depth = 0;
@@ -1353,21 +1450,24 @@ lower_init_sym(void)
   stack_size = 100;
   NEW(stack, int, stack_size);
 
+  from_func = gbl.rutype == RU_SUBR && gbl.entries > NOSYM && FVALG(gbl.entries);
   /* look for ENTRY points; make all ENTRY points with the same
    * return type use the same FVAL symbol */
-  if (gbl.rutype == RU_FUNC) {
+  if (from_func || gbl.rutype == RU_FUNC) {
     int ent, esame;
     for (ent = gbl.entries; ent > NOSYM; ent = SYMLKG(ent)) {
       for (esame = gbl.entries; esame != ent; esame = SYMLKG(esame)) {
         int fval, fvalsame;
         fval = FVALG(ent);
         fvalsame = FVALG(esame);
         if (fval && fvalsame && fval != fvalsame &&
-            DTYPEG(fval) == DTYPEG(fvalsame)) {
+            same_dtype(DTYPEG(fval), DTYPEG(fvalsame))) {
           /* esame is the earlier entry point, make ent use the
            * FVAL of esame */
           LOWER_SYMBOL_REPLACE(fval) = fvalsame;
+          replace_fval_in_params(ent, esame);
           FVALP(ent, fvalsame);
+          replace_fval_in_ast(fval, fvalsame);
           break; /* leave inner loop */
         }
       }

tools/flang1/flang1exe/semfin.c

@@ -467,10 +467,13 @@ semfin(void)
             error(45, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries));
         pointer_check:
           STYPEP(FVALG(sptr), ST_VAR);
-          if (POINTERG(sptr) || ALLOCATTRG(FVALG(sptr))) {
+          if (POINTERG(FVALG(sptr)) || ALLOCATTRG(FVALG(sptr))) {
             /* We convert a pointer-valued function into a subroutine whose
              * first dummy argument is the result now, really late in
              * semantic analysis.
+             * Check the attributes of fval instead of the attributes of entry,
+             * because only the first entry can get all attributes defined by
+             * fval through copy_type_to_entry(semant.c).
              */
             prepend_func_result_as_first_arg(sptr);
             gbl.rutype = RU_SUBR;