Implement fixed- and deferred-length character in array constructor

gklimowicz · gklimowicz · commit 0918a2f2db72 · 2018-09-30T22:21:33.000-07:00
It works with the following 14 cases for both fixed-length
and deferred-length character arrays:
    1) b = a
    2) b = [ a(1), a(2), a(3), a(4) ]
    3) b = [ a ]
    4) b = [ character(len=newlen) :: a, c ]
    5) b = [ character(len=newlen) :: c, a ]
    6) b = [ (a(n), n=1,size(a)) ]
    7) b = [ character(len=len(a)) :: (a(n), n=1,size(a)) ]
    8) b = [ character(len=newlen) :: (a(n), n=1,size(a)), c ]
    9) b = [ character(len=len(a)) :: a ]
    10) b = [ a(1:2) ]
    11) b = [ character(len=len(a)) :: a(:) ]
    12) b = [ character(len=newlen) :: a(:), c ]
    13) b = [ character(len=newlen) :: c, a(:) ]
    14) b = [ character(len=newlen) :: a(1:2), c, a(3:) ]

For fixed-length character arrays:
    character(len=8), allocatable :: a(:)
    character(len=8), allocatable :: b(:)
    character(len=8), allocatable :: c
    a = [ character(len=8) :: "1","2","3","4" ]
    c = "w"

For deferred-length character arrays:
    character(len=:), allocatable :: a(:)
    character(len=:), allocatable :: b(:)
    character(len=:), allocatable :: c
    a = [ character(len=8) :: "1","2","3","4" ]
    c = "w"
diff --git a/tools/flang1/flang1exe/dtypeutl.c b/tools/flang1/flang1exe/dtypeutl.c
@@ -573,7 +573,13 @@ size_ast(int sptr, DTYPE dtype)
     if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR
         || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
         ) {
-      clen = ast_intr(I_LEN, astb.bnd.dtype, 1, mk_id(sptr));
+      if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR
+       || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
+      ) {
+        clen = ast_intr(I_LEN, astb.bnd.dtype, 1, mk_id(sptr));
+      } else {
+        clen = DTY(dtype+1);
+      }
     } else if (ADJLENG(sptr) && !F90POINTERG(sptr)) {
       /* don't add CVLEN for local automatic character */
       clen = CVLENG(sptr);
@@ -2387,6 +2393,86 @@ getast(int ast, char *string)
   } /* switch */
 } /* getast */
 
+/** \brief Check if ast is deferred-length character  */
+bool
+is_deferlenchar_ast(int ast)
+{
+  DTYPE dt;
+  SPTR sym = 0;
+
+  dt = DDTG(A_DTYPEG(ast));
+  if (DTY(dt) != TY_CHAR && DTY(dt) != TY_NCHAR) {
+    return false;
+  }
+
+  if (dt ==  DT_ASSCHAR || dt ==  DT_ASSNCHAR) {
+    return false;
+  } else if (dt == DT_DEFERCHAR || dt == DT_DEFERNCHAR) {
+    return true;
+  }
+
+  if (ast_is_sym(ast)) {
+    sym = memsym_of_ast(ast);
+  }
+
+  /* adjustable length character */
+  if ((sym > NOSYM) && ADJLENG(sym)) {
+    return false;
+  }
+
+  if (DTY(A_DTYPEG(ast)) == TY_ARRAY) {
+    if (ADD_DEFER(A_DTYPEG(ast))) {
+      dt = DTY(DDTG(A_DTYPEG(ast)) + 1);
+      if (A_TYPEG(dt) != A_CNST) {
+        return true;
+      }
+    }
+  }
+  return false;
+}
+
+/** \brief Check if dtype is deferred-length character */
+bool
+is_deferlenchar_dtype(DTYPE dtype)
+{
+  DTYPE dt;
+
+  dt = DDTG(dtype);
+  if (DTY(dt) != TY_CHAR && DTY(dt) != TY_NCHAR) {
+    return false;
+  }
+
+  if (dt == DT_DEFERCHAR || dt == DT_DEFERNCHAR) {
+    return true;
+  }
+  dt = DTY(dt+1);
+  if (DTY(dtype) == TY_ARRAY) {
+    if (!ADD_DEFER(dtype)) {
+      return false;
+    }
+  }
+
+  if (A_TYPEG(dt) == A_ID) {
+    /* i.e. character(len=newlen) */
+    if (ASSNG(A_SPTRG(dt))) {
+      return true;
+    }
+  } else if (A_TYPEG(dt) == A_SUBSCR) {
+    /* i.e. character(len=newlen(1)) */
+    if (ASSNG(memsym_of_ast(dt))) {
+      return true;
+    }
+  }
+
+  /* i.e. character(len=len(a)) */
+  if ((A_TYPEG(dt) == A_FUNC || A_TYPEG(dt) == A_INTR)
+    && is_deferlenchar_ast(ARGT_ARG(A_ARGSG(dt), 0))) {
+    return true;
+  }
+  return false;
+}
+
+
 /** \brief Put into the character array pointed to by ptr, the print
    representation
     of dtype.
diff --git a/tools/flang1/flang1exe/dtypeutl.h b/tools/flang1/flang1exe/dtypeutl.h
@@ -1,5 +1,5 @@
 /*
- * Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
+ * Copyright (c) 2016-2018, NVIDIA CORPORATION.  All rights reserved.
  *
  * Licensed under the Apache License, Version 2.0 (the "License");
  * you may not use this file except in compliance with the License.
@@ -111,3 +111,5 @@ 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);
+bool is_deferlenchar_ast(int);
+bool is_deferlenchar_dtype(DTYPE);
diff --git a/tools/flang1/flang1exe/lowersym.c b/tools/flang1/flang1exe/lowersym.c
@@ -101,6 +101,12 @@ static void lower_fileinfo_llvm();
 static LOGICAL llvm_iface_flag = FALSE;
 static void stb_lower_sym_header();
 
+/** \brief 
+ * ASSCHAR = -1 assumed size character
+ * ADJCHAR = -2 backend maps to DT_ASSCHAR 
+ * DEFERCHAR = -3 deferred-length character */
+enum LEN {ASSCHAR = -1, ADJCHAR = -2, DEFERCHAR = -3};
+
 /** \brief Returns true if the procedure (sptr) has optional arguments. 
  */
 static bool
@@ -2433,7 +2439,7 @@ eval_con_expr(int ast, int *val, int *dtyp)
 static void
 lower_put_datatype(int dtype, int usage)
 {
-  int ndim, i, sptr, zbase, numelm;
+  int ndim, i, zbase, numelm;
   int dty, iface;
   /* if this was a 'stashed' old datatype */
   if (DTY(dtype) < 0)
@@ -2586,9 +2592,9 @@ lower_put_datatype(int dtype, int usage)
   case TY_CHAR:
     putwhich("character", "c");
     if (dtype == DT_ASSCHAR) {
-      putval("len", -1);
+      putval("len", ASSCHAR);
     } else if (dtype == DT_DEFERCHAR) {
-      putval("len", -3);
+      putval("len", DEFERCHAR);
     } else {
       int clen = DTY(dtype + 1);
       if (A_ALIASG(clen)) {
@@ -2597,16 +2603,20 @@ lower_put_datatype(int dtype, int usage)
         clen = CONVAL2G(clen);
         putval("len", clen);
       } else {
-        putval("len", -2 /* which backend maps to DT_ASSCHAR */);
+        if (sem.gcvlen && is_deferlenchar_dtype(dtype)) {
+          putval("len", DEFERCHAR);
+        } else {
+          putval("len", ADJCHAR);
+        }
       }
     }
     break;
   case TY_NCHAR:
     putwhich("kcharacter", "k");
     if (dtype == DT_ASSNCHAR) {
-      putval("len", -1);
+      putval("len", ASSCHAR);
     } else if (dtype == DT_DEFERNCHAR) {
-      putval("len", -3);
+      putval("len", DEFERCHAR);
     } else {
       int clen = DTY(dtype + 1);
       if (A_ALIASG(clen)) {
@@ -2615,7 +2625,7 @@ lower_put_datatype(int dtype, int usage)
         clen = CONVAL2G(clen);
         putval("len", clen);
       } else {
-        putval("len", -1);
+        putval("len", ASSCHAR);
       }
     }
     break;
diff --git a/tools/flang1/flang1exe/semutil2.c b/tools/flang1/flang1exe/semutil2.c
@@ -751,19 +751,6 @@ add_p_dealloc_item(int sptr)
   sem.p_dealloc = itemp;
 }
 
-/** \brief Given an allocatable array and an explicit shape list which has been
-           deposited in the semant 'bounds' structure, generate assignments to
-           the arrays bounds temporaries, and allocate the array.  Save the id
-   ast
-           of the array for an ensuing deallocate of the array.
- */
-void
-gen_allocate_array(int arr)
-{
-  int alloc_obj = gen_defer_shape(arr, 0, arr);
-  (void)gen_alloc_dealloc(TK_ALLOCATE, alloc_obj, 0);
-  add_p_dealloc_item(arr);
-}
 
 /** \brief Generate deallocates for the temporary arrays in the sem.p_delloc
  * list.
@@ -1011,7 +998,6 @@ typedef struct {
 } _ACS;
 
 static _ACS acs;
-
 static LOGICAL _can_fold(int);
 static void constructf90(int, ACL *);
 static void _dinit_acl(ACL *, LOGICAL);
@@ -1033,6 +1019,24 @@ iexpr_op(int op)
   return "?N?";
 }
 
+/** \brief Given an allocatable array and an explicit shape list which has been
+           deposited in the semant 'bounds' structure, generate assignments to
+           the arrays bounds temporaries, and allocate the array.  Save the id
+   ast
+           of the array for an ensuing deallocate of the array.
+ */
+void
+gen_allocate_array(int arr)
+{
+  int alloc_obj = gen_defer_shape(arr, 0, arr);
+  if (is_deferlenchar_dtype(acs.arrtype)) {
+    get_static_descriptor(arr);
+    get_all_descriptors(arr);
+  }
+  gen_alloc_dealloc(TK_ALLOCATE, alloc_obj, 0);
+  add_p_dealloc_item(arr);
+}
+
 #if DEBUG
 static void
 _printacl(int in_array, ACL *aclp, FILE *f)
@@ -1491,6 +1495,9 @@ chk_constructor(ACL *aclp, DTYPE dtype)
     sem.arrdim.ndefer = 1;
     acs.is_const = FALSE;
   }
+  if (sem.gcvlen && is_deferlenchar_dtype(acs.eltype)) {
+    sem.arrdim.ndefer = 1;
+  }
   aclp->size = sem.bounds[0].upast;
 
   acs.arrtype = mk_arrdsc();
@@ -1669,6 +1676,7 @@ init_sptr_w_acl(int in_sptr, ACL *aclp)
     if (sem.arrdim.ndefer) {
       ALLOCATE_ARRAYS = 0; /* allocate for these array temps is done here */
     }
+
       sptr = acs.tmp = get_arr_temp(acs.arrtype, FALSE, FALSE, FALSE);
     ALLOCATE_ARRAYS = 1;
     if (sem.arrdim.ndefer) {
@@ -1767,13 +1775,17 @@ compute_size_ast(bool add_flag, ACL *aclp, DTYPE dtype)
 static DTYPE
 compute_size_expr(bool add_flag, ACL *aclp, DTYPE dtype)
 {
+  DTYPE dt2, dtype2;
   SST *stkp = aclp->u1.stkp;
   LOGICAL specified_dtype = dtype != 0;
-  DTYPE dt = dtype;
+  DTYPE dt = DDTG(dtype);
+  dtype2 = SST_DTYPEG(stkp);
+  dt2 = DDTG(SST_DTYPEG(stkp));
   if (!specified_dtype) {
-    dtype = SST_DTYPEG(stkp);
-    dt = DDTG(dtype);
+    dtype = dtype2;
+    dt = dt2;
   }
+
   if (acs.eltype == 0 || acs.zln) {
     int id = SST_IDG(stkp);
     if (acs.eltype != 0) {
@@ -1786,15 +1798,21 @@ compute_size_expr(bool add_flag, ACL *aclp, DTYPE dtype)
           || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
       ) {
         dt = adjust_ch_length(dt, SST_ASTG(stkp));
+      } else if (dt == DT_ASSCHAR || dt == DT_DEFERCHAR
+          || dt == DT_ASSNCHAR || dt == DT_DEFERNCHAR
+      ) {
+        dt = fix_dtype(SST_SYMG(stkp), dt);
       }
     }
     /* need to change the type for the first element too */
     if (specified_dtype && acs.eltype == 0 &&
         add_flag) { /* if we're in a struct, don't do */
       if (DTY(dt) == TY_CHAR && DTY(dtype) == TY_CHAR)
-        ;
+        if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
+          dtype = SST_DTYPEG(stkp);
       else if (DTY(dt) == TY_NCHAR && DTY(dtype) == TY_NCHAR)
-        ;
+        if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
+          dtype = SST_DTYPEG(stkp);
       else if (DTY(dtype) == TY_ARRAY) {
         if (DDTG(dtype) != dt) {
           errsev(95);
@@ -1818,10 +1836,12 @@ compute_size_expr(bool add_flag, ACL *aclp, DTYPE dtype)
      * causes S_CONST to become S_EXPR.
      */
     if (add_flag) { /* if we're in a struct, don't do */
-      if (DTY(acs.eltype) == TY_CHAR && DTY(dtype) == TY_CHAR)
-        ;
-      else if (DTY(acs.eltype) == TY_NCHAR && DTY(dtype) == TY_NCHAR)
-        ;
+      if (DTY(dt) == TY_CHAR && DTY(dtype) == TY_CHAR)
+        if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
+          dtype = SST_DTYPEG(stkp);
+      else if (DTY(dt) == TY_NCHAR && DTY(dtype) == TY_NCHAR)
+        if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
+          dtype = SST_DTYPEG(stkp);
       else if (DTY(dtype) == TY_ARRAY) {
         if (!eq_dtype(DDTG(dtype), acs.eltype)) {
           errsev(95);
@@ -2328,6 +2348,9 @@ get_shape_arraydtype(int shape, int eltype)
     }
   }
 
+  if (is_deferlenchar_dtype(acs.arrtype))
+    sem.arrdim.ndefer = 1;
+
   arrtype = mk_arrdsc();
   DTY(arrtype + 1) = eltype;
   return arrtype;
@@ -2364,7 +2387,11 @@ mkexpr_assign_temp(SST *stkptr)
   /* if we have an array expression, we need to assign it to
      a temporary so that we can subscript it. */
   if (DTY(dtype = SST_DTYPEG(stkptr)) == TY_ARRAY && !simple) {
-    dtype = get_shape_arraydtype(A_SHAPEG(ast), DTY(dtype + 1));
+    if (is_deferlenchar_ast(ast)) {
+      dtype = get_shape_arraydtype(A_SHAPEG(ast), DTY(acs.arrtype + 1));
+    } else {
+      dtype = get_shape_arraydtype(A_SHAPEG(ast), DTY(dtype + 1));
+    }
     id = get_arr_temp(dtype, FALSE, FALSE, FALSE);
     if (sem.arrdim.ndefer)
       gen_allocate_array(id);
@@ -7605,13 +7632,15 @@ get_ch_temp(DTYPE dtype)
   } while (dt != dtype);
 
   if (needalloc) {
+    int clen;
     ALLOCP(sptr, 1);
     /* if the length is not a constant, make it 'adjustable' */
-    if (A_ALIASG(len) == 0) {
+    if (sem.gcvlen && is_deferlenchar_dtype(dtype)) {
+      clen = ast_intr(I_LEN, astb.bnd.dtype, 1, mk_id(sptr));
+    } else if (A_ALIASG(len) == 0) {
       /* fill in CVLEN field */
       ADJLENP(sptr, 1);
       if (CVLENG(sptr) == 0) {
-        int clen;
         clen = sym_get_scalar(SYMNAME(sptr), "len", astb.bnd.dtype);
         CVLENP(sptr, clen);
       }
@@ -7626,7 +7655,8 @@ get_ch_temp(DTYPE dtype)
           if (ADD_LWBD(dtype, d) == 0)
             ADD_LWBD(dtype, d) = astb.bnd.one;
         }
-        allocate_temp(sptr);
+        if (!ADD_DEFER(DTYPEG(sptr)) || ADJLENG(sptr))
+          allocate_temp(sptr);
       }
     } else {
       allocate_temp(sptr);
@@ -11408,8 +11438,7 @@ gen_alloc_dealloc(int stmtyp, int object, ITEM *spec)
   /* This is for allocate statement, must set length before allocate
    * sem.gcvlen supposedly gets set only when it is character
    */
-  if ((DDTG(A_DTYPEG(object)) == DT_DEFERCHAR ||
-       DDTG(A_DTYPEG(object)) == DT_DEFERCHAR) &&
+  if (is_deferlenchar_ast(object) &&
       stmtyp == TK_ALLOCATE) {
     if (sem.gcvlen) {
       len_stmt =
diff --git a/tools/flang1/flang1exe/transfrm.c b/tools/flang1/flang1exe/transfrm.c
