[F03] bogus error: Could not resolve generic type bound procedure #533

test/f90_correct/inc/tbp.mk

@@ -0,0 +1,34 @@
+#
+# 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
+	-$(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 ###

test/f90_correct/lit/tbp.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
+#
+
+
+# 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/tbp.f90

@@ -0,0 +1,111 @@
+!
+! 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
+
+    type A_t
+    contains
+! Case 1:
+        procedure :: f_none
+        procedure ,nopass :: f_int
+        procedure :: 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_none1, 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_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
+    end function f_int
+    real 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_none1() result (RSLT)
+        RSLT = 2
+    end function f_none1
+    integer function f_int1( me, n ) result (RSLT)
+        class(A_t) :: me
+        integer :: n
+        RSLT = n - 1
+    end function f_int1
+    real 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
+    real 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
+    real 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(10)
+    logical expect(10)
+
+    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)
+
+    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)
+
+    results(9) = 1 .eq. A%f()
+    results(10) = 2 .eq. A%f1()
+
+    call check(results,expect,10)
+end

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,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)) {
-            goto var_ref_common; /* assume NOPASS tbp */
+            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)));

tools/flang1/flang1exe/semfunc.c

@@ -654,6 +654,34 @@ is_ptr_arg(SST *sst_actual)
   return sptr > NOSYM && POINTERG(sptr);
 }
 
+// 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
+
 /* Non-pointer passed to a pointer dummy: geneerate a pointer temp, associate
  * the temp with the actual arg, and pass the temp.
  */
@@ -850,6 +878,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 +903,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 +3305,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 +3477,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);

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