Fixes for SUBMODULE, MODULE and tests

Fix internal compiler error with new_symbol not found with submodules

If the compiler finds one type bound procedure is bound to
the separate module procedure, export the separate module
procedure dummy arguments. Otherwise, those symbols are
not visible for other modules to use.

INMODULE bit was also not set, which causes the separate
module procedure name is not mangled properly in the
backend that causes an undefined error. This only happens
when the SMP is declared and defined within the same module.

For ST_USERGENERIC symbols, do not use the ST_ALIAS symbol
table type for the symbol if its GTYPE field is set. GTYPE
is set when the ST_USERGENERIC name overloads a derived
type name.

Author: gklimowicz

test/f90_correct/src/submod33.f90

@@ -19,17 +19,16 @@ module mod_set_foo_submod33
     Character*8,external :: FOO 
     Character*26 :: BAR
 interface
-module subroutine call_foo
-end subroutine
+  module subroutine call_foo
+  end subroutine
+
+  module subroutine  check_abc
+  end subroutine
 end interface
 end module
 
 submodule (mod_set_foo_submod33) submod_set_foo_submod33
     character*3 :: abc
-interface
-    module subroutine  check_abc
-    end subroutine
-end interface
 contains
     module procedure call_foo
         print *, FOO(BAR)

tools/flang1/flang1exe/exterf.c

@@ -378,6 +378,14 @@ static void export(FILE *export_fd, char *export_name, int cleanup)
           }
         }
         break;
+      case ST_IDENT:
+        if (for_module) {
+          if (SCG(sptr) == SC_DUMMY && SCOPEG(SCOPEG(sptr)) != sym_module &&
+              TBP_BOUND_TO_SMPG(SCOPEG(sptr))) {
+            queue_symbol(sptr);
+          }
+        }
+        break;
       default:
         break;
       }
@@ -2318,8 +2326,14 @@ export_symbol(int sptr)
       lzprintf(outlz, "C %d %d %s\n", sptr, STYPEG(sptr), SYMNAME(sptr));
       return;
     }
-    if (stype == ST_MODULE && sptr != sym_module && !for_inliner)
+    if (stype == ST_MODULE && sptr != sym_module && !for_inliner && 
+       /* No return when this module has a separate module procedure that
+        * implements a type bound procedure. We need to export modules 
+        * sptr next.
+        */
+        !HAS_TBP_BOUND_TO_SMPG(sptr) && ANCESTORG(sym_module) != sptr) {
       return;
+    }
   }
 
 

tools/flang1/flang1exe/interf.c

@@ -5145,7 +5145,7 @@ fill_ST_MODULE(SYMITEM *ps, int sptr)
   NEEDMODP(sptr, NEEDMODG(0));
   TYPDP(sptr, TYPDG(0));
   PRIVATEP(sptr, PRIVATEG(0));
-
+  HAS_TBP_BOUND_TO_SMPP(sptr, HAS_TBP_BOUND_TO_SMPG(0));
   stb.stg_base[0] = save_sym0;
 
 } /* fill_ST_MODULE */

tools/flang1/flang1exe/module.c

@@ -667,7 +667,7 @@ apply_use(MODULE_ID m_id)
       INKINDP(pr->local, INKINDG(pr->global));
       PDNUMP(pr->local, PDNUMG(pr->global));
       copy_specifics(ng, pr->local);
-    } else if (STYPEG(ng /*pr->global*/) == ST_USERGENERIC) {
+    } else if (STYPEG(ng /*pr->global*/) == ST_USERGENERIC && !GTYPEG(ng)) {
       if (NMPTRG(pr->local) == NMPTRG(pr->global)) {
         STYPEP(pr->local, ST_ALIAS);
         SYMLKP(pr->local, pr->global);

tools/flang1/flang1exe/semant.c

@@ -2339,6 +2339,17 @@ semant1(int rednum, SST *top)
          * ISSUBMODULEP is used for name mangling. 
          */
         SEPARATEMPP(sptr, TRUE);
+        if (IN_MODULE)
+          INMODULEP(sptr, TRUE);
+        if (SST_FIRSTG(RHS(rhstop))) {
+          TBP_BOUND_TO_SMPP(sptr, TRUE);
+          /* We also set the HAS_TBP_BOUND_TO_SMP flag on the separate module 
+           * procedure's module. This indicates that the module contains a 
+           * separate module procedure declaration to which at least one TBP
+           * has been bound.
+           */
+          HAS_TBP_BOUND_TO_SMPP(SCOPEG(sptr), TRUE);
+        }
       } else {
         SEPARATEMPP(sptr, TRUE);
 
@@ -11385,6 +11396,9 @@ semant1(int rednum, SST *top)
     } else {
       sptr2 = refsym(SST_SYMG(RHS(rhstop)), OC_OTHER);
     }
+  
+    if (SEPARATEMPG(sptr2))
+      TBP_BOUND_TO_SMPP(sptr2, TRUE);
 
     if (bindingNameRequiresOverloading(sptr)) {
       sptr = insert_sym(sptr);

tools/flang1/flang1exe/symtab.c

@@ -56,6 +56,11 @@ typedef struct {
   LOGICAL typ8;        /* True if the type is altered by -r8 */
 } DTIMPL[26 + 26 + 2];
 
+typedef struct {
+  SPTR dec_sptr;
+  SPTR def_sptr; 
+} DEC_DEF_MAP;
+
 static DTIMPL dtimplicit;
 static int dtimplicitsize = 0;
 static DTIMPL *save_dtimplicit = NULL;
@@ -64,7 +69,7 @@ static int dtimplicitstack = 0;
 static void cng_inttyp(int, int);
 static void cng_specific(int, int);
 static void generate_type_mismatch_errors(SPTR s1, SPTR s2);
-
+static void update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies);
 /* entry hack? */
 static ENTRY onlyentry;
 
@@ -2863,12 +2868,14 @@ SPTR
 instantiate_interface(SPTR iface)
 {
   int dummies;
-  SPTR fval, hashlk_sptr, proc; 
+  SPTR fval, hashlk_sptr, proc;
+  DEC_DEF_MAP *dec_def_map;
   proc = insert_dup_sym(iface);
   gbl.currsub = proc;
 
   SCOPEP(proc, SCOPEG(find_explicit_interface(proc)));
   dummies = PARAMCTG(iface);
+  NEW(dec_def_map, DEC_DEF_MAP, dummies);
   fval = NOSYM;
 
   STYPEP(proc, ST_ENTRY);
@@ -2907,7 +2914,9 @@ instantiate_interface(SPTR iface)
     for (j = 0; j < dummies; ++j) {
       SPTR arg = aux.dpdsc_base[iface_dpdsc + j];
       if (arg > NOSYM) {
+        dec_def_map[j].dec_sptr = arg;
         arg = insert_dup_sym(arg);
+        dec_def_map[j].def_sptr = arg;
         SCOPEP(arg, proc);
         if (DTY(DTYPEG(arg)) == TY_ARRAY && ASSUMSHPG(arg)) {
           DTYPE elem_dt = array_element_dtype(DTYPEG(arg));
@@ -2920,10 +2929,10 @@ instantiate_interface(SPTR iface)
           get_static_descriptor(arg);
         }
         if (ALLOCATTRG(arg) || POINTERG(arg)) {
-          newdsc = sym_get_arg_sec(arg);          
-          SDSCP(arg, newdsc);
-          SCP(newdsc, SC_DUMMY);
-          SCOPEP(newdsc, proc);
+          if (!SDSCG(arg))
+            get_static_descriptor(arg);
+          if (!PTROFFG(arg))
+            get_all_descriptors(arg);
         }
 
         HIDDENP(arg, 0);
@@ -2935,9 +2944,54 @@ instantiate_interface(SPTR iface)
       aux.dpdsc_base[proc_dpdsc + j] = arg;
     }
   }
+
+  if (ADJARRG(fval)) {
+    ADSC *ad;
+    int arr_dsc;
+    DTYPE elem_dt;
+    ad = AD_DPTR(DTYPEG(FVALG(iface)));
+    update_arrdsc(fval, dec_def_map, dummies);
+    elem_dt = array_element_dtype(DTYPEG(iface));
+    arr_dsc = mk_arrdsc();
+    DTY(arr_dsc + 1) = elem_dt;
+    DTYPEP(fval, arr_dsc); 
+    trans_mkdescr(fval);
+  }
+
+  FREE(dec_def_map);
+  
   return proc;
 }
 
+/** \brief Update array bound AST SPTRs (old_sptr) using newly created SPTRs 
+           (new_sptr) by referring to DEC_DEF_MAP. The DEC_DEF_MAP is a struct 
+           which contains mapping info from the old_sptr to new_sptr.
+ */
+static void 
+update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies) {
+  int i, j;
+  SPTR dec_sptr_lwbd, dec_sptr_upbd;
+  ADSC *ad;
+  ad = AD_DPTR(DTYPEG(s));
+  sem.arrdim.ndim = AD_NUMDIM(ad);
+  sem.arrdim.ndefer = AD_DEFER(ad);
+  for (i = 0; i < sem.arrdim.ndim; ++i) {
+    /* restore arrdsc bound ast info from *ad */
+    sem.bounds[i].lwast = AD_LWAST(ad, i);
+    sem.bounds[i].upast = AD_UPAST(ad, i);
+
+    /* update arrdsc bound ast info */
+    dec_sptr_lwbd = A_SPTRG(AD_LWBD(ad, i));
+    dec_sptr_upbd = A_SPTRG(AD_UPBD(ad, i));
+    for (j = 0; j < num_dummies; ++j) {  
+      if (dec_sptr_lwbd == smap[j].dec_sptr)
+        sem.bounds[i].lwast = mk_id(smap[j].def_sptr);
+      if (dec_sptr_upbd == smap[j].dec_sptr)
+        sem.bounds[i].upast = mk_id(smap[j].def_sptr);
+    }
+  }
+}
+
 /**
  * reinitialize a symbol
  */

tools/flang1/utils/symtab/symtab.n

@@ -1571,6 +1571,8 @@ for this symbol.
 Flags
 .FL SEPARATEMP
 MODULE SUBROUTINE, MODULE FUNCTION for a separate module procedure.
+.FL TBP_BOUND_TO_SMP f112
+At least one type bound procedure is bound to this separate module procedure.
 .FL IS_INTERFACE
 Set if the procedure symbol is in an interface block.
 .FL IS_PROC_DUMMY f109
@@ -2511,6 +2513,9 @@ Flags
 Used to mark the submodule SUBROUTINE, submodule FUNCTION that is defined 
 inside interface and used by submodules. This is used to differentiate 
 the normal module SUBROUTINE, FUNCTION, and PROCEDURE.
+.FL HAS_TBP_BOUND_TO_SMP f112
+This flag is set when this module has a derived type with a type bound 
+procedure that is implemented by a separate module procedure
 .FL NEEDMOD f1
 If set, an external reference to this module needs to be generated,
 so a link error will occur if a program that USEs this module is linked