Fix a segfault with procedure dummy arguments

Fix a fault with procedure dummy arguments and interfaces.
Create a unique symbol for interfaces that are used in procedure
pointer declarations because the LLVM bridge uses the interface
as well as the argument ILI to generate arguments at a procedure
pointer call.  An interface symbol might turn into a procedure
symbol in the back-end.  Create a unique symbol so we can
mark it with a new field called IS_PROC_PTR_IFACE. This
field says that the symbol is used as an interface to a
procedure pointer. When the bridge sees this field set, it
knows to generate a closure pointer as the last argument at
the call-site.

This bug fix addresses Flang issue #577.

Author: gklimowicz

tools/flang1/flang1exe/dtypeutl.c

@@ -1517,6 +1517,20 @@ tk_match_arg(int formal_dt, int actual_dt, LOGICAL flag)
     }
   }
   else if (!eq_dtype2(f_dt, a_dt, flag)) {
+    if (DTY(f_dt) == TY_PTR && DTY(a_dt) == TY_PTR && 
+        DTY(DTY(f_dt + 1)) == TY_PROC && DTY(DTY(a_dt + 1)) == TY_PROC) {
+      /* eq_dtype2 checks equality of the procedure pointers.
+       * If they are not the same (including the same name), then
+       * it returns false. This is correct for an equality test.
+       * However, in this case, we don't care about the names being
+       * the same if all other attributes are equal.
+       */
+       DTYPE d1 = DTY(f_dt + 1);
+       DTYPE d2 = DTY(a_dt + 1);
+       if (cmp_interfaces(DTY(d1 + 2), DTY(d2 + 2), FALSE)) {
+         return TRUE;
+       }
+    } 
     return FALSE;
   }
 

tools/flang1/flang1exe/lower.h

@@ -140,6 +140,8 @@
  * 20.1         -- 1.55
  *              All of 1.54 +
  *              pass elemental field for subprogram when emitting ST_ENTRY.
+ *
+ *              For ST_PROC, pass IS_PROC_PTR_IFACE flag.
  */
 #define VersionMajor 1
 #define VersionMinor 55

tools/flang1/flang1exe/lowersym.c

@@ -4043,6 +4043,7 @@ lower_symbol(int sptr)
         putbit("is_interface", IS_INTERFACEG(sptr));
         putval("assocptr", ASSOC_PTRG(sptr));
         putval("ptrtarget",PTR_TARGETG(sptr));
+        putbit("prociface", IS_PROC_PTR_IFACEG(sptr));
       }
 
       strip = 1;
@@ -4273,6 +4274,7 @@ lower_symbol(int sptr)
 #endif
     putval("assocptr", ASSOC_PTRG(sptr));
     putval("ptrtarget", PTR_TARGETG(sptr));
+    putbit("prociface", IS_PROC_PTR_IFACEG(sptr));
     strip = 1;
     break;
 
@@ -4322,6 +4324,7 @@ lower_symbol(int sptr)
     putbit("is_interface", 0);
     putval("assocptr", 0);
     putval("ptrtarget", 0);
+    putbit("prociface", 0);
     strip = 1;
     break;
 
@@ -4523,6 +4526,7 @@ lower_symbol(int sptr)
       putval("descriptor", IS_PROC_DUMMYG(sptr) ? SDSCG(sptr) : 0);
     putsym("assocptr", ASSOC_PTRG(sptr));
     putsym("ptrtarget", PTR_TARGETG(sptr));
+    putbit("prociface", IS_PROC_PTR_IFACEG(sptr)); 
     if (gbl.stbfil && DTY(DTYPEG(sptr) + 2)) {
       if (fvalfirst) {
         putsym(NULL, FVALG(sptr));

tools/flang1/flang1exe/semant.c

@@ -2479,7 +2479,7 @@ semant1(int rednum, SST *top)
        * body should never contain a procedure defined by a subprogram,
        * so this flag should never be set for an interface. Because
        * getsym() does not have access to sem.interface, we reset the
-       *  NTERNAL flag here.
+       * INTERNAL flag here.
        */
       INTERNALP(sptr, 0);
     }
@@ -11343,6 +11343,49 @@ semant1(int rednum, SST *top)
       if (POINTERG(sptr)) {
         attr |= ET_B(ET_POINTER);
       } 
+    if (!IS_PROC_DUMMYG(sptr) && IS_INTERFACEG(proc_interf_sptr) &&
+        !IS_PROC_PTR_IFACEG(proc_interf_sptr)) {
+      /* Create a unique symbol for the interface so it does not conflict with
+       * an external procedure symbol. For non-procedure dummy arguments,
+       * we need a unique symbol for the interface in order to preserve
+       * the interface flag (IS_PROC_PTR_IFACE). We need the interface flag in 
+       * the back-end so we properly generate the procedure descriptor
+       * actual arguments on the call-site (when we call the procedure pointer).
+       * This is only needed  by the LLVM back-end because the bridge uses the 
+       * interface to generate the LLVM IR for the actual arguments. 
+       */
+      char * buf;
+      int len;
+      SPTR sym;
+    
+      /* First, let's see if we aleady have a unique interface symbol */ 
+      len = strlen(SYMNAME(proc_interf_sptr)) + strlen("iface") + 1;
+      buf = getitem(0, len);
+      sprintf(buf,"%s$iface",SYMNAME(proc_interf_sptr));
+      sym = findByNameStypeScope(buf, ST_PROC, 0);
+      if (sym > NOSYM && !cmp_interfaces_strict(sym, proc_interf_sptr, 0)) { 
+        /* The interface is not compatible. We will now try to find one that
+         * is compatible in the symbol table.
+         */
+        SPTR sym2 = sym;
+        get_next_hash_link(sym2, 0);
+        while ((sym2=get_next_hash_link(sym2, 1)) > NOSYM) {
+          if (cmp_interfaces_strict(sym2, proc_interf_sptr, 0)) {
+            break;
+          }
+        }
+        sym = sym2;
+      }
+      if (sym <= NOSYM) {  
+        /* We don't yet have a unique interface symbol, so create it now */
+        sym  = get_next_sym(SYMNAME(proc_interf_sptr), "iface");
+        /* Propagate flags from the original symbol to the new symbol */
+        copy_sym_flags(sym, proc_interf_sptr);
+        HCCSYMP(sym, 1);
+        IS_PROC_PTR_IFACEP(sym, 1);
+      }
+      proc_interf_sptr = sym;
+    }
       sptr = decl_procedure_sym(sptr, proc_interf_sptr, attr);
       sptr =
           setup_procedure_sym(sptr, proc_interf_sptr, attr, entity_attr.access);

tools/flang1/flang1exe/symtab.c

@@ -2802,6 +2802,41 @@ cmp_interfaces_strict(SPTR sym1, SPTR sym2, cmp_interface_flags flag)
   return true;
 }
 
+/** \brief Copy flags from one symbol to another symbol.
+ *
+ * This routine is the same as dup_sym() except it preserves the symbol's
+ * name, hash link, scope, and name pointer. In other words, it copies all but 
+ * 4 flags from one symbol to another. The 4 flags that are not copied are 
+ * the hashlk, symlk, scope, and nmptr.
+ *
+ * \param dest is the receiving symbol table pointer of the flags.
+ * \param src is the source symbol table pointer of the flags.
+ */
+void
+copy_sym_flags(SPTR dest, SPTR src)
+{
+
+  SYM *destSym;
+  SPTR hashlk;
+  SPTR symlk;
+  INT nmptr;
+  INT scope;
+
+  destSym = (stb.stg_base + dest);
+  hashlk = destSym->hashlk;
+  symlk = destSym->symlk;
+  nmptr = destSym->nmptr;
+  scope = destSym->scope;
+
+  *destSym = *(stb.stg_base + src);
+
+  destSym->hashlk = hashlk;
+  destSym->symlk = symlk;
+  destSym->nmptr = nmptr;
+  destSym->scope = scope;
+
+}
+  
 /**
  * replace contents of a symbol with values defining every field while ensuring
  * values necessary for the hashing function are saved and restored.

tools/flang1/utils/symtab/symtab.in.h

@@ -414,6 +414,7 @@ LOGICAL is_arg_in_entry(int, int);
 int resolve_sym_aliases(int);
 LOGICAL is_procedure_ptr(int);
 void proc_arginfo(int, int *, int *, int *);
+void copy_sym_flags(SPTR, SPTR);
 void dup_sym(int, struct SYM *);
 int insert_dup_sym(int);
 int get_align_desc(int, int);

tools/flang1/utils/symtab/symtab.n

@@ -1592,6 +1592,9 @@ for this symbol.
 .lp
 .ul
 Flags
+.FL IS_PROC_PTR_IFACE f117
+This is set when this procedure symbol is used as an interface for a procedure
+pointer. IS_INTERFACE should also be set in this case.
 .FL SEPARATEMP
 MODULE SUBROUTINE, MODULE FUNCTION for a separate module procedure.
 .FL TBP_BOUND_TO_SMP f112

tools/flang2/flang2exe/ll_ftn.cpp

@@ -36,6 +36,8 @@
 #include "cgmain.h"
 #include "symfun.h"
 
+static SPTR create_display_temp_arg(DTYPE ref_dtype);
+
 /* debug switches:
    -Mq,11,16 dump ili right before ILI -> LLVM translation
    -Mq,12,16 provides dinit info, ilt trace, and some basic preprocessing info
@@ -233,6 +235,21 @@ gen_ref_arg(SPTR param_sptr, SPTR func_sptr, LL_Type *ref_dummy, int param_num,
   addag_llvm_argdtlist(gblsym, param_num, param_sptr, llt);
 }
 
+/** \brief Create a procedure DUMMY argument to hold a closure/display pointer.
+ *
+ * \param ref_dtype is a dtype for the display argument.
+ *
+ * \return the symbol table pointer of the newly created display argument.
+ */ 
+static SPTR
+create_display_temp_arg(DTYPE ref_dtype)
+{
+  SPTR display_temp = getccsym('S', gbl.currsub, ST_VAR);
+  SCP(display_temp, SC_DUMMY);
+  DTYPEP(display_temp, ref_dtype); 
+  return display_temp;
+}
+
 void
 ll_process_routine_parameters(SPTR func_sptr)
 {
@@ -325,14 +342,13 @@ ll_process_routine_parameters(SPTR func_sptr)
       display_temp = aux.curr_entry->display;
       DTYPEP(display_temp, ref_dtype); /* fake type */
     } else {
-      display_temp = getccsym('S', gbl.currsub, ST_VAR);
       /* we won't make type as at the time we generate the prototype, we don't
-       * know
-       * what members it has.
+       * know what members it has.
        */
-      SCP(display_temp, SC_DUMMY);
-      DTYPEP(display_temp, ref_dtype); /* fake type */
+      display_temp = create_display_temp_arg(ref_dtype);
     }
+  } else if (IS_PROC_PTR_IFACEG(func_sptr)) {
+    display_temp = create_display_temp_arg(ref_dtype);
   }
 
   if (fval) {

tools/flang2/flang2exe/upper.cpp

@@ -2045,6 +2045,7 @@ read_symbol(void)
   int alldefaultinit;
   int tpalloc, procdummy, procdesc, has_opts;
   SPTR assocptr, ptrtarget;
+  int prociface;
   ISZ_T address, size;
   SPTR sptr = getSptrVal("symbol");
   bool has_alias = false;
@@ -2764,7 +2765,7 @@ read_symbol(void)
     tpalloc = getbit("tpalloc");
     assocptr = getSptrVal("assocptr");
     ptrtarget = getSptrVal("ptrtarget");
-
+    prociface = getbit("prociface");
     newsptr = get_or_create_symbol(sptr);
 
     STYPEP(newsptr, stype);
@@ -2812,6 +2813,7 @@ read_symbol(void)
     if (assocptr > NOSYM || ptrtarget > NOSYM) {
       PTR_INITIALIZERP(newsptr, 1);
     }
+    IS_PROC_PTR_IFACEP(newsptr, prociface);
     break;
 
   case ST_NML:
@@ -2944,6 +2946,7 @@ read_symbol(void)
     descriptor = (sclass == SC_DUMMY) ? getSptrVal("descriptor") : SPTR_NULL;
     assocptr = getSptrVal("assocptr");
     ptrtarget = getSptrVal("ptrtarget");
+    prociface = getbit("prociface");
 
     if (paramcount == 0) {
       dpdsc = 0;
@@ -3123,6 +3126,7 @@ read_symbol(void)
     if (assocptr > NOSYM || ptrtarget > NOSYM) {
       PTR_INITIALIZERP(newsptr, 1);
     }
+    IS_PROC_PTR_IFACEP(newsptr, prociface);
     break;
 
   case ST_GENERIC:

tools/flang2/flang2exe/upper.h

@@ -144,6 +144,8 @@
  * 20.1         -- 1.55
  *              All of 1.54 +
  *              pass elemental field for subprogram when emitting ST_ENTRY.
+ *
+ *              For ST_PROC, receive IS_PROC_PTR_IFACE flag.
  */
 
 #include "gbldefs.h"