From 6aa81f765c5f438ae29596f0b474d018cde6122a Mon Sep 17 00:00:00 2001
From: kiranktp <kirankumar.tp@amd.com>
Date: Wed, 8 Jan 2020 15:34:40 +0530
Subject: [PATCH 1/5] [F03] bogus error: Could not resolve generic type bound
 procedure #533 Earlier a tbp arg was added for few type bound procedure calls
 (with/without nopass clause). This was inconsistent. While procedure
 matching, procedures with nopass clauses were not considered. This has been
 fixed. Now a tbp arg will be added to all type bound procedure calls and this
 tbp arg will be considered/discarded depending on the procedure (with/without
 nopass clause) being matched.

Change-Id: I73a1b0c15852b8d2302048d44db4aa26f1f0a9ac
---
 test/f90_correct/inc/tbp.mk      | 32 +++++++++++
 test/f90_correct/lit/tbp.sh      |  7 +++
 test/f90_correct/src/tbp.f90     | 91 ++++++++++++++++++++++++++++++++
 tools/flang1/flang1exe/semant2.c | 14 ++---
 tools/flang1/flang1exe/semfunc.c | 61 +++++++++++++++++++++
 tools/flang1/flang1exe/semgnr.c  | 14 ++++-
 6 files changed, 206 insertions(+), 13 deletions(-)
 create mode 100644 test/f90_correct/inc/tbp.mk
 create mode 100644 test/f90_correct/lit/tbp.sh
 create mode 100644 test/f90_correct/src/tbp.f90

diff --git a/test/f90_correct/inc/tbp.mk b/test/f90_correct/inc/tbp.mk
new file mode 100644
index 00000000000..fa1998b4f29
--- /dev/null
+++ b/test/f90_correct/inc/tbp.mk
@@ -0,0 +1,32 @@
+# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved.
+#
+# Date of Modification: December 2019
+#
+
+########## Make rule to test type-bound procedures ########
+
+fcheck.o check_mod.mod: $(SRC)/check_mod.f90
+	-$(FC) -c $(FFLAGS) $(SRC)/check_mod.f90 -o fcheck.o
+
+tbp.o:  $(SRC)/tbp.f90 check_mod.mod
+	@echo ------------------------------------ building test $@
+	-$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/tbp.f90 -o tbp.o
+
+tbp: tbp.o fcheck.o
+	-$(FC) $(FFLAGS) $(LDFLAGS) tbp.o fcheck.o $(LIBS) -o tbp
+
+tbp.run: tbp
+	@echo ------------------------------------ executing test tbp
+	tbp
+	-$(RM) test_m.mod
+
+### TA Expected Targets ###
+
+build: $(TEST)
+
+.PHONY: run
+run: $(TEST).run
+
+verify: ; 
+
+### End of Expected Targets ###
diff --git a/test/f90_correct/lit/tbp.sh b/test/f90_correct/lit/tbp.sh
new file mode 100644
index 00000000000..b3f31780f34
--- /dev/null
+++ b/test/f90_correct/lit/tbp.sh
@@ -0,0 +1,7 @@
+# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved.
+#
+# Date of Modification: December 2019
+#
+
+# 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/tbp.f90 b/test/f90_correct/src/tbp.f90
new file mode 100644
index 00000000000..18fc6821a9a
--- /dev/null
+++ b/test/f90_correct/src/tbp.f90
@@ -0,0 +1,91 @@
+! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved.
+!
+! Date of Modification: December 2019
+
+module test_m
+    implicit none
+
+    type A_t
+    contains
+! Case 1:
+        procedure ,nopass :: f_int
+        procedure :: f_real
+        generic :: f => f_int, f_real
+! Case 2:
+        procedure :: f_int1
+        procedure ,nopass :: f_real1
+        generic :: f1 => f_int1, f_real1
+! Case 3:
+        procedure ,nopass:: f_int2
+        procedure ,nopass :: f_real2
+        generic :: f2 => f_int2, f_real2
+! Case 4:
+        procedure :: f_int3
+        procedure :: f_real3
+        generic :: f3 => f_int3, f_real3
+    endtype
+
+contains
+! Case 1:
+    integer function f_int( n ) result (RSLT)
+        integer :: n
+        RSLT = n - 1
+    end function f_int
+    integer function f_real( me, x ) result (RSLT)
+        class(A_t) :: me
+        real :: x
+        RSLT = x + 1
+    end function f_real
+
+! Case 2:
+    integer function f_int1( me, n ) result (RSLT)
+        class(A_t) :: me
+        integer :: n
+        RSLT = n - 1
+    end function f_int1
+    integer function f_real1( x ) result (RSLT)
+        real :: x
+        RSLT = x + 1
+    end function f_real1
+
+! Case 3:
+    integer function f_int2( n ) result (RSLT)
+        integer :: n
+        RSLT = n - 1
+    end function f_int2
+    integer function f_real2( x ) result (RSLT)
+        real :: x
+        RSLT = x + 1
+    end function f_real2
+
+! Case 3:
+    integer function f_int3( me, n ) result (RSLT)
+        class(A_t) :: me
+        integer :: n
+        RSLT = n - 1
+    end function f_int3
+    integer function f_real3( me, x ) result (RSLT)
+        class(A_t) :: me
+        real :: x
+        RSLT = x + 1
+    end function f_real3
+end module
+
+program main
+USE CHECK_MOD
+    use test_m
+    implicit none
+    type(A_t) :: A
+    logical results(4)
+    logical expect(4)
+
+    results = .false.
+    expect = .true.
+
+    results(1) = 9 .eq. A%f(10)
+    results(2) = 99 .eq. A%f1(100)
+    results(3) = 999 .eq. A%f2(1000)
+    results(4) = 9999 .eq. A%f3(10000)
+
+    call check(results,expect,4)
+end
diff --git a/tools/flang1/flang1exe/semant2.c b/tools/flang1/flang1exe/semant2.c
index 179392649ae..8e9b26bd939 100644
--- a/tools/flang1/flang1exe/semant2.c
+++ b/tools/flang1/flang1exe/semant2.c
@@ -768,16 +768,6 @@ semant2(int rednum, SST *top)
       } else {
         int dty = TBPLNKG(sptr);
         itemp = ITEM_END;
-        if (generic_tbp_has_pass_and_nopass(dty, sptr)) {
-          int parent, sp;
-          e1 = (SST *)getitem(0, sizeof(SST));
-          sp = sym_of_ast(ast);
-          SST_SYMP(e1, sp);
-          SST_DTYPEP(e1, DTYPEG(sp));
-          mkident(e1);
-          mkexpr(e1);
-          itemp = mkitem(e1);
-        }
         goto var_ref_common;
       }
     }
@@ -966,7 +956,9 @@ semant2(int rednum, SST *top)
           mem2 = get_specific_member(TBPLNKG(sptr), VTABLEG(mem));
           argno = get_tbp_argno(BINDG(mem2), TBPLNKG(sptr));
           if (!argno && NOPASSG(mem2)) {
-            goto var_ref_common; /* assume NOPASS tbp */
+            // One tbp argument will be added to a type bound procedure call
+            // with NOPASS clause.
+            argno = 1;
           }
         } else {
           argno = get_tbp_argno(sptr, DTYPEG(pass_sym_of_ast(ast)));
diff --git a/tools/flang1/flang1exe/semfunc.c b/tools/flang1/flang1exe/semfunc.c
index 71df4af5f34..eca7484af90 100644
--- a/tools/flang1/flang1exe/semfunc.c
+++ b/tools/flang1/flang1exe/semfunc.c
@@ -654,6 +654,36 @@ is_ptr_arg(SST *sst_actual)
   return sptr > NOSYM && POINTERG(sptr);
 }
 
+// AOCC Begin
+// Add a tbp arg when there is a call to type bound procedures
+static ITEM*
+add_tbp_arg (SST *stktop, ITEM *itemp)
+{
+  ITEM *itemp2;
+  SST *e1em;
+  int sp;
+  int ast = SST_ASTG(stktop);
+  e1em = (SST *)getitem(0, sizeof(SST));
+  sp = sym_of_ast(ast);
+  SST_SYMP(e1em, sp);
+  SST_DTYPEP(e1em, DTYPEG(sp));
+  mkident(e1em);
+  mkexpr(e1em);
+  itemp2 = (ITEM *)getitem(0, sizeof(ITEM));
+  itemp2->t.stkp = e1em;
+  itemp2->next = ITEM_END;
+
+  //tbp arg will be the first argument
+  if (itemp == ITEM_END) {
+    itemp = itemp2;
+  } else {
+    itemp2->next = itemp;
+    itemp = itemp2;
+  }
+  return itemp;
+} // add_tbp_arg
+// AOCC End
+
 /* Non-pointer passed to a pointer dummy: geneerate a pointer temp, associate
  * the temp with the actual arg, and pass the temp.
  */
@@ -850,6 +880,14 @@ func_call2(SST *stktop, ITEM *list, int flag)
       dtype = DTY(dtype + 1);
     if (STYPEG(BINDG(callee)) == ST_USERGENERIC) {
       int mem;
+      int imp, mem1;
+      // For type bound procedures with no "nopass" clause, tbp arg
+      // has already been added to the list. Need to do the same for type bound
+      // procedures with "nopass" clause as well.
+      sptr1 = BINDG(callee);
+      imp = get_implementation(TBPLNKG(sptr1), sptr1, 0, &mem1);
+      if (imp && NOPASSG(mem1))
+        list = add_tbp_arg(stktop, list);
       func_sptr = generic_tbp_func(BINDG(callee), stktop, list);
       if (func_sptr) {
         if (get_implementation(dtype, func_sptr, 0, &mem) == 0) {
@@ -867,6 +905,13 @@ func_call2(SST *stktop, ITEM *list, int flag)
         } else {
           SST_ASTP(stktop, replace_memsym_of_ast(SST_ASTG(stktop), mem));
           callee = mem;
+          // For the type bound procedures with nopass clause,
+          // tbg arg should be removed now.
+          // Procedure has already been resolved.
+          // First argument is tbp arg.
+          if (NOPASSG(mem)) {
+            list = list->next;
+          }
         }
       }
     }
@@ -3262,6 +3307,13 @@ subr_call2(SST *stktop, ITEM *list, int flag)
     }
     if (stype == ST_USERGENERIC && check_generic) {
       if (CLASSG(sptr)) {
+        int imp, mem;
+        imp = get_implementation(TBPLNKG(sptr), sptr, 0, &mem);
+        // For type bound procedures with no "nopass" clause, tbp arg
+        // has already been added to the list. Need to do the same for type bound
+        // procedures with "nopass" clause as well.
+        if (imp && NOPASSG(mem))
+          list = add_tbp_arg(stktop, list);
         sptr = generic_tbp_call(sptr, stktop, list, 0);
         goto do_call;
       }
@@ -3427,6 +3479,15 @@ subr_call2(SST *stktop, ITEM *list, int flag)
           sptr1 = 0;
           break;
         }
+        // For the type bound procedures with nopass clause,
+        // tbg arg should be removed now.
+        // Procedure has already been resolved.
+        // First argument is tbp arg.
+        if (NOPASSG(mem)) {
+          list = list->next;
+          count_actuals(list);
+          count = carg.nent;
+        }
         ast = replace_memsym_of_ast(ast, mem);
         SST_ASTP(stktop, ast);
         sptr = BINDG(mem);
diff --git a/tools/flang1/flang1exe/semgnr.c b/tools/flang1/flang1exe/semgnr.c
index 2d92f8e6b90..c6df882588a 100644
--- a/tools/flang1/flang1exe/semgnr.c
+++ b/tools/flang1/flang1exe/semgnr.c
@@ -313,6 +313,8 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device,
   int dscptr;
   int paramct, curr_paramct;
   SPTR found_sptrgen, func_sptrgen;
+  ITEM *list_bkp = list;
+  int arg_cnt_bkp = arg_cnt;
 
   /* find the generic's max nbr of formal args and use it to compute
    * the size of the arg distatnce data item.
@@ -382,6 +384,9 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device,
     for (gndsc = GNDSCG(sptrgen); gndsc; gndsc = SYMI_NEXT(gndsc)) {
       func = SYMI_SPTR(gndsc);
       func_sptrgen = sptrgen;
+      // Restore the argument list and argument count
+      list = list_bkp;
+      arg_cnt = arg_cnt_bkp;
       if (IS_TBP(func)) {
         /* For generic type bound procedures, use the implementation
          * of the generic bind name for the argument comparison.
@@ -399,8 +404,13 @@ find_best_generic(int gnr, ITEM *list, int arg_cnt, int try_device,
         if (!func)
           continue;
         mem = get_generic_member(dty, bind);
-        if (NOPASSG(mem) && generic_tbp_has_pass_and_nopass(dty, BINDG(mem)))
-          continue;
+        if (NOPASSG(mem)) {
+          // skip the tbp arg which has been added while processing the call
+          // before matching the procedure.
+          // type bound procedures with nopass clause will not have tbp argument.
+          list = list->next;
+          arg_cnt--;
+        }
         if (mem && PRIVATEG(mem) && SCOPEG(stb.curr_scope) != SCOPEG(mem))
           continue;
       } else

From 17c072e1a8440e72c03baa72f3bc3e9ae4eb7c1c Mon Sep 17 00:00:00 2001
From: kiranktp <kirankumar.tp@amd.com>
Date: Wed, 8 Jan 2020 15:40:59 +0530
Subject: [PATCH 2/5] Updated with correct license

Change-Id: Icc4334dcb22ca0e46b6ece3c651652729505e024
---
 test/f90_correct/inc/tbp.mk  | 6 ++++--
 test/f90_correct/lit/tbp.sh  | 6 ++++--
 test/f90_correct/src/tbp.f90 | 7 +++++--
 3 files changed, 13 insertions(+), 6 deletions(-)

diff --git a/test/f90_correct/inc/tbp.mk b/test/f90_correct/inc/tbp.mk
index fa1998b4f29..14804435cd5 100644
--- a/test/f90_correct/inc/tbp.mk
+++ b/test/f90_correct/inc/tbp.mk
@@ -1,8 +1,10 @@
-# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved.
 #
-# Date of Modification: December 2019
+# 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 to test type-bound procedures ########
 
 fcheck.o check_mod.mod: $(SRC)/check_mod.f90
diff --git a/test/f90_correct/lit/tbp.sh b/test/f90_correct/lit/tbp.sh
index b3f31780f34..de818590de6 100644
--- a/test/f90_correct/lit/tbp.sh
+++ b/test/f90_correct/lit/tbp.sh
@@ -1,7 +1,9 @@
-# Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved.
 #
-# Date of Modification: December 2019
+# 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
 #
 
+
 # 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/tbp.f90 b/test/f90_correct/src/tbp.f90
index 18fc6821a9a..d1641ad4a0a 100644
--- a/test/f90_correct/src/tbp.f90
+++ b/test/f90_correct/src/tbp.f90
@@ -1,6 +1,9 @@
-! Copyright (c) 2019, Advanced Micro Devices, Inc. All rights reserved.
 !
-! Date of Modification: December 2019
+! 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
+!
+
 
 module test_m
     implicit none

From 6244084e4f5b1e3c8025261a5846106de23b3ce0 Mon Sep 17 00:00:00 2001
From: kiranktp <kirankumar.tp@amd.com>
Date: Thu, 23 Jan 2020 10:39:07 +0530
Subject: [PATCH 3/5] Removed unwanted lines

Change-Id: I200132907086a9ca4a6af5fbe26279ce9473f94d
---
 tools/flang1/flang1exe/semfunc.c | 2 --
 1 file changed, 2 deletions(-)

diff --git a/tools/flang1/flang1exe/semfunc.c b/tools/flang1/flang1exe/semfunc.c
index eca7484af90..266ea447dab 100644
--- a/tools/flang1/flang1exe/semfunc.c
+++ b/tools/flang1/flang1exe/semfunc.c
@@ -654,7 +654,6 @@ is_ptr_arg(SST *sst_actual)
   return sptr > NOSYM && POINTERG(sptr);
 }
 
-// AOCC Begin
 // Add a tbp arg when there is a call to type bound procedures
 static ITEM*
 add_tbp_arg (SST *stktop, ITEM *itemp)
@@ -682,7 +681,6 @@ add_tbp_arg (SST *stktop, ITEM *itemp)
   }
   return itemp;
 } // add_tbp_arg
-// AOCC End
 
 /* Non-pointer passed to a pointer dummy: geneerate a pointer temp, associate
  * the temp with the actual arg, and pass the temp.

From f43ed48085688142cd52e1969693c1aecf4b21fe Mon Sep 17 00:00:00 2001
From: kiranktp <kirankumar.tp@amd.com>
Date: Thu, 6 Feb 2020 11:00:12 +0530
Subject: [PATCH 4/5] Incorporated review comments

Change-Id: I2268f5ae7100429b666f561de455eeef2ca32017
---
 test/f90_correct/src/tbp.f90     | 19 ++++++++++++-------
 tools/flang1/flang1exe/semant2.c | 10 +++++++---
 2 files changed, 19 insertions(+), 10 deletions(-)

diff --git a/test/f90_correct/src/tbp.f90 b/test/f90_correct/src/tbp.f90
index d1641ad4a0a..8d14953fdaf 100644
--- a/test/f90_correct/src/tbp.f90
+++ b/test/f90_correct/src/tbp.f90
@@ -34,7 +34,7 @@ integer function f_int( n ) result (RSLT)
         integer :: n
         RSLT = n - 1
     end function f_int
-    integer function f_real( me, x ) result (RSLT)
+    real function f_real( me, x ) result (RSLT)
         class(A_t) :: me
         real :: x
         RSLT = x + 1
@@ -46,7 +46,7 @@ integer function f_int1( me, n ) result (RSLT)
         integer :: n
         RSLT = n - 1
     end function f_int1
-    integer function f_real1( x ) result (RSLT)
+    real function f_real1( x ) result (RSLT)
         real :: x
         RSLT = x + 1
     end function f_real1
@@ -56,7 +56,7 @@ integer function f_int2( n ) result (RSLT)
         integer :: n
         RSLT = n - 1
     end function f_int2
-    integer function f_real2( x ) result (RSLT)
+    real function f_real2( x ) result (RSLT)
         real :: x
         RSLT = x + 1
     end function f_real2
@@ -67,7 +67,7 @@ integer function f_int3( me, n ) result (RSLT)
         integer :: n
         RSLT = n - 1
     end function f_int3
-    integer function f_real3( me, x ) result (RSLT)
+    real function f_real3( me, x ) result (RSLT)
         class(A_t) :: me
         real :: x
         RSLT = x + 1
@@ -79,8 +79,8 @@ program main
     use test_m
     implicit none
     type(A_t) :: A
-    logical results(4)
-    logical expect(4)
+    logical results(8)
+    logical expect(8)
 
     results = .false.
     expect = .true.
@@ -90,5 +90,10 @@ program main
     results(3) = 999 .eq. A%f2(1000)
     results(4) = 9999 .eq. A%f3(10000)
 
-    call check(results,expect,4)
+    results(5) = 11.1 .eq. A%f(10.1)
+    results(6) = 101.1 .eq. A%f1(100.1)
+    results(7) = 1001.1 .eq. A%f2(1000.1)
+    results(8) = 10001.1 .eq. A%f3(10000.1)
+
+    call check(results,expect,8)
 end
diff --git a/tools/flang1/flang1exe/semant2.c b/tools/flang1/flang1exe/semant2.c
index 8e9b26bd939..0788e8461d1 100644
--- a/tools/flang1/flang1exe/semant2.c
+++ b/tools/flang1/flang1exe/semant2.c
@@ -956,9 +956,13 @@ semant2(int rednum, SST *top)
           mem2 = get_specific_member(TBPLNKG(sptr), VTABLEG(mem));
           argno = get_tbp_argno(BINDG(mem2), TBPLNKG(sptr));
           if (!argno && NOPASSG(mem2)) {
-            // One tbp argument will be added to a type bound procedure call
-            // with NOPASS clause.
-            argno = 1;
+            if (STYPEG(sptr) == ST_USERGENERIC) {
+              // One tbp argument will be added to a type bound procedure call
+              // with NOPASS clause.
+              argno = 1;
+            } else {
+              goto var_ref_common; /* assume NOPASS tbp */
+            }
           }
         } else {
           argno = get_tbp_argno(sptr, DTYPEG(pass_sym_of_ast(ast)));

From e491503a0956778f334c764b4130e1e13c5ce4d4 Mon Sep 17 00:00:00 2001
From: kiranktp <kirankumar.tp@amd.com>
Date: Sun, 9 Feb 2020 22:09:32 +0530
Subject: [PATCH 5/5] Updated the test case

Change-Id: Idd1d60a7b3b2761dd36df2a8f60020257e2aedb5
---
 test/f90_correct/src/tbp.f90 | 22 +++++++++++++++++-----
 1 file changed, 17 insertions(+), 5 deletions(-)

diff --git a/test/f90_correct/src/tbp.f90 b/test/f90_correct/src/tbp.f90
index 8d14953fdaf..eb9cd55bce1 100644
--- a/test/f90_correct/src/tbp.f90
+++ b/test/f90_correct/src/tbp.f90
@@ -11,13 +11,15 @@ module test_m
     type A_t
     contains
 ! Case 1:
+        procedure :: f_none
         procedure ,nopass :: f_int
         procedure :: f_real
-        generic :: f => f_int, f_real
+        generic :: f => f_none, f_int, f_real
 ! Case 2:
+        procedure , nopass :: f_none1
         procedure :: f_int1
         procedure ,nopass :: f_real1
-        generic :: f1 => f_int1, f_real1
+        generic :: f1 => f_none1, f_int1, f_real1
 ! Case 3:
         procedure ,nopass:: f_int2
         procedure ,nopass :: f_real2
@@ -30,6 +32,10 @@ module test_m
 
 contains
 ! Case 1:
+    integer function f_none( me ) result (RSLT)
+        class(A_t) :: me
+        RSLT = 1
+    end function f_none
     integer function f_int( n ) result (RSLT)
         integer :: n
         RSLT = n - 1
@@ -41,6 +47,9 @@ real function f_real( me, x ) result (RSLT)
     end function f_real
 
 ! Case 2:
+    integer function f_none1() result (RSLT)
+        RSLT = 2
+    end function f_none1
     integer function f_int1( me, n ) result (RSLT)
         class(A_t) :: me
         integer :: n
@@ -79,8 +88,8 @@ program main
     use test_m
     implicit none
     type(A_t) :: A
-    logical results(8)
-    logical expect(8)
+    logical results(10)
+    logical expect(10)
 
     results = .false.
     expect = .true.
@@ -95,5 +104,8 @@ program main
     results(7) = 1001.1 .eq. A%f2(1000.1)
     results(8) = 10001.1 .eq. A%f3(10000.1)
 
-    call check(results,expect,8)
+    results(9) = 1 .eq. A%f()
+    results(10) = 2 .eq. A%f1()
+
+    call check(results,expect,10)
 end