Add F2008 polymorphic allocatable assignment

This also fixes Flang issues #244 and #721.

include/flang/Error/errmsg-in.n

@@ -1527,3 +1527,4 @@ A DO CONCURRENT variable with LOCAL_INIT locality must have a host variable of t
 .MS S 1214 "PGI Accelerator $ data clause may not follow a device_type clause."
 .MS S 1215 "OpenACC data clause expected after $."
 .MS S 1216 "Expression in assignment statement contains type bound procedure name $. This may be a function call that's missing parentheses."
+.MS S 1217 "Left hand side of polymorphic assignment must be allocatable - $"

runtime/flang/type.c

@@ -35,6 +35,8 @@ static TYPE_DESC * get_parent_pointer(TYPE_DESC *src_td, __INT_T level);
 static void sourced_alloc_and_assign_array(int extent, char *ab, char *bb, TYPE_DESC *td);
 static void sourced_alloc_and_assign_array_from_scalar(int extent, char *ab, char *bb, TYPE_DESC *td);
 
+static void get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd, int *dest_sz, int *src_sz, int *dest_is_array, int *src_is_array, TYPE_DESC **tad, TYPE_DESC **tbd, __INT_T flag);
+
 #define ARG1_PTR 0x1
 #define ARG1_ALLOC 0x2
 #define ARG2_PTR 0x4
@@ -272,6 +274,58 @@ void ENTF90(SET_TYPE, set_type)(F90_Desc *dd, OBJECT_DESC *td)
   }
 }
 
+/** \brief Check whether two polymorphic types are conformable.
+ *
+ *  This routine is similar to the conformable routines in rdst.c, but
+ *  it is for two polymorphic scalar objects instead of arrays.
+ *
+ *  This is needed in polymorphic allocatable assignment. If two types
+ *  are conformable or the type of the left hand side expression is large
+ *  enough to hold the value(s) on the right hand side, then we do not have
+ *  to reallocate the left hand side if it's already allocated.
+ *
+ *  \param ab is the address of the first object.
+ *  \param ab is the first object's descriptor.
+ *  \param bd is the second object's descriptor.
+ *  \param flag can be 0, 1, 2.  See flag's description for poly_asn().
+ *
+ *  \return 1 if types are conformable; 0 if types are not conformable but
+ *          \param ab is big enough to hold \param bd; -1 if \param ab is not
+ *          conformable, not big enough, or not allocated.
+ */
+int ENTF90(POLY_CONFORM_TYPES, poly_conform_types)(char *ab, F90_Desc *ad, 
+                                                   F90_Desc *bd, __INT_T flag)
+{
+  /* Possible return values. Do not change the integer values */
+  typedef enum {
+    NOT_BIG_ENOUGH = -1, /* not conformable, not big enough */
+    BIG_ENOUGH = 0,      /* not conformable but big enough */
+    CONFORMABLE = 1      /* conformable */
+  } CONFORM_TYPES;
+
+  OBJECT_DESC *src = (OBJECT_DESC *)bd;
+  OBJECT_DESC *dest = (OBJECT_DESC *)ad;
+  TYPE_DESC *src_td, *dest_td;
+  int src_sz, dest_sz;
+  int src_is_array = 0, dest_is_array = 0;
+
+  if (!I8(__fort_allocated)(ab)) {
+    return NOT_BIG_ENOUGH;
+  }
+
+  get_source_and_dest_sizes(ad, bd, &dest_sz, &src_sz, &dest_is_array, 
+                            &src_is_array, &dest_td, &src_td, flag);
+
+  if (dest_td != 0 && src_td != 0) {
+    if (dest_td == src_td && dest_sz == src_sz) {
+      return CONFORMABLE;
+    } else if (dest_sz >= src_sz) {
+      return BIG_ENOUGH;
+    } 
+  } 
+  return NOT_BIG_ENOUGH;
+}  
+
 void ENTF90(TEST_AND_SET_TYPE, test_and_set_type)(F90_Desc *dd, OBJECT_DESC *td)
 {
   OBJECT_DESC *td2 = (OBJECT_DESC *)dd;
@@ -297,7 +351,7 @@ ENTF90(GET_OBJECT_SIZE, get_object_size)(F90_Desc *d)
     return 0;
 
   td = od->type;
-  return td ? td->obj.size : od->size;
+  return td && td != I8(__f03_ty_to_id)[__STR] ? td->obj.size : od->size;
 }
 
 __INT8_T
@@ -310,7 +364,8 @@ ENTF90(KGET_OBJECT_SIZE, kget_object_size)(F90_Desc *d)
     return 0;
 
   td = od->type;
-  return (__INT8_T)(td ? td->obj.size : od->size);
+  return (__INT8_T)(td && td != I8(__f03_ty_to_id)[__STR] ? td->obj.size : 
+                    od->size);
 }
 
 /** \brief Compute address of an element in a polymorphic array.
@@ -975,21 +1030,35 @@ sourced_alloc_and_assign_array_from_scalar(int extent, char *ab, char *bb,
   }
 }
 
-void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
-                                __INT_T flag)
+/** \brief Computes destination/first object and source/second object  sizes 
+ *         and other variables used by the poly_asn() and poly_conform_types()
+ *         routines.
+ *
+ *  \param ad is the destination/first descriptor in a polymorphic assignment
+ *         or polymorphic type conformance test.
+ *  \param bd is the source/second descriptor in a polymorphic assignment or
+ *         polymorphic type conformance test.
+ *  \param dest_sz is used to return the destination/first object's size.
+ *  \param src_sz is used to return the source/second object's size.
+ *  \param dest_is_array stores whether the destination/first object is an 
+ *         array.
+ *  \param src_is_array stores whether the source/second object is an array.
+ *  \param tad is used to return the destination/first object's type descriptor.
+ *  \param tbd is used to return the source/second object's type descriptor.
+ *  \param flag can be 0, 1, 2.  See flag's description for poly_asn().
+ */ 
+static void
+get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd,
+                          int *dest_sz, int *src_sz, 
+                          int *dest_is_array, int *src_is_array,
+                          TYPE_DESC **tad, TYPE_DESC **tbd,
+                          __INT_T flag)
 {
-  /* Copy the contents of object bb to object ab
-   * Assumes destination descriptor, ad, is a full descriptor.
-   * If flag == 0, then source descriptor, bd, is a scalar "fake" descriptor
-   * If flag == 1, assume full descriptor for bd
-   * If flag == 2, assume full descriptor for bd and copy bd into ad.
-   */
-
   OBJECT_DESC *src = (OBJECT_DESC *)bd;
   OBJECT_DESC *dest = (OBJECT_DESC *)ad;
   TYPE_DESC *src_td, *dest_td;
-  int src_sz, dest_sz, sz;
-  int dest_is_array, src_is_array, i;
+
+  *dest_is_array = *src_is_array = 0;
 
   if (dest) {
     dest_td = dest->type ? dest->type : (TYPE_DESC *)ad;
@@ -1002,48 +1071,72 @@ void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
   } else {
     src_td = 0;
   }
-  dest_is_array = src_is_array = 0;
+
   if (src_td) {
     if (bd && bd->tag == __DESC && bd->rank > 0) {
-      src_sz = bd->lsize * (size_t)src_td->obj.size;
-      src_is_array = 1;
+      *src_sz = bd->lsize * (size_t)src_td->obj.size;
+      *src_is_array = 1;
     } else if (src_td->obj.baseTag == __STR) {
-      src_sz = (size_t)(ad->len * ad->lsize);
-      src_is_array = 1;
+      *src_sz = (size_t)(ad->len * ad->lsize); 
+      *src_is_array = 1;
     } else if (bd && (flag || bd->tag == __POLY || bd->tag == __DESC)) {
-      src_sz = (size_t)src_td->obj.size;
+      *src_sz = (size_t)src_td->obj.size;
     } else {
-      src_sz = 0;
+      *src_sz = 0;
     }
   } else if (bd && !flag && ISSCALAR(bd) && bd->tag != __POLY &&
              bd->tag < __NTYPES) {
 #if defined(WINNT)
-    src_sz = __get_fort_size_of(bd->tag);
+    *src_sz = __get_fort_size_of(bd->tag);
 #else
-    src_sz = __fort_size_of[bd->tag];
+    *src_sz = __fort_size_of[bd->tag];
 #endif
   } else {
-    src_sz = 0;
+    *src_sz = 0;
   }
 
   if (dest_td) {
     if (ad && ad->tag == __DESC && ad->rank > 0) {
-      dest_sz = ad->lsize * (size_t)dest_td->obj.size;
-      dest_is_array = 1;
+      *dest_sz = ad->lsize * (size_t)dest_td->obj.size;
+      *dest_is_array = 1;
     } else if (ad && ad->tag == __DESC && dest_td &&
                dest_td->obj.tag == __POLY && ad->len > 0 && !ad->lsize &&
                !ad->gsize && ad->kind > 0 && ad->kind < __NTYPES) {
-      dest_sz = (size_t)dest_td->obj.size * ad->len;
-    } else if (!src_sz || (ad && ad->tag == __DESC && dest_td &&
-                           dest_td->obj.tag == __POLY)) {
-      dest_sz = (size_t)dest_td->obj.size;
+      *dest_sz = (size_t)dest_td->obj.size * ad->len;
+    } else if (!*src_sz || ((flag == 1 || (ad && ad->tag == __DESC)) && 
+                           dest_td->obj.tag == __POLY)) { 
+      *dest_sz = (size_t)dest_td->obj.size;
     } else {
-      dest_sz = 0;
+      *dest_sz = 0;
     }
   } else {
-    dest_sz = 0;
+    *dest_sz = 0;
   }
 
+  *tad = dest_td;
+  *tbd = src_td;
+
+}
+
+void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
+                                __INT_T flag)
+{
+  /* Copy the contents of object bb to object ab
+   * Assumes destination descriptor, ad, is a full descriptor.
+   * If flag == 0, then source descriptor, bd, is a scalar "fake" descriptor
+   * If flag == 1, assume full descriptor for bd
+   * If flag == 2, assume full descriptor for bd and copy bd into ad.
+   */
+
+  OBJECT_DESC *src = (OBJECT_DESC *)bd;
+  OBJECT_DESC *dest = (OBJECT_DESC *)ad;
+  TYPE_DESC *src_td, *dest_td;
+  int src_sz, dest_sz, sz;
+  int dest_is_array, src_is_array, i;
+
+  get_source_and_dest_sizes(ad, bd, &dest_sz, &src_sz, &dest_is_array,
+                            &src_is_array, &dest_td, &src_td, flag);
+
   if (src_sz && src_td && src_td->obj.tag == __POLY &&
       (!ad || ad->tag != __DESC || !dest_td || dest_td->obj.tag != __POLY))
     sz = src_sz;
@@ -1063,7 +1156,7 @@ void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
     for (i = 0; i < sz; i += src_sz) {
       __fort_bcopy(ab + i, bb, src_sz);
     }
-  } else {
+  } else { 
     __fort_bcopy(ab, bb, sz);
   }
 
@@ -1083,11 +1176,11 @@ void ENTF90(POLY_ASN, poly_asn)(char *ab, F90_Desc *ad, char *bb, F90_Desc *bd,
   if (flag) {
     if (src_td && (src_td->obj.tag > 0 && src_td->obj.tag < __NTYPES) &&
         !src_is_array && !dest_is_array) {
-      sourced_alloc_and_assign(ab, bb, src_td);
+      sourced_alloc_and_assign(ab, bb, src_td->obj.type);
     } else if (dest_is_array && src_is_array) {
-      sourced_alloc_and_assign_array(ad->lsize, ab, bb, dest_td);
+      sourced_alloc_and_assign_array(ad->lsize, ab, bb, dest_td->obj.type);
     } else if (dest_is_array) {
-      sourced_alloc_and_assign_array_from_scalar(ad->lsize, ab, bb, dest_td);
+      sourced_alloc_and_assign_array_from_scalar(ad->lsize, ab, bb, dest_td->obj.type);
     }
   }
 }

tools/flang1/flang1exe/dpm_out.c

@@ -2222,7 +2222,7 @@ set_type_in_descriptor(int descriptor_ast, int sptr, DTYPE dtype0,
     type_ast = mk_unop(OP_VAL, mk_cval1(dtype_arg_ast, DT_INT), DT_INT);
   }
 
-  if (type_ast > 0) {
+  if (type_ast > 0 && type_ast != descriptor_ast) {
     int argt = mk_argt(2), astnew;
     int func_ast = mk_id(sym_mkfunc_nodesc(mkRteRtnNm(func), DT_NONE));
     ARGT_ARG(argt, 0) = descriptor_ast;

tools/flang1/flang1exe/lowerilm.c

@@ -3000,7 +3000,8 @@ lower_stmt(int std, int ast, int lineno, int label)
       case A_SUBSCR:
         object = A_LOPG(src);
         sptr = find_pointer_variable(object);
-        dtype = DTYPEG(sptr);
+        dtype = (src_dtype && CLASSG(sptr) && DTY(src_dtype) == TY_ARRAY) ? 
+                src_dtype : DTYPEG(sptr);
         if (DTY(dtype) == TY_ARRAY)
           isarray = 1;
         if (isarray && (!ADJARRG(sptr) || RESULTG(sptr))) {

tools/flang1/flang1exe/lowersym.c

@@ -4709,8 +4709,10 @@ propagate_byval_visit(int sptr)
 void
 lower_symbols(void)
 {
-  int sptr;
+  SPTR sptr;
   FILE *tfile;
+  bool is_interface;
+  SPTR scope;
 
   if (OUTPUT_DWARF)
     scan_for_dwarf_module();
@@ -4740,26 +4742,29 @@ lower_symbols(void)
       lower_put_datatype_stb(BASETYPEG(sptr));
     }
     if (VISITG(sptr) && is_procedure_ptr(sptr)) {
-      /* FS#18789 - make sure we lower type and subtype of procedure ptr */
+      /* make sure we lower type and subtype of procedure ptr */
       int dtype = DTYPEG(sptr);
       lower_put_datatype_stb(dtype);
       lower_put_datatype_stb(DTY(dtype + 1));
     }
-    if (0 && VISITG(sptr) && STYPEG(sptr) == ST_TYPEDEF) {
-      int tag = DTY(DTYPEG(sptr) + 3);
-      if (VISITG(tag)) {
-        int sdsc = SDSCG(tag);
+    scope = SCOPEG(sptr);
+    is_interface = ((STYPEG(scope) == ST_PROC || STYPEG(scope) == ST_ENTRY) &&
+    IS_INTERFACEG(scope));
+
+    if (!is_interface && STYPEG(sptr) == ST_TYPEDEF) {
+      SPTR tag = DTY(DTYPEG(sptr) + 3);
+      if (!VISITG(tag)) {
+        SPTR sdsc = SDSCG(tag);
+        lower_put_datatype_stb(DTYPEG(tag));
+        lower_symbol_stb(tag);
+        VISITP(tag, 1);
         if (sdsc && !VISITG(sdsc)) {
           VISITP(sdsc, 1);
           lower_put_datatype_stb(DTYPEG(sdsc));
         }
       }
     } else if (!VISITG(sptr) && CLASSG(sptr) && DESCARRAYG(sptr) &&
                STYPEG(sptr) == ST_DESCRIPTOR) {
-      SPTR scope = SCOPEG(sptr);
-      bool is_interface =
-          ((STYPEG(scope) == ST_PROC || STYPEG(scope) == ST_ENTRY) &&
-           IS_INTERFACEG(scope));
       if (PARENTG(sptr) && !is_interface) {
         /* Only perform this if PARENT is set. Also do not create type
          * descriptors for derived types defined inside interfaces. When

tools/flang1/flang1exe/semant3.c

@@ -550,11 +550,8 @@ semant3(int rednum, SST *top)
       } else {
         sptr = SST_SYMG(RHS(2));
       }
-      if (CLASSG(sptr) && !MONOMORPHICG(sptr)) {
-        error(155, 3, gbl.lineno,
-              "Left hand side of assignment"
-              " cannot be polymorphic -",
-              SYMNAME(sptr));
+      if (CLASSG(sptr) && !MONOMORPHICG(sptr) && !ALLOCATTRG(sptr)) {
+        error(1217, ERR_Severe, gbl.lineno, SYMNAME(sptr), CNULL);
       }
       chk_and_rewrite_cmplxpart_assn(RHS(2), RHS(5));
 
@@ -4091,7 +4088,7 @@ semant3(int rednum, SST *top)
                  */
 
                 int new_sym, dty2, sz, dest_ast;
-                int flag_con = 1;
+                int flag_con = 2;
                 dty2 = dtype;
                 dest_ast = 0;
                 fidx = RTE_poly_asn;

tools/flang1/flang1exe/semstk.h

@@ -1,5 +1,5 @@
 /*
- * Copyright (c) 1994-2018, NVIDIA CORPORATION.  All rights reserved.
+ * Copyright (c) 1994-2019, 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.
@@ -266,7 +266,7 @@ INT chk_scalar_inttyp(SST *, int, char *);
 INT chk_arr_extent(SST *, char *);
 INT chksubscr(SST *, int);
 int casttyp(SST *, int);
-void cngtyp(SST *, int);
+void cngtyp(SST *, DTYPE);
 void cngshape(SST *, SST *);
 LOGICAL chkshape(SST *, SST *, LOGICAL);
 int chklog(SST *);