tob@archimedes:~/projects/gcc/gcc/testsuite > diffstat /dev/shm/array-desc-type-v2.diff
b/gcc/fortran/libgfortran.h | 23 -
b/gcc/fortran/trans-array.c | 134 +++---
b/gcc/fortran/trans-array.h | 7
b/gcc/fortran/trans-decl.c | 4
b/gcc/fortran/trans-expr.c | 43 +-
b/gcc/fortran/trans-intrinsic.c | 39 -
b/gcc/fortran/trans-io.c | 16
b/gcc/fortran/trans-stmt.c | 21 -
b/gcc/fortran/trans-types.c | 165 ++-----
b/gcc/fortran/trans-types.h | 2
b/gcc/fortran/trans.c | 4
b/gcc/fortran/trans.h | 3
b/gcc/testsuite/gfortran.dg/assign_10.f90 | 2
b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90 | 3
b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 | 10
b/gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 3
b/gcc/testsuite/gfortran.dg/iso-ts-29113_1_c.c | 4
b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 | 2
b/libgfortran/ISO_Fortran_binding.h.tmpl | 22 -
b/libgfortran/intrinsics/associated.c | 2
b/libgfortran/intrinsics/cshift0.c | 63 +--
b/libgfortran/intrinsics/date_and_time.c | 4
b/libgfortran/intrinsics/iso_c_binding.c | 11
b/libgfortran/intrinsics/pack_generic.c | 154 +++----
b/libgfortran/intrinsics/spread_generic.c | 282 ++++++-------
b/libgfortran/intrinsics/unpack_generic.c | 313 +++++++--------
b/libgfortran/io/io.h | 6
b/libgfortran/io/list_read.c | 40 -
b/libgfortran/io/transfer.c | 22 -
b/libgfortran/io/write.c | 26 -
b/libgfortran/libgfortran.h | 95 ----
b/libgfortran/runtime/in_pack_generic.c | 119 ++---
b/libgfortran/runtime/in_unpack_generic.c | 136 +++---
b/libgfortran/runtime/iso_ts29113.c | 9
gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_2.f90 | 158 +++++++
gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_3.f90 | 71 +++
gcc/gcc/testsuite/gfortran.dg/iso-ts-29113_3_c.c | 206 +++++++++
37 files changed, 1239 insertions(+), 985 deletions(-)
@@ -115,9 +115,24 @@ libgfortran_stat_codes;
#define GFC_MAX_DIMENSIONS 15
-#define GFC_DTYPE_TYPE_SHIFT 3
-#define GFC_DTYPE_TYPE_MASK 0x38
-#define GFC_DTYPE_SIZE_SHIFT 6
+#define GFC_TYPE_MASK 0xFF
+#define GFC_TYPE_KIND_SHIFT 8
+
+/* Array-descriptor attributes, see ISO_Fortran_binding.h. */
+#define GFC_ATTRIBUTE_POINTER 1
+#define GFC_ATTRIBUTE_ALLOCATABLE 2
+#define GFC_ATTRIBUTE_OTHER 3
+
+/* Array-descriptor basic types, see ISO_Fortran_binding.h. */
+#define GFC_TYPE_INTEGER 1
+#define GFC_TYPE_LOGICAL 2
+#define GFC_TYPE_REAL 3
+#define GFC_TYPE_COMPLEX 4
+#define GFC_TYPE_CHARACTER 5
+#define GFC_TYPE_STRUCT 6
+#define GFC_TYPE_CPTR 7
+#define GFC_TYPE_CFUNPTR 8
+#define GFC_TYPE_OTHER -1
/* Array-descriptor attributes, see ISO_Fortran_binding.h. */
#define GFC_ATTRIBUTE_POINTER 1
@@ -130,7 +145,7 @@ libgfortran_stat_codes;
used in the run-time library for IO. */
typedef enum
{ BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX,
- BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
+ BT_CHARACTER, BT_DERIVED, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
BT_ASSUMED
}
bt;
@@ -127,9 +127,9 @@ gfc_array_dataptr_type (tree desc)
#define ELEM_LEN_FIELD 1
#define VERSION_FIELD 2
#define RANK_FIELD 3
-#define OFFSET_FIELD 4
+#define ATTR_FIELD 4
#define DTYPE_FIELD 5
-#define ATTR_FIELD 6
+#define OFFSET_FIELD 6
#define DIMENSION_FIELD 7
#define CAF_TOKEN_FIELD 8
@@ -283,7 +283,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_CODE (TREE_TYPE (field)) == INTEGER_TYPE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
@@ -306,7 +307,8 @@ gfc_conv_descriptor_rank (tree desc)
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = gfc_advance_chain (TYPE_FIELDS (type), RANK_FIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == integer_type_node);
+ gcc_assert (field != NULL_TREE
+ && TREE_CODE (TREE_TYPE (field)) == INTEGER_TYPE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
@@ -316,8 +318,8 @@ gfc_conv_descriptor_rank (tree desc)
void
gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int rank)
{
- gfc_add_modify (block, gfc_conv_descriptor_rank (desc),
- build_int_cst (integer_type_node, rank));
+ tree field = gfc_conv_descriptor_rank (desc);
+ gfc_add_modify (block, field, build_int_cst (TREE_TYPE (field), rank));
}
@@ -349,11 +351,12 @@ gfc_conv_descriptor_attr_set (stmtblock_t *block, tree desc, int attr)
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = gfc_advance_chain (TYPE_FIELDS (type), ATTR_FIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == integer_type_node);
+ gcc_assert (field != NULL_TREE
+ && TREE_CODE (TREE_TYPE (field)) == INTEGER_TYPE);
field = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
- gfc_add_modify (block, field, build_int_cst (integer_type_node, attr));
+ gfc_add_modify (block, field, build_int_cst (TREE_TYPE (field), attr));
}
@@ -564,7 +567,8 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
/* Build a null array descriptor constructor. */
tree
-gfc_build_null_descriptor (tree desc_type, int rank, int attr)
+gfc_build_null_descriptor (tree desc_type, int rank, int attr,
+ gfc_typespec *ts)
{
tree field;
tree tmp;
@@ -590,16 +594,16 @@ gfc_build_null_descriptor (tree desc_type, int rank, int attr)
/* Set rank. */
tmp = gfc_advance_chain (field, RANK_FIELD);
CONSTRUCTOR_APPEND_ELT (init, tmp,
- build_int_cst (integer_type_node, rank));
-
- /* Set type. */
- tmp = gfc_advance_chain (field, DTYPE_FIELD);
- CONSTRUCTOR_APPEND_ELT (init, tmp, gfc_get_dtype (desc_type));
+ build_int_cst (TREE_TYPE (tmp), rank));
/* Set attribute (allocatable, pointer, other). */
tmp = gfc_advance_chain (field, ATTR_FIELD);
CONSTRUCTOR_APPEND_ELT (init, tmp,
- build_int_cst (integer_type_node, attr));
+ build_int_cst (TREE_TYPE (tmp), attr));
+
+ /* Set type. */
+ tmp = gfc_advance_chain (field, DTYPE_FIELD);
+ CONSTRUCTOR_APPEND_ELT (init, tmp, gfc_get_dtype (ts));
/* All other fields are set during allocate/pointer association. */
tmp = build_constructor (desc_type, init);
@@ -919,7 +923,7 @@ gfc_trans_static_array_pointer (gfc_symbol * sym)
type = TREE_TYPE (sym->backend_decl);
DECL_INITIAL (sym->backend_decl)
- = gfc_build_null_descriptor (type, sym->as->rank, attr);
+ = gfc_build_null_descriptor (type, sym->as->rank, attr, &sym->ts);
}
@@ -1190,7 +1194,8 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
tree
gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree eltype, tree initial, bool dynamic,
- bool dealloc, bool callee_alloc, locus * where)
+ bool dealloc, bool callee_alloc,
+ gfc_typespec *ts, tree strlen, locus * where)
{
gfc_loopinfo *loop;
gfc_ss *s;
@@ -1200,6 +1205,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree desc;
tree tmp;
tree size;
+ tree elem_len;
tree nelem;
tree cond;
tree or_expr;
@@ -1280,32 +1286,42 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
GFC_DECL_PACKED_ARRAY (desc) = 1;
info->descriptor = desc;
- size = gfc_index_one_node;
/* Fill in the elem_len, version, rank, dtype and attribute. */
- gfc_conv_descriptor_elem_len_set (pre, desc,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+
+ if (class_expr != NULL_TREE)
+ elem_len = gfc_vtable_size_get (class_expr);
+ else if (ts->type == BT_CHARACTER && strlen)
+ elem_len = size_of_string_in_bytes (ts->kind, strlen);
+ else if (ts->type != BT_CHARACTER)
+ elem_len = size_in_bytes (gfc_typenode_for_spec (ts));
+ else
+ elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+
+ gfc_conv_descriptor_elem_len_set (pre, desc, elem_len);
gfc_conv_descriptor_version_set (pre, desc);
gfc_conv_descriptor_rank_set (pre, desc, total_dim);
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (pre, tmp, gfc_get_dtype (type));
+ gfc_add_modify (pre, tmp, gfc_get_dtype (ts));
gfc_conv_descriptor_attr_set (pre, desc, GFC_ATTRIBUTE_ALLOCATABLE);
/*
Fill in the bounds and stride. This is a packed array, so:
- size = 1;
+ size = elem_len;
for (n = 0; n < rank; n++)
{
- stride[n] = size
- delta = ubound[n] + 1 - lbound[n];
+ sm[n] = size
+ delta = extent[n];
size = size * delta;
}
- size = size * sizeof(element);
*/
or_expr = NULL_TREE;
+ elem_len = fold_convert (gfc_array_index_type, elem_len);
+ size = elem_len;
+
/* If there is at least one null loop->to[n], it is a callee allocated
array. */
for (n = 0; n < total_dim; n++)
@@ -1334,17 +1350,17 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
for (n = 0; n < total_dim; n++)
{
/* Store the stride and bound components in the descriptor. */
- gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size);
+ gfc_conv_descriptor_sm_set (pre, desc, gfc_rank_cst[n], size);
gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], to[n]);
-
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type,
to[n], gfc_index_one_node);
+ gfc_conv_descriptor_extent_set (pre, desc, gfc_rank_cst[n], tmp);
+
/* Check whether the size for this dimension is negative. */
cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
tmp, gfc_index_zero_node);
@@ -1363,27 +1379,21 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
}
/* Get the size of the array. */
- if (size && !callee_alloc)
+ if (size != NULL_TREE && !callee_alloc)
{
- tree elemsize;
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
-
- nelem = size;
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_vtable_size_get (class_expr);
-
- size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size, elemsize);
+ nelem = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, size, elem_len);
}
else
{
- nelem = size;
+ nelem = (size == NULL_TREE)
+ ? NULL_TREE
+ : fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, size, elem_len);
size = NULL_TREE;
}
@@ -1667,7 +1677,7 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock,
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
/* Make sure the constructed array has room for the new data. */
if (dynamic)
@@ -2502,7 +2512,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
}
gfc_trans_create_temp_array (&outer_loop->pre, &outer_loop->post, ss, type,
- NULL_TREE, dynamic, true, false, where);
+ NULL_TREE, dynamic, true, false, &expr->ts,
+ ss_info->string_length, where);
desc = ss_info->data.array.descriptor;
offset = gfc_index_zero_node;
@@ -4858,7 +4869,7 @@ set_loop_bounds (gfc_loopinfo *loop)
moved outside the loop. */
void
-gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
+gfc_conv_loop_setup (gfc_loopinfo *loop, locus *where, gfc_typespec *ts)
{
gfc_ss *tmp_ss;
tree tmp;
@@ -4894,7 +4905,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
gcc_assert (tmp_ss->dimen != 0);
gfc_trans_create_temp_array (&loop->pre, &loop->post, tmp_ss, tmp,
- NULL_TREE, false, true, false, where);
+ NULL_TREE, false, true, false, ts,
+ tmp_ss_info->string_length, where);
}
/* For array parameters we don't have loop variables, so don't calculate the
@@ -5067,7 +5079,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
/*GCC ARRAYS*/
static tree
-gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
+gfc_array_init_size (tree descriptor, gfc_typespec *ts,
+ int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
@@ -5095,11 +5108,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
offset = gfc_index_zero_node;
/* Set the rank and dtype. */
- tmp = gfc_conv_descriptor_rank (descriptor);
- gfc_add_modify (descriptor_block, tmp, build_int_cst (integer_type_node,
- rank));
+ gfc_conv_descriptor_rank_set (descriptor_block, descriptor, rank);
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (ts));
or_expr = boolean_false_node;
@@ -5402,7 +5413,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
gfc_init_block (&set_descriptor_block);
- size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
+ size = gfc_array_init_size (se->expr, &expr->ts, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
expr3_elem_size, nelems, expr3);
@@ -5676,7 +5687,8 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
break;
case EXPR_NULL:
- return gfc_build_null_descriptor (type, 1, GFC_ATTRIBUTE_OTHER);
+ return gfc_build_null_descriptor (type, 1, GFC_ATTRIBUTE_OTHER,
+ &expr->ts);
default:
gcc_unreachable ();
@@ -6852,7 +6864,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
- gfc_conv_loop_setup (&loop, & expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
if (need_tmp)
{
@@ -6986,13 +6998,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (expr->ts.type == BT_CHARACTER)
elem_len = size_of_string_in_bytes (expr->ts.kind, se->string_length);
else
- elem_len = size_in_bytes (gfc_get_element_type (TREE_TYPE (desc)));
+ elem_len = size_in_bytes (gfc_typenode_for_spec(&expr->ts));
gfc_conv_descriptor_elem_len_set (&loop.pre, parm, elem_len);
gfc_conv_descriptor_version_set (&loop.pre, parm);
gfc_conv_descriptor_rank_set (&loop.pre, parm, loop.dimen);
tmp = gfc_conv_descriptor_dtype (parm);
- gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (parmtype));
+ gfc_add_modify (&loop.pre, tmp, gfc_get_dtype (&expr->ts));
gfc_conv_descriptor_attr_set (&loop.pre, parm, GFC_ATTRIBUTE_OTHER);
/* Set offset for assignments to pointer only to zero if it is not
@@ -7889,7 +7901,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_conv_descriptor_version_set (&fnblock, comp);
gfc_conv_descriptor_rank_set (&fnblock, comp, c->as->rank);
gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
- gfc_get_dtype (TREE_TYPE (comp)));
+ gfc_get_dtype (&c->ts));
gfc_conv_descriptor_attr_set (&fnblock, comp,
c->attr.allocatable
? GFC_ATTRIBUTE_ALLOCATABLE
@@ -7932,7 +7944,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_conv_descriptor_rank_set (&fnblock, comp,
CLASS_DATA (c)->as->rank);
gfc_add_modify (&fnblock, gfc_conv_descriptor_dtype (comp),
- gfc_get_dtype (TREE_TYPE (comp)));
+ gfc_get_dtype (&c->ts));
gfc_conv_descriptor_attr_set (&fnblock, comp,
c->attr.allocatable
? GFC_ATTRIBUTE_ALLOCATABLE
@@ -8534,11 +8546,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
1, size2);
gfc_conv_descriptor_data_set (&alloc_block,
desc, tmp);
- tmp = gfc_conv_descriptor_rank (desc);
- gfc_add_modify (&alloc_block, tmp, build_int_cst (integer_type_node,
- expr1->rank));
+ gfc_conv_descriptor_rank_set (&alloc_block, desc, expr1->rank);
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (&expr1->ts));
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
{
@@ -8673,7 +8683,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
gfc_conv_descriptor_version_set (&init, descriptor);
gfc_conv_descriptor_rank_set (&init, descriptor, sym->as->rank);
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (&init, tmp, gfc_get_dtype (type));
+ gfc_add_modify (&init, tmp, gfc_get_dtype (&sym->ts));
gcc_assert (sym->attr.allocatable || sym->attr.pointer);
gfc_conv_descriptor_attr_set (&init, descriptor,
sym->attr.allocatable
@@ -32,7 +32,8 @@ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
/* Generate code to create a temporary array. */
tree gfc_trans_create_temp_array (stmtblock_t *, stmtblock_t *, gfc_ss *,
- tree, tree, bool, bool, bool, locus *);
+ tree, tree, bool, bool, bool,
+ gfc_typespec *, tree, locus *);
/* Generate function entry code for allocation of compiler allocated array
variables. */
@@ -114,13 +115,13 @@ void gfc_trans_scalarizing_loops (gfc_loopinfo *, stmtblock_t *);
/* Mark the end of the main loop body and the start of the copying loop. */
void gfc_trans_scalarized_loop_boundary (gfc_loopinfo *, stmtblock_t *);
/* Initialize the scalarization loop parameters. */
-void gfc_conv_loop_setup (gfc_loopinfo *, locus *);
+void gfc_conv_loop_setup (gfc_loopinfo *, locus *, gfc_typespec *ts);
/* Set each array's delta. */
void gfc_set_delta (gfc_loopinfo *);
/* Resolve array assignment dependencies. */
void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
/* Build a null array descriptor constructor. */
-tree gfc_build_null_descriptor (tree, int, int);
+tree gfc_build_null_descriptor (tree, int, int, gfc_typespec *);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_symbol *, locus *);
@@ -3686,7 +3686,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
tmp = gfc_class_data_get (sym->backend_decl);
tmp = gfc_build_null_descriptor (TREE_TYPE (tmp),
CLASS_DATA (sym)->as->rank,
- attr);
+ attr, &sym->ts);
}
else
tmp = null_pointer_node;
@@ -3843,7 +3843,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_conv_descriptor_rank_set (&init, descriptor,
CLASS_DATA (sym)->as->rank);
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (&init, tmp, gfc_get_dtype (type));
+ gfc_add_modify (&init, tmp, gfc_get_dtype (&sym->ts));
gfc_conv_descriptor_attr_set (&init, descriptor,
CLASS_DATA (sym)->attr.allocatable
? GFC_ATTRIBUTE_ALLOCATABLE
@@ -60,7 +60,8 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
}
tree
-gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
+gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr,
+ gfc_typespec *ts)
{
tree desc, type;
int desc_attr;
@@ -74,7 +75,7 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
gfc_conv_descriptor_version_set (&se->pre, desc);
gfc_conv_descriptor_rank_set (&se->pre, desc, 0);
gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype (type));
+ gfc_get_dtype (ts));
if (attr.pointer)
desc_attr = GFC_ATTRIBUTE_POINTER;
else if (attr.allocatable)
@@ -385,7 +386,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_conv_descriptor_version_set (&parmse->pre, ctree);
gfc_conv_descriptor_rank_set (&parmse->pre, ctree, 0);
gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
+ gfc_get_dtype (&class_ts));
if (attr.pointer)
desc_attr = GFC_ATTRIBUTE_POINTER;
@@ -652,13 +653,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
{
if (e->rank == 0)
{
-// FIXME: Use gfc_conv_scalar_to_descriptor
- tree type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_add_modify (&block, gfc_conv_descriptor_rank (ctree),
- build_int_cst (integer_type_node, 0));
+ gfc_conv_descriptor_rank_set (&block, ctree, 0);
gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
+ gfc_get_dtype (&e->ts));
tmp = gfc_class_data_get (parmse->expr);
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
@@ -3616,7 +3613,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
gfc_add_ss_to_loop (&loop, loop.temp_ss);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
/* Pass the temporary descriptor back to the caller. */
info = &loop.temp_ss->info->data.array;
@@ -3680,7 +3677,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
gfc_conv_ss_startstride (&loop2);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop2, &expr->where);
+ gfc_conv_loop_setup (&loop2, &expr->where, &expr->ts);
gfc_copy_loopinfo_to_se (&lse, &loop2);
gfc_copy_loopinfo_to_se (&rse, &loop2);
@@ -4334,7 +4331,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
tmp = TREE_OPERAND (tmp, 0);
parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
- fsym->attr);
+ fsym->attr,
+ &e->ts);
parmse.expr = gfc_build_addr_expr (NULL_TREE,
parmse.expr);
}
@@ -4921,6 +4919,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
tmp, NULL_TREE, false,
!comp->attr.pointer, callee_alloc,
+ &se->ss->info->expr->ts,
+ se->ss->info->string_length,
&se->ss->info->expr->where);
/* Pass the temporary as the first argument. */
@@ -4957,6 +4957,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
tmp, NULL_TREE, false,
!sym->attr.pointer, callee_alloc,
+ &se->ss->info->expr->ts,
+ se->ss->info->string_length,
&se->ss->info->expr->where);
/* Pass the temporary as the first argument. */
@@ -5617,7 +5619,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
/* Arrays need special handling. */
if (pointer)
ctor = gfc_build_null_descriptor (type, rank,
- GFC_ATTRIBUTE_POINTER);
+ GFC_ATTRIBUTE_POINTER, ts);
/* Special case assigning an array to zero. */
else if (is_zero_initializer_p (expr))
ctor = build_constructor (type, NULL);
@@ -5725,7 +5727,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_conv_ss_startstride (&loop);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop);
@@ -6554,7 +6556,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (expr1->ts.deferred || expr1->ts.type == BT_CLASS)
{
dtype = gfc_conv_descriptor_dtype (desc);
- tmp = gfc_get_dtype (TREE_TYPE (desc));
+ tmp = gfc_get_dtype (&expr2->ts);
gfc_add_modify (&block, dtype, tmp);
}
@@ -7005,8 +7007,8 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
reallocatable assignments from extrinsic function calls. */
static void
-realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
- gfc_loopinfo *loop)
+realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_typespec *ts,
+ gfc_ss **ss, gfc_loopinfo *loop)
{
/* Signal that the function call should not be made by
gfc_conv_loop_setup. */
@@ -7015,7 +7017,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
gfc_add_ss_to_loop (loop, *ss);
gfc_add_ss_to_loop (loop, se->ss);
gfc_conv_ss_startstride (loop);
- gfc_conv_loop_setup (loop, where);
+ gfc_conv_loop_setup (loop, where, ts);
gfc_copy_loopinfo_to_se (se, loop);
gfc_add_block_to_block (&se->pre, &loop->pre);
gfc_add_block_to_block (&se->pre, &loop->post);
@@ -7184,7 +7186,8 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
ss = gfc_walk_expr (expr1);
gcc_assert (ss != gfc_ss_terminator);
- realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &ss, &loop);
+ realloc_lhs_loop_for_fcn_call (&se, &expr1->where, &expr1->ts,
+ &ss, &loop);
ss->is_alloc_lhs = 1;
}
else
@@ -7656,7 +7659,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* Resolve any data dependencies in the statement. */
gfc_conv_resolve_dependencies (&loop, lss, rss);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop, &expr2->where);
+ gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop);
@@ -926,7 +926,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
{
stmtblock_t loop;
tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
- lbound, ubound, extent, ml;
+ lbound, extent, ml;
gfc_se argse;
int rank, corank;
@@ -1082,10 +1082,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
gfc_add_modify (&loop, ml, m);
/* extent = ... */
- lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
- ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
- extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- extent = fold_convert (type, extent);
+ extent = fold_convert (type, gfc_conv_descriptor_extent_get (desc, loop_var));
/* m = m/extent. */
gfc_add_modify (&loop, m,
@@ -1208,12 +1205,11 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
for (codim = corank + rank - 2; codim >= rank; codim--)
{
- tree extent, ubound;
+ tree extent;
/* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
- extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[codim]);
/* coindex *= extent. */
coindex = fold_build2_loc (input_location, MULT_EXPR,
@@ -1280,7 +1276,8 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
gfc_add_block_to_block (&se->pre, &argse.pre);
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),
+ gfc_conv_descriptor_rank (argse.expr));
}
@@ -1370,7 +1367,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
else
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
- bound, fold_convert(TREE_TYPE (bound), tmp));
+ bound, fold_convert (TREE_TYPE (bound), tmp));
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
boolean_type_node, cond, tmp);
gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
@@ -2491,7 +2488,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
gfc_mark_ss_chain_used (arrayss, 1);
/* Generate the loop body. */
@@ -2573,7 +2570,7 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
gfc_mark_ss_chain_used (arrayss, 1);
/* Generate the loop body. */
@@ -2707,7 +2704,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
gfc_mark_ss_chain_used (arrayss, 1);
if (maskexpr && maskexpr->rank > 0)
@@ -2928,7 +2925,7 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
gfc_mark_ss_chain_used (arrayss1, 1);
gfc_mark_ss_chain_used (arrayss2, 1);
@@ -3169,7 +3166,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
loops (without conflicting with temporary management), or use a single
loop minmaxloc implementation. See PR 31067. */
loop.temp_dim = loop.dimen;
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
gcc_assert (loop.dimen == 1);
if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
@@ -3629,7 +3626,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
loops (without conflicting with temporary management), or use a single
loop minmaxval implementation. See PR 31067. */
loop.temp_dim = loop.dimen;
- gfc_conv_loop_setup (&loop, &expr->where);
+ gfc_conv_loop_setup (&loop, &expr->where, &expr->ts);
if (nonempty == NULL && maskss == NULL
&& loop.dimen == 1 && loop.from[0] && loop.to[0])
@@ -5603,7 +5600,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
/* Build a destination descriptor, using the pointer, source, as the
data field. */
gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
- NULL_TREE, false, true, false, &expr->where);
+ NULL_TREE, false, true, false,
+ &expr->ts, NULL_TREE, &expr->where);
/* Cast the pointer to the result. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
@@ -6428,10 +6426,9 @@ conv_isocbinding_subroutine (gfc_code *code)
/* Set data value, rank, dtype, and offset. */
tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
- gfc_add_modify (&block, gfc_conv_descriptor_rank (desc),
- build_int_cst (integer_type_node, arg->next->expr->rank));
+ gfc_conv_descriptor_rank_set (&block, desc, arg->next->expr->rank);
gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_get_dtype (&arg->next->expr->ts));
/* Start scalarization of the bounds, using the shape argument. */
@@ -6442,7 +6439,7 @@ conv_isocbinding_subroutine (gfc_code *code)
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, shape_ss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &arg->next->expr->where);
+ gfc_conv_loop_setup (&loop, &arg->next->expr->where, &arg->next->expr->ts);
gfc_mark_ss_chain_used (shape_ss, 1);
gfc_copy_loopinfo_to_se (&shapese, &loop);
@@ -1539,11 +1539,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
tree dt = NULL;
tree string;
tree tmp;
- tree dtype;
tree dt_parm_addr;
tree decl = NULL_TREE;
int n_dim;
- int itype;
int rank = 0;
gcc_assert (sym || c);
@@ -1569,13 +1567,10 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
if (sym && sym->attr.dummy)
decl = build_fold_indirect_ref_loc (input_location, decl);
dt = TREE_TYPE (decl);
- dtype = gfc_get_dtype (dt);
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dt));
}
else
{
- itype = ts->type;
- dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
tmp = TREE_TYPE (decl);
if (TREE_CODE (tmp) == REFERENCE_TYPE)
tmp = TREE_TYPE (tmp);
@@ -1586,15 +1581,16 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
/* Build up the arguments for the transfer call.
The call for the scalar part transfers:
- (address, name, type, kind or string_length, dtype) */
+ (address, name, kind, elem_len, type) */
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
tmp = build_call_expr_loc (input_location,
iocall[IOCALL_SET_NML_VAL], 7,
dt_parm_addr, addr_expr, string,
- IARG (ts->kind), tmp,
- build_int_cst (integer_type_node, rank), dtype);
+ build_int_cst (integer_type_node, ts->kind), tmp,
+ build_int_cst (integer_type_node, rank),
+ build_int_cst (integer_type_node, ts->type));
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
@@ -1972,7 +1968,7 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, where);
+ gfc_conv_loop_setup (&loop, where, &cm->ts);
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
@@ -2286,7 +2282,7 @@ gfc_trans_transfer (gfc_code * code)
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &code->expr1->where);
+ gfc_conv_loop_setup (&loop, &code->expr1->where, &code->expr1->ts);
/* The main loop body. */
gfc_mark_ss_chain_used (ss, 1);
@@ -315,7 +315,8 @@ gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
gfc_init_block (&temp_post);
tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
temptype, initial, false, true,
- false, &arg->expr->where);
+ false, &e->ts, se->string_length,
+ &arg->expr->where);
gfc_add_modify (&se->pre, size, tmp);
tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
gfc_add_modify (&se->pre, data, tmp);
@@ -451,7 +452,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
subscripts. This could be prevented in the elemental case
as temporaries are handled separatedly
(below in gfc_conv_elemental_dependencies). */
- gfc_conv_loop_setup (&loop, &code->expr1->where);
+ gfc_conv_loop_setup (&loop, &code->expr1->where, &code->expr1->ts);
gfc_mark_ss_chain_used (ss, 1);
/* Convert the arguments, checking for dependencies. */
@@ -1217,7 +1218,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
assignment from an unlimited polymorphic object. */
tmp = gfc_conv_descriptor_dtype (sym->backend_decl);
gfc_add_modify (&se.pre, tmp,
- gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
+ gfc_get_dtype (&sym->ts));
}
gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
@@ -2952,7 +2953,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop1);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop1, &expr->where);
+ gfc_conv_loop_setup (&loop1, &expr->where, &expr->ts);
gfc_mark_ss_chain_used (lss, 1);
@@ -3052,7 +3053,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr2->where);
+ gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts);
gfc_mark_ss_chain_used (rss, 1);
/* Start the loop body. */
@@ -3171,7 +3172,7 @@ compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS;
gfc_conv_ss_startstride (&loop);
gfc_option.rtcheck = save_flag;
- gfc_conv_loop_setup (&loop, &expr2->where);
+ gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts);
/* Figure out how many elements we need. */
for (i = 0; i < loop.dimen; i++)
@@ -3516,7 +3517,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
/* Setup the scalarizing loops and bounds. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &expr2->where);
+ gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts);
info = &rss->info->data.array;
desc = info->descriptor;
@@ -4034,7 +4035,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
gfc_add_ss_to_loop (&loop, rss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &me->where);
+ gfc_conv_loop_setup (&loop, &me->where, &me->ts);
gfc_mark_ss_chain_used (rss, 1);
/* Start the loop body. */
@@ -4204,7 +4205,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
gfc_conv_resolve_dependencies (&loop, lss_section, rss);
/* Setup the scalarizing loops. */
- gfc_conv_loop_setup (&loop, &expr2->where);
+ gfc_conv_loop_setup (&loop, &expr2->where, &expr2->ts);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop);
@@ -4651,7 +4652,7 @@ gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
}
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop, &tdst->where);
+ gfc_conv_loop_setup (&loop, &tdst->where, &tdst->ts);
gfc_mark_ss_chain_used (css, 1);
gfc_mark_ss_chain_used (tdss, 1);
@@ -78,7 +78,6 @@ tree complex_float128_type_node = NULL_TREE;
bool gfc_real16_is_float128 = false;
static GTY(()) tree gfc_desc_dim_type;
-static GTY(()) tree gfc_max_array_element_size;
static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
@@ -861,9 +860,6 @@ gfc_init_types (void)
char name_buf[18];
int index;
tree type;
- unsigned n;
- unsigned HOST_WIDE_INT hi;
- unsigned HOST_WIDE_INT lo;
/* Create and name the types. */
#define PUSH_TYPE(name, node) \
@@ -950,19 +946,6 @@ gfc_init_types (void)
build_int_cst (gfc_array_index_type, 0),
NULL_TREE);
- /* The maximum array element size that can be handled is determined
- 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;
- lo = ~ (unsigned HOST_WIDE_INT) 0;
- if (n > HOST_BITS_PER_WIDE_INT)
- hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
- else
- hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
- gfc_max_array_element_size
- = build_int_cst_wide (long_unsigned_type_node, lo, hi);
-
boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
boolean_true_node = build_int_cst (boolean_type_node, 1);
boolean_false_node = build_int_cst (boolean_type_node, 0);
@@ -1190,21 +1173,25 @@ gfc_get_element_type (tree type)
/* Build an array. This function is called from gfc_sym_type().
Actually returns array descriptor type.
- Format of array descriptors is as follows:
+ Format of array descriptors is as follows, cf. TS29113:2012.
struct gfc_array_descriptor
{
- array *data
- index offset;
- index dtype;
- struct descriptor_dimension dimension[N_DIM];
+ base_type *base_addr;
+ size_t elem_len;
+ int version;
+ int8_t rank;
+ int8_t attribute;
+ int16_t type;
+ ptrdiff_t offset;
+ struct CFI_dim_t dim[N_DIM];
}
- struct descriptor_dimension
+ struct CFI_dim_t
{
- index stride;
- index lbound;
- index ubound;
+ ptrdiff_t lower_bound;
+ ptrdiff_t extent;
+ ptrdiff_t sm;
}
Translation code should use gfc_conv_descriptor_* rather than
@@ -1216,10 +1203,10 @@ 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:
- // 3 unused bits (used to be the rank)
- type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
- size = dtype >> GFC_DTYPE_SIZE_SHIFT
+ The type member is formatted as follows; the lower byte contains
+ the type, the upper byte contains the kind value.
+ data_type = (type & GFC_TYPE_MASK)
+ kind = (type >> GFC_TYPE_KIND_SHIFT)
I originally used nested ARRAY_TYPE nodes to represent arrays, but
this generated poor code for assumed/deferred size arrays. These
@@ -1386,87 +1373,45 @@ gfc_get_desc_dim_type (void)
unknown cases abort. */
tree
-gfc_get_dtype (tree type)
+gfc_get_dtype (gfc_typespec *ts)
{
- tree size;
- int n;
- HOST_WIDE_INT i;
- tree tmp;
- tree dtype;
- tree etype;
-
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
+ int type;
+ tree int16_type_node
+ = gfc_get_int_type (gfc_get_int_kind_from_width_isofortranenv (16));
- if (GFC_TYPE_ARRAY_DTYPE (type))
- return GFC_TYPE_ARRAY_DTYPE (type);
-
- etype = gfc_get_element_type (type);
-
- switch (TREE_CODE (etype))
+ switch (ts->type)
{
- case INTEGER_TYPE:
- n = BT_INTEGER;
- break;
-
- case BOOLEAN_TYPE:
- n = BT_LOGICAL;
+ case BT_INTEGER:
+ type = GFC_TYPE_INTEGER + (ts->kind << GFC_TYPE_KIND_SHIFT);
break;
-
- case REAL_TYPE:
- n = BT_REAL;
+ case BT_LOGICAL:
+ type = GFC_TYPE_LOGICAL + (ts->kind << GFC_TYPE_KIND_SHIFT);
break;
-
- case COMPLEX_TYPE:
- n = BT_COMPLEX;
+ case BT_REAL:
+ type = GFC_TYPE_REAL + (ts->kind << GFC_TYPE_KIND_SHIFT);
break;
-
- /* We will never have arrays of arrays. */
- case RECORD_TYPE:
- n = BT_DERIVED;
+ case BT_COMPLEX:
+ type = GFC_TYPE_COMPLEX + (ts->kind << GFC_TYPE_KIND_SHIFT);
break;
-
- case ARRAY_TYPE:
- n = BT_CHARACTER;
+ case BT_CHARACTER:
+ type = GFC_TYPE_CHARACTER + (ts->kind << GFC_TYPE_KIND_SHIFT);
break;
-
- case POINTER_TYPE:
- n = BT_ASSUMED;
+ case BT_DERIVED:
+ if (ts->f90_type == BT_VOID)
+ type = ts->u.derived
+ && ts->u.derived->intmod_sym_id == ISOCBINDING_PTR
+ ? GFC_TYPE_CFUNPTR : GFC_TYPE_CPTR;
+ type = GFC_TYPE_STRUCT;
+ if (ts->u.derived->attr.sequence || ts->u.derived->attr.is_bind_c)
+ type = GFC_TYPE_STRUCT;
+ else
+ type = GFC_TYPE_OTHER;
break;
-
default:
- /* TODO: Don't do dtype for temporary descriptorless arrays. */
- /* We can strange array types for temporary arrays. */
- return gfc_index_zero_node;
+ type = GFC_TYPE_OTHER;
}
- size = TYPE_SIZE_UNIT (etype);
-
- i = (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");
-
- i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
- }
- dtype = build_int_cst (gfc_array_index_type, i);
-
- 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. */
-
- GFC_TYPE_ARRAY_DTYPE (type) = dtype;
- return dtype;
+ return build_int_cst (int16_type_node, type);
}
@@ -1689,9 +1634,15 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
enum gfc_array_kind akind)
{
tree fat_type, decl, arraytype, *chain = NULL;
+ tree int8_type_node, int16_type_node;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
int idx;
+ int8_type_node
+ = gfc_get_int_type (gfc_get_int_kind_from_width_isofortranenv (8));
+ int16_type_node
+ = gfc_get_int_type (gfc_get_int_kind_from_width_isofortranenv (16));
+
/* Assumed-rank array. */
if (dimen == -1)
dimen = GFC_MAX_DIMENSIONS;
@@ -1737,25 +1688,25 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
/* Add the rank component. */
decl = gfc_add_field_to_struct_1 (fat_type,
get_identifier ("rank"),
- integer_type_node, &chain);
+ int8_type_node, &chain);
TREE_NO_WARNING (decl) = 1;
- /* Add the offset component. */
+ /* Add the attribute component. */
decl = gfc_add_field_to_struct_1 (fat_type,
- get_identifier ("offset"),
- gfc_array_index_type, &chain);
+ get_identifier ("attribute"),
+ int8_type_node, &chain);
TREE_NO_WARNING (decl) = 1;
/* Add the type component. */
decl = gfc_add_field_to_struct_1 (fat_type,
get_identifier ("type"),
- gfc_array_index_type, &chain);
+ int16_type_node, &chain);
TREE_NO_WARNING (decl) = 1;
- /* Add the attribute component. */
+ /* Add the offset component. */
decl = gfc_add_field_to_struct_1 (fat_type,
- get_identifier ("attribute"),
- integer_type_node, &chain);
+ get_identifier ("offset"),
+ gfc_array_index_type, &chain);
TREE_NO_WARNING (decl) = 1;
/* Build the array type for the stride and bound components. */
@@ -97,7 +97,7 @@ int gfc_return_by_reference (gfc_symbol *);
int gfc_is_nodesc_array (gfc_symbol *);
/* Return the DTYPE for an array. */
-tree gfc_get_dtype (tree);
+tree gfc_get_dtype (gfc_typespec *);
tree gfc_get_ppc_type (gfc_component *);
@@ -1078,7 +1078,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
tmp = TREE_OPERAND (array, 0);
gfc_init_se (&se, NULL);
- array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+ array = gfc_conv_scalar_to_descriptor (&se, array, attr, &var->ts);
array = gfc_build_addr_expr (NULL, array);
gcc_assert (se.post.head == NULL_TREE);
}
@@ -1122,7 +1122,7 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var,
/* attr: Argument is neither a pointer/allocatable,
i.e. no copy back needed */
gfc_init_se (&se, NULL);
- array = gfc_conv_scalar_to_descriptor (&se, array, attr);
+ array = gfc_conv_scalar_to_descriptor (&se, array, attr, &var->ts);
array = gfc_build_addr_expr (NULL, array);
gcc_assert (se.post.head == NULL_TREE);
}
@@ -404,7 +404,8 @@ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr);
void gfc_conv_expr_reference (gfc_se * se, gfc_expr *);
void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
-tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
+tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute,
+ gfc_typespec *);
/* Termine the byte-size of a string. */
tree size_of_string_in_bytes (int, tree);
@@ -24,5 +24,5 @@ end
! Note that it is the kind conversion that generates the temp.
!
! { dg-final { scan-tree-dump-times "parm" 28 "original" } }
-! { dg-final { scan-tree-dump-times "atmp" 28 "original" } }
+! { dg-final { scan-tree-dump-times "atmp" 26 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
@@ -16,6 +16,5 @@ function f() result(res)
end function f
end
-! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.base_addr = .void .. D.\[0-9\]+;.*desc.0.elem_len = 48;.*desc.0.version = 1;.*desc.0.rank = 0;.*desc.0.type = 600;.*desc.0.attribute = 1;.*sub \\(&desc.0\\);.*D.\[0-9\]+ = .integer.kind=4. .. desc.0.base_addr;" "original" } }
+! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.base_addr = .void .. D.\[0-9\]+;.*desc.0.elem_len = 32;.*desc.0.version = 1;.*desc.0.rank = 0;.*desc.0.type = 1025;.*desc.0.attribute = 1;.*sub \\(&desc.0\\);.*D.\[0-9\]+ = .integer.kind=4. .. desc.0.base_addr;" "original" } }
! { dg-final { cleanup-tree-dump "original" } }
-
@@ -15,10 +15,10 @@ subroutine sub(xxx, yyy)
ptr4 = c_loc (yyy(5:))
end
! { dg-final { scan-tree-dump-not " _gfortran_internal_pack" "original" } }
-! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
-! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } }
-! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
-! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } }
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } }
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
+! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.base_addr = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } }
-! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.data;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.base_addr;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } }
! { dg-final { cleanup-tree-dump "optimized" } }
@@ -25,7 +25,8 @@ call sub()
call sub2()
end
-! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.base_addr=0B, .elem_len=4, .version=1, .rank=1, .type=296, .attribute=2}, ._vptr=&__vtab_m_T};" 1 "original" } }
+! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.base_addr=0B, .elem_len=4, .version=1, .rank=1, .attribute=2, .type=-1}, ._vptr=&__vtab_m_T};" 1 "original" } }
! { dg-final { scan-tree-dump-times "static struct __class_m_T_a y = {._data=0B, ._vptr=&__vtab_m_T};" 1 "original" } }
+
! { dg-final { cleanup-tree-dump "original" } }
@@ -20,9 +20,7 @@ test_address (CFI_cdesc_t *dv)
if (dv->version != CFI_VERSION) abort ();
if (dv->elem_len != sizeof (float)/ sizeof (char)) abort ();
if (dv->attribute != CFI_attribute_other) abort ();
-
- /* FIXME: Add type assert:
- if (dv->type != CFI_type_float) abort (); */
+ if (dv->type != CFI_type_float) abort ();
/* FIXME: TS 29113 requires lower_bound == 0,
currently, lower_bound == 1 is used. */
@@ -61,5 +61,5 @@ end
! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
!
! { dg-final { scan-tree-dump-times "parm" 102 "original" } }
-! { dg-final { scan-tree-dump-times "atmp" 18 "original" } }
+! { dg-final { scan-tree-dump-times "atmp" 16 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
@@ -67,9 +67,9 @@ extern "C" {
/* Types definitions. */
typedef ptrdiff_t CFI_index_t;
-typedef int CFI_attribute_t;
-typedef ptrdiff_t CFI_type_t;
-typedef int CFI_rank_t;
+typedef int8_t CFI_rank_t;
+typedef int8_t CFI_attribute_t;
+typedef int16_t CFI_type_t;
typedef struct CFI_dim_t
@@ -86,9 +86,9 @@ typedef struct CFI_cdesc_t
size_t elem_len;
int version;
CFI_rank_t rank;
- size_t offset;
- CFI_type_t type;
CFI_attribute_t attribute;
+ CFI_type_t type;
+ size_t offset;
CFI_dim_t dim[];
}
CFI_cdesc_t;
@@ -102,13 +102,13 @@ struct {\
size_t elem_len;\
int version; \
CFI_rank_t rank; \
- size_t offset;\
- CFI_index_t type;\
CFI_attribute_t attribute; \
+ CFI_type_t type;\
+ size_t offset;\
CFI_dim_t dim[r];\
}
-#define CFI_CDESC_T(r) CFI_GFC_CDESC_T (r, void)
+#define CFI_CDESC_T(r) CFI_CDESC_TYPE_T (r, void)
/* Functions. */
@@ -141,9 +141,9 @@ int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
/* Types without kind paramter. */
-#define CFI_type_struct 7
-#define CFI_type_cptr 8
-#define CFI_type_cfunptr 9
+#define CFI_type_struct 6
+#define CFI_type_cptr 7
+#define CFI_type_cfunptr 8
#define CFI_type_other -1
@@ -37,7 +37,7 @@ 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_TYPE (pointer) != GFC_DESCRIPTOR_TYPE (target))
return 0;
rank = GFC_DESCRIPTOR_RANK (pointer);
@@ -51,7 +51,7 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
index_type n;
index_type arraysize;
- index_type type_size;
+ CFI_type_t type;
if (which < 1 || which > GFC_DESCRIPTOR_RANK (array))
runtime_error ("Argument 'DIM' is out of range in call to 'CSHIFT'");
@@ -92,98 +92,84 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
if (arraysize == 0)
return;
- type_size = GFC_DTYPE_TYPE_SIZE (array);
+ type = GFC_DESCRIPTOR_TYPE (array);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (array) == 1)
+ type = CFI_type_Integer1;
- switch(type_size)
+ switch(type)
{
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_INTEGER_1:
- case GFC_DTYPE_DERIVED_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
cshift0_i1 ((gfc_array_i1 *)ret, (gfc_array_i1 *) array, shift, which);
return;
- case GFC_DTYPE_LOGICAL_2:
- case GFC_DTYPE_INTEGER_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
cshift0_i2 ((gfc_array_i2 *)ret, (gfc_array_i2 *) array, shift, which);
return;
- case GFC_DTYPE_LOGICAL_4:
- case GFC_DTYPE_INTEGER_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
cshift0_i4 ((gfc_array_i4 *)ret, (gfc_array_i4 *) array, shift, which);
return;
- case GFC_DTYPE_LOGICAL_8:
- case GFC_DTYPE_INTEGER_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
cshift0_i8 ((gfc_array_i8 *)ret, (gfc_array_i8 *) array, shift, which);
return;
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_LOGICAL_16:
- case GFC_DTYPE_INTEGER_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
cshift0_i16 ((gfc_array_i16 *)ret, (gfc_array_i16 *) array, shift,
which);
return;
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
cshift0_r4 ((gfc_array_r4 *)ret, (gfc_array_r4 *) array, shift, which);
return;
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
cshift0_r8 ((gfc_array_r8 *)ret, (gfc_array_r8 *) array, shift, which);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
cshift0_r10 ((gfc_array_r10 *)ret, (gfc_array_r10 *) array, shift,
which);
return;
# endif
# ifdef HAVE_GFC_REAL_16
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
cshift0_r16 ((gfc_array_r16 *)ret, (gfc_array_r16 *) array, shift,
which);
return;
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
cshift0_c4 ((gfc_array_c4 *)ret, (gfc_array_c4 *) array, shift, which);
return;
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
cshift0_c8 ((gfc_array_c8 *)ret, (gfc_array_c8 *) array, shift, which);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
cshift0_c10 ((gfc_array_c10 *)ret, (gfc_array_c10 *) array, shift,
which);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
cshift0_c16 ((gfc_array_c16 *)ret, (gfc_array_c16 *) array, shift,
which);
return;
# endif
-#endif
default:
break;
@@ -286,7 +272,6 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array,
break;
}
-
which = which - 1;
sstride[0] = 0;
rstride[0] = 0;
@@ -271,9 +271,7 @@ 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_TYPE (avalues) = CFI_type_Real4;
GFC_DESCRIPTOR_ELEM_LEN (avalues) = sizeof (GFC_INTEGER_4);
GFC_DIMENSION_SET (avalues->dim[0], 0, 8, sizeof (GFC_REAL_4));
@@ -60,7 +60,8 @@ ISO_C_BINDING_PREFIX (c_f_pointer) (void *c_ptr_in,
f_ptr_out->offset = 0;
/* Set the data type (e.g., BT_INTEGER). */
- f_ptr_out->type = (type << GFC_DTYPE_TYPE_SHIFT);
+ f_ptr_out->type = type;
+ f_ptr_out->elem_len = elemSize;
}
/* Use the generic version of c_f_pointer to set common fields. */
@@ -156,8 +157,7 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
shift right by TYPE_SHIFT bits we'll throw away the existing
rank. Then, shift left by the same number to shift in zeros
and or with the new rank. */
- f_ptr_out->type = ((f_ptr_out->type >> GFC_DTYPE_TYPE_SHIFT)
- << GFC_DTYPE_TYPE_SHIFT);
+ f_ptr_out->type = f_ptr_out->type;
}
}
@@ -176,8 +176,7 @@ ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in,
/* Preserve the size and rank bits, but reset the type. */
if (shape != NULL)
{
- f_ptr_out->type = f_ptr_out->type & (~GFC_DTYPE_TYPE_MASK);
- f_ptr_out->type = f_ptr_out->type
- | (BT_DERIVED << GFC_DTYPE_TYPE_SHIFT);
+ f_ptr_out->type = f_ptr_out->type;
+ f_ptr_out->type = CFI_type_struct;
}
}
@@ -122,6 +122,8 @@ pack_internal (gfc_array_char *ret, const gfc_array_char *array,
extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
sstride[n] = GFC_DESCRIPTOR_SM(array,n);
mstride[n] = GFC_DESCRIPTOR_SM(mask,n);
+ if (extent[n] <= 0)
+ mptr = NULL;
}
if (sstride[0] == 0)
sstride[0] = size;
@@ -248,160 +250,154 @@ void
pack (gfc_array_char *ret, const gfc_array_char *array,
const gfc_array_l1 *mask, const gfc_array_char *vector)
{
- index_type type_size;
+ CFI_type_t type;
index_type size;
- type_size = GFC_DTYPE_TYPE_SIZE(array);
+ type = GFC_DESCRIPTOR_TYPE (array);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (array) == 1)
+ type = CFI_type_Integer1;
- switch(type_size)
+ switch(type)
{
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_INTEGER_1:
- case GFC_DTYPE_DERIVED_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
pack_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) array,
(gfc_array_l1 *) mask, (gfc_array_i1 *) vector);
return;
- case GFC_DTYPE_LOGICAL_2:
- case GFC_DTYPE_INTEGER_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
(gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
return;
- case GFC_DTYPE_LOGICAL_4:
- case GFC_DTYPE_INTEGER_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
(gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
return;
- case GFC_DTYPE_LOGICAL_8:
- case GFC_DTYPE_INTEGER_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
(gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
return;
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_LOGICAL_16:
- case GFC_DTYPE_INTEGER_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
(gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
return;
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
pack_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) array,
(gfc_array_l1 *) mask, (gfc_array_r4 *) vector);
return;
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
pack_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) array,
(gfc_array_l1 *) mask, (gfc_array_r8 *) vector);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
pack_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) array,
(gfc_array_l1 *) mask, (gfc_array_r10 *) vector);
return;
# endif
# ifdef HAVE_GFC_REAL_16
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
pack_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) array,
(gfc_array_l1 *) mask, (gfc_array_r16 *) vector);
return;
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
pack_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) array,
(gfc_array_l1 *) mask, (gfc_array_c4 *) vector);
return;
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
pack_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) array,
(gfc_array_l1 *) mask, (gfc_array_c8 *) vector);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
pack_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) array,
(gfc_array_l1 *) mask, (gfc_array_c10 *) vector);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
pack_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) array,
(gfc_array_l1 *) mask, (gfc_array_c16 *) vector);
return;
# endif
-#endif
/* For derived types, let's check the actual alignment of the
data pointers. If they are aligned, we can safely call
the unpack functions. */
- case GFC_DTYPE_DERIVED_2:
- if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(array->base_addr)
- || (vector && GFC_UNALIGNED_2(vector->base_addr)))
- break;
- else
- {
- pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
- (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
- return;
- }
+ case CFI_type_struct:
+ case CFI_type_other:
+ switch (GFC_DESCRIPTOR_ELEM_LEN(array))
+ {
+ case 2:
+ if (GFC_UNALIGNED_2(ret->base_addr)
+ || GFC_UNALIGNED_2(array->base_addr)
+ || (vector && GFC_UNALIGNED_2(vector->base_addr)))
+ break;
+ else
+ {
+ pack_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) array,
+ (gfc_array_l1 *) mask, (gfc_array_i2 *) vector);
+ return;
+ }
- case GFC_DTYPE_DERIVED_4:
- if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(array->base_addr)
- || (vector && GFC_UNALIGNED_4(vector->base_addr)))
- break;
- else
- {
- pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
- (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
- return;
- }
+ case 4:
+ if (GFC_UNALIGNED_4(ret->base_addr)
+ || GFC_UNALIGNED_4(array->base_addr)
+ || (vector && GFC_UNALIGNED_4(vector->base_addr)))
+ break;
+ else
+ {
+ pack_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) array,
+ (gfc_array_l1 *) mask, (gfc_array_i4 *) vector);
+ return;
+ }
- case GFC_DTYPE_DERIVED_8:
- if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(array->base_addr)
- || (vector && GFC_UNALIGNED_8(vector->base_addr)))
- break;
- else
- {
- pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
- (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
- return;
- }
+ case 8:
+ if (GFC_UNALIGNED_8(ret->base_addr)
+ || GFC_UNALIGNED_8(array->base_addr)
+ || (vector && GFC_UNALIGNED_8(vector->base_addr)))
+ break;
+ else
+ {
+ pack_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) array,
+ (gfc_array_l1 *) mask, (gfc_array_i8 *) vector);
+ return;
+ }
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_DERIVED_16:
- if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(array->base_addr)
- || (vector && GFC_UNALIGNED_16(vector->base_addr)))
- break;
- else
- {
- pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
- (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
- return;
- }
+ case 16:
+ if (GFC_UNALIGNED_16(ret->base_addr)
+ || GFC_UNALIGNED_16(array->base_addr)
+ || (vector && GFC_UNALIGNED_16(vector->base_addr)))
+ break;
+ else
+ {
+ pack_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) array,
+ (gfc_array_l1 *) mask, (gfc_array_i16 *) vector);
+ return;
+ }
#endif
-
+ }
}
size = GFC_DESCRIPTOR_ELEM_LEN (array);
@@ -252,8 +252,9 @@ spread_internal_scalar (gfc_array_char *ret, const char *source,
}
else
{
- if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
- / GFC_DESCRIPTOR_STRIDE(ret,0))
+ if (ncopies - 1
+ > (index_type) ((GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
+ / GFC_DESCRIPTOR_STRIDE(ret,0)))
runtime_error ("dim too large in spread()");
}
@@ -272,150 +273,146 @@ void
spread (gfc_array_char *ret, const gfc_array_char *source,
const index_type *along, const index_type *pncopies)
{
- index_type type_size;
+ CFI_type_t type;
- type_size = GFC_DTYPE_TYPE_SIZE(ret);
- switch(type_size)
+ type = GFC_DESCRIPTOR_TYPE (ret);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (ret) == 1)
+ type = CFI_type_Integer1;
+
+ switch(type)
{
- case GFC_DTYPE_DERIVED_1:
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_INTEGER_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_LOGICAL_2:
- case GFC_DTYPE_INTEGER_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_LOGICAL_4:
- case GFC_DTYPE_INTEGER_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_LOGICAL_8:
- case GFC_DTYPE_INTEGER_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_LOGICAL_16:
- case GFC_DTYPE_INTEGER_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
*along, *pncopies);
return;
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
*along, *pncopies);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef GFC_HAVE_REAL_10
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
*along, *pncopies);
return;
# endif
# ifdef GFC_HAVE_REAL_16
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
*along, *pncopies);
return;
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
*along, *pncopies);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef GFC_HAVE_COMPLEX_10
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
*along, *pncopies);
return;
# endif
# ifdef GFC_HAVE_COMPLEX_16
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
*along, *pncopies);
return;
# endif
-#endif
- case GFC_DTYPE_DERIVED_2:
- if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source->base_addr))
- break;
- else
+ case CFI_type_struct:
+ case CFI_type_other:
+ switch (GFC_DESCRIPTOR_ELEM_LEN(ret))
{
- spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
- *along, *pncopies);
+ case 2:
+ if (GFC_UNALIGNED_2(ret->base_addr)
+ || GFC_UNALIGNED_2(source->base_addr))
+ break;
+ else
+ {
+ spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
+ *along, *pncopies);
return;
- }
+ }
- case GFC_DTYPE_DERIVED_4:
- if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source->base_addr))
- break;
- else
- {
- spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
- *along, *pncopies);
+ case 4:
+ if (GFC_UNALIGNED_4(ret->base_addr)
+ || GFC_UNALIGNED_4(source->base_addr))
+ break;
+ else
+ {
+ spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
+ *along, *pncopies);
return;
- }
+ }
- case GFC_DTYPE_DERIVED_8:
- if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source->base_addr))
- break;
- else
- {
- spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
- *along, *pncopies);
+ case 8:
+ if (GFC_UNALIGNED_8(ret->base_addr)
+ || GFC_UNALIGNED_8(source->base_addr))
+ break;
+ else
+ {
+ spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
+ *along, *pncopies);
return;
- }
+ }
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_DERIVED_16:
- if (GFC_UNALIGNED_16(ret->base_addr)
- || GFC_UNALIGNED_16(source->base_addr))
- break;
- else
- {
- spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
- *along, *pncopies);
- return;
- }
+ case 16:
+ if (GFC_UNALIGNED_16(ret->base_addr)
+ || GFC_UNALIGNED_16(source->base_addr))
+ break;
+ else
+ {
+ spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
+ *along, *pncopies);
+ return;
+ }
#endif
+ }
+ break;
}
spread_internal (ret, source, along, pncopies);
@@ -465,151 +462,144 @@ void
spread_scalar (gfc_array_char *ret, const char *source,
const index_type *along, const index_type *pncopies)
{
- index_type type_size;
+ CFI_type_t type;
if (!ret->type)
runtime_error ("return array missing descriptor in spread()");
- type_size = GFC_DTYPE_TYPE_SIZE(ret);
- switch(type_size)
+ type = GFC_DESCRIPTOR_TYPE (ret);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (ret) == 1)
+ type = CFI_type_Integer1;
+
+ switch(type)
{
- case GFC_DTYPE_DERIVED_1:
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_INTEGER_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_LOGICAL_2:
- case GFC_DTYPE_INTEGER_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_LOGICAL_4:
- case GFC_DTYPE_INTEGER_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_LOGICAL_8:
- case GFC_DTYPE_INTEGER_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
*along, *pncopies);
return;
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_LOGICAL_16:
- case GFC_DTYPE_INTEGER_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
*along, *pncopies);
return;
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
*along, *pncopies);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
*along, *pncopies);
return;
# endif
# ifdef HAVE_GFC_REAL_16
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
*along, *pncopies);
return;
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
*along, *pncopies);
return;
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
*along, *pncopies);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
*along, *pncopies);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
*along, *pncopies);
return;
# endif
-#endif
- case GFC_DTYPE_DERIVED_2:
- if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
- break;
- else
+ case CFI_type_struct:
+ case CFI_type_other:
+ switch (GFC_DESCRIPTOR_ELEM_LEN(ret))
{
- spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
- *along, *pncopies);
- return;
- }
+ case 2:
+ if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(source))
+ break;
+ else
+ {
+ spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
+ *along, *pncopies);
+ return;
+ }
- case GFC_DTYPE_DERIVED_4:
- if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
- break;
- else
- {
- spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
- *along, *pncopies);
- return;
- }
+ case 4:
+ if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(source))
+ break;
+ else
+ {
+ spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
+ *along, *pncopies);
+ return;
+ }
+
+ case 8:
+ if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
+ break;
+ else
+ {
+ spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
+ *along, *pncopies);
+ return;
+ }
- case GFC_DTYPE_DERIVED_8:
- if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(source))
- break;
- else
- {
- spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
- *along, *pncopies);
- return;
- }
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_DERIVED_16:
- if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
- break;
- else
- {
- spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
- *along, *pncopies);
- return;
- }
+ case 16:
+ if (GFC_UNALIGNED_16(ret->base_addr) || GFC_UNALIGNED_16(source))
+ break;
+ else
+ {
+ spread_scalar_i16 ((gfc_array_i16 *) ret,
+ (GFC_INTEGER_16 *) source, *along, *pncopies);
+ return;
+ }
#endif
+ }
}
spread_internal_scalar (ret, source, along, pncopies);
@@ -207,160 +207,155 @@ void
unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, const gfc_array_char *field)
{
- index_type type_size;
+ CFI_type_t type;
index_type size;
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, field);
- type_size = GFC_DTYPE_TYPE_SIZE (vector);
size = GFC_DESCRIPTOR_ELEM_LEN (vector);
- switch(type_size)
+ type = GFC_DESCRIPTOR_TYPE (vector);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (vector) == 1)
+ type = CFI_type_Integer1;
+
+ switch (type)
{
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_INTEGER_1:
- case GFC_DTYPE_DERIVED_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
mask, (gfc_array_i1 *) field);
return;
- case GFC_DTYPE_LOGICAL_2:
- case GFC_DTYPE_INTEGER_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (gfc_array_i2 *) field);
return;
- case GFC_DTYPE_LOGICAL_4:
- case GFC_DTYPE_INTEGER_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (gfc_array_i4 *) field);
return;
- case GFC_DTYPE_LOGICAL_8:
- case GFC_DTYPE_INTEGER_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (gfc_array_i8 *) field);
return;
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_LOGICAL_16:
- case GFC_DTYPE_INTEGER_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (gfc_array_i16 *) field);
return;
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
mask, (gfc_array_r4 *) field);
return;
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
mask, (gfc_array_r8 *) field);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
mask, (gfc_array_r10 *) field);
return;
# endif
# ifdef HAVE_GFC_REAL_16
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
mask, (gfc_array_r16 *) field);
return;
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
mask, (gfc_array_c4 *) field);
return;
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
mask, (gfc_array_c8 *) field);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
mask, (gfc_array_c10 *) field);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
mask, (gfc_array_c16 *) field);
return;
# endif
-#endif
-
- case GFC_DTYPE_DERIVED_2:
- if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
- || GFC_UNALIGNED_2(field->base_addr))
- break;
- else
- {
- unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
- mask, (gfc_array_i2 *) field);
- return;
- }
-
- case GFC_DTYPE_DERIVED_4:
- if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
- || GFC_UNALIGNED_4(field->base_addr))
- break;
- else
- {
- unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
- mask, (gfc_array_i4 *) field);
- return;
- }
- case GFC_DTYPE_DERIVED_8:
- if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
- || GFC_UNALIGNED_8(field->base_addr))
- break;
- else
- {
- unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
- mask, (gfc_array_i8 *) field);
- return;
- }
+ case CFI_type_struct:
+ case CFI_type_other:
+ switch (GFC_DESCRIPTOR_ELEM_LEN(vector))
+ {
+ case 2:
+ if (GFC_UNALIGNED_2(ret->base_addr)
+ || GFC_UNALIGNED_2(vector->base_addr)
+ || GFC_UNALIGNED_2(field->base_addr))
+ break;
+ else
+ {
+ unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
+ mask, (gfc_array_i2 *) field);
+ return;
+ }
+
+ case 4:
+ if (GFC_UNALIGNED_4(ret->base_addr)
+ || GFC_UNALIGNED_4(vector->base_addr)
+ || GFC_UNALIGNED_4(field->base_addr))
+ break;
+ else
+ {
+ unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
+ mask, (gfc_array_i4 *) field);
+ return;
+ }
+
+ case 8:
+ if (GFC_UNALIGNED_8(ret->base_addr)
+ || GFC_UNALIGNED_8(vector->base_addr)
+ || GFC_UNALIGNED_8(field->base_addr))
+ break;
+ else
+ {
+ unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
+ mask, (gfc_array_i8 *) field);
+ return;
+ }
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_DERIVED_16:
- if (GFC_UNALIGNED_16(ret->base_addr)
- || GFC_UNALIGNED_16(vector->base_addr)
- || GFC_UNALIGNED_16(field->base_addr))
- break;
- else
- {
- unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
- mask, (gfc_array_i16 *) field);
- return;
- }
+ case 16:
+ if (GFC_UNALIGNED_16(ret->base_addr)
+ || GFC_UNALIGNED_16(vector->base_addr)
+ || GFC_UNALIGNED_16(field->base_addr))
+ break;
+ else
+ {
+ unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
+ mask, (gfc_array_i16 *) field);
+ return;
+ }
#endif
+ }
}
unpack_internal (ret, vector, mask, field, size);
@@ -419,160 +414,152 @@ unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l1 *mask, char *field)
{
gfc_array_char tmp;
-
- index_type type_size;
+ CFI_type_t type;
if (unlikely(compile_options.bounds_check))
unpack_bounds (ret, vector, mask, NULL);
- type_size = GFC_DTYPE_TYPE_SIZE (vector);
+ type = GFC_DESCRIPTOR_TYPE (vector);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (vector) == 1)
+ type = CFI_type_Integer1;
- switch (type_size)
+ switch (type)
{
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_INTEGER_1:
- case GFC_DTYPE_DERIVED_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
mask, (GFC_INTEGER_1 *) field);
return;
- case GFC_DTYPE_LOGICAL_2:
- case GFC_DTYPE_INTEGER_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
mask, (GFC_INTEGER_2 *) field);
return;
- case GFC_DTYPE_LOGICAL_4:
- case GFC_DTYPE_INTEGER_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
mask, (GFC_INTEGER_4 *) field);
return;
- case GFC_DTYPE_LOGICAL_8:
- case GFC_DTYPE_INTEGER_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
mask, (GFC_INTEGER_8 *) field);
return;
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_LOGICAL_16:
- case GFC_DTYPE_INTEGER_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
mask, (GFC_INTEGER_16 *) field);
return;
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
mask, (GFC_REAL_4 *) field);
return;
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
mask, (GFC_REAL_8 *) field);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_REAL_10
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
mask, (GFC_REAL_10 *) field);
return;
# endif
# ifdef HAVE_GFC_REAL_16
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
mask, (GFC_REAL_16 *) field);
return;
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
mask, (GFC_COMPLEX_4 *) field);
return;
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
mask, (GFC_COMPLEX_8 *) field);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# ifdef HAVE_GFC_COMPLEX_10
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
mask, (GFC_COMPLEX_10 *) field);
return;
# endif
# ifdef HAVE_GFC_COMPLEX_16
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
mask, (GFC_COMPLEX_16 *) field);
return;
# endif
-#endif
-
- case GFC_DTYPE_DERIVED_2:
- if (GFC_UNALIGNED_2(ret->base_addr) || GFC_UNALIGNED_2(vector->base_addr)
- || GFC_UNALIGNED_2(field))
- break;
- else
- {
- unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
- mask, (GFC_INTEGER_2 *) field);
- return;
- }
-
- case GFC_DTYPE_DERIVED_4:
- if (GFC_UNALIGNED_4(ret->base_addr) || GFC_UNALIGNED_4(vector->base_addr)
- || GFC_UNALIGNED_4(field))
- break;
- else
- {
- unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
- mask, (GFC_INTEGER_4 *) field);
- return;
- }
- case GFC_DTYPE_DERIVED_8:
- if (GFC_UNALIGNED_8(ret->base_addr) || GFC_UNALIGNED_8(vector->base_addr)
- || GFC_UNALIGNED_8(field))
- break;
- else
+ case CFI_type_struct:
+ case CFI_type_other:
+ switch (GFC_DESCRIPTOR_ELEM_LEN(vector))
{
- unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
- mask, (GFC_INTEGER_8 *) field);
- return;
- }
+ case 2:
+ if (GFC_UNALIGNED_2(ret->base_addr)
+ || GFC_UNALIGNED_2(vector->base_addr)
+ || GFC_UNALIGNED_2(field))
+ break;
+ else
+ {
+ unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
+ mask, (GFC_INTEGER_2 *) field);
+ return;
+ }
+
+ case 4:
+ if (GFC_UNALIGNED_4(ret->base_addr)
+ || GFC_UNALIGNED_4(vector->base_addr)
+ || GFC_UNALIGNED_4(field))
+ break;
+ else
+ {
+ unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
+ mask, (GFC_INTEGER_4 *) field);
+ return;
+ }
+
+ case 8:
+ if (GFC_UNALIGNED_8(ret->base_addr)
+ || GFC_UNALIGNED_8(vector->base_addr)
+ || GFC_UNALIGNED_8(field))
+ break;
+ else
+ {
+ unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
+ mask, (GFC_INTEGER_8 *) field);
+ return;
+ }
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_DERIVED_16:
- if (GFC_UNALIGNED_16(ret->base_addr)
- || GFC_UNALIGNED_16(vector->base_addr)
- || GFC_UNALIGNED_16(field))
- break;
- else
- {
- unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
- mask, (GFC_INTEGER_16 *) field);
- return;
- }
+ case 16:
+ if (GFC_UNALIGNED_16(ret->base_addr)
+ || GFC_UNALIGNED_16(vector->base_addr)
+ || GFC_UNALIGNED_16(field))
+ break;
+ else
+ {
+ unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
+ mask, (GFC_INTEGER_16 *) field);
+ return;
+ }
#endif
-
+ }
}
memset (&tmp, 0, sizeof (tmp));
@@ -106,6 +106,9 @@ typedef struct namelist_type
/* Object type. */
bt type;
+ /* Intrinsic kind. */
+ int kind;
+
/* Object name. */
char * var_name;
@@ -115,9 +118,6 @@ typedef struct namelist_type
/* Flag to show that a read is to be attempted for this node. */
int touched;
- /* Length of intrinsic type in bytes. */
- int len;
-
/* Rank of the object. */
int var_rank;
@@ -2486,7 +2486,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
namelist_info * cmp;
char * obj_name;
int nml_carry;
- int len;
+ int kind;
int dim;
index_type dlen;
index_type m;
@@ -2501,29 +2501,11 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
dtp->u.p.repeat_count = 0;
eat_spaces (dtp);
- len = nl->len;
- switch (nl->type)
- {
- case BT_INTEGER:
- case BT_LOGICAL:
- dlen = len;
- break;
-
- case BT_REAL:
- dlen = size_from_real_kind (len);
- break;
-
- case BT_COMPLEX:
- dlen = size_from_complex_kind (len);
- break;
-
- case BT_CHARACTER:
- dlen = chigh ? (chigh - clow + 1) : nl->string_length;
- break;
-
- default:
- dlen = 0;
- }
+ kind = nl->kind;
+ if (nl->type == BT_CHARACTER)
+ dlen = chigh ? (chigh - clow + 1) : nl->string_length;
+ else
+ dlen = nl->size;
do
{
@@ -2553,27 +2535,27 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
switch (nl->type)
{
case BT_INTEGER:
- read_integer (dtp, len);
+ read_integer (dtp, kind);
break;
case BT_LOGICAL:
- read_logical (dtp, len);
+ read_logical (dtp, kind);
break;
case BT_CHARACTER:
- read_character (dtp, len);
+ read_character (dtp, kind);
break;
case BT_REAL:
/* Need to copy data back from the real location to the temp in
order to handle nml reads into arrays. */
- read_real (dtp, pdata, len);
+ read_real (dtp, pdata, kind);
memcpy (dtp->u.p.value, pdata, dlen);
break;
case BT_COMPLEX:
/* Same as for REAL, copy back to temp. */
- read_complex (dtp, pdata, len, dlen);
+ read_complex (dtp, pdata, kind, dlen);
memcpy (dtp->u.p.value, pdata, dlen);
break;
@@ -2132,7 +2132,11 @@ transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
- iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
+ iotype = (bt) (GFC_DESCRIPTOR_TYPE (desc) & CFI_type_mask);
+
+ if (iotype > CFI_type_Character)
+ internal_error (NULL, "transfer_array(): Bad type");
+
size = iotype == BT_CHARACTER ? charlen
: (index_type) GFC_DESCRIPTOR_ELEM_LEN (desc);
@@ -3749,15 +3753,13 @@ st_wait (st_parameter_wait *wtp __attribute__((unused)))
in a linked list of namelist_info types. */
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
- GFC_INTEGER_4, size_t, int,
- GFC_INTEGER_4);
+ int, size_t, int, int);
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, size_t elem_len,
- int rank, GFC_INTEGER_4 type)
+ int kind, size_t elem_len, int rank, int type)
{
namelist_info *t1 = NULL;
namelist_info *nml;
@@ -3771,12 +3773,12 @@ st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
memcpy (nml->var_name, var_name, var_name_len);
nml->var_name[var_name_len] = '\0';
- nml->len = (int) len;
- nml->string_length = len ? (index_type) elem_len/len : 0;
-
- nml->var_rank = rank;
+ nml->type = (bt) type;
+ nml->kind = kind;
nml->size = (index_type) elem_len;
- nml->type = (bt) ((type & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
+ nml->string_length = nml->type == BT_CHARACTER
+ ? (index_type) elem_len/kind : 0;
+ nml->var_rank = rank;
if (nml->var_rank > 0)
{
@@ -1744,28 +1744,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
num = 1;
- len = obj->len;
-
- switch (obj->type)
- {
-
- case BT_REAL:
- obj_size = size_from_real_kind (len);
- break;
-
- case BT_COMPLEX:
- obj_size = size_from_complex_kind (len);
- break;
-
- case BT_CHARACTER:
- obj_size = obj->string_length;
- break;
-
- default:
- obj_size = len;
- }
-
- if (obj->var_rank)
+ len = obj->kind;
+ if (obj->type == BT_CHARACTER)
+ obj_size = obj->string_length;
+ else
obj_size = obj->size;
/* Set the index vector and count the number of elements. */
@@ -324,9 +324,20 @@ internal_proto(big_endian);
#if GFC_ATTRIBUTE_POINTER != CFI_attribute_pointer \
|| GFC_ATTRIBUTE_ALLOCATABLE != CFI_attribute_allocatable \
- || GFC_ATTRIBUTE_OTHER != CFI_attribute_other
- || GFC_MAX_DIMENSIONS != CFI_MAX_RANK
- chokeme
+ || GFC_ATTRIBUTE_OTHER != CFI_attribute_other \
+ || GFC_MAX_DIMENSIONS != CFI_MAX_RANK \
+ || GFC_TYPE_INTEGER != CFI_type_Integer \
+ || GFC_TYPE_LOGICAL != CFI_type_Logical \
+ || GFC_TYPE_REAL != CFI_type_Real \
+ || GFC_TYPE_COMPLEX != CFI_type_Complex \
+ || GFC_TYPE_CHARACTER != CFI_type_Character \
+ || GFC_TYPE_STRUCT != CFI_type_struct \
+ || GFC_TYPE_CPTR != CFI_type_cptr \
+ || GFC_TYPE_CFUNPTR != CFI_type_cfunptr \
+ || GFC_TYPE_OTHER != CFI_type_other \
+ || GFC_TYPE_KIND_SHIFT != CFI_type_kind_shift \
+ || GFC_TYPE_MASK != CFI_type_mask
+ choke me
#endif
typedef CFI_dim_t descriptor_dimension;
@@ -367,8 +378,7 @@ typedef CFI_CDESC_TYPE_T (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16;
#define GFC_DESCRIPTOR_RANK(desc) ((desc)->rank)
-#define GFC_DESCRIPTOR_TYPE(desc) (((desc)->type & GFC_DTYPE_TYPE_MASK) \
- >> GFC_DTYPE_TYPE_SHIFT)
+#define GFC_DESCRIPTOR_TYPE(desc) ((desc)->type)
#define GFC_DESCRIPTOR_ELEM_LEN(desc) ((desc)->elem_len)
/* This is for getting the size of a type when the type of the
@@ -376,7 +386,6 @@ typedef CFI_CDESC_TYPE_T (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16;
#define GFC_DESCRIPTOR_SIZE_TYPEKNOWN(desc) (sizeof((desc)->base_addr[0]))
#define GFC_DESCRIPTOR_DATA(desc) ((desc)->base_addr)
-#define GFC_DESCRIPTOR_DTYPE(desc) ((desc)->type)
#define GFC_DIMENSION_LBOUND(dim) ((dim).lower_bound)
#define GFC_DIMENSION_UBOUND(dim) ((dim).lower_bound + (dim).extent - 1)
@@ -407,80 +416,8 @@ typedef CFI_CDESC_TYPE_T (GFC_MAX_DIMENSIONS, GFC_LOGICAL_16) gfc_array_l16;
types. */
#define GFC_DESCRIPTOR_STRIDE_TYPEKNOWN(desc,i) \
- (GFC_DESCRIPTOR_SM(desc,i) / GFC_DESCRIPTOR_SIZE_TYPEKNOWN(desc))
+ ((index_type)(GFC_DESCRIPTOR_SM(desc,i) / GFC_DESCRIPTOR_SIZE_TYPEKNOWN(desc)))
-/* Macros to get both the size and the type with a single masking operation */
-
-#define GFC_DTYPE_SIZE_MASK \
- ((~((index_type) 0) >> GFC_DTYPE_SIZE_SHIFT) << 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)->type & GFC_DTYPE_TYPE_SIZE_MASK)
-
-#define GFC_DTYPE_INTEGER_1 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_INTEGER_2 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_2) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_INTEGER_4 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_4) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_INTEGER_8 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_8) << GFC_DTYPE_SIZE_SHIFT))
-#ifdef HAVE_GFC_INTEGER_16
-#define GFC_DTYPE_INTEGER_16 ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_16) << GFC_DTYPE_SIZE_SHIFT))
-#endif
-
-#define GFC_DTYPE_LOGICAL_1 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_LOGICAL_1) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_LOGICAL_2 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_LOGICAL_2) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_LOGICAL_4 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_LOGICAL_4) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_LOGICAL_8 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_LOGICAL_8) << GFC_DTYPE_SIZE_SHIFT))
-#ifdef HAVE_GFC_LOGICAL_16
-#define GFC_DTYPE_LOGICAL_16 ((BT_LOGICAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_LOGICAL_16) << GFC_DTYPE_SIZE_SHIFT))
-#endif
-
-#define GFC_DTYPE_REAL_4 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_REAL_4) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_REAL_8 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_REAL_8) << GFC_DTYPE_SIZE_SHIFT))
-#ifdef HAVE_GFC_REAL_10
-#define GFC_DTYPE_REAL_10 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_REAL_10) << GFC_DTYPE_SIZE_SHIFT))
-#endif
-#ifdef HAVE_GFC_REAL_16
-#define GFC_DTYPE_REAL_16 ((BT_REAL << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_REAL_16) << GFC_DTYPE_SIZE_SHIFT))
-#endif
-
-#define GFC_DTYPE_COMPLEX_4 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_COMPLEX_4) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_COMPLEX_8 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_COMPLEX_8) << GFC_DTYPE_SIZE_SHIFT))
-#ifdef HAVE_GFC_COMPLEX_10
-#define GFC_DTYPE_COMPLEX_10 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_COMPLEX_10) << GFC_DTYPE_SIZE_SHIFT))
-#endif
-#ifdef HAVE_GFC_COMPLEX_16
-#define GFC_DTYPE_COMPLEX_16 ((BT_COMPLEX << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_COMPLEX_16) << GFC_DTYPE_SIZE_SHIFT))
-#endif
-
-#define GFC_DTYPE_DERIVED_1 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_1) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_DERIVED_2 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_2) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_DERIVED_4 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_4) << GFC_DTYPE_SIZE_SHIFT))
-#define GFC_DTYPE_DERIVED_8 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_8) << GFC_DTYPE_SIZE_SHIFT))
-#ifdef HAVE_GFC_INTEGER_16
-#define GFC_DTYPE_DERIVED_16 ((BT_DERIVED << GFC_DTYPE_TYPE_SHIFT) \
- | (sizeof(GFC_INTEGER_16) << GFC_DTYPE_SIZE_SHIFT))
-#endif
/* Macros to determine the alignment of pointers. */
@@ -46,109 +46,102 @@ internal_pack (gfc_array_char * source)
int n;
int packed;
index_type size;
- index_type type_size;
+ CFI_type_t type;
if (source->base_addr == NULL)
- return NULL;
+ return source->base_addr;
+
+ type = GFC_DESCRIPTOR_TYPE (source);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (source) == 1)
+ type = CFI_type_Integer1;
- type_size = GFC_DTYPE_TYPE_SIZE(source);
- switch (type_size)
+ switch (type)
{
- case GFC_DTYPE_INTEGER_1:
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_DERIVED_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
return internal_pack_1 ((gfc_array_i1 *) source);
- case GFC_DTYPE_INTEGER_2:
- case GFC_DTYPE_LOGICAL_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
return internal_pack_2 ((gfc_array_i2 *) source);
- case GFC_DTYPE_INTEGER_4:
- case GFC_DTYPE_LOGICAL_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
return internal_pack_4 ((gfc_array_i4 *) source);
- case GFC_DTYPE_INTEGER_8:
- case GFC_DTYPE_LOGICAL_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
return internal_pack_8 ((gfc_array_i8 *) source);
#if defined(HAVE_GFC_INTEGER_16)
- case GFC_DTYPE_INTEGER_16:
- case GFC_DTYPE_LOGICAL_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
return internal_pack_16 ((gfc_array_i16 *) source);
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
return internal_pack_r4 ((gfc_array_r4 *) source);
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
return internal_pack_r8 ((gfc_array_r8 *) source);
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined (HAVE_GFC_REAL_10)
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
return internal_pack_r10 ((gfc_array_r10 *) source);
# endif
# if defined (HAVE_GFC_REAL_16)
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
return internal_pack_r16 ((gfc_array_r16 *) source);
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
return internal_pack_c4 ((gfc_array_c4 *) source);
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
return internal_pack_c8 ((gfc_array_c8 *) source);
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined (HAVE_GFC_COMPLEX_10)
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
return internal_pack_c10 ((gfc_array_c10 *) source);
# endif
# if defined (HAVE_GFC_COMPLEX_16)
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
return internal_pack_c16 ((gfc_array_c16 *) source);
# endif
-#endif
- case GFC_DTYPE_DERIVED_2:
- if (GFC_UNALIGNED_2(source->base_addr))
- break;
- else
- return internal_pack_2 ((gfc_array_i2 *) source);
-
- case GFC_DTYPE_DERIVED_4:
- if (GFC_UNALIGNED_4(source->base_addr))
- break;
- else
- return internal_pack_4 ((gfc_array_i4 *) source);
-
- case GFC_DTYPE_DERIVED_8:
- if (GFC_UNALIGNED_8(source->base_addr))
- break;
- else
- return internal_pack_8 ((gfc_array_i8 *) source);
+ case CFI_type_struct:
+ case CFI_type_other:
+ switch (GFC_DESCRIPTOR_ELEM_LEN(source))
+ {
+ case 2:
+ if (GFC_UNALIGNED_2(source->base_addr))
+ break;
+ else
+ return internal_pack_2 ((gfc_array_i2 *) source);
+
+ case 4:
+ if (GFC_UNALIGNED_4(source->base_addr))
+ break;
+ else
+ return internal_pack_4 ((gfc_array_i4 *) source);
+
+ case 8:
+ if (GFC_UNALIGNED_8(source->base_addr))
+ break;
+ else
+ return internal_pack_8 ((gfc_array_i8 *) source);
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_DERIVED_16:
- if (GFC_UNALIGNED_16(source->base_addr))
- break;
- else
- return internal_pack_16 ((gfc_array_i16 *) source);
+ case 16:
+ if (GFC_UNALIGNED_16(source->base_addr))
+ break;
+ else
+ return internal_pack_16 ((gfc_array_i16 *) source);
#endif
+ }
+ break;
default:
break;
@@ -179,8 +172,8 @@ internal_pack (gfc_array_char * source)
if (packed)
return source->base_addr;
- /* Allocate storage for the destination. */
- destptr = xmalloc (ssize * size);
+ /* Allocate storage for the destination. */
+ destptr = xmalloc (ssize);
dest = (char *)destptr;
src = source->base_addr;
sm0 = sm[0];
@@ -44,142 +44,136 @@ internal_unpack (gfc_array_char * d, const void * s)
const char *src;
int n;
int size;
- int type_size;
+ CFI_type_t type;
dest = d->base_addr;
/* This check may be redundant, but do it anyway. */
if (s == dest || !s)
return;
- type_size = GFC_DTYPE_TYPE_SIZE (d);
- switch (type_size)
+ type = GFC_DESCRIPTOR_TYPE (d);
+ if ((type == CFI_type_struct || type == CFI_type_other)
+ && GFC_DESCRIPTOR_ELEM_LEN (d) == 1)
+ type = CFI_type_Integer1;
+
+ switch (type)
{
- case GFC_DTYPE_INTEGER_1:
- case GFC_DTYPE_LOGICAL_1:
- case GFC_DTYPE_DERIVED_1:
+ case CFI_type_Integer1:
+ case CFI_type_Logical1:
internal_unpack_1 ((gfc_array_i1 *) d, (const GFC_INTEGER_1 *) s);
return;
- case GFC_DTYPE_INTEGER_2:
- case GFC_DTYPE_LOGICAL_2:
+ case CFI_type_Integer2:
+ case CFI_type_Logical2:
internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
return;
- case GFC_DTYPE_INTEGER_4:
- case GFC_DTYPE_LOGICAL_4:
+ case CFI_type_Integer4:
+ case CFI_type_Logical4:
internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
return;
- case GFC_DTYPE_INTEGER_8:
- case GFC_DTYPE_LOGICAL_8:
+ case CFI_type_Integer8:
+ case CFI_type_Logical8:
internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
return;
#if defined (HAVE_GFC_INTEGER_16)
- case GFC_DTYPE_INTEGER_16:
- case GFC_DTYPE_LOGICAL_16:
+ case CFI_type_Integer16:
+ case CFI_type_Logical16:
internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
return;
#endif
- case GFC_DTYPE_REAL_4:
+ case CFI_type_Real4:
internal_unpack_r4 ((gfc_array_r4 *) d, (const GFC_REAL_4 *) s);
return;
- case GFC_DTYPE_REAL_8:
+ case CFI_type_Real8:
internal_unpack_r8 ((gfc_array_r8 *) d, (const GFC_REAL_8 *) s);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined(HAVE_GFC_REAL_10)
- case GFC_DTYPE_REAL_10:
+ case CFI_type_Real10:
internal_unpack_r10 ((gfc_array_r10 *) d, (const GFC_REAL_10 *) s);
return;
# endif
# if defined(HAVE_GFC_REAL_16)
- case GFC_DTYPE_REAL_16:
+ case CFI_type_Real16:
internal_unpack_r16 ((gfc_array_r16 *) d, (const GFC_REAL_16 *) s);
return;
# endif
-#endif
- case GFC_DTYPE_COMPLEX_4:
+ case CFI_type_Complex4:
internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s);
return;
- case GFC_DTYPE_COMPLEX_8:
+ case CFI_type_Complex8:
internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s);
return;
-/* FIXME: This here is a hack, which will have to be removed when
- the array descriptor is reworked. Currently, we don't store the
- kind value for the type, but only the size. Because on targets with
- __float128, we have sizeof(logn double) == sizeof(__float128),
- we cannot discriminate here and have to fall back to the generic
- handling (which is suboptimal). */
-#if !defined(GFC_REAL_16_IS_FLOAT128)
# if defined(HAVE_GFC_COMPLEX_10)
- case GFC_DTYPE_COMPLEX_10:
+ case CFI_type_Complex10:
internal_unpack_c10 ((gfc_array_c10 *) d, (const GFC_COMPLEX_10 *) s);
return;
# endif
# if defined(HAVE_GFC_COMPLEX_16)
- case GFC_DTYPE_COMPLEX_16:
+ case CFI_type_Complex16:
internal_unpack_c16 ((gfc_array_c16 *) d, (const GFC_COMPLEX_16 *) s);
return;
# endif
-#endif
-
- case GFC_DTYPE_DERIVED_2:
- if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s))
- break;
- else
- {
- internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
- return;
- }
- case GFC_DTYPE_DERIVED_4:
- if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s))
- break;
- else
- {
- internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
- return;
- }
- case GFC_DTYPE_DERIVED_8:
- if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s))
- break;
- else
+ case CFI_type_struct:
+ case CFI_type_other:
+ switch (GFC_DESCRIPTOR_ELEM_LEN(d))
{
- internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
- return;
- }
+ case 2:
+ if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s))
+ break;
+ else
+ {
+ internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
+ return;
+ }
+
+ case 4:
+ if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s))
+ break;
+ else
+ {
+ internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
+ return;
+ }
+
+ case 8:
+ if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s))
+ break;
+ else
+ {
+ internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
+ return;
+ }
#ifdef HAVE_GFC_INTEGER_16
- case GFC_DTYPE_DERIVED_16:
- if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s))
- break;
- else
- {
- internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
- return;
- }
+ case 16:
+ if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s))
+ break;
+ else
+ {
+ internal_unpack_16 ((gfc_array_i16 *) d,
+ (const GFC_INTEGER_16 *) s);
+ return;
+ }
#endif
+ }
+ break;
default:
break;
}
-
dim = GFC_DESCRIPTOR_RANK (d);
size = GFC_DESCRIPTOR_ELEM_LEN (d);
dsize = size;
@@ -1,4 +1,4 @@
-/* ISO_Fortran_binding.h of GCC's GNU Fortran compiler.
+/* iso_ts29113.c. of GCC's GNU Fortran compiler.
Copyright (C) 2013 Free Software Foundation, Inc.
This file is part of the GNU Fortran runtime library (libgfortran)
@@ -252,9 +252,9 @@ CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source,
for (i = 0, j = 0; i < source->rank; i++)
{
if (lower_bounds)
- offset += lower_bounds[i]*source->dim[i].sm;
+ offset += (lower_bounds[i]-source->dim[i].lower_bound)*source->dim[i].sm;
- if (source->dim[i].sm == 0)
+ if (strides && strides[i] == 0)
continue;
result->dim[j].lower_bound = lower_bounds
@@ -262,7 +262,7 @@ CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source,
if (upper_bounds)
{
CFI_index_t extent;
- extent = upper_bounds[i] - result->dim[j].lower_bound;
+ extent = upper_bounds[i] - result->dim[j].lower_bound + 1;
result->dim[j].extent = extent < 0 ? 0 : extent;
}
else
@@ -273,6 +273,7 @@ CFI_section (CFI_cdesc_t *result, const CFI_cdesc_t *source,
else
{
result->dim[j].sm = source->dim[i].sm * strides[i];
+ result->dim[j].extent /= strides[i];
}
j++;
@@ -0,0 +1,158 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Check whether the type files are properly set
+!
+subroutine test
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine foo(x,i)
+ type(*) :: x(..)
+ integer(2), value :: i
+ end subroutine foo
+ end interface
+
+! /* Array-descriptor basic types, see ISO_Fortran_binding.h. */
+! #define GFC_TYPE_INTEGER 1
+! #define GFC_TYPE_LOGICAL 2
+! #define GFC_TYPE_REAL 3
+! #define GFC_TYPE_COMPLEX 4
+! #define GFC_TYPE_CHARACTER 5
+! #define GFC_TYPE_STRUCT 6
+! #define GFC_TYPE_CPTR 7
+! #define GFC_TYPE_CFUNPTR 8
+! #define GFC_TYPE_OTHER -1
+
+ integer(2), parameter :: CFI_Int = 1
+ integer(2), parameter :: CFI_Log = 2
+ integer(2), parameter :: CFI_Real = 3
+ integer(2), parameter :: CFI_Cmplx = 4
+ integer(2), parameter :: CFI_Char = 5
+ integer(2), parameter :: CFI_Struct = 6
+ integer(2), parameter :: CFI_cptr = 7
+ integer(2), parameter :: CFI_funcptr = 8
+ integer(2), parameter :: CFI_other = -1
+
+
+ integer(1), allocatable :: x_int1(:)
+ integer(2), allocatable :: x_int2(:)
+ integer(4), allocatable :: x_int4(:)
+ integer(8), allocatable :: x_int8(:)
+
+ logical(1), allocatable :: x_log1(:)
+ logical(2), allocatable :: x_log2(:)
+ logical(4), allocatable :: x_log4(:)
+ logical(8), allocatable :: x_log8(:)
+
+ real(4), allocatable :: x_real4(:)
+ real(8), allocatable :: x_real8(:)
+
+ complex(4), allocatable :: x_cmplx4(:)
+ complex(8), allocatable :: x_cmplx8(:)
+
+ character(kind=1,len=1), allocatable :: x_str1a(:)
+ character(kind=1,len=:), allocatable :: x_str1b(:)
+ character(kind=4,len=1), allocatable :: x_str4a(:)
+ character(kind=4,len=:), allocatable :: x_str4b(:)
+
+ type(c_ptr), allocatable :: x_cptr(:)
+ type(c_funptr), allocatable :: x_funcptr(:)
+
+
+ type t_seq
+ sequence
+ integer :: iii
+ end type t_seq
+
+ type, bind(C) :: t_bindc
+ integer(c_int) :: iii
+ end type t_bindc
+
+ type :: t_ext
+ integer :: iii
+ end type t_ext
+
+ type(t_seq), allocatable :: x_seq(:)
+ type(t_bindc), allocatable :: x_bindc(:)
+ type(t_ext), allocatable :: x_ext(:)
+ class(t_ext), allocatable :: x_class(:)
+
+ call foo(x_int1, CFI_Int + ishft (int(kind(x_int1),kind=2),8))
+ call foo(x_int2, CFI_Int + ishft (int(kind(x_int2),kind=2),8))
+ call foo(x_int4, CFI_Int + ishft (int(kind(x_int4),kind=2),8))
+ call foo(x_int8, CFI_Int + ishft (int(kind(x_int8),kind=2),8))
+
+ call foo(x_log1, CFI_Log + ishft (int(kind(x_log1),kind=2),8))
+ call foo(x_log2, CFI_Log + ishft (int(kind(x_log2),kind=2),8))
+ call foo(x_log4, CFI_Log + ishft (int(kind(x_log4),kind=2),8))
+ call foo(x_log8, CFI_Log + ishft (int(kind(x_log8),kind=2),8))
+
+ call foo(x_real4, CFI_Real + ishft (int(kind(x_real4),kind=2),8))
+ call foo(x_real8, CFI_Real + ishft (int(kind(x_real8),kind=2),8))
+
+ call foo(x_cmplx4, CFI_cmplx + ishft (int(kind(x_cmplx4),kind=2),8))
+ call foo(x_cmplx8, CFI_cmplx + ishft (int(kind(x_cmplx8),kind=2),8))
+
+ call foo(x_str1a, CFI_char + ishft (int(kind(x_str1a),kind=2),8))
+ call foo(x_str1b, CFI_char + ishft (int(kind(x_str1a),kind=2),8))
+ call foo(x_str4a, CFI_char + ishft (int(kind(x_str4a),kind=2),8))
+ call foo(x_str4b, CFI_char + ishft (int(kind(x_str4a),kind=2),8))
+
+ call foo(x_cptr, CFI_cptr)
+ call foo(x_funcptr, CFI_funcptr)
+
+ call foo(x_seq, CFI_struct)
+ call foo(x_bindc, CFI_struct)
+ call foo(x_ext, CFI_other)
+ call foo(x_class, CFI_other)
+end subroutine test
+
+! { dg-final { scan-tree-dump-times "x_cmplx4.type = 1028;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_cmplx8.type = 2052;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_int1.type = 257;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_int2.type = 513;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_int4.type = 1025;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_int8.type = 2049;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_log1.type = 258;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_log2.type = 514;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_log4.type = 1026;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_log8.type = 2050;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_real4.type = 1027;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_real8.type = 2051;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_str1a.type = 261;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_str1b.type = 261;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_str4a.type = 1029;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_str4b.type = 1029;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_cptr.type = 2049;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_funcptr.type = 2049;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_seq.type = 6;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_bindc.type = 6;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_ext.type = -1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x_class._data.type = -1;" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "foo \\(&x_int1, 257\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_int2, 513\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_int4, 1025\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_int8, 2049\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_log1, 258\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_log2, 514\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_log4, 1026\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_log8, 2050\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_real4, 1027\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_real8, 2051\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_cmplx4, 1028\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_cmplx8, 2052\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_str1a, 261, 1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_str1b, 261, .x_str1b\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_str4a, 1029, 1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_str4b, 1029, .x_str4b\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_cptr, 7\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_funcptr, 8\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_seq, 6\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_bindc, 6\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_ext, -1\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "foo \\(&x_class._data, -1\\);" 1 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }
@@ -0,0 +1,71 @@
+! { dg-do run }
+! { dg-additional-sources iso-ts-29113_3_c.c }
+! { dg-options "" }
+!
+! dg-options is required to silence -pedantic warnings for
+! the C code.
+!
+! Test whether accessing the array from C works using
+! TS29113's ISO_Fortran_binding.h
+!
+! The C examples are based on TS29113's.
+!
+module m
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine test_establish1() bind(C)
+ end subroutine test_establish1
+ subroutine test_establish2() bind(C)
+ end subroutine test_establish2
+ subroutine test_section1(x) bind(C)
+ import
+ real(c_float) :: x(:)
+ end subroutine test_section1
+ subroutine test_section2(x) bind(C)
+ import
+ real(c_float) :: x(:,:)
+ end subroutine test_section2
+ end interface
+
+ real, target :: A(100)
+ real, target :: B(100, 100)
+contains
+ subroutine check_section1(x) bind(C)
+ real(c_float), target :: x(:)
+
+ if (size (x) /= size (A(3::5))) call abort ()
+ if (lbound (x,1) /= lbound (A(3::5),1)) call abort ()
+ if (ubound (x,1) /= ubound (A(3::5),1)) call abort ()
+ if (loc (x(1)) /= loc (A(2))) call abort () ! FIXME: Should be A(3::5), lower_bound 0<->1 issue
+ if (any (x /= A(2::5))) call abort ()
+ end subroutine
+ subroutine check_section2(x) bind(C)
+ real(c_float), target :: x(:)
+
+ if (size (x) /= size (B(:,42))) call abort ()
+ if (lbound (x,1) /= lbound (B(:,42),1)) call abort ()
+ if (ubound (x,1) /= ubound (B(:,42),1)) call abort ()
+ if (loc (x(1)) /= loc (B(1,41))) call abort () ! FIXME: Should be B(1,42), lower_bound 0<->1 issue
+ if (any (x /= B(:,41))) call abort () ! FIXME: Should be B(:,42), lower_bound 0<->1 issue
+ end subroutine
+end module m
+
+use m
+implicit none
+integer :: i,j
+
+call test_establish1 ()
+call test_establish2 ()
+
+A = [(i+100, i=0,99)]
+call test_section1 (A)
+
+do j = 1, 100
+ do i = 1, 100
+ B(i,j) = -i - 1000*j
+ end do
+end do
+call test_section2 (B)
+end
@@ -0,0 +1,206 @@
+/* To be complied together with iso-ts-29113_2.f90.
+
+ Test whether accessing the array from C works using
+ TS29113's ISO_Fortran_binding.h
+
+ The examples are based on TS29113's. */
+
+#include <ISO_Fortran_binding.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+
+void check_section1 (CFI_cdesc_t *);
+void check_section2 (CFI_cdesc_t *);
+
+
+void
+test_establish1 (void)
+{
+ int ind;
+
+ /* For establish */
+ CFI_rank_t rank;
+ CFI_CDESC_T(1) field;
+
+ /* For allocate */
+ CFI_index_t lower[1], upper[1];
+ size_t dummy = 0;
+
+ rank = 1;
+ ind = CFI_establish ((CFI_cdesc_t *) &field, NULL, CFI_attribute_allocatable,
+ CFI_type_double, 0, rank, NULL);
+
+ if (ind != CFI_SUCCESS) abort ();
+ if (field.base_addr != NULL) abort ();
+ if (field.rank != 1) abort();
+ if (field.version != CFI_VERSION) abort ();
+ if (field.type != CFI_type_double) abort ();
+ if (field.attribute != CFI_attribute_allocatable) abort ();
+
+ lower[0] = -1;
+ upper[0] = 100;
+ ind = CFI_allocate ((CFI_cdesc_t *) &field, lower, upper, dummy);
+ if (ind != CFI_SUCCESS) abort ();
+ if (field.elem_len != sizeof (double)) abort ();
+ if (field.dim[0].lower_bound != -1) abort ();
+ if (field.dim[0].extent != 100-(-1)+1) abort ();
+ if (field.dim[0].sm != 1*field.elem_len) abort ();
+
+ ind = CFI_allocate ((CFI_cdesc_t *) &field, lower, upper, dummy);
+ if (ind != CFI_ERROR_BASE_ADDR_NOT_NULL) abort ();
+
+ ind = CFI_deallocate ((CFI_cdesc_t *) &field);
+ if (ind != CFI_SUCCESS) abort ();
+}
+
+
+void
+test_establish2 (void)
+{
+ int ind;
+
+ /* For establish */
+ typedef struct {double x; double _Complex y;} t;
+ t a_c[100];
+ CFI_CDESC_T(1) a_fortran;
+ CFI_index_t extent[1];
+
+ /* For allocate */
+ CFI_index_t lower[2], upper[2];
+ size_t dummy = 0;
+
+ extent[0] = 100;
+ ind = CFI_establish((CFI_cdesc_t *) &a_fortran, a_c, CFI_attribute_other,
+ CFI_type_struct, sizeof(t), 1, extent);
+
+ if (ind != CFI_SUCCESS) abort ();
+ if (a_fortran.base_addr != a_c) abort ();
+ if (a_fortran.rank != 1) abort();
+ if (a_fortran.version != CFI_VERSION) abort ();
+ if (a_fortran.type != CFI_type_struct) abort ();
+ if (a_fortran.elem_len != sizeof(t)) abort ();
+ if (a_fortran.attribute != CFI_attribute_other) abort ();
+ if (a_fortran.dim[0].lower_bound != 0) abort ();
+ if (a_fortran.dim[0].extent != 100) abort ();
+ if (a_fortran.dim[0].sm != a_fortran.elem_len) abort ();
+
+ lower[0] = -1;
+ upper[0] = 100;
+ ind = CFI_allocate ((CFI_cdesc_t *) &a_fortran, lower, upper, dummy);
+ if (ind != CFI_INVALID_ATTRIBUTE) abort ();
+
+ if (a_fortran.base_addr != a_c) abort ();
+ if (a_fortran.rank != 1) abort();
+ if (a_fortran.version != CFI_VERSION) abort ();
+ if (a_fortran.type != CFI_type_struct) abort ();
+ if (a_fortran.elem_len != sizeof(t)) abort ();
+ if (a_fortran.attribute != CFI_attribute_other) abort ();
+ if (a_fortran.dim[0].lower_bound != 0) abort ();
+ if (a_fortran.dim[0].extent != 100) abort ();
+ if (a_fortran.dim[0].sm != a_fortran.elem_len) abort ();
+}
+
+
+void
+test_section1 (CFI_cdesc_t *source)
+{
+ int ind;
+
+ CFI_index_t lower_bounds[] = {2}, strides[] = {5};
+ CFI_CDESC_T(1) section;
+
+ CFI_rank_t rank = 1;
+ ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL,
+ CFI_attribute_other, CFI_type_float, 0, rank, NULL);
+ if (ind != CFI_SUCCESS) abort ();
+ if (section.base_addr != NULL) abort ();
+ if (section.rank != 1) abort();
+ if (section.version != CFI_VERSION) abort ();
+ if (section.type != CFI_type_float) abort ();
+ if (section.attribute != CFI_attribute_other) abort ();
+
+ if (source->base_addr == NULL) abort ();
+ if (source->rank != 1) abort();
+ if (source->version != CFI_VERSION) abort ();
+ if (source->type != CFI_type_float) abort ();
+ if (source->attribute != CFI_attribute_other) abort ();
+ if (source->elem_len != sizeof(float)) abort ();
+ /* FIXME: lower_bound should be 0. */
+ if (source->dim[0].lower_bound != 1) abort ();
+ if (source->dim[0].extent != 100) abort ();
+ if (source->dim[0].sm != source->elem_len) abort ();
+
+ for (ind = 0; ind < 100; ind++)
+ if (((float *)source->base_addr)[ind] != 100 + ind) abort();
+
+ ind = CFI_section ((CFI_cdesc_t *) §ion, source, lower_bounds,
+ NULL, strides);
+ if (ind != CFI_SUCCESS) abort ();
+ /* FIXME: Off by one due to 0<->1 lower_bound issue. */
+ if (section.base_addr != source->base_addr+1*source->dim[0].sm) abort ();
+ if (section.dim[0].lower_bound != 2) abort (); /* FIXME: Is this correct? */
+ if (section.dim[0].extent != 20) abort ();
+ if (section.dim[0].sm != source->elem_len*5) abort ();
+ if (section.rank != 1) abort();
+ if (section.version != CFI_VERSION) abort ();
+ if (section.type != CFI_type_float) abort ();
+ if (section.attribute != CFI_attribute_other) abort ();
+ if (section.elem_len != sizeof(float)) abort ();
+
+ check_section1 ((CFI_cdesc_t *) §ion);
+}
+
+
+void
+test_section2 (CFI_cdesc_t *source)
+{
+ int ind;
+ CFI_index_t lower_bounds[] = {source->dim[0].lower_bound, 41},
+ upper_bounds[] = {source->dim[0].lower_bound+source->dim[0].extent-1, 41},
+ strides[] = {1, 0};
+ CFI_CDESC_T(1) section;
+
+
+ CFI_rank_t rank = 1 ;
+ ind = CFI_establish ((CFI_cdesc_t *) §ion, NULL,
+ CFI_attribute_other, CFI_type_float, 0, rank, NULL);
+
+ if (ind != CFI_SUCCESS) abort ();
+ if (section.base_addr != NULL) abort ();
+ if (section.rank != 1) abort();
+ if (section.version != CFI_VERSION) abort ();
+ if (section.type != CFI_type_float) abort ();
+ if (section.attribute != CFI_attribute_other) abort ();
+
+ if (source->base_addr == NULL) abort ();
+ if (source->rank != 2) abort();
+ if (source->version != CFI_VERSION) abort ();
+ if (source->type != CFI_type_float) abort ();
+ if (source->attribute != CFI_attribute_other) abort ();
+ if (source->elem_len != sizeof(float)) abort ();
+ /* FIXME: Off by one due to 0<->1 lower_bound issue. */
+ if (source->dim[0].lower_bound != 1) abort ();
+ if (source->dim[1].lower_bound != 1) abort ();
+ if (source->dim[0].extent != 100) abort ();
+ if (source->dim[1].extent != 100) abort ();
+ if (source->dim[0].sm != source->elem_len) abort ();
+ if (source->dim[1].sm != 100*source->elem_len) abort ();
+
+ ind = CFI_section ((CFI_cdesc_t *) §ion, source,
+ lower_bounds, upper_bounds, strides );
+ if (ind != CFI_SUCCESS) abort ();
+ /* FIXME: Off by one due to 0<->1 lower_bound issue. */
+ if (section.dim[0].lower_bound != 1) abort ();
+ if (section.dim[0].extent != 100) abort ();
+ if (section.dim[0].sm != source->elem_len) abort ();
+ /* FIXME: Off by one due to 0<->1 lower_bound issue. */
+ if (section.base_addr != source->base_addr+40*100*source->dim[0].sm) abort ();
+ if (section.rank != 1) abort();
+ if (section.version != CFI_VERSION) abort ();
+ if (section.type != CFI_type_float) abort ();
+ if (section.attribute != CFI_attribute_other) abort ();
+ if (section.elem_len != sizeof(float)) abort ();
+
+ check_section2 ((CFI_cdesc_t *) §ion);
+}
This patch implements the TS29113 type handling. However, there is a catch: It does not fix any regression but adds two new ones: gfortran.dg/mvbits_7.f90 gfortran.dg/mvbits_8.f90 The problem with those is that this patch correctly sets the elem_len; that might cause that elem_len and sm do not agree with another. That issue shows up with packing: type t integer :: i, j end type t type(t), pointer :: x(:) call bar(x(:)%i) Here, "x(:)%i" has the elem_len=4 (= "integer(4)") while the stride multiplier is dim[0].sm = 8. Before, the old code used the TYPE_UNIT_SIZE(element_type(prev-desc)), which was 8. Usually, that shouldn't cause a problem - except if one doesn't start with the first element but has a span (possibly with negative strides). In that base, the code sets: "base_addr[offset]" - and the offset calculation is based on the element size. It should be "((char*)base_addr) + byte_offset" instead. Namely, gfc_get_dataptr_offset has to be fixed. Another issue is that in gfc_trans_create_temp_array, the elem_len cannot always be set for strings, e.g. the call from TRANSFER where the string is the result of a function call - in that case, the string length is not available. I haven't tried to check whether the elem_len gets properly set later on or not. But now to the good stuff: * The type handling now matches TS29113 and in the array functions, real(10) and real(16) can be distinguished. * Even more C examples using the TS29113 interop work now (I had to fix some bugs) * The used data types in the descriptor has been updated - it is a bit more compact now * Some ubound -> extent changes have been done. Build and regtested on x86-64-gnu-linux. Do you have comments to that patch? - Or on the general direction/on the previous patches? TODO: * The most obvious candidate is gfc_get_dataptr_offset as that one caused the new regression. (As follow up: Other code which assumes that strides are multiples of an element - for the subelement arrays) * Internally, lower_bound should start with 0 at some cases (see TS29113) - to fix more of the C interop * Fix remaining testsuite issues (still 22 test-case files fail), see also PR56818 * Remove "offset" field * Other bugs, cleanup, ... Tobias