Merge pull request #112 from ThePortlandGroup/nv_stage

Pull 2017-06-27T16-27 Recent NVIDIA Changes

Author: sscalpone

tools/flang1/flang1exe/dtypeutl.c

@@ -3866,15 +3866,21 @@ array_element_dtype(DTYPE dtype)
 LOGICAL
 is_dtype_runtime_length_char(DTYPE dtype)
 {
-  switch (dtype) {
-  case DT_ASSCHAR:
-  case DT_DEFERCHAR:
-  case DT_ASSNCHAR:
-  case DT_DEFERNCHAR:
-    return TRUE;
-  default:
-    return FALSE;
-  }
+  if (is_array_dtype(dtype))
+    dtype = array_element_dtype(dtype);
+  return dtype > DT_NONE &&
+         DT_ISCHAR(dtype) &&
+         string_length(dtype) == 0;
+}
+
+LOGICAL
+is_dtype_unlimited_polymorphic(DTYPE dtype)
+{
+  if (is_array_dtype(dtype))
+    dtype = array_element_dtype(dtype);
+  return dtype > DT_NONE &&
+         DTY(dtype) == TY_DERIVED &&
+         UNLPOLYG(DTY(dtype + 3 /*tag*/));
 }
 
 /** \brief Test if a data type index corresponds with a procedure pointer
@@ -4012,3 +4018,20 @@ is_unresolved_parameterized_dtype(DTYPE dtype)
   }
   return FALSE;
 }
+
+/* Correct TYPE IS(CHARACTER(LEN=*)) to TYPE IS(CHARACTER(LEN=:))
+ * so that semant3 can create a pointer or allocatable for construct
+ * association.
+ */
+DTYPE
+change_assumed_char_to_deferred(DTYPE dtype)
+{
+  switch (dtype) {
+  case DT_ASSCHAR:
+    return DT_DEFERCHAR;
+  case DT_ASSNCHAR:
+    return DT_DEFERNCHAR;
+  default:
+    return dtype;
+  }
+}

tools/flang1/flang1exe/dtypeutl.h

@@ -98,6 +98,7 @@ DTYPE get_iso_c_ptr(void);
 LOGICAL is_array_dtype(DTYPE dtype);
 DTYPE array_element_dtype(DTYPE dtype);
 LOGICAL is_dtype_runtime_length_char(DTYPE dtype);
+LOGICAL is_dtype_unlimited_polymorphic(DTYPE dtype);
 LOGICAL is_procedure_ptr_dtype(DTYPE dtype);
 DTYPE proc_ptr_result_dtype(DTYPE dtype);
 void set_proc_ptr_result_dtype(DTYPE ptr_dtype, DTYPE result_dtype);
@@ -109,3 +110,4 @@ SPTR get_struct_tag_sptr(DTYPE dtype);
 SPTR get_struct_members(DTYPE dtype);
 SPTR get_struct_initialization_tree(DTYPE dtype);
 LOGICAL is_unresolved_parameterized_dtype(DTYPE dtype);
+DTYPE change_assumed_char_to_deferred(DTYPE);

tools/flang1/flang1exe/func.c

@@ -1492,7 +1492,7 @@ check_pointer_type(int past, int tast, int stmt, LOGICAL is_sourced_allocation)
 
   if (!is_sourced_allocation && POINTERG(psptr) && UNLPOLYG(DTY(dt1 + 3)) &&
       UNLPOLYG(DTY(dt2 + 3)) && SDSCG(psptr) && SDSCG(tsptr)) {
-    /* init unlimited polymorophic descriptor for pointer.
+    /* init unlimited polymorphic descriptor for pointer.
      * We do not have to do this for the sourced allocation case since
      * the sourced allocation case is handled in semant3.c with the
      * ALLOCATE productions.
@@ -1511,12 +1511,7 @@ check_pointer_type(int past, int tast, int stmt, LOGICAL is_sourced_allocation)
       tsdsc = SDSCG(tsptr);
     }
     assert(tsdsc > NOSYM, "no descriptor for tsptr", tsptr, 3);
-    if (XBIT(68, 0x1)) {
-      fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
-
-    } else
-      fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
-
+    fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
     dest_sdsc_ast = check_member(past, mk_id(psdsc));
     src_sdsc_ast = check_member(tast, mk_id(tsdsc));
 
@@ -1685,8 +1680,8 @@ check_alloc_ptr_type(int psptr, int stmt, DTYPE dt1, int flag, LOGICAL after,
         }
         stmt = gen_set_type(desc1_ast, type2_ast, stmt, !after, intrin_type);
         if (no_alloc_ptr) {
-          int astnew = mk_assn_stmt(tagdesc, mk_isz_cval((intrin_type) ? 
-                                    __TAGPOLY : __TAGDESC, DT_INT), 0);
+          int tag = mk_isz_cval(intrin_type ? __TAGPOLY : __TAGDESC, DT_INT);
+          int astnew = mk_assn_stmt(tagdesc, tag, 0);
           stmt = add_stmt_before(astnew, stmt);
         }
       }

tools/flang1/flang1exe/rest.c

@@ -1486,7 +1486,7 @@ transform_call(int std, int ast)
            */
           /* Also execute this code if the interface arg
            * does not need a descriptor, but the actual arg is
-           * allocatable. That way, the type gets added the actual's
+           * allocatable. That way, the type gets added to the actual's
            * descriptor.
            */
           if (!needdescr && !CLASSG(sptr) && DTY(DTYPEG(sptr)) == TY_DERIVED) {
@@ -1504,6 +1504,17 @@ transform_call(int std, int ast)
             }
           } else {
             check_alloc_ptr_type(sptr, std, 0, unl_poly ? 2 : 1, 0, 0, 0);
+            if (unl_poly) {
+              int descr_length_ast =
+                    symbol_descriptor_length_ast(sptr, 0 /*no AST*/);
+              if (descr_length_ast > 0) {
+                int length_ast = get_value_length_ast(DT_NONE, 0, sptr,
+                                                      DTYPEG(sptr), 0);
+                if (length_ast > 0)
+                  add_stmt_before(mk_assn_stmt(descr_length_ast, length_ast,
+                                               astb.bnd.dtype), std);
+              }
+            }
           }
         }
         dty = DTYPEG(sptr);

tools/flang1/flang1exe/rte.h

@@ -198,7 +198,6 @@ extern int get_byte_len_indx(void);
 extern void set_descriptor_sc(int sc);
 extern int get_desc_rank(int);
 extern int get_kind(int);
-extern int get_byte_len(int);
 extern int get_gbase(int);
 extern int get_gbase2(int);
 extern int get_desc_tag(int);

tools/flang1/flang1exe/semant3.c

@@ -5513,20 +5513,14 @@ convert_to_block_forall(int old_forall_ast)
 static void
 gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast)
 {
-  int fsptr, argt, val, ast;
-  if (XBIT(68, 0x1)) {
-    fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
-
-  } else
-    fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
-
-  argt = mk_argt(3);
+  int fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
+  int argt = mk_argt(3);
+  int val = mk_cval1(43, DT_INT);
+  int ast = mk_id(fsptr);
   ARGT_ARG(argt, 0) = dest_sdsc_ast;
   ARGT_ARG(argt, 1) = src_sdsc_ast;
-  val = mk_cval1(43, DT_INT);
   val = mk_unop(OP_VAL, val, DT_INT);
   ARGT_ARG(argt, 2) = val;
-  ast = mk_id(fsptr);
   ast = mk_func_node(A_CALL, ast, 3, argt);
   add_stmt(ast);
 }
@@ -5665,15 +5659,6 @@ is_associatable_variable_sst(SST *rhs)
   return FALSE;
 }
 
-/* Build an AST that references the byte length field in a descriptor.
- */
-static int
-get_descriptor_length_ast(int descriptor_ast)
-{
-  int subs = mk_isz_cval(get_byte_len_indx(), astb.bnd.dtype);
-  return mk_subscr(descriptor_ast, &subs, 1, astb.bnd.dtype);
-}
-
 /* Implement an association for one of these constructs:
  *
  *   ASSOCIATE(a => variable)
@@ -5712,6 +5697,7 @@ construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, LOGICAL is_class)
   LOGICAL is_lhs_unl_poly;
   int rhs_descriptor_ast = 0;
   LOGICAL does_lhs_need_runtime_type;
+  int lhs_length_ast;
 
   if (!(rhs_ast = SST_ASTG(rhs))) {
     mkexpr(rhs);
@@ -5727,16 +5713,19 @@ construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, LOGICAL is_class)
   }
 
   lhs_dtype = stmt_dtype > 0 ? stmt_dtype : rhs_dtype;
-  lhs_element_dtype = lhs_dtype;
   if (is_array_dtype(lhs_dtype)) {
     int rank = get_ast_rank(rhs_ast);
     is_array = rank > 0;
     if (is_array) {
-      lhs_element_dtype = DTY(lhs_dtype + 1);
+      lhs_element_dtype = array_element_dtype(lhs_dtype);
+      lhs_element_dtype = change_assumed_char_to_deferred(lhs_element_dtype);
       lhs_dtype = get_array_dtype(rank, lhs_element_dtype);
       ADD_DEFER(lhs_dtype) = TRUE;
       ADD_NOBOUNDS(lhs_dtype) = TRUE;
     }
+  } else {
+    lhs_dtype = change_assumed_char_to_deferred(lhs_dtype);
+    lhs_element_dtype = lhs_dtype;
   }
   is_lhs_runtime_length_char = is_dtype_runtime_length_char(lhs_dtype);
 
@@ -5875,7 +5864,8 @@ construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, LOGICAL is_class)
   }
 
   /* For TYPE IS statements with intrinsic types, set the LHS type
-   * directly. */
+   * directly.
+   */
   if (SDSCG(lhs_sptr) > NOSYM && stmt_dtype && !is_class &&
       DTY(lhs_element_dtype) != TY_DERIVED) {
     int args = mk_argt(2);
@@ -5888,30 +5878,17 @@ construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, LOGICAL is_class)
   /* Generate code to initialize, when necessary, the byte length field
    * in the left-hand side's descriptor, if it exists.
    */
-  if (SDSCG(lhs_sptr) > NOSYM) {
-    int dest_len_ast = 0;
-    if (is_lhs_runtime_length_char) {
-      dest_len_ast = get_byte_len(SDSCG(lhs_sptr));
-    } else if (is_lhs_unl_poly || is_array) {
-      dest_len_ast = get_descriptor_length_ast(mk_id(SDSCG(lhs_sptr)));
-    }
-    if (dest_len_ast) {
-      int len_ast = 0;
-      if (is_dtype_runtime_length_char(rhs_dtype)) {
-        len_ast = string_expr_length(rhs_ast);
-      } else if (stmt_dtype && !is_class /* TYPE IS(stmt_dtype) */ &&
-                 !is_lhs_runtime_length_char) {
-        len_ast = size_ast(lhs_sptr, lhs_element_dtype);
-      } else if (rhs_descriptor_ast &&
-                 is_array_dtype(A_DTYPEG(rhs_descriptor_ast))) {
-        len_ast = get_descriptor_length_ast(rhs_descriptor_ast);
-      }
-      if (len_ast) {
-        int assignment_ast =
-            mk_assn_stmt(dest_len_ast, len_ast, astb.bnd.dtype);
-        add_stmt(assignment_ast);
-      }
-    }
+  lhs_length_ast = symbol_descriptor_length_ast(lhs_sptr, 0 /*no AST*/);
+  if (lhs_length_ast > 0) {
+    SPTR size_sptr = stmt_dtype > DT_NONE &&
+                     !is_class /* TYPE IS */ &&
+                     !is_lhs_runtime_length_char ? lhs_sptr
+                                                 : NOSYM;
+    int rhs_length_ast = get_value_length_ast(rhs_dtype, rhs_ast, size_sptr,
+                                              lhs_element_dtype,
+                                              rhs_descriptor_ast);
+    if (rhs_length_ast > 0)
+      add_stmt(mk_assn_stmt(lhs_length_ast, rhs_length_ast, astb.bnd.dtype));
   }
 
   return lhs_sptr;

tools/flang1/flang1exe/semfin.c

@@ -266,13 +266,19 @@ add_class_arg_descr_arg(int func_sptr, int arg_sptr, int new_arg_position)
       /* add type descriptor argument */
       static int tmp = 0;
       int new_arg_sptr = getccsym_sc('O', tmp++, ST_VAR, SC_DUMMY);
+      DTYPE dtype = get_array_dtype(1, astb.bnd.dtype);
+      ADD_LWBD(dtype, 0) = 0;
+      ADD_LWAST(dtype, 0) = astb.bnd.one;
+      ADD_NUMELM(dtype) = ADD_UPBD(dtype, 0) = ADD_UPAST(dtype, 0) =
+        mk_isz_cval(get_descriptor_len(0), astb.bnd.dtype);
       CLASSP(new_arg_sptr, 1);
-      DTYPEP(new_arg_sptr, stb.user.dt_int);
+      DTYPEP(new_arg_sptr, dtype);
       inject_arg(func_sptr, new_arg_sptr, new_arg_position);
       PARENTP(arg_sptr, new_arg_sptr);
       /*OPTARGP(new_arg_sptr, TRUE);*/ /* FS#17571 */
       return TRUE;
-    } else if (!SDSCG(arg_sptr)) {
+    }
+    if (!SDSCG(arg_sptr)) {
       /* FS#19541 - create normal descr dummy now */
       int descr_sptr = sym_get_arg_sec(arg_sptr);
       SDSCP(arg_sptr, descr_sptr);

tools/flang1/flang1exe/semutil.c

@@ -3785,8 +3785,9 @@ add_ptr_assign(int dest, int src, int std)
     DTYPEP(memsym_of_ast(dest), dtype);
   }
 
-  if (dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR ||
-      (UNLPOLYG(tag) && DTY(A_DTYPEG(src)) == TY_CHAR)) {
+  if ((dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR ||
+       (UNLPOLYG(tag) && DTY(A_DTYPEG(src)) == TY_CHAR)) &&
+      !is_dtype_unlimited_polymorphic(A_DTYPEG(src))) {
     int dest_len_ast = get_len_of_deferchar_ast(dest);
     int src_len_ast, cvlen;
     if (A_TYPEG(src) == A_INTR && A_OPTYPEG(src) == I_NULL)

tools/flang1/flang1exe/semutil2.c

@@ -10900,7 +10900,7 @@ get_dtype_init_template(DTYPE dtype)
   SPTR tag_sptr = get_struct_tag_sptr(element_dtype);
   int init_ict = get_struct_initialization_tree(element_dtype);
   ACL *aclp, *tmpl_aclp;
-  SPTR sptr;
+  SPTR sptr = NOSYM;
   char namebuf[128];
   int sc = SC_STATIC;
   const char prefix[] = "_dtInit";
@@ -10909,9 +10909,11 @@ get_dtype_init_template(DTYPE dtype)
          "get_dtype_init_template: element dtype not derived",
          dtype, ERR_Fatal);
   aclp = get_getitem_p(init_ict);
-  assert(eq_dtype(DDTG(aclp->dtype), element_dtype),
-         "get_dtype_init_template: element dtype mismatch",
-         dtype, ERR_Fatal);
+  if (aclp) {
+    assert(eq_dtype(DDTG(aclp->dtype), element_dtype),
+           "get_dtype_init_template: element dtype mismatch",
+           dtype, ERR_Fatal);
+  }
 
   if (is_unresolved_parameterized_dtype(element_dtype))
     return NOSYM;
@@ -10928,21 +10930,23 @@ get_dtype_init_template(DTYPE dtype)
   namebuf[sizeof namebuf - 1] = '\0'; /* Windows snprintf bug workaround */
 
   /* no existing initialization template yet for this derived type; build one */
-  if (sc == SC_EXTERN) {
-    sptr = mk_external_var(namebuf, element_dtype);
-  } else {
-    sptr = getccssym_sc(prefix, (int) element_dtype, ST_VAR, sc);
-    DTYPEP(sptr, element_dtype);
-  }
-  DCLDP(sptr, TRUE);
-  INITIALIZERP(sptr, TRUE);
-
-  tmpl_aclp = GET_ACL(15);
-  *tmpl_aclp = *aclp;
-  tmpl_aclp->sptr = sptr;
-  dinit((VAR *)NULL, tmpl_aclp);
-  if (tag_sptr > NOSYM)
-    TYPDEF_INITP(tag_sptr, sptr);
+  if (aclp) {
+    if (sc == SC_EXTERN) {
+      sptr = mk_external_var(namebuf, element_dtype);
+    } else {
+      sptr = getccssym_sc(prefix, (int) element_dtype, ST_VAR, sc);
+      DTYPEP(sptr, element_dtype);
+    }
+    DCLDP(sptr, TRUE);
+    INITIALIZERP(sptr, TRUE);
+
+    tmpl_aclp = GET_ACL(15);
+    *tmpl_aclp = *aclp;
+    tmpl_aclp->sptr = sptr;
+    dinit((VAR *)NULL, tmpl_aclp);
+    if (tag_sptr > NOSYM)
+      TYPDEF_INITP(tag_sptr, sptr);
+  }
   return sptr;
 }