+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
}
}
+ 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;
#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_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);
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);
}
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)
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;
}
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
{
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);
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
{
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);
}
tree lower;
tree upper;
tree byte_size;
+ tree field;
int n;
gfc_init_se (&argse, NULL);
? 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)
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 (
tree dtio_proc = null_pointer_node;
tree vtable = null_pointer_node;
int n_dim;
- int itype;
int rank = 0;
gcc_assert (sym || c);
}
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.
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)
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,
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;
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
{
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))
{
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. */
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;
}
/* 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. */
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))
{
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);
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);
/* 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,
+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
! 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
!
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,*]
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" } }
! { 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" } }
!
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" } }
! 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
+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
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;
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;
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);
/* 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);
char *data;
bt iotype;
+ /* Adjust item_count before emitting error message. */
+
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
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;
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;
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)
{
}
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);
/* 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);
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);
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];\
}
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)
#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))
git://gcc.gnu.org / gcc.git / commitdiff