diff --git a/test/f90_correct/inc/tbp.mk b/test/f90_correct/inc/tbp.mk new file mode 100644 index 00000000000..14804435cd5 --- /dev/null +++ b/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 ### diff --git a/test/f90_correct/lit/tbp.sh b/test/f90_correct/lit/tbp.sh new file mode 100644 index 00000000000..de818590de6 --- /dev/null +++ b/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 diff --git a/test/f90_correct/src/tbp.f90 b/test/f90_correct/src/tbp.f90 new file mode 100644 index 00000000000..eb9cd55bce1 --- /dev/null +++ b/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 diff --git a/tools/flang1/flang1exe/semant2.c b/tools/flang1/flang1exe/semant2.c index 179392649ae..0788e8461d1 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,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))); diff --git a/tools/flang1/flang1exe/semfunc.c b/tools/flang1/flang1exe/semfunc.c index 71df4af5f34..266ea447dab 100644 --- a/tools/flang1/flang1exe/semfunc.c +++ b/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); 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