re PR fortran/37577 ([meta-bug] change internal array descriptor format for…

re PR fortran/37577 ([meta-bug] change internal array descriptor format for better syntax, C interop TR, rank 15)

2018-25-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/37577
	* array.c (gfc_match_array_ref): If standard earlier than F2008
	it is an error if the reference dimension is greater than 7.
	libgfortran.h : Increase GFC_MAX_DIMENSIONS to 15. Change the
	dtype masks and shifts accordingly.
	* trans-array.c (gfc_conv_descriptor_dtype): Use the dtype
	type node to check the field.
	(gfc_conv_descriptor_dtype): Access the rank field of dtype.
	(duplicate_allocatable_coarray): Access the rank field of the
	dtype descriptor rather than the dtype itself.
	* trans-expr.c (get_scalar_to_descriptor_type): Store the type
	of 'scalar' on entry and use its TREE_TYPE if it is ARRAY_TYPE
	(ie. a character).
	(gfc_conv_procedure_call): Pass TREE_OPERAND (tmp,0) to
	get_scalar_to_descriptor_type if the actual expression is a
	constant.
	(gfc_trans_structure_assign): Assign the rank directly to the
	dtype rank field.
	* trans-intrinsic.c (gfc_conv_intrinsic_rank): Cast the result
	to default integer kind.
	(gfc_conv_intrinsic_sizeof): Obtain the element size from the
	'elem_len' field of the dtype.
	* trans-io.c (gfc_build_io_library_fndecls): Replace
	gfc_int4_type_node with dtype_type_node where necessary.
	(transfer_namelist_element): Use gfc_get_dtype_rank_type for
	scalars.
	* trans-types.c : Provide 'get_dtype_type_node' to acces the
	dtype_type_node and, if necessary, build it.
	The maximum size of an array element is now determined by the
	maximum value of size_t.
	Update the description of the array descriptor, including the
	type def for the dtype_type.
	(gfc_get_dtype_rank_type): Build a constructor for the dtype.
	Distinguish RECORD_TYPEs that are BT_DERIVED or BT_CLASS.
	(gfc_get_array_descriptor_base): Change the type of the dtype
	field to dtype_type_node.
	(gfc_get_array_descr_info): Get the offset to the rank field of
	the dtype.
	* trans-types.h : Add a prototype for 'get_dtype_type_node ()'.
	* trans.h : Define the indices of the dtype fields.

2018-25-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/37577
	* gfortran.dg/coarray_18.f90: Allow dimension 15 for F2008.
	* gfortran.dg/coarray_lib_this_image_2.f90: Change 'array1' to
	'array01' in the tree dump comparison.
	* gfortran.dg/coarray_lib_token_4.f90: Likewise.
	* gfortran.dg/inline_sum_1.f90: Similar - allow two digits.
	* gfortran.dg/rank_1.f90: Allow dimension 15 for F2008.

2018-25-01  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/37577
	* caf/single.c (_gfortran_caf_failed_images): Access the 'type'
	and 'elem_len' fields of the dtype instead of the shifts.
	(_gfortran_caf_stopped_images): Likewise.
	* intrinsics/associated.c (associated): Compare the 'type' and
	'elem_len' fields instead of the dtype.
	* caf/date_and_time.c : Access the dtype fields rather using
	shifts and masks.
	* io/transfer.c (transfer_array ): Comment on item count.
	(set_nml_var,st_set_nml_var): Change dtype type and use fields.
	(st_set_nml_dtio_var): Likewise.
	* libgfortran.h : Change definition of GFC_ARRAY_DESCRIPTOR and
	add a typedef for the dtype_type. Change the GFC_DTYPE_* macros
	to access the dtype fields.

From-SVN: r257065

gcc/fortran/ChangeLog

+2018-25-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37577
+	* array.c (gfc_match_array_ref): If standard earlier than F2008
+	it is an error if the reference dimension is greater than 7.
+	libgfortran.h : Increase GFC_MAX_DIMENSIONS to 15. Change the
+	dtype masks and shifts accordingly.
+	* trans-array.c (gfc_conv_descriptor_dtype): Use the dtype
+	type node to check the field.
+	(gfc_conv_descriptor_dtype): Access the rank field of dtype.
+	(duplicate_allocatable_coarray): Access the rank field of the
+	dtype descriptor rather than the dtype itself.
+	* trans-expr.c (get_scalar_to_descriptor_type): Store the type
+	of 'scalar' on entry and use its TREE_TYPE if it is ARRAY_TYPE
+	(ie. a character).
+	(gfc_conv_procedure_call): Pass TREE_OPERAND (tmp,0) to
+	get_scalar_to_descriptor_type if the actual expression is a
+	constant.
+	(gfc_trans_structure_assign): Assign the rank directly to the
+	dtype rank field.
+	* trans-intrinsic.c (gfc_conv_intrinsic_rank): Cast the result
+	to default integer kind.
+	(gfc_conv_intrinsic_sizeof): Obtain the element size from the
+	'elem_len' field of the dtype.
+	* trans-io.c (gfc_build_io_library_fndecls): Replace
+	gfc_int4_type_node with dtype_type_node where necessary.
+	(transfer_namelist_element): Use gfc_get_dtype_rank_type for
+	scalars.
+	* trans-types.c : Provide 'get_dtype_type_node' to acces the
+	dtype_type_node and, if necessary, build it.
+	The maximum size of an array element is now determined by the
+	maximum value of size_t.
+	Update the description of the array descriptor, including the
+	type def for the dtype_type.
+	(gfc_get_dtype_rank_type): Build a constructor for the dtype.
+	Distinguish RECORD_TYPEs that are BT_DERIVED or BT_CLASS.
+	(gfc_get_array_descriptor_base): Change the type of the dtype
+	field to dtype_type_node.
+	(gfc_get_array_descr_info): Get the offset to the rank field of
+	the dtype.
+	* trans-types.h : Add a prototype for 'get_dtype_type_node ()'.
+	* trans.h : Define the indices of the dtype fields.
+
 2018-23-01  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/83866

gcc/fortran/array.c

@@ -197,6 +197,11 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
 	}
     }
 
+  if (ar->dimen >= 7
+      && !gfc_notify_std (GFC_STD_F2008,
+			  "Array reference at %C has more than 7 dimensions"))
+    return MATCH_ERROR;
+
   gfc_error ("Array reference at %C cannot have more than %d dimensions",
 	     GFC_MAX_DIMENSIONS);
   return MATCH_ERROR;

gcc/fortran/libgfortran.h

@@ -150,15 +150,13 @@ typedef enum
 #define GFC_STDOUT_UNIT_NUMBER 6
 #define GFC_STDERR_UNIT_NUMBER 0
 
+/* F2003 onward. For std < F2003, error caught in array.c(gfc_match_array_ref).  */
+#define GFC_MAX_DIMENSIONS 15
 
-/* FIXME: Increase to 15 for Fortran 2008. Also needs changes to
-   GFC_DTYPE_RANK_MASK. See PR 36825.  */
-#define GFC_MAX_DIMENSIONS 7
-
-#define GFC_DTYPE_RANK_MASK 0x07
-#define GFC_DTYPE_TYPE_SHIFT 3
-#define GFC_DTYPE_TYPE_MASK 0x38
-#define GFC_DTYPE_SIZE_SHIFT 6
+#define GFC_DTYPE_RANK_MASK 0x0F
+#define GFC_DTYPE_TYPE_SHIFT 4
+#define GFC_DTYPE_TYPE_MASK 0x70
+#define GFC_DTYPE_SIZE_SHIFT 7
 
 /* Basic types.  BT_VOID is used by ISO C Binding so funcs like c_f_pointer
    can take any arg with the pointer attribute as a param.  These are also

gcc/fortran/trans-array.c

@@ -239,7 +239,8 @@ gfc_conv_descriptor_dtype (tree desc)
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 
   field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
-  gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type);
+  gcc_assert (field != NULL_TREE
+	      && TREE_TYPE (field) == get_dtype_type_node ());
 
   return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 			  desc, field, NULL_TREE);
@@ -283,10 +284,11 @@ gfc_conv_descriptor_rank (tree desc)
   tree dtype;
 
   dtype = gfc_conv_descriptor_dtype (desc);
-  tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
-  tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
-			 dtype, tmp);
-  return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
+  tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_RANK);
+  gcc_assert (tmp!= NULL_TREE
+	      && TREE_TYPE (tmp) == signed_char_type_node);
+  return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+			  dtype, tmp, NULL_TREE);
 }
 
 
@@ -8205,7 +8207,7 @@ duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src,
   else
     {
       /* Set the rank or unitialized memory access may be reported.  */
-      tmp = gfc_conv_descriptor_dtype (dest);
+      tmp = gfc_conv_descriptor_rank (dest);
       gfc_add_modify (&globalblock, tmp, build_int_cst (TREE_TYPE (tmp), rank));
 
       if (rank)

gcc/fortran/trans-expr.c

@@ -66,9 +66,10 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
 tree
 gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 {
-  tree desc, type;
+  tree desc, type, etype;
 
   type = get_scalar_to_descriptor_type (scalar, attr);
+  etype = TREE_TYPE (scalar);
   desc = gfc_create_var (type, "desc");
   DECL_ARTIFICIAL (desc) = 1;
 
@@ -81,8 +82,10 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
     }
   if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
     scalar = gfc_build_addr_expr (NULL_TREE, scalar);
+  else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
+    etype = TREE_TYPE (etype);
   gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
-		  gfc_get_dtype (type));
+		  gfc_get_dtype_rank_type (0, etype));
   gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
 
   /* Copy pointer address back - but only if it could have changed and
@@ -5323,7 +5326,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		    {
 		      tmp = parmse.expr;
 		      if (TREE_CODE (tmp) == ADDR_EXPR
-			  && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
+			   && (POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0)))
+			       || e->expr_type == EXPR_CONSTANT))
 			tmp = TREE_OPERAND (tmp, 0);
 		      parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
 								   fsym->attr);
@@ -7611,8 +7615,8 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
 		rank = 1;
 	      size = integer_zero_node;
 	      desc = field;
-	      gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
-			      build_int_cst (gfc_array_index_type, rank));
+	      gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
+			      build_int_cst (signed_char_type_node, rank));
 	    }
 	  else
 	    {

gcc/fortran/trans-intrinsic.c

@@ -2602,6 +2602,8 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
   gfc_add_block_to_block (&se->post, &argse.post);
 
   se->expr = gfc_conv_descriptor_rank (argse.expr);
+  se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
+			   se->expr);
 }
 
 
@@ -6783,6 +6785,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
   tree lower;
   tree upper;
   tree byte_size;
+  tree field;
   int n;
 
   gfc_init_se (&argse, NULL);
@@ -6805,10 +6808,13 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 	    ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
 	tmp = build_fold_indirect_ref_loc (input_location, tmp);
-      tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp));
-      tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp,
-			     build_int_cst (TREE_TYPE (tmp),
-					    GFC_DTYPE_SIZE_SHIFT));
+
+      tmp = gfc_conv_descriptor_dtype (tmp);
+      field = gfc_advance_chain (TYPE_FIELDS (get_dtype_type_node ()),
+				 GFC_DTYPE_ELEM_LEN);
+      tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+			     tmp, field, NULL_TREE);
+
       byte_size = fold_convert (gfc_array_index_type, tmp);
     }
   else if (arg->ts.type == BT_CLASS)

gcc/fortran/trans-io.c

@@ -478,12 +478,12 @@ gfc_build_io_library_fndecls (void)
   iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("st_set_nml_var")), ".w.R",
 	void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
-	gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
+	gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node());
 
   iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
 	void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
-	gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
+	gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node(),
 	pvoid_type_node, pvoid_type_node);
 
   iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
@@ -1662,7 +1662,6 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
   tree dtio_proc = null_pointer_node;
   tree vtable = null_pointer_node;
   int n_dim;
-  int itype;
   int rank = 0;
 
   gcc_assert (sym || c);
@@ -1699,8 +1698,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
     }
   else
     {
-      itype = ts->type;
-      dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
+      dt =  gfc_typenode_for_spec (ts);
+      dtype = gfc_get_dtype_rank_type (0, dt);
     }
 
   /* Build up the arguments for the transfer call.

gcc/fortran/trans-types.c

@@ -130,6 +130,47 @@ int gfc_size_kind;
 int gfc_numeric_storage_size;
 int gfc_character_storage_size;
 
+tree dtype_type_node = NULL_TREE;
+
+
+/* Build the dtype_type_node if necessary.  */
+tree get_dtype_type_node (void)
+{
+  tree field;
+  tree dtype_node;
+  tree *dtype_chain = NULL;
+
+  if (dtype_type_node == NULL_TREE)
+    {
+      dtype_node = make_node (RECORD_TYPE);
+      TYPE_NAME (dtype_node) = get_identifier ("dtype_type");
+      TYPE_NAMELESS (dtype_node) = 1;
+      field = gfc_add_field_to_struct_1 (dtype_node,
+					 get_identifier ("elem_len"),
+					 size_type_node, &dtype_chain);
+      TREE_NO_WARNING (field) = 1;
+      field = gfc_add_field_to_struct_1 (dtype_node,
+					 get_identifier ("version"),
+					 integer_type_node, &dtype_chain);
+      TREE_NO_WARNING (field) = 1;
+      field = gfc_add_field_to_struct_1 (dtype_node,
+					 get_identifier ("rank"),
+					 signed_char_type_node, &dtype_chain);
+      TREE_NO_WARNING (field) = 1;
+      field = gfc_add_field_to_struct_1 (dtype_node,
+					 get_identifier ("type"),
+					 signed_char_type_node, &dtype_chain);
+      TREE_NO_WARNING (field) = 1;
+      field = gfc_add_field_to_struct_1 (dtype_node,
+					 get_identifier ("attribute"),
+					 short_integer_type_node, &dtype_chain);
+      TREE_NO_WARNING (field) = 1;
+      gfc_finish_type (dtype_node);
+      TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (dtype_node)) = 1;
+      dtype_type_node = dtype_node;
+    }
+  return dtype_type_node;
+}
 
 bool
 gfc_check_any_c_kind (gfc_typespec *ts)
@@ -1003,7 +1044,7 @@ gfc_init_types (void)
      by the number of bits available to store this field in the array
      descriptor.  */
 
-  n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
+  n = TYPE_PRECISION (size_type_node);
   gfc_max_array_element_size
     = wide_int_to_tree (size_type_node,
 			wi::mask (n, UNSIGNED,
@@ -1255,12 +1296,21 @@ gfc_get_element_type (tree type)
 
     struct gfc_array_descriptor
     {
-      array *data
+      array *data;
       index offset;
-      index dtype;
+      struct dtype_type dtype;
       struct descriptor_dimension dimension[N_DIM];
     }
 
+    struct dtype_type
+    {
+      size_t elem_len;
+      int version;
+      signed char rank;
+      signed char type;
+      signed short attribute;
+    }
+
     struct descriptor_dimension
     {
       index stride;
@@ -1277,11 +1327,6 @@ gfc_get_element_type (tree type)
    are gfc_array_index_type and the data node is a pointer to the
    data.  See below for the handling of character types.
 
-   The dtype member is formatted as follows:
-    rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
-    type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
-    size = dtype >> GFC_DTYPE_SIZE_SHIFT
-
    I originally used nested ARRAY_TYPE nodes to represent arrays, but
    this generated poor code for assumed/deferred size arrays.  These
    require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
@@ -1468,9 +1513,10 @@ gfc_get_dtype_rank_type (int rank, tree etype)
 {
   tree size;
   int n;
-  HOST_WIDE_INT i;
   tree tmp;
   tree dtype;
+  tree field;
+  vec<constructor_elt, va_gc> *v = NULL;
 
   switch (TREE_CODE (etype))
     {
@@ -1490,18 +1536,21 @@ gfc_get_dtype_rank_type (int rank, tree etype)
       n = BT_COMPLEX;
       break;
 
-    /* We will never have arrays of arrays.  */
     case RECORD_TYPE:
-      n = BT_DERIVED;
+      if (GFC_CLASS_TYPE_P (etype))
+	n = BT_CLASS;
+      else
+	n = BT_DERIVED;
       break;
 
+    /* We will never have arrays of arrays.  */
     case ARRAY_TYPE:
       n = BT_CHARACTER;
       break;
 
     case POINTER_TYPE:
       n = BT_ASSUMED;
-      break;
+    break;
 
     default:
       /* TODO: Don't do dtype for temporary descriptorless arrays.  */
@@ -1509,32 +1558,27 @@ gfc_get_dtype_rank_type (int rank, tree etype)
       return gfc_index_zero_node;
     }
 
-  gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
   size = TYPE_SIZE_UNIT (etype);
+  if (n == BT_CHARACTER && size == NULL_TREE)
+    size = TYPE_SIZE_UNIT (TREE_TYPE (etype));
 
-  i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
-  if (size && INTEGER_CST_P (size))
-    {
-      if (tree_int_cst_lt (gfc_max_array_element_size, size))
-	gfc_fatal_error ("Array element size too big at %C");
+  tmp = get_dtype_type_node ();
+  field = gfc_advance_chain (TYPE_FIELDS (tmp),
+			     GFC_DTYPE_ELEM_LEN);
+  CONSTRUCTOR_APPEND_ELT (v, field,
+			  fold_convert (TREE_TYPE (field), size));
 
-      i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
-    }
-  dtype = build_int_cst (gfc_array_index_type, i);
+  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+			     GFC_DTYPE_RANK);
+  CONSTRUCTOR_APPEND_ELT (v, field,
+			  build_int_cst (TREE_TYPE (field), rank));
 
-  if (size && !INTEGER_CST_P (size))
-    {
-      tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
-      tmp  = fold_build2_loc (input_location, LSHIFT_EXPR,
-			      gfc_array_index_type,
-			      fold_convert (gfc_array_index_type, size), tmp);
-      dtype = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-			       tmp, dtype);
-    }
-  /* If we don't know the size we leave it as zero.  This should never happen
-     for anything that is actually used.  */
-  /* TODO: Check this is actually true, particularly when repacking
-     assumed size parameters.  */
+  field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
+			     GFC_DTYPE_TYPE);
+  CONSTRUCTOR_APPEND_ELT (v, field,
+			  build_int_cst (TREE_TYPE (field), n));
+
+  dtype = build_constructor (tmp, v);
 
   return dtype;
 }
@@ -1820,7 +1864,7 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
   /* Add the dtype component.  */
   decl = gfc_add_field_to_struct_1 (fat_type,
 				    get_identifier ("dtype"),
-				    gfc_array_index_type, &chain);
+				    get_dtype_type_node (), &chain);
   TREE_NO_WARNING (decl) = 1;
 
   /* Add the span component.  */
@@ -3232,6 +3276,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
   tree etype, ptype, t, base_decl;
   tree data_off, dim_off, dtype_off, dim_size, elem_size;
   tree lower_suboff, upper_suboff, stride_suboff;
+  tree dtype, field, rank_off;
 
   if (! GFC_DESCRIPTOR_TYPE_P (type))
     {
@@ -3313,11 +3358,15 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
       t = base_decl;
       if (!integer_zerop (dtype_off))
 	t = fold_build_pointer_plus (t, dtype_off);
+      dtype = TYPE_MAIN_VARIANT (get_dtype_type_node ());
+      field = gfc_advance_chain (TYPE_FIELDS (dtype), GFC_DTYPE_RANK);
+      rank_off = byte_position (field);
+      if (!integer_zerop (dtype_off))
+	t = fold_build_pointer_plus (t, rank_off);
+
       t = build1 (NOP_EXPR, build_pointer_type (gfc_array_index_type), t);
       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
-      info->rank = build2 (BIT_AND_EXPR, gfc_array_index_type, t,
-			   build_int_cst (gfc_array_index_type,
-					  GFC_DTYPE_RANK_MASK));
+      info->rank = t;
       t = build0 (PLACEHOLDER_EXPR, TREE_TYPE (dim_off));
       t = size_binop (MULT_EXPR, t, dim_size);
       dim_off = build2 (PLUS_EXPR, TREE_TYPE (dim_off), t, dim_off);

gcc/fortran/trans-types.h

@@ -73,6 +73,7 @@ void gfc_init_kinds (void);
 void gfc_init_types (void);
 void gfc_init_c_interop_kinds (void);
 
+tree get_dtype_type_node (void);
 tree gfc_get_int_type (int);
 tree gfc_get_real_type (int);
 tree gfc_get_complex_type (int);

gcc/fortran/trans.h

@@ -914,6 +914,12 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit;
 /* gfortran-specific declaration information, the _CONT versions denote
    arrays with CONTIGUOUS attribute.  */
 
+#define GFC_DTYPE_ELEM_LEN 0
+#define GFC_DTYPE_VERSION 1
+#define GFC_DTYPE_RANK 2
+#define GFC_DTYPE_TYPE 3
+#define GFC_DTYPE_ATTRIBUTE 4
+
 enum gfc_array_kind
 {
   GFC_ARRAY_UNKNOWN,

gcc/testsuite/ChangeLog

+2018-25-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37577
+	* gfortran.dg/coarray_18.f90: Allow dimension 15 for F2008.
+	* gfortran.dg/coarray_lib_this_image_2.f90: Change 'array1' to
+	'array01' in the tree dump comparison.
+	* gfortran.dg/coarray_lib_token_4.f90: Likewise.
+	* gfortran.dg/inline_sum_1.f90: Similar - allow two digits.
+	* gfortran.dg/rank_1.f90: Allow dimension 15 for F2008.
+
 2018-01-25  Jan Hubicka  <hubicka@ucw.cz>
 
 	PR middle-end/83055

gcc/testsuite/gfortran.dg/coarray_18.f90

@@ -5,8 +5,7 @@
 ! dimensions (normal + codimensions).
 !
 ! Fortran 2008 allows (co)arrays with 15 ranks
-! Currently, gfortran only supports 7, cf. PR 37577
-! Thus, the program is valid Fortran 2008 ...
+! Previously gfortran only supported 7, cf. PR 37577
 !
 ! See also general coarray PR 18918
 !
@@ -19,14 +18,20 @@ program ar
   integer :: ic(2)[*]
   integer :: id(2,2)[2,*]
   integer :: ie(2,2,2)[2,2,*]
-  integer :: ig(2,2,2,2)[2,2,2,*] ! { dg-error "has more than 7 dimensions" }
-  integer :: ih(2,2,2,2,2)[2,2,2,2,*] ! { dg-error "has more than 7 dimensions" }
-  integer :: ij(2,2,2,2,2,2)[2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" }
-  integer :: ik(2,2,2,2,2,2,2)[2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" }
-  integer :: il[2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" }
-  integer :: im[2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" }
-  integer :: in[2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" }
-  integer :: io[2,2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 7 dimensions" }
+! Previously, these would give errors.
+  integer :: ig(2,2,2,2)[2,2,2,*]
+  integer :: ih(2,2,2,2,2)[2,2,2,2,*]
+  integer :: ij(2,2,2,2,2,2)[2,2,2,2,2,*]
+  integer :: ik(2,2,2,2,2,2,2)[2,2,2,2,2,2,*]
+  integer :: il[2,2,2,2,2,2,2,*] 
+  integer :: im[2,2,2,2,2,2,2,2,*]
+  integer :: in[2,2,2,2,2,2,2,2,2,*]
+  integer :: io[2,2,2,2,2,2,2,2,2,2,*]
+! Now with max dimensions 15.....
+  integer :: ip(2,2,2,2,2,2,2,2)[2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" }
+  integer :: iq[2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" }
+! Check a non-coarray
+  integer :: ir(2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2) ! { dg-error "has more than 15 dimensions" }
    real :: x2(2,2,4)[2,*]
    complex :: c2(4,2)[2,*]
    double precision :: d2(1,5,9)[2,*]

gcc/testsuite/gfortran.dg/coarray_lib_this_image_2.f90

@@ -16,7 +16,7 @@ contains
   end subroutine bar
 end
 
-! { dg-final { scan-tree-dump-times "bar \\(struct array1_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct array01_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } }

gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90

@@ -35,9 +35,9 @@ end program test_caf
 
 ! { dg-final { scan-tree-dump-times "expl \\(integer\\(kind=4\\).0:. . restrict z, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
 !
-! { dg-final { scan-tree-dump-times "bar \\(struct array1_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bar \\(struct array01_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
 !
-! { dg-final { scan-tree-dump-times "foo \\(struct array1_integer\\(kind=4\\) & restrict x, struct array1_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(struct array01_integer\\(kind=4\\) & restrict x, struct array01_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
 !
 ! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } }
 !

gcc/testsuite/gfortran.dg/inline_sum_1.f90

@@ -188,6 +188,6 @@ contains
     o = i
   end subroutine tes
 end
-! { dg-final { scan-tree-dump-times "struct array._integer\\(kind=4\\) atmp" 13 "original" } }
+! { dg-final { scan-tree-dump-times "struct array.._integer\\(kind=4\\) atmp" 13 "original" } }
 ! { dg-final { scan-tree-dump-times "struct array\[^\\n\]*atmp" 13 "original" } }
 ! { dg-final { scan-tree-dump-times "_gfortran_sum_" 0 "original" } }

gcc/testsuite/gfortran.dg/rank_1.f90

@@ -4,7 +4,6 @@
 ! Fortran < 2008 allows 7  dimensions
 ! Fortran   2008 allows 15 dimensions (including co-array ranks)
 !
-! FIXME: Rank patch was reverted because of PR 36825.
-integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) ! { dg-error "has more than 7 dimensions" }
-integer :: b(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) ! { dg-error "has more than 7 dimensions" }
+integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)
+integer :: b(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) ! { dg-error "has more than 15 dimensions" }
 end

libgfortran/ChangeLog

+2018-25-01  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/37577
+	* caf/single.c (_gfortran_caf_failed_images): Access the 'type'
+	and 'elem_len' fields of the dtype instead of the shifts.
+	(_gfortran_caf_stopped_images): Likewise.
+	* intrinsics/associated.c (associated): Compare the 'type' and
+	'elem_len' fields instead of the dtype.
+	* caf/date_and_time.c : Access the dtype fields rather using
+	shifts and masks.
+	* io/transfer.c (transfer_array ): Comment on item count.
+	(set_nml_var,st_set_nml_var): Change dtype type and use fields.
+	(st_set_nml_dtio_var): Likewise.
+	* libgfortran.h : Change definition of GFC_ARRAY_DESCRIPTOR and
+	add a typedef for the dtype_type. Change the GFC_DTYPE_* macros
+	to access the dtype fields.
+
 2018-01-15  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/54613

libgfortran/caf/single.c

@@ -332,8 +332,8 @@ _gfortran_caf_failed_images (gfc_descriptor_t *array,
   int local_kind = kind != NULL ? *kind : 4;
 
   array->base_addr = NULL;
-  array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
-		  | (local_kind << GFC_DTYPE_SIZE_SHIFT));
+  array->dtype.type = BT_INTEGER;
+  array->dtype.elem_len = local_kind;
    /* Setting lower_bound higher then upper_bound is what the compiler does to
       indicate an empty array.  */
   array->dim[0].lower_bound = 0;
@@ -354,8 +354,8 @@ _gfortran_caf_stopped_images (gfc_descriptor_t *array,
   int local_kind = kind != NULL ? *kind : 4;
 
   array->base_addr = NULL;
-  array->dtype =  ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
-		   | (local_kind << GFC_DTYPE_SIZE_SHIFT));
+  array->dtype.type =  BT_INTEGER;
+  array->dtype.elem_len =  local_kind;
   /* Setting lower_bound higher then upper_bound is what the compiler does to
      indicate an empty array.  */
   array->dim[0].lower_bound = 0;

libgfortran/intrinsics/associated.c

@@ -37,7 +37,9 @@ associated (const gfc_array_void *pointer, const gfc_array_void *target)
     return 0;
   if (GFC_DESCRIPTOR_DATA (pointer) != GFC_DESCRIPTOR_DATA (target))
     return 0;
-  if (GFC_DESCRIPTOR_DTYPE (pointer) != GFC_DESCRIPTOR_DTYPE (target))
+  if (GFC_DESCRIPTOR_DTYPE (pointer).elem_len != GFC_DESCRIPTOR_DTYPE (target).elem_len)
+    return 0;
+  if (GFC_DESCRIPTOR_DTYPE (pointer).type != GFC_DESCRIPTOR_DTYPE (target).type)
     return 0;
 
   rank = GFC_DESCRIPTOR_RANK (pointer);

libgfortran/intrinsics/date_and_time.c

@@ -270,10 +270,9 @@ secnds (GFC_REAL_4 *x)
   /* Make the INTEGER*4 array for passing to date_and_time.  */
   gfc_array_i4 *avalues = xmalloc (sizeof (gfc_array_i4));
   avalues->base_addr = &values[0];
-  GFC_DESCRIPTOR_DTYPE (avalues) = ((BT_REAL << GFC_DTYPE_TYPE_SHIFT)
-				        & GFC_DTYPE_TYPE_MASK) +
-				    (4 << GFC_DTYPE_SIZE_SHIFT);
-
+  GFC_DESCRIPTOR_DTYPE (avalues).type = BT_REAL;
+  GFC_DESCRIPTOR_DTYPE (avalues).elem_len = 4;
+  GFC_DESCRIPTOR_DTYPE (avalues).rank = 1;
   GFC_DIMENSION_SET(avalues->dim[0], 0, 7, 1);
 
   date_and_time (NULL, NULL, NULL, avalues, 0, 0, 0);

libgfortran/io/transfer.c

@@ -2406,6 +2406,8 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
   char *data;
   bt iotype;
 
+  /* Adjust item_count before emitting error message.  */
+ 
   if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
     return;
 
@@ -2413,6 +2415,7 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
   size = iotype == BT_CHARACTER ? (index_type) charlen : GFC_DESCRIPTOR_SIZE (desc);
 
   rank = GFC_DESCRIPTOR_RANK (desc);
+
   for (n = 0; n < rank; n++)
     {
       count[n] = 0;
@@ -4208,7 +4211,7 @@ st_wait (st_parameter_wait *wtp __attribute__((unused)))
 static void
 set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
 	     GFC_INTEGER_4 len, gfc_charlen_type string_length,
-	     GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
+	     dtype_type dtype, void *dtio_sub, void *vtable)
 {
   namelist_info *t1 = NULL;
   namelist_info *nml;
@@ -4227,9 +4230,9 @@ set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
   nml->len = (int) len;
   nml->string_length = (index_type) string_length;
 
-  nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
-  nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
-  nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
+  nml->var_rank = (int) (dtype.rank);
+  nml->size = (index_type) (dtype.elem_len);
+  nml->type = (bt) (dtype.type);
 
   if (nml->var_rank > 0)
     {
@@ -4259,13 +4262,13 @@ set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
 }
 
 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
-			    GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
+			    GFC_INTEGER_4, gfc_charlen_type, dtype_type);
 export_proto(st_set_nml_var);
 
 void
 st_set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
 		GFC_INTEGER_4 len, gfc_charlen_type string_length,
-		GFC_INTEGER_4 dtype)
+		dtype_type dtype)
 {
   set_nml_var (dtp, var_addr, var_name, len, string_length,
 	       dtype, NULL, NULL);
@@ -4275,7 +4278,7 @@ st_set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
 /* Essentially the same as previous but carrying the dtio procedure
    and the vtable as additional arguments.  */
 extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *,
-				 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4,
+				 GFC_INTEGER_4, gfc_charlen_type, dtype_type,
 				 void *, void *);
 export_proto(st_set_nml_dtio_var);
 
@@ -4283,7 +4286,7 @@ export_proto(st_set_nml_dtio_var);
 void
 st_set_nml_dtio_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
 		     GFC_INTEGER_4 len, gfc_charlen_type string_length,
-		     GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
+		     dtype_type dtype, void *dtio_sub, void *vtable)
 {
   set_nml_var (dtp, var_addr, var_name, len, string_length,
 	       dtype, dtio_sub, vtable);

libgfortran/libgfortran.h

@@ -327,14 +327,23 @@ typedef struct descriptor_dimension
   index_type lower_bound;
   index_type _ubound;
 }
-
 descriptor_dimension;
 
+typedef struct dtype_type
+{
+  size_t elem_len;
+  int version;
+  signed char rank;
+  signed char type;
+  signed short attribute;
+}
+dtype_type;
+
 #define GFC_ARRAY_DESCRIPTOR(r, type) \
 struct {\
   type *base_addr;\
   size_t offset;\
-  index_type dtype;\
+  dtype_type dtype;\
   index_type span;\
   descriptor_dimension dim[r];\
 }
@@ -375,10 +384,9 @@ typedef GFC_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16;
 typedef gfc_array_i1 gfc_array_s1;
 typedef gfc_array_i4 gfc_array_s4;
 
-#define GFC_DESCRIPTOR_RANK(desc) ((desc)->dtype & GFC_DTYPE_RANK_MASK)
-#define GFC_DESCRIPTOR_TYPE(desc) (((desc)->dtype & GFC_DTYPE_TYPE_MASK) \
-                                   >> GFC_DTYPE_TYPE_SHIFT)
-#define GFC_DESCRIPTOR_SIZE(desc) ((desc)->dtype >> GFC_DTYPE_SIZE_SHIFT)
+#define GFC_DESCRIPTOR_RANK(desc) ((desc)->dtype.rank)
+#define GFC_DESCRIPTOR_TYPE(desc) ((desc)->dtype.type)
+#define GFC_DESCRIPTOR_SIZE(desc) ((desc)->dtype.elem_len)
 #define GFC_DESCRIPTOR_DATA(desc) ((desc)->base_addr)
 #define GFC_DESCRIPTOR_DTYPE(desc) ((desc)->dtype)
 
@@ -411,18 +419,24 @@ typedef gfc_array_i4 gfc_array_s4;
 #define GFC_DTYPE_SIZE_MASK (-((index_type) 1 << GFC_DTYPE_SIZE_SHIFT))
 #define GFC_DTYPE_TYPE_SIZE_MASK (GFC_DTYPE_SIZE_MASK | GFC_DTYPE_TYPE_MASK)
 
-#define GFC_DTYPE_TYPE_SIZE(desc) ((desc)->dtype & GFC_DTYPE_TYPE_SIZE_MASK)
+#define GFC_DTYPE_TYPE_SIZE(desc) (( ((desc)->dtype.type << GFC_DTYPE_TYPE_SHIFT) \
+    | ((desc)->dtype.elem_len << GFC_DTYPE_SIZE_SHIFT) ) & GFC_DTYPE_TYPE_SIZE_MASK)
 
 /* Macros to set size and type information.  */
 
 #define GFC_DTYPE_COPY(a,b) do { (a)->dtype = (b)->dtype; } while(0)
 #define GFC_DTYPE_COPY_SETRANK(a,b,n) \
   do { \
-  (a)->dtype = (((b)->dtype & ~GFC_DTYPE_RANK_MASK) | n ); \
+  (a)->dtype.rank = ((b)->dtype.rank | n ); \
   } while (0)
 
-#define GFC_DTYPE_IS_UNSET(a) (unlikely((a)->dtype == 0))
-#define GFC_DTYPE_CLEAR(a) do { (a)->dtype = 0; } while(0)
+#define GFC_DTYPE_IS_UNSET(a) (unlikely((a)->dtype.elem_len == 0))
+#define GFC_DTYPE_CLEAR(a) do { (a)->dtype.elem_len = 0; \
+				(a)->dtype.version = 0; \
+				(a)->dtype.rank = 0; \
+				(a)->dtype.type = 0; \
+				(a)->dtype.attribute = 0; \
+} while(0)
 
 #define GFC_DTYPE_INTEGER_1 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
    | (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT))