[gcc(refs/users/mikael/heads/refactor_descriptor_v07)] Patch principal
Mikael Morin
mikael@gcc.gnu.org
Mon Jun 30 09:50:08 GMT 2025
https://gcc.gnu.org/g:690614acb36e0b7b0563364cee9794ef7455b3bc
commit 690614acb36e0b7b0563364cee9794ef7455b3bc
Author: Mikael Morin <mikael@gcc.gnu.org>
Date: Mon Jun 30 11:45:41 2025 +0200
Patch principal
Diff:
---
gcc/alias.cc | 11 +-
gcc/alias.h | 1 +
gcc/cgraphunit.cc | 1 +
gcc/fortran/Make-lang.in | 2 +-
gcc/fortran/class.cc | 88 +-
gcc/fortran/expr.cc | 37 +-
gcc/fortran/f95-lang.cc | 71 +
gcc/fortran/gfortran.h | 8 +-
gcc/fortran/libgfortran.h | 1 +
gcc/fortran/primary.cc | 86 +-
gcc/fortran/resolve.cc | 53 +-
gcc/fortran/trans-array.cc | 2929 +++++++----------
gcc/fortran/trans-array.h | 21 +-
gcc/fortran/trans-decl.cc | 592 ++--
gcc/fortran/trans-descriptor.cc | 3424 +++++++++++++++++++-
gcc/fortran/trans-descriptor.h | 151 +-
gcc/fortran/trans-expr.cc | 923 ++----
gcc/fortran/trans-intrinsic.cc | 191 +-
gcc/fortran/trans-io.cc | 60 +-
gcc/fortran/trans-openmp.cc | 107 +-
gcc/fortran/trans-stmt.cc | 176 +-
gcc/fortran/trans-types.cc | 955 ++++--
gcc/fortran/trans-types.h | 12 +-
gcc/fortran/trans.cc | 247 +-
gcc/fortran/trans.h | 58 +-
gcc/gimple-fold.cc | 52 +-
gcc/gimple-loop-versioning.cc | 468 ++-
gcc/selftest-run-tests.cc | 2 +
gcc/selftest.h | 1 +
gcc/stor-layout.cc | 10 +-
gcc/testsuite/gfortran.dg/allocate_with_mold_2.f90 | 2 +-
gcc/testsuite/gfortran.dg/array_reference_3.f90 | 28 +-
gcc/testsuite/gfortran.dg/assign_10.f90 | 2 +-
gcc/testsuite/gfortran.dg/assumed_rank_12.f90 | 6 +-
gcc/testsuite/gfortran.dg/assumed_type_2.f90 | 10 +-
gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 | 4 +-
.../gfortran.dg/bind_c_array_params_2.f90 | 10 +-
gcc/testsuite/gfortran.dg/bind_c_char_9.f90 | 4 +-
gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 | 2 +-
gcc/testsuite/gfortran.dg/c_loc_test_22.f90 | 8 +-
gcc/testsuite/gfortran.dg/char_cast_1.f90 | 2 +-
gcc/testsuite/gfortran.dg/char_cast_2.f90 | 2 +-
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
gcc/testsuite/gfortran.dg/coarray_32.f90 | 2 +-
.../gfortran.dg/coarray_collectives_18.f90 | 2 +-
.../gfortran.dg/coarray_lib_this_image_1.f90 | 2 +-
gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90 | 2 +-
gcc/testsuite/gfortran.dg/coarray_lock_7.f90 | 4 +-
gcc/testsuite/gfortran.dg/coarray_poly_8.f90 | 2 +-
gcc/testsuite/gfortran.dg/contiguous_3.f90 | 8 +-
.../gfortran.dg/elemental_dependency_4.f90 | 4 +-
.../gfortran.dg/f202y/generic_assumed_rank_1.f90 | 2 +-
.../gfortran.dg/goacc/array-with-dt-3.f90 | 2 +-
.../gfortran.dg/goacc/kernels-alias-4.f95 | 4 +-
.../gfortran.dg/goacc/kernels-decompose-1.f95 | 10 +-
.../gfortran.dg/gomp/affinity-clause-1.f90 | 6 +-
.../gfortran.dg/gomp/affinity-clause-5.f90 | 4 +-
gcc/testsuite/gfortran.dg/gomp/depend-4.f90 | 83 +-
gcc/testsuite/gfortran.dg/gomp/depend-5.f90 | 18 +-
gcc/testsuite/gfortran.dg/gomp/depend-6.f90 | 83 +-
gcc/testsuite/gfortran.dg/ipcp-array-2.f90 | 1 -
gcc/testsuite/gfortran.dg/loop_versioning_1.f90 | 1 -
gcc/testsuite/gfortran.dg/loop_versioning_9.f90 | 2 +-
gcc/testsuite/gfortran.dg/matmul_bounds_6.f90 | 4 +-
gcc/testsuite/gfortran.dg/no_arg_check_2.f90 | 10 +-
gcc/testsuite/gfortran.dg/pr32921.f | 2 +-
gcc/testsuite/gfortran.dg/pr48636.f90 | 2 +-
gcc/testsuite/gfortran.dg/typebound_call_22.f03 | 2 +-
gcc/testsuite/gfortran.dg/unconstrained_commons.f | 4 +-
gcc/testsuite/lib/scandump.exp | 50 +
gcc/testsuite/lib/scantree.exp | 26 +
gcc/tree-ssa-loop-niter.cc | 6 +-
gcc/tree.cc | 22 +-
libgfortran/caf/single.c | 4 +-
libgfortran/intrinsics/associated.c | 2 +-
libgfortran/intrinsics/cshift0.c | 19 +-
libgfortran/intrinsics/date_and_time.c | 124 +-
libgfortran/intrinsics/dtime.c | 2 +-
libgfortran/intrinsics/eoshift0.c | 32 +-
libgfortran/intrinsics/eoshift2.c | 20 +-
libgfortran/intrinsics/etime.c | 2 +-
libgfortran/intrinsics/is_contiguous.c | 10 +-
libgfortran/intrinsics/move_alloc.c | 10 +-
libgfortran/intrinsics/pack_generic.c | 18 +-
libgfortran/intrinsics/random.c | 160 +-
libgfortran/intrinsics/reduce.c | 66 +-
libgfortran/intrinsics/reshape_generic.c | 80 +-
libgfortran/intrinsics/spread_generic.c | 33 +-
libgfortran/intrinsics/stat.c | 142 +-
libgfortran/intrinsics/unpack_generic.c | 24 +-
libgfortran/io/format.c | 4 +-
libgfortran/io/list_read.c | 29 +-
libgfortran/io/transfer.c | 45 +-
libgfortran/io/unit.c | 4 +-
libgfortran/io/unix.c | 2 +-
libgfortran/io/write.c | 6 +-
libgfortran/libgfortran.h | 37 +-
libgfortran/m4/bessel.m4 | 40 +-
libgfortran/m4/cshift0.m4 | 61 +-
libgfortran/m4/cshift1.m4 | 62 +-
libgfortran/m4/cshift1a.m4 | 78 +-
libgfortran/m4/eoshift1.m4 | 62 +-
libgfortran/m4/eoshift3.m4 | 80 +-
libgfortran/m4/ifindloc0.m4 | 109 +-
libgfortran/m4/ifindloc1.m4 | 116 +-
libgfortran/m4/ifindloc2.m4 | 30 +-
libgfortran/m4/iforeach-s.m4 | 100 +-
libgfortran/m4/iforeach-s2.m4 | 30 +-
libgfortran/m4/iforeach.m4 | 64 +-
libgfortran/m4/ifunction-s.m4 | 99 +-
libgfortran/m4/ifunction-s2.m4 | 166 +-
libgfortran/m4/ifunction.m4 | 164 +-
libgfortran/m4/ifunction_logical.m4 | 35 +-
libgfortran/m4/in_pack.m4 | 20 +-
libgfortran/m4/in_unpack.m4 | 20 +-
libgfortran/m4/iparm.m4 | 4 +-
libgfortran/m4/matmul_internal.m4 | 311 +-
libgfortran/m4/matmull.m4 | 46 +-
libgfortran/m4/maxloc0.m4 | 24 +-
libgfortran/m4/maxloc0s.m4 | 8 +-
libgfortran/m4/maxloc1.m4 | 40 +-
libgfortran/m4/maxloc1s.m4 | 10 +-
libgfortran/m4/maxloc2s.m4 | 22 +-
libgfortran/m4/maxval.m4 | 22 +-
libgfortran/m4/maxval1s.m4 | 4 +-
libgfortran/m4/minloc0.m4 | 36 +-
libgfortran/m4/minloc0s.m4 | 8 +-
libgfortran/m4/minloc1.m4 | 46 +-
libgfortran/m4/minloc1s.m4 | 10 +-
libgfortran/m4/minloc2s.m4 | 22 +-
libgfortran/m4/minval.m4 | 20 +-
libgfortran/m4/minval1s.m4 | 4 +-
libgfortran/m4/pack.m4 | 60 +-
libgfortran/m4/reshape.m4 | 67 +-
libgfortran/m4/shape.m4 | 7 +-
libgfortran/m4/spread.m4 | 69 +-
libgfortran/m4/unpack.m4 | 124 +-
libgfortran/runtime/ISO_Fortran_binding.c | 6 +-
libgfortran/runtime/bounds.c | 2 +-
libgfortran/runtime/error.c | 4 +
libgfortran/runtime/in_pack_class.c | 30 +-
libgfortran/runtime/in_pack_generic.c | 18 +-
libgfortran/runtime/in_unpack_class.c | 18 +-
libgfortran/runtime/in_unpack_generic.c | 20 +-
144 files changed, 8779 insertions(+), 5684 deletions(-)
diff --git a/gcc/alias.cc b/gcc/alias.cc
index 4f17664c15b3..b249588a9c59 100644
--- a/gcc/alias.cc
+++ b/gcc/alias.cc
@@ -972,11 +972,20 @@ get_alias_set (tree t)
set = lang_hooks.get_alias_set (t);
if (set != -1)
return set;
+ else
+ return get_default_alias_set (t);
+}
+
+alias_set_type
+get_default_alias_set (tree t)
+{
+ alias_set_type set;
+
/* There are no objects of FUNCTION_TYPE, so there's no point in
using up an alias set for them. (There are, of course, pointers
and references to functions, but that's different.) */
- else if (TREE_CODE (t) == FUNCTION_TYPE || TREE_CODE (t) == METHOD_TYPE)
+ if (TREE_CODE (t) == FUNCTION_TYPE || TREE_CODE (t) == METHOD_TYPE)
set = 0;
/* Unless the language specifies otherwise, let vector types alias
diff --git a/gcc/alias.h b/gcc/alias.h
index 7c2e33eaa73e..6271dcc7089a 100644
--- a/gcc/alias.h
+++ b/gcc/alias.h
@@ -42,6 +42,7 @@ int compare_base_decls (tree, tree);
bool refs_same_for_tbaa_p (tree, tree);
bool mems_same_for_tbaa_p (rtx, rtx);
bool view_converted_memref_p (tree);
+alias_set_type get_default_alias_set (tree);
/* This alias set can be used to force a memory to conflict with all
other memories, creating a barrier across which no memory reference
diff --git a/gcc/cgraphunit.cc b/gcc/cgraphunit.cc
index fa54a59d02b8..fa21dfe71289 100644
--- a/gcc/cgraphunit.cc
+++ b/gcc/cgraphunit.cc
@@ -2321,6 +2321,7 @@ symbol_table::output_weakrefs (void)
}
}
+
/* Perform simple optimizations based on callgraph. */
void
diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in
index 2ddb0366e9dc..2914855eb225 100644
--- a/gcc/fortran/Make-lang.in
+++ b/gcc/fortran/Make-lang.in
@@ -45,7 +45,7 @@ GFORTRAN_TARGET_INSTALL_NAME := $(target_noncanonical)-$(shell echo gfortran|sed
#^L
# Use strict warnings for this front end.
-fortran-warn = $(STRICT_WARN)
+fortran-warn = $(STRICT_WARN) -Wno-error=infinite-recursion
# These are the groups of object files we have. The F95_PARSER_OBJS are
# all the front end files, the F95_OBJS are the files for the translation
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index df18601e45bd..aee7f2ce8f5e 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -632,6 +632,51 @@ gfc_get_len_component (gfc_expr *e, int k)
}
+gfc_namespace *
+gfc_class_namespace (gfc_symbol * derived)
+{
+ if (derived->attr.unlimited_polymorphic)
+ {
+ /* Find the top-level namespace. */
+ for (gfc_namespace * ns = gfc_current_ns; ns; ns = ns->parent)
+ if (!ns->parent)
+ return ns;
+
+ gcc_unreachable ();
+ }
+ else
+ return derived->ns;
+}
+
+
+char *
+gfc_class_name (gfc_symbol *derived, int rank, int corank,
+ bool allocatable, bool pointer)
+{
+ char tname[GFC_MAX_SYMBOL_LEN+1];
+ char * name;
+
+ get_unique_hashed_string (tname, derived);
+ if (rank == -1)
+ rank = GFC_MAX_DIMENSIONS;
+ bool array = rank != 0 || corank != 0;
+ if (array && allocatable)
+ name = xasprintf ("__class_%s_%d_%da", tname, rank, corank);
+ else if (array && pointer)
+ name = xasprintf ("__class_%s_%d_%dp", tname, rank, corank);
+ else if (array)
+ name = xasprintf ("__class_%s_%d_%dt", tname, rank, corank);
+ else if (pointer)
+ name = xasprintf ("__class_%s_p", tname);
+ else if (allocatable)
+ name = xasprintf ("__class_%s_a", tname);
+ else
+ name = xasprintf ("__class_%s_t", tname);
+
+ return name;
+}
+
+
/* Build a polymorphic CLASS entity, using the symbol that comes from
build_sym. A CLASS entity is represented by an encapsulating type,
which contains the declared type as '_data' component, plus a pointer
@@ -644,7 +689,6 @@ bool
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as)
{
- char tname[GFC_MAX_SYMBOL_LEN+1];
char *name;
gfc_typespec *orig_ts = ts;
gfc_symbol *fclass;
@@ -683,34 +727,15 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
return true;
/* Determine the name of the encapsulating type. */
- rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
+ rank = !(*as) ? 0 : (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
if (!ts->u.derived)
return false;
- get_unique_hashed_string (tname, ts->u.derived);
- if ((*as) && attr->allocatable)
- name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
- else if ((*as) && attr->pointer)
- name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
- else if ((*as))
- name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
- else if (attr->pointer)
- name = xasprintf ("__class_%s_p", tname);
- else if (attr->allocatable)
- name = xasprintf ("__class_%s_a", tname);
- else
- name = xasprintf ("__class_%s_t", tname);
-
- if (ts->u.derived->attr.unlimited_polymorphic)
- {
- /* Find the top-level namespace. */
- for (ns = gfc_current_ns; ns; ns = ns->parent)
- if (!ns->parent)
- break;
- }
- else
- ns = ts->u.derived->ns;
+ int corank = (*as) == nullptr ? 0 : (*as)->corank;
+ name = gfc_class_name (ts->u.derived, rank, corank,
+ attr->allocatable, attr->pointer);
+ ns = gfc_class_namespace (ts->u.derived);
/* Although this might seem to be counterintuitive, we can build separate
class types with different array specs because the TKR interface checks
@@ -1324,7 +1349,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
static gfc_code*
finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
gfc_symbol *strides, gfc_symbol *sizes,
- gfc_symbol *byte_stride, gfc_expr *rank,
+ gfc_symbol *byte_stride ATTRIBUTE_UNUSED, gfc_expr *rank,
gfc_code *block, gfc_namespace *sub_ns)
{
gfc_iterator *iter;
@@ -1418,17 +1443,6 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
block->block->next->expr2->ts = idx->ts;
block->block->next->expr2->where = gfc_current_locus;
- /* After the loop: offset = offset * byte_stride. */
- block->next = gfc_get_code (EXEC_ASSIGN);
- block = block->next;
- block->expr1 = gfc_lval_expr_from_sym (offset);
- block->expr2 = gfc_get_expr ();
- block->expr2->expr_type = EXPR_OP;
- block->expr2->value.op.op = INTRINSIC_TIMES;
- block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset);
- block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride);
- block->expr2->ts = block->expr2->value.op.op1->ts;
- block->expr2->where = gfc_current_locus;
return block;
}
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index b0495b7733ee..213f31a6360b 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1176,16 +1176,10 @@ is_subref_array (gfc_expr * e)
{
gfc_ref * ref;
bool seen_array;
- gfc_symbol *sym;
if (e->expr_type != EXPR_VARIABLE)
return false;
- sym = e->symtree->n.sym;
-
- if (sym->attr.subref_array_pointer)
- return true;
-
seen_array = false;
for (ref = e->ref; ref; ref = ref->next)
@@ -1209,12 +1203,6 @@ is_subref_array (gfc_expr * e)
return seen_array;
}
- if (sym->ts.type == BT_CLASS
- && sym->attr.dummy
- && CLASS_DATA (sym)->attr.dimension
- && CLASS_DATA (sym)->attr.class_pointer)
- return true;
-
return false;
}
@@ -5530,27 +5518,38 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
gfc_ref *ref;
if (expr->rank == 0)
- return NULL;
+ return nullptr;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_CONSTANT)
{
- if (expr->symtree)
- as = expr->symtree->n.sym->as;
+ gfc_symbol *sym = expr->symtree ? expr->symtree->n.sym : nullptr;
+ if (sym
+ && sym->ts.type == BT_CLASS)
+ as = CLASS_DATA (sym)->as;
+ else if (sym)
+ as = sym->as;
else
- as = NULL;
+ as = nullptr;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_COMPONENT:
- as = ref->u.c.component->as;
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->ts.type == BT_CLASS)
+ as = CLASS_DATA (comp)->as;
+ else
+ as = comp->as;
+ }
continue;
case REF_SUBSTRING:
case REF_INQUIRY:
+ as = nullptr;
continue;
case REF_ARRAY:
@@ -5560,7 +5559,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
case AR_ELEMENT:
case AR_SECTION:
case AR_UNKNOWN:
- as = NULL;
+ as = nullptr;
continue;
case AR_FULL:
@@ -5572,7 +5571,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
}
}
else
- as = NULL;
+ as = nullptr;
return as;
}
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index bb4ce6d82882..26583c1d21c6 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -40,6 +40,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-types.h"
#include "trans-const.h"
#include "attribs.h"
+#include "alias.h"
/* Language-dependent contents of an identifier. */
@@ -78,6 +79,8 @@ static void gfc_finish (void);
static void gfc_be_parse_file (void);
static void gfc_init_ts (void);
static tree gfc_builtin_function (tree);
+static alias_set_type gfc_get_alias_set (tree t);
+
/* Handle an "omp declare target" attribute; arguments as in
struct attribute_spec.handler. */
@@ -134,6 +137,7 @@ gfc_get_sarif_source_language (const char *)
#undef LANG_HOOKS_TYPE_FOR_MODE
#undef LANG_HOOKS_TYPE_FOR_SIZE
#undef LANG_HOOKS_INIT_TS
+#undef LANG_HOOKS_GET_ALIAS_SET
#undef LANG_HOOKS_OMP_ARRAY_DATA
#undef LANG_HOOKS_OMP_ARRAY_SIZE
#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR
@@ -177,6 +181,7 @@ gfc_get_sarif_source_language (const char *)
#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode
#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size
#define LANG_HOOKS_INIT_TS gfc_init_ts
+#define LANG_HOOKS_GET_ALIAS_SET gfc_get_alias_set
#define LANG_HOOKS_OMP_ARRAY_DATA gfc_omp_array_data
#define LANG_HOOKS_OMP_ARRAY_SIZE gfc_omp_array_size
#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr
@@ -309,6 +314,72 @@ gfc_finish (void)
return;
}
+
+static bool
+is_non_root_class_wrapper_type (tree t)
+{
+ if (!TYPE_P (t))
+ return false;
+
+ if (!GFC_CLASS_TYPE_P (t))
+ return false;
+
+ if (!(TYPE_LANG_SPECIFIC (t) && GFC_TYPE_PARENT_CLASS_TYPE (t)))
+ return false;
+
+ return true;
+}
+
+
+static alias_set_type
+gfc_get_alias_set (tree t)
+{
+ if (!TYPE_P (t))
+ return -1;
+
+ tree parent_type = NULL_TREE;
+ if (POINTER_TYPE_P (t))
+ {
+ tree pointee_type = TREE_TYPE (t);
+ if (!is_non_root_class_wrapper_type (pointee_type))
+ return -1;
+
+ tree parent_wrapper_type = GFC_TYPE_PARENT_CLASS_TYPE (pointee_type);
+ if (TREE_CODE (t) == REFERENCE_TYPE)
+ parent_type = build_reference_type (parent_wrapper_type);
+ else
+ parent_type = build_pointer_type (parent_wrapper_type);
+ }
+ else if (!is_non_root_class_wrapper_type (t))
+ return -1;
+ else
+ parent_type = GFC_TYPE_PARENT_CLASS_TYPE (t);
+
+ alias_set_type new_set = get_default_alias_set (t);
+ TYPE_ALIAS_SET (t) = new_set;
+ alias_set_type parent_set = get_alias_set (parent_type);
+
+ record_alias_subset (parent_set, new_set);
+
+ if (!POINTER_TYPE_P (t))
+ {
+ tree parent_field = TYPE_FIELDS (parent_type);
+ tree child_field = TYPE_FIELDS (t);
+ alias_set_type parent_base_set = get_alias_set (parent_field);
+ alias_set_type child_base_set = get_alias_set (child_field);
+ record_alias_subset (parent_base_set, child_base_set);
+
+ parent_field = TREE_CHAIN (parent_field);
+ child_field = TREE_CHAIN (child_field);
+ alias_set_type parent_vtype_ptr_set = get_alias_set (TREE_TYPE (parent_field));
+ alias_set_type child_vtype_ptr_set = get_alias_set (TREE_TYPE (child_field));
+ record_alias_subset (parent_vtype_ptr_set, child_vtype_ptr_set);
+ }
+
+ return new_set;
+}
+
+
/* These functions and variables deal with binding contours. We only
need these functions for the list of PARM_DECLs, but we leave the
functions more general; these are a simplified version of the
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6848bd1762d3..f596fbce8f9f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2028,10 +2028,6 @@ typedef struct gfc_symbol
/* Set if this should be passed by value, but is not a VALUE argument
according to the Fortran standard. */
unsigned pass_as_value:1;
- /* Set if an allocatable array variable has been allocated in the current
- scope. Used in the suppression of uninitialized warnings in reallocation
- on assignment. */
- unsigned allocated_in_scope:1;
/* Set if an external dummy argument is called with different argument lists.
This is legal in Fortran, but can cause problems with autogenerated
C prototypes for C23. */
@@ -3539,6 +3535,7 @@ void gfc_maybe_initialize_eh (void);
/* iresolve.cc */
const char * gfc_get_string (const char *, ...) ATTRIBUTE_PRINTF_1;
bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *);
+void gfc_resolve_symbol (gfc_symbol *);
/* error.cc */
locus gfc_get_location_range (locus *, unsigned, locus *, unsigned, locus *);
@@ -4119,6 +4116,7 @@ const char *gfc_dt_lower_string (const char *);
const char *gfc_dt_upper_string (const char *);
/* primary.cc */
+symbol_attribute gfc_symbol_attr (gfc_symbol *);
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
@@ -4195,6 +4193,8 @@ bool gfc_is_class_container_ref (gfc_expr *e);
gfc_expr *gfc_class_initializer (gfc_typespec *, gfc_expr *);
unsigned int gfc_hash_value (gfc_symbol *);
gfc_expr *gfc_get_len_component (gfc_expr *e, int);
+char * gfc_class_name (gfc_symbol *, int, int, bool, bool);
+gfc_namespace *gfc_class_namespace (gfc_symbol *derived);
bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
gfc_array_spec **);
void gfc_change_class (gfc_typespec *, symbol_attribute *,
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 9de5afb6c83e..b592c1477879 100644
--- a/gcc/fortran/libgfortran.h
+++ b/gcc/fortran/libgfortran.h
@@ -143,6 +143,7 @@ typedef enum
LIBERROR_INQUIRE_INTERNAL_UNIT, /* Must be different from STAT_STOPPED_IMAGE. */
LIBERROR_BAD_WAIT_ID,
LIBERROR_NO_MEMORY,
+ LIBERROR_MISALIGNED_INTERNAL_UNIT,
LIBERROR_LAST /* Not a real error, the last error # + 1. */
}
libgfortran_error_codes;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index f0e1fef6812e..6f69130d2f81 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2909,43 +2909,14 @@ check_substring:
}
-/* Given an expression that is a variable, figure out what the
- ultimate variable's type and attribute is, traversing the reference
- structures if necessary.
-
- This subroutine is trickier than it looks. We start at the base
- symbol and store the attribute. Component references load a
- completely new attribute.
-
- A couple of rules come into play. Subobjects of targets are always
- targets themselves. If we see a component that goes through a
- pointer, then the expression must also be a target, since the
- pointer is associated with something (if it isn't core will soon be
- dumped). If we see a full part or section of an array, the
- expression is also an array.
-
- We can have at most one full array reference. */
-
symbol_attribute
-gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+gfc_symbol_attr (gfc_symbol *sym)
{
- int dimension, codimension, pointer, allocatable, target, optional;
+ int dimension, codimension, pointer, allocatable, target;
symbol_attribute attr;
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
- bool has_inquiry_part;
- bool has_substring_ref = false;
-
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_FUNCTION
- && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
- gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
- sym = expr->symtree->n.sym;
attr = sym->attr;
- optional = attr.optional;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
{
dimension = CLASS_DATA (sym)->attr.dimension;
@@ -2981,6 +2952,59 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
target = 0;
}
+ attr.dimension = dimension;
+ attr.codimension = codimension;
+ attr.pointer = pointer;
+ attr.allocatable = allocatable;
+ attr.target = target;
+
+ return attr;
+}
+
+
+/* Given an expression that is a variable, figure out what the
+ ultimate variable's type and attribute is, traversing the reference
+ structures if necessary.
+
+ This subroutine is trickier than it looks. We start at the base
+ symbol and store the attribute. Component references load a
+ completely new attribute.
+
+ A couple of rules come into play. Subobjects of targets are always
+ targets themselves. If we see a component that goes through a
+ pointer, then the expression must also be a target, since the
+ pointer is associated with something (if it isn't core will soon be
+ dumped). If we see a full part or section of an array, the
+ expression is also an array.
+
+ We can have at most one full array reference. */
+
+symbol_attribute
+gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+{
+ int dimension, codimension, pointer, allocatable, target, optional;
+ symbol_attribute attr;
+ gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
+ bool has_inquiry_part;
+ bool has_substring_ref = false;
+
+ if (expr->expr_type != EXPR_VARIABLE
+ && expr->expr_type != EXPR_FUNCTION
+ && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
+ gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
+
+ sym = expr->symtree->n.sym;
+ attr = gfc_symbol_attr (sym);
+
+ optional = attr.optional;
+ dimension = attr.dimension;
+ codimension = attr.codimension;
+ pointer = attr.pointer;
+ allocatable = attr.allocatable;
+ target = attr.target;
+
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 7089e4f171d1..0de38eb687b0 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -2800,6 +2800,31 @@ done:
}
+static void
+expression_shape (gfc_expr *e, gfc_array_spec *as)
+{
+ mpz_t array[GFC_MAX_DIMENSIONS];
+ int i;
+
+ if (e->rank <= 0 || e->shape != NULL)
+ return;
+
+ for (i = 0; i < e->rank; i++)
+ if (!spec_dimen_size (as, i, &array[i]))
+ goto fail;
+
+ e->shape = gfc_get_shape (e->rank);
+
+ memcpy (e->shape, array, e->rank * sizeof (mpz_t));
+
+ return;
+
+fail:
+ for (i--; i >= 0; i--)
+ mpz_clear (array[i]);
+}
+
+
/************* Function resolution *************/
/* Resolve a function call known to be generic.
@@ -2823,15 +2848,17 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym)
else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN)
expr->ts = s->result->ts;
- if (s->as != NULL)
- {
- expr->rank = s->as->rank;
- expr->corank = s->as->corank;
- }
- else if (s->result != NULL && s->result->as != NULL)
+ if (s->result != NULL && s->result->as != NULL)
{
expr->rank = s->result->as->rank;
expr->corank = s->result->as->corank;
+ expression_shape (expr, s->result->as);
+ }
+ else if (s->as != NULL)
+ {
+ expr->rank = s->as->rank;
+ expr->corank = s->as->corank;
+ expression_shape (expr, s->as);
}
gfc_set_sym_referenced (expr->value.function.esym);
@@ -2975,11 +3002,13 @@ found:
{
expr->rank = CLASS_DATA (sym)->as->rank;
expr->corank = CLASS_DATA (sym)->as->corank;
+ expression_shape (expr, CLASS_DATA (sym)->as);
}
else if (sym->as != NULL)
{
expr->rank = sym->as->rank;
expr->corank = sym->as->corank;
+ expression_shape (expr, sym->as);
}
return MATCH_YES;
@@ -3104,6 +3133,7 @@ resolve_unknown_f (gfc_expr *expr)
{
expr->rank = sym->as->rank;
expr->corank = sym->as->corank;
+ expression_shape (expr, sym->as);
}
/* Type of the expression is either the type of the symbol or the
@@ -3663,6 +3693,7 @@ resolve_function (gfc_expr *expr)
gfc_warning (OPT_Wdeprecated_declarations,
"Using function %qs at %L is deprecated",
sym->name, &expr->where);
+
return t;
}
@@ -5924,9 +5955,6 @@ gfc_resolve_ref (gfc_expr *expr)
}
-/* Given an expression, determine its shape. This is easier than it sounds.
- Leaves the shape array NULL if it is not possible to determine the shape. */
-
static void
expression_shape (gfc_expr *e)
{
@@ -18111,6 +18139,13 @@ skip_interfaces:
}
+void
+gfc_resolve_symbol (gfc_symbol *sym)
+{
+ resolve_symbol (sym);
+}
+
+
/************* Resolve DATA statements *************/
static struct
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index e4541e6004e2..720e2a94cf46 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -92,6 +92,7 @@ along with GCC; see the file COPYING3. If not see
#include "trans-array.h"
#include "trans-const.h"
#include "dependency.h"
+#include "gimplify.h"
#include "trans-descriptor.h"
static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
@@ -101,49 +102,6 @@ static gfc_ss gfc_ss_terminator_var;
gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var;
-static tree
-gfc_array_dataptr_type (tree desc)
-{
- return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
-}
-
-/* Modify a descriptor such that the lbound of a given dimension is the value
- specified. This also updates ubound and offset accordingly. */
-
-void
-gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
- int dim, tree new_lbound)
-{
- tree offs, ubound, lbound, stride;
- tree diff, offs_diff;
-
- new_lbound = fold_convert (gfc_array_index_type, new_lbound);
-
- offs = gfc_conv_descriptor_offset_get (desc);
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
- stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
-
- /* Get difference (new - old) by which to shift stuff. */
- diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- new_lbound, lbound);
-
- /* Shift ubound and offset accordingly. This has to be done before
- updating the lbound, as they depend on the lbound expression! */
- ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- ubound, diff);
- gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
- offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- diff, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offs, offs_diff);
- gfc_conv_descriptor_offset_set (block, desc, offs);
-
- /* Finally set lbound to value we want. */
- gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
-}
-
-
/* Mark a SS chain as used. Flags specifies in which loops the SS is used.
flags & 1 = Main loop body.
flags & 2 = temp copy loop. */
@@ -555,12 +513,8 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
void
gfc_trans_static_array_pointer (gfc_symbol * sym)
{
- tree type;
-
gcc_assert (TREE_STATIC (sym->backend_decl));
- /* Just zero the data member. */
- type = TREE_TYPE (sym->backend_decl);
- DECL_INITIAL (sym->backend_decl) = gfc_build_null_descriptor (type);
+ gfc_clear_descriptor (nullptr, sym, sym->backend_decl);
}
@@ -637,13 +591,14 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping,
DYNAMIC is true if the caller may want to extend the array later
using realloc. This prevents us from putting the array on the stack. */
-static void
+static tree
gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
gfc_array_info * info, tree size, tree nelem,
tree initial, bool dynamic, bool dealloc)
{
tree tmp;
tree desc;
+ tree ptr = NULL_TREE;
bool onstack;
desc = info->descriptor;
@@ -651,7 +606,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
if (size == NULL_TREE || (dynamic && integer_zerop (size)))
{
/* A callee allocated array. */
- gfc_conv_descriptor_data_set (pre, desc, null_pointer_node);
+ ptr = null_pointer_node;
onstack = false;
}
else
@@ -679,8 +634,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
fold_build1_loc (input_location,
DECL_EXPR, TREE_TYPE (tmp),
tmp));
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
- gfc_conv_descriptor_data_set (pre, desc, tmp);
+ ptr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
{
@@ -688,7 +642,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
if (initial == NULL_TREE)
{
tmp = gfc_call_malloc (pre, NULL, size);
- tmp = gfc_evaluate_now (tmp, pre);
+ ptr = gfc_evaluate_now (tmp, pre);
}
else
{
@@ -731,18 +685,12 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
build_empty_stmt (input_location));
gfc_add_expr_to_block (pre, tmp);
- tmp = fold_convert (pvoid_type_node, packed);
+ ptr = fold_convert (pvoid_type_node, packed);
}
-
- gfc_conv_descriptor_data_set (pre, desc, tmp);
}
}
info->data = gfc_conv_descriptor_data_get (desc);
- /* The offset is zero because we create temporaries with a zero
- lower bound. */
- gfc_conv_descriptor_offset_set (pre, desc, gfc_index_zero_node);
-
if (dealloc && !onstack)
{
/* Free the temporary. */
@@ -750,6 +698,8 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
tmp = gfc_call_free (tmp);
gfc_add_expr_to_block (post, tmp);
}
+
+ return ptr;
}
@@ -801,8 +751,8 @@ innermost_ss (gfc_ss *ss)
It is different from the loop dimension in the case of a transposed array.
*/
-static int
-get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
+int
+gfc_get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
{
return get_scalarizer_dim_for_array_dim (innermost_ss (ss),
ss->dim[loop_dim]);
@@ -922,12 +872,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
tmp2 = gfc_class_len_get (class_expr);
gfc_add_modify (pre, tmp, tmp2);
}
-
- if (rhs_function)
- {
- tmp = gfc_class_data_get (class_expr);
- gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
- }
}
else if (rhs_ss->info->data.array.descriptor)
{
@@ -961,7 +905,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
}
-
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
functions returning arrays. Adjusts the loop variables to be
@@ -983,12 +926,13 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
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, locus * where,
+ bool shift_bounds)
{
gfc_loopinfo *loop;
gfc_ss *s;
gfc_array_info *info;
- tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS];
+ tree from[GFC_MAX_DIMENSIONS], to[GFC_MAX_DIMENSIONS], spacing[GFC_MAX_DIMENSIONS];
tree type;
tree desc;
tree tmp;
@@ -1070,19 +1014,22 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
{
dim = s->dim[n];
- /* Callee allocated arrays may not have a known bound yet. */
- if (loop->to[n])
- loop->to[n] = gfc_evaluate_now (
- fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- loop->to[n], loop->from[n]),
- pre);
- loop->from[n] = gfc_index_zero_node;
-
- /* We have just changed the loop bounds, we must clear the
- corresponding specloop, so that delta calculation is not skipped
- later in gfc_set_delta. */
- loop->specloop[n] = NULL;
+ if (shift_bounds)
+ {
+ /* Callee allocated arrays may not have a known bound yet. */
+ if (loop->to[n])
+ loop->to[n] = gfc_evaluate_now (
+ fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ loop->to[n], loop->from[n]),
+ pre);
+ loop->from[n] = gfc_index_zero_node;
+
+ /* We have just changed the loop bounds, we must clear the
+ corresponding specloop, so that delta calculation is not skipped
+ later in gfc_set_delta. */
+ loop->specloop[n] = NULL;
+ }
/* We are constructing the temporary's descriptor based on the loop
dimensions. As the dimensions may be accessed in arbitrary order
@@ -1098,13 +1045,28 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
info->start[dim] = gfc_index_zero_node;
info->end[dim] = gfc_index_zero_node;
info->stride[dim] = gfc_index_one_node;
+ info->lbound[dim] = gfc_index_zero_node;
}
}
- /* Initialize the descriptor. */
+ /* Clear type upper bound if dynamic. */
+ tree to0 = NULL_TREE;
+ if (dynamic && total_dim == 1)
+ {
+ to0 = to[0];
+ to[0] = NULL_TREE;
+ }
type =
- gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, 1,
- GFC_ARRAY_UNKNOWN, true);
+ gfc_get_array_type_bounds (eltype, total_dim, 0, from, to, PACKED_STATIC,
+ GFC_ARRAY_UNKNOWN, true,
+ ss->info->expr ? ss->info->expr->ts.type
+ : BT_UNKNOWN);
+ /* Restore the upper bound, for the rest (not type-related) of the descriptor
+ initialization. */
+ if (to0)
+ to[0] = to0;
+
+ /* Initialize the descriptor. */
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
@@ -1124,13 +1086,12 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
TREE_USED (desc) = 0;
}
+ bool rank_changer = false;
if (class_expr != NULL_TREE
|| (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
{
tree class_data;
- tree dtype;
gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
- bool rank_changer;
/* Pick out these transformational functions because they change the rank
or shape of the first argument. This requires that the class type be
@@ -1183,19 +1144,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
class_data = gfc_class_data_get (tmp);
- if (rank_changer)
- {
- /* Take the dtype from the class expression. */
- tree class_descr = gfc_class_data_get (class_expr);
- dtype = gfc_conv_descriptor_dtype_get (class_descr);
- gfc_conv_descriptor_dtype_set (pre, desc, dtype);
-
-
- /* These transformational functions change the rank. */
- gfc_conv_descriptor_rank_set (pre, desc, ss->loop->dimen);
- fcn_ss->info->class_container = NULL_TREE;
- }
-
/* Assign the new descriptor to the _data field. This allows the
vptr _copy to be used for scalarized assignment since the class
temporary can be found from the descriptor. */
@@ -1206,15 +1154,10 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
/* Point desc to the class _data field. */
desc = class_data;
}
- else
- {
- /* Fill in the array dtype. */
- gfc_conv_descriptor_dtype_set (pre, desc,
- gfc_get_dtype (TREE_TYPE (desc)));
- }
info->descriptor = desc;
- size = gfc_index_one_node;
+ size = elemsize;
+ nelem = gfc_index_one_node;
/*
Fill in the bounds and stride. This is a packed array, so:
@@ -1258,21 +1201,20 @@ 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);
+ info->spacing[n] = spacing[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);
+ tree extent = to[n];
+ if (!shift_bounds && !integer_zerop (from[n]))
+ extent = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, to[n], from[n]);
+
+ extent = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ extent, gfc_index_one_node);
/* Check whether the size for this dimension is negative. */
cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
- tmp, gfc_index_zero_node);
+ extent, gfc_index_zero_node);
cond = gfc_evaluate_now (cond, pre);
if (n == 0)
@@ -1281,36 +1223,42 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, or_expr, cond);
+ extent = gfc_evaluate_now (extent, pre);
+
size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
+ gfc_array_index_type, size, extent);
size = gfc_evaluate_now (size, pre);
+
+ nelem = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, nelem, extent);
}
}
+ bool bounds_known = size != NULL_TREE;
+
/* Get the size of the array. */
if (size && !callee_alloc)
{
+ or_expr = gfc_evaluate_now (or_expr, pre);
+
/* 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;
- size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size, elemsize);
+ nelem = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
+ or_expr, gfc_index_zero_node, nelem);
}
else
- {
- nelem = size;
- size = NULL_TREE;
- }
+ size = NULL_TREE;
- /* Set the span. */
- tmp = fold_convert (gfc_array_index_type, elemsize);
- gfc_conv_descriptor_span_set (pre, desc, tmp);
+ tree data_ptr = gfc_trans_allocate_array_storage (pre, post, info, size,
+ nelem, initial, dynamic,
+ dealloc);
- gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
- dynamic, dealloc);
+ gfc_set_temporary_descriptor (pre, desc, class_expr, elemsize,
+ data_ptr, from, to, spacing, total_dim,
+ !bounds_known, rank_changer, shift_bounds);
while (ss->parent)
ss = ss->parent;
@@ -1342,43 +1290,6 @@ gfc_get_iteration_count (tree start, tree end, tree step)
}
-/* Extend the data in array DESC by EXTRA elements. */
-
-static void
-gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
-{
- tree arg0, arg1;
- tree tmp;
- tree size;
- tree ubound;
-
- if (integer_zerop (extra))
- return;
-
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
-
- /* Add EXTRA to the upper bound. */
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- ubound, extra);
- gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
-
- /* Get the value of the current data pointer. */
- arg0 = gfc_conv_descriptor_data_get (desc);
-
- /* Calculate the new array size. */
- size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- ubound, gfc_index_one_node);
- arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- fold_convert (size_type_node, tmp),
- fold_convert (size_type_node, size));
-
- /* Call the realloc() function. */
- tmp = gfc_call_realloc (pblock, arg0, arg1);
- gfc_conv_descriptor_data_set (pblock, desc, tmp);
-}
-
-
/* Return true if the bounds of iterator I can only be determined
at run time. */
@@ -1493,7 +1404,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
/* Store the value. */
tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_descriptor_data_get (desc));
- tmp = gfc_build_array_ref (tmp, offset, NULL);
+ tmp = gfc_build_array_ref (tmp, offset, true);
if (expr->expr_type == EXPR_FUNCTION && expr->ts.type == BT_DERIVED
&& expr->ts.u.derived->attr.alloc_comp)
@@ -1824,7 +1735,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock,
tmp = gfc_conv_descriptor_data_get (desc);
tmp = build_fold_indirect_ref_loc (input_location,
tmp);
- tmp = gfc_build_array_ref (tmp, *poffset, NULL);
+ tmp = gfc_build_array_ref (tmp, *poffset, true);
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
init = gfc_build_addr_expr (NULL_TREE, init);
@@ -2195,6 +2106,15 @@ gfc_constant_array_constructor_p (gfc_constructor_base base)
}
+static void
+append_constructor (vec<constructor_elt, va_gc> *&v, tree t)
+{
+ unsigned len = vec_safe_length (v);
+ tree idx = build_int_cst (gfc_array_index_type, len);
+ CONSTRUCTOR_APPEND_ELT (v, idx, t);
+}
+
+
/* Given EXPR, the constant array constructor specified by an EXPR_ARRAY,
and the tree type of it's elements, TYPE, return a static constant
variable that is compile-time initialized. */
@@ -2223,8 +2143,7 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
else if (POINTER_TYPE_P (type))
se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
se.expr);
- CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
- se.expr);
+ append_constructor (v, se.expr);
c = gfc_constructor_next (c);
nelem++;
}
@@ -2252,7 +2171,8 @@ gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
NULL, tmp - 1);
}
- tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
+ tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true,
+ expr->ts.type);
/* as is not needed anymore. */
for (i = 0; i < as.rank + as.corank; i++)
@@ -2377,7 +2297,7 @@ get_loop_upper_bound_for_array (gfc_ss *array, int array_dim)
for (ss = array; ss; ss = ss->parent)
for (n = 0; n < ss->loop->dimen; n++)
- if (array_dim == get_array_ref_dim_for_loop_dim (ss, n))
+ if (array_dim == gfc_get_array_ref_dim_for_loop_dim (ss, n))
return &(ss->loop->to[n]);
gcc_unreachable ();
@@ -2518,6 +2438,8 @@ trans_array_constructor (gfc_ss * ss, locus * where)
/* Complex character array constructors should have been taken care of
and not end up here. */
gcc_assert (ss_info->string_length);
+ ss_info->string_length = gfc_evaluate_now (ss_info->string_length,
+ &outer_loop->pre);
store_backend_decl (&expr->ts.u.cl, ss_info->string_length, force_new_cl);
@@ -2588,7 +2510,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, where,
+ true);
desc = ss_info->data.array.descriptor;
offset = gfc_index_zero_node;
@@ -2613,7 +2536,6 @@ trans_array_constructor (gfc_ss * ss, locus * where)
gfc_array_index_type,
offsetvar, gfc_index_one_node);
tmp = gfc_evaluate_now (tmp, &outer_loop->pre);
- gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp);
if (*loop_ubound0 && VAR_P (*loop_ubound0))
gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp);
else
@@ -2858,6 +2780,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
gfc_add_block_to_block (&outer_loop->pre, &se.pre);
gfc_add_block_to_block (&outer_loop->post, &se.post);
info->descriptor = se.expr;
+ gfc_conv_array_lbound_spacing (&outer_loop->pre, ss, 0);
break;
case GFC_SS_INTRINSIC:
@@ -2865,18 +2788,104 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
break;
case GFC_SS_FUNCTION:
- /* Array function return value. We call the function and save its
- result in a temporary for use inside the loop. */
- gfc_init_se (&se, NULL);
- se.loop = loop;
- se.ss = ss;
- if (gfc_is_class_array_function (expr))
- expr->must_finalize = 1;
- gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&outer_loop->pre, &se.pre);
- gfc_add_block_to_block (&outer_loop->post, &se.post);
- gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
- ss_info->string_length = se.string_length;
+ {
+ /* Array function return value. We call the function and save its
+ result in a temporary for use inside the loop. */
+ gfc_init_se (&se, NULL);
+ se.loop = loop;
+ se.ss = ss;
+ bool class_func = gfc_is_class_array_function (expr);
+ if (class_func)
+ expr->must_finalize = 1;
+ gfc_conv_expr (&se, expr);
+ gfc_add_block_to_block (&outer_loop->pre, &se.pre);
+ if (class_func
+ && se.expr
+ && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
+ {
+ if (!ss->info->class_container
+ && se.class_container)
+ ss->info->class_container = se.class_container;
+ tree tmp = gfc_class_data_get (se.expr);
+ info->descriptor = tmp;
+ info->data = gfc_conv_descriptor_data_get (tmp);
+ info->offset = gfc_conv_descriptor_offset_get (tmp);
+ for (gfc_ss *s = ss; s; s = s->parent)
+ for (int n = 0; n < s->dimen; n++)
+ {
+ int dim = s->dim[n];
+ tree tree_dim = gfc_rank_cst[dim];
+
+ tree start = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
+ start = gfc_evaluate_now (start, &outer_loop->pre);
+ info->start[dim] = start;
+
+ tree end = gfc_conv_descriptor_ubound_get (tmp, tree_dim);
+ end = gfc_evaluate_now (end, &outer_loop->pre);
+ info->end[dim] = end;
+
+ info->stride[dim] = gfc_index_one_node;
+
+ tree spacing = gfc_conv_descriptor_spacing_get (tmp, tree_dim);
+ spacing = gfc_evaluate_now (spacing, &outer_loop->pre);
+ info->spacing[dim] = spacing;
+
+ tree lbound = gfc_conv_descriptor_lbound_get (tmp, tree_dim);
+ lbound = gfc_evaluate_now (lbound, &outer_loop->pre);
+ info->lbound[dim] = lbound;
+ }
+ }
+ else
+ {
+ bool missing_spacing;
+ for (int n = 0; n < ss_info->expr->rank; n++)
+ if (info->spacing[n] == NULL_TREE)
+ {
+ missing_spacing = true;
+ break;
+ }
+ if (missing_spacing)
+ {
+ tree type = gfc_typenode_for_spec (&ss_info->expr->ts);
+ if (TYPE_SIZE_UNIT (type) == NULL_TREE
+ || !INTEGER_CST_P (TYPE_SIZE_UNIT (type))
+ || expr->ts.type == BT_CLASS
+ || gfc_expr_attr (expr).pointer)
+ {
+ for (n = 0; n < ss_info->expr->rank; n++)
+ {
+ tree spacing = gfc_conv_descriptor_spacing_get (info->descriptor,
+ gfc_rank_cst[n]);
+ info->spacing[n] = gfc_evaluate_now (spacing, &outer_loop->pre);
+ }
+ }
+ else
+ {
+ tree spacing = fold_convert_loc (input_location,
+ gfc_array_index_type,
+ TYPE_SIZE_UNIT (type));
+ spacing = gfc_evaluate_now (spacing, &outer_loop->pre);
+
+ for (n = 0; n < ss_info->expr->rank; n++)
+ {
+ info->spacing[n] = spacing;
+
+ tree extent = gfc_conv_descriptor_extent_get (info->descriptor,
+ gfc_rank_cst[n]);
+
+ spacing = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing,
+ extent);
+ spacing = gfc_evaluate_now (spacing, &outer_loop->pre);
+ }
+ }
+ }
+ }
+
+ gfc_add_block_to_block (&outer_loop->post, &se.post);
+ gfc_add_block_to_block (&outer_loop->post, &se.finalblock);
+ ss_info->string_length = se.string_length;
+ }
break;
case GFC_SS_CONSTRUCTOR:
@@ -2894,6 +2903,32 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
gfc_add_block_to_block (&outer_loop->post, &se.post);
}
trans_array_constructor (ss, where);
+ {
+ gcc_assert (info->shape != nullptr || ss->dimen == 1);
+ tree type = gfc_typenode_for_spec (expr->ts.type == BT_CLASS
+ ? &CLASS_DATA (expr)->ts
+ : &expr->ts);
+ if (expr->ts.type == BT_CHARACTER
+ && gfc_is_constant_expr (ss_info->expr))
+ type = build_pointer_type (type);
+ tree spacing = TYPE_SIZE_UNIT (type);
+ if (spacing == NULL_TREE)
+ spacing = expr->ts.u.cl->backend_decl;
+ spacing = fold_convert_loc (input_location, gfc_array_index_type,
+ spacing);
+ for (n = 0; n < expr->rank; n++)
+ {
+ info->spacing[n] = spacing;
+ if (n < expr->rank - 1)
+ {
+ tree extent = gfc_conv_mpz_to_tree_type (info->shape[n],
+ gfc_array_index_type);
+ spacing = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing,
+ extent);
+ }
+ }
+ }
break;
case GFC_SS_TEMP:
@@ -2913,6 +2948,35 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
}
+/* A simple reference can be accessed with a pointer and
+ a constant offset. */
+bool
+simple_reference_p (tree data_ref)
+{
+ bool seen_dereference = false;
+ while (true)
+ {
+ if (DECL_P (data_ref))
+ return true;
+
+ if (TREE_CODE (data_ref) == INDIRECT_REF)
+ {
+ if (seen_dereference)
+ return false;
+
+ seen_dereference = true;
+ data_ref = TREE_OPERAND (data_ref, 0);
+ }
+ else if (TREE_CODE (data_ref) == COMPONENT_REF)
+ data_ref = TREE_OPERAND (data_ref, 0);
+ else if (TREE_CODE (data_ref) == NOP_EXPR)
+ data_ref = TREE_OPERAND (data_ref, 0);
+ else
+ return false;
+ }
+}
+
+
/* Translate expressions for the descriptor and data pointer of a SS. */
/*GCC ARRAYS*/
@@ -2933,7 +2997,35 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
se.descriptor_only = 1;
gfc_conv_expr_lhs (&se, ss_info->expr);
gfc_add_block_to_block (block, &se.pre);
- info->descriptor = se.expr;
+ if (simple_reference_p (se.expr))
+ info->descriptor = se.expr;
+ else
+ {
+ tree desc = se.expr;
+ STRIP_NOPS (desc);
+ if (TREE_CODE (desc) == INDIRECT_REF)
+ {
+ tree ptr = TREE_OPERAND (desc, 0);
+ ptr = gfc_evaluate_now (ptr, block);
+ TREE_OPERAND (desc, 0) = ptr;
+ info->descriptor = se.expr;
+ }
+ else if (TREE_CODE (desc) == COMPONENT_REF)
+ {
+ tree parent_ref = TREE_OPERAND (desc, 0);
+ tree parent_ptr_type = build_pointer_type (TREE_TYPE (parent_ref));
+ tree ptr = fold_build1_loc (input_location, ADDR_EXPR,
+ parent_ptr_type, parent_ref);
+ ptr = gfc_evaluate_now (ptr, block);
+ tree deref = fold_build1_loc (input_location, INDIRECT_REF,
+ TREE_TYPE (parent_ref),
+ ptr);
+ TREE_OPERAND (desc, 0) = deref;
+ info->descriptor = se.expr;
+ }
+ else
+ info->descriptor = gfc_evaluate_now (se.expr, block);
+ }
ss_info->string_length = se.string_length;
ss_info->class_container = se.class_container;
@@ -2954,27 +3046,30 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
TYPE_NAME (arraytype)));
}
/* Also the data pointer. */
- tmp = gfc_conv_array_data (se.expr);
+ tree data = gfc_conv_array_data (se.expr);
/* If this is a variable or address or a class array, use it directly.
Otherwise we must evaluate it now to avoid breaking dependency
analysis by pulling the expressions for elemental array indices
inside the loop. */
- if (!(DECL_P (tmp)
- || (TREE_CODE (tmp) == ADDR_EXPR
- && DECL_P (TREE_OPERAND (tmp, 0)))
+ if (!(DECL_P (data)
+ || (TREE_CODE (data) == ADDR_EXPR
+ && DECL_P (TREE_OPERAND (data, 0)))
|| (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
&& TREE_CODE (se.expr) == COMPONENT_REF
- && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
- tmp = gfc_evaluate_now (tmp, block);
- info->data = tmp;
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))
+ && !ss->is_alloc_lhs)
+ data = gfc_evaluate_now (data, block);
+ info->data = data;
tmp = gfc_conv_array_offset (se.expr);
- info->offset = gfc_evaluate_now (tmp, block);
+ if (!ss->is_alloc_lhs)
+ tmp = gfc_evaluate_now (tmp, block);
+ info->offset = tmp;
/* Make absolutely sure that the saved_offset is indeed saved
so that the variable is still accessible after the loops
are translated. */
- info->saved_offset = info->offset;
+ info->saved_data = info->data;
}
}
@@ -3052,7 +3147,7 @@ gfc_conv_array_offset (tree descriptor)
/* Get an expression for the array stride. */
tree
-gfc_conv_array_stride (tree descriptor, int dim)
+gfc_conv_array_spacing (tree descriptor, int dim)
{
tree tmp;
tree type;
@@ -3060,16 +3155,17 @@ gfc_conv_array_stride (tree descriptor, int dim)
type = TREE_TYPE (descriptor);
/* For descriptorless arrays use the array size. */
- tmp = GFC_TYPE_ARRAY_STRIDE (type, dim);
- if (tmp != NULL_TREE)
+ tmp = GFC_TYPE_ARRAY_SPACING (type, dim);
+ if (tmp != NULL_TREE
+ && !contains_placeholder_p (tmp))
return tmp;
- tmp = gfc_conv_descriptor_stride_get (descriptor, gfc_rank_cst[dim]);
+ tmp = gfc_conv_descriptor_spacing_get (descriptor, gfc_rank_cst[dim]);
return tmp;
}
-/* Like gfc_conv_array_stride, but for the lower bound. */
+/* Like gfc_conv_array_sm, but for the lower bound. */
tree
gfc_conv_array_lbound (tree descriptor, int dim)
@@ -3080,7 +3176,8 @@ gfc_conv_array_lbound (tree descriptor, int dim)
type = TREE_TYPE (descriptor);
tmp = GFC_TYPE_ARRAY_LBOUND (type, dim);
- if (tmp != NULL_TREE)
+ if (tmp != NULL_TREE
+ && !contains_placeholder_p (tmp))
return tmp;
tmp = gfc_conv_descriptor_lbound_get (descriptor, gfc_rank_cst[dim]);
@@ -3088,7 +3185,7 @@ gfc_conv_array_lbound (tree descriptor, int dim)
}
-/* Like gfc_conv_array_stride, but for the upper bound. */
+/* Like gfc_conv_array_sm, but for the upper bound. */
tree
gfc_conv_array_ubound (tree descriptor, int dim)
@@ -3099,7 +3196,8 @@ gfc_conv_array_ubound (tree descriptor, int dim)
type = TREE_TYPE (descriptor);
tmp = GFC_TYPE_ARRAY_UBOUND (type, dim);
- if (tmp != NULL_TREE)
+ if (tmp != NULL_TREE
+ && !contains_placeholder_p (tmp))
return tmp;
/* This should only ever happen when passing an assumed shape array
@@ -3112,6 +3210,16 @@ gfc_conv_array_ubound (tree descriptor, int dim)
}
+tree
+gfc_conv_array_extent (tree descriptor, int dim)
+{
+ tree lbound = gfc_conv_array_lbound (descriptor, dim);
+ tree ubound = gfc_conv_array_ubound (descriptor, dim);
+
+ return gfc_conv_array_extent_dim (lbound, ubound, nullptr);
+}
+
+
/* Generate abridged name of a part-ref for use in bounds-check message.
Cases:
(1) for an ordinary array variable x return "x"
@@ -3314,13 +3422,57 @@ array_bound_check_elemental (gfc_se * se, gfc_ss * ss, gfc_expr * expr)
}
+/* Indicates that the tree EXPR is a reference to an array that can’t
+ have any negative stride. */
+
+static bool
+non_negative_strides_array_p (tree expr)
+{
+ if (expr == NULL_TREE)
+ return false;
+
+ tree type = TREE_TYPE (expr);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+
+ if (TYPE_LANG_SPECIFIC (type))
+ {
+ gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
+
+ if (array_kind == GFC_ARRAY_ALLOCATABLE
+ || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || array_kind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || array_kind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || array_kind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ || array_kind == GFC_ARRAY_POINTER_CONT)
+ return true;
+ }
+
+ /* An array with descriptor can have negative strides.
+ We try to be conservative and return false by default here
+ if we don’t recognize a contiguous array instead of
+ returning false if we can identify a non-contiguous one. */
+ if (!GFC_ARRAY_TYPE_P (type))
+ return false;
+
+ /* If the array was originally a dummy with a descriptor, strides can be
+ negative. */
+ if (DECL_P (expr)
+ && DECL_LANG_SPECIFIC (expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
+ return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
+
+ return true;
+}
+
+
/* Return the offset for an index. Performs bound checking for elemental
dimensions. Single element references are processed separately.
DIM is the array dimension, I is the loop dimension. */
static tree
-conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
- gfc_array_ref * ar, tree stride)
+conv_array_index (gfc_se * se, gfc_ss * ss, int dim, int i, gfc_array_ref * ar)
{
gfc_array_info *info;
tree index;
@@ -3354,22 +3506,20 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
gcc_assert (info && se->loop);
gcc_assert (info->subscript[dim]
&& info->subscript[dim]->info->type == GFC_SS_VECTOR);
- desc = info->subscript[dim]->info->data.array.descriptor;
- /* Get a zero-based index into the vector. */
- index = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- se->loop->loopvar[i], se->loop->from[i]);
+ desc = info->subscript[dim]->info->data.array.descriptor;
- /* Multiply the index by the stride. */
- index = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- index, gfc_conv_array_stride (desc, 0));
+ /* Get a zero-based index into the vector. */
+ index = fold_convert_loc (input_location, gfc_array_index_type,
+ se->loop->loopvar[i]);
/* Read the vector to get an index into info->descriptor. */
- data = build_fold_indirect_ref_loc (input_location,
- gfc_conv_array_data (desc));
- index = gfc_build_array_ref (data, index, NULL);
+ data = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_array_data (desc));
+ index = gfc_build_array_ref (data, index,
+ non_negative_strides_array_p (desc),
+ se->loop->from[i],
+ info->subscript[dim]->info->data.array.spacing[0]);
index = gfc_evaluate_now (index, &se->pre);
index = fold_convert (gfc_array_index_type, index);
@@ -3405,206 +3555,136 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
gcc_assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
- /* Pointer functions can have stride[0] different from unity.
- Use the stride returned by the function call and stored in
- the descriptor for the temporary. */
- if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
- && se->ss->info->expr
- && se->ss->info->expr->symtree
- && se->ss->info->expr->symtree->n.sym->result
- && se->ss->info->expr->symtree->n.sym->result->attr.pointer)
- stride = gfc_conv_descriptor_stride_get (info->descriptor,
- gfc_rank_cst[dim]);
-
if (info->delta[dim] && !integer_zerop (info->delta[dim]))
index = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, index, info->delta[dim]);
}
-
- /* Multiply by the stride. */
- if (stride != NULL && !integer_onep (stride))
- index = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- index, stride);
-
+
return index;
}
-/* Build a scalarized array reference using the vptr 'size'. */
+static tree
+build_array_ref (tree array, tree offset, bool use_array_ref)
+{
+ if (use_array_ref)
+ {
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)))
+ array = gfc_conv_array_data (array);
+ if (TREE_CODE (TREE_TYPE (array)) == POINTER_TYPE)
+ array = build_fold_indirect_ref_loc (input_location, array);
+ return gfc_build_array_ref (array, offset, true, gfc_index_zero_node);
+ }
+
+ tree ptr = gfc_conv_array_data (array);
+ gcc_assert (TREE_CODE (TREE_TYPE (ptr)) == POINTER_TYPE);
+ if (TREE_CODE (TREE_TYPE (TREE_TYPE (ptr))) == ARRAY_TYPE)
+ {
+ tree elt_type = TREE_TYPE (TREE_TYPE (TREE_TYPE (ptr)));
+ ptr = fold_convert_loc (input_location,
+ build_pointer_type (elt_type), ptr);
+ }
+
+ tree tmp = fold_build_pointer_plus_loc (input_location, ptr, offset);
+ return build_fold_indirect_ref_loc (input_location, tmp);
+}
+
static bool
-build_class_array_ref (gfc_se *se, tree base, tree index)
+array_section_parent_ref_is_contiguous (gfc_expr *expr, gfc_array_ref *ar)
{
- tree size;
- tree decl = NULL_TREE;
- tree tmp;
- gfc_expr *expr = se->ss->info->expr;
- gfc_expr *class_expr;
- gfc_typespec *ts;
- gfc_symbol *sym;
-
- tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
+ if (expr == nullptr || ar == nullptr)
+ return false;
- if (tmp != NULL_TREE)
- decl = tmp;
- else
+ gfc_symbol *root_sym = expr->symtree->n.sym;
+ bt last_type = root_sym->ts.type;
+ bool last_is_allocatable = root_sym->attr.allocatable;
+ bool last_is_contiguous = root_sym->attr.contiguous;
+ for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
{
- /* The base expression does not contain a class component, either
- because it is a temporary array or array descriptor. Class
- array functions are correctly resolved above. */
- if (!expr
- || (expr->ts.type != BT_CLASS
- && !gfc_is_class_array_ref (expr, NULL)))
- return false;
+ if (ref->type == REF_ARRAY && &ref->u.ar == ar)
+ break;
- /* Obtain the expression for the class entity or component that is
- followed by an array reference, which is not an element, so that
- the span of the array can be obtained. */
- class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
+ if (ref->type != REF_COMPONENT)
+ continue;
- if (!ts)
- return false;
+ if (last_type == BT_CLASS
+ && strcmp (ref->u.c.component->name, "_data") == 0)
+ continue;
- sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
- if (sym && sym->attr.function
- && sym == sym->result
- && sym->backend_decl == current_function_decl)
- /* The temporary is the data field of the class data component
- of the current function. */
- decl = gfc_get_fake_result_decl (sym, 0);
- else if (sym)
- {
- if (decl == NULL_TREE)
- decl = expr->symtree->n.sym->backend_decl;
- /* For class arrays the tree containing the class is stored in
- GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
- For all others it's sym's backend_decl directly. */
- if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- }
- else
- decl = gfc_get_class_from_gfc_expr (class_expr);
+ last_type = ref->u.c.component->ts.type;
+ last_is_allocatable = ref->u.c.component->attr.allocatable;
+ last_is_contiguous = ref->u.c.component->attr.contiguous;
+ }
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
+ if (!(last_type == BT_CLASS || last_type == BT_CHARACTER)
+ && (last_is_allocatable || last_is_contiguous))
+ return true;
- if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- return false;
- }
+ return false;
+}
- se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
- size = gfc_class_vtab_size_get (decl);
- /* For unlimited polymorphic entities then _len component needs to be
- multiplied with the size. */
- size = gfc_resize_class_size_with_len (&se->pre, decl, size);
- size = fold_convert (TREE_TYPE (index), size);
+static bool
+array_section_parent_ref_is_contiguous (gfc_expr *expr, gfc_ref *array_ref)
+{
+ if (array_ref == nullptr)
+ return false;
- /* Return the element in the se expression. */
- se->expr = gfc_build_spanned_array_ref (base, index, size);
- return true;
+ return array_section_parent_ref_is_contiguous (expr, &array_ref->u.ar);
}
-/* Indicates that the tree EXPR is a reference to an array that can’t
- have any negative stride. */
-
static bool
-non_negative_strides_array_p (tree expr)
+array_section_parent_ref_is_contiguous (gfc_ss *ss)
{
- if (expr == NULL_TREE)
- return false;
+ return array_section_parent_ref_is_contiguous (ss->info->expr,
+ ss->info->data.array.ref);
+}
- tree type = TREE_TYPE (expr);
- if (POINTER_TYPE_P (type))
- type = TREE_TYPE (type);
- if (TYPE_LANG_SPECIFIC (type))
- {
- gfc_array_kind array_kind = GFC_TYPE_ARRAY_AKIND (type);
+tree
+build_array_ref_dim (gfc_ss *ss, tree index, tree lbound, tree spacing,
+ bool tmp_array = false)
+{
+ gfc_array_info *info = &ss->info->data.array;
- if (array_kind == GFC_ARRAY_ALLOCATABLE
- || array_kind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
- return true;
- }
+ tree base = build_fold_indirect_ref_loc (input_location, info->data);
- /* An array with descriptor can have negative strides.
- We try to be conservative and return false by default here
- if we don’t recognize a contiguous array instead of
- returning false if we can identify a non-contiguous one. */
- if (!GFC_ARRAY_TYPE_P (type))
- return false;
-
- /* If the array was originally a dummy with a descriptor, strides can be
- negative. */
- if (DECL_P (expr)
- && DECL_LANG_SPECIFIC (expr)
- && GFC_DECL_SAVED_DESCRIPTOR (expr)
- && GFC_DECL_SAVED_DESCRIPTOR (expr) != expr)
- return non_negative_strides_array_p (GFC_DECL_SAVED_DESCRIPTOR (expr));
-
- return true;
-}
+ gfc_ss_type ss_type = ss->info->type;
+ bool non_negative_stride = ss_type == GFC_SS_FUNCTION
+ || ss_type == GFC_SS_CONSTRUCTOR
+ || ss_type == GFC_SS_INTRINSIC
+ || tmp_array
+ || (ss_type == GFC_SS_SECTION
+ && array_section_parent_ref_is_contiguous (ss))
+ || non_negative_strides_array_p (info->descriptor);
+ return gfc_build_array_ref (base, index, non_negative_stride, lbound,
+ spacing);
+}
/* Build a scalarized reference to an array. */
static void
-gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar,
- bool tmp_array = false)
+gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar, bool tmp_array = false)
{
- gfc_array_info *info;
- tree decl = NULL_TREE;
- tree index;
- tree base;
gfc_ss *ss;
- gfc_expr *expr;
int n;
ss = se->ss;
- expr = ss->info->expr;
- info = &ss->info->data.array;
if (ar)
n = se->loop->order[0];
else
n = 0;
- index = conv_array_index_offset (se, ss, ss->dim[n], n, ar, info->stride0);
- /* Add the offset for this dimension to the stored offset for all other
- dimensions. */
- if (info->offset && !integer_zerop (info->offset))
- index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- index, info->offset);
+ tree index = conv_array_index (se, ss, ss->dim[n], n, ar);
- base = build_fold_indirect_ref_loc (input_location, info->data);
-
- /* Use the vptr 'size' field to access the element of a class array. */
- if (build_class_array_ref (se, base, index))
- return;
-
- if (get_CFI_desc (NULL, expr, &decl, ar))
- decl = build_fold_indirect_ref_loc (input_location, decl);
-
- /* A pointer array component can be detected from its field decl. Fix
- the descriptor, mark the resulting variable decl and pass it to
- gfc_build_array_ref. */
- if (is_pointer_array (info->descriptor)
- || (expr && expr->ts.deferred && info->descriptor
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))))
- {
- if (TREE_CODE (info->descriptor) == COMPONENT_REF)
- decl = info->descriptor;
- else if (INDIRECT_REF_P (info->descriptor))
- decl = TREE_OPERAND (info->descriptor, 0);
-
- if (decl == NULL_TREE)
- decl = info->descriptor;
- }
-
- bool non_negative_stride = tmp_array
- || non_negative_strides_array_p (info->descriptor);
- se->expr = gfc_build_array_ref (base, index, decl,
- non_negative_stride);
+ gfc_array_info *info = &ss->info->data.array;
+ se->expr = build_array_ref_dim (ss, index, info->lbound[ss->dim[n]],
+ info->spacing[ss->dim[n]], tmp_array);
+ if (ss->info->class_container)
+ se->class_container = ss->info->class_container;
}
@@ -3614,10 +3694,13 @@ void
gfc_conv_tmp_array_ref (gfc_se * se)
{
se->string_length = se->ss->info->string_length;
- gfc_conv_scalarized_array_ref (se, NULL, true);
+ bool tmp_array = !(se->ss->info->expr
+ && gfc_expr_attr (se->ss->info->expr).pointer);
+ gfc_conv_scalarized_array_ref (se, NULL, tmp_array);
gfc_advance_se_ss_chain (se);
}
+
/* Add T to the offset pair *OFFSET, *CST_OFFSET. */
static void
@@ -3636,40 +3719,35 @@ add_to_offset (tree *cst_offset, tree *offset, tree t)
}
-static tree
-build_array_ref (tree desc, tree offset, tree decl, tree vptr)
+bool
+array_ref_safe_p (gfc_expr *expr, gfc_array_ref *ar, tree array, tree *elt_size)
{
- tree tmp;
- tree type;
- tree cdesc;
-
- /* For class arrays the class declaration is stored in the saved
- descriptor. */
- if (INDIRECT_REF_P (desc)
- && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
- && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
- cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
- TREE_OPERAND (desc, 0)));
- else
- cdesc = desc;
-
- /* Class container types do not always have the GFC_CLASS_TYPE_P
- but the canonical type does. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc))
- && TREE_CODE (cdesc) == COMPONENT_REF)
+ STRIP_NOPS (array);
+ if (TREE_CODE (array) == COMPONENT_REF)
{
- type = TREE_TYPE (TREE_OPERAND (cdesc, 0));
- if (TYPE_CANONICAL (type)
- && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
- vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0));
+ tree parent = TREE_OPERAND (array, 0);
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (parent)))
+ return false;
+
+ STRIP_NOPS (parent);
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (parent)))
+ return false;
}
- tmp = gfc_conv_array_data (desc);
- tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_build_array_ref (tmp, offset, decl,
- non_negative_strides_array_p (desc),
- vptr);
- return tmp;
+ if (array_section_parent_ref_is_contiguous (expr, ar))
+ ;
+ else if (!non_negative_strides_array_p (array))
+ return false;
+
+ tree elt_type = gfc_get_element_type (TREE_TYPE (array));
+ if (TYPE_SIZE_UNIT (elt_type) == NULL_TREE
+ || !INTEGER_CST_P (TYPE_SIZE_UNIT (elt_type)))
+ return false;
+
+ if (elt_size)
+ *elt_size = TYPE_SIZE_UNIT (elt_type);
+
+ return true;
}
@@ -3686,7 +3764,6 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
int n;
tree offset, cst_offset;
tree tmp;
- tree stride;
tree decl = NULL_TREE;
gfc_se indexse;
gfc_se tmpse;
@@ -3742,8 +3819,19 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
&& ar->as->type != AS_DEFERRED)
decl = sym->backend_decl;
+ tree elt_size;
+ bool use_array_ref = array_ref_safe_p (expr, ar, decl, &elt_size);
+ if (use_array_ref)
+ elt_size = fold_convert_loc (input_location, gfc_array_index_type,
+ elt_size);
+
+ tree off = gfc_conv_array_offset (decl);
+ if (use_array_ref)
+ off = fold_build2_loc (input_location, EXACT_DIV_EXPR,
+ gfc_array_index_type, off, elt_size);
+
cst_offset = offset = gfc_index_zero_node;
- add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (decl));
+ add_to_offset (&cst_offset, &offset, off);
/* Calculate the offsets from all the dimensions. Make sure to associate
the final offset so that we form a chain of loop invariant summands. */
@@ -3811,65 +3899,24 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
}
/* Multiply the index by the stride. */
- stride = gfc_conv_array_stride (decl, n);
+ tree spacing = gfc_conv_array_spacing (decl, n);
+ if (use_array_ref)
+ spacing = fold_build2_loc (input_location, EXACT_DIV_EXPR,
+ gfc_array_index_type, spacing, elt_size);
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- indexse.expr, stride);
-
+ indexse.expr, spacing);
+
/* And add it to the total. */
add_to_offset (&cst_offset, &offset, tmp);
}
+ free (var_name);
+
if (!integer_zerop (cst_offset))
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
- /* A pointer array component can be detected from its field decl. Fix
- the descriptor, mark the resulting variable decl and pass it to
- build_array_ref. */
- decl = NULL_TREE;
- if (get_CFI_desc (sym, expr, &decl, ar))
- decl = build_fold_indirect_ref_loc (input_location, decl);
- if (!expr->ts.deferred && !sym->attr.codimension
- && is_pointer_array (se->expr))
- {
- if (TREE_CODE (se->expr) == COMPONENT_REF)
- decl = se->expr;
- else if (INDIRECT_REF_P (se->expr))
- decl = TREE_OPERAND (se->expr, 0);
- else
- decl = se->expr;
- }
- else if (expr->ts.deferred
- || (sym->ts.type == BT_CHARACTER
- && sym->attr.select_type_temporary))
- {
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
- {
- decl = se->expr;
- if (INDIRECT_REF_P (decl))
- decl = TREE_OPERAND (decl, 0);
- }
- else
- decl = sym->backend_decl;
- }
- else if (sym->ts.type == BT_CLASS)
- {
- if (UNLIMITED_POLY (sym))
- {
- gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr (&tmpse, class_expr);
- if (!se->class_vptr)
- se->class_vptr = gfc_class_vptr_get (tmpse.expr);
- gfc_free_expr (class_expr);
- decl = tmpse.expr;
- }
- else
- decl = NULL_TREE;
- }
-
- free (var_name);
- se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
+ se->expr = build_array_ref (decl, offset, use_array_ref);
}
@@ -3882,21 +3929,23 @@ add_array_offset (stmtblock_t *pblock, gfc_loopinfo *loop, gfc_ss *ss,
{
gfc_se se;
gfc_array_info *info;
- tree stride, index;
info = &ss->info->data.array;
+ tree type = TREE_TYPE (info->data);
+
gfc_init_se (&se, NULL);
se.loop = loop;
se.expr = info->descriptor;
- stride = gfc_conv_array_stride (info->descriptor, array_dim);
- index = conv_array_index_offset (&se, ss, array_dim, loop_dim, ar, stride);
+ tree index = conv_array_index (&se, ss, array_dim, loop_dim, ar);
+
gfc_add_block_to_block (pblock, &se.pre);
- info->offset = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- info->offset, index);
- info->offset = gfc_evaluate_now (info->offset, pblock);
+ tree tmp = build_array_ref_dim (ss, index, info->lbound[array_dim], info->spacing[array_dim]);
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ tree fixed_type = gfc_get_unbounded_array_type (type);
+ tmp = fold_convert_loc (input_location, fixed_type, tmp);
+ info->data = gfc_evaluate_now (tmp, pblock);
}
@@ -3907,7 +3956,6 @@ static void
gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
stmtblock_t * pblock)
{
- tree stride;
gfc_ss_info *ss_info;
gfc_array_info *info;
gfc_ss_type ss_type;
@@ -3963,25 +4011,14 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
{
gcc_assert (0 == ploop->order[0]);
- stride = gfc_conv_array_stride (info->descriptor,
- innermost_ss (ss)->dim[0]);
-
- /* Calculate the stride of the innermost loop. Hopefully this will
- allow the backend optimizers to do their stuff more effectively.
- */
- info->stride0 = gfc_evaluate_now (stride, pblock);
-
- /* For the outermost loop calculate the offset due to any
- elemental dimensions. It will have been initialized with the
- base offset of the array. */
if (info->ref)
{
- for (int i = 0; i < ar->dimen; i++)
+ for (int i = ar->dimen - 1; i >= 0; i--)
{
if (ar->dimen_type[i] != DIMEN_ELEMENT)
continue;
- add_array_offset (pblock, loop, ss, ar, i, /* unused */ -1);
+ add_array_offset (pblock, ploop, ss, ar, i, -1 /* unused */);
}
}
}
@@ -4004,7 +4041,7 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag,
/* Remember this offset for the second loop. */
if (dim == loop->temp_dim - 1 && loop->parent == NULL)
- info->saved_offset = info->offset;
+ info->saved_data = info->data;
}
}
@@ -4233,7 +4270,7 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
&& ss_type != GFC_SS_COMPONENT)
continue;
- ss_info->data.array.offset = ss_info->data.array.saved_offset;
+ ss_info->data.array.data = ss_info->data.array.saved_data;
}
/* Restart all the inner loops we just finished. */
@@ -4262,13 +4299,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body)
static void
evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
- tree desc, int dim, bool lbound, bool deferred)
+ tree desc, int dim, bool lbound, bool deferred, bool save_value)
{
gfc_se se;
- gfc_expr * input_val = values[dim];
+ gfc_expr * input_val = values ? values[dim] : nullptr;
tree *output = &bounds[dim];
-
if (input_val)
{
/* Specified section bound. */
@@ -4294,7 +4330,58 @@ evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
*output = lbound ? gfc_conv_array_lbound (desc, dim) :
gfc_conv_array_ubound (desc, dim);
}
- *output = gfc_evaluate_now (*output, block);
+ if (save_value)
+ *output = gfc_evaluate_now (*output, block);
+}
+
+
+void
+gfc_conv_array_lbound_spacing (stmtblock_t * block, gfc_ss * ss, int dim)
+{
+ gfc_array_info *info;
+
+ gcc_assert (ss->info->type == GFC_SS_SECTION
+ || ss->info->type == GFC_SS_COMPONENT
+ || ss->info->type == GFC_SS_VECTOR);
+
+ info = &ss->info->data.array;
+ tree desc = info->descriptor;
+
+ bool save_value = !ss->is_alloc_lhs;
+
+ tree value = NULL_TREE;
+
+ value = gfc_conv_array_spacing (desc, dim);
+
+#if 0
+ if (GFC_ARRAY_TYPE_P (type)
+ && GFC_TYPE_ARRAY_SPACING (type, dim) != NULL_TREE)
+ value = GFC_TYPE_ARRAY_SPACING (type, dim);
+ else if (dim == 0)
+ value = gfc_index_one_node;
+ else
+ {
+ if (info->spacing[dim - 1] == NULL_TREE)
+ conv_array_spacing (block, ss, dim - 1);
+
+ tree previous_spacing = info->spacing[dim - 1];
+ tree previous_extent = gfc_conv_array_extent (desc, dim - 1);
+ value = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, previous_spacing,
+ previous_extent);
+ }
+#endif
+
+ if (save_value)
+ info->spacing[dim] = gfc_evaluate_now (value, block);
+ else
+ info->spacing[dim] = value;
+
+ value = gfc_conv_array_lbound (desc, dim);
+ if (save_value)
+ info->lbound[dim] = gfc_evaluate_now (value, block);
+ else
+ info->lbound[dim] = value;
}
@@ -4327,19 +4414,18 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
|| ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
desc = info->descriptor;
stride = ar->stride[dim];
-
+ bool save_value = !ss->is_alloc_lhs;
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
evaluate_bound (block, info->start, ar->start, desc, dim, true,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, save_value);
/* Similarly calculate the end. Although this is not used in the
scalarizer, it is needed when checking bounds and where the end
is an expression with side-effects. */
evaluate_bound (block, info->end, ar->end, desc, dim, false,
- ar->as->type == AS_DEFERRED);
-
+ ar->as->type == AS_DEFERRED, save_value);
/* Calculate the stride. */
if (stride == NULL)
@@ -4349,7 +4435,11 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim)
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, stride, gfc_array_index_type);
gfc_add_block_to_block (block, &se.pre);
- info->stride[dim] = gfc_evaluate_now (se.expr, block);
+ tree value = se.expr;
+ if (save_value)
+ info->stride[dim] = gfc_evaluate_now (value, block);
+ else
+ info->stride[dim] = value;
}
}
@@ -4602,7 +4692,15 @@ done:
!loop->array_parameter);
for (n = 0; n < ss->dimen; n++)
- gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
+ {
+ gfc_conv_section_startstride (&outer_loop->pre, ss, ss->dim[n]);
+ gfc_conv_array_lbound_spacing (&outer_loop->pre, ss, ss->dim[n]);
+ }
+ if (loop->parent == nullptr)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ if (info->subscript[n]
+ && info->subscript[n]->info->type == GFC_SS_SCALAR)
+ gfc_conv_array_lbound_spacing (&outer_loop->pre, ss, n);
break;
case GFC_SS_INTRINSIC:
@@ -4691,14 +4789,15 @@ done:
}
/* FALLTHRU */
- case GFC_SS_CONSTRUCTOR:
case GFC_SS_FUNCTION:
+ case GFC_SS_CONSTRUCTOR:
for (n = 0; n < ss->dimen; n++)
{
int dim = ss->dim[n];
info->start[dim] = gfc_index_zero_node;
- info->end[dim] = gfc_index_zero_node;
+ if (ss_info->type != GFC_SS_FUNCTION)
+ info->end[dim] = gfc_index_zero_node;
info->stride[dim] = gfc_index_one_node;
}
break;
@@ -5286,7 +5385,8 @@ set_loop_bounds (gfc_loopinfo *loop)
&& INTEGER_CST_P (info->stride[dim]))
{
loop->from[n] = info->start[dim];
- mpz_set (i, cshape[get_array_ref_dim_for_loop_dim (loopspec[n], n)]);
+ const int idx = gfc_get_array_ref_dim_for_loop_dim (loopspec[n], n);
+ mpz_set (i, cshape[idx]);
mpz_sub_ui (i, i, 1);
/* To = from + (size - 1) * stride. */
tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind);
@@ -5383,6 +5483,46 @@ set_loop_bounds (gfc_loopinfo *loop)
}
+/* Last attempt to set the loop bounds, in case they depend on an allocatable
+ function result. */
+
+static void
+late_set_loop_bounds (gfc_loopinfo *loop)
+{
+ int n, dim;
+ gfc_array_info *info;
+ gfc_ss **loopspec;
+
+ loopspec = loop->specloop;
+
+ for (n = 0; n < loop->dimen; n++)
+ {
+ /* Set the extents of this range. */
+ if (loop->from[n] == NULL_TREE
+ || loop->to[n] == NULL_TREE)
+ {
+ /* We should have found the scalarization loop specifier. If not,
+ that's bad news. */
+ gcc_assert (loopspec[n]);
+
+ info = &loopspec[n]->info->data.array;
+ dim = loopspec[n]->dim[n];
+
+ if (loopspec[n]->info->type == GFC_SS_FUNCTION
+ && info->start[dim]
+ && info->end[dim])
+ {
+ loop->from[n] = info->start[dim];
+ loop->to[n] = info->end[dim];
+ }
+ }
+ }
+
+ for (loop = loop->nested; loop; loop = loop->next)
+ late_set_loop_bounds (loop);
+}
+
+
/* Initialize the scalarization loop. Creates the loop variables. Determines
the range of the loop variables. Creates a temporary if required.
Also generates code for scalar expressions which have been
@@ -5401,6 +5541,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
allocating the temporary. */
gfc_add_loop_ss_code (loop, loop->ss, false, where);
+ late_set_loop_bounds (loop);
+
tmp_ss = loop->temp_ss;
/* If we want a temporary then create it. */
if (tmp_ss != NULL)
@@ -5411,12 +5553,19 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
gcc_assert (tmp_ss_info->type == GFC_SS_TEMP);
gcc_assert (loop->parent == NULL);
+ bool preserve_bounds = tmp_ss_info->data.temp.preserve_bounds;
+
/* Make absolutely sure that this is a complete type. */
if (tmp_ss_info->string_length)
- tmp_ss_info->data.temp.type
- = gfc_get_character_type_len_for_eltype
- (TREE_TYPE (tmp_ss_info->data.temp.type),
- tmp_ss_info->string_length);
+ {
+ tree len = tmp_ss_info->string_length;
+ len = gfc_evaluate_now (len, &outermost_loop (loop)->pre);
+ tmp_ss_info->string_length = len;
+ tmp_ss_info->data.temp.type
+ = gfc_get_character_type_len_for_eltype
+ (TREE_TYPE (tmp_ss_info->data.temp.type),
+ tmp_ss_info->string_length);
+ }
tmp = tmp_ss_info->data.temp.type;
memset (&tmp_ss_info->data.array, 0, sizeof (gfc_array_info));
@@ -5425,7 +5574,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, where,
+ !preserve_bounds);
}
/* For array parameters we don't have loop variables, so don't calculate the
@@ -5457,9 +5607,11 @@ gfc_set_delta (gfc_loopinfo *loop)
gfc_ss_type ss_type;
ss_type = ss->info->type;
- if (ss_type != GFC_SS_SECTION
- && ss_type != GFC_SS_COMPONENT
- && ss_type != GFC_SS_CONSTRUCTOR)
+ if (!(ss_type == GFC_SS_SECTION
+ || ss_type == GFC_SS_COMPONENT
+ || ss_type == GFC_SS_CONSTRUCTOR
+ || (ss_type == GFC_SS_FUNCTION
+ && gfc_is_class_array_function (ss->info->expr))))
continue;
info = &ss->info->data.array;
@@ -5484,7 +5636,10 @@ gfc_set_delta (gfc_loopinfo *loop)
gfc_array_index_type,
info->start[dim], tmp);
- info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
+ if (ss->is_alloc_lhs)
+ info->delta[dim] = tmp;
+ else
+ info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre);
}
}
}
@@ -5494,358 +5649,17 @@ gfc_set_delta (gfc_loopinfo *loop)
}
-/* Calculate the size of a given array dimension from the bounds. This
- is simply (ubound - lbound + 1) if this expression is positive
- or 0 if it is negative (pick either one if it is zero). Optionally
- (if or_expr is present) OR the (expression != 0) condition to it. */
-
-tree
-gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
-{
- tree res;
- tree cond;
-
- /* Calculate (ubound - lbound + 1). */
- res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- ubound, lbound);
- res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
- gfc_index_one_node);
-
- /* Check whether the size for this dimension is negative. */
- cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
- gfc_index_zero_node);
- res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
- gfc_index_zero_node, res);
-
- /* Build OR expression. */
- if (or_expr)
- *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, *or_expr, cond);
-
- return res;
-}
-
-
-/* For an array descriptor, get the total number of elements. This is just
- the product of the extents along from_dim to to_dim. */
-
static tree
-gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
-{
- tree res;
- int dim;
-
- res = gfc_index_one_node;
-
- for (dim = from_dim; dim < to_dim; ++dim)
- {
- tree lbound;
- tree ubound;
- tree extent;
-
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
-
- extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- res, extent);
- }
-
- return res;
-}
-
-
-/* Full size of an array. */
-
-tree
-gfc_conv_descriptor_size (tree desc, int rank)
-{
- return gfc_conv_descriptor_size_1 (desc, 0, rank);
-}
-
-
-/* Size of a coarray for all dimensions but the last. */
-
-tree
-gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
-{
- return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
-}
-
-
-/* Fills in an array descriptor, and returns the size of the array.
- The size will be a simple_val, ie a variable or a constant. Also
- calculates the offset of the base. The pointer argument overflow,
- which should be of integer type, will increase in value if overflow
- occurs during the size calculation. Returns the size of the array.
- {
- stride = 1;
- offset = 0;
- for (n = 0; n < rank; n++)
- {
- a.lbound[n] = specified_lower_bound;
- offset = offset + a.lbond[n] * stride;
- size = 1 - lbound;
- a.ubound[n] = specified_upper_bound;
- a.stride[n] = stride;
- size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
- overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
- stride = stride * size;
- }
- for (n = rank; n < rank+corank; n++)
- (Set lcobound/ucobound as above.)
- element_size = sizeof (array element);
- if (!rank)
- return element_size
- stride = (size_t) stride;
- overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
- stride = stride * element_size;
- return (stride);
- } */
-/*GCC ARRAYS*/
-
-static tree
-gfc_array_init_size (tree descriptor, 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,
- tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
- tree *element_size, bool explicit_ts)
+descriptor_element_size (tree descriptor, gfc_typespec *explicit_ts,
+ tree expr3_elem_size, gfc_expr *expr3)
{
tree type;
tree tmp;
- tree size;
- tree offset;
- tree stride;
- tree or_expr;
- tree thencase;
- tree elsecase;
- tree cond;
- tree var;
- stmtblock_t thenblock;
- stmtblock_t elseblock;
- gfc_expr *ubound;
- gfc_se se;
- int n;
type = TREE_TYPE (descriptor);
- stride = gfc_index_one_node;
- offset = gfc_index_zero_node;
-
- /* Set the dtype before the alloc, because registration of coarrays needs
- it initialized. */
- if (expr->ts.type == BT_CHARACTER
- && expr->ts.deferred
- && VAR_P (expr->ts.u.cl->backend_decl))
- {
- type = gfc_typenode_for_spec (&expr->ts);
- gfc_conv_descriptor_dtype_set (pblock, descriptor,
- gfc_get_dtype_rank_type (rank, type));
- }
- else if (expr->ts.type == BT_CHARACTER
- && expr->ts.deferred
- && TREE_CODE (descriptor) == COMPONENT_REF)
- {
- /* Deferred character components have their string length tucked away
- in a hidden field of the derived type. Obtain that and use it to
- set the dtype. The charlen backend decl is zero because the field
- type is zero length. */
- gfc_ref *ref;
- tmp = NULL_TREE;
- for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT
- && gfc_deferred_strlen (ref->u.c.component, &tmp))
- break;
- gcc_assert (tmp != NULL_TREE);
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
- TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
- tmp = fold_convert (gfc_charlen_type_node, tmp);
- type = gfc_get_character_type_len (expr->ts.kind, tmp);
- gfc_conv_descriptor_dtype_set (pblock, descriptor,
- gfc_get_dtype_rank_type (rank, type));
- }
- else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
- gfc_conv_descriptor_dtype_set (pblock, descriptor,
- gfc_conv_descriptor_dtype_get (expr3_desc));
- else if (expr->ts.type == BT_CLASS && !explicit_ts
- && expr3 && expr3->ts.type != BT_CLASS
- && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
- gfc_conv_descriptor_elem_len_set (pblock, descriptor, expr3_elem_size);
- else
- gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
-
- or_expr = logical_false_node;
-
- for (n = 0; n < rank; n++)
- {
- tree conv_lbound;
- tree conv_ubound;
-
- /* We have 3 possibilities for determining the size of the array:
- lower == NULL => lbound = 1, ubound = upper[n]
- upper[n] = NULL => lbound = 1, ubound = lower[n]
- upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
- ubound = upper[n];
-
- /* Set lower bound. */
- gfc_init_se (&se, NULL);
- if (expr3_desc != NULL_TREE)
- {
- if (e3_has_nodescriptor)
- /* The lbound of nondescriptor arrays like array constructors,
- nonallocatable/nonpointer function results/variables,
- start at zero, but when allocating it, the standard expects
- the array to start at one. */
- se.expr = gfc_index_one_node;
- else
- se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
- gfc_rank_cst[n]);
- }
- else if (lower == NULL)
- se.expr = gfc_index_one_node;
- else
- {
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
- else
- {
- se.expr = gfc_index_one_node;
- ubound = lower[n];
- }
- }
- gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
- gfc_rank_cst[n], se.expr);
- conv_lbound = se.expr;
-
- /* Work out the offset for this component. */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- se.expr, stride);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, tmp);
-
- /* Set upper bound. */
- gfc_init_se (&se, NULL);
- if (expr3_desc != NULL_TREE)
- {
- if (e3_has_nodescriptor)
- {
- /* The lbound of nondescriptor arrays like array constructors,
- nonallocatable/nonpointer function results/variables,
- start at zero, but when allocating it, the standard expects
- the array to start at one. Therefore fix the upper bound to be
- (desc.ubound - desc.lbound) + 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (
- expr3_desc, gfc_rank_cst[n]),
- gfc_conv_descriptor_lbound_get (
- expr3_desc, gfc_rank_cst[n]));
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp,
- gfc_index_one_node);
- se.expr = gfc_evaluate_now (tmp, pblock);
- }
- else
- se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
- gfc_rank_cst[n]);
- }
- else
- {
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- if (ubound->expr_type == EXPR_FUNCTION)
- se.expr = gfc_evaluate_now (se.expr, pblock);
- }
- gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
- gfc_rank_cst[n], se.expr);
- conv_ubound = se.expr;
-
- /* Store the stride. */
- gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
- gfc_rank_cst[n], stride);
-
- /* Calculate size and check whether extent is negative. */
- size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
- size = gfc_evaluate_now (size, pblock);
-
- /* Check whether multiplying the stride by the number of
- elements in this dimension would overflow. We must also check
- whether the current dimension has zero size in order to avoid
- division by zero.
- */
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_array_index_type,
- fold_convert (gfc_array_index_type,
- TYPE_MAX_VALUE (gfc_array_index_type)),
- size);
- cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
- logical_type_node, tmp, stride),
- PRED_FORTRAN_OVERFLOW);
- tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
- integer_one_node, integer_zero_node);
- cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, size,
- gfc_index_zero_node),
- PRED_FORTRAN_SIZE_ZERO);
- tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
- integer_zero_node, tmp);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
- *overflow, tmp);
- *overflow = gfc_evaluate_now (tmp, pblock);
-
- /* Multiply the stride by the number of elements in this dimension. */
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, size);
- stride = gfc_evaluate_now (stride, pblock);
- }
-
- for (n = rank; n < rank + corank; n++)
- {
- ubound = upper[n];
-
- /* Set lower bound. */
- gfc_init_se (&se, NULL);
- if (lower == NULL || lower[n] == NULL)
- {
- gcc_assert (n == rank + corank - 1);
- se.expr = gfc_index_one_node;
- }
- else
- {
- if (ubound || n == rank + corank - 1)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
- else
- {
- se.expr = gfc_index_one_node;
- ubound = lower[n];
- }
- }
- gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
- gfc_rank_cst[n], se.expr);
-
- if (n < rank + corank - 1)
- {
- gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
- gfc_rank_cst[n], se.expr);
- }
- }
-
- /* The stride is the number of elements in the array, so multiply by the
- size of an element to get the total size. Obviously, if there is a
- SOURCE expression (expr3) we must use its element size. */
+ /* Obviously, if there is a SOURCE expression (expr3) we must use its element
+ size. */
if (expr3_elem_size != NULL_TREE)
tmp = expr3_elem_size;
else if (expr3 != NULL)
@@ -5868,30 +5682,57 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
}
}
else
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ {
+ tree element_type;
+ if (explicit_ts)
+ element_type = gfc_typenode_for_spec (explicit_ts);
+ else
+ element_type = gfc_get_element_type (type);
+
+ tmp = TYPE_SIZE_UNIT (element_type);
+ }
/* Convert to size_t. */
- *element_size = fold_convert (size_type_node, tmp);
+ return fold_convert (size_type_node, tmp);
+}
- if (rank == 0)
- return *element_size;
- *nelems = gfc_evaluate_now (stride, pblock);
- stride = fold_convert (size_type_node, stride);
+/* Calculates the memory size of an array, given the size of its elements,
+ the number of them, and the predicate whether the array is empty.
+ elements_count = (size_t) elements_count;
+ overflow += element_size == 0 ? 0: (MAX/element_size < elements_count ? 1: 0);
+ tmp = elements_count * element_size;
+ return (tmp); */
+
+static tree
+get_array_memory_size (tree element_size, tree elements_count,
+ tree empty_array_cond, stmtblock_t * pblock,
+ tree * overflow)
+{
+ tree tmp;
+ tree size;
+ tree thencase;
+ tree elsecase;
+ tree cond;
+ tree var;
+ stmtblock_t thenblock;
+ stmtblock_t elseblock;
+
+ elements_count = fold_convert (size_type_node, elements_count);
/* First check for overflow. Since an array of type character can
have zero element_size, we must check for that before
dividing. */
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
size_type_node,
- TYPE_MAX_VALUE (size_type_node), *element_size);
+ TYPE_MAX_VALUE (size_type_node), element_size);
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
- logical_type_node, tmp, stride),
+ logical_type_node, tmp, elements_count),
PRED_FORTRAN_OVERFLOW);
tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
integer_one_node, integer_zero_node);
cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, *element_size,
+ logical_type_node, element_size,
build_int_cst (size_type_node, 0)),
PRED_FORTRAN_SIZE_ZERO);
tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
@@ -5901,17 +5742,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
*overflow = gfc_evaluate_now (tmp, pblock);
size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- stride, *element_size);
+ elements_count, element_size);
- if (poffset != NULL)
- {
- offset = gfc_evaluate_now (offset, pblock);
- *poffset = offset;
- }
-
- if (integer_zerop (or_expr))
+ if (integer_zerop (empty_array_cond))
return size;
- if (integer_onep (or_expr))
+ if (integer_onep (empty_array_cond))
return build_int_cst (size_type_node, 0);
var = gfc_create_var (TREE_TYPE (size), "size");
@@ -5923,7 +5758,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_add_modify (&elseblock, var, size);
elsecase = gfc_finish_block (&elseblock);
- tmp = gfc_evaluate_now (or_expr, pblock);
+ tmp = gfc_evaluate_now (empty_array_cond, pblock);
tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
gfc_add_expr_to_block (pblock, tmp);
@@ -5965,15 +5800,12 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
- bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc,
- bool explicit_ts)
+ gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
+ gfc_omp_namelist *omp_alloc, gfc_typespec * explicit_ts)
{
tree tmp;
tree pointer;
- tree offset = NULL_TREE;
tree token = NULL_TREE;
- tree size;
tree msg;
tree error = NULL_TREE;
tree overflow; /* Boolean storing whether size calculation overflows. */
@@ -6083,6 +5915,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (expr->ts.type == BT_CHARACTER
&& TREE_CODE (se->string_length) == COMPONENT_REF
+ && expr->ts.u.cl->backend_decl
&& expr->ts.u.cl->backend_decl != se->string_length
&& VAR_P (expr->ts.u.cl->backend_decl))
gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl,
@@ -6090,17 +5923,28 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
se->string_length));
gfc_init_block (&set_descriptor_block);
+
+
+ element_size = descriptor_element_size (se->expr, explicit_ts,
+ expr3_elem_size, expr3);
+
+ tree empty_array_cond;
/* Take the corank only from the actual ref and not from the coref. The
later will mislead the generation of the array dimensions for allocatable/
pointer components in derived types. */
- size = gfc_array_init_size (se->expr, alloc_w_e3_arr_spec ? expr->rank
- : ref->u.ar.as->rank,
- coarray ? ref->u.ar.as->corank : 0,
- &offset, lower, upper,
- &se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3, e3_arr_desc,
- e3_has_nodescriptor, expr, &element_size,
- explicit_ts);
+ int rank = alloc_w_e3_arr_spec ? expr->rank : ref->u.ar.as->rank;
+ tree count = gfc_descr_init_count (se->expr, rank,
+ coarray ? ref->u.ar.as->corank : 0,
+ lower, upper, &se->pre,
+ &set_descriptor_block, &overflow,
+ expr3_elem_size, expr3, e3_arr_desc,
+ e3_has_nodescriptor, expr, element_size,
+ explicit_ts, &empty_array_cond);
+
+ tree size = rank == 0
+ ? element_size
+ : get_array_memory_size (element_size, count, empty_array_cond,
+ &se->pre, &overflow);
if (dimension)
{
@@ -6137,7 +5981,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
{
pointer = non_ulimate_coarray_ptr_comp ? se->expr
: gfc_conv_descriptor_data_get (se->expr);
- token = gfc_conv_descriptor_token (se->expr);
+ token = gfc_conv_descriptor_token_get (se->expr);
token = gfc_build_addr_expr (NULL_TREE, token);
}
else
@@ -6201,11 +6045,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
build_tree_list (NULL_TREE, alloc),
DECL_ATTRIBUTES (omp_alt_alloc));
omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
- stmtblock_t tmp_block;
- gfc_init_block (&tmp_block);
- gfc_conv_descriptor_version_set (&tmp_block, se->expr,
+
+ stmtblock_t set_version;
+ gfc_init_block (&set_version);
+ gfc_conv_descriptor_version_set (&set_version, se->expr,
build_int_cst (integer_type_node, 1));
- succ_add_expr = gfc_finish_block (&tmp_block);
+ succ_add_expr = gfc_finish_block (&set_version);
}
/* The allocatable variant takes the old pointer as first argument. */
@@ -6236,14 +6081,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_add_expr_to_block (&se->pre, tmp);
- /* Update the array descriptor with the offset and the span. */
- if (dimension)
- {
- gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
- tmp = fold_convert (gfc_array_index_type, element_size);
- gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp);
- }
-
set_descriptor = gfc_finish_block (&set_descriptor_block);
if (status != NULL_TREE)
{
@@ -6264,8 +6101,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
else
gfc_add_expr_to_block (&se->pre, set_descriptor);
- expr->symtree->n.sym->allocated_in_scope = 1;
-
return true;
}
@@ -6278,6 +6113,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
{
gfc_constructor *c;
tree tmp;
+ tree min_index = NULL_TREE;
gfc_se se;
tree index, range;
vec<constructor_elt, va_gc> *v = NULL;
@@ -6314,6 +6150,9 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
break;
case EXPR_ARRAY:
+ if (TYPE_DOMAIN (type))
+ min_index = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+
/* Create a vector of all the elements. */
for (c = gfc_constructor_first (expr->value.constructor);
c && c->expr; c = gfc_constructor_next (c))
@@ -6333,6 +6172,9 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
else
index = NULL_TREE;
+ if (index && min_index)
+ index = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (index), index, min_index);
if (mpz_cmp_si (c->repeat, 1) > 0)
{
@@ -6351,6 +6193,14 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
else
tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+ if (min_index)
+ {
+ tmp1 = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (tmp1), tmp1, min_index);
+ tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (tmp2), tmp2, min_index);
+ }
+
range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
mpz_clear (maxval);
}
@@ -6468,7 +6318,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
/* Generate code to evaluate non-constant array bounds. Sets *poffset and
- returns the size (in elements) of the array. */
+ returns the size (in bytes) of the array. */
tree
gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
@@ -6476,7 +6326,6 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
{
gfc_array_spec *as;
tree size;
- tree stride;
tree offset;
tree ubound;
tree lbound;
@@ -6485,13 +6334,32 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
int dim;
+ gfc_trans_vla_type_sizes (sym, pblock);
+
as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+ tree eltype = gfc_get_element_type (type);
+ tree elem_len = fold_convert_loc (input_location, gfc_array_index_type,
+ TYPE_SIZE_UNIT (eltype));
size = gfc_index_one_node;
offset = gfc_index_zero_node;
- stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
- if (stride && VAR_P (stride))
- gfc_add_modify (pblock, stride, gfc_index_one_node);
+ tree spacing = GFC_TYPE_ARRAY_SPACING (type, 0);
+ if (spacing && VAR_P (spacing))
+ {
+ tree spacing0;
+ if (sym->ts.type == BT_CLASS
+ && DECL_LANG_SPECIFIC (sym->backend_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))
+ {
+ tree class_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+ tree array_desc = gfc_class_data_get (class_desc);
+ spacing0 = gfc_conv_array_spacing (array_desc, 0);
+ }
+ else
+ spacing0 = elem_len;
+
+ gfc_add_modify (pblock, spacing, spacing0);
+ }
for (dim = 0; dim < as->rank; dim++)
{
/* Evaluate non-constant array bound expressions.
@@ -6508,6 +6376,18 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
gfc_add_block_to_block (pblock, &se.finalblock);
gfc_add_modify (pblock, lbound, se.expr);
}
+ /* The offset of this dimension. offset = offset - lbound * sm. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ lbound, spacing);
+ offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ offset, tmp);
+ if (as->type == AS_ASSUMED_SIZE
+ && dim == as->rank - 1)
+ {
+ size = NULL_TREE;
+ break;
+ }
+
ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
if (as->upper[dim] && !INTEGER_CST_P (ubound))
{
@@ -6517,44 +6397,35 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
gfc_add_block_to_block (pblock, &se.finalblock);
gfc_add_modify (pblock, ubound, se.expr);
}
- /* The offset of this dimension. offset = offset - lbound * stride. */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- lbound, size);
- offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, tmp);
- /* The size of this dimension, and the stride of the next. */
+ /* Calculate spacing = size * (ubound + 1 - lbound). */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, nullptr);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+
+ tree array_info;
if (dim + 1 < as->rank)
- stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
+ array_info = GFC_TYPE_ARRAY_SPACING (type, dim + 1);
else
- stride = GFC_TYPE_ARRAY_SIZE (type);
+ array_info = GFC_TYPE_ARRAY_SIZE (type);
- if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
+ if (!(array_info && INTEGER_CST_P (array_info)))
{
- /* Calculate stride = size * (ubound + 1 - lbound). */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- gfc_index_one_node, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, ubound, tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
- if (stride)
- gfc_add_modify (pblock, stride, tmp);
+ if (dim + 1 < as->rank)
+ {
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing, tmp);
+ spacing = array_info;
+ }
else
- stride = gfc_evaluate_now (tmp, pblock);
+ {
+ tmp = size;
+ spacing = NULL_TREE;
+ }
- /* Make sure that negative size arrays are translated
- to being zero size. */
- tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, tmp,
- stride, gfc_index_zero_node);
- gfc_add_modify (pblock, stride, tmp);
+ gcc_assert (array_info);
+ gfc_add_modify (pblock, array_info, tmp);
}
-
- size = stride;
}
gfc_trans_array_cobounds (type, pblock, sym);
@@ -6622,15 +6493,6 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
}
}
- if (onstack)
- {
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
- back);
- return;
- }
-
- type = TREE_TYPE (type);
-
gcc_assert (!sym->attr.use_assoc);
gcc_assert (!sym->module);
@@ -6638,17 +6500,29 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
&& !INTEGER_CST_P (sym->ts.u.cl->backend_decl))
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
+ if (!onstack)
+ type = TREE_TYPE (type);
+
+ if (!GFC_TYPE_ARRAY_ELEM_LEN (type))
+ {
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ return;
+ }
+
size = gfc_trans_array_bounds (type, sym, &offset, &init);
+ /* Set offset of the array. */
+ if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
+ gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
+
/* Don't actually allocate space for Cray Pointees. */
- if (sym->attr.cray_pointee)
+ if (onstack || sym->attr.cray_pointee)
{
- if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
- gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
-
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE,
+ onstack && back);
return;
}
+
if (sym->attr.omp_allocate)
{
/* The size is the number of elements in the array, so multiply by the
@@ -6679,7 +6553,6 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, fold_convert (gfc_array_index_type, tmp));
-
/* Allocate memory to hold the data. */
tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size);
gfc_add_modify (&init, decl, tmp);
@@ -6689,10 +6562,6 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
space = NULL_TREE;
}
- /* Set offset of the array. */
- if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
- gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
-
/* Automatic arrays should not have initializers. */
gcc_assert (!sym->value);
@@ -6812,11 +6681,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
tree stmtInit, stmtCleanup;
tree lbound;
tree ubound;
- tree dubound;
- tree dlbound;
+ tree dextent;
tree dumdesc;
tree tmp;
- tree stride, stride2;
+ tree stride2, spacing = NULL_TREE;
tree stmt_packed;
tree stmt_unpacked;
tree partial;
@@ -6877,9 +6745,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
anything as we still don't know the array stride. */
partial = gfc_create_var (logical_type_node, "partial");
TREE_USED (partial) = 1;
- tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
+ tmp = gfc_conv_descriptor_spacing_get (dumdesc, gfc_rank_cst[0]);
tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp,
- gfc_index_one_node);
+ gfc_conv_descriptor_span_get (dumdesc));
gfc_add_modify (&init, partial, tmp);
}
else
@@ -6890,28 +6758,27 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
if (no_repack)
{
/* Set the first stride. */
- stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]);
- stride = gfc_evaluate_now (stride, &init);
-
- tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
- tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node, stride);
- stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
- gfc_add_modify (&init, stride, tmp);
+ spacing = GFC_TYPE_ARRAY_SPACING (type, 0);
+ if (!INTEGER_CST_P (spacing))
+ {
+ tmp = gfc_conv_descriptor_spacing_get (dumdesc, gfc_rank_cst[0]);
+ tmp = gfc_evaluate_now (tmp, &init);
+ gfc_add_modify (&init, spacing, tmp);
+ }
/* Allow the user to disable array repacking. */
stmt_unpacked = NULL_TREE;
}
else
{
- gcc_assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0)));
/* A library call to repack the array if necessary. */
tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
stmt_unpacked = build_call_expr_loc (input_location,
gfor_fndecl_in_pack, 1, tmp);
- stride = gfc_index_one_node;
+ spacing = gfc_conv_descriptor_span_get (dumdesc);
+ spacing = fold_convert_loc (input_location, gfc_array_index_type,
+ spacing);
if (warn_array_temporaries)
{
@@ -6942,21 +6809,16 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
offset = gfc_index_zero_node;
size = gfc_index_one_node;
+ tree spacing_units = gfc_conv_descriptor_span_get (dumdesc);
/* Evaluate the bounds of the array. */
for (n = 0; n < as->rank; n++)
{
if (checkparm || !as->upper[n])
- {
- /* Get the bounds of the actual parameter. */
- dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
- dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]);
- }
+ /* Get the bounds of the actual parameter. */
+ dextent = gfc_conv_descriptor_extent_get (dumdesc, gfc_rank_cst[n]);
else
- {
- dubound = NULL_TREE;
- dlbound = NULL_TREE;
- }
+ dextent = NULL_TREE;
lbound = GFC_TYPE_ARRAY_LBOUND (type, n);
if (!INTEGER_CST_P (lbound))
@@ -6968,6 +6830,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
gfc_add_modify (&init, lbound, se.expr);
}
+ tree extent = GFC_TYPE_ARRAY_EXTENT (type, n);
ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
/* Set the desired upper bound. */
if (as->upper[n])
@@ -6991,17 +6854,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
locus where;
gfc_locus_from_location (&where, loc);
- temp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- temp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- gfc_index_one_node, temp);
- stride2 = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, dubound,
- dlbound);
- stride2 = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- gfc_index_one_node, stride2);
+ temp = extent;
+ stride2 = dextent;
tmp = fold_build2_loc (input_location, NE_EXPR,
gfc_array_index_type, temp, stride2);
msg = xasprintf ("Dimension %d of array '%s' has extent "
@@ -7019,71 +6873,65 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
/* For assumed shape arrays move the upper bound by the same amount
as the lower bound. */
tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, dubound, dlbound);
+ gfc_array_index_type, dextent,
+ gfc_index_one_node);
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, tmp, lbound);
gfc_add_modify (&init, ubound, tmp);
}
- /* The offset of this dimension. offset = offset - lbound * stride. */
+ /* The offset of this dimension. offset = offset - lbound * spacing. */
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- lbound, stride);
+ lbound, spacing);
offset = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, offset, tmp);
- /* The size of this dimension, and the stride of the next. */
+ /* The size of this dimension, and the spacing of the next. */
if (n + 1 < as->rank)
{
- stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
+ spacing = GFC_TYPE_ARRAY_SPACING (type, n + 1);
if (no_repack || partial != NULL_TREE)
stmt_unpacked =
- gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]);
+ gfc_conv_descriptor_spacing_get (dumdesc, gfc_rank_cst[n+1]);
- /* Figure out the stride if not a known constant. */
- if (!INTEGER_CST_P (stride))
+ /* Figure out the spacing if not a known constant. */
+ if (!INTEGER_CST_P (spacing))
{
if (no_repack)
stmt_packed = NULL_TREE;
else
{
- /* Calculate stride = size * (ubound + 1 - lbound). */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- gfc_index_one_node, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, ubound, tmp);
+ /* Calculate spacing = size * (ubound + 1 - lbound). */
size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
- stmt_packed = size;
+ gfc_array_index_type, size, extent);
+ spacing_units = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ spacing_units, extent);
+
+ stmt_packed = spacing_units;
}
- /* Assign the stride. */
+ /* Assign the spacing. */
if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE)
tmp = fold_build3_loc (input_location, COND_EXPR,
gfc_array_index_type, partial,
stmt_unpacked, stmt_packed);
else
tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked;
- gfc_add_modify (&init, stride, tmp);
+ gfc_add_modify (&init, spacing, tmp);
}
}
else
{
- stride = GFC_TYPE_ARRAY_SIZE (type);
+ spacing = GFC_TYPE_ARRAY_SIZE (type);
- if (stride && !INTEGER_CST_P (stride))
+ if (spacing && !INTEGER_CST_P (spacing))
{
/* Calculate size = stride * (ubound + 1 - lbound). */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- gfc_index_one_node, lbound);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- ubound, tmp);
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
- gfc_add_modify (&init, stride, tmp);
+ size, extent);
+ gfc_add_modify (&init, spacing, tmp);
}
}
}
@@ -7168,7 +7016,6 @@ void
gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
bool subref, gfc_expr *expr)
{
- tree tmp;
tree field;
tree stride;
tree index;
@@ -7176,17 +7023,13 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
gfc_se start;
int n;
- /* If offset is NULL and this is not a subreferenced array, there is
- nothing to do. */
- if (offset == NULL_TREE)
- {
- if (subref)
- offset = gfc_index_zero_node;
- else
- return;
- }
+ bool non_negative_strides = non_negative_strides_array_p (desc);
+
+ tree tmp = gfc_conv_array_data (desc);
+ tree array = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = build_array_ref (desc, offset, NULL, NULL);
+ tmp = gfc_build_array_ref (array, gfc_index_zero_node, non_negative_strides,
+ gfc_index_zero_node, NULL_TREE, offset);
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */
@@ -7219,7 +7062,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
gfc_init_se (&start, NULL);
gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
gfc_add_block_to_block (block, &start.pre);
- tmp = gfc_build_array_ref (tmp, start.expr, NULL);
+ tmp = gfc_build_array_ref (tmp, start.expr, true);
break;
case REF_ARRAY:
@@ -7264,7 +7107,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
}
/* Apply the index to obtain the array element. */
- tmp = gfc_build_array_ref (tmp, index, NULL);
+ tmp = gfc_build_array_ref (tmp, index, true, gfc_index_zero_node);
break;
case REF_INQUIRY:
@@ -7547,6 +7390,7 @@ is_explicit_coarray (gfc_expr *expr)
return cas && cas->cotype == AS_EXPLICIT;
}
+
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
passed. For whole arrays the descriptor is passed. For array sections
@@ -7589,7 +7433,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tree tmp;
tree desc;
stmtblock_t block;
- tree start;
int full;
bool subref_array_target = false;
bool deferred_array_component = false;
@@ -7618,9 +7461,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
expr = expr->value.function.actual->expr;
}
- if (!se->direct_byref)
- se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
@@ -7647,11 +7487,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
substr = info->ref && info->ref->next
&& info->ref->next->type == REF_SUBSTRING;
- subref_array_target = (is_subref_array (expr)
- && (se->direct_byref
- || expr->ts.type == BT_CHARACTER));
+ subref_array_target = is_subref_array (expr);
need_tmp = (gfc_ref_needs_temporary_p (expr->ref)
- && !subref_array_target);
+ && !(subref_array_target
+ && (se->direct_byref
+ || expr->ts.type == BT_CHARACTER)));
if (se->force_tmp)
need_tmp = 1;
@@ -7667,7 +7507,11 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
/* Create a new descriptor if the array doesn't have one. */
full = 0;
}
- else if (info->ref->u.ar.type == AR_FULL || se->descriptor_only)
+ else if (se->descriptor_only)
+ full = 1;
+ else if (subref_array_target)
+ full = 0;
+ else if (info->ref->u.ar.type == AR_FULL)
full = 1;
else if (se->direct_byref)
full = 0;
@@ -7681,29 +7525,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (full && !transposed_dims (ss))
{
if (se->direct_byref && !se->byref_noassign)
- {
- struct lang_type *lhs_ls
- = TYPE_LANG_SPECIFIC (TREE_TYPE (se->expr)),
- *rhs_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (desc));
- /* When only the array_kind differs, do a view_convert. */
- tmp = lhs_ls && rhs_ls && lhs_ls->rank == rhs_ls->rank
- && lhs_ls->akind != rhs_ls->akind
- ? build1 (VIEW_CONVERT_EXPR, TREE_TYPE (se->expr), desc)
- : desc;
- /* Copy the descriptor for pointer assignments. */
- gfc_add_modify (&se->pre, se->expr, tmp);
-
- /* Add any offsets from subreferences. */
- gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
- subref_array_target, expr);
-
- /* ....and set the span field. */
- if (ss_info->expr->ts.type == BT_CHARACTER)
- tmp = gfc_conv_descriptor_span_get (desc);
- else
- tmp = gfc_get_array_span (desc, expr);
- gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
- }
+ gfc_copy_descriptor (&se->pre, se->expr, desc, expr,
+ subref_array_target);
else if (se->want_pointer)
{
/* We pass full arrays directly. This means that pointers and
@@ -7745,14 +7568,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
else
gcc_assert (se->ss == ss);
- if (!is_pointer_array (se->expr))
- {
- tmp = gfc_get_element_type (TREE_TYPE (se->expr));
- tmp = fold_convert (gfc_array_index_type,
- size_in_bytes (tmp));
- gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
- }
-
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
gfc_conv_expr (se, expr);
@@ -7851,6 +7666,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
: NULL),
loop.dimen);
+ loop.temp_ss->info->expr = expr;
+
se->string_length = loop.temp_ss->info->string_length;
gcc_assert (loop.temp_ss->dimen == loop.dimen);
gfc_add_ss_to_loop (&loop, loop.temp_ss);
@@ -7924,12 +7741,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
int dim, ndim, codim;
tree parm;
tree parmtype;
- tree dtype;
- tree stride;
- tree from;
- tree to;
- tree base;
- tree offset;
ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
@@ -7955,7 +7766,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gcc_assert (n == codim - 1);
evaluate_bound (&loop.pre, info->start, ar->start,
info->descriptor, n + ndim, true,
- ar->as->type == AS_DEFERRED);
+ ar->as->type == AS_DEFERRED, true);
loop.from[n + loop.dimen] = info->start[n + ndim];
}
else
@@ -8008,202 +7819,85 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
else
{
/* Otherwise make a new one. */
- if (expr->ts.type == BT_CHARACTER)
+ if (expr->ts.type == BT_CHARACTER
+ || subref_array_target)
parmtype = gfc_typenode_for_spec (&expr->ts);
else
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
loop.from, loop.to, 0,
- GFC_ARRAY_UNKNOWN, false);
+ GFC_ARRAY_UNKNOWN, false,
+ expr->ts.type);
parm = gfc_create_var (parmtype, "parm");
/* When expression is a class object, then add the class' handle to
the parm_decl. */
- if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
- {
- gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
- gfc_se classse;
-
- /* class_expr can be NULL, when no _class ref is in expr.
- We must not fix this here with a gfc_fix_class_ref (). */
- if (class_expr)
- {
- gfc_init_se (&classse, NULL);
- gfc_conv_expr (&classse, class_expr);
- gfc_free_expr (class_expr);
-
- gcc_assert (classse.pre.head == NULL_TREE
- && classse.post.head == NULL_TREE);
- gfc_allocate_lang_decl (parm);
- GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
- }
- }
- }
-
- if (expr->ts.type == BT_CHARACTER
- && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
- {
- tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
- gfc_add_modify (&loop.pre, elem_len,
- fold_convert (TREE_TYPE (elem_len),
- gfc_get_array_span (desc, expr)));
- }
-
- /* Set the span field. */
- tmp = NULL_TREE;
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- tmp = gfc_conv_descriptor_span_get (desc);
- else
- tmp = gfc_get_array_span (desc, expr);
- if (tmp)
- gfc_conv_descriptor_span_set (&loop.pre, parm, tmp);
-
- /* The following can be somewhat confusing. We have two
- descriptors, a new one and the original array.
- {parm, parmtype, dim} refer to the new one.
- {desc, type, n, loop} refer to the original, which maybe
- a descriptorless array.
- The bounds of the scalarization are the bounds of the section.
- We don't have to worry about numeric overflows when calculating
- the offsets because all elements are within the array data. */
-
- /* Set the dtype. */
- if (se->unlimited_polymorphic)
- dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
- else if (expr->ts.type == BT_ASSUMED)
- {
- tree tmp2 = desc;
- if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
- tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
- if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
- tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
- dtype = gfc_conv_descriptor_dtype_get (tmp2);
- }
- else
- dtype = gfc_get_dtype (parmtype);
- gfc_conv_descriptor_dtype_set (&loop.pre, parm, dtype);
-
- /* The 1st element in the section. */
- base = gfc_index_zero_node;
- if (expr->ts.type == BT_CHARACTER && expr->rank == 0 && codim)
- base = gfc_index_one_node;
-
- /* The offset from the 1st element in the section. */
- offset = gfc_index_zero_node;
-
- for (n = 0; n < ndim; n++)
- {
- stride = gfc_conv_array_stride (desc, n);
-
- /* Work out the 1st element in the section. */
- if (info->ref
- && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
- {
- gcc_assert (info->subscript[n]
- && info->subscript[n]->info->type == GFC_SS_SCALAR);
- start = info->subscript[n]->info->data.scalar.value;
- }
- else
- {
- /* Evaluate and remember the start of the section. */
- start = info->start[n];
- stride = gfc_evaluate_now (stride, &loop.pre);
- }
-
- tmp = gfc_conv_array_lbound (desc, n);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
- start, tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
- tmp, stride);
- base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
- base, tmp);
-
- if (info->ref
- && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
- {
- /* For elemental dimensions, we only need the 1st
- element in the section. */
- continue;
- }
-
- /* Vector subscripts need copying and are handled elsewhere. */
- if (info->ref)
- gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
-
- /* look for the corresponding scalarizer dimension: dim. */
- for (dim = 0; dim < ndim; dim++)
- if (ss->dim[dim] == n)
- break;
-
- /* loop exited early: the DIM being looked for has been found. */
- gcc_assert (dim < ndim);
-
- /* Set the new lower bound. */
- from = loop.from[dim];
- to = loop.to[dim];
-
- gfc_conv_descriptor_lbound_set (&loop.pre, parm,
- gfc_rank_cst[dim], from);
-
- /* Set the new upper bound. */
- gfc_conv_descriptor_ubound_set (&loop.pre, parm,
- gfc_rank_cst[dim], to);
-
- /* Multiply the stride by the section stride to get the
- total stride. */
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- stride, info->stride[n]);
+ if (expr->ts.type == BT_CLASS && expr->expr_type == EXPR_VARIABLE)
+ {
+ gfc_expr *class_expr = gfc_find_and_cut_at_last_class_ref (expr);
+ gfc_se classse;
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (offset), stride, from);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (offset), offset, tmp);
+ /* class_expr can be NULL, when no _class ref is in expr.
+ We must not fix this here with a gfc_fix_class_ref (). */
+ if (class_expr)
+ {
+ gfc_init_se (&classse, NULL);
+ gfc_conv_expr (&classse, class_expr);
+ gfc_free_expr (class_expr);
- /* Store the new stride. */
- gfc_conv_descriptor_stride_set (&loop.pre, parm,
- gfc_rank_cst[dim], stride);
+ gcc_assert (classse.pre.head == NULL_TREE
+ && classse.post.head == NULL_TREE);
+ gfc_allocate_lang_decl (parm);
+ GFC_DECL_SAVED_DESCRIPTOR (parm) = classse.expr;
+ }
+ }
}
- for (n = loop.dimen; n < loop.dimen + codim; n++)
+ if (expr->ts.type == BT_CHARACTER
+ && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
{
- from = loop.from[n];
- to = loop.to[n];
- gfc_conv_descriptor_lbound_set (&loop.pre, parm,
- gfc_rank_cst[n], from);
- if (n < loop.dimen + codim - 1)
- gfc_conv_descriptor_ubound_set (&loop.pre, parm,
- gfc_rank_cst[n], to);
+ tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
+ gfc_add_modify (&loop.pre, elem_len,
+ fold_convert (TREE_TYPE (elem_len),
+ gfc_get_array_span (desc, expr)));
}
- if (se->data_not_needed)
- gfc_conv_descriptor_data_set (&loop.pre, parm,
- gfc_index_zero_node);
- else
- /* Point the data pointer at the 1st element in the section. */
- gfc_get_dataptr_offset (&loop.pre, parm, desc, base,
- subref_array_target, expr);
-
- gfc_conv_descriptor_offset_set (&loop.pre, parm, offset);
-
- if (flag_coarray == GFC_FCOARRAY_LIB && expr->corank)
+ tree elem_len = NULL_TREE;
+ if (subref_array_target)
{
- tmp = INDIRECT_REF_P (desc) ? TREE_OPERAND (desc, 0) : desc;
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ /* In case of subreferences, don't pick element size from the original
+ descriptor. */
+ if (expr->ts.type == BT_CLASS)
{
- tmp = gfc_conv_descriptor_token (tmp);
+ tree class_container = ss->info->class_container;
+ tree vptr = gfc_class_vptr_get (class_container);
+ elem_len = gfc_vptr_size_get (vptr);
}
- else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
- && GFC_DECL_TOKEN (tmp) != NULL_TREE)
- tmp = GFC_DECL_TOKEN (tmp);
- else
+ else if (expr->ts.type == BT_CHARACTER)
{
- tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
+ tree slen = se->string_length;
+ slen = fold_convert_loc (input_location, gfc_array_index_type,
+ slen);
+ tree kind = build_int_cst (gfc_array_index_type,
+ expr->ts.kind);
+ elem_len = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, slen, kind);
+ }
+ else
+ {
+ tree elem_type = gfc_get_element_type (TREE_TYPE (parm));
+ elem_len = TYPE_SIZE_UNIT (elem_type);
}
- gfc_add_modify (&loop.pre, gfc_conv_descriptor_token (parm), tmp);
+ elem_len = fold_convert_loc (input_location, gfc_array_index_type,
+ elem_len);
}
+
+ gfc_set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
+ ss, info, loop.from, loop.to, !se->data_not_needed,
+ subref_array_target, !se->direct_byref, elem_len);
+
desc = parm;
}
@@ -8214,8 +7908,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
{
gfc_allocate_lang_decl (desc);
GFC_DECL_SAVED_DESCRIPTOR (desc) =
- DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
- GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
+ (DECL_P (expr->symtree->n.sym->backend_decl)
+ && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+ ? GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
: expr->symtree->n.sym->backend_decl;
}
else if (expr->expr_type == EXPR_ARRAY && VAR_P (desc)
@@ -8271,13 +7966,7 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
{
if (!dim)
dim = gfc_index_zero_node;
- tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
- tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
-
- size = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- size, gfc_index_one_node);
+ size = gfc_conv_descriptor_extent_get (desc, dim);
/* if (!allocatable && !pointer && assumed rank)
size = (idx == rank && ubound[rank-1] == -1 ? -1 : size;
else
@@ -8338,11 +8027,7 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
cond, tmp);
}
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (desc, idx),
- gfc_conv_descriptor_lbound_get (desc, idx));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ tmp = gfc_conv_descriptor_extent_get (desc, idx);
gfc_add_modify (&cond_block, extent, tmp);
tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
extent, gfc_index_zero_node);
@@ -8401,12 +8086,40 @@ is_pointer (gfc_expr *e)
return sym->attr.pointer || sym->attr.proc_pointer;
}
+
+static bool
+keep_descriptor_lower_bound (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ /* Detect any array references with vector subscripts. */
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
+ && ref->u.ar.type != AR_FULL)
+ {
+ int dim;
+ for (dim = 0; dim < ref->u.ar.dimen; dim++)
+ if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ break;
+ if (dim < ref->u.ar.dimen)
+ break;
+ }
+
+ /* Array references with vector subscripts and non-variable
+ expressions need be converted to a one-based descriptor. */
+ if (ref || e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ return true;
+}
+
+
/* Convert an array for passing as an actual parameter. */
void
gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
- tree *size, tree *lbshift, tree *packed)
+ tree *size, bool maybe_shift, tree *packed)
{
tree ptr;
tree desc;
@@ -8456,9 +8169,21 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
{
- get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
- expr->ts.u.cl->backend_decl = tmp;
- se->string_length = tmp;
+ if (expr->ts.u.cl->length_from_typespec)
+ {
+ gfc_se len_se;
+ gfc_init_se (&len_se, NULL);
+ gfc_conv_expr_val (&len_se, expr->ts.u.cl->length);
+ gfc_add_block_to_block (&se->pre, &len_se.pre);
+ expr->ts.u.cl->backend_decl = len_se.expr;
+ se->string_length = len_se.expr;
+ }
+ else
+ {
+ get_array_ctor_strlen (&se->pre, expr->value.constructor, &tmp);
+ expr->ts.u.cl->backend_decl = tmp;
+ se->string_length = tmp;
+ }
}
/* Is this the result of the enclosing procedure? */
@@ -8643,38 +8368,24 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
stmtblock_t block;
gfc_init_block (&block);
- if (lbshift && *lbshift)
- {
- /* Apply a shift of the lbound when supplied. */
- for (int dim = 0; dim < expr->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
- *lbshift);
- }
+ if (maybe_shift && !keep_descriptor_lower_bound (expr))
+ gfc_conv_shift_descriptor (&block, se->expr, expr->rank);
+
+ bool assumed_rank_fsym;
+ if (fsym
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || (fsym->ts.type != BT_CLASS
+ && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)))
+ assumed_rank_fsym = true;
+ else
+ assumed_rank_fsym = false;
+
tmp = gfc_class_data_get (ctree);
- if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
- && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
- {
- tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
- gfc_conv_descriptor_data_set (&block, arr,
- gfc_conv_descriptor_data_get (
- se->expr));
- gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
- gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_size (se->expr, expr->rank));
- gfc_conv_descriptor_stride_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
- tree tmp2 = gfc_conv_descriptor_dtype_get (se->expr);
- gfc_conv_descriptor_dtype_set (&block, arr, tmp2);
- gfc_conv_descriptor_rank_set (&block, arr, 1);
- gfc_conv_descriptor_span_set (&block, arr,
- gfc_conv_descriptor_span_get (arr));
- gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
- se->expr = arr;
- }
- gfc_class_array_data_assign (&block, tmp, se->expr, true);
+ gfc_copy_sequence_descriptor (block, tmp, se->expr,
+ assumed_rank_fsym);
/* Handle optional. */
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
@@ -8803,50 +8514,19 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
{
tmp = build_fold_indirect_ref_loc (input_location, desc);
- gfc_ss * ss = gfc_walk_expr (expr);
- if (!transposed_dims (ss))
- {
- if (!ctree)
- gfc_conv_descriptor_data_set (&se->pre, tmp, ptr);
- }
- else if (!ctree)
+ if (!ctree)
{
- tree old_field, new_field;
+ gfc_ss * ss = gfc_walk_expr (expr);
- /* The original descriptor has transposed dims so we can't reuse
- it directly; we have to create a new one. */
tree old_desc = tmp;
tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc");
- old_field = gfc_conv_descriptor_dtype_get (old_desc);
- gfc_conv_descriptor_dtype_set (&se->pre, new_desc, old_field);
-
- old_field = gfc_conv_descriptor_offset_get (old_desc);
- gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field);
-
- for (int i = 0; i < expr->rank; i++)
- {
- int idx = get_array_ref_dim_for_loop_dim (ss, i);
- old_field = gfc_conv_descriptor_dimension_get (old_desc, idx);
- gfc_conv_descriptor_dimension_set (&se->pre, new_desc, i,
- old_field);
-
- }
-
- if (flag_coarray == GFC_FCOARRAY_LIB
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (old_desc))
- && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (old_desc))
- == GFC_ARRAY_ALLOCATABLE)
- {
- old_field = gfc_conv_descriptor_token (old_desc);
- new_field = gfc_conv_descriptor_token (new_desc);
- gfc_add_modify (&se->pre, new_field, old_field);
- }
-
- gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr);
+ gfc_copy_descriptor_to_contiguous (&se->pre, old_desc, new_desc,
+ ptr, expr->rank, ss);
se->expr = gfc_build_addr_expr (NULL_TREE, new_desc);
+
+ gfc_free_ss (ss);
}
- gfc_free_ss (ss);
}
if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
@@ -8952,20 +8632,26 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
tree nelems;
tree tmp;
if (rank < 0)
- idx = gfc_conv_descriptor_rank_get (decl);
+ {
+ idx = gfc_conv_descriptor_rank_get (decl);
+ tmp = gfc_conv_descriptor_extent_get (decl, idx);
+ tmp = gfc_evaluate_now (tmp, block);
+
+ nelems = gfc_conv_descriptor_stride_get (decl, idx);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ nelems, tmp);
+ }
else
- idx = gfc_rank_cst[rank - 1];
- nelems = gfc_conv_descriptor_ubound_get (decl, idx);
- tmp = gfc_conv_descriptor_lbound_get (decl, idx);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- nelems, tmp);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
- tmp = gfc_evaluate_now (tmp, block);
+ {
+ tmp = gfc_index_one_node;
+ for (int i = 0; i < rank; i++)
+ {
+ tree extent = gfc_conv_descriptor_extent_get (decl, gfc_rank_cst[i]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, extent);
- nelems = gfc_conv_descriptor_stride_get (decl, idx);
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- nelems, tmp);
+ }
+ }
return gfc_evaluate_now (tmp, block);
}
@@ -9333,6 +9019,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
{
/* Otherwise use the TYPE_DOMAIN information. */
tmp = array_type_nelts_minus_one (decl_type);
+ if (error_operand_p (tmp)
+ && GFC_ARRAY_TYPE_P (decl_type))
+ {
+ tmp = GFC_TYPE_ARRAY_SIZE (decl_type);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ }
tmp = fold_convert (gfc_array_index_type, tmp);
}
@@ -9343,13 +9037,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
/* Build the body of the loop. */
gfc_init_block (&loopbody);
- vref = gfc_build_array_ref (var, index, NULL);
+ vref = gfc_build_array_ref (var, index, true, gfc_index_zero_node);
if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
{
tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_array_data (dest));
- dref = gfc_build_array_ref (tmp, index, NULL);
+ dref = gfc_build_array_ref (tmp, index, true, gfc_index_zero_node);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
COPY_ALLOC_COMP, caf_mode, args,
no_finalization);
@@ -9507,32 +9201,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
ubound = build_int_cst (gfc_array_index_type, 1);
}
- /* Treat strings like arrays. Or the other way around, do not
- * generate an additional array layer for scalar components. */
- if (attr->dimension || c->ts.type == BT_CHARACTER)
- {
- cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
- &ubound, 1,
- GFC_ARRAY_ALLOCATABLE, false);
-
- cdesc = gfc_create_var (cdesc, "cdesc");
- DECL_ARTIFICIAL (cdesc) = 1;
-
- gfc_conv_descriptor_dtype_set (&tmpblock, cdesc,
- gfc_get_dtype_rank_type (1, tmp));
- gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
- gfc_index_zero_node, ubound);
- }
- else
- /* Prevent warning. */
- cdesc = NULL_TREE;
-
if (attr->dimension)
{
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
@@ -9555,13 +9223,24 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
gfc_add_block_to_block (&tmpblock, &se.pre);
}
+ /* Treat strings like arrays. Or the other way around, do not
+ * generate an additional array layer for scalar components. */
if (attr->dimension || c->ts.type == BT_CHARACTER)
- gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+ {
+ cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+ &ubound, 1,
+ GFC_ARRAY_ALLOCATABLE, false,
+ c->ts.type);
+
+ cdesc = gfc_create_var (cdesc, "cdesc");
+ DECL_ARTIFICIAL (cdesc) = 1;
+
+ gfc_set_contiguous_array (&tmpblock, cdesc, ubound, comp);
+ }
else
cdesc = comp;
tree fndecl;
-
fndecl = build_call_expr_loc (input_location,
gfor_fndecl_co_broadcast, 5,
gfc_build_addr_expr (pvoid_type_node,cdesc),
@@ -9664,7 +9343,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
decl, gfc_comp_caf_token (c),
NULL_TREE);
else if (attr->dimension && !attr->proc_pointer)
- caf_token = gfc_conv_descriptor_token (comp);
+ caf_token = gfc_conv_descriptor_token_get (comp);
}
tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE,
@@ -9704,26 +9383,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
&ubound, 1,
- GFC_ARRAY_ALLOCATABLE, false);
+ GFC_ARRAY_ALLOCATABLE, false,
+ c->ts.type);
cdesc = gfc_create_var (cdesc, "cdesc");
DECL_ARTIFICIAL (cdesc) = 1;
- gfc_conv_descriptor_dtype_set (&dealloc_block, cdesc,
- gfc_get_dtype_rank_type (1, tmp));
- gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&dealloc_block, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc,
- gfc_index_zero_node, ubound);
-
if (attr->dimension)
comp = gfc_conv_descriptor_data_get (comp);
- gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp);
+ gfc_set_contiguous_array (&dealloc_block, cdesc, ubound, comp);
/* Now call the deallocator. */
vtab = gfc_find_vtab (&c->ts);
@@ -9873,11 +9542,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
if (c->attr.dimension)
{
/* Set the dtype, because caf_register needs it. */
- tree tmp2 = gfc_get_dtype (TREE_TYPE (comp));
- gfc_conv_descriptor_dtype_set (&fnblock, comp, tmp2);
+ tree dtype_value = gfc_get_dtype (TREE_TYPE (comp));
+ gfc_conv_descriptor_dtype_set (&fnblock, comp, dtype_value);
tmp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- token = gfc_conv_descriptor_token (tmp);
+ token = gfc_conv_descriptor_token_get (tmp);
}
else
{
@@ -10099,7 +9768,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
{
tree dst_tok;
if (c->as)
- dst_tok = gfc_conv_descriptor_token (dcmp);
+ dst_tok = gfc_conv_descriptor_token_get (dcmp);
else
{
dst_tok
@@ -10192,56 +9861,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
if (c->attr.pdt_array)
{
- gfc_se tse;
- int i;
- tree size = gfc_index_one_node;
- tree offset = gfc_index_zero_node;
- tree lower, upper;
- gfc_expr *e;
-
- /* This chunk takes the expressions for 'lower' and 'upper'
- in the arrayspec and substitutes in the expressions for
- the parameters from 'pdt_param_list'. The descriptor
- fields can then be filled from the values so obtained. */
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)));
- for (i = 0; i < c->as->rank; i++)
- {
- gfc_init_se (&tse, NULL);
- e = gfc_copy_expr (c->as->lower[i]);
- gfc_insert_parameter_exprs (e, pdt_param_list);
- gfc_conv_expr_type (&tse, e, gfc_array_index_type);
- gfc_free_expr (e);
- lower = tse.expr;
- gfc_conv_descriptor_lbound_set (&fnblock, comp,
- gfc_rank_cst[i],
- lower);
- e = gfc_copy_expr (c->as->upper[i]);
- gfc_insert_parameter_exprs (e, pdt_param_list);
- gfc_conv_expr_type (&tse, e, gfc_array_index_type);
- gfc_free_expr (e);
- upper = tse.expr;
- gfc_conv_descriptor_ubound_set (&fnblock, comp,
- gfc_rank_cst[i],
- upper);
- gfc_conv_descriptor_stride_set (&fnblock, comp,
- gfc_rank_cst[i],
- size);
- size = gfc_evaluate_now (size, &fnblock);
- offset = fold_build2_loc (input_location,
- MINUS_EXPR,
- gfc_array_index_type,
- offset, size);
- offset = gfc_evaluate_now (offset, &fnblock);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- upper, lower);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp, gfc_index_one_node);
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
- }
- gfc_conv_descriptor_offset_set (&fnblock, comp, offset);
+ tree nelts = gfc_set_pdt_array_descriptor (&fnblock, comp,
+ c->as, pdt_param_list);
if (c->ts.type == BT_CLASS)
{
tmp = gfc_get_vptr_from_expr (comp);
@@ -10252,18 +9873,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
else
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (ctype));
tmp = fold_convert (gfc_array_index_type, tmp);
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
+ tree size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, nelts, tmp);
size = gfc_evaluate_now (size, &fnblock);
tmp = gfc_call_malloc (&fnblock, NULL, size);
gfc_conv_descriptor_data_set (&fnblock, comp, tmp);
- gfc_conv_descriptor_dtype_set (&fnblock, comp,
- gfc_get_dtype (ctype));
if (c->initializer && c->initializer->rank)
{
+ gfc_se tse;
gfc_init_se (&tse, NULL);
- e = gfc_copy_expr (c->initializer);
+ gfc_expr *e = gfc_copy_expr (c->initializer);
gfc_insert_parameter_exprs (e, pdt_param_list);
gfc_conv_expr_descriptor (&tse, e);
gfc_add_block_to_block (&fnblock, &tse.pre);
@@ -10335,12 +9955,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
{
tree cd, t;
if (c->attr.pdt_array)
- {
- tree version = gfc_conv_descriptor_version_get (comp);
- cd = fold_build2_loc (input_location, EQ_EXPR,
- boolean_type_node, version,
- build_int_cst (integer_type_node, 1));
- }
+ cd = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node,
+ gfc_conv_descriptor_version_get (comp),
+ build_int_cst (integer_type_node, 1));
else
cd = gfc_omp_call_is_alloc (tmp);
t = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
@@ -10350,8 +9968,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
gfc_init_block (&tblock);
gfc_add_expr_to_block (&tblock, t);
if (c->attr.pdt_array)
- gfc_conv_descriptor_version_set (&tblock, comp,
- integer_zero_node);
+ gfc_conv_descriptor_version_set (&tblock, comp, integer_zero_node);
tmp = build3_loc (input_location, COND_EXPR, void_type_node,
cd, gfc_finish_block (&tblock),
gfc_call_free (tmp));
@@ -10458,6 +10075,10 @@ tree
gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
int caf_mode)
{
+ if (DECL_P (decl)
+ && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_ALLOC_COMP,
GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
@@ -10609,76 +10230,6 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
}
-/* Returns the value of LBOUND for an expression. This could be broken out
- from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
- called by gfc_alloc_allocatable_for_assignment. */
-static tree
-get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
-{
- tree lbound;
- tree ubound;
- tree stride;
- tree cond, cond1, cond3, cond4;
- tree tmp;
- gfc_ref *ref;
-
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- {
- tmp = gfc_rank_cst[dim];
- lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
- ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
- stride = gfc_conv_descriptor_stride_get (desc, tmp);
- cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- ubound, lbound);
- cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
- cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
- logical_type_node, cond3, cond1);
- cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
- stride, gfc_index_zero_node);
- if (assumed_size)
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- tmp, build_int_cst (gfc_array_index_type,
- expr->rank - 1));
- else
- cond = logical_false_node;
-
- cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond3, cond4);
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, cond, cond1);
-
- return fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, cond,
- lbound, gfc_index_one_node);
- }
-
- if (expr->expr_type == EXPR_FUNCTION)
- {
- /* A conversion function, so use the argument. */
- gcc_assert (expr->value.function.isym
- && expr->value.function.isym->conversion);
- expr = expr->value.function.actual->expr;
- }
-
- if (expr->expr_type == EXPR_VARIABLE)
- {
- tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
- for (ref = expr->ref; ref; ref = ref->next)
- {
- if (ref->type == REF_COMPONENT
- && ref->u.c.component->as
- && ref->next
- && ref->next->u.ar.type == AR_FULL)
- tmp = TREE_TYPE (ref->u.c.component->backend_decl);
- }
- return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
- }
-
- return gfc_index_one_node;
-}
-
-
/* Returns true if an expression represents an lhs that can be reallocated
on assignment. */
@@ -10688,6 +10239,9 @@ gfc_is_reallocatable_lhs (gfc_expr *expr)
gfc_ref * ref;
gfc_symbol *sym;
+ if (!flag_realloc_lhs)
+ return false;
+
if (!expr->ref)
return false;
@@ -10812,6 +10366,51 @@ concat_str_length (gfc_expr* expr)
}
+static void
+update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop)
+{
+ for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain)
+ {
+ if (!s->is_alloc_lhs)
+ continue;
+
+ gcc_assert (s->info->type == GFC_SS_SECTION);
+ gfc_array_info *info = &s->info->data.array;
+ tree desc = info->descriptor;
+
+#define UPDATE_VALUE(field, value) \
+ do \
+ { \
+ if ((field) && VAR_P ((field))) \
+ { \
+ tree val = (value); \
+ gfc_add_modify (block, (field), val); \
+ } \
+ else \
+ (field) = gfc_evaluate_now ((field), block); \
+ } \
+ while (0)
+
+ UPDATE_VALUE (info->offset, gfc_conv_descriptor_offset_get (desc));
+ info->saved_data = info->data;
+ for (int i = 0; i < s->dimen; i++)
+ {
+ int dim = s->dim[i];
+ tree tree_dim = gfc_rank_cst[dim];
+ UPDATE_VALUE (info->start[dim],
+ gfc_conv_descriptor_lbound_get (desc, tree_dim));
+ UPDATE_VALUE (info->end[dim],
+ gfc_conv_descriptor_ubound_get (desc, tree_dim));
+ UPDATE_VALUE (info->spacing[dim],
+ gfc_conv_descriptor_spacing_get (desc, tree_dim));
+ info->delta[dim] = gfc_evaluate_now (info->delta[dim], block);
+ }
+
+#undef UPDATE_VALUE
+ }
+}
+
+
/* Allocate the lhs of an assignment to an allocatable array, otherwise
reallocate it. */
@@ -10823,14 +10422,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
stmtblock_t realloc_block;
stmtblock_t alloc_block;
stmtblock_t fblock;
- stmtblock_t loop_pre_block;
gfc_ref *ref;
gfc_ss *rss;
gfc_ss *lss;
gfc_array_info *linfo;
tree realloc_expr;
tree alloc_expr;
- tree size1;
tree size2;
tree elemsize1;
tree elemsize2;
@@ -10838,20 +10435,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tree cond_null;
tree cond;
tree tmp;
- tree tmp2;
- tree lbound;
- tree ubound;
tree desc;
- tree old_desc;
tree desc2;
- tree offset;
+ tree old_desc;
tree jump_label1;
tree jump_label2;
- tree lbd;
tree class_expr2 = NULL_TREE;
int n;
- int dim;
- gfc_array_spec * as;
bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
&& gfc_caf_attr (expr1, true).codimension);
tree token;
@@ -10973,7 +10563,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tmp = tmpse.expr;
expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
}
- tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+ tmp = fold_convert (gfc_charlen_type_node, tmp);
}
if (expr1->ts.u.cl->backend_decl
@@ -11034,71 +10624,26 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
if (ref->type == REF_COMPONENT)
break;
- if (!expr1->symtree->n.sym->allocated_in_scope && !ref)
- {
- gfc_start_block (&loop_pre_block);
- for (n = 0; n < expr1->rank; n++)
- {
- gfc_conv_descriptor_lbound_set (&loop_pre_block, desc,
- gfc_rank_cst[n],
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&loop_pre_block, desc,
- gfc_rank_cst[n],
- gfc_index_zero_node);
- gfc_conv_descriptor_stride_set (&loop_pre_block, desc,
- gfc_rank_cst[n],
- gfc_index_zero_node);
- }
-
- gfc_conv_descriptor_offset_set (&loop_pre_block, desc,
- gfc_index_zero_node);
-
- tmp = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, array1,
- build_int_cst (TREE_TYPE (array1), 0));
- tmp = build3_v (COND_EXPR, tmp,
- gfc_finish_block (&loop_pre_block),
- build_empty_stmt (input_location));
- gfc_prepend_expr_to_block (&loop->pre, tmp);
-
- expr1->symtree->n.sym->allocated_in_scope = 1;
- }
-
tmp = build3_v (COND_EXPR, cond_null,
build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location));
gfc_add_expr_to_block (&fblock, tmp);
- /* Get arrayspec if expr is a full array. */
- if (expr2 && expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym
- && expr2->value.function.isym->conversion)
- {
- /* For conversion functions, take the arg. */
- gfc_expr *arg = expr2->value.function.actual->expr;
- as = gfc_get_full_arrayspec_from_expr (arg);
- }
- else if (expr2)
- as = gfc_get_full_arrayspec_from_expr (expr2);
- else
- as = NULL;
-
/* If the lhs shape is not the same as the rhs jump to setting the
bounds and doing the reallocation....... */
for (n = 0; n < expr1->rank; n++)
{
/* Check the shape. */
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ tree extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[n]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
loop->to[n], loop->from[n]);
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type,
- tmp, lbound);
+ tmp, gfc_index_one_node);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
- tmp, ubound);
+ tmp, extent);
cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
tmp, gfc_index_zero_node);
@@ -11133,12 +10678,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
size2 = gfc_index_one_node;
for (n = 0; n < expr2->rank; n++)
{
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- loop->to[n], loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp, gfc_index_one_node);
+ tmp = gfc_conv_array_extent_dim (loop->from[n], loop->to[n], NULL);
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
tmp, size2);
@@ -11153,86 +10693,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
else
old_desc = NULL_TREE;
- /* Now modify the lhs descriptor and the associated scalarizer
- variables. F2003 7.4.1.3: "If variable is or becomes an
- unallocated allocatable variable, then it is allocated with each
- deferred type parameter equal to the corresponding type parameters
- of expr , with the shape of expr , and with each lower bound equal
- to the corresponding element of LBOUND(expr)."
- Reuse size1 to keep a dimension-by-dimension track of the
- stride of the new array. */
- size1 = gfc_index_one_node;
- offset = gfc_index_zero_node;
-
- for (n = 0; n < expr2->rank; n++)
- {
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- loop->to[n], loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp, gfc_index_one_node);
-
- lbound = gfc_index_one_node;
- ubound = tmp;
-
- if (as)
- {
- lbd = get_std_lbound (expr2, desc2, n,
- as->type == AS_ASSUMED_SIZE);
- ubound = fold_build2_loc (input_location,
- MINUS_EXPR,
- gfc_array_index_type,
- ubound, lbound);
- ubound = fold_build2_loc (input_location,
- PLUS_EXPR,
- gfc_array_index_type,
- ubound, lbd);
- lbound = lbd;
- }
-
- gfc_conv_descriptor_lbound_set (&fblock, desc,
- gfc_rank_cst[n],
- lbound);
- gfc_conv_descriptor_ubound_set (&fblock, desc,
- gfc_rank_cst[n],
- ubound);
- gfc_conv_descriptor_stride_set (&fblock, desc,
- gfc_rank_cst[n],
- size1);
- lbound = gfc_conv_descriptor_lbound_get (desc,
- gfc_rank_cst[n]);
- tmp2 = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- lbound, size1);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- offset, tmp2);
- size1 = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- tmp, size1);
- }
-
- /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
- the array offset is saved and the info.offset is used for a
- running offset. Use the saved_offset instead. */
- gfc_conv_descriptor_offset_set (&fblock, desc, offset);
- if (linfo->saved_offset
- && VAR_P (linfo->saved_offset))
- gfc_add_modify (&fblock, linfo->saved_offset, offset);
-
- /* Now set the deltas for the lhs. */
- for (n = 0; n < expr1->rank; n++)
- {
- tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
- dim = lss->dim[n];
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, tmp,
- loop->from[dim]);
- if (linfo->delta[dim] && VAR_P (linfo->delta[dim]))
- gfc_add_modify (&fblock, linfo->delta[dim], tmp);
- }
-
/* Take into account _len of unlimited polymorphic entities, so that span
for array descriptors and allocation sizes are computed correctly. */
if (UNLIMITED_POLY (expr2))
@@ -11246,9 +10706,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
fold_convert (gfc_array_index_type, len));
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
-
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
elemsize2, size2);
@@ -11257,68 +10714,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
size2, size_one_node);
size2 = gfc_evaluate_now (size2, &fblock);
- /* For deferred character length, the 'size' field of the dtype might
- have changed so set the dtype. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
- && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- tree type;
- if (expr2->ts.u.cl->backend_decl)
- type = gfc_typenode_for_spec (&expr2->ts);
- else
- type = gfc_typenode_for_spec (&expr1->ts);
-
- tree tmp = gfc_get_dtype_rank_type (expr1->rank,type);
- gfc_conv_descriptor_dtype_set (&fblock, desc, tmp);
- }
- else if (expr1->ts.type == BT_CLASS)
- {
- tree type;
-
- if (expr2->ts.type != BT_CLASS)
- type = gfc_typenode_for_spec (&expr2->ts);
- else
- type = gfc_get_character_type_len (1, elemsize2);
-
- tree tmp = gfc_get_dtype_rank_type (expr2->rank,type);
- gfc_conv_descriptor_dtype_set (&fblock, desc, tmp);
-
- /* Set the _len field as well... */
- if (UNLIMITED_POLY (expr1))
- {
- tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CHARACTER)
- gfc_add_modify (&fblock, tmp,
- fold_convert (TREE_TYPE (tmp),
- TYPE_SIZE_UNIT (type)));
- else if (UNLIMITED_POLY (expr2))
- gfc_add_modify (&fblock, tmp,
- gfc_class_len_get (TREE_OPERAND (desc2, 0)));
- else
- gfc_add_modify (&fblock, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
- }
- /* ...and the vptr. */
- tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
- && TREE_CODE (desc2) == COMPONENT_REF)
- {
- tmp2 = gfc_get_class_from_expr (desc2);
- tmp2 = gfc_class_vptr_get (tmp2);
- }
- else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
- tmp2 = gfc_class_vptr_get (class_expr2);
- else
- {
- tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
- tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
- }
-
- gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
- }
- else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- gfc_conv_descriptor_dtype_set (&fblock, desc,
- gfc_get_dtype (TREE_TYPE (desc)));
+ gfc_set_descriptor_for_assign_realloc (&fblock, loop, expr1, expr2, desc,
+ desc2, elemsize2, class_expr2);
/* Realloc expression. Note that the scalarizer uses desc.data
in the array reference - (*desc.data)[<element>]. */
@@ -11432,8 +10829,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
&& ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
|| coarray))
&& expr1->ts.type != BT_CLASS)
- gfc_conv_descriptor_dtype_set (&alloc_block, desc,
- gfc_get_dtype (TREE_TYPE (desc)));
+ {
+ gfc_conv_descriptor_dtype_set (&alloc_block, desc,
+ gfc_get_dtype (TREE_TYPE (desc)));
+ }
if ((expr1->ts.type == BT_DERIVED)
&& expr1->ts.u.derived->attr.alloc_comp)
@@ -11448,18 +10847,18 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
- /* Make sure that the scalarizer data pointer is updated. */
- if (linfo->data && VAR_P (linfo->data))
- {
- tmp = gfc_conv_descriptor_data_get (desc);
- gfc_add_modify (&fblock, linfo->data, tmp);
- }
-
/* Add the label for same shape lhs and rhs. */
tmp = build1_v (LABEL_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
- return gfc_finish_block (&fblock);
+ tree realloc_code = gfc_finish_block (&fblock);
+
+ stmtblock_t result_block;
+ gfc_init_block (&result_block);
+ gfc_add_expr_to_block (&result_block, realloc_code);
+ update_reallocated_descriptor (&result_block, loop);
+
+ return gfc_finish_block (&result_block);
}
@@ -11497,8 +10896,8 @@ gfc_trans_class_array (gfc_symbol * sym, gfc_wrapped_block * block)
rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
gcc_assert (rank>=0);
etype = gfc_get_element_type (type);
- gfc_conv_descriptor_dtype_set (&init, descriptor,
- gfc_get_dtype_rank_type (rank, etype));
+ tree dtype_value = gfc_get_dtype_rank_type (rank, etype);
+ gfc_conv_descriptor_dtype_set (&init, descriptor, dtype_value);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
input_location = loc;
@@ -11622,34 +11021,20 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
pointers when -fcheck=pointer is specified. */
if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save
&& (sym->attr.allocatable
- || (sym->attr.pointer && (gfc_option.rtcheck & GFC_RTCHECK_POINTER))))
- {
- gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
- if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
- {
- /* Declare the variable static so its array descriptor stays present
- after leaving the scope. It may still be accessed through another
- image. This may happen, for example, with the caf_mpi
- implementation. */
- TREE_STATIC (descriptor) = 1;
- tmp = gfc_conv_descriptor_token (descriptor);
- gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
- }
- }
-
- /* Set initial TKR for pointers and allocatables */
- if (GFC_DESCRIPTOR_TYPE_P (type)
- && (sym->attr.pointer || sym->attr.allocatable))
+ || sym->attr.pointer))
{
- tree etype;
+ /* Declare the variable static so its array descriptor stays present
+ after leaving the scope. It may still be accessed through another
+ image. This may happen, for example, with the caf_mpi
+ implementation. */
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && sym->attr.codimension
+ && sym->attr.allocatable)
+ TREE_STATIC (descriptor) = 1;
- gcc_assert (sym->as && sym->as->rank>=0);
- etype = gfc_get_element_type (type);
- gfc_conv_descriptor_dtype_set (&init, descriptor,
- gfc_get_dtype_rank_type (sym->as->rank,
- etype));
+ gfc_clear_descriptor (&init, sym, descriptor);
}
+
input_location = loc;
gfc_init_block (&cleanup);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index ae46bcf283ff..c5f92b3f3cca 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -21,8 +21,8 @@ along with GCC; see the file COPYING3. If not see
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *, tree, bool,
- gfc_omp_namelist *, bool);
+ tree, gfc_expr *, tree, bool,
+ gfc_omp_namelist *, gfc_typespec *);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
@@ -30,7 +30,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, locus *,
+ bool shift_bounds);
/* Generate function entry code for allocation of compiler allocated array
variables. */
@@ -105,6 +106,7 @@ gfc_ss *gfc_reverse_ss (gfc_ss *);
void gfc_cleanup_loop (gfc_loopinfo *);
/* Associate a SS chain with a loop. */
void gfc_add_ss_to_loop (gfc_loopinfo *, gfc_ss *);
+int gfc_get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim);
/* Mark a SS chain as used in this loop. */
void gfc_mark_ss_chain_used (gfc_ss *, unsigned);
/* Free a gfc_ss chain. */
@@ -120,6 +122,8 @@ gfc_ss *gfc_get_scalar_ss (gfc_ss *, gfc_expr *);
bool gfc_scalar_elemental_arg_saved_as_reference (gfc_ss_info *);
+void gfc_conv_array_lbound_spacing (stmtblock_t *, gfc_ss *, int);
+
/* Calculates the lower bound and stride of array sections. */
void gfc_conv_ss_startstride (gfc_loopinfo *);
@@ -138,8 +142,6 @@ void gfc_conv_loop_setup (gfc_loopinfo *, locus *);
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);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
@@ -154,16 +156,18 @@ tree gfc_get_array_span (tree, gfc_expr *);
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
/* Convert an array for passing as an actual function parameter. */
void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
- const char *, tree *, tree * = nullptr,
+ const char *, tree *, bool = false,
tree * = nullptr);
/* These work with both descriptors and descriptorless arrays. */
tree gfc_conv_array_data (tree);
tree gfc_conv_array_offset (tree);
+tree gfc_conv_array_align (tree);
/* Return either an INT_CST or an expression for that part of the descriptor. */
-tree gfc_conv_array_stride (tree, int);
+tree gfc_conv_array_spacing (tree, int);
tree gfc_conv_array_lbound (tree, int);
tree gfc_conv_array_ubound (tree, int);
+tree gfc_conv_array_extent (tree, int);
/* Set (co)bounds of an array. */
tree gfc_trans_array_bounds (tree, gfc_symbol *, tree *, stmtblock_t *);
@@ -173,9 +177,6 @@ void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *);
void gfc_get_descriptor_offsets_for_info (const_tree, tree *, tree *, tree *, tree *,
tree *, tree *, tree *, tree *);
-/* Shift lower bound of descriptor, updating ubound and offset. */
-void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
-
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index e3e41cc6c12d..8789f7585a9f 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -42,7 +42,6 @@ along with GCC; see the file COPYING3. If not see
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
-#include "trans-descriptor.h"
/* Only for gfc_trans_code. Shouldn't need to include this. */
#include "trans-stmt.h"
#include "trans-descriptor.h"
@@ -54,6 +53,7 @@ along with GCC; see the file COPYING3. If not see
#include "attr-fnspec.h"
#include "tree-iterator.h"
#include "dependency.h"
+#include "trans-descriptor.h"
#define MAX_LABEL_VALUE 99999
@@ -931,7 +931,7 @@ gfc_defer_symbol_init (gfc_symbol * sym)
an existing backend_decl is found. */
bool
-gfc_get_module_backend_decl (gfc_symbol *sym)
+gfc_get_module_backend_decl (gfc_symbol *sym, bool create_type_decl)
{
gfc_gsymbol *gsym;
gfc_symbol *s;
@@ -987,6 +987,9 @@ gfc_get_module_backend_decl (gfc_symbol *sym)
if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl)
{
+ if (!create_type_decl)
+ return false;
+
if (s->attr.flavor == FL_UNION)
s->backend_decl = gfc_get_union_type (s);
else
@@ -1026,6 +1029,65 @@ create_index_var (const char * pfx, int nest)
}
+static tree
+update_type_bounds (tree type, tree lbound[GFC_MAX_DIMENSIONS],
+ tree ubound[GFC_MAX_DIMENSIONS],
+ tree spacing[GFC_MAX_DIMENSIONS], tree root_type, int dim)
+{
+ if (dim > 0)
+ update_type_bounds (type, lbound, ubound, spacing, root_type, dim - 1);
+
+ tree current_lbound = lbound[dim];
+ if (current_lbound != NULL_TREE)
+ {
+ GFC_TYPE_ARRAY_LBOUND (root_type, dim) = current_lbound;
+ if (current_lbound
+ && VAR_P (current_lbound)
+ && DECL_ARTIFICIAL (current_lbound)
+ && DECL_IGNORED_P (current_lbound))
+ {
+ if (DECL_NAME (current_lbound)
+ && strstr (IDENTIFIER_POINTER (DECL_NAME (current_lbound)),
+ "lbound") != 0)
+ DECL_NAMELESS (current_lbound) = 1;
+ }
+ }
+
+ tree current_ubound = ubound[dim];
+ if (current_ubound != NULL_TREE)
+ {
+ GFC_TYPE_ARRAY_UBOUND (root_type, dim) = current_ubound;
+ if (current_ubound
+ && VAR_P (current_ubound)
+ && DECL_ARTIFICIAL (current_ubound)
+ && DECL_IGNORED_P (current_ubound))
+ {
+ if (DECL_NAME (current_ubound)
+ && strstr (IDENTIFIER_POINTER (DECL_NAME (current_ubound)),
+ "ubound") != 0)
+ DECL_NAMELESS (current_ubound) = 1;
+ }
+ }
+
+ tree current_spacing = spacing[dim];
+ if (current_spacing != NULL_TREE)
+ {
+ GFC_TYPE_ARRAY_SPACING (root_type, dim) = current_spacing;
+ if (current_spacing
+ && VAR_P (current_spacing)
+ && DECL_ARTIFICIAL (current_spacing)
+ && DECL_IGNORED_P (current_spacing))
+ {
+ if (DECL_NAME (current_spacing)
+ && strstr (IDENTIFIER_POINTER (DECL_NAME (current_spacing)),
+ "spacing") != 0)
+ DECL_NAMELESS (current_spacing) = 1;
+ }
+ }
+
+ return type;
+}
+
/* Create variables to hold all the non-constant bits of info for a
descriptorless array. Remember these in the lang-specific part of the
type. */
@@ -1033,6 +1095,9 @@ create_index_var (const char * pfx, int nest)
static void
gfc_build_qualified_array (tree decl, gfc_symbol * sym)
{
+ tree lbound[GFC_MAX_DIMENSIONS];
+ tree ubound[GFC_MAX_DIMENSIONS];
+ tree spacing[GFC_MAX_DIMENSIONS];
tree type;
int dim;
int nest;
@@ -1114,24 +1179,51 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
{
if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
{
- GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
- suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim));
+ lbound[dim] = create_index_var ("lbound", nest);
+ suppress_warning (lbound[dim]);
}
+ else
+ lbound[dim] = NULL_TREE;
+
/* Don't try to use the unknown bound for assumed shape arrays. */
if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
&& (as->type != AS_ASSUMED_SIZE
|| dim < GFC_TYPE_ARRAY_RANK (type) - 1))
{
- GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
- suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim));
+ ubound[dim] = create_index_var ("ubound", nest);
+ suppress_warning (ubound[dim]);
}
+ else
+ ubound[dim] = NULL_TREE;
- if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
+ if (GFC_TYPE_ARRAY_SPACING (type, dim) == NULL_TREE)
{
- GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
- suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim));
+ spacing[dim] = create_index_var ("spacing", nest);
+ suppress_warning (spacing[dim]);
}
+ else
+ spacing[dim] = NULL_TREE;
+ }
+
+ if (POINTER_TYPE_P (type))
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type))
+ && TYPE_LANG_SPECIFIC (TREE_TYPE (type))
+ == TYPE_LANG_SPECIFIC (type));
+ type = TREE_TYPE (type);
+ }
+
+ if (as->rank > 0)
+ {
+ tree new_type = update_type_bounds (type, lbound, ubound, spacing, type,
+ as->rank - 1);
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ TREE_TYPE (TREE_TYPE (decl)) = new_type;
+ else
+ TREE_TYPE (decl) = new_type;
+ type = new_type;
}
+
for (dim = GFC_TYPE_ARRAY_RANK (type);
dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
{
@@ -1167,84 +1259,63 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
suppress_warning (GFC_TYPE_ARRAY_SIZE (type));
}
- if (POINTER_TYPE_P (type))
- {
- gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
- gcc_assert (TYPE_LANG_SPECIFIC (type)
- == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
- type = TREE_TYPE (type);
- }
-
- if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
+ if (! COMPLETE_TYPE_P (type)
+ && GFC_TYPE_ARRAY_SIZE (type)
+ && GFC_TYPE_ARRAY_ELEM_LEN (type))
{
tree size, range;
+ tree lower = TYPE_MIN_VALUE (TYPE_DOMAIN (type));
+ if (lower == NULL_TREE)
+ lower = gfc_index_zero_node;
+
size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
- range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
- size);
+ size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ size, lower);
+ range = build_range_type (gfc_array_index_type, lower, size);
TYPE_DOMAIN (type) = range;
- layout_type (type);
- }
-
- if (TYPE_NAME (type) != NULL_TREE && as->rank > 0
- && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
- && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)))
- {
- tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
-
- for (dim = 0; dim < as->rank - 1; dim++)
- {
- gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
- gtype = TREE_TYPE (gtype);
- }
- gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
- if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
- TYPE_NAME (type) = NULL_TREE;
- }
-
- if (TYPE_NAME (type) == NULL_TREE)
- {
- tree gtype = TREE_TYPE (type), rtype, type_decl;
-
- for (dim = as->rank - 1; dim >= 0; dim--)
+ if (GFC_TYPE_PACKED_ARRAY (type))
+ layout_type (type);
+ else
{
- tree lbound, ubound;
- lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
- ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
- rtype = build_range_type (gfc_array_index_type, lbound, ubound);
- gtype = build_array_type (gtype, rtype);
- /* Ensure the bound variables aren't optimized out at -O0.
- For -O1 and above they often will be optimized out, but
- can be tracked by VTA. Also set DECL_NAMELESS, so that
- the artificial lbound.N or ubound.N DECL_NAME doesn't
- end up in debug info. */
- if (lbound
- && VAR_P (lbound)
- && DECL_ARTIFICIAL (lbound)
- && DECL_IGNORED_P (lbound))
+ tree off = gfc_index_zero_node;
+ for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
{
- if (DECL_NAME (lbound)
- && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
- "lbound") != 0)
- DECL_NAMELESS (lbound) = 1;
- DECL_IGNORED_P (lbound) = 0;
- }
- if (ubound
- && VAR_P (ubound)
- && DECL_ARTIFICIAL (ubound)
- && DECL_IGNORED_P (ubound))
- {
- if (DECL_NAME (ubound)
- && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
- "ubound") != 0)
- DECL_NAMELESS (ubound) = 1;
- DECL_IGNORED_P (ubound) = 0;
+ tree lb = GFC_TYPE_ARRAY_LBOUND (type, dim);
+ tree ub = GFC_TYPE_ARRAY_UBOUND (type, dim);
+ tree extent = gfc_conv_array_extent_dim (lb, ub, nullptr);
+ tree extent_m1 = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, extent,
+ gfc_index_one_node);
+ tree spacing = GFC_TYPE_ARRAY_SPACING (type, dim);
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ extent_m1, spacing);
+ tmp = fold_build2_loc (input_location, MAX_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_zero_node);
+ off = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, off, tmp);
}
+ tree elem_len = GFC_TYPE_ARRAY_ELEM_LEN (type);
+ elem_len = fold_convert_loc (input_location, gfc_array_index_type,
+ elem_len);
+ off = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, off, elem_len);
+ tree size_units = fold_build2_loc (input_location, EXACT_DIV_EXPR,
+ gfc_array_index_type,
+ off, elem_len);
+ tree size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size_units,
+ build_int_cst (gfc_array_index_type,
+ BITS_PER_UNIT));
+ size_units = fold_convert_loc (input_location, sizetype, size_units);
+ TYPE_SIZE_UNIT (type) = size_units;
+ size = fold_convert_loc (input_location, sizetype, size);
+ TYPE_SIZE (type) = size;
+ layout_type (type);
}
- TYPE_NAME (type) = type_decl = build_decl (input_location,
- TYPE_DECL, NULL, gtype);
- DECL_ORIGINAL_TYPE (type_decl) = gtype;
}
}
@@ -1315,7 +1386,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
are not repacked. */
if (!flag_repack_arrays || sym->attr.target)
{
- if (as->type == AS_ASSUMED_SIZE)
+ if (as->type == AS_ASSUMED_SIZE && !is_classarray)
packed = PACKED_FULL;
}
else
@@ -1343,8 +1414,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
gfc_typenode_for_spec () returns the array descriptor. */
type = is_classarray ? gfc_get_element_type (type)
: gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, as, packed,
- !sym->attr.target);
+ type = gfc_get_nodesc_array_type (type, as, packed, !sym->attr.target,
+ sym->ts.type);
}
else
{
@@ -2098,7 +2169,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (sym->attr.vtab || def_init)
{
DECL_ARTIFICIAL (decl) = 1;
- if (def_init && sym->value)
+ if (sym->attr.vtab || sym->value)
TREE_READONLY (decl) = 1;
}
@@ -4360,16 +4431,34 @@ gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
}
+
+static bool
+decl_ref_or_const_like_p (tree t)
+{
+ if (TREE_CONSTANT (t) || DECL_P (t))
+ return true;
+
+ if (TREE_CODE (t) == SAVE_EXPR
+ || TREE_CODE (t) == NON_LVALUE_EXPR)
+ return decl_ref_or_const_like_p (TREE_OPERAND (t, 0));
+ else
+ return false;
+}
+
+
static void
-gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
+gfc_trans_vla_one_sizepos (tree *tp, tree root_decl, stmtblock_t *body)
{
tree t = *tp, var, val;
if (t == NULL || t == error_mark_node)
return;
- if (TREE_CONSTANT (t) || DECL_P (t))
+ if (decl_ref_or_const_like_p (t))
return;
+ if (contains_placeholder_p (t))
+ t = substitute_placeholder_in_expr (t, root_decl);
+
if (TREE_CODE (t) == SAVE_EXPR)
{
if (SAVE_EXPR_RESOLVED_P (t))
@@ -4391,7 +4480,7 @@ gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
}
static void
-gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
+gfc_trans_vla_type_sizes_1 (tree type, tree root_decl, stmtblock_t *body)
{
tree t;
@@ -4402,8 +4491,8 @@ gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
if (TREE_CODE (type) == INTEGER_TYPE)
{
- gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
- gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
+ gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), root_decl, body);
+ gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), root_decl, body);
for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
{
@@ -4413,10 +4502,10 @@ gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
}
else if (TREE_CODE (type) == ARRAY_TYPE)
{
- gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
- gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
- gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
- gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
+ gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), root_decl, body);
+ gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), root_decl, body);
+ gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), root_decl, body);
+ gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), root_decl, body);
for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
{
@@ -4439,7 +4528,8 @@ gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
void
gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
{
- tree type = TREE_TYPE (sym->backend_decl);
+ tree root_decl = sym->backend_decl;
+ tree type = TREE_TYPE (root_decl);
if (TREE_CODE (type) == FUNCTION_TYPE
&& (sym->attr.function || sym->attr.result || sym->attr.entry))
@@ -4460,10 +4550,10 @@ gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
while (POINTER_TYPE_P (etype))
etype = TREE_TYPE (etype);
- gfc_trans_vla_type_sizes_1 (etype, body);
+ gfc_trans_vla_type_sizes_1 (etype, root_decl, body);
}
- gfc_trans_vla_type_sizes_1 (type, body);
+ gfc_trans_vla_type_sizes_1 (type, root_decl, body);
}
@@ -4773,16 +4863,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
{
/* Nullify explicit return class arrays on entry. */
- tree type;
tmp = get_proc_result (proc_sym);
- if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- {
- gfc_start_block (&init);
- tmp = gfc_class_data_get (tmp);
- type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
- gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- }
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ gfc_clear_descriptor (&init, proc_sym, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ }
}
@@ -4924,48 +5012,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
}
- if (sym->attr.pointer && sym->attr.dimension
- && sym->attr.save == SAVE_NONE
- && !sym->attr.use_assoc
- && !sym->attr.host_assoc
- && !sym->attr.dummy
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
- {
- gfc_init_block (&tmpblock);
- gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
- build_int_cst (gfc_array_index_type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
- NULL_TREE);
- }
-
if (sym->ts.type == BT_CLASS
&& (sym->attr.save || flag_max_stack_var_size == 0)
&& CLASS_DATA (sym)->attr.allocatable)
{
- tree vptr;
-
- if (UNLIMITED_POLY (sym))
- vptr = null_pointer_node;
- else
- {
- gfc_symbol *vsym;
- vsym = gfc_find_derived_vtab (sym->ts.u.derived);
- vptr = gfc_get_symbol_decl (vsym);
- vptr = gfc_build_addr_expr (NULL, vptr);
- }
-
- if (CLASS_DATA (sym)->attr.dimension
- || (CLASS_DATA (sym)->attr.codimension
- && flag_coarray != GFC_FCOARRAY_LIB))
- {
- tmp = gfc_class_data_get (sym->backend_decl);
- tmp = gfc_build_null_descriptor (TREE_TYPE (tmp));
- }
- else
- tmp = null_pointer_node;
-
DECL_INITIAL (sym->backend_decl)
- = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
+ = gfc_build_default_class_descriptor (TREE_TYPE (sym->backend_decl),
+ sym->ts);
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
else if ((sym->attr.dimension || sym->attr.codimension
@@ -5340,7 +5393,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
continue;
/* 'omp allocate( {purpose: allocator, value: align},
{purpose: init-stmtlist, value: cleanup-stmtlist},
- {purpose: size-var, value: last-size-expr} )
+ {purpose: size-var, value: last-size-expr}}
where init-stmt/cleanup-stmt is the STATEMENT list to find the
try-final block; last-size-expr is to find the location after
which to add the code and 'size-var' is for the proper size, cf.
@@ -7069,7 +7122,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
stmtblock_t block;
gfc_init_block (&block);
tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
- tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
+ tree idx, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
bool do_copy_inout = false;
/* When allocatable + intent out, free the cfi descriptor. */
@@ -7261,107 +7314,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
goto done;
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
- {
- /* gfc->dtype = ... (from declaration, not from cfi). */
- etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
- gfc_conv_descriptor_dtype_set (&block, gfc_desc,
- gfc_get_dtype_rank_type (sym->as->rank,
- etype));
- /* gfc->data = cfi->base_addr. */
- gfc_conv_descriptor_data_set (&block, gfc_desc,
- gfc_get_cfi_desc_base_addr (cfi));
- }
-
- if (sym->ts.type == BT_ASSUMED)
- {
- /* For type(*), take elem_len + dtype.type from the actual argument. */
- gfc_conv_descriptor_elem_len_set (&block, gfc_desc,
- gfc_get_cfi_desc_elem_len (cfi));
- tree cond;
- tree ctype = gfc_get_cfi_desc_type (cfi);
- ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
- ctype, build_int_cst (TREE_TYPE (ctype),
- CFI_type_mask));
- tree type = gfc_conv_descriptor_type_get (gfc_desc);
-
- /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
- /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
- build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_VOID));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- type,
- build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_struct));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_DERIVED));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
- /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
- before (see below, as generated bottom up). */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Character));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_CHARACTER));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
- /* Note: gfc->elem_len = cfi->elem_len/4. */
- /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
- gfc->elem_len == cfi->elem_len, which helps with operations which use
- sizeof() in Fortran and cfi->elem_len in C. */
- tmp = gfc_get_cfi_desc_type (cfi);
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp),
- CFI_type_ucs4_char));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_CHARACTER));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Complex));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
- build_int_cst (TREE_TYPE (type), BT_COMPLEX));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
- ctype else <tmp2> */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Integer));
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Logical));
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
- cond, tmp);
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Real));
- cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
- cond, tmp);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- type, fold_convert (TREE_TYPE (type), ctype));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- gfc_add_expr_to_block (&block, tmp2);
- }
-
if (sym->as->rank < 0)
{
/* Set gfc->dtype.rank, if assumed-rank. */
rank = gfc_get_cfi_desc_rank (cfi);
- gfc_conv_descriptor_rank_set (&block, gfc_desc, rank);
}
else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
/* In that case, the CFI rank and the declared rank can differ. */
@@ -7369,15 +7325,24 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
else
rank = build_int_cst (signed_char_type_node, sym->as->rank);
+ stmtblock_t block2;
+ gfc_init_block (&block2);
+
+ do_copy_inout =
+ (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length
+ && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT))
+ || sym->attr.contiguous;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ gfc_set_gfc_from_cfi (&block, &block2, gfc_desc, cfi, rank, sym,
+ true, do_copy_inout, false);
+
/* With bind(C), the standard requires that both Fortran callers and callees
handle noncontiguous arrays passed to an dummy with 'contiguous' attribute
and with character(len=*) + assumed-size/explicit-size arrays.
cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */
- if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length
- && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT))
- || sym->attr.contiguous)
+ if (do_copy_inout)
{
- do_copy_inout = true;
gcc_assert (!sym->attr.pointer);
stmtblock_t block2;
tree data;
@@ -7538,110 +7503,6 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
goto done;
}
- /* If cfi->data != NULL. */
- stmtblock_t block2;
- gfc_init_block (&block2);
-
- /* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len
- We use gfc instead of cfi on the RHS as this might be a constant. */
- tmp = fold_convert (gfc_array_index_type,
- gfc_conv_descriptor_elem_len_get (gfc_desc));
- if (!do_copy_inout)
- {
- /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len)
- ? cfi->dim[0].sm : gfc->elem_len). */
- tree cond;
- tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
- gfc_array_index_type, tmp2, tmp);
- cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- cond, gfc_index_zero_node);
- tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
- tmp2, tmp);
- }
- gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp);
-
- /* Calculate offset + set lbound, ubound and stride. */
- gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node);
- if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable)
- for (int i = 0; i < sym->as->rank; ++i)
- {
- gfc_se se;
- gfc_init_se (&se, NULL );
- if (sym->as->lower[i])
- {
- gfc_conv_expr (&se, sym->as->lower[i]);
- tmp = se.expr;
- }
- else
- tmp = gfc_index_one_node;
- gfc_add_block_to_block (&block2, &se.pre);
- gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i],
- tmp);
- gfc_add_block_to_block (&block2, &se.post);
- }
-
- /* Loop: for (i = 0; i < rank; ++i). */
- idx = gfc_create_var (TREE_TYPE (rank), "idx");
-
- /* Loop body. */
- stmtblock_t loop_body;
- gfc_init_block (&loop_body);
- /* gfc->dim[i].lbound = ... */
- if (sym->attr.pointer || sym->attr.allocatable)
- {
- tmp = gfc_get_cfi_dim_lbound (cfi, idx);
- gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp);
- }
- else if (sym->as->rank < 0)
- gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx,
- gfc_index_one_node);
-
- /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (gfc_desc, idx),
- gfc_index_one_node);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- gfc_get_cfi_dim_extent (cfi, idx), tmp);
- gfc_conv_descriptor_ubound_set (&loop_body, gfc_desc, idx, tmp);
-
- if (do_copy_inout)
- {
- /* gfc->dim[i].stride
- = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
- tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- idx, build_zero_cst (TREE_TYPE (idx)));
- tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
- idx, build_int_cst (TREE_TYPE (idx), 1));
- tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp);
- tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2),
- tmp2, tmp);
- tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
- gfc_index_one_node, tmp);
- }
- else
- {
- /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
- tmp = gfc_get_cfi_dim_sm (cfi, idx);
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_array_index_type, tmp,
- fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi)));
- }
- gfc_conv_descriptor_stride_set (&loop_body, gfc_desc, idx, tmp);
- /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_stride_get (gfc_desc, idx),
- gfc_conv_descriptor_lbound_get (gfc_desc, idx));
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_offset_get (gfc_desc), tmp);
- gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp);
-
- /* Generate loop. */
- gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
- rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
- gfc_finish_block (&loop_body));
if (sym->attr.allocatable || sym->attr.pointer)
{
tmp = gfc_get_cfi_desc_base_addr (cfi),
@@ -7810,21 +7671,16 @@ done:
idx = gfc_create_var (TREE_TYPE (rank), "idx");
/* Loop body. */
+ stmtblock_t loop_body;
gfc_init_block (&loop_body);
/* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx),
gfc_conv_descriptor_lbound_get (gfc_desc, idx));
/* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (gfc_desc, idx),
- gfc_conv_descriptor_lbound_get (gfc_desc, idx));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp,
- gfc_index_one_node);
+ tmp = gfc_conv_descriptor_extent_get (gfc_desc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
- /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_stride_get (gfc_desc, idx),
- gfc_conv_descriptor_span_get (gfc_desc));
+ /* d->dim[n].sm = gfc->dim[i].spacing */
+ tmp = gfc_conv_descriptor_spacing_get (gfc_desc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
/* Generate loop. */
@@ -7966,6 +7822,7 @@ gfc_generate_function_code (gfc_namespace * ns)
fsym->backend_decl = NULL;
tree type = gfc_sym_type (fsym);
gcc_assert (POINTER_TYPE_P (type));
+ tree desc_type = TREE_TYPE (type);
if (POINTER_TYPE_P (TREE_TYPE (type)))
/* For instance, allocatable scalars. */
type = TREE_TYPE (type);
@@ -7997,6 +7854,31 @@ gfc_generate_function_code (gfc_namespace * ns)
}
fsym->backend_decl = desc_p;
gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
+ if (GFC_DESCRIPTOR_TYPE_P (desc_type)
+ && TYPE_LANG_SPECIFIC (desc_type))
+ {
+ if (GFC_TYPE_ARRAY_ELEM_LEN (desc_type)
+ && TREE_CODE (GFC_TYPE_ARRAY_ELEM_LEN (desc_type)) == SAVE_EXPR)
+ GFC_TYPE_ARRAY_ELEM_LEN (desc_type) =
+ gfc_evaluate_now (GFC_TYPE_ARRAY_ELEM_LEN (desc_type),
+ &init);
+
+ if (GFC_TYPE_ARRAY_OFFSET (desc_type)
+ && TREE_CODE (GFC_TYPE_ARRAY_OFFSET (desc_type)) == SAVE_EXPR)
+ GFC_TYPE_ARRAY_OFFSET (desc_type)
+ = gfc_evaluate_now (GFC_TYPE_ARRAY_OFFSET (desc_type),
+ &init);
+
+
+ if (GFC_TYPE_ARRAY_RANK (desc_type) > 0)
+ for (int i = 0; i < GFC_TYPE_ARRAY_RANK (desc_type); i++)
+ if (GFC_TYPE_ARRAY_SPACING (desc_type, i)
+ && TREE_CODE (GFC_TYPE_ARRAY_SPACING (desc_type, i))
+ == SAVE_EXPR)
+ GFC_TYPE_ARRAY_SPACING (desc_type, i)
+ = gfc_evaluate_now (GFC_TYPE_ARRAY_SPACING (desc_type, i),
+ &init);
+ }
}
/* For OpenMP, ensure that declare variant in INTERFACE is is processed
diff --git a/gcc/fortran/trans-descriptor.cc b/gcc/fortran/trans-descriptor.cc
index a05fc1b4b573..8b472cd41688 100644
--- a/gcc/fortran/trans-descriptor.cc
+++ b/gcc/fortran/trans-descriptor.cc
@@ -1,4 +1,5 @@
-/* Copyright (C) 2002-2025 Free Software Foundation, Inc.
+/* Array descriptor translation routines
+ Copyright (C) 2002-2025 Free Software Foundation, Inc.
This file is part of GCC.
@@ -15,19 +16,28 @@ for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
-
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "fold-const.h"
#include "gfortran.h"
#include "trans.h"
-#include "trans-const.h"
+#include "fold-const.h"
#include "trans-types.h"
+#include "trans-const.h"
+#include "gimplify.h"
+#include "trans-descriptor.h"
+#include "trans-array.h"
+#include "stor-layout.h"
+tree
+gfc_array_dataptr_type (tree desc)
+{
+ return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
+}
+
/* Build expressions to access members of the CFI descriptor. */
#define CFI_FIELD_BASE_ADDR 0
#define CFI_FIELD_ELEM_LEN 1
@@ -97,7 +107,7 @@ static tree
gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
{
tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
- tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true);
+ tmp = gfc_build_array_ref (tmp, idx, true);
tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
gcc_assert (field != NULL_TREE);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
@@ -159,12 +169,13 @@ gfc_get_cfi_dim_sm (tree desc, tree idx)
#define DIMENSION_FIELD 4
#define CAF_TOKEN_FIELD 5
-#define STRIDE_SUBFIELD 0
+#define SPACING_SUBFIELD 0
#define LBOUND_SUBFIELD 1
#define UBOUND_SUBFIELD 2
+
static tree
-gfc_get_descriptor_field (tree desc, unsigned field_idx)
+get_field (tree desc, unsigned field_idx)
{
tree type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
@@ -172,6 +183,14 @@ gfc_get_descriptor_field (tree desc, unsigned field_idx)
tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
gcc_assert (field != NULL_TREE);
+ return field;
+}
+
+static tree
+get_component (tree desc, unsigned field_idx)
+{
+ tree field = get_field (desc, field_idx);
+
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
}
@@ -180,7 +199,7 @@ gfc_get_descriptor_field (tree desc, unsigned field_idx)
static tree
get_descriptor_data (tree desc)
{
- return gfc_get_descriptor_field (desc, DATA_FIELD);
+ return get_component (desc, DATA_FIELD);
}
/* This provides READ-ONLY access to the data field. The field itself
@@ -193,7 +212,10 @@ gfc_conv_descriptor_data_get (tree desc)
gcc_assert (TREE_CODE (type) != REFERENCE_TYPE);
tree field = get_descriptor_data (desc);
- tree target_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ tree target_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ if (gfc_type_contains_placeholder_p (target_type))
+ target_type = gfc_substitute_placeholder_in_type (target_type, desc,
+ nullptr);
tree t = fold_convert (target_type, field);
return non_lvalue_loc (input_location, t);
}
@@ -209,15 +231,18 @@ gfc_conv_descriptor_data_get (tree desc)
void
gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value)
{
- tree field = gfc_get_descriptor_field (desc, DATA_FIELD);
- gfc_add_modify (block, field, fold_convert (TREE_TYPE (field), value));
+ tree field = get_descriptor_data (desc);
+ tree type = TREE_TYPE (field);
+ if (gfc_type_contains_placeholder_p (type))
+ type = gfc_substitute_placeholder_in_type (type, desc, block);
+ gfc_add_modify (block, field, fold_convert (type, value));
}
static tree
get_descriptor_offset (tree desc)
{
- tree field = gfc_get_descriptor_field (desc, OFFSET_FIELD);
+ tree field = get_component (desc, OFFSET_FIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
@@ -229,8 +254,7 @@ gfc_conv_descriptor_offset_get (tree desc)
}
void
-gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
- tree value)
+gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, tree value)
{
tree t = get_descriptor_offset (desc);
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
@@ -240,7 +264,7 @@ gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc,
static tree
get_descriptor_dtype (tree desc)
{
- tree field = gfc_get_descriptor_field (desc, DTYPE_FIELD);
+ tree field = get_component (desc, DTYPE_FIELD);
gcc_assert (TREE_TYPE (field) == get_dtype_type_node ());
return field;
}
@@ -252,18 +276,17 @@ gfc_conv_descriptor_dtype_get (tree desc)
}
void
-gfc_conv_descriptor_dtype_set (stmtblock_t *block, tree desc,
- tree value)
+gfc_conv_descriptor_dtype_set (stmtblock_t *block, tree desc, tree val)
{
tree t = get_descriptor_dtype (desc);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ gfc_add_modify (block, t, val);
}
static tree
-gfc_conv_descriptor_span (tree desc)
+get_descriptor_span (tree desc)
{
- tree field = gfc_get_descriptor_field (desc, SPAN_FIELD);
+ tree field = get_component (desc, SPAN_FIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
@@ -271,18 +294,73 @@ gfc_conv_descriptor_span (tree desc)
tree
gfc_conv_descriptor_span_get (tree desc)
{
- return non_lvalue_loc (input_location, gfc_conv_descriptor_span (desc));
+ return non_lvalue_loc (input_location, get_descriptor_span (desc));
}
-void
-gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc,
- tree value)
+static void
+gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, tree value)
{
- tree t = gfc_conv_descriptor_span (desc);
+ tree t = get_descriptor_span (desc);
gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
}
+static tree
+get_descriptor_dimensions (tree desc)
+{
+ tree field = get_component (desc, DIMENSION_FIELD);
+ gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
+ return field;
+}
+
+static tree
+get_descriptor_dimensions (tree desc, tree type)
+{
+ tree t = get_descriptor_dimensions (desc);
+ return build4_loc (input_location, ARRAY_RANGE_REF, type, t,
+ gfc_index_zero_node, NULL_TREE, NULL_TREE);
+}
+
+static tree
+get_descriptor_dimension (tree desc, tree dim)
+{
+ tree tmp;
+
+ tmp = get_descriptor_dimensions (desc);
+
+ return gfc_build_array_ref (tmp, dim, true);
+}
+
+tree
+gfc_conv_descriptor_dimension_get (tree desc, tree dim)
+{
+ return non_lvalue_loc (input_location, get_descriptor_dimension (desc, dim));
+}
+
+
+tree
+gfc_conv_descriptor_dimensions_get (tree desc)
+{
+ return non_lvalue_loc (input_location, get_descriptor_dimensions (desc));
+}
+
+tree
+gfc_conv_descriptor_dimensions_get (tree desc, tree type)
+{
+ tree t = get_descriptor_dimensions (desc, type);
+ return non_lvalue_loc (input_location, t);
+}
+
+void
+gfc_conv_descriptor_dimensions_set (stmtblock_t *block, tree desc, tree value)
+{
+ location_t loc = input_location;
+ tree t = get_descriptor_dimensions (desc, TREE_TYPE (value));
+ gfc_add_modify_loc (loc, block, t, value);
+}
+
+
static tree
get_descriptor_rank (tree desc)
{
@@ -304,18 +382,23 @@ gfc_conv_descriptor_rank_get (tree desc)
}
void
-gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, tree value)
+gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, tree val)
{
+ location_t loc = input_location;
tree t = get_descriptor_rank (desc);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), val));
}
void
-gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int value)
+gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int val)
{
- gfc_conv_descriptor_rank_set (block, desc, gfc_rank_cst[value]);
+ tree t = get_descriptor_rank (desc);
+ gfc_conv_descriptor_rank_set (block, desc, build_int_cst (TREE_TYPE (t),
+ val));
}
+
static tree
get_descriptor_version (tree desc)
{
@@ -337,16 +420,15 @@ gfc_conv_descriptor_version_get (tree desc)
}
void
-gfc_conv_descriptor_version_set (stmtblock_t *block, tree desc,
- tree value)
+gfc_conv_descriptor_version_set (stmtblock_t *block, tree desc, tree val)
{
+ location_t loc = input_location;
tree t = get_descriptor_version (desc);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), val));
}
-/* Return the element length from the descriptor dtype field. */
-
static tree
get_descriptor_elem_len (tree desc)
{
@@ -362,6 +444,8 @@ get_descriptor_elem_len (tree desc)
dtype, tmp, NULL_TREE);
}
+/* Return the element length from the descriptor dtype field. */
+
tree
gfc_conv_descriptor_elem_len_get (tree desc)
{
@@ -369,102 +453,122 @@ gfc_conv_descriptor_elem_len_get (tree desc)
}
void
-gfc_conv_descriptor_elem_len_set (stmtblock_t *block, tree desc,
- tree value)
+gfc_conv_descriptor_elem_len_set (stmtblock_t *block, tree desc, tree value)
{
+ location_t loc = input_location;
tree t = get_descriptor_elem_len (desc);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), value));
}
+
static tree
-get_descriptor_type (tree desc)
+get_descriptor_attribute (tree desc)
{
tree tmp;
tree dtype;
dtype = get_descriptor_dtype (desc);
- tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
+ tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)),
+ GFC_DTYPE_ATTRIBUTE);
gcc_assert (tmp!= NULL_TREE
- && TREE_TYPE (tmp) == signed_char_type_node);
+ && TREE_TYPE (tmp) == short_integer_type_node);
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
dtype, tmp, NULL_TREE);
}
tree
-gfc_conv_descriptor_type_get (tree desc)
+gfc_conv_descriptor_attribute_get (tree desc)
{
- return non_lvalue_loc (input_location, get_descriptor_type (desc));
+ return non_lvalue_loc (input_location, get_descriptor_attribute (desc));
}
void
-gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, tree value)
-{
- tree t = get_descriptor_type (desc);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
-}
-
-
-tree
-gfc_get_descriptor_dimension (tree desc)
+gfc_conv_descriptor_attribute_set (stmtblock_t *block, tree desc, tree value)
{
- tree field = gfc_get_descriptor_field (desc, DIMENSION_FIELD);
- gcc_assert (TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE
- && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE);
- return field;
+ location_t loc = input_location;
+ tree t = get_descriptor_attribute (desc);
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), value));
}
static tree
-get_descriptor_dimension (tree desc, tree dim)
+get_descriptor_type (tree desc)
{
tree tmp;
+ tree dtype;
- tmp = gfc_get_descriptor_dimension (desc);
-
- return gfc_build_array_ref (tmp, dim, NULL_TREE, true);
+ dtype = get_descriptor_dtype (desc);
+ tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
+ gcc_assert (tmp!= NULL_TREE
+ && TREE_TYPE (tmp) == signed_char_type_node);
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ dtype, tmp, NULL_TREE);
}
tree
-gfc_conv_descriptor_dimension_get (tree desc, tree dim)
+gfc_conv_descriptor_type_get (tree desc)
{
- return non_lvalue_loc (input_location, get_descriptor_dimension (desc, dim));
+ return non_lvalue_loc (input_location, get_descriptor_type (desc));
}
-tree
-gfc_conv_descriptor_dimension_get (tree desc, int dim)
+void
+gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, tree value)
{
- return gfc_conv_descriptor_dimension_get (desc, gfc_rank_cst[dim]);
+ location_t loc = input_location;
+ tree t = get_descriptor_type (desc);
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), value));
}
-void
-gfc_conv_descriptor_dimension_set (stmtblock_t *block, tree desc, tree dim,
- tree value)
+
+static tree
+get_dtype_subfield (tree desc, unsigned subfield)
{
- tree t = get_descriptor_dimension (desc, dim);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ tree dtype = get_field (desc, DTYPE_FIELD);
+ tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), subfield);
+ gcc_assert (field != NULL_TREE);
+ return field;
}
void
-gfc_conv_descriptor_dimension_set (stmtblock_t *block, tree desc, int dim,
- tree value)
+gfc_conv_descriptor_type_set (stmtblock_t *block, tree desc, int value)
{
- gfc_conv_descriptor_dimension_set (block, desc, gfc_rank_cst[dim], value);
+ tree field = get_dtype_subfield (desc, GFC_DTYPE_TYPE);
+ tree val = build_int_cst (TREE_TYPE (field), value);
+ gfc_conv_descriptor_type_set (block, desc, val);
}
-
tree
gfc_conv_descriptor_token (tree desc)
{
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
- tree field = gfc_get_descriptor_field (desc, CAF_TOKEN_FIELD);
+ tree field = get_component (desc, CAF_TOKEN_FIELD);
/* Should be a restricted pointer - except in the finalization wrapper. */
gcc_assert (TREE_TYPE (field) == prvoid_type_node
|| TREE_TYPE (field) == pvoid_type_node);
return field;
}
+tree
+gfc_conv_descriptor_token_get (tree desc)
+{
+ return non_lvalue_loc (input_location, gfc_conv_descriptor_token (desc));
+}
+
+void
+gfc_conv_descriptor_token_set (stmtblock_t *block, tree desc, tree value)
+{
+ location_t loc = input_location;
+ tree t = gfc_conv_descriptor_token (desc);
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), value));
+}
+
+
static tree
-gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
+get_descr_dim_subfield (tree desc, tree dim, unsigned field_idx)
{
tree tmp = get_descriptor_dimension (desc, dim);
tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
@@ -474,16 +578,16 @@ gfc_conv_descriptor_subfield (tree desc, tree dim, unsigned field_idx)
tmp, field, NULL_TREE);
}
-static tree
-get_descriptor_stride (tree desc, tree dim)
+tree
+get_descriptor_spacing (tree desc, tree dim)
{
- tree field = gfc_conv_descriptor_subfield (desc, dim, STRIDE_SUBFIELD);
+ tree field = get_descr_dim_subfield (desc, dim, SPACING_SUBFIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
tree
-gfc_conv_descriptor_stride_get (tree desc, tree dim)
+gfc_conv_descriptor_spacing_get (tree desc, tree dim)
{
tree type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
@@ -494,23 +598,25 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
- return gfc_index_one_node;
+ return gfc_conv_descriptor_span_get (desc);
- return non_lvalue_loc (input_location, get_descriptor_stride (desc, dim));
+ return non_lvalue_loc (input_location, get_descriptor_spacing (desc, dim));
}
void
-gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc,
+gfc_conv_descriptor_spacing_set (stmtblock_t *block, tree desc,
tree dim, tree value)
{
- tree t = get_descriptor_stride (desc, dim);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ location_t loc = input_location;
+ tree t = get_descriptor_spacing (desc, dim);
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), value));
}
-static tree
+tree
get_descriptor_lbound (tree desc, tree dim)
{
- tree field = gfc_conv_descriptor_subfield (desc, dim, LBOUND_SUBFIELD);
+ tree field = get_descr_dim_subfield (desc, dim, LBOUND_SUBFIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
@@ -525,14 +631,16 @@ void
gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc,
tree dim, tree value)
{
+ location_t loc = input_location;
tree t = get_descriptor_lbound (desc, dim);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), value));
}
-static tree
+tree
get_descriptor_ubound (tree desc, tree dim)
{
- tree field = gfc_conv_descriptor_subfield (desc, dim, UBOUND_SUBFIELD);
+ tree field = get_descr_dim_subfield (desc, dim, UBOUND_SUBFIELD);
gcc_assert (TREE_TYPE (field) == gfc_array_index_type);
return field;
}
@@ -547,72 +655,3114 @@ void
gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc,
tree dim, tree value)
{
+ location_t loc = input_location;
tree t = get_descriptor_ubound (desc, dim);
- gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value));
+ gfc_add_modify_loc (loc, block, t,
+ fold_convert_loc (loc, TREE_TYPE (t), value));
}
-/* Build a null array descriptor constructor. */
+/* Calculate the size of a given array dimension from the bounds. This
+ is simply (ubound - lbound + 1) if this expression is positive
+ or 0 if it is negative (pick either one if it is zero). Optionally
+ (if or_expr is present) OR the (expression != 0) condition to it. */
+
+static tree
+conv_array_extent_dim (tree lbound, tree ubound, bool maybe_negative, tree* or_expr)
+{
+ tree res;
+ tree cond;
+
+ /* Calculate (ubound - lbound + 1). */
+ res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ ubound, lbound);
+ res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
+ gfc_index_one_node);
+
+ /* Check whether the size for this dimension is negative. */
+ if (maybe_negative)
+ {
+ cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
+ gfc_index_zero_node);
+ res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+ gfc_index_zero_node, res);
+ }
+
+ /* Build OR expression. */
+ if (maybe_negative && or_expr)
+ *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, *or_expr, cond);
+
+ return res;
+}
+
tree
-gfc_build_null_descriptor (tree type)
+gfc_conv_descriptor_extent_get (tree desc, tree dim)
{
- tree field;
- tree tmp;
+ tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+ return conv_array_extent_dim (lbound, ubound, false, NULL);
+}
+
+tree
+gfc_conv_descriptor_stride_get (tree desc, tree dim)
+{
+ tree type = TREE_TYPE (desc);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
- gcc_assert (DATA_FIELD == 0);
- field = TYPE_FIELDS (type);
+ if (integer_zerop (dim)
+ && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
+ return gfc_index_one_node;
- /* Set a NULL data pointer. */
- tmp = build_constructor_single (type, field, null_pointer_node);
- TREE_CONSTANT (tmp) = 1;
- /* All other fields are ignored. */
+ tree spacing = get_descriptor_spacing (desc, dim);
+ tree len = get_descriptor_elem_len (desc);
+ return fold_build2_loc (input_location, EXACT_DIV_EXPR, gfc_array_index_type,
+ spacing, len);
+}
- return tmp;
+
+static bt
+get_type_info (const bt &type)
+{
+ switch (type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ case BT_COMPLEX:
+ case BT_DERIVED:
+ case BT_CHARACTER:
+ case BT_VOID:
+ case BT_UNSIGNED:
+ return type;
+
+ case BT_CLASS:
+ return BT_DERIVED;
+
+ case BT_PROCEDURE:
+ case BT_ASSUMED:
+ return BT_VOID;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+
+ return BT_UNKNOWN;
}
-/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
+static tree
+get_size_info (gfc_typespec &ts)
+{
+ switch (ts.type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ case BT_COMPLEX:
+ case BT_DERIVED:
+ case BT_UNSIGNED:
+ return size_in_bytes (gfc_typenode_for_spec (&ts));
+
+ case BT_CHARACTER:
+ {
+ tree type = gfc_typenode_for_spec (&ts);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ tree char_type = TREE_TYPE (type);
+ tree len = ts.u.cl->backend_decl;
+ return fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ size_in_bytes (char_type),
+ fold_convert (size_type_node, len));
+ }
+
+ case BT_CLASS:
+ return get_size_info (ts.u.derived->components->ts);
+
+ case BT_PROCEDURE:
+ case BT_VOID:
+ case BT_ASSUMED:
+ default:
+ gcc_unreachable ();
+ }
+
+ return NULL_TREE;
+}
-void
-gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
- tree *dtype_off, tree *span_off,
- tree *dim_off, tree *dim_size,
- tree *stride_suboff, tree *lower_suboff,
- tree *upper_suboff)
+
+enum descr_change_type {
+ UNKNOWN_CHANGE,
+ EXPLICIT_NULLIFICATION,
+ INITIALISATION,
+ DEFAULT_INITIALISATION,
+ NULL_INITIALISATION,
+ SCALAR_VALUE
+};
+
+
+struct descr_change_info {
+ enum descr_change_type type;
+ tree descriptor_type;
+ union
+ {
+ struct
+ {
+ gfc_typespec *ts;
+ }
+ null_init;
+ struct
+ {
+ const symbol_attribute *attr;
+ }
+ default_init;
+ struct
+ {
+ gfc_typespec *ts;
+ tree value;
+ tree caf_token;
+ bool clear_token;
+ bool use_declared_type;
+ }
+ scalar_value;
+ }
+ u;
+};
+
+
+#if 0
+static modify_info *
+get_internal_info (const descr_change_info &info)
{
- tree field;
- tree type;
+ switch (info.type)
+ {
+ case UNKNOWN_CHANGE:
+ return info.u.unknown_info;
- type = TYPE_MAIN_VARIANT (desc_type);
- field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
- *data_off = byte_position (field);
- field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
- *dtype_off = byte_position (field);
- field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
- *span_off = byte_position (field);
- field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
- *dim_off = byte_position (field);
- type = TREE_TYPE (TREE_TYPE (field));
- *dim_size = TYPE_SIZE_UNIT (type);
- field = gfc_advance_chain (TYPE_FIELDS (type), STRIDE_SUBFIELD);
- *stride_suboff = byte_position (field);
- field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
- *lower_suboff = byte_position (field);
- field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
- *upper_suboff = byte_position (field);
+ case EXPLICIT_NULLIFICATION:
+ return info.u.nullification_info;
+
+ case INITIALISATION:
+ return info.u.initialization_info;
+
+ case SCALAR_VALUE:
+ return info.u.scalar_value.info;
+
+ default:
+ gcc_unreachable ();
+ }
}
+#endif
-/* Cleanup those #defines. */
+static tree
+get_descr_data_value (const descr_change_info &info)
+{
+ switch (info.type)
+ {
+ case UNKNOWN_CHANGE:
+ return NULL_TREE;
+
+ case EXPLICIT_NULLIFICATION:
+ case NULL_INITIALISATION:
+ return null_pointer_node;
+
+ case INITIALISATION:
+ return NULL_TREE;
+
+ case DEFAULT_INITIALISATION:
+ if (!info.u.default_init.attr->pointer
+ || (gfc_option.rtcheck & GFC_RTCHECK_POINTER))
+ return null_pointer_node;
+ else
+ return NULL_TREE;
+
+ case SCALAR_VALUE:
+ {
+ tree value = info.u.scalar_value.value;
+ if (POINTER_TYPE_P (TREE_TYPE (value)))
+ return value;
+ else
+ return gfc_build_addr_expr (NULL_TREE, value);
+ }
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+static tree
+get_descr_span (const descr_change_info &info)
+{
+ switch (info.type)
+ {
+ case UNKNOWN_CHANGE:
+ case EXPLICIT_NULLIFICATION:
+ case INITIALISATION:
+ case DEFAULT_INITIALISATION:
+ case NULL_INITIALISATION:
+ return NULL_TREE;
+
+ case SCALAR_VALUE:
+ {
+ tree fields = TYPE_FIELDS (info.descriptor_type);
+ tree span_field = gfc_advance_chain (fields, SPAN_FIELD);
+ return build_zero_cst (TREE_TYPE (span_field));
+ }
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+static tree
+get_descr_caf_token (const descr_change_info &info)
+{
+ switch (info.type)
+ {
+ case UNKNOWN_CHANGE:
+ case EXPLICIT_NULLIFICATION:
+ case INITIALISATION:
+ case DEFAULT_INITIALISATION:
+ case NULL_INITIALISATION:
+ return null_pointer_node;
+
+ case SCALAR_VALUE:
+ {
+ if (info.u.scalar_value.caf_token != NULL_TREE)
+ return info.u.scalar_value.caf_token;
+ else if (info.u.scalar_value.clear_token)
+ return null_pointer_node;
+ else
+ return NULL_TREE;
+ }
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+static tree
+get_elt_type (tree value)
+{
+ tree tmp = value;
+
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = TREE_TYPE (tmp);
+
+ tree etype = TREE_TYPE (tmp);
+
+ /* For arrays, which are not scalar coarrays. */
+ if (TREE_CODE (etype) == ARRAY_TYPE && !TYPE_STRING_FLAG (etype))
+ etype = TREE_TYPE (etype);
+
+ return etype;
+}
+
+
+static tree
+get_descr_element_length (const descr_change_info &change_info,
+ gfc_typespec *ts)
+{
+ if (change_info.type == UNKNOWN_CHANGE
+ || change_info.type == EXPLICIT_NULLIFICATION
+ || (ts
+ && (ts->type == BT_CLASS
+ || (ts->type == BT_CHARACTER && ts->deferred))))
+ return NULL_TREE;
+
+ if (change_info.type == SCALAR_VALUE)
+ {
+ tree value = change_info.u.scalar_value.value;
+ if (!change_info.u.scalar_value.use_declared_type)
+ {
+ if (TREE_CODE (value) == COMPONENT_REF)
+ {
+ tree parent_obj = TREE_OPERAND (value, 0);
+ tree len;
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (parent_obj))
+ && gfc_class_len_get (parent_obj, &len))
+ return len;
+ }
+
+ tree size;
+ tree etype = get_elt_type (value);
+ gfc_get_type_info (etype, nullptr, &size);
+ return size;
+ }
+ }
+
+ return get_size_info (*ts);
+}
+
+
+static tree
+get_descr_type (const struct descr_change_info &change_info,
+ gfc_typespec *type_info)
+{
+ bt n;
+ switch (change_info.type)
+ {
+ case UNKNOWN_CHANGE:
+ case EXPLICIT_NULLIFICATION:
+ n = BT_UNKNOWN;
+ break;
+
+ case INITIALISATION:
+ case DEFAULT_INITIALISATION:
+ case NULL_INITIALISATION:
+ n = get_type_info (type_info->type);
+ break;
+
+ case SCALAR_VALUE:
+ {
+ if (change_info.u.scalar_value.use_declared_type)
+ n = get_type_info (type_info->type);
+ else
+ {
+ tree etype = get_elt_type (change_info.u.scalar_value.value);
+ gfc_get_type_info (etype, &n, nullptr);
+ }
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ tree descriptor_type = change_info.descriptor_type;
+ tree dtype_field = gfc_advance_chain (TYPE_FIELDS (descriptor_type),
+ DTYPE_FIELD);
+ tree dtype_type = TREE_TYPE (dtype_field);
+ tree type_info_field = gfc_advance_chain (TYPE_FIELDS (dtype_type),
+ GFC_DTYPE_TYPE);
+ return build_int_cst (TREE_TYPE (type_info_field), n);
+}
+
+
+static tree
+get_descr_dtype (const descr_change_info &change_info, gfc_typespec *ts,
+ int rank, const symbol_attribute & ATTRIBUTE_UNUSED)
+{
+ if (change_info.type == UNKNOWN_CHANGE
+ || change_info.type == EXPLICIT_NULLIFICATION)
+ return NULL_TREE;
+
+ vec<constructor_elt, va_gc> *v = nullptr;
+
+ tree type = get_dtype_type_node ();
+
+ tree fields = TYPE_FIELDS (type);
+
+ gfc_typespec *type_info;
+ switch (change_info.type)
+ {
+ case INITIALISATION:
+ case DEFAULT_INITIALISATION:
+ type_info = ts;
+ break;
+
+ case NULL_INITIALISATION:
+ type_info = change_info.u.null_init.ts;
+ break;
+
+ case SCALAR_VALUE:
+ type_info = change_info.u.scalar_value.ts;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ if (type_info == nullptr)
+ type_info = ts;
+
+ tree elem_len_val = get_descr_element_length (change_info, type_info);
+ if (elem_len_val != NULL_TREE)
+ {
+ tree elem_len_field = gfc_advance_chain (fields, GFC_DTYPE_ELEM_LEN);
+ elem_len_val = fold_convert (TREE_TYPE (elem_len_field), elem_len_val);
+ CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
+ }
+
+ tree version_field = gfc_advance_chain (fields, GFC_DTYPE_VERSION);
+ tree version_val = build_int_cst (TREE_TYPE (version_field), 0);
+ CONSTRUCTOR_APPEND_ELT (v, version_field, version_val);
+
+ if (rank != -1)
+ {
+ tree rank_field = gfc_advance_chain (fields, GFC_DTYPE_RANK);
+ tree rank_val = build_int_cst (TREE_TYPE (rank_field), rank);
+ CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
+ }
+
+ tree type_val = get_descr_type (change_info, type_info);
+ if (type_val != NULL_TREE)
+ {
+ tree type_info_field = gfc_advance_chain (fields, GFC_DTYPE_TYPE);
+ CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_val);
+ }
+
+ return build_constructor (type, v);
+}
+
+
+/* Build a null array descriptor constructor. */
+
+vec<constructor_elt, va_gc> *
+get_descriptor_init (tree type, gfc_typespec *ts, int rank,
+ const symbol_attribute *attr,
+ const descr_change_info &change)
+{
+ vec<constructor_elt, va_gc> *v = nullptr;
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (DATA_FIELD == 0);
+ tree fields = TYPE_FIELDS (type);
+
+ /* Don't init pointers by default. */
+ tree data_value = get_descr_data_value (change);
+ if (data_value != NULL_TREE)
+ {
+ tree data_field = gfc_advance_chain (fields, DATA_FIELD);
+ data_value = fold_convert (TREE_TYPE (data_field), data_value);
+ CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
+ }
+
+ tree dtype_value = get_descr_dtype (change, ts, rank, *attr);
+ if (dtype_value != NULL_TREE)
+ {
+ tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+ CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+ }
+
+ tree span_value = get_descr_span (change);
+ if (span_value != NULL_TREE)
+ {
+ tree span_field = gfc_advance_chain (fields, SPAN_FIELD);
+ tree span_value = build_zero_cst (TREE_TYPE (span_field));
+ CONSTRUCTOR_APPEND_ELT (v, span_field, span_value);
+ }
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
+ {
+ tree caf_token = get_descr_caf_token (change);
+ if (caf_token != NULL_TREE)
+ {
+ /* Declare the variable static so its array descriptor stays present
+ after leaving the scope. It may still be accessed through another
+ image. This may happen, for example, with the caf_mpi
+ implementation. */
+ bool dim_present = GFC_TYPE_ARRAY_RANK (type) > 0
+ || GFC_TYPE_ARRAY_CORANK (type) > 0;
+ tree token_field = gfc_advance_chain (fields,
+ CAF_TOKEN_FIELD
+ - (!dim_present));
+ tree token_value = fold_convert (TREE_TYPE (token_field),
+ caf_token);
+ CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
+ }
+ }
+
+ return v;
+}
+
+
+vec<constructor_elt, va_gc> *
+get_default_array_descriptor_init (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
+{
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (DATA_FIELD == 0);
+
+ struct descr_change_info info;
+ info.type = DEFAULT_INITIALISATION;
+ info.descriptor_type = type;
+
+ return get_descriptor_init (type, &ts, rank, &attr, info);
+}
+
+
+vec<constructor_elt, va_gc> *
+get_null_array_descriptor_init (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
+{
+ struct descr_change_info info;
+ info.type = NULL_INITIALISATION;
+ info.descriptor_type = type;
+ info.u.null_init.ts = &ts;
+
+ return get_descriptor_init (type, &ts, rank, &attr, info);
+}
+
+
+vec<constructor_elt, va_gc> *
+get_null_array_descriptor (tree type, const symbol_attribute &attr)
+{
+ struct descr_change_info info;
+ info.type = EXPLICIT_NULLIFICATION;
+ info.descriptor_type = type;
+
+ return get_descriptor_init (type, nullptr, 0, &attr, info);
+}
+
+
+tree
+gfc_build_default_array_descriptor (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
+{
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ struct descr_change_info info;
+ info.type = DEFAULT_INITIALISATION;
+ info.descriptor_type = type;
+
+ return build_constructor (type,
+ get_descriptor_init (type, &ts, rank, &attr, info));
+}
+
+
+tree
+gfc_build_null_array_descriptor (tree type, gfc_typespec &ts, int rank,
+ const symbol_attribute &attr)
+{
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+
+ return build_constructor (type,
+ get_null_array_descriptor_init (type, ts, rank,
+ attr));
+}
+
+
+tree
+gfc_build_null_array_descriptor (tree type, gfc_typespec &ts,
+ const symbol_attribute &attr)
+{
+ return gfc_build_null_array_descriptor (type, ts, -1, attr);
+}
+
+
+tree
+gfc_build_default_class_descriptor (tree type, gfc_typespec &ts)
+{
+ vec<constructor_elt, va_gc> *v = nullptr;
+
+ tree fields = TYPE_FIELDS (type);
+
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+
+ tree data_field = gfc_advance_chain (fields, CLASS_DATA_FIELD);
+ tree data_type = TREE_TYPE (data_field);
+
+ gcc_assert (ts.type == BT_CLASS);
+ tree data_value;
+ if (ts.u.derived->components->attr.dimension
+ || (ts.u.derived->components->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+ {
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (data_type));
+ gfc_component *data_comp = ts.u.derived->components;
+ data_value = gfc_build_null_array_descriptor (data_type, ts,
+ data_comp->as->rank,
+ data_comp->attr);
+ }
+ else
+ {
+ gcc_assert (POINTER_TYPE_P (data_type));
+ data_value = fold_convert (data_type, null_pointer_node);
+ }
+ CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
+
+ tree vptr_field = gfc_advance_chain (fields, CLASS_VPTR_FIELD);
+
+ tree vptr_value;
+ if (ts.u.derived->attr.unlimited_polymorphic)
+ vptr_value = fold_convert (TREE_TYPE (vptr_field), null_pointer_node);
+ else
+ {
+ gfc_symbol *vsym = gfc_find_derived_vtab (ts.u.derived);
+ tree vsym_decl = gfc_get_symbol_decl (vsym);
+ vptr_value = gfc_build_addr_expr (nullptr, vsym_decl);
+ }
+ CONSTRUCTOR_APPEND_ELT (v, vptr_field, vptr_value);
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+
+ return build_constructor (type, v);
+}
+
+
+void
+gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
+{
+ symbol_attribute attr;
+
+ gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (var_ref);
+ int rank = as != nullptr ? as->rank : 0;
+
+ attr = gfc_expr_attr (var_ref);
+
+ gfc_add_modify (&var.pre, var.expr,
+ gfc_build_null_array_descriptor (TREE_TYPE (var.expr),
+ var_ref->ts,
+ rank, attr));
+}
+
+
+static int
+field_count (tree type)
+{
+ gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+
+ int count = 0;
+ tree field = TYPE_FIELDS (type);
+ while (field != NULL_TREE)
+ {
+ count++;
+ field = DECL_CHAIN (field);
+ }
+
+ return count;
+}
+
+
+#if 0
+static bool
+complete_init_p (tree type, vec<constructor_elt, va_gc> *init_values)
+{
+ return (unsigned) field_count (type) == vec_safe_length (init_values);
+}
+#endif
+
+
+static int
+cmp_wi (const void *x, const void *y)
+{
+ const offset_int *wix = (const offset_int *) x;
+ const offset_int *wiy = (const offset_int *) y;
+
+ return wi::cmpu (*wix, *wiy);
+}
+
+
+static offset_int
+get_offset_bits (tree field)
+{
+ offset_int field_offset = wi::to_offset (DECL_FIELD_OFFSET (field));
+ offset_int field_bit_offset = wi::to_offset (DECL_FIELD_BIT_OFFSET (field));
+ unsigned long offset_align = DECL_OFFSET_ALIGN (field);
+
+ return field_offset * offset_align + field_bit_offset;
+}
+
+
+static bool
+check_cleared_low_bits (const offset_int &val, int bitcount)
+{
+ if (bitcount == 0)
+ return true;
+
+ offset_int mask = wi::mask <offset_int> (bitcount, false);
+ if ((val & mask) != 0)
+ return false;
+
+ return true;
+}
+
+
+static bool
+right_shift_if_clear (const offset_int &val, int bitcount, offset_int *result)
+{
+ if (bitcount == 0)
+ {
+ *result = val;
+ return true;
+ }
+
+ if (!check_cleared_low_bits (val, bitcount))
+ return false;
+
+ *result = val >> bitcount;
+ return true;
+}
+
+
+static bool
+contiguous_init_p (tree type, tree value)
+{
+ gcc_assert (TREE_CODE (value) == CONSTRUCTOR);
+ auto_vec<offset_int> field_offsets;
+ int count = field_count (type);
+ field_offsets.reserve (count);
+
+ tree field = TYPE_FIELDS (type);
+ offset_int expected_offset = 0;
+ while (field != NULL_TREE)
+ {
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ offset_int type_size = wi::to_offset (TYPE_SIZE_UNIT (TREE_TYPE (field)));
+ int align = wi::ctz (type_size);
+ if (!check_cleared_low_bits (field_offset, align))
+ return false;
+
+ if (field_offset != expected_offset)
+ return false;
+
+ expected_offset += type_size;
+ field_offsets.quick_push (field_offset);
+
+ field = DECL_CHAIN (field);
+ }
+
+ auto_vec<offset_int> value_offsets;
+ value_offsets.reserve (count);
+
+ unsigned i;
+ tree field_init;
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field, field_init)
+ {
+ if (TREE_TYPE (field) != TREE_TYPE (field_init))
+ return false;
+
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ value_offsets.quick_push (field_offset);
+ }
+
+ value_offsets.qsort (cmp_wi);
+
+ unsigned idx = 0;
+ offset_int field_off, val_off;
+ while (field_offsets.iterate (idx, &field_off)
+ && value_offsets.iterate (idx, &val_off))
+ {
+ if (val_off != field_off)
+ return false;
+
+ idx++;
+ }
+
+ return true;
+}
+
+
+static bool
+modifiable_p (tree data_ref)
+{
+ switch (TREE_CODE (data_ref))
+ {
+ case INDIRECT_REF:
+ return true;
+
+ case CONST_DECL:
+ return false;
+
+ case VAR_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ return !TREE_CONSTANT (data_ref) && !TREE_READONLY (data_ref);
+
+ case COMPONENT_REF:
+ {
+ tree field_decl = TREE_OPERAND (data_ref, 1);
+
+ if (TREE_CONSTANT (field_decl) || TREE_READONLY (field_decl))
+ return false;
+ }
+
+ /* fallthrough */
+ case ARRAY_REF:
+ case ARRAY_RANGE_REF:
+ case REALPART_EXPR:
+ case IMAGPART_EXPR:
+ case VIEW_CONVERT_EXPR:
+ case NOP_EXPR:
+ {
+ tree parent_ref = TREE_OPERAND (data_ref, 0);
+ return modifiable_p (parent_ref);
+ }
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+typedef enum
+{
+ SINGLE,
+ MULTIPLE
+} init_kind;
+
+typedef union
+{
+ tree single;
+ vec<constructor_elt, va_gc> *multiple;
+} init_values;
+
+static void
+init_struct (stmtblock_t *block, tree data_ref, tree value);
+
+static void
+init_struct (stmtblock_t *block, tree data_ref, init_kind kind,
+ init_values values)
+{
+ tree type = TREE_TYPE (data_ref);
+
+ if (kind == SINGLE)
+ {
+ tree value = values.single;
+ if (TREE_STATIC (data_ref)
+ || !modifiable_p (data_ref))
+ DECL_INITIAL (data_ref) = value;
+ else if (TREE_CODE (value) == CONSTRUCTOR
+ && !(TREE_CONSTANT (value)
+ && contiguous_init_p (type, value)))
+ {
+ unsigned i;
+ tree field, field_init;
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field, field_init)
+ {
+ tree ref = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field),
+ unshare_expr (data_ref),
+ field, NULL_TREE);
+ init_struct (block, ref, field_init);
+ }
+ }
+ else
+ gfc_add_modify (block, data_ref, value);
+ }
+ else if (TREE_STATIC (data_ref))
+ return init_struct (block, data_ref,
+ build_constructor (type, values.multiple));
+ else
+ {
+ gcc_assert (TREE_CODE (type) == RECORD_TYPE);
+
+ unsigned i;
+ constructor_elt *ce;
+ FOR_EACH_VEC_ELT (*values.multiple, i, ce)
+ {
+ tree field_decl = ce->index;
+ tree ref = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field_decl),
+ unshare_expr (data_ref),
+ field_decl, NULL_TREE);
+ init_struct (block, ref, ce->value);
+ }
+ }
+}
+
+
+static void
+init_struct (stmtblock_t *block, tree data_ref, tree value)
+{
+ init_values wrapped_values;
+ wrapped_values.single = value;
+
+ return init_struct (block, data_ref, SINGLE, wrapped_values);
+}
+
+
+static void
+init_struct (stmtblock_t *block, tree data_ref,
+ vec<constructor_elt, va_gc> *values)
+{
+ init_values wrapped_values;
+ wrapped_values.multiple = values;
+
+ return init_struct (block, data_ref, MULTIPLE, wrapped_values);
+}
+
+
+#if 0
+static void
+set_from_constructor_elts (stmtblock_t *block, tree data_ref,
+ vec<constructor_elt, va_gc> *constructor_values)
+{
+ unsigned i;
+ constructor_elt *ce;
+ FOR_EACH_VEC_ELT (*constructor_values, i, ce)
+ {
+ tree field_decl = ce->index;
+ tree ref = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field_decl), data_ref,
+ field_decl, NULL_TREE);
+ gfc_add_modify (block, ref, ce->value);
+ }
+}
+#endif
+
+
+void
+gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree descriptor)
+{
+ symbol_attribute attr;
+
+ gfc_array_spec *as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as
+ : sym->as;
+ int rank = as != nullptr ? as->rank : 0;
+
+ attr = gfc_symbol_attr (sym);
+
+ init_struct (block, descriptor,
+ get_null_array_descriptor_init (TREE_TYPE (descriptor),
+ sym->ts, rank, attr));
+}
+
+
+void
+gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *expr, tree descriptor)
+{
+ symbol_attribute attr;
+
+ attr = gfc_expr_attr (expr);
+
+ init_struct (block, descriptor,
+ get_null_array_descriptor (TREE_TYPE (descriptor), attr));
+}
+
+
+void
+gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym,
+ gfc_expr *expr, tree descriptor)
+{
+ symbol_attribute attr;
+
+ gfc_array_spec *as = sym->ts.type == BT_CLASS
+ ? CLASS_DATA (sym)->as
+ : sym->as;
+ int rank = as == nullptr
+ ? 0
+ : as->type == AS_ASSUMED_RANK
+ ? expr->rank
+ : as->rank;
+
+ attr = gfc_symbol_attr (sym);
+
+ init_struct (block, descriptor,
+ get_null_array_descriptor_init (TREE_TYPE (descriptor),
+ expr->ts, rank, attr));
+}
+
+
+void
+gfc_set_scalar_null_descriptor (stmtblock_t *block, tree descriptor,
+ gfc_symbol *sym, gfc_expr *expr, tree value)
+{
+ symbol_attribute attr;
+
+ attr = gfc_symbol_attr (sym);
+
+ struct descr_change_info info;
+ info.type = SCALAR_VALUE;
+ info.descriptor_type = TREE_TYPE (descriptor);
+ info.u.scalar_value.ts = &expr->ts;
+ info.u.scalar_value.value = value;
+ info.u.scalar_value.caf_token = value;
+ info.u.scalar_value.clear_token = true;
+ info.u.scalar_value.use_declared_type = true;
+
+ init_struct (block, descriptor,
+ get_descriptor_init (TREE_TYPE (descriptor), &sym->ts, 0,
+ &attr, info));
+}
+
+
+void
+gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ symbol_attribute *attr, tree caf_token)
+{
+ struct descr_change_info info;
+ info.type = SCALAR_VALUE;
+ info.descriptor_type = TREE_TYPE (desc);
+ info.u.scalar_value.ts = nullptr;
+ info.u.scalar_value.value = scalar;
+ info.u.scalar_value.caf_token = caf_token;
+ info.u.scalar_value.clear_token = false;
+ info.u.scalar_value.use_declared_type = false;
+
+ init_struct (block, desc,
+ get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr, info));
+}
+
+
+/* Build a null array descriptor constructor. */
+
+tree
+gfc_build_null_descriptor (tree type)
+{
+ tree field;
+ tree tmp;
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (DATA_FIELD == 0);
+ field = TYPE_FIELDS (type);
+
+ /* Set a NULL data pointer. */
+ tmp = build_constructor_single (type, field, null_pointer_node);
+ TREE_CONSTANT (tmp) = 1;
+ /* All other fields are ignored. */
+
+ return tmp;
+}
+
+
+static void
+set_bounds_update_offset (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree spacing, tree lbound_diff,
+ tree *offset, tree *next_spacing, bool spacing_unchanged)
+{
+ /* Stabilize values in case the expressions depend on the existing bounds. */
+ lbound = fold_convert (gfc_array_index_type, lbound);
+ lbound = gfc_evaluate_now (lbound, block);
+
+ ubound = fold_convert (gfc_array_index_type, ubound);
+ ubound = gfc_evaluate_now (ubound, block);
+
+ spacing = fold_convert (gfc_array_index_type, spacing);
+ spacing = gfc_evaluate_now (spacing, block);
+
+ lbound_diff = fold_convert (gfc_array_index_type, lbound_diff);
+ lbound_diff = gfc_evaluate_now (lbound_diff, block);
+
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+ if (!spacing_unchanged)
+ gfc_conv_descriptor_spacing_set (block, desc, gfc_rank_cst[dim], spacing);
+
+ if (!offset && !next_spacing)
+ return;
+
+ /* Update offset. */
+ if (!integer_zerop (lbound_diff))
+ {
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound_diff, spacing);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, *offset, tmp);
+ *offset = gfc_evaluate_now (tmp, block);
+ }
+
+ if (!next_spacing)
+ return;
+
+ /* Set sm for next dimension. */
+ tree tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ *next_spacing = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing, tmp);
+}
+
+
+static void
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree spacing, tree *offset,
+ tree *next_sm)
+{
+ set_bounds_update_offset (block, desc, dim, lbound, ubound, spacing, lbound,
+ offset, next_sm, false);
+}
+
+
+/* Modify a descriptor such that the lbound of a given dimension is the value
+ specified. This also updates ubound and offset accordingly. */
+
+static void
+conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree to_desc, int dim,
+ tree new_lbound, tree *offset, bool zero_based)
+{
+ new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+ new_lbound = gfc_evaluate_now (new_lbound, block);
+
+ tree lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
+ tree ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
+ tree spacing = gfc_conv_descriptor_spacing_get (from_desc, gfc_rank_cst[dim]);
+
+ tree diff;
+ if (zero_based)
+ diff = new_lbound;
+ else
+ {
+ /* Get difference (new - old) by which to shift stuff. */
+ diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ new_lbound, lbound);
+ diff = gfc_evaluate_now (diff, block);
+ }
+
+ /* Shift ubound and offset accordingly. This has to be done before
+ updating the lbound, as they depend on the lbound expression! */
+ tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ ubound, diff);
+
+ set_bounds_update_offset (block, to_desc, dim, new_lbound, tmp1, spacing, diff,
+ offset, nullptr, from_desc == to_desc);
+}
+
+
+class lb_info_base
+{
+public:
+ virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+ virtual bool zero_based_src () const { return false; }
+};
+
+
+class lb_info : public lb_info_base
+{
+public:
+ using lb_info_base::lower_bound;
+ virtual gfc_expr *lower_bound (int dim) const = 0;
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+};
+
+
+tree
+lb_info::lower_bound (stmtblock_t *block, int dim) const
+{
+ gfc_expr *lb_expr = lower_bound(dim);
+
+ if (lb_expr == nullptr)
+ return gfc_index_one_node;
+ else
+ {
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (gfc_array_index_type, "lower_bound");
+ gfc_add_modify (block, lb_var,
+ fold_convert (gfc_array_index_type, lb_se.expr));
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ return lb_var;
+ }
+}
+
+
+
+class unset_lb : public lb_info
+{
+public:
+ using lb_info::lower_bound;
+ virtual gfc_expr *lower_bound (int) const { return nullptr; }
+};
+
+
+class defined_lb : public lb_info
+{
+ int rank;
+ gfc_expr * const * lower_bounds;
+
+public:
+ using lb_info::lower_bound;
+ defined_lb (int arg_rank, gfc_expr * const arg_lower_bounds[GFC_MAX_DIMENSIONS])
+ : rank(arg_rank), lower_bounds(arg_lower_bounds) { }
+ virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
+};
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree src, tree dest, int rank,
+ const lb_info_base &info)
+{
+ if (src != dest)
+ {
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+
+ tmp = gfc_conv_descriptor_span_get (src);
+ gfc_conv_descriptor_span_set (block, dest, tmp);
+ }
+
+ tree offset = gfc_create_var (gfc_array_index_type, "offset");
+ tree init_offset;
+ if (info.zero_based_src ())
+ init_offset = gfc_index_zero_node;
+ else
+ init_offset = gfc_conv_descriptor_offset_get (src);
+ gfc_add_modify (block, offset, init_offset);
+
+ /* Apply a shift of the lbound when supplied. */
+ for (int dim = 0; dim < rank; ++dim)
+ {
+ tree lower_bound = info.lower_bound (block, dim);
+ conv_shift_descriptor_lbound (block, src, dest, dim, lower_bound, &offset,
+ info.zero_based_src ());
+ }
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ const lb_info_base &info)
+{
+ conv_shift_descriptor (block, desc, desc, rank, info);
+}
+
+
+class cond_descr_lb : public lb_info_base
+{
+ tree desc;
+ tree cond;
+public:
+ cond_descr_lb (tree arg_desc, tree arg_cond)
+ : desc (arg_desc), cond (arg_cond) { }
+
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+ virtual bool zero_based_src () const { return true; }
+};
+
+
+tree
+cond_descr_lb::lower_bound (stmtblock_t *block ATTRIBUTE_UNUSED, int dim) const
+{
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+ return lbound;
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+ conv_shift_descriptor (block, desc, rank, unset_lb ());
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ gfc_expr * const lower_bounds[GFC_MAX_DIMENSIONS])
+{
+ conv_shift_descriptor (block, desc, rank, defined_lb (rank, lower_bounds));
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_spec &as)
+{
+ conv_shift_descriptor (block, desc, as.rank, as.lower);
+}
+
+
+static void
+set_type (array_type &type, array_type value)
+{
+ gcc_assert (type == AS_UNKNOWN || type == value);
+ type = value;
+}
+
+
+static void
+array_ref_to_array_spec (const gfc_array_ref &ref, gfc_array_spec &spec)
+{
+ spec.rank = ref.dimen;
+ spec.corank = ref.codimen;
+
+ spec.type = AS_UNKNOWN;
+ spec.cotype = AS_ASSUMED_SIZE;
+
+ for (int dim = 0; dim < spec.rank + spec.corank; dim++)
+ switch (ref.dimen_type[dim])
+ {
+ case DIMEN_ELEMENT:
+ spec.upper[dim] = ref.start[dim];
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ case DIMEN_RANGE:
+ spec.lower[dim] = ref.start[dim];
+ spec.upper[dim] = ref.end[dim];
+ if (spec.upper[dim] == nullptr)
+ set_type (spec.type, AS_DEFERRED);
+ else
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ default:
+ break;
+ }
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_ref &ar)
+{
+ gfc_array_spec as;
+
+ array_ref_to_array_spec (ar, as);
+
+ conv_shift_descriptor (block, desc, as);
+}
+
+
+class dataref_lb : public lb_info_base
+{
+ gfc_array_spec *as;
+ gfc_expr *conv_arg;
+ tree desc;
+
+public:
+ dataref_lb (gfc_array_spec *arg_as, gfc_expr *arg_conv_arg, tree arg_desc)
+ : as(arg_as), conv_arg (arg_conv_arg), desc (arg_desc)
+ {}
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+};
+
+
+tree
+dataref_lb::lower_bound (stmtblock_t *block, int dim) const
+{
+ tree lbound;
+ if (as && as->lower[dim])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[dim]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+ }
+ else if (as && conv_arg)
+ {
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp, gfc_rank_cst[dim]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ else
+ lbound = gfc_index_one_node;
+
+ return fold_convert (gfc_array_index_type, lbound);
+}
+
+
+void
+gfc_conv_shift_descriptor_subarray (stmtblock_t *block, tree desc,
+ gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+ as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+ as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ conv_shift_descriptor (block, desc, value_expr->rank, dataref_lb (as, conv_arg, desc));
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ tree lbound[GFC_MAX_DIMENSIONS],
+ tree ubound[GFC_MAX_DIMENSIONS])
+{
+ tree size = gfc_index_one_node;
+ tree offset = gfc_index_zero_node;
+ for (int n = 0; n < rank; n++)
+ {
+ tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (block,
+ desc,
+ gfc_rank_cst[n],
+ tmp);
+ gfc_conv_descriptor_lbound_set (block,
+ desc,
+ gfc_rank_cst[n],
+ gfc_index_one_node);
+ size = gfc_evaluate_now (size, block);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, size);
+ offset = gfc_evaluate_now (offset, block);
+ tmp = gfc_conv_array_extent_dim (lbound[n], ubound[n], nullptr);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ }
+
+ gfc_conv_descriptor_offset_set (block, desc,
+ offset);
+}
+
+
+
+
+int
+gfc_descriptor_rank (tree descriptor)
+{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+ return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+ tree dim = gfc_conv_descriptor_dimensions_get (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+ return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_spec &as)
+{
+ int dest_rank = gfc_descriptor_rank (dest);
+
+ /* Set dtype. */
+ tree tmp = gfc_get_dtype (TREE_TYPE (src));
+ gfc_conv_descriptor_dtype_set (block, dest, tmp);
+
+ /* Copy data pointer. */
+ tree data = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, data);
+
+ /* Copy the span. */
+ tree span;
+ if (VAR_P (src)
+ && GFC_DECL_PTR_ARRAY_P (src))
+ span = gfc_conv_descriptor_span_get (src);
+ else
+ {
+ tmp = TREE_TYPE (src);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+ span = fold_convert (gfc_array_index_type, tmp);
+ }
+ gfc_conv_descriptor_span_set (block, dest, span);
+
+ /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero. */
+ tree offset;
+ if (src_rank == -1)
+ offset = gfc_index_zero_node;
+ else
+ {
+ tree offs = gfc_conv_descriptor_offset_get (src);
+ for (int dim = 0; dim < src_rank; ++dim)
+ {
+ tree spacing = gfc_conv_descriptor_spacing_get (src, gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing, lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ offset = offs;
+ }
+ /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly. */
+ tree spacing = gfc_conv_descriptor_spacing_get (src, gfc_rank_cst[0]);
+ int last_dim = dest_rank - 1;
+ for (int dim = 0; dim < dest_rank; ++dim)
+ {
+ gfc_se lower_se;
+ gfc_se upper_se;
+
+ gcc_assert (as.lower[dim] && as.upper[dim]);
+
+ /* Convert declared bounds. */
+ gfc_init_se (&lower_se, NULL);
+ gfc_init_se (&upper_se, NULL);
+ gfc_conv_expr_val (&lower_se, as.lower[dim]);
+ gfc_conv_expr_val (&upper_se, as.upper[dim]);
+
+ gfc_add_block_to_block (block, &lower_se.pre);
+ gfc_add_block_to_block (block, &upper_se.pre);
+
+ set_descriptor_dimension (block, dest, dim, lower_se.expr, upper_se.expr,
+ spacing, &offset,
+ dim < last_dim ? &spacing : nullptr);
+ }
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+}
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_ref &ar)
+{
+ gfc_array_spec as;
+
+ array_ref_to_array_spec (ar, as);
+
+ gfc_conv_remap_descriptor (block, dest, src, src_rank, as);
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, tree zero_cond)
+{
+ conv_shift_descriptor (block, src, dest, rank,
+ cond_descr_lb (dest, zero_cond));
+}
+
+
+void
+gfc_copy_descriptor (stmtblock_t *block, tree dest, tree src,
+ gfc_expr *src_expr, bool subref)
+{
+ struct lang_type *dest_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (dest));
+ struct lang_type *src_ls = TYPE_LANG_SPECIFIC (TREE_TYPE (src));
+
+ /* When only the array_kind differs, do a view_convert. */
+ tree tmp1;
+ if (dest_ls
+ && src_ls
+ && dest_ls->rank == src_ls->rank
+ && dest_ls->akind != src_ls->akind)
+ tmp1 = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dest), src);
+ else
+ tmp1 = src;
+
+ /* Copy the descriptor for pointer assignments. */
+ gfc_add_modify (block, dest, tmp1);
+
+ /* Add any offsets from subreferences. */
+ if (subref)
+ gfc_get_dataptr_offset (block, dest, src, NULL_TREE, subref, src_expr);
+
+ /* ....and set the span field. */
+ tree tmp2;
+ if (src_expr->ts.type == BT_CHARACTER)
+ tmp2 = gfc_conv_descriptor_span_get (src);
+ else
+ tmp2 = gfc_get_array_span (src, src_expr);
+ gfc_conv_descriptor_span_set (block, dest, tmp2);
+}
+
+
+void
+gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc,
+ tree ptr, gfc_expr *shape,
+ locus *where)
+{
+ /* Set the span field. */
+ tree elem_type = gfc_get_element_type (TREE_TYPE (desc));
+ tree elem_len = TYPE_SIZE_UNIT (elem_type);
+ elem_len = fold_convert (gfc_array_index_type, elem_len);
+ gfc_conv_descriptor_span_set (block, desc, elem_len);
+
+ /* Set data value, dtype, and offset. */
+ tree tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ gfc_conv_descriptor_data_set (block, desc, fold_convert (tmp, ptr));
+ gfc_conv_descriptor_dtype_set (block, desc, gfc_get_dtype (TREE_TYPE (desc)));
+
+ /* Start scalarization of the bounds, using the shape argument. */
+
+ gfc_ss *shape_ss = gfc_walk_expr (shape);
+ gcc_assert (shape_ss != gfc_ss_terminator);
+ gfc_se shapese;
+ gfc_init_se (&shapese, NULL);
+
+ gfc_loopinfo loop;
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, shape_ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, where);
+ gfc_mark_ss_chain_used (shape_ss, 1);
+
+ gfc_copy_loopinfo_to_se (&shapese, &loop);
+ shapese.ss = shape_ss;
+
+ tree spacing = gfc_create_var (gfc_array_index_type, "spacing");
+ tree offset = gfc_create_var (gfc_array_index_type, "offset");
+ gfc_add_modify (block, spacing, elem_len);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+
+ /* Loop body. */
+ stmtblock_t body;
+ gfc_start_scalarized_body (&loop, &body);
+
+ tree dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ loop.loopvar[0], loop.from[0]);
+
+ /* Set bounds and spacing. */
+ gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+ gfc_conv_descriptor_spacing_set (&body, desc, dim, spacing);
+
+ gfc_conv_expr (&shapese, shape);
+ gfc_add_block_to_block (&body, &shapese.pre);
+ gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+ gfc_add_block_to_block (&body, &shapese.post);
+
+ /* Calculate offset. */
+ gfc_add_modify (&body, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, spacing));
+ /* Update spacing. */
+ gfc_add_modify (&body, spacing,
+ fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing,
+ fold_convert (gfc_array_index_type,
+ shapese.expr)));
+ /* Finish scalarization loop. */
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (block, &loop.pre);
+ gfc_add_block_to_block (block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ gfc_add_modify (block, offset,
+ fold_build1_loc (input_location, NEGATE_EXPR,
+ gfc_array_index_type, offset));
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+}
+
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+ arrays. */
+
+tree
+gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+ enum gfc_array_kind akind;
+
+ if (attr.pointer)
+ akind = GFC_ARRAY_POINTER_CONT;
+ else if (attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ else
+ akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+ if (POINTER_TYPE_P (TREE_TYPE (scalar)))
+ scalar = TREE_TYPE (scalar);
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+ akind, !(attr.pointer || attr.target),
+ BT_UNKNOWN);
+}
+
+
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = gfc_descriptor_rank (lhs_desc);
+ int rhs_rank = gfc_descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+ desc = rhs_desc;
+ else
+ {
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ tree size_m1 = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, size,
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size_m1);
+ tree spacing0 =
+ gfc_conv_descriptor_spacing_get (rhs_desc, gfc_index_zero_node);
+ size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ size, spacing0);
+ gfc_conv_descriptor_spacing_set ( &block, arr, gfc_index_zero_node, spacing0);
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_spacing_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_conv_descriptor_dtype_set (&block, arr,
+ gfc_conv_descriptor_dtype_get (rhs_desc));
+ tree rank_value = build_int_cst (signed_char_type_node, lhs_rank);
+ gfc_conv_descriptor_rank_set (&block, arr, rank_value);
+ gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+ desc = arr;
+ }
+
+ gfc_class_array_data_assign (&block, lhs_desc, desc, true);
+}
+
+
+void
+gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
+ stmtblock_t *conditional_block, tree gfc, tree cfi,
+ tree rank, gfc_symbol *gfc_sym,
+ bool init_static, bool contiguous_gfc, bool contiguous_cfi)
+{
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (unconditional_block, gfc, tmp);
+
+ if (init_static)
+ {
+ /* gfc->dtype = ... (from declaration, not from cfi). */
+ tree etype = gfc_get_element_type (TREE_TYPE (gfc));
+ tree dtype = gfc_get_dtype_rank_type (gfc_sym->as->rank, etype);
+ gfc_conv_descriptor_dtype_set (unconditional_block, gfc, dtype);
+
+ if (gfc_sym->as->type == AS_ASSUMED_RANK)
+ gfc_conv_descriptor_rank_set (unconditional_block, gfc, rank);
+ }
+
+ if (gfc_sym && gfc_sym->ts.type == BT_ASSUMED)
+ {
+ /* For type(*), take elem_len + dtype.type from the actual argument. */
+ tree elem_len_val = gfc_get_cfi_desc_elem_len (cfi);
+ gfc_conv_descriptor_elem_len_set (unconditional_block, gfc, elem_len_val);
+
+ tree cond;
+ tree ctype = gfc_get_cfi_desc_type (cfi);
+ ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
+ ctype, build_int_cst (TREE_TYPE (ctype),
+ CFI_type_mask));
+
+ /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
+ /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
+
+ stmtblock_t set_void;
+ gfc_init_block (&set_void);
+ gfc_conv_descriptor_type_set (&set_void, gfc, BT_VOID);
+
+ stmtblock_t set_unknown;
+ gfc_init_block (&set_unknown);
+ gfc_conv_descriptor_type_set (&set_unknown, gfc, BT_UNKNOWN);
+
+ tree tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&set_void),
+ gfc_finish_block (&set_unknown));
+
+ /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_struct));
+ stmtblock_t set_derived;
+ gfc_init_block (&set_derived);
+ gfc_conv_descriptor_type_set (&set_derived, gfc, BT_DERIVED);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&set_derived), tmp2);
+
+ /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
+ /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
+ before (see below, as generated bottom up). */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Character));
+ stmtblock_t set_character;
+ gfc_init_block (&set_character);
+ gfc_conv_descriptor_type_set (&set_character, gfc, BT_CHARACTER);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&set_character), tmp2);
+
+ /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
+ /* Note: gfc->elem_len = cfi->elem_len/4. */
+ /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
+ gfc->elem_len == cfi->elem_len, which helps with operations which use
+ sizeof() in Fortran and cfi->elem_len in C. */
+ tmp = gfc_get_cfi_desc_type (cfi);
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp),
+ CFI_type_ucs4_char));
+ gfc_init_block (&set_character);
+ gfc_conv_descriptor_type_set (&set_character, gfc, BT_CHARACTER);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&set_character), tmp2);
+
+ /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Complex));
+ stmtblock_t set_complex;
+ gfc_init_block (&set_complex);
+ gfc_conv_descriptor_type_set (&set_complex, gfc, BT_COMPLEX);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&set_complex), tmp2);
+
+ /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
+ ctype else <tmp2> */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Integer));
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Logical));
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond, tmp);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Real));
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond, tmp);
+ stmtblock_t set_ctype;
+ gfc_init_block (&set_ctype);
+ gfc_conv_descriptor_type_set (&set_ctype, gfc, ctype);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ gfc_finish_block (&set_ctype), tmp2);
+ gfc_add_expr_to_block (unconditional_block, tmp2);
+ }
+
+ tree elem_len;
+ if (gfc_sym)
+ /* We use gfc instead of cfi as this might be a constant. */
+ elem_len = fold_convert (gfc_array_index_type,
+ gfc_conv_descriptor_elem_len_get (gfc));
+ else
+ elem_len = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+
+ if (contiguous_cfi || contiguous_gfc)
+ {
+ /* gfc->span = elem_len (either cfi->elem_len or gfc.dtype.elem_len). */
+ tmp = elem_len;
+ }
+ else
+ {
+ /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len). */
+ tree sm0 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ gfc_array_index_type, sm0, elem_len);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+ sm0, elem_len);
+ }
+ gfc_conv_descriptor_span_set (conditional_block, gfc, tmp);
+
+ /* Calculate offset + set lbound, ubound and stride. */
+ gfc_conv_descriptor_offset_set (conditional_block, gfc, gfc_index_zero_node);
+ if (gfc_sym
+ && gfc_sym->as->rank > 0
+ && !gfc_sym->attr.pointer
+ && !gfc_sym->attr.allocatable)
+ for (int i = 0; i < gfc_sym->as->rank; ++i)
+ {
+ gfc_se se;
+ gfc_init_se (&se, NULL );
+ if (gfc_sym->as->lower[i])
+ {
+ gfc_conv_expr (&se, gfc_sym->as->lower[i]);
+ tmp = se.expr;
+ }
+ else
+ tmp = gfc_index_one_node;
+ gfc_add_block_to_block (conditional_block, &se.pre);
+ gfc_conv_descriptor_lbound_set (conditional_block, gfc, gfc_rank_cst[i],
+ tmp);
+ gfc_add_block_to_block (conditional_block, &se.post);
+ }
+
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&loop_body);
+ /* gfc->dim[i].lbound = ... */
+ if (!gfc_sym || (gfc_sym->attr.pointer || gfc_sym->attr.allocatable))
+ {
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+ }
+ else if (gfc_sym && gfc_sym->as->type == AS_ASSUMED_RANK)
+ gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx,
+ gfc_index_one_node);
+
+ /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound_get (gfc, idx),
+ gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+ if (contiguous_gfc)
+ {
+ /* gfc->dim[i].spacing
+ = idx == 0 ? cfi->elem_len / gfc->align : gfc->dim[i-1].spacing * cfi->dim[i-1].extent */
+ tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ idx, build_zero_cst (TREE_TYPE (idx)));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
+ idx, build_int_cst (TREE_TYPE (idx), 1));
+ tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp);
+ tmp = gfc_conv_descriptor_spacing_get (gfc, tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2),
+ tmp2, tmp);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)),
+ tmp);
+ }
+ else
+ {
+ /* gfc->dim[i].spacing = cfi->dim[i].sm */
+ tmp = gfc_get_cfi_dim_sm (cfi, idx);
+ }
+ gfc_conv_descriptor_spacing_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->offset -= gfc->dim[i].spacing * gfc->dim[i].lbound. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_spacing_get (gfc, idx),
+ gfc_conv_descriptor_lbound_get (gfc, idx));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_offset_get (gfc), tmp);
+ gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+ /* Generate loop. */
+ gfc_simple_for_loop (conditional_block, idx, build_zero_cst (TREE_TYPE (idx)),
+ rank, LT_EXPR, build_one_cst (TREE_TYPE (idx)),
+ gfc_finish_block (&loop_body));
+}
+
+
+/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
+
+void
+gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
+ tree *dtype_off, tree *span_off,
+ tree *dim_off, tree *dim_size,
+ tree *spacing_suboff, tree *lower_suboff,
+ tree *upper_suboff)
+{
+ tree field;
+ tree type;
+
+ type = TYPE_MAIN_VARIANT (desc_type);
+ field = gfc_advance_chain (TYPE_FIELDS (type), DATA_FIELD);
+ *data_off = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD);
+ *dtype_off = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD);
+ *span_off = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD);
+ *dim_off = byte_position (field);
+ type = TREE_TYPE (TREE_TYPE (field));
+ *dim_size = TYPE_SIZE_UNIT (type);
+ field = gfc_advance_chain (TYPE_FIELDS (type), SPACING_SUBFIELD);
+ *spacing_suboff = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), LBOUND_SUBFIELD);
+ *lower_suboff = byte_position (field);
+ field = gfc_advance_chain (TYPE_FIELDS (type), UBOUND_SUBFIELD);
+ *upper_suboff = byte_position (field);
+}
+
+
+/* Cleanup those #defines. */
+
+#undef DATA_FIELD
+#undef OFFSET_FIELD
+#undef DTYPE_FIELD
+#undef SPAN_FIELD
+#undef DIMENSION_FIELD
+#undef CAF_TOKEN_FIELD
+#undef STRIDE_SUBFIELD
+#undef LBOUND_SUBFIELD
+#undef UBOUND_SUBFIELD
+
+void
+gfc_set_temporary_descriptor (stmtblock_t *block, tree desc, tree class_src,
+ tree elemsize, tree data_ptr,
+ tree lbound[GFC_MAX_DIMENSIONS],
+ tree ubound[GFC_MAX_DIMENSIONS],
+ tree spacing[GFC_MAX_DIMENSIONS], int rank,
+ bool omit_bounds, bool rank_changer,
+ bool shift_bounds)
+{
+ int n;
+
+ if (!class_src)
+ {
+ /* Fill in the array dtype. */
+ gfc_conv_descriptor_dtype_set (block, desc,
+ gfc_get_dtype (TREE_TYPE (desc)));
+ }
+ else if (rank_changer)
+ {
+ /* For classes, we copy the whole original class descriptor to the
+ temporary one, so we don't need to set the individual dtype fields.
+ Except for the case of rank altering intrinsics for which we
+ generate descriptors of different rank. */
+
+ /* Take the dtype from the class expression. */
+ tree src_data = gfc_class_data_get (class_src);
+ tree dtype = gfc_conv_descriptor_dtype_get (src_data);
+ gfc_conv_descriptor_dtype_set (block, desc, dtype);
+
+ /* These transformational functions change the rank. */
+ gfc_conv_descriptor_rank_set (block, desc, rank);
+ }
+
+ tree offset = gfc_index_zero_node;
+ if (!omit_bounds)
+ {
+ for (n = 0; n < rank; n++)
+ {
+ /* Store the stride and bound components in the descriptor. */
+ tree this_lbound = shift_bounds ? gfc_index_zero_node : lbound[n];
+ set_descriptor_dimension (block, desc, n, this_lbound, ubound[n],
+ spacing[n], &offset, nullptr);
+ if (TREE_CODE (spacing[n]) == INTEGER_CST
+ && GFC_TYPE_ARRAY_SPACING (TREE_TYPE (desc), n) == NULL_TREE)
+ GFC_TYPE_ARRAY_SPACING (TREE_TYPE (desc), n) = spacing[n];
+ }
+ }
+
+ gfc_conv_descriptor_span_set (block, desc, elemsize);
+
+ gfc_conv_descriptor_data_set (block, desc, data_ptr);
+
+ /* The offset is zero because we create temporaries with a zero
+ lower bound. */
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+}
+
+
+/* Calculate the size of a given array dimension from the bounds. This
+ is simply (ubound - lbound + 1) if this expression is positive
+ or 0 if it is negative (pick either one if it is zero). Optionally
+ (if or_expr is present) OR the (expression != 0) condition to it. */
+
+tree
+gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
+{
+ return conv_array_extent_dim (lbound, ubound, true, or_expr);
+}
+
+/* For an array descriptor, get the total number of elements. This is just
+ the product of the extents along from_dim to to_dim. */
+
+static tree
+gfc_conv_descriptor_size_1 (tree desc, int from_dim, int to_dim)
+{
+ tree res;
+ int dim;
+
+ res = gfc_index_one_node;
+
+ for (dim = from_dim; dim < to_dim; ++dim)
+ {
+ tree extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[dim]);
+ res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ res, extent);
+ }
+
+ return res;
+}
+
+
+/* Full size of an array. */
+
+tree
+gfc_conv_descriptor_size (tree desc, int rank)
+{
+ return gfc_conv_descriptor_size_1 (desc, 0, rank);
+}
+
+
+/* Size of a coarray for all dimensions but the last. */
+
+tree
+gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
+{
+ return gfc_conv_descriptor_size_1 (desc, rank, rank + corank - 1);
+}
+
+
+static bool
+placeholder_free_element_type (tree type)
+{
+ if (!GFC_DESCRIPTOR_TYPE_P (type))
+ return true;
+
+ tree data_ptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ return !gfc_type_contains_placeholder_p (data_ptr_type);
+}
+
+
+static tree
+get_descriptor_dtype (tree desc, int * prank)
+{
+ tree type = TREE_TYPE (desc);
+
+ if (placeholder_free_element_type (type))
+ return gfc_get_dtype (type, prank);
+ else
+ {
+ tree data_ptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ data_ptr_type = gfc_substitute_placeholder_in_type (data_ptr_type, desc,
+ nullptr);
+
+ gcc_assert (TREE_CODE (data_ptr_type) == POINTER_TYPE);
+ tree etype = TREE_TYPE (data_ptr_type);
+ if (TREE_CODE (etype) == ARRAY_TYPE && ! TYPE_STRING_FLAG (etype))
+ etype = TREE_TYPE (etype);
+
+ int rank = prank ? *prank : GFC_TYPE_ARRAY_RANK (type);
+ return gfc_get_dtype_rank_type (rank, etype);
+ }
+}
+
+
+void
+gfc_set_descriptor (stmtblock_t *block, tree dest, tree src, gfc_expr *src_expr,
+ int rank, int corank, gfc_ss *ss, gfc_array_info *info,
+ tree lowers[GFC_MAX_DIMENSIONS],
+ tree uppers[GFC_MAX_DIMENSIONS], bool data_needed,
+ bool subref, bool update_spacing_in_type,
+ tree elem_len)
+{
+ int ndim = info->ref ? info->ref->u.ar.dimen : rank;
+
+ /* Set the span field. */
+ tree tmp = NULL_TREE;
+ if (subref)
+ {
+ gcc_assert (elem_len != NULL_TREE);
+ tmp = elem_len;
+ }
+ else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src)))
+ tmp = gfc_conv_descriptor_span_get (src);
+ else
+ tmp = gfc_get_array_span (src, src_expr);
+ if (tmp)
+ gfc_conv_descriptor_span_set (block, dest, tmp);
+
+ /* The following can be somewhat confusing. We have two
+ descriptors, a new one and the original array.
+ {dest, parmtype, dim} refer to the new one.
+ {src, type, n, loop} refer to the original, which maybe
+ a descriptorless array.
+ The bounds of the scalarization are the bounds of the section.
+ We don't have to worry about numeric overflows when calculating
+ the offsets because all elements are within the array data. */
+
+ /* Set the dtype. */
+ tree dtype;
+ if (src_expr->ts.type == BT_ASSUMED)
+ {
+ tree tmp2 = src;
+ if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
+ tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
+ tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+ dtype = gfc_conv_descriptor_dtype_get (tmp2);
+ }
+ else
+ dtype = get_descriptor_dtype (src, &rank);
+ gfc_conv_descriptor_dtype_set (block, dest, dtype);
+
+ if (subref)
+ gfc_conv_descriptor_elem_len_set (block, dest, elem_len);
+
+ /* The 1st element in the section. */
+ tree base = gfc_index_zero_node;
+
+ /* The offset from the 1st element in the section. */
+ tree offset = gfc_index_zero_node;
+
+ for (int n = 0; n < ndim; n++)
+ {
+ tree spacing = gfc_conv_array_spacing (src, n);
+
+ /* Work out the 1st element in the section. */
+ tree start;
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ {
+ gcc_assert (info->subscript[n]
+ && info->subscript[n]->info->type == GFC_SS_SCALAR);
+ start = info->subscript[n]->info->data.scalar.value;
+ }
+ else
+ {
+ /* Evaluate and remember the start of the section. */
+ start = info->start[n];
+ spacing = gfc_evaluate_now (spacing, block);
+ }
+
+ tmp = gfc_conv_array_lbound (src, n);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+ start, tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+ tmp, spacing);
+ base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp),
+ base, tmp);
+
+ if (info->ref
+ && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT)
+ {
+ /* For elemental dimensions, we only need the 1st
+ element in the section. */
+ continue;
+ }
+
+ /* Vector subscripts need copying and are handled elsewhere. */
+ if (info->ref)
+ gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
+
+ /* look for the corresponding scalarizer dimension: dim. */
+ int dim;
+ for (dim = 0; dim < ndim; dim++)
+ if (ss->dim[dim] == n)
+ break;
+
+ /* loop exited early: the DIM being looked for has been found. */
+ gcc_assert (dim < ndim);
+
+ /* Set the new lower bound. */
+ tree from = lowers[dim];
+ tree to = uppers[dim];
+
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[dim], from);
+
+ /* Set the new upper bound. */
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[dim], to);
+
+ /* Multiply the spacing by the section stride to get the
+ total stride. */
+ spacing = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ spacing, info->stride[n]);
+
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (offset), spacing, from);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (offset), offset, tmp);
+
+ if (update_spacing_in_type
+ && TREE_CODE (spacing) == INTEGER_CST
+ && GFC_TYPE_ARRAY_SPACING (TREE_TYPE (dest), dim) == NULL_TREE)
+ GFC_TYPE_ARRAY_SPACING (TREE_TYPE (dest), dim) = spacing;
+
+ /* Store the new spacing. */
+ gfc_conv_descriptor_spacing_set (block, dest, gfc_rank_cst[dim], spacing);
+ }
+
+ for (int n = rank; n < rank + corank; n++)
+ {
+ tree from = lowers[n];
+ tree to = uppers[n];
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[n], from);
+ if (n < rank + corank - 1)
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[n], to);
+ }
+
+ if (data_needed)
+ /* Point the data pointer at the 1st element in the section. */
+ gfc_get_dataptr_offset (block, dest, src, base, subref, src_expr);
+ else
+ gfc_conv_descriptor_data_set (block, dest,
+ gfc_index_zero_node);
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && src_expr->corank)
+ {
+ tmp = INDIRECT_REF_P (src) ? TREE_OPERAND (src, 0) : src;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ tmp = gfc_conv_descriptor_token_get (tmp);
+ }
+ else if (DECL_P (tmp) && DECL_LANG_SPECIFIC (tmp)
+ && GFC_DECL_TOKEN (tmp) != NULL_TREE)
+ tmp = GFC_DECL_TOKEN (tmp);
+ else
+ {
+ tmp = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (tmp));
+ }
+
+ gfc_conv_descriptor_token_set (block, dest, tmp);
+ }
+}
+
+
+
+/* Fills in an array descriptor, and returns the number of elements in the
+ array. The pointer argument overflow, which should be of integer type,
+ will increase in value if overflow occurs during the size calculation.
+ Also sets the condition whether the array is empty through empty_array_cond.
+ {
+ stride = 1;
+ offset = 0;
+ for (n = 0; n < rank; n++)
+ {
+ a.lbound[n] = specified_lower_bound;
+ offset = offset + a.lbond[n] * stride;
+ size = 1 - lbound;
+ a.ubound[n] = specified_upper_bound;
+ a.stride[n] = stride;
+ size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
+ overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
+ stride = stride * size;
+ }
+ for (n = rank; n < rank+corank; n++)
+ (Set lcobound/ucobound as above.)
+ if (rank == 0)
+ return 1;
+ return stride;
+ } */
+/*GCC ARRAYS*/
+
+tree
+gfc_descr_init_count (tree descriptor, int rank, int corank, gfc_expr ** lower,
+ gfc_expr ** upper, stmtblock_t * pblock,
+ stmtblock_t * descriptor_block, tree * overflow,
+ tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
+ bool e3_has_nodescriptor, gfc_expr *expr,
+ tree element_size, gfc_typespec * explicit_ts,
+ tree *empty_array_cond)
+{
+ tree type;
+ tree tmp;
+ tree size;
+ tree offset;
+ tree stride;
+ tree spacing;
+ tree cond;
+ gfc_expr *ubound;
+ gfc_se se;
+ int n;
+
+ type = TREE_TYPE (descriptor);
+
+ stride = gfc_index_one_node;
+ offset = gfc_index_zero_node;
+
+ /* Set the dtype before the alloc, because registration of coarrays needs
+ it initialized. */
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.deferred
+ && expr->ts.u.cl->backend_decl
+ && VAR_P (expr->ts.u.cl->backend_decl))
+ {
+ type = gfc_typenode_for_spec (&expr->ts);
+ tree dtype_value = gfc_get_dtype_rank_type (rank, type);
+ gfc_conv_descriptor_dtype_set (pblock, descriptor, dtype_value);
+ }
+ else if (expr->ts.type == BT_CHARACTER
+ && expr->ts.deferred
+ && TREE_CODE (descriptor) == COMPONENT_REF)
+ {
+ /* Deferred character components have their string length tucked away
+ in a hidden field of the derived type. Obtain that and use it to
+ set the dtype. The charlen backend decl is zero because the field
+ type is zero length. */
+ gfc_ref *ref;
+ tmp = NULL_TREE;
+ for (ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT
+ && gfc_deferred_strlen (ref->u.c.component, &tmp))
+ break;
+ gcc_assert (tmp != NULL_TREE);
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ TREE_OPERAND (descriptor, 0), tmp, NULL_TREE);
+ tmp = fold_convert (gfc_charlen_type_node, tmp);
+ type = gfc_get_character_type_len (expr->ts.kind, tmp);
+ tree dtype_value = gfc_get_dtype_rank_type (rank, type);
+ gfc_conv_descriptor_dtype_set (pblock, descriptor, dtype_value);
+ }
+ else if (explicit_ts)
+ {
+ type = gfc_typenode_for_spec (explicit_ts);
+ tree dtype_value = gfc_get_dtype_rank_type (rank, type);
+ gfc_conv_descriptor_dtype_set (pblock, descriptor, dtype_value);
+ }
+ else if (expr3_desc && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+ {
+ tree dtype_value = gfc_conv_descriptor_dtype_get (expr3_desc);
+ gfc_conv_descriptor_dtype_set (pblock, descriptor, dtype_value);
+ }
+ else if (expr->ts.type == BT_CLASS && !explicit_ts
+ && expr3 && expr3->ts.type != BT_CLASS
+ && expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
+ gfc_conv_descriptor_elem_len_set (pblock, descriptor, expr3_elem_size);
+ else
+ gfc_conv_descriptor_dtype_set (pblock, descriptor, gfc_get_dtype (type));
+
+ gfc_conv_descriptor_elem_len_set (pblock, descriptor, element_size);
+
+ tree empty_cond = logical_false_node;
+ spacing = fold_convert_loc (input_location, gfc_array_index_type, element_size);
+
+ for (n = 0; n < rank; n++)
+ {
+ tree conv_lbound;
+ tree conv_ubound;
+
+ /* We have 3 possibilities for determining the size of the array:
+ lower == NULL => lbound = 1, ubound = upper[n]
+ upper[n] = NULL => lbound = 1, ubound = lower[n]
+ upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
+ ubound = upper[n];
+
+ /* Set lower bound. */
+ gfc_init_se (&se, NULL);
+ if (expr3_desc != NULL_TREE)
+ {
+ if (e3_has_nodescriptor)
+ /* The lbound of nondescriptor arrays like array constructors,
+ nonallocatable/nonpointer function results/variables,
+ start at zero, but when allocating it, the standard expects
+ the array to start at one. */
+ se.expr = gfc_index_one_node;
+ else
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc,
+ gfc_rank_cst[n]);
+ }
+ else if (lower == NULL)
+ se.expr = gfc_index_one_node;
+ else
+ {
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
+ }
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
+ conv_lbound = se.expr;
+
+ /* Work out the offset for this component. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ se.expr, spacing);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+
+ /* Set upper bound. */
+ gfc_init_se (&se, NULL);
+ if (expr3_desc != NULL_TREE)
+ {
+ if (e3_has_nodescriptor)
+ {
+ /* The lbound of nondescriptor arrays like array constructors,
+ nonallocatable/nonpointer function results/variables,
+ start at zero, but when allocating it, the standard expects
+ the array to start at one. Therefore fix the upper bound to be
+ (desc.ubound - desc.lbound) + 1. */
+ tmp = gfc_conv_array_extent_dim (
+ gfc_conv_descriptor_lbound_get (expr3_desc,
+ gfc_rank_cst[n]),
+ gfc_conv_descriptor_ubound_get (expr3_desc,
+ gfc_rank_cst[n]),
+ nullptr);
+ se.expr = gfc_evaluate_now (tmp, pblock);
+ }
+ else
+ se.expr = gfc_conv_descriptor_ubound_get (expr3_desc,
+ gfc_rank_cst[n]);
+ }
+ else
+ {
+ gcc_assert (ubound);
+ gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ if (ubound->expr_type == EXPR_FUNCTION)
+ se.expr = gfc_evaluate_now (se.expr, pblock);
+ }
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
+ conv_ubound = se.expr;
+
+ /* Store the spacing. */
+ gfc_conv_descriptor_spacing_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], spacing);
+
+ /* Calculate size and check whether extent is negative. */
+ size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound,
+ &empty_cond);
+ size = gfc_evaluate_now (size, pblock);
+
+ /* Check whether multiplying the stride by the number of
+ elements in this dimension would overflow. We must also check
+ whether the current dimension has zero size in order to avoid
+ division by zero.
+ */
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type,
+ TYPE_MAX_VALUE (gfc_array_index_type)),
+ size);
+ cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
+ logical_type_node, tmp, spacing),
+ PRED_FORTRAN_OVERFLOW);
+ tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+ integer_one_node, integer_zero_node);
+ cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, size,
+ gfc_index_zero_node),
+ PRED_FORTRAN_SIZE_ZERO);
+ tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond,
+ integer_zero_node, tmp);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ *overflow, tmp);
+ *overflow = gfc_evaluate_now (tmp, pblock);
+
+ /* Multiply the stride by the number of elements in this dimension. */
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, size);
+ stride = gfc_evaluate_now (stride, pblock);
+
+ spacing = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing, size);
+ spacing = gfc_evaluate_now (spacing, pblock);
+ }
+
+ for (n = rank; n < rank + corank; n++)
+ {
+ ubound = upper[n];
+
+ /* Set lower bound. */
+ gfc_init_se (&se, NULL);
+ if (lower == NULL || lower[n] == NULL)
+ {
+ gcc_assert (n == rank + corank - 1);
+ se.expr = gfc_index_one_node;
+ }
+ else
+ {
+ if (ubound || n == rank + corank - 1)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
+ }
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
+
+ if (n < rank + corank - 1)
+ {
+ gfc_init_se (&se, NULL);
+ gcc_assert (ubound);
+ gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
+ }
+ }
+
+ *empty_array_cond = empty_cond;
+
+ if (rank == 0)
+ return gfc_index_one_node;
+
+ /* Update the array descriptor with the offset and the span. */
+ offset = gfc_evaluate_now (offset, pblock);
+ gfc_conv_descriptor_offset_set (descriptor_block, descriptor, offset);
+ tmp = fold_convert (gfc_array_index_type, element_size);
+ gfc_conv_descriptor_span_set (descriptor_block, descriptor, tmp);
+
+ return gfc_evaluate_now (stride, pblock);
+}
+
+
+void
+gfc_copy_descriptor_to_contiguous (stmtblock_t *block, tree src, tree dest,
+ tree cont_ptr, int rank, gfc_ss *ss)
+{
+ tree old_field = gfc_conv_descriptor_dtype_get (src);
+ gfc_conv_descriptor_dtype_set (block, dest, old_field);
+
+ tree offset = gfc_index_zero_node;
+ tree spacing = gfc_conv_descriptor_span_get (src);
+ spacing = gfc_evaluate_now (spacing, block);
+
+ for (int i = 0; i < rank; i++)
+ {
+ tree src_dim = gfc_rank_cst[gfc_get_array_ref_dim_for_loop_dim (ss, i)];
+
+ tree lbound = gfc_conv_descriptor_lbound_get (src, src_dim);
+ lbound = gfc_evaluate_now (lbound, block);
+ gfc_conv_descriptor_lbound_set (block, dest, gfc_rank_cst[i], lbound);
+
+ tree ubound = gfc_conv_descriptor_ubound_get (src, src_dim);
+ ubound = gfc_evaluate_now (ubound, block);
+ gfc_conv_descriptor_ubound_set (block, dest, gfc_rank_cst[i], ubound);
+
+ gfc_conv_descriptor_spacing_set (block, dest, gfc_rank_cst[i], spacing);
+
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing, lbound);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+ if (i < rank - 1)
+ {
+ tree extent = gfc_conv_array_extent_dim (lbound, ubound, nullptr);
+ spacing = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, spacing, extent);
+ spacing = gfc_evaluate_now (spacing, block);
+ }
+ }
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+
+ gfc_conv_descriptor_data_set (block, dest, cont_ptr);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (src))
+ && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (src))
+ == GFC_ARRAY_ALLOCATABLE)
+ {
+ old_field = gfc_conv_descriptor_token_get (src);
+ gfc_conv_descriptor_token_set (block, dest, old_field);
+ }
+}
+
+
+void
+gfc_set_contiguous_array (stmtblock_t *block, tree desc, tree size,
+ tree data_ptr)
+{
+ tree dtype_value = gfc_get_dtype_rank_type (1, TREE_TYPE (desc));
+ gfc_conv_descriptor_dtype_set (block, desc, dtype_value);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+ tree span = gfc_conv_descriptor_span_get (desc);
+ gfc_conv_descriptor_spacing_set (block, desc, gfc_index_zero_node, span);
+ gfc_conv_descriptor_ubound_set (block, desc, gfc_index_zero_node, size);
+ gfc_conv_descriptor_data_set (block, desc, data_ptr);
+}
+
+
+void
+gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
+ bool)
+{
+ tree tmp, tmp2, type;
+
+ gfc_conv_descriptor_data_set (block, lhs_desc,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_offset_set (block, lhs_desc,
+ gfc_conv_descriptor_offset_get (rhs_desc));
+
+ gfc_conv_descriptor_dtype_set (block, lhs_desc,
+ gfc_conv_descriptor_dtype_get (rhs_desc));
+
+ gfc_conv_descriptor_span_set (block, lhs_desc,
+ gfc_conv_descriptor_span_get (rhs_desc));
+
+ /* Assign the dimension as range-ref. */
+ tmp = gfc_conv_descriptor_dimensions_get (lhs_desc);
+ tmp2 = gfc_conv_descriptor_dimensions_get (rhs_desc);
+
+ int rank = gfc_descriptor_rank (lhs_desc);
+ int rank2 = gfc_descriptor_rank (rhs_desc);
+ if (rank == GFC_MAX_DIMENSIONS && rank2 != GFC_MAX_DIMENSIONS)
+ type = TREE_TYPE (tmp2);
+ else if (rank2 == GFC_MAX_DIMENSIONS && rank != GFC_MAX_DIMENSIONS)
+ type = TREE_TYPE (tmp);
+ else
+ {
+ int corank = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (lhs_desc));
+ int corank2 = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (rhs_desc));
+ if (corank > 0 && corank2 == 0)
+ type = TREE_TYPE (tmp2);
+ else if (corank2 > 0 && corank == 0)
+ type = TREE_TYPE (tmp);
+ else
+ {
+ gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
+ type = TREE_TYPE (tmp);
+ }
+ }
+
+ tmp = gfc_conv_descriptor_dimensions_get (rhs_desc, type);
+ gfc_conv_descriptor_dimensions_set (block, lhs_desc, tmp);
+}
+
+
+void
+gfc_copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
+{
+ int n;
+ tree dim;
+ tree tmp;
+ tree tmp2;
+ tree size;
+ tree offset;
+
+ offset = gfc_index_zero_node;
+
+ /* Use memcpy to copy the descriptor. The size is the minimum of
+ the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
+ tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
+ tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
+ size = fold_build2_loc (input_location, MIN_EXPR,
+ TREE_TYPE (tmp), tmp, tmp2);
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp = build_call_expr_loc (input_location, tmp, 3,
+ gfc_build_addr_expr (NULL_TREE, dst),
+ gfc_build_addr_expr (NULL_TREE, src),
+ fold_convert (size_type_node, size));
+ gfc_add_expr_to_block (block, tmp);
+
+ /* Set the offset correctly. */
+ for (n = 0; n < rank; n++)
+ {
+ dim = gfc_rank_cst[n];
+ tmp = gfc_conv_descriptor_lbound_get (src, dim);
+ tmp2 = gfc_conv_descriptor_spacing_get (src, dim);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+ tmp, tmp2);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ TREE_TYPE (offset), offset, tmp);
+ offset = gfc_evaluate_now (offset, block);
+ }
+
+ gfc_conv_descriptor_offset_set (block, dst, offset);
+}
+
+
+/* Returns the value of LBOUND for an expression. This could be broken out
+ from gfc_conv_intrinsic_bound but this seemed to be simpler. This is
+ called by gfc_alloc_allocatable_for_assignment. */
+static tree
+get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size)
+{
+ tree lbound;
+ tree ubound;
+ tree spacing;
+ tree cond, cond1, cond3, cond4;
+ tree tmp;
+ gfc_ref *ref;
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ tmp = gfc_rank_cst[dim];
+ lbound = gfc_conv_descriptor_lbound_get (desc, tmp);
+ ubound = gfc_conv_descriptor_ubound_get (desc, tmp);
+ spacing = gfc_conv_descriptor_spacing_get (desc, tmp);
+ cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ ubound, lbound);
+ cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
+ spacing, gfc_index_zero_node);
+ cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ logical_type_node, cond3, cond1);
+ cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
+ spacing, gfc_index_zero_node);
+ if (assumed_size)
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ tmp, build_int_cst (gfc_array_index_type,
+ expr->rank - 1));
+ else
+ cond = logical_false_node;
+
+ cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, cond3, cond4);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, cond, cond1);
+
+ return fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ lbound, gfc_index_one_node);
+ }
+
+ if (expr->expr_type == EXPR_FUNCTION)
+ {
+ /* A conversion function, so use the argument. */
+ gcc_assert (expr->value.function.isym
+ && expr->value.function.isym->conversion);
+ expr = expr->value.function.actual->expr;
+ }
+
+ if (expr->expr_type == EXPR_VARIABLE)
+ {
+ tmp = TREE_TYPE (expr->symtree->n.sym->backend_decl);
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_COMPONENT
+ && ref->u.c.component->as
+ && ref->next
+ && ref->next->u.ar.type == AR_FULL)
+ tmp = TREE_TYPE (ref->u.c.component->backend_decl);
+ }
+ return GFC_TYPE_ARRAY_LBOUND(tmp, dim);
+ }
+
+ return gfc_index_one_node;
+}
+
+
+void
+gfc_set_descriptor_for_assign_realloc (stmtblock_t *block, gfc_loopinfo *loop,
+ gfc_expr *expr1, gfc_expr *expr2,
+ tree desc, tree desc2, tree elemsize2,
+ tree class_expr2)
+{
+ bool coarray = (flag_coarray == GFC_FCOARRAY_LIB
+ && gfc_caf_attr (expr1, true).codimension);
+
+ gfc_array_spec * as;
+ /* Get arrayspec if expr is a full array. */
+ if (expr2 && expr2->expr_type == EXPR_FUNCTION
+ && expr2->value.function.isym
+ && expr2->value.function.isym->conversion)
+ {
+ /* For conversion functions, take the arg. */
+ gfc_expr *arg = expr2->value.function.actual->expr;
+ as = gfc_get_full_arrayspec_from_expr (arg);
+ }
+ else if (expr2)
+ as = gfc_get_full_arrayspec_from_expr (expr2);
+ else
+ as = NULL;
+
+ /* Modify the lhs descriptor and the associated scalarizer
+ variables. F2003 7.4.1.3: "If variable is or becomes an
+ unallocated allocatable variable, then it is allocated with each
+ deferred type parameter equal to the corresponding type parameters
+ of expr , with the shape of expr , and with each lower bound equal
+ to the corresponding element of LBOUND(expr)."
+ Reuse size1 to keep a dimension-by-dimension track of the
+ stride of the new array. */
+ tree size1 = elemsize2;
+ tree offset = gfc_index_zero_node;
+
+ for (int n = 0; n < expr2->rank; n++)
+ {
+ tree tmp = gfc_conv_array_extent_dim (loop->from[n], loop->to[n], NULL);
+
+ tree lbound = gfc_index_one_node;
+ tree ubound = tmp;
+
+ if (as)
+ {
+ tree lbd = get_std_lbound (expr2, desc2, n,
+ as->type == AS_ASSUMED_SIZE);
+ ubound = fold_build2_loc (input_location,
+ MINUS_EXPR,
+ gfc_array_index_type,
+ ubound, lbound);
+ ubound = fold_build2_loc (input_location,
+ PLUS_EXPR,
+ gfc_array_index_type,
+ ubound, lbd);
+ lbound = lbd;
+ }
+
+ gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[n], lbound);
+ gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[n], ubound);
+ gfc_conv_descriptor_spacing_set (block, desc, gfc_rank_cst[n], size1);
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ gfc_rank_cst[n]);
+ tree tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, size1);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ offset, tmp2);
+ size1 = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, size1);
+ }
+
+ /* Set the lhs descriptor and scalarizer offsets. For rank > 1,
+ the array offset is saved and the info.offset is used for a
+ running offset. Use the saved_offset instead. */
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ gfc_conv_descriptor_span_set (block, desc, elemsize2);
+
+ /* For deferred character length, the 'size' field of the dtype might
+ have changed so set the dtype. */
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+ && expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ tree type;
+ if (expr2->ts.u.cl->backend_decl)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_typenode_for_spec (&expr1->ts);
+
+ tree dtype_value = gfc_get_dtype_rank_type (expr1->rank, type);
+ gfc_conv_descriptor_dtype_set (block, desc, dtype_value);
+ }
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ tree type;
+ if (expr2->ts.type != BT_CLASS)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_get_character_type_len (1, elemsize2);
+
+ tree dtype_value = gfc_get_dtype_rank_type (expr2->rank, type);
+ gfc_conv_descriptor_dtype_set (block, desc, dtype_value);
+
+ /* Set the _len field as well... */
+ if (UNLIMITED_POLY (expr1))
+ {
+ tree tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+ if (expr2->ts.type == BT_CHARACTER)
+ gfc_add_modify (block, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ TYPE_SIZE_UNIT (type)));
+ else if (UNLIMITED_POLY (expr2))
+ gfc_add_modify (block, tmp,
+ gfc_class_len_get (TREE_OPERAND (desc2, 0)));
+ else
+ gfc_add_modify (block, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ }
+ /* ...and the vptr. */
+ tree tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
+ tree tmp2;
+ if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
+ && TREE_CODE (desc2) == COMPONENT_REF)
+ {
+ tmp2 = gfc_get_class_from_expr (desc2);
+ tmp2 = gfc_class_vptr_get (tmp2);
+ }
+ else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
+ tmp2 = gfc_class_vptr_get (class_expr2);
+ else
+ {
+ tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+ tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+ }
+
+ gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+ }
+ else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ {
+ gfc_conv_descriptor_dtype_set (block, desc,
+ gfc_get_dtype (TREE_TYPE (desc)));
+ }
+}
+
+
+tree
+gfc_set_pdt_array_descriptor (stmtblock_t *block, tree desc,
+ gfc_array_spec *as,
+ gfc_actual_arglist *pdt_param_list)
+{
+ /* This chunk takes the expressions for 'lower' and 'upper'
+ in the arrayspec and substitutes in the expressions for
+ the parameters from 'pdt_param_list'. The descriptor
+ fields can then be filled from the values so obtained. */
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
+
+ gfc_conv_descriptor_dtype_set (block, desc,
+ gfc_get_dtype (TREE_TYPE (desc)));
+ tree size = gfc_conv_descriptor_elem_len_get (desc);
+ tree offset = gfc_index_zero_node;
+ for (int i = 0; i < as->rank; i++)
+ {
+ gfc_se tse;
+ gfc_init_se (&tse, NULL);
+ gfc_expr *e = gfc_copy_expr (as->lower[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ tree lower = tse.expr;
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[i],
+ lower);
+ e = gfc_copy_expr (as->upper[i]);
+ gfc_insert_parameter_exprs (e, pdt_param_list);
+ gfc_conv_expr_type (&tse, e, gfc_array_index_type);
+ gfc_free_expr (e);
+ tree upper = tse.expr;
+ gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[i], upper);
+ size = gfc_evaluate_now (size, block);
+ size = fold_convert_loc (input_location, gfc_array_index_type, size);
+ gfc_conv_descriptor_spacing_set (block, desc, gfc_rank_cst[i], size);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, size);
+ offset = gfc_evaluate_now (offset, block);
+ tree tmp = gfc_conv_array_extent_dim (lower, upper, nullptr);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, size, tmp);
+ }
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+ return size;
+}
+
+
+/* Extend the data in array DESC by EXTRA elements. */
+
+void
+gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra)
+{
+ tree arg0, arg1;
+ tree tmp;
+ tree size;
+ tree ubound;
+
+ if (integer_zerop (extra))
+ return;
+
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[0]);
+
+ /* Add EXTRA to the upper bound. */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ ubound, extra);
+ gfc_conv_descriptor_ubound_set (pblock, desc, gfc_rank_cst[0], tmp);
+
+ /* Get the value of the current data pointer. */
+ arg0 = gfc_conv_descriptor_data_get (desc);
+
+ /* Calculate the new array size. */
+ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ gcc_assert (integer_zerop (GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), 0)));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ ubound, gfc_index_one_node);
+ arg1 = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, tmp),
+ fold_convert (size_type_node, size));
+
+ /* Reset array type upper bound if known. */
+ tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ tree fixed_ptr_type = gfc_get_unbounded_array_type (dataptr_type);
+ if (fixed_ptr_type != dataptr_type)
+ GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)) = fixed_ptr_type;
+
+ /* Call the realloc() function. */
+ tmp = gfc_call_realloc (pblock, arg0, arg1);
+ gfc_conv_descriptor_data_set (pblock, desc, tmp);
+}
+
-#undef DATA_FIELD
-#undef OFFSET_FIELD
-#undef DTYPE_FIELD
-#undef SPAN_FIELD
-#undef DIMENSION_FIELD
-#undef CAF_TOKEN_FIELD
-#undef STRIDE_SUBFIELD
-#undef LBOUND_SUBFIELD
-#undef UBOUND_SUBFIELD
diff --git a/gcc/fortran/trans-descriptor.h b/gcc/fortran/trans-descriptor.h
index d313d9fab175..128ea68e4979 100644
--- a/gcc/fortran/trans-descriptor.h
+++ b/gcc/fortran/trans-descriptor.h
@@ -1,4 +1,5 @@
-/* Copyright (C) 2002-2025 Free Software Foundation, Inc.
+/* Header for array descriptor functions
+ Copyright (C) 2002-2025 Free Software Foundation, Inc.
This file is part of GCC.
@@ -16,58 +17,104 @@ You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
+/* Build a null array descriptor constructor. */
+tree gfc_array_dataptr_type (tree);
+tree gfc_build_null_descriptor (tree);
+tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, tree);
+void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
+void gfc_set_scalar_null_descriptor (stmtblock_t *block, tree, gfc_symbol *, gfc_expr *, tree);
+void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
+ gfc_expr *, locus *);
+tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
+void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
+ symbol_attribute *, tree = NULL_TREE);
+void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
+void gfc_set_gfc_from_cfi (stmtblock_t *, stmtblock_t *, tree, tree, tree,
+ gfc_symbol *, bool, bool, bool);
+int gfc_descriptor_rank (tree);
-tree gfc_get_cfi_desc_base_addr (tree desc);
-tree gfc_get_cfi_desc_elem_len (tree desc);
-tree gfc_get_cfi_desc_version (tree desc);
-tree gfc_get_cfi_desc_rank (tree desc);
-tree gfc_get_cfi_desc_type (tree desc);
-tree gfc_get_cfi_desc_attribute (tree desc);
-
-tree gfc_get_cfi_dim_lbound (tree desc, tree idx);
-tree gfc_get_cfi_dim_extent (tree desc, tree idx);
-tree gfc_get_cfi_dim_sm (tree desc, tree idx);
-
-
-tree gfc_get_descriptor_dimension (tree desc);
-tree gfc_conv_descriptor_token (tree desc);
-
-tree gfc_conv_descriptor_data_get (tree desc);
-tree gfc_conv_descriptor_offset_get (tree desc);
-tree gfc_conv_descriptor_dtype_get (tree desc);
-tree gfc_conv_descriptor_elem_len_get (tree desc);
-tree gfc_conv_descriptor_version_get (tree desc);
-tree gfc_conv_descriptor_rank_get (tree desc);
-tree gfc_conv_descriptor_type_get (tree desc);
-tree gfc_conv_descriptor_span_get (tree desc);
-
-tree gfc_conv_descriptor_dimension_get (tree desc, tree dim);
-tree gfc_conv_descriptor_dimension_get (tree desc, int dim);
-tree gfc_conv_descriptor_stride_get (tree desc, tree dim);
-tree gfc_conv_descriptor_lbound_get (tree desc, tree dim);
-tree gfc_conv_descriptor_ubound_get (tree desc, tree dim);
-
-void gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_offset_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_dtype_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_elem_len_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_version_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_rank_set (stmtblock_t *block, tree desc, int value);
-void gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, tree value);
-void gfc_conv_descriptor_dimension_set (stmtblock_t *block, tree desc, tree dim, tree value);
-void gfc_conv_descriptor_dimension_set (stmtblock_t *block, tree desc, int dim, tree value);
-void gfc_conv_descriptor_stride_set (stmtblock_t *block, tree desc, tree dim, tree value);
-void gfc_conv_descriptor_lbound_set (stmtblock_t *block, tree desc, tree dim, tree value);
-void gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree desc, tree dim, tree value);
-
-tree gfc_build_null_descriptor (tree type);
+void gfc_copy_descriptor (stmtblock_t *block, tree dest, tree src,
+ gfc_expr *src_expr, bool subref);
+
+tree gfc_conv_descriptor_data_get (tree);
+tree gfc_conv_descriptor_offset_get (tree);
+tree gfc_conv_descriptor_span_get (tree);
+tree gfc_conv_descriptor_dtype_get (tree);
+tree gfc_conv_descriptor_rank_get (tree);
+tree gfc_conv_descriptor_elem_len_get (tree);
+tree gfc_conv_descriptor_version_get (tree);
+tree gfc_conv_descriptor_attribute_get (tree);
+tree gfc_conv_descriptor_type_get (tree);
+tree gfc_conv_descriptor_dimension_get (tree, tree);
+tree gfc_conv_descriptor_dimensions_get (tree);
+tree gfc_conv_descriptor_dimensions_get (tree, tree);
+tree gfc_conv_descriptor_stride_get (tree, tree);
+tree gfc_conv_descriptor_lbound_get (tree, tree);
+tree gfc_conv_descriptor_ubound_get (tree, tree);
+tree gfc_conv_descriptor_extent_get (tree, tree);
+tree gfc_conv_descriptor_spacing_get (tree, tree);
+tree gfc_conv_descriptor_token (tree);
+tree gfc_conv_descriptor_token_get (tree);
+
+void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_token_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_dtype_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_version_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_rank_set (stmtblock_t *, tree, tree);
+void gfc_conv_descriptor_rank_set (stmtblock_t *, tree, int);
+void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
+
+/* CFI descriptor. */
+tree gfc_get_cfi_desc_base_addr (tree);
+tree gfc_get_cfi_desc_elem_len (tree);
+tree gfc_get_cfi_desc_version (tree);
+tree gfc_get_cfi_desc_rank (tree);
+tree gfc_get_cfi_desc_type (tree);
+tree gfc_get_cfi_desc_attribute (tree);
+tree gfc_get_cfi_dim_lbound (tree, tree);
+tree gfc_get_cfi_dim_extent (tree, tree);
+tree gfc_get_cfi_dim_sm (tree, tree);
+
+/* Shift lower bound of descriptor, updating ubound and offset. */
+tree gfc_build_desc_array_type (tree, tree, int, tree *, tree *);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
+void gfc_conv_shift_descriptor_subarray (stmtblock_t*, tree, gfc_expr *, gfc_expr *);
+void gfc_conv_shift_descriptor (stmtblock_t *, tree, int, tree *, tree *);
+
+void gfc_set_temporary_descriptor (stmtblock_t *, tree, tree, tree, tree,
+ tree[GFC_MAX_DIMENSIONS], tree[GFC_MAX_DIMENSIONS],
+ tree[GFC_MAX_DIMENSIONS], int, bool, bool, bool);
+
+void gfc_set_descriptor (stmtblock_t *, tree, tree, gfc_expr *, int, int,
+ gfc_ss *, gfc_array_info *, tree [GFC_MAX_DIMENSIONS],
+ tree [GFC_MAX_DIMENSIONS], bool, bool, bool, tree);
+
+tree gfc_descr_init_count (tree, int, int, gfc_expr **, gfc_expr **,
+ stmtblock_t *, stmtblock_t *, tree *, tree,
+ gfc_expr *, tree, bool, gfc_expr *, tree,
+ gfc_typespec *, tree *);
+void gfc_copy_descriptor_to_contiguous (stmtblock_t *, tree, tree, tree, int, gfc_ss *);
+void
+gfc_set_contiguous_array (stmtblock_t *block, tree desc, tree size,
+ tree data_ptr);
+void
+gfc_class_array_data_assign (stmtblock_t *, tree, tree, bool);
+
+void
+gfc_copy_descriptor (stmtblock_t *, tree, tree, int);
+
+void
+gfc_set_descriptor_for_assign_realloc (stmtblock_t *, gfc_loopinfo *,
+ gfc_expr *, gfc_expr *, tree, tree,
+ tree, tree);
+tree
+gfc_set_pdt_array_descriptor (stmtblock_t *, tree, gfc_array_spec *,
+ gfc_actual_arglist *);
void
-gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off,
- tree *dtype_off, tree *span_off,
- tree *dim_off, tree *dim_size,
- tree *stride_suboff, tree *lower_suboff,
- tree *upper_suboff);
+gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d46c43857dc7..b16b870ff369 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -38,12 +38,12 @@ along with GCC; see the file COPYING3. If not see
#include "trans-const.h"
#include "trans-types.h"
#include "trans-array.h"
-#include "trans-descriptor.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
#include "trans-stmt.h"
#include "dependency.h"
#include "gimplify.h"
#include "tm.h" /* For CHAR_TYPE_SIZE. */
+#include "trans-descriptor.h"
/* Calculate the number of characters in a string. */
@@ -84,34 +84,80 @@ gfc_get_character_len_in_bytes (tree type)
}
-/* Convert a scalar to an array descriptor. To be used for assumed-rank
- arrays. */
+tree
+gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr *expr, tree scalar)
+{
+ symbol_attribute attr = sym->attr;
-static tree
-get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+ tree type = gfc_get_scalar_to_descriptor_type (scalar, attr);
+ tree desc = gfc_create_var (type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+
+ if (CONSTANT_CLASS_P (scalar))
+ {
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (&se->pre, tmp, scalar);
+ scalar = tmp;
+ }
+ if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
+ scalar = gfc_build_addr_expr (NULL_TREE, scalar);
+
+ gfc_set_scalar_null_descriptor (&se->pre, desc, sym, expr, scalar);
+
+ /* Copy pointer address back - but only if it could have changed and
+ if the actual argument is a pointer and not, e.g., NULL(). */
+ if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
+ gfc_add_modify (&se->post, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ gfc_conv_descriptor_data_get (desc)));
+ return desc;
+}
+
+
+tree
+gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr *expr)
{
- enum gfc_array_kind akind;
+#if 0
+ symbol_attribute attr = sym->attr;
+#endif
+ tree lower[GFC_MAX_DIMENSIONS], upper[GFC_MAX_DIMENSIONS];
- if (attr.pointer)
- akind = GFC_ARRAY_POINTER_CONT;
- else if (attr.allocatable)
- akind = GFC_ARRAY_ALLOCATABLE;
- else
- akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+ for (int i = 0; i < expr->rank; i++)
+ {
+ lower[i] = NULL_TREE;
+ upper[i] = NULL_TREE;
+ }
- if (POINTER_TYPE_P (TREE_TYPE (scalar)))
- scalar = TREE_TYPE (scalar);
- return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
- akind, !(attr.pointer || attr.target));
+ tree elt_type = gfc_typenode_for_spec (&sym->ts);
+ tree desc_type = gfc_get_array_type_bounds (elt_type, expr->rank, 0,
+ lower, upper, 0,
+ GFC_ARRAY_UNKNOWN, false,
+ expr->ts.type);
+ tree desc = gfc_create_var (desc_type, "desc");
+ DECL_ARTIFICIAL (desc) = 1;
+
+ gfc_clear_descriptor (&se->pre, sym, expr, desc);
+
+#if 0
+ /* Copy pointer address back - but only if it could have changed and
+ if the actual argument is a pointer and not, e.g., NULL(). */
+ if ((attr.pointer || attr.allocatable) && attr.intent != INTENT_IN)
+ gfc_add_modify (&se->post, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ gfc_conv_descriptor_data_get (desc)));
+#endif
+
+ return desc;
}
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
- tree desc, type, etype;
+ tree desc, type;
- type = get_scalar_to_descriptor_type (scalar, attr);
- etype = TREE_TYPE (scalar);
+ type = gfc_get_scalar_to_descriptor_type (scalar, attr);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -122,15 +168,8 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
gfc_add_modify (&se->pre, tmp, scalar);
scalar = tmp;
}
- if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
- scalar = gfc_build_addr_expr (NULL_TREE, scalar);
- else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
- etype = TREE_TYPE (etype);
- gfc_conv_descriptor_dtype_set (&se->pre, desc,
- gfc_get_dtype_rank_type (0, etype));
- gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
- gfc_conv_descriptor_span_set (&se->pre, desc,
- gfc_conv_descriptor_elem_len_get (desc));
+
+ gfc_set_descriptor_from_scalar (&se->pre, desc, scalar, &attr);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
@@ -201,7 +240,7 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
caf = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (comp), se.expr, comp, NULL_TREE);
else
- caf = gfc_conv_descriptor_token (se.expr);
+ caf = gfc_conv_descriptor_token_get (se.expr);
return gfc_build_addr_expr (NULL_TREE, caf);
}
@@ -273,8 +312,8 @@ gfc_class_vptr_get (tree decl)
}
-tree
-gfc_class_len_get (tree decl)
+bool
+gfc_class_len_get (tree decl, tree * result)
{
tree len;
/* For class arrays decl may be a temporary descriptor handle, the len is
@@ -286,9 +325,22 @@ gfc_class_len_get (tree decl)
decl = build_fold_indirect_ref_loc (input_location, decl);
len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
CLASS_LEN_FIELD);
- return fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (len), decl, len,
- NULL_TREE);
+ if (len == NULL_TREE)
+ return false;
+
+ *result = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (len), decl, len,
+ NULL_TREE);
+ return true;
+}
+
+
+tree
+gfc_class_len_get (tree decl)
+{
+ tree result;
+ gfc_class_len_get (decl, &result);
+ return result;
}
@@ -298,20 +350,11 @@ gfc_class_len_get (tree decl)
static tree
gfc_class_len_or_zero_get (tree decl)
{
- tree len;
- /* For class arrays decl may be a temporary descriptor handle, the vptr is
- then available through the saved descriptor. */
- if (VAR_P (decl) && DECL_LANG_SPECIFIC (decl)
- && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
- len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
- CLASS_LEN_FIELD);
- return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (len), decl, len,
- NULL_TREE)
- : build_zero_cst (gfc_charlen_type_node);
+ tree result;
+ if (gfc_class_len_get (decl, &result))
+ return result;
+ else
+ return build_zero_cst (gfc_charlen_type_node);
}
@@ -761,31 +804,6 @@ gfc_get_vptr_from_expr (tree expr)
return NULL_TREE;
}
-void
-gfc_class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc,
- bool lhs_type)
-{
- tree tmp, tmp2, type;
-
- gfc_conv_descriptor_data_set (block, lhs_desc,
- gfc_conv_descriptor_data_get (rhs_desc));
- gfc_conv_descriptor_offset_set (block, lhs_desc,
- gfc_conv_descriptor_offset_get (rhs_desc));
-
- gfc_conv_descriptor_dtype_set (block, lhs_desc,
- gfc_conv_descriptor_dtype_get (rhs_desc));
-
- /* Assign the dimension as range-ref. */
- tmp = gfc_get_descriptor_dimension (lhs_desc);
- tmp2 = gfc_get_descriptor_dimension (rhs_desc);
-
- type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2);
- tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
- gfc_index_zero_node, NULL_TREE, NULL_TREE);
- tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2,
- gfc_index_zero_node, NULL_TREE, NULL_TREE);
- gfc_add_modify (block, tmp, tmp2);
-}
/* Takes a derived type expression and returns the address of a temporary
class object of the 'declared' type. If opt_vptr_src is not NULL, this is
@@ -813,7 +831,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
var = gfc_create_var (tmp, "class");
/* Set the vptr. */
- if (opt_vptr_src)
+ if (parmse->class_container)
+ gfc_class_set_vptr (&parmse->pre, var, parmse->class_container);
+ else if (opt_vptr_src)
gfc_class_set_vptr (&parmse->pre, var, opt_vptr_src);
else
gfc_reset_vptr (&parmse->pre, e, var);
@@ -821,14 +841,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
/* Now set the data field. */
ctree = gfc_class_data_get (var);
+ tree caf_token;
if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
{
- tree token;
tmp = gfc_get_tree_for_caf_expr (e);
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
tmp = build_fold_indirect_ref (tmp);
- gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
+ gfc_get_caf_token_offset (parmse, &caf_token, nullptr, tmp, NULL_TREE, e);
+ /* gfc_set_descriptor_from scalar already updates the token,
+ don't do it twice. */
+ if ((parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+ || (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
+ || e->rank != 0
+ || fsym->ts.u.derived->components->as == nullptr)
+ gfc_conv_descriptor_token_set (&parmse->pre, ctree, caf_token);
}
if (optional)
@@ -895,18 +921,17 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
/* Scalar to an assumed-rank array. */
if (fsym->ts.u.derived->components->as)
{
- tree type;
- type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_conv_descriptor_dtype_set (&parmse->pre, ctree,
- gfc_get_dtype (type));
- if (optional)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE (parmse->expr),
- null_pointer_node));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
+ tree tmp = parmse->expr;
+ if (cond_optional)
+ {
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ null_pointer_node));
+ }
+ symbol_attribute attr = gfc_expr_attr (e);
+ gfc_set_descriptor_from_scalar (&parmse->pre, ctree, tmp, &attr,
+ caf_token);
}
else
{
@@ -924,8 +949,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
stmtblock_t block;
gfc_init_block (&block);
gfc_ref *ref;
- int dim;
- tree lbshift = NULL_TREE;
/* Array refs with sections indicate, that a for a formal argument
expecting contiguous repacking needs to be done. */
@@ -938,25 +961,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
&& (ref || e->rank != fsym->ts.u.derived->components->as->rank))
fsym->attr.contiguous = 1;
- /* Detect any array references with vector subscripts. */
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
- && ref->u.ar.type != AR_FULL)
- {
- for (dim = 0; dim < ref->u.ar.dimen; dim++)
- if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- break;
- if (dim < ref->u.ar.dimen)
- break;
- }
- /* Array references with vector subscripts and non-variable
- expressions need be converted to a one-based descriptor. */
- if (ref || e->expr_type != EXPR_VARIABLE)
- lbshift = gfc_index_one_node;
-
parmse->expr = var;
gfc_conv_array_parameter (parmse, e, false, fsym, proc_name, nullptr,
- &lbshift, &packed);
+ true, &packed);
if (derived_array && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
{
@@ -970,10 +977,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
tmp = gfc_finish_block (&block);
gfc_init_block (&block);
- gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node);
+ gfc_clear_descriptor (&block, fsym, ctree);
if (derived_array && *derived_array != NULL_TREE)
- gfc_conv_descriptor_data_set (&block, *derived_array,
- null_pointer_node);
+ gfc_clear_descriptor (&block, fsym, *derived_array);
tmp = build3_v (COND_EXPR, cond_optional, tmp,
gfc_finish_block (&block));
@@ -1086,7 +1092,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
tree ctree;
tree var;
tree tmp;
- int dim;
bool unlimited_poly;
unlimited_poly = class_ts.type == BT_CLASS
@@ -1154,11 +1159,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
/* Array references with vector subscripts and non-variable expressions
need be converted to a one-based descriptor. */
if (e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
- dim, gfc_index_one_node);
- }
+ gfc_conv_shift_descriptor (&parmse->pre, parmse->expr, e->rank);
if (class_ts.u.derived->components->as->rank != e->rank)
{
@@ -1281,7 +1282,9 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
}
if ((ref == NULL || class_ref == ref)
- && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
+ && !(gfc_is_class_array_function (e)
+ && (parmse->class_vptr != NULL_TREE
+ || parmse->class_container != NULL_TREE))
&& (!class_ts.u.derived->components->as
|| class_ts.u.derived->components->as->rank != -1))
return;
@@ -1307,26 +1310,32 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
{
if (e->rank == 0)
{
- tree type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_conv_descriptor_dtype_set (&block, ctree,
- gfc_get_dtype (type));
-
- tmp = gfc_class_data_get (parmse->expr);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- gfc_conv_descriptor_data_set (&block, ctree, tmp);
+ tree data = gfc_class_data_get (parmse->expr);
+ symbol_attribute attr = gfc_expr_attr (e);
+ gfc_set_descriptor_from_scalar (&block, ctree, data, &attr);
}
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
else
{
- if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
- parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
- TREE_TYPE (ctree), parmse->expr);
- gfc_add_modify (&block, ctree, parmse->expr);
+ tree val = parmse->expr;
+
+ if (TREE_CODE (TREE_TYPE (val)) == POINTER_TYPE)
+ val = build_fold_indirect_ref_loc (input_location, val);
+
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (val)))
+ val = gfc_class_data_get (val);
+
+ if (TREE_CODE (TREE_TYPE (ctree)) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (val)) != POINTER_TYPE)
+ val = gfc_build_addr_expr (NULL_TREE, val);
+
+ if (TREE_TYPE (val) != TREE_TYPE (ctree))
+ val = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (ctree), val);
+
+ gfc_add_modify (&block, ctree, val);
}
/* Return the data component, except in the case of scalarized array
@@ -1362,6 +1371,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
if (gfc_is_class_array_function (e)
&& parmse->class_vptr != NULL_TREE)
tmp = parmse->class_vptr;
+ else if (parmse->class_container != NULL_TREE)
+ /* Don't redundantly evaluate the expression if the required information
+ is already available. */
+ tmp = parmse->class_container;
else if (class_ref == NULL
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
{
@@ -1375,10 +1388,6 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
slen = build_zero_cst (size_type_node);
}
- else if (parmse->class_container != NULL_TREE)
- /* Don't redundantly evaluate the expression if the required information
- is already available. */
- tmp = parmse->class_container;
else
{
/* Remove everything after the last class reference, convert the
@@ -1637,8 +1646,11 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
{
tmp = gfc_conv_array_data (to);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ tree ptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (to_data));
+ tree len = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (ptr_type)));
to_ref = gfc_build_addr_expr (NULL_TREE,
- gfc_build_array_ref (tmp, index, to));
+ gfc_build_array_ref (tmp, index, true,
+ NULL_TREE, len));
}
vec_safe_push (args, to_ref);
@@ -2462,7 +2474,7 @@ gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl,
/* Coarray token. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
- *token = gfc_conv_descriptor_token (caf_decl);
+ *token = gfc_conv_descriptor_token_get (caf_decl);
else if (DECL_P (caf_decl) && DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
*token = GFC_DECL_TOKEN (caf_decl);
@@ -2600,8 +2612,7 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
TREE_TYPE (tmp), img_idx, tmp);
if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
{
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[i]);
extent = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
}
@@ -2795,7 +2806,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
/* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */
if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
{
- tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true);
+ tmp = gfc_build_array_ref (tmp, start.expr, true);
se->expr = gfc_build_addr_expr (type, tmp);
}
else if (POINTER_TYPE_P (TREE_TYPE (tmp)))
@@ -2939,7 +2950,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
field = f2;
}
- if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
+ if (ref->u.c.sym && ref->u.c.sym->attr.is_class
&& strcmp ("_data", c->name) == 0)
{
/* Found a ref to the _data component. Store the associated ref to
@@ -2949,7 +2960,11 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
else
se->class_vptr = NULL_TREE;
- tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ tree type = TREE_TYPE (field);
+ if (gfc_type_contains_placeholder_p (type))
+ type = gfc_substitute_placeholder_in_type (type, decl, &se->pre);
+
+ tmp = fold_build3_loc (input_location, COMPONENT_REF, type,
decl, field, NULL_TREE);
se->expr = tmp;
@@ -4801,7 +4816,7 @@ gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed,
!sym->attr.target && !sym->attr.pointer
- && !sym->attr.proc_pointer);
+ && !sym->attr.proc_pointer, sym->ts.type);
var = gfc_create_var (type, "ifm");
gfc_add_modify (block, var, fold_convert (type, data));
@@ -4826,7 +4841,7 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
{
dim = gfc_rank_cst[n];
- GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
+ GFC_TYPE_ARRAY_SPACING (type, n) = gfc_conv_array_spacing (desc, n);
if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
{
GFC_TYPE_ARRAY_LBOUND (type, n)
@@ -4848,7 +4863,7 @@ gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
}
tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_LBOUND (type, n),
- GFC_TYPE_ARRAY_STRIDE (type, n));
+ GFC_TYPE_ARRAY_SPACING (type, n));
offset = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, offset, tmp);
}
@@ -5365,11 +5380,8 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
gfc_loopinfo loop;
gfc_loopinfo loop2;
gfc_array_info *info;
- tree offset;
- tree tmp_index;
tree tmp;
tree base_type;
- tree size;
stmtblock_t body;
int n;
int dimen;
@@ -5436,6 +5448,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
? expr->ts.u.cl->backend_decl
: NULL),
loop.dimen);
+ loop.temp_ss->info->data.temp.preserve_bounds = 1;
parmse->string_length = loop.temp_ss->info->string_length;
@@ -5464,16 +5477,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
/* Translate the expression. */
gfc_conv_expr (&rse, expr);
- /* Reset the offset for the function call since the loop
- is zero based on the data pointer. Note that the temp
- comes first in the loop chain since it is added second. */
- if (gfc_is_class_array_function (expr))
- {
- tmp = loop.ss->loop_chain->info->data.array.descriptor;
- gfc_conv_descriptor_offset_set (&loop.pre, tmp,
- gfc_index_zero_node);
- }
-
gfc_conv_tmp_array_ref (&lse);
if (intent != INTENT_OUT)
@@ -5499,6 +5502,13 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
freeing of allocated memory is done at the right time. */
gfc_add_block_to_block (&parmse->pre, &loop.pre);
+ /* Remove the temporary from the first loop before cleanup, as we need it in
+ the second loop. */
+ gfc_ss *tmp_ss = loop.temp_ss;
+ gcc_assert (loop.ss == tmp_ss);
+ loop.ss = loop.ss->loop_chain;
+ gfc_cleanup_loop (&loop);
+
/**********Copy the temporary back again.*********/
gfc_init_se (&lse, NULL);
@@ -5506,7 +5516,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
/* Walk the argument expression. */
lss = gfc_walk_expr (expr);
- rse.ss = loop.temp_ss;
+ rse.ss = tmp_ss;
lse.ss = lss;
/* Initialize the scalarizer. */
@@ -5525,61 +5535,19 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop2, &expr->where);
+ /* Add the temporary late, as it doesn't need to be set up again. */
+ tmp_ss->info->data.array.data = tmp_ss->info->data.array.saved_data;
+ gfc_add_ss_to_loop (&loop2, tmp_ss);
+
gfc_copy_loopinfo_to_se (&lse, &loop2);
gfc_copy_loopinfo_to_se (&rse, &loop2);
gfc_mark_ss_chain_used (lss, 1);
- gfc_mark_ss_chain_used (loop.temp_ss, 1);
+ gfc_mark_ss_chain_used (tmp_ss, 1);
- /* Declare the variable to hold the temporary offset and start the
- scalarized loop body. */
- offset = gfc_create_var (gfc_array_index_type, NULL);
gfc_start_scalarized_body (&loop2, &body);
- /* Build the offsets for the temporary from the loop variables. The
- temporary array has lbounds of zero and strides of one in all
- dimensions, so this is very simple. The offset is only computed
- outside the innermost loop, so the overall transfer could be
- optimized further. */
- info = &rse.ss->info->data.array;
-
- tmp_index = gfc_index_zero_node;
- for (n = dimen - 1; n > 0; n--)
- {
- tree tmp_str;
- tmp = rse.loop->loopvar[n];
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- tmp, rse.loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- tmp, tmp_index);
-
- tmp_str = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- rse.loop->to[n-1], rse.loop->from[n-1]);
- tmp_str = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp_str, gfc_index_one_node);
-
- tmp_index = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp, tmp_str);
- }
-
- tmp_index = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- tmp_index, rse.loop->from[0]);
- gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
-
- tmp_index = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- rse.loop->loopvar[0], offset);
-
- /* Now use the offset for the reference. */
- tmp = build_fold_indirect_ref_loc (input_location,
- info->data);
- rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
-
- if (expr->ts.type == BT_CHARACTER)
- rse.string_length = expr->ts.u.cl->backend_decl;
+ gfc_conv_tmp_array_ref (&rse);
gfc_conv_expr (&lse, expr);
@@ -5610,9 +5578,6 @@ class_array_fcn:
gfc_add_block_to_block (&parmse->post, &loop.post);
- gfc_cleanup_loop (&loop);
- gfc_cleanup_loop (&loop2);
-
/* Pass the string length to the argument expression. */
if (expr->ts.type == BT_CHARACTER)
parmse->string_length = expr->ts.u.cl->backend_decl;
@@ -5620,42 +5585,10 @@ class_array_fcn:
/* Determine the offset for pointer formal arguments and set the
lbounds to one. */
if (formal_ptr)
- {
- size = gfc_index_one_node;
- offset = gfc_index_zero_node;
- for (n = 0; n < dimen; n++)
- {
- tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
- gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&parmse->pre,
- parmse->expr,
- gfc_rank_cst[n],
- tmp);
- gfc_conv_descriptor_lbound_set (&parmse->pre,
- parmse->expr,
- gfc_rank_cst[n],
- gfc_index_one_node);
- size = gfc_evaluate_now (size, &parmse->pre);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- offset, size);
- offset = gfc_evaluate_now (offset, &parmse->pre);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- rse.loop->to[n], rse.loop->from[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type,
- tmp, gfc_index_one_node);
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size, tmp);
- }
+ gfc_conv_shift_descriptor (&parmse->pre, parmse->expr, dimen,
+ rse.loop->from, rse.loop->to);
- gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
- offset);
- }
+ gfc_cleanup_loop (&loop2);
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
@@ -5944,6 +5877,7 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
/* A helper function to set the dtype for unallocated or unassociated
entities. */
+#if 0
static void
set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
@@ -5975,15 +5909,18 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
cond = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
+ tmp = gfc_conv_descriptor_dtype (desc);
type = gfc_get_element_type (TREE_TYPE (desc));
- gfc_conv_descriptor_dtype_set (&block, desc,
- gfc_get_dtype_rank_type (e->rank, type));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (tmp), tmp,
+ gfc_get_dtype_rank_type (e->rank, type));
+ gfc_add_expr_to_block (&block, tmp);
cond = build3_v (COND_EXPR, cond,
gfc_finish_block (&block),
build_empty_stmt (input_location));
gfc_add_expr_to_block (&parmse->pre, cond);
}
-
+#endif
/* Provide an interface between gfortran array descriptors and the F2018:18.4
@@ -6050,8 +5987,6 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
While sm is fine as it uses span*stride and not elem_len. */
if (POINTER_TYPE_P (TREE_TYPE (gfc)))
gfc = build_fold_indirect_ref_loc (input_location, gfc);
- else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
- gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
}
if (e->ts.type == BT_CHARACTER)
{
@@ -6310,16 +6245,10 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
tmp = gfc_index_zero_node;
gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
/* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_ubound_get (gfc, idx),
- gfc_conv_descriptor_lbound_get (gfc, idx));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- tmp, gfc_index_one_node);
+ tmp = gfc_conv_descriptor_extent_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
/* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_stride_get (gfc, idx),
- gfc_conv_descriptor_span_get (gfc));
+ tmp = gfc_conv_descriptor_spacing_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
/* Generate loop. */
@@ -6372,77 +6301,16 @@ done:
goto post_call;
gfc_init_block (&block2);
+
if (e->rank == 0)
{
+ gfc_init_block (&block2);
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
}
else
- {
- tmp = gfc_get_cfi_desc_base_addr (cfi);
- gfc_conv_descriptor_data_set (&block, gfc, tmp);
-
- if (fsym->attr.allocatable)
- {
- /* gfc->span = cfi->elem_len. */
- tmp = fold_convert (gfc_array_index_type,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
- }
- else
- {
- /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
- ? cfi->dim[0].sm : cfi->elem_len). */
- tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- tmp2 = fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi));
- tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
- gfc_array_index_type, tmp, tmp2);
- tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- tmp, gfc_index_zero_node);
- tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
- }
- gfc_conv_descriptor_span_set (&block2, gfc, tmp);
-
- /* Calculate offset + set lbound, ubound and stride. */
- gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
- /* Loop: for (i = 0; i < rank; ++i). */
- tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
- /* Loop body. */
- stmtblock_t loop_body;
- gfc_init_block (&loop_body);
- /* gfc->dim[i].lbound = ... */
- tmp = gfc_get_cfi_dim_lbound (cfi, idx);
- gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (gfc, idx),
- gfc_index_one_node);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- gfc_get_cfi_dim_extent (cfi, idx), tmp);
- gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
- tmp = gfc_get_cfi_dim_sm (cfi, idx);
- tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
- gfc_array_index_type, tmp,
- fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi)));
- gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
-
- /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_stride_get (gfc, idx),
- gfc_conv_descriptor_lbound_get (gfc, idx));
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_offset_get (gfc), tmp);
- gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
- /* Generate loop. */
- gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
- rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
- gfc_finish_block (&loop_body));
- }
+ gfc_set_gfc_from_cfi (&block, &block2, gfc, cfi, rank, nullptr,
+ false, false, fsym->attr.allocatable);
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
@@ -6629,8 +6497,10 @@ conv_null_actual (gfc_se * parmse, gfc_expr * e, gfc_symbol * fsym)
if (fsym->as && fsym->as->type == AS_ASSUMED_RANK)
{
tree tmp = parmse->expr;
- tmp = gfc_conv_scalar_to_descriptor (parmse, tmp, fsym->attr);
- gfc_conv_descriptor_rank_set (&parmse->pre, tmp, e->rank);
+ if (e->rank == 0)
+ tmp = gfc_conv_scalar_null_to_descriptor (parmse, fsym, e, tmp);
+ else
+ tmp = gfc_conv_null_array_descriptor (parmse, fsym, e);
parmse->expr = gfc_build_addr_expr (NULL_TREE, tmp);
}
else
@@ -7696,6 +7566,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e)
+ && !(fsym && fsym->as
+ && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
+ || fsym->as->type == AS_DEFERRED))
&& !(fsym && fsym->attr.pointer))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
@@ -7819,7 +7693,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Unallocated allocatable arrays and unassociated pointer
arrays need their dtype setting if they are argument
associated with assumed rank dummies to set the rank. */
- set_dtype_for_unallocated (&parmse, e);
+ //set_dtype_for_unallocated (&parmse, e);
}
else if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.dummy
@@ -8266,7 +8140,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = POINTER_TYPE_P (TREE_TYPE (caf_decl))
? build_fold_indirect_ref (caf_decl)
: caf_decl;
- tmp = gfc_conv_descriptor_token (tmp);
+ tmp = gfc_conv_descriptor_token_get (tmp);
}
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
@@ -8492,7 +8366,7 @@ 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->where);
+ &se->ss->info->expr->where, true);
/* Pass the temporary as the first argument. */
result = info->descriptor;
@@ -8528,7 +8402,11 @@ 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->where);
+ &se->ss->info->expr->where, true);
+
+ if (se->ss->info->class_container
+ && !se->class_container)
+ se->class_container = se->ss->info->class_container;
/* Pass the temporary as the first argument. */
result = info->descriptor;
@@ -8830,28 +8708,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
{
- int n;
- if (se->ss && se->ss->loop)
- {
- gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
- se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
- tmp = gfc_class_data_get (se->expr);
- info->descriptor = tmp;
- info->data = gfc_conv_descriptor_data_get (tmp);
- info->offset = gfc_conv_descriptor_offset_get (tmp);
- for (n = 0; n < se->ss->loop->dimen; n++)
- {
- tree dim = gfc_rank_cst[n];
- se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim);
- se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim);
- }
- }
- else
- {
- /* TODO Eliminate the doubling of temporaries. This
- one is necessary to ensure no memory leakage. */
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
- }
+ /* TODO Eliminate the doubling of temporaries. This
+ one is necessary to ensure no memory leakage. */
+ se->expr = gfc_evaluate_now (se->expr, &se->pre);
+
+ se->class_container = se->expr;
/* Finalize the result, if necessary. */
attr = expr->value.function.esym
@@ -9429,7 +9290,8 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
lss_array->offset = gfc_conv_array_offset (dest);
for (n = 0; n < cm->as->rank; n++)
{
- lss_array->start[n] = gfc_conv_array_lbound (dest, n);
+ lss_array->start[n] = lss_array->lbound[n] = gfc_conv_array_lbound (dest, n);
+ lss_array->spacing[n] = gfc_conv_array_spacing (dest, n);
lss_array->stride[n] = gfc_index_one_node;
mpz_init (lss_array->shape[n]);
@@ -9492,11 +9354,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
{
gfc_se se;
stmtblock_t block;
- tree offset;
- int n;
tree tmp;
- tree tmp2;
- gfc_array_spec *as;
gfc_expr *arg = NULL;
gfc_start_block (&block);
@@ -9557,10 +9415,6 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
- if (expr->expr_type != EXPR_VARIABLE)
- gfc_conv_descriptor_data_set (&block, se.expr,
- null_pointer_node);
-
/* We need to know if the argument of a conversion function is a
variable, so that the correct lower bound can be used. */
if (expr->expr_type == EXPR_FUNCTION
@@ -9570,71 +9424,21 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
- /* Obtain the array spec of full array references. */
- if (arg)
- as = gfc_get_full_arrayspec_from_expr (arg);
- else
- as = gfc_get_full_arrayspec_from_expr (expr);
-
- /* Shift the lbound and ubound of temporaries to being unity,
- rather than zero, based. Always calculate the offset. */
- gfc_conv_descriptor_offset_set (&block, dest, gfc_index_zero_node);
- offset = gfc_conv_descriptor_offset_get (dest);
- tmp2 =gfc_create_var (gfc_array_index_type, NULL);
-
- for (n = 0; n < expr->rank; n++)
- {
- tree span;
- tree lbound;
-
- /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
- TODO It looks as if gfc_conv_expr_descriptor should return
- the correct bounds and that the following should not be
- necessary. This would simplify gfc_conv_intrinsic_bound
- as well. */
- if (as && as->lower[n])
- {
- gfc_se lbse;
- gfc_init_se (&lbse, NULL);
- gfc_conv_expr (&lbse, as->lower[n]);
- gfc_add_block_to_block (&block, &lbse.pre);
- lbound = gfc_evaluate_now (lbse.expr, &block);
- }
- else if (as && arg)
- {
- tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
- lbound = gfc_conv_descriptor_lbound_get (tmp,
- gfc_rank_cst[n]);
- }
- else if (as)
- lbound = gfc_conv_descriptor_lbound_get (dest,
- gfc_rank_cst[n]);
- else
- lbound = gfc_index_one_node;
-
- lbound = fold_convert (gfc_array_index_type, lbound);
-
- /* Shift the bounds and set the offset accordingly. */
- tmp = gfc_conv_descriptor_ubound_get (dest, gfc_rank_cst[n]);
- span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- tmp, gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n]));
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- span, lbound);
- gfc_conv_descriptor_ubound_set (&block, dest,
- gfc_rank_cst[n], tmp);
- gfc_conv_descriptor_lbound_set (&block, dest,
- gfc_rank_cst[n], lbound);
+ stmtblock_t shift_block;
+ gfc_init_block (&shift_block);
+ gfc_conv_shift_descriptor_subarray (&shift_block, dest, expr, arg);
+
+ tree data = gfc_conv_descriptor_data_get (se.expr);
+ data = fold_convert (pvoid_type_node, data);
+ tree non_null = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ data, null_pointer_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ non_null, gfc_finish_block (&shift_block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- gfc_conv_descriptor_lbound_get (dest,
- gfc_rank_cst[n]),
- gfc_conv_descriptor_stride_get (dest,
- gfc_rank_cst[n]));
- gfc_add_modify (&block, tmp2, tmp);
- tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, tmp2);
- gfc_conv_descriptor_offset_set (&block, dest, tmp);
- }
+ if (expr->expr_type != EXPR_VARIABLE)
+ gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
if (arg)
{
@@ -10148,7 +9952,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
token
= is_array
- ? gfc_conv_descriptor_token (field)
+ ? gfc_conv_descriptor_token_get (field)
: fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (gfc_comp_caf_token (cm)), dest,
gfc_comp_caf_token (cm), NULL_TREE);
@@ -10656,7 +10460,12 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
if (!DECL_P (rse->expr))
{
if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
- class_expr = gfc_get_class_from_expr (rse->expr);
+ {
+ if (rse->class_container)
+ class_expr = rse->class_container;
+ else
+ class_expr = gfc_get_class_from_expr (rse->expr);
+ }
if (rse->loop)
pre = &rse->loop->pre;
@@ -10664,9 +10473,13 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
pre = &rse->pre;
if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
- tmp = gfc_evaluate_now (TREE_OPERAND (rse->expr, 0), &rse->pre);
+ {
+ tmp = gfc_build_addr_expr (NULL_TREE, rse->expr);
+ tmp = gfc_evaluate_now (tmp, &rse->pre);
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+ }
else
- tmp = gfc_evaluate_now (rse->expr, &rse->pre);
+ tmp = gfc_evaluate_now (rse->expr, &rse->pre);
rse->expr = tmp;
}
@@ -11062,7 +10875,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
if (expr2->expr_type == EXPR_NULL)
{
/* Just set the data pointer to null. */
- gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
+ gfc_nullify_descriptor (&lse.pre, expr1, lse.expr);
}
else if (rank_remap)
{
@@ -11085,7 +10898,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
tmp = gfc_typenode_for_spec (&expr2->ts);
tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0,
bound, bound, 0,
- GFC_ARRAY_POINTER_CONT, false);
+ GFC_ARRAY_POINTER_CONT, false,
+ expr2->ts.type);
tmp = gfc_create_var (tmp, "ptrtemp");
rse.descriptor_only = 0;
rse.expr = tmp;
@@ -11142,11 +10956,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
{
rse.expr = gfc_class_data_get (rse.expr);
gfc_add_modify (&lse.pre, desc, rse.expr);
- /* Set the lhs span. */
- tmp = TREE_TYPE (rse.expr);
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
- tmp = fold_convert (gfc_array_index_type, tmp);
- gfc_conv_descriptor_span_set (&lse.pre, desc, tmp);
}
else
{
@@ -11219,7 +11028,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
/* If we do bounds remapping, update LHS descriptor accordingly. */
if (remap)
{
- int dim;
gcc_assert (remap->u.ar.dimen == expr1->rank);
if (rank_remap)
@@ -11227,142 +11035,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
/* Do rank remapping. We already have the RHS's descriptor
converted in rse and now have to build the correct LHS
descriptor for it. */
-
- tree data, span;
- tree offs, stride;
- tree lbound, ubound;
-
- /* Set dtype. */
- gfc_conv_descriptor_dtype_set (&block, desc,
- gfc_get_dtype (TREE_TYPE (desc)));
-
- /* Copy data pointer. */
- data = gfc_conv_descriptor_data_get (rse.expr);
- gfc_conv_descriptor_data_set (&block, desc, data);
-
- /* Copy the span. */
- if (VAR_P (rse.expr)
- && GFC_DECL_PTR_ARRAY_P (rse.expr))
- span = gfc_conv_descriptor_span_get (rse.expr);
- else
- {
- tmp = TREE_TYPE (rse.expr);
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
- span = fold_convert (gfc_array_index_type, tmp);
- }
- gfc_conv_descriptor_span_set (&block, desc, span);
-
- /* Copy offset but adjust it such that it would correspond
- to a lbound of zero. */
- if (expr2->rank == -1)
- gfc_conv_descriptor_offset_set (&block, desc,
- gfc_index_zero_node);
- else
- {
- offs = gfc_conv_descriptor_offset_get (rse.expr);
- for (dim = 0; dim < expr2->rank; ++dim)
- {
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[dim]);
- lbound = gfc_conv_descriptor_lbound_get (rse.expr,
- gfc_rank_cst[dim]);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride,
- lbound);
- offs = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offs, tmp);
- }
- gfc_conv_descriptor_offset_set (&block, desc, offs);
- }
- /* Set the bounds as declared for the LHS and calculate strides as
- well as another offset update accordingly. */
- stride = gfc_conv_descriptor_stride_get (rse.expr,
- gfc_rank_cst[0]);
- for (dim = 0; dim < expr1->rank; ++dim)
- {
- gfc_se lower_se;
- gfc_se upper_se;
-
- gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
-
- if (remap->u.ar.start[dim]->expr_type != EXPR_CONSTANT
- || remap->u.ar.start[dim]->expr_type != EXPR_VARIABLE)
- gfc_resolve_expr (remap->u.ar.start[dim]);
- if (remap->u.ar.end[dim]->expr_type != EXPR_CONSTANT
- || remap->u.ar.end[dim]->expr_type != EXPR_VARIABLE)
- gfc_resolve_expr (remap->u.ar.end[dim]);
-
- /* Convert declared bounds. */
- gfc_init_se (&lower_se, NULL);
- gfc_init_se (&upper_se, NULL);
- gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
- gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
-
- gfc_add_block_to_block (&block, &lower_se.pre);
- gfc_add_block_to_block (&block, &upper_se.pre);
-
- lbound = fold_convert (gfc_array_index_type, lower_se.expr);
- ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
- lbound = gfc_evaluate_now (lbound, &block);
- ubound = gfc_evaluate_now (ubound, &block);
-
- gfc_add_block_to_block (&block, &lower_se.post);
- gfc_add_block_to_block (&block, &upper_se.post);
-
- /* Set bounds in descriptor. */
- gfc_conv_descriptor_lbound_set (&block, desc,
- gfc_rank_cst[dim], lbound);
- gfc_conv_descriptor_ubound_set (&block, desc,
- gfc_rank_cst[dim], ubound);
-
- /* Set stride. */
- stride = gfc_evaluate_now (stride, &block);
- gfc_conv_descriptor_stride_set (&block, desc,
- gfc_rank_cst[dim], stride);
-
- /* Update offset. */
- offs = gfc_conv_descriptor_offset_get (desc);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
- offs = gfc_evaluate_now (offs, &block);
- gfc_conv_descriptor_offset_set (&block, desc, offs);
-
- /* Update stride. */
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride, tmp);
- }
+ gfc_conv_remap_descriptor (&block, desc, rse.expr, expr2->rank,
+ remap->u.ar);
}
else
- {
- /* Bounds remapping. Just shift the lower bounds. */
-
- gcc_assert (expr1->rank == expr2->rank);
-
- for (dim = 0; dim < remap->u.ar.dimen; ++dim)
- {
- gfc_se lbound_se;
-
- gcc_assert (!remap->u.ar.end[dim]);
- gfc_init_se (&lbound_se, NULL);
- if (remap->u.ar.start[dim])
- {
- gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
- gfc_add_block_to_block (&block, &lbound_se.pre);
- }
- else
- /* This remap arises from a target that is not a whole
- array. The start expressions will be NULL but we need
- the lbounds to be one. */
- lbound_se.expr = gfc_index_one_node;
- gfc_conv_shift_descriptor_lbound (&block, desc,
- dim, lbound_se.expr);
- gfc_add_block_to_block (&block, &lbound_se.post);
- }
- }
+ /* Bounds remapping. Just shift the lower bounds. */
+ gfc_conv_shift_descriptor (&block, desc, remap->u.ar);
}
/* If rank remapping was done, check with -fcheck=bounds that
@@ -11605,10 +11283,10 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
{
if (flag_coarray == GFC_FCOARRAY_LIB && assoc_assign)
{
- gfc_add_modify (&block, gfc_conv_descriptor_token (lse->expr),
- TYPE_LANG_SPECIFIC (
- TREE_TYPE (TREE_TYPE (rse->expr)))
- ->caf_token);
+ tree token_value = TYPE_LANG_SPECIFIC (
+ TREE_TYPE (TREE_TYPE (rse->expr)))
+ ->caf_token;
+ gfc_conv_descriptor_token_set (&block, lse->expr, token_value);
}
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lse->expr)))
lse->expr = gfc_conv_array_data (lse->expr);
@@ -11811,7 +11489,6 @@ fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
tree desc;
tree res_desc;
tree tmp;
- tree offset;
tree zero_cond;
tree not_same_shape;
stmtblock_t shape_block;
@@ -11824,11 +11501,9 @@ fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
desc = build_fold_indirect_ref_loc (input_location, desc);
/* Unallocated, the descriptor does not have a dtype. */
- if (dtype != NULL_TREE)
- gfc_conv_descriptor_dtype_set (&se->pre, desc, dtype);
- else
- gfc_conv_descriptor_dtype_set (&se->pre, desc,
- gfc_get_dtype (TREE_TYPE (desc)));
+ if (dtype == NULL_TREE)
+ dtype = gfc_get_dtype (TREE_TYPE (desc));
+ gfc_conv_descriptor_dtype_set (&se->pre, desc, dtype);
res_desc = gfc_evaluate_now (desc, &se->pre);
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
@@ -11844,9 +11519,6 @@ fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
tmp = gfc_call_free (tmp);
gfc_add_expr_to_block (&se->post, tmp);
- tmp = gfc_conv_descriptor_data_get (res_desc);
- gfc_conv_descriptor_data_set (&se->post, desc, tmp);
-
/* Check that the shapes are the same between lhs and expression.
The evaluation of the shape is done in 'shape_block' to avoid
unitialized warnings from the lhs bounds. */
@@ -11890,37 +11562,7 @@ fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
/* Now reset the bounds returned from the function call to bounds based
on the lhs lbounds, except where the lhs is not allocated or the shapes
of 'variable and 'expr' are different. Set the offset accordingly. */
- offset = gfc_index_zero_node;
- for (n = 0 ; n < rank; n++)
- {
- tree lbound;
-
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]);
- lbound = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, zero_cond,
- gfc_index_one_node, lbound);
- lbound = gfc_evaluate_now (lbound, &se->post);
-
- tmp = gfc_conv_descriptor_ubound_get (res_desc, gfc_rank_cst[n]);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp, lbound);
- gfc_conv_descriptor_lbound_set (&se->post, desc,
- gfc_rank_cst[n], lbound);
- gfc_conv_descriptor_ubound_set (&se->post, desc,
- gfc_rank_cst[n], tmp);
-
- /* Set stride and accumulate the offset. */
- tmp = gfc_conv_descriptor_stride_get (res_desc, gfc_rank_cst[n]);
- gfc_conv_descriptor_stride_set (&se->post, desc,
- gfc_rank_cst[n], tmp);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, lbound, tmp);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offset, tmp);
- offset = gfc_evaluate_now (offset, &se->post);
- }
-
- gfc_conv_descriptor_offset_set (&se->post, desc, offset);
+ gfc_conv_shift_descriptor (&se->post, desc, res_desc, rank, zero_cond);
}
@@ -12861,11 +12503,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
if (gfc_is_reallocatable_lhs (expr1))
{
lss->no_bounds_check = 1;
- if (!(expr2->expr_type == EXPR_FUNCTION
- && expr2->value.function.isym != NULL
- && !(expr2->value.function.isym->elemental
- || expr2->value.function.isym->conversion)))
- lss->is_alloc_lhs = 1;
+ lss->is_alloc_lhs = 1;
}
else
lss->no_bounds_check = expr1->no_bounds_check;
@@ -12929,6 +12567,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp);
}
+ tree reallocation = NULL_TREE;
if (lss != gfc_ss_terminator)
{
/* The assignment needs scalarization. */
@@ -12947,8 +12586,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
/* Walk the rhs. */
rss = gfc_walk_expr (expr2);
if (rss == gfc_ss_terminator)
- /* The rhs is scalar. Add a ss for the expression. */
- rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ {
+ /* The rhs is scalar. Add a ss for the expression. */
+ rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
+ lss->is_alloc_lhs = 0;
+ }
+
/* When doing a class assign, then the handle to the rhs needs to be a
pointer to allow for polymorphism. */
if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2))
@@ -12966,7 +12609,11 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
loop.reverse[n] = GFC_ENABLE_REVERSE;
/* Resolve any data dependencies in the statement. */
if (may_alias)
- gfc_conv_resolve_dependencies (&loop, lss, rss);
+ {
+ gfc_conv_resolve_dependencies (&loop, lss, rss);
+ if (loop.temp_ss)
+ loop.temp_ss->info->expr = expr2;
+ }
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop, &expr2->where);
@@ -12997,6 +12644,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
}
+ /* F2003: Allocate or reallocate lhs of allocatable array. */
+ if (realloc_flag)
+ {
+ realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
+ ompws_flags &= ~OMPWS_SCALARIZER_WS;
+ reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
+ }
+
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop, &body);
}
@@ -13196,10 +12851,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
references. Use the vptr copy function, since this does a deep
copy of allocatable components, without which the finalizer call
will deallocate the components. */
- tmp = gfc_get_vptr_from_expr (rse.expr);
- if (tmp != NULL_TREE)
+ tree cls = rse.class_container;
+ tree vptr;
+ if (cls == NULL_TREE)
+ vptr = gfc_get_vptr_from_expr (rse.expr);
+ else
+ vptr = gfc_class_vptr_get (cls);
+ if (vptr != NULL_TREE)
{
- tree fcn = gfc_vptr_copy_get (tmp);
+ tree fcn = gfc_vptr_copy_get (vptr);
if (POINTER_TYPE_P (TREE_TYPE (fcn)))
fcn = build_fold_indirect_ref_loc (input_location, fcn);
tmp = build_call_expr_loc (input_location,
@@ -13305,15 +12965,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_expr_to_block (&body, tmp);
}
- /* F2003: Allocate or reallocate lhs of allocatable array. */
- if (realloc_flag)
- {
- realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
- ompws_flags &= ~OMPWS_SCALARIZER_WS;
- tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2);
- if (tmp != NULL_TREE)
- gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp);
- }
+ if (reallocation != NULL_TREE)
+ gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation);
if (maybe_workshare)
ompws_flags &= ~OMPWS_SCALARIZER_BODY;
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index f2e57c5ddece..b92a536bea0a 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -39,11 +39,11 @@ along with GCC; see the file COPYING3. If not see
#include "trans-const.h"
#include "trans-types.h"
#include "trans-array.h"
-#include "trans-descriptor.h"
#include "dependency.h" /* For CAF array alias analysis. */
#include "attribs.h"
#include "realmpfr.h"
#include "constructor.h"
+#include "trans-descriptor.h"
/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
@@ -1289,7 +1289,8 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs,
/* Create temporary. */
may_realloc = gfc_trans_create_temp_array (&se->pre, &se->post, se->ss,
type, NULL_TREE, false, false,
- false, &array_expr->where)
+ false, &array_expr->where,
+ true)
== NULL_TREE;
res_var = se->ss->info->data.array.descriptor;
if (array_expr->ts.type == BT_CHARACTER)
@@ -1824,8 +1825,8 @@ static void
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, team;
+ tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
+ lbound, extent, ml, team;
gfc_se argse;
int rank, corank;
@@ -1991,9 +1992,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 = gfc_conv_descriptor_extent_get (desc, loop_var);
extent = fold_convert (type, extent);
/* m = m/extent. */
@@ -2163,7 +2162,8 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
thus we need explicitly check this - and return 0 if they are exceeded. */
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
- tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], false, NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (TREE_TYPE (subse.expr), 0));
invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
fold_convert (gfc_array_index_type, tmp),
lbound);
@@ -2172,7 +2172,10 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
{
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
- tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], false,
+ NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (TREE_TYPE (subse.expr),
+ 0));
cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
fold_convert (gfc_array_index_type, tmp),
lbound);
@@ -2191,8 +2194,9 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
/* coindex = sub(corank) - lcobound(n). */
coindex = fold_convert (gfc_array_index_type,
- gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
- NULL));
+ gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+ false, NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (TREE_TYPE (subse.expr), 0)));
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
fold_convert (gfc_array_index_type, coindex),
@@ -2200,19 +2204,19 @@ 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,
gfc_array_index_type, coindex, extent);
/* coindex += sub(codim). */
- tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], false,
+ NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (TREE_TYPE (subse.expr), 0));
coindex = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, coindex,
fold_convert (gfc_array_index_type, tmp));
@@ -2313,7 +2317,7 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
{
gfc_ss *ss;
gfc_se argse;
- tree desc, tmp, stride, extent, cond;
+ tree desc, tmp, extent, cond;
int i;
tree fncall0;
gfc_array_spec *as;
@@ -2351,25 +2355,19 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
gfc_add_block_to_block (&se->post, &argse.post);
desc = gfc_evaluate_now (argse.expr, &se->pre);
- stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
+ tree spacing = gfc_conv_descriptor_spacing_get (desc, gfc_rank_cst[0]);
cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- stride, build_int_cst (TREE_TYPE (stride), 1));
+ spacing, gfc_conv_descriptor_span_get (desc));
for (i = 0; i < arg->rank - 1; i++)
{
- tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
- extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
- extent = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, extent, tmp);
- extent = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, extent,
- gfc_index_one_node);
- tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
+ extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[i]);
+ tmp = gfc_conv_descriptor_spacing_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
tmp, extent);
- stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
+ spacing = gfc_conv_descriptor_spacing_get (desc, gfc_rank_cst[i+1]);
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- stride, tmp);
+ spacing, tmp);
cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
boolean_type_node, cond, tmp);
}
@@ -2483,10 +2481,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
ubound = gfc_conv_descriptor_ubound_get (desc, bound);
lbound = gfc_conv_descriptor_lbound_get (desc, bound);
- size = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, ubound, lbound);
- size = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, size, gfc_index_one_node);
+ size = gfc_conv_descriptor_extent_get (desc, bound);
/* 13.14.53: Result value for LBOUND
@@ -2774,7 +2769,7 @@ conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
gfc_add_block_to_block (&se->pre, &argse.pre);
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
argse.expr, gfc_index_one_node);
- se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
+ se->expr = gfc_conv_descriptor_spacing_get (desc, tmp);
}
static void
@@ -4997,12 +4992,13 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
as.rank = 1;
as.lower[0] = gfc_get_int_expr (gfc_index_integer_kind,
&arrayexpr->where,
- HOST_WIDE_INT_1);
+ HOST_WIDE_INT_0);
as.upper[0] = gfc_get_int_expr (gfc_index_integer_kind,
&arrayexpr->where,
- arrayexpr->rank);
+ arrayexpr->rank - 1);
- tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
+ tree array = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true,
+ BT_INTEGER);
result_var = gfc_create_var (array, "loc_result");
}
@@ -5558,8 +5554,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
for (int i = 0; i < arrayexpr->rank; i++)
{
tree res_idx = build_int_cst (gfc_array_index_type, i);
- tree res_arr_ref = gfc_build_array_ref (result_var, res_idx,
- NULL_TREE, true);
+ tree res_arr_ref = gfc_build_array_ref (result_var, res_idx, true);
tree value = convert (type, pos[i]);
gfc_add_modify (&se->pre, res_arr_ref, value);
@@ -8141,8 +8136,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
gfc_se argse;
tree source_bytes;
tree tmp;
- tree lower;
- tree upper;
tree byte_size;
int n;
@@ -8168,7 +8161,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
tmp = gfc_conv_descriptor_elem_len_get (tmp);
-
byte_size = fold_convert (gfc_array_index_type, tmp);
}
else if (arg->ts.type == BT_CLASS)
@@ -8254,9 +8246,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
- lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
- upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
- tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
+ tmp = gfc_conv_descriptor_extent_get (argse.expr, loop_var);
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, source_bytes);
gfc_add_modify (&body, source_bytes, tmp);
@@ -8282,9 +8272,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
{
tree idx;
idx = gfc_rank_cst[n];
- lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
- upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
- tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
+ tmp = gfc_conv_descriptor_extent_get (argse.expr, idx);
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, source_bytes);
gfc_add_modify (&argse.pre, source_bytes, tmp);
@@ -8441,7 +8429,6 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
tree size_words;
tree size_bytes;
tree upper;
- tree lower;
tree stmt;
tree class_ref = NULL_TREE;
gfc_actual_arglist *arg;
@@ -8595,16 +8582,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
tree idx;
idx = gfc_rank_cst[n];
gfc_add_modify (&argse.pre, source_bytes, tmp);
- lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
- upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, upper, lower);
+ tmp = gfc_conv_descriptor_extent_get (argse.expr, idx);
gfc_add_modify (&argse.pre, extent, tmp);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, extent,
- gfc_index_one_node);
tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp, source_bytes);
+ gfc_array_index_type, extent, source_bytes);
}
}
@@ -8747,7 +8728,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->where,
+ true);
/* Cast the pointer to the result. */
tmp = gfc_conv_descriptor_data_get (info->descriptor);
@@ -9041,7 +9023,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
}
else
tmp = gfc_rank_cst[arg1->expr->rank - 1];
- tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
+ tmp = gfc_conv_descriptor_spacing_get (arg1se.expr, tmp);
if (arg2->expr->rank != 0)
nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
logical_type_node, tmp,
@@ -9849,11 +9831,8 @@ conv_isocbinding_subroutine (gfc_code *code)
gfc_se se;
gfc_se cptrse;
gfc_se fptrse;
- gfc_se shapese;
- gfc_ss *shape_ss;
- tree desc, dim, tmp, stride, offset;
- stmtblock_t body, block;
- gfc_loopinfo loop;
+ tree desc;
+ stmtblock_t block;
gfc_actual_arglist *arg = code->ext.actual;
gfc_init_se (&se, NULL);
@@ -9891,74 +9870,11 @@ conv_isocbinding_subroutine (gfc_code *code)
gfc_add_block_to_block (&block, &fptrse.pre);
desc = fptrse.expr;
- /* Set the span field. */
- tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
- tmp = fold_convert (gfc_array_index_type, tmp);
- gfc_conv_descriptor_span_set (&block, desc, tmp);
-
- /* Set data value, 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_conv_descriptor_dtype_set (&block, desc,
- gfc_get_dtype (TREE_TYPE (desc)));
-
- /* Start scalarization of the bounds, using the shape argument. */
+ gfc_set_descriptor_with_shape (&block, desc, cptrse.expr,
+ arg->next->next->expr,
+ &arg->next->expr->where);
- shape_ss = gfc_walk_expr (arg->next->next->expr);
- gcc_assert (shape_ss != gfc_ss_terminator);
- gfc_init_se (&shapese, NULL);
-
- 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_mark_ss_chain_used (shape_ss, 1);
-
- gfc_copy_loopinfo_to_se (&shapese, &loop);
- shapese.ss = shape_ss;
-
- stride = gfc_create_var (gfc_array_index_type, "stride");
- offset = gfc_create_var (gfc_array_index_type, "offset");
- gfc_add_modify (&block, stride, gfc_index_one_node);
- gfc_add_modify (&block, offset, gfc_index_zero_node);
-
- /* Loop body. */
- gfc_start_scalarized_body (&loop, &body);
-
- dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- loop.loopvar[0], loop.from[0]);
-
- /* Set bounds and stride. */
- gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
-
- gfc_conv_expr (&shapese, arg->next->next->expr);
- gfc_add_block_to_block (&body, &shapese.pre);
- gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
- gfc_add_block_to_block (&body, &shapese.post);
-
- /* Calculate offset. */
- gfc_add_modify (&body, offset,
- fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, offset, stride));
- /* Update stride. */
- gfc_add_modify (&body, stride,
- fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, stride,
- fold_convert (gfc_array_index_type,
- shapese.expr)));
- /* Finish scalarization loop. */
- gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
gfc_add_block_to_block (&block, &fptrse.post);
- gfc_cleanup_loop (&loop);
-
- gfc_add_modify (&block, offset,
- fold_build1_loc (input_location, NEGATE_EXPR,
- gfc_array_index_type, offset));
- gfc_conv_descriptor_offset_set (&block, desc, offset);
-
gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
gfc_add_block_to_block (&se.pre, &se.post);
return gfc_finish_block (&se.pre);
@@ -11537,7 +11453,7 @@ static gfc_ss *
nest_loop_dimension (gfc_ss *ss, int dim)
{
int ss_dim, i;
- gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
+ gfc_ss *new_ss = nullptr, *prev_ss = gfc_ss_terminator;
gfc_loopinfo *new_loop;
gcc_assert (ss != gfc_ss_terminator);
@@ -12701,7 +12617,7 @@ conv_intrinsic_event_query (gfc_code *code)
/* For arrays, obtain the array index. */
if (gfc_expr_attr (event_expr).dimension)
{
- tree desc, tmp, extent, lbound, ubound;
+ tree desc, tmp, extent, lbound;
gfc_array_ref *ar, ar2;
int i;
@@ -12734,8 +12650,7 @@ conv_intrinsic_event_query (gfc_code *code)
TREE_TYPE (tmp), index, tmp);
if (i < ar->dimen - 1)
{
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[i]);
extent = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
}
@@ -13097,6 +13012,8 @@ conv_intrinsic_move_alloc (gfc_code *code)
}
gfc_conv_expr_descriptor (&to_se, to_expr);
gfc_conv_expr_descriptor (&from_se, from_expr);
+ gfc_add_block_to_block (&block, &to_se.pre);
+ gfc_add_block_to_block (&block, &from_se.pre);
/* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
is an image control "statement", cf. IR F08/0040 in 12-006A. */
@@ -13154,8 +13071,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
{
/* Copy the array descriptor data has overwritten the to-token and cleared
from.data. Now also clear the from.token. */
- gfc_add_modify (&block, gfc_conv_descriptor_token (from_se.expr),
- null_pointer_node);
+ gfc_conv_descriptor_token_set (&block, from_se.expr, null_pointer_node);
}
if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
@@ -13170,6 +13086,9 @@ conv_intrinsic_move_alloc (gfc_code *code)
if (fin_label)
gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, fin_label));
+ gfc_add_block_to_block (&block, &to_se.post);
+ gfc_add_block_to_block (&block, &from_se.post);
+
return gfc_finish_block (&block);
}
diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 5ba7689ac128..f0f397de45dd 100644
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -32,8 +32,8 @@ along with GCC; see the file COPYING3. If not see
#include "trans-array.h"
#include "trans-types.h"
#include "trans-const.h"
-#include "trans-descriptor.h"
#include "options.h"
+#include "trans-descriptor.h"
/* Members of the ioparm structure. */
@@ -751,7 +751,7 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
if (e->rank == 0)
{
- tree type, array, tmp;
+ tree type, array;
gfc_symbol *sym;
int rank;
@@ -765,40 +765,37 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
array = sym->backend_decl;
type = TREE_TYPE (array);
- tree elts_count;
+ tree elts_count = NULL_TREE;
+ tree full_size = NULL_TREE;
if (GFC_ARRAY_TYPE_P (type))
elts_count = GFC_TYPE_ARRAY_SIZE (type);
else
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
- tree stride = gfc_conv_array_stride (array, rank);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- gfc_conv_array_ubound (array, rank),
- gfc_conv_array_lbound (array, rank));
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp,
- gfc_index_one_node);
- elts_count = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp, stride);
+ tree spacing = gfc_conv_array_spacing (array, rank);
+ tree tmp = gfc_conv_array_extent (array, rank);
+ full_size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, spacing);
}
- gcc_assert (elts_count);
+ gcc_assert (elts_count || full_size);
tree elt_size = TYPE_SIZE_UNIT (gfc_get_element_type (type));
elt_size = fold_convert (gfc_array_index_type, elt_size);
- tree size;
+ if (full_size == NULL_TREE)
+ full_size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, elts_count,
+ elt_size);
+
+ tree offset;
if (TREE_CODE (se->expr) == ARRAY_REF)
{
tree index = TREE_OPERAND (se->expr, 1);
index = fold_convert (gfc_array_index_type, index);
- elts_count = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- elts_count, index);
-
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, elts_count, elt_size);
+ offset = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, index,
+ elt_size);
}
else
{
@@ -806,15 +803,13 @@ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
tree ptr = TREE_OPERAND (se->expr, 0);
gcc_assert (TREE_CODE (ptr) == POINTER_PLUS_EXPR);
- tree offset = fold_convert_loc (input_location, gfc_array_index_type,
- TREE_OPERAND (ptr, 1));
-
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, elts_count, elt_size);
- size = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, size, offset);
+ offset = fold_convert_loc (input_location, gfc_array_index_type,
+ TREE_OPERAND (ptr, 1));
}
- gcc_assert (size);
+
+ gcc_assert (offset);
+ tree size = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, full_size, offset);
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
se->string_length = fold_convert (gfc_charlen_type_node, size);
@@ -1657,7 +1652,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
- tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
+ tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, false,
+ NULL_TREE, GFC_TYPE_ARRAY_SPACING (tmp, 0));
if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
tmp = build_fold_indirect_ref_loc (input_location,
@@ -1823,7 +1819,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
iocall[IOCALL_SET_NML_VAL_DIM], 5,
dt_parm_addr,
build_int_cst (gfc_int4_type_node, n_dim),
- gfc_conv_array_stride (decl, n_dim),
+ gfc_conv_array_spacing (decl, n_dim),
gfc_conv_array_lbound (decl, n_dim),
gfc_conv_array_ubound (decl, n_dim));
gfc_add_expr_to_block (block, tmp);
@@ -2203,6 +2199,8 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
cm->as->lower[n]->value.integer);
mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
}
+
+ gfc_conv_array_lbound_spacing (&block, ss, n);
}
/* Once we got ss, we use scalarizer to create the loop. */
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index d9e47fef9b5d..137312e57d1f 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -38,7 +38,6 @@ along with GCC; see the file COPYING3. If not see
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
-#include "trans-descriptor.h"
#include "arith.h"
#include "constructor.h"
#include "gomp-constants.h"
@@ -48,6 +47,7 @@ along with GCC; see the file COPYING3. If not see
#include "dependency.h"
#include "gimple-iterator.h" /* For gsi_iterator_update. */
#include "gimplify-me.h" /* For force_gimple_operand. */
+#include "trans-descriptor.h"
#undef GCC_DIAG_STYLE
#define GCC_DIAG_STYLE __gcc_tdiag__
@@ -248,7 +248,8 @@ gfc_omp_privatize_by_reference (const_tree decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
|| GFC_DECL_CRAY_POINTEE (decl)
|| GFC_DECL_ASSOCIATE_VAR_P (decl)
- || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
+ || VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
+ || !TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl))))
return false;
if (!DECL_ARTIFICIAL (decl)
@@ -644,13 +645,15 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var,
gfc_init_block (&tmpblock);
tem = gfc_conv_array_data (decl);
tree declvar = build_fold_indirect_ref_loc (input_location, tem);
- tree declvref = gfc_build_array_ref (declvar, index, NULL);
+ tree declvref = gfc_build_array_ref (declvar, index, false, NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (declvar, 0));
tree destvar, destvref = NULL_TREE;
if (dest)
{
tem = gfc_conv_array_data (dest);
destvar = build_fold_indirect_ref_loc (input_location, tem);
- destvref = gfc_build_array_ref (destvar, index, NULL);
+ destvref = gfc_build_array_ref (destvar, index, false, NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (declvar, 0));
}
gfc_add_expr_to_block (&tmpblock,
gfc_walk_alloc_comps (declvref, destvref,
@@ -829,20 +832,17 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
{
gfc_add_modify (&cond_block, decl, outer);
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
- size = gfc_conv_descriptor_ubound_get (decl, rank);
- size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- size,
- gfc_conv_descriptor_lbound_get (decl, rank));
- size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- size, gfc_index_one_node);
- if (GFC_TYPE_ARRAY_RANK (type) > 1)
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size,
- gfc_conv_descriptor_stride_get (decl, rank));
- tree esize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = gfc_conv_descriptor_extent_get (decl, rank);
+ tree spacing;
+ if (GFC_TYPE_ARRAY_RANK (type) >= 1)
+ spacing = gfc_conv_descriptor_spacing_get (decl, rank);
+ else
+ {
+ tree esize = gfc_conv_descriptor_span_get (decl);
+ spacing = fold_convert_loc (input_location, gfc_array_index_type, esize);
+ }
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size, esize);
+ size, spacing);
size = unshare_expr (size);
size = gfc_evaluate_now (fold_convert (size_type_node, size),
&cond_block);
@@ -1020,20 +1020,17 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
if (GFC_DESCRIPTOR_TYPE_P (type))
{
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
- size = gfc_conv_descriptor_ubound_get (dest, rank);
- size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- size,
- gfc_conv_descriptor_lbound_get (dest, rank));
- size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- size, gfc_index_one_node);
- if (GFC_TYPE_ARRAY_RANK (type) > 1)
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size,
- gfc_conv_descriptor_stride_get (dest, rank));
- tree esize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = gfc_conv_descriptor_extent_get (dest, rank);
+ tree spacing;
+ if (GFC_TYPE_ARRAY_RANK (type) >= 1)
+ spacing = gfc_conv_descriptor_spacing_get (dest, rank);
+ else
+ {
+ tree esize = gfc_conv_descriptor_span_get (dest);
+ spacing = fold_convert_loc (input_location, gfc_array_index_type, esize);
+ }
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size, esize);
+ size, spacing);
size = unshare_expr (size);
size = gfc_evaluate_now (fold_convert (size_type_node, size),
&cond_block);
@@ -1143,20 +1140,19 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
if (GFC_DESCRIPTOR_TYPE_P (type))
{
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
- size = gfc_conv_descriptor_ubound_get (src, rank);
- size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- size,
- gfc_conv_descriptor_lbound_get (src, rank));
- size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- size, gfc_index_one_node);
- if (GFC_TYPE_ARRAY_RANK (type) > 1)
- size = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, size,
- gfc_conv_descriptor_stride_get (src, rank));
- tree esize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ size = gfc_conv_descriptor_extent_get (src, rank);
+ tree spacing;
+ if (GFC_TYPE_ARRAY_RANK (type) >= 1)
+ {
+ spacing = gfc_conv_descriptor_spacing_get (src, rank);
+ }
+ else
+ {
+ tree esize = gfc_conv_descriptor_span_get (src);
+ spacing = fold_convert_loc (input_location, gfc_array_index_type, esize);
+ }
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- size, esize);
+ size, spacing);
size = unshare_expr (size);
size = gfc_evaluate_now (fold_convert (size_type_node, size),
&cond_block);
@@ -1180,15 +1176,9 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
for (i = 0; i < GFC_TYPE_ARRAY_RANK (type); i++)
{
tree rank = gfc_rank_cst[i];
- tree tem = gfc_conv_descriptor_ubound_get (src, rank);
- tem = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, tem,
- gfc_conv_descriptor_lbound_get (src, rank));
- tem = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tem,
- gfc_conv_descriptor_lbound_get (dest, rank));
+ tree tem = gfc_conv_descriptor_extent_get (src, rank);
tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- tem, gfc_conv_descriptor_ubound_get (dest,
+ tem, gfc_conv_descriptor_extent_get (dest,
rank));
cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
logical_type_node, cond, tem);
@@ -1291,8 +1281,10 @@ gfc_omp_linear_clause_add_loop (stmtblock_t *block, tree dest, tree src,
gfc_init_block (&tmpblock);
if (TREE_CODE (TREE_TYPE (dest)) == ARRAY_TYPE)
{
- desta = gfc_build_array_ref (dest, index, NULL);
- srca = gfc_build_array_ref (src, index, NULL);
+ desta = gfc_build_array_ref (dest, index, false, NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (dest, 0));
+ srca = gfc_build_array_ref (src, index, false, NULL_TREE,
+ GFC_TYPE_ARRAY_SPACING (src, 0));
}
else
{
@@ -1374,12 +1366,7 @@ gfc_omp_clause_linear_ctor (tree clause, tree dest, tree src, tree add)
if (GFC_DESCRIPTOR_TYPE_P (type))
{
tree rank = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (type) - 1];
- size = gfc_conv_descriptor_ubound_get (dest, rank);
- size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- size,
- gfc_conv_descriptor_lbound_get (dest, rank));
- size = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- size, gfc_index_one_node);
+ size = gfc_conv_descriptor_extent_get (dest, rank);
if (GFC_TYPE_ARRAY_RANK (type) > 1)
size = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, size,
@@ -2693,7 +2680,7 @@ gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type)
{
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_LBOUND (type, r));
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_UBOUND (type, r));
- omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_STRIDE (type, r));
+ omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SPACING (type, r));
}
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_SIZE (type));
omp_firstprivatize_variable (ctx, GFC_TYPE_ARRAY_OFFSET (type));
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 5817c6ab4fb2..81645f0b78fe 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -33,8 +33,8 @@ along with GCC; see the file COPYING3. If not see
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
-#include "trans-descriptor.h"
#include "dependency.h"
+#include "trans-descriptor.h"
typedef struct iter_info
{
@@ -200,14 +200,6 @@ replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
*sess = new_ss;
new_ss->next = old_ss->next;
- /* Make sure that trailing references are not lost. */
- if (old_ss->info
- && old_ss->info->data.array.ref
- && old_ss->info->data.array.ref->next
- && !(new_ss->info->data.array.ref
- && new_ss->info->data.array.ref->next))
- new_ss->info->data.array.ref = old_ss->info->data.array.ref;
-
for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
loopss = &((*loopss)->loop_chain))
if (*loopss == old_ss)
@@ -326,7 +318,7 @@ 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, &arg->expr->where, true);
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);
@@ -506,7 +498,7 @@ gfc_trans_call (gfc_code * code, bool dependency_check,
{
/* Form the mask expression according to the mask. */
index = count1;
- maskexpr = gfc_build_array_ref (mask, index, NULL);
+ maskexpr = gfc_build_array_ref (mask, index, true);
if (invert)
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (maskexpr), maskexpr);
@@ -979,7 +971,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
/* For arrays, obtain the array index. */
if (gfc_expr_attr (code->expr1).dimension)
{
- tree desc, tmp, extent, lbound, ubound;
+ tree desc, tmp, extent, lbound;
gfc_array_ref *ar, ar2;
int i, rank;
@@ -1015,8 +1007,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
TREE_TYPE (tmp), index, tmp);
if (i < ar->dimen - 1)
{
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[i]);
extent = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
}
@@ -1180,7 +1171,7 @@ gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
/* For arrays, obtain the array index. */
if (gfc_expr_attr (code->expr1).dimension)
{
- tree desc, tmp, extent, lbound, ubound;
+ tree desc, tmp, extent, lbound;
gfc_array_ref *ar, ar2;
int i;
@@ -1213,8 +1204,7 @@ gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
TREE_TYPE (tmp), index, tmp);
if (i < ar->dimen - 1)
{
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tmp = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[i]);
extent = fold_build2_loc (input_location, MULT_EXPR,
TREE_TYPE (tmp), extent, tmp);
}
@@ -1755,48 +1745,6 @@ class_has_len_component (gfc_symbol *sym)
}
-static void
-copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
-{
- int n;
- tree dim;
- tree tmp;
- tree tmp2;
- tree size;
- tree offset;
-
- offset = gfc_index_zero_node;
-
- /* Use memcpy to copy the descriptor. The size is the minimum of
- the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
- tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
- size = fold_build2_loc (input_location, MIN_EXPR,
- TREE_TYPE (tmp), tmp, tmp2);
- tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
- tmp = build_call_expr_loc (input_location, tmp, 3,
- gfc_build_addr_expr (NULL_TREE, dst),
- gfc_build_addr_expr (NULL_TREE, src),
- fold_convert (size_type_node, size));
- gfc_add_expr_to_block (block, tmp);
-
- /* Set the offset correctly. */
- for (n = 0; n < rank; n++)
- {
- dim = gfc_rank_cst[n];
- tmp = gfc_conv_descriptor_lbound_get (src, dim);
- tmp2 = gfc_conv_descriptor_stride_get (src, dim);
- tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
- tmp, tmp2);
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- TREE_TYPE (offset), offset, tmp);
- offset = gfc_evaluate_now (offset, block);
- }
-
- gfc_conv_descriptor_offset_set (block, dst, offset);
-}
-
-
/* Do proper initialization for ASSOCIATE names. */
static void
@@ -1807,9 +1755,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
bool class_target;
bool unlimited;
tree desc;
- tree offset;
- tree dim;
- int n;
tree charlen;
bool need_len_assign;
bool whole_array = true;
@@ -1928,7 +1873,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
attributes so the selector descriptor must be copied in and
copied out. */
if (rank > 0)
- copy_descriptor (&se.pre, desc, se.expr, rank);
+ gfc_copy_descriptor (&se.pre, desc, se.expr, rank);
else
{
tmp = gfc_conv_descriptor_data_get (se.expr);
@@ -1957,7 +1902,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
|| CLASS_DATA (sym)->attr.pointer)))
{
if (rank > 0)
- copy_descriptor (&se.post, se.expr, desc, rank);
+ gfc_copy_descriptor (&se.post, se.expr, desc, rank);
else
gfc_conv_descriptor_data_set (&se.post, se.expr, desc);
@@ -2102,26 +2047,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
if ((!sym->assoc->variable && !cst_array_ctor)
|| !whole_array)
{
- int dim;
-
if (whole_array)
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&se.pre, desc,
- dim, gfc_index_one_node);
- }
-
- /* If this is a subreference array pointer associate name use the
- associate variable element size for the value of 'span'. */
- if (sym->attr.subref_array_pointer && !se.direct_byref)
- {
- gcc_assert (e->expr_type == EXPR_VARIABLE);
- tmp = gfc_get_array_span (se.expr, e);
-
- gfc_conv_descriptor_span_set (&se.pre, desc, tmp);
+ gfc_conv_shift_descriptor (&se.pre, desc, e->rank);
}
if (e->expr_type == EXPR_FUNCTION
@@ -2191,8 +2122,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
/* Recover the dtype, which has been overwritten by the
assignment from an unlimited polymorphic object. */
- tree tmp = gfc_get_dtype (TREE_TYPE (sym->backend_decl));
- gfc_conv_descriptor_dtype_set (&se.pre, sym->backend_decl, tmp);
+ tree dtype_val = gfc_get_dtype (TREE_TYPE (sym->backend_decl));
+ gfc_conv_descriptor_dtype_set (&se.pre, sym->backend_decl, dtype_val);
}
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
@@ -2233,21 +2164,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
desc = gfc_class_data_get (se.expr);
- /* Set the offset. */
- offset = gfc_index_zero_node;
- for (n = 0; n < e->rank; n++)
- {
- dim = gfc_rank_cst[n];
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type,
- gfc_conv_descriptor_stride_get (desc, dim),
- gfc_conv_descriptor_lbound_get (desc, dim));
- offset = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- offset, tmp);
- }
- gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
-
if (need_len_assign)
{
if (e->symtree
@@ -2424,9 +2340,10 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
tmp = sym->backend_decl;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_conv_descriptor_data_get (tmp);
- gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
- null_pointer_node));
+ gfc_conv_descriptor_data_set (&se.pre, tmp, null_pointer_node);
+ else
+ gfc_add_modify (&se.pre, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
}
lhs = gfc_lval_expr_from_sym (sym);
@@ -3959,8 +3876,10 @@ gfc_trans_select_rank_cases (gfc_code * code)
/* Calculate the switch expression. */
gfc_init_se (&se, NULL);
gfc_conv_expr_descriptor (&se, code->expr1);
+ gfc_add_block_to_block (&block, &se.pre);
rank = gfc_conv_descriptor_rank_get (se.expr);
rank = gfc_evaluate_now (rank, &block);
+ gfc_add_block_to_block (&block, &se.post);
symbol_attribute attr = gfc_expr_attr (code->expr1);
if (!attr.pointer && !attr.allocatable)
{
@@ -4147,13 +4066,6 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
gfc_add_block_to_block (pre, &tse.pre);
gfc_add_block_to_block (post, &tse.post);
tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
-
- if (c->expr1->ref->u.ar.type != AR_SECTION)
- {
- /* Use the variable offset for the temporary. */
- tmp = gfc_conv_array_offset (old_sym->backend_decl);
- gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
- }
}
else
{
@@ -4446,7 +4358,7 @@ gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
/* If a mask was specified make the assignment conditional. */
if (mask)
{
- tmp = gfc_build_array_ref (mask, maskindex, NULL);
+ tmp = gfc_build_array_ref (mask, maskindex, true);
body = build3_v (COND_EXPR, tmp, body,
build_empty_stmt (input_location));
}
@@ -4523,7 +4435,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
{
gfc_init_block (&body1);
gfc_conv_expr (&lse, expr);
- rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+ rse.expr = gfc_build_array_ref (tmp1, count1, true);
}
else
{
@@ -4546,7 +4458,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
gfc_conv_expr (&lse, expr);
/* Form the expression of the temporary. */
- rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+ rse.expr = gfc_build_array_ref (tmp1, count1, true);
}
/* Use the scalar assignment. */
@@ -4557,7 +4469,7 @@ generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
- wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3, true);
if (invert)
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
@@ -4628,7 +4540,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
{
gfc_init_block (&body1);
gfc_conv_expr (&rse, expr2);
- lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+ lse.expr = gfc_build_array_ref (tmp1, count1, true);
}
else
{
@@ -4652,7 +4564,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
gfc_conv_expr (&rse, expr2);
/* Form the expression of the temporary. */
- lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
+ lse.expr = gfc_build_array_ref (tmp1, count1, true);
}
/* Use the scalar assignment. */
@@ -4663,7 +4575,7 @@ generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
- wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
+ wheremaskexpr = gfc_build_array_ref (wheremask, count3, true);
if (invert)
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
@@ -5069,7 +4981,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
- lse.expr = gfc_build_array_ref (tmp1, count, NULL);
+ lse.expr = gfc_build_array_ref (tmp1, count, true);
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
@@ -5096,7 +5008,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
- rse.expr = gfc_build_array_ref (tmp1, count, NULL);
+ rse.expr = gfc_build_array_ref (tmp1, count, true);
lse.want_pointer = 1;
gfc_conv_expr (&lse, expr1);
gfc_add_block_to_block (&body, &lse.pre);
@@ -5132,14 +5044,15 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
loop.from, loop.to, 1,
- GFC_ARRAY_UNKNOWN, true);
+ GFC_ARRAY_UNKNOWN, true,
+ expr2->ts.type);
/* Allocate temporary for nested forall construct. */
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
inner_size, NULL, block, &ptemp1);
gfc_start_block (&body);
gfc_init_se (&lse, NULL);
- lse.expr = gfc_build_array_ref (tmp1, count, NULL);
+ lse.expr = gfc_build_array_ref (tmp1, count, true);
lse.direct_byref = 1;
gfc_conv_expr_descriptor (&lse, expr2);
@@ -5161,7 +5074,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
/* Reset count. */
gfc_add_modify (block, count, gfc_index_zero_node);
- parm = gfc_build_array_ref (tmp1, count, NULL);
+ parm = gfc_build_array_ref (tmp1, count, true);
gfc_init_se (&lse, NULL);
gfc_conv_expr_descriptor (&lse, expr1);
gfc_add_modify (&lse.pre, lse.expr, parm);
@@ -5555,7 +5468,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
/* Store the mask. */
se.expr = convert (mask_type, se.expr);
- tmp = gfc_build_array_ref (mask, maskindex, NULL);
+ tmp = gfc_build_array_ref (mask, maskindex, true);
gfc_add_modify (&body, tmp, se.expr);
/* Advance to the next mask element. */
@@ -5817,7 +5730,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
if (mask && (cmask || pmask))
{
- tmp = gfc_build_array_ref (mask, count, NULL);
+ tmp = gfc_build_array_ref (mask, count, true);
if (invert)
tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
gfc_add_modify (&body1, mtmp, tmp);
@@ -5825,7 +5738,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
if (cmask)
{
- tmp1 = gfc_build_array_ref (cmask, count, NULL);
+ tmp1 = gfc_build_array_ref (cmask, count, true);
tmp = cond;
if (mask)
tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
@@ -5835,7 +5748,7 @@ gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
if (pmask)
{
- tmp1 = gfc_build_array_ref (pmask, count, NULL);
+ tmp1 = gfc_build_array_ref (pmask, count, true);
tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
if (mask)
tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
@@ -5994,7 +5907,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
/* Form the mask expression according to the mask. */
index = count1;
- maskexpr = gfc_build_array_ref (mask, index, NULL);
+ maskexpr = gfc_build_array_ref (mask, index, true);
if (invert)
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (maskexpr), maskexpr);
@@ -6048,7 +5961,7 @@ gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
/* Form the mask expression according to the mask tree list. */
index = count2;
- maskexpr = gfc_build_array_ref (mask, index, NULL);
+ maskexpr = gfc_build_array_ref (mask, index, true);
if (invert)
maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (maskexpr), maskexpr);
@@ -6640,7 +6553,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
stmtblock_t block;
stmtblock_t post;
stmtblock_t final_block;
- tree nelems;
bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
bool needs_caf_sync, caf_refs_comp;
bool e3_has_nodescriptor = false;
@@ -7172,7 +7084,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
to handle the complete array allocation. Only the element size
needs to be provided, which is done most of the time by the
pre-evaluation step. */
- nelems = NULL_TREE;
if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
|| code->expr3->ts.type == BT_CLASS))
{
@@ -7244,11 +7155,11 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
}
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems,
- e3rhs ? e3rhs : code->expr3,
+ label_finish, tmp, e3rhs ? e3rhs : code->expr3,
e3_is == E3_DESC ? expr3 : NULL_TREE,
e3_has_nodescriptor, omp_alloc_item,
- code->ext.alloc.ts.type != BT_UNKNOWN))
+ code->ext.alloc.ts.type != BT_UNKNOWN
+ ? &code->ext.alloc.ts : nullptr))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -8013,7 +7924,12 @@ gfc_trans_deallocate (gfc_code *code)
if (al->expr->ts.type == BT_CLASS)
{
- gfc_reset_vptr (&se.pre, al->expr);
+ if (is_subref_array (al->expr))
+ /* Finalisation code can create bogus
+ array subreferences, ignore those. */
+ ;
+ else
+ gfc_reset_vptr (&se.pre, al->expr);
if (UNLIMITED_POLY (al->expr)
|| (al->expr->ts.type == BT_DERIVED
&& al->expr->ts.u.derived->attr.unlimited_polymorphic))
diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index e15b1bb89f01..a065b9748a55 100644
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -39,6 +39,7 @@ along with GCC; see the file COPYING3. If not see
#include "dwarf2out.h" /* For struct array_descr_info. */
#include "attribs.h"
#include "alias.h"
+#include "trans-descriptor.h"
#if (GFC_MAX_DIMENSIONS < 10)
@@ -1307,6 +1308,8 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
{
tree len;
+ gfc_conv_const_charlen (cl);
+
len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
if (len && POINTER_TYPE_P (TREE_TYPE (len)))
len = build_fold_indirect_ref (len);
@@ -1491,7 +1494,7 @@ gfc_get_element_type (tree type)
struct descriptor_dimension
{
- index stride;
+ index sm;
index lbound;
index ubound;
}
@@ -1586,7 +1589,7 @@ gfc_is_nodesc_array (gfc_symbol * sym)
static tree
gfc_build_array_type (tree type, gfc_array_spec * as,
enum gfc_array_kind akind, bool restricted,
- bool contiguous, int codim)
+ bool contiguous, int codim, bt type_type)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
@@ -1627,9 +1630,15 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
ubound[n] = gfc_conv_array_bound (as->upper[n]);
}
- if (as->type == AS_ASSUMED_SHAPE)
- akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
- : GFC_ARRAY_ASSUMED_SHAPE;
+ gfc_packed packed = PACKED_NO;
+ if (contiguous)
+ packed = PACKED_FULL;
+ else if (akind == GFC_ARRAY_ALLOCATABLE
+ && type_type != BT_CLASS
+ && type_type != BT_UNKNOWN
+ && type_type != BT_CHARACTER)
+ packed = PACKED_STATIC;
+
else if (as->type == AS_ASSUMED_RANK)
{
if (akind == GFC_ARRAY_ALLOCATABLE)
@@ -1641,10 +1650,11 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
: GFC_ARRAY_ASSUMED_RANK;
}
+
return gfc_get_array_type_bounds (type, as->rank == -1
? GFC_MAX_DIMENSIONS : as->rank,
- corank, lbound, ubound, 0, akind,
- restricted);
+ corank, lbound, ubound, packed, akind,
+ restricted, type_type);
}
/* Returns the struct descriptor_dimension type. */
@@ -1664,9 +1674,9 @@ gfc_get_desc_dim_type (void)
TYPE_NAME (type) = get_identifier ("descriptor_dimension");
TYPE_PACKED (type) = 1;
- /* Consists of the stride, lbound and ubound members. */
+ /* Consists of the sm, lbound and ubound members. */
decl = gfc_add_field_to_struct_1 (type,
- get_identifier ("stride"),
+ get_identifier ("spacing"),
gfc_array_index_type, &chain);
suppress_warning (decl);
@@ -1689,23 +1699,13 @@ gfc_get_desc_dim_type (void)
}
-/* Return the DTYPE for an array. This describes the type and type parameters
- of the array. */
-/* TODO: Only call this when the value is actually used, and make all the
- unknown cases abort. */
-
-tree
-gfc_get_dtype_rank_type (int rank, tree etype)
+void
+gfc_get_type_info (tree etype, bt *type, tree *psize)
{
- tree ptype;
tree size;
- int n;
- tree tmp;
- tree dtype;
- tree field;
- vec<constructor_elt, va_gc> *v = NULL;
+ bt n;
- ptype = etype;
+ tree ptype = etype;
while (TREE_CODE (etype) == POINTER_TYPE
|| TREE_CODE (etype) == ARRAY_TYPE)
{
@@ -1760,6 +1760,12 @@ gfc_get_dtype_rank_type (int rank, tree etype)
gcc_unreachable ();
}
+ if (type)
+ *type = n;
+
+ if (psize == nullptr)
+ return;
+
switch (n)
{
case BT_CHARACTER:
@@ -1779,6 +1785,29 @@ gfc_get_dtype_rank_type (int rank, tree etype)
STRIP_NOPS (size);
size = fold_convert (size_type_node, size);
+
+ if (psize)
+ *psize = size;
+}
+
+
+/* Return the DTYPE for an array. This describes the type and type parameters
+ of the array. */
+/* TODO: Only call this when the value is actually used, and make all the
+ unknown cases abort. */
+
+tree
+gfc_get_dtype_rank_type (int rank, tree etype)
+{
+ tree size;
+ bt n;
+ tree tmp;
+ tree dtype;
+ tree field;
+ vec<constructor_elt, va_gc> *v = NULL;
+
+ gfc_get_type_info (etype, &n, &size);
+
tmp = get_dtype_type_node ();
field = gfc_advance_chain (TYPE_FIELDS (tmp),
GFC_DTYPE_ELEM_LEN);
@@ -1829,66 +1858,69 @@ gfc_get_dtype (tree type, int * rank)
tree
gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
- bool restricted)
+ bool restricted, bt type_type)
{
- tree range;
+ tree lbound[GFC_MAX_DIMENSIONS];
+ tree ubound[GFC_MAX_DIMENSIONS];
+ tree spacing[GFC_MAX_DIMENSIONS];
tree type;
tree tmp;
int n;
- int known_stride;
- int known_offset;
mpz_t offset;
mpz_t stride;
+ mpz_t spc;
mpz_t delta;
+ mpz_t *lbound0 = nullptr;
gfc_expr *expr;
mpz_init_set_ui (offset, 0);
mpz_init_set_ui (stride, 1);
- mpz_init (delta);
-
- /* We don't use build_array_type because this does not include
- lang-specific information (i.e. the bounds of the array) when checking
- for duplicates. */
- if (as->rank)
- type = make_node (ARRAY_TYPE);
- else
- type = build_variant_type_copy (etype);
+ mpz_init (spc);
- GFC_ARRAY_TYPE_P (type) = 1;
- TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
+ bool known_spacing = packed != PACKED_NO && INTEGER_CST_P (TYPE_SIZE_UNIT (etype));
+ if (known_spacing)
+ {
+ wide_int elem_len = wi::to_wide (TYPE_SIZE_UNIT (etype));
+ gcc_assert (wi::fits_uhwi_p (elem_len));
+ mpz_set_ui (spc, elem_len.to_uhwi ());
+ }
+ mpz_init (delta);
- known_stride = (packed != PACKED_NO);
- known_offset = 1;
+ bool known_stride = (packed != PACKED_NO);
+ bool known_offset = true;
for (n = 0; n < as->rank; n++)
{
- /* Fill in the stride and bound components of the type. */
- if (known_stride)
- tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
+ /* Fill in the spacing and bound components of the type. */
+ if (known_spacing)
+ tmp = gfc_conv_mpz_to_tree (spc, gfc_index_integer_kind);
else
tmp = NULL_TREE;
- GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
+ spacing[n] = tmp;
expr = as->lower[n];
if (expr && expr->expr_type == EXPR_CONSTANT)
{
+ if (n == 0)
+ lbound0 = &expr->value.integer;
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
}
else
{
- known_stride = 0;
+ known_stride = false;
+ known_spacing = false;
tmp = NULL_TREE;
}
- GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
+ lbound[n] = tmp;
- if (known_stride)
+ if (known_spacing)
{
/* Calculate the offset. */
- mpz_mul (delta, stride, as->lower[n]->value.integer);
+ mpz_mul (delta, spc, as->lower[n]->value.integer);
mpz_sub (offset, offset, delta);
}
else
- known_offset = 0;
+ known_offset = false;
expr = as->upper[n];
if (expr && expr->expr_type == EXPR_CONSTANT)
@@ -1899,22 +1931,47 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
else
{
tmp = NULL_TREE;
- known_stride = 0;
+ known_stride = false;
+ known_spacing = false;
}
- GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+ ubound[n] = tmp;
- if (known_stride)
+ if (known_spacing || known_stride)
{
/* Calculate the stride. */
mpz_sub (delta, as->upper[n]->value.integer,
as->lower[n]->value.integer);
mpz_add_ui (delta, delta, 1);
- mpz_mul (stride, stride, delta);
+ if (known_stride)
+ mpz_mul (stride, stride, delta);
+ if (known_spacing)
+ mpz_mul (spc, spc, delta);
}
/* Only the first stride is known for partial packed arrays. */
if (packed == PACKED_NO || packed == PACKED_PARTIAL)
- known_stride = 0;
+ {
+ known_stride = false;
+ known_spacing = false;
+ }
+ }
+
+ /* We don't use build_array_type because this does not include
+ lang-specific information (i.e. the bounds of the array) when checking
+ for duplicates. */
+ if (as->rank != 0)
+ type = make_node (ARRAY_TYPE);
+ else
+ type = build_variant_type_copy (etype);
+
+ GFC_ARRAY_TYPE_P (type) = 1;
+ TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
+
+ for (n = 0; n < as->rank; n++)
+ {
+ GFC_TYPE_ARRAY_SPACING (type, n) = spacing[n];
+ GFC_TYPE_ARRAY_LBOUND (type, n) = lbound[n];
+ GFC_TYPE_ARRAY_UBOUND (type, n) = ubound[n];
}
for (n = as->rank; n < as->rank + as->corank; n++)
{
@@ -1952,72 +2009,60 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
else
GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
- GFC_TYPE_ARRAY_RANK (type) = as->rank;
- GFC_TYPE_ARRAY_CORANK (type) = as->corank;
- GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
- range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
- NULL_TREE);
- /* TODO: use main type if it is unbounded. */
- GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
- build_pointer_type (build_array_type (etype, range));
- if (restricted)
- GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
- build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
- TYPE_QUAL_RESTRICT);
-
- if (as->rank == 0)
+ if (as->rank != 0)
{
- if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB)
+ tree max_idx;
+ if (known_stride)
{
- type = build_pointer_type (type);
-
- if (restricted)
- type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
-
- GFC_ARRAY_TYPE_P (type) = 1;
- TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
+ mpz_t size;
+ mpz_init (size);
+ mpz_sub_ui (size, stride, 1);
+ if (as->rank == 1 && lbound0)
+ mpz_add (size, size, *lbound0);
+ else if (as->rank == 1 && as->lower[0] == nullptr)
+ mpz_add_ui (size, size, 1);
+ max_idx = gfc_conv_mpz_to_tree (size, gfc_index_integer_kind);
}
+ else
+ max_idx = NULL_TREE;
- goto array_type_done;
- }
+ tree lower;
+ if (as->rank == 1 && lbound0)
+ lower = gfc_conv_mpz_to_tree (*lbound0, gfc_index_integer_kind);
+ else if (as->rank == 1 && as && as->lower[0] == nullptr)
+ lower = gfc_index_one_node;
+ else
+ lower = gfc_index_zero_node;
- if (known_stride)
- {
- mpz_sub_ui (stride, stride, 1);
- range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
+ TYPE_DOMAIN (type) = build_range_type (gfc_array_index_type,
+ lower, max_idx);
+ TREE_TYPE (type) = etype;
}
- else
- range = NULL_TREE;
-
- range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
- TYPE_DOMAIN (type) = range;
-
- build_pointer_type (etype);
- TREE_TYPE (type) = etype;
layout_type (type);
- /* Represent packed arrays as multi-dimensional if they have rank >
- 1 and with proper bounds, instead of flat arrays. This makes for
- better debug info. */
- if (known_offset)
- {
- tree gtype = etype, rtype, type_decl;
+ if (type_type != BT_UNKNOWN
+ && type_type != BT_CLASS
+ && (type_type != BT_CHARACTER
+ || (TREE_CODE (etype) == ARRAY_TYPE
+ && TYPE_SIZE_UNIT (etype))))
+ GFC_TYPE_ARRAY_ELEM_LEN (type) = TYPE_SIZE_UNIT (etype);
- for (n = as->rank - 1; n >= 0; n--)
- {
- rtype = build_range_type (gfc_array_index_type,
- GFC_TYPE_ARRAY_LBOUND (type, n),
- GFC_TYPE_ARRAY_UBOUND (type, n));
- gtype = build_array_type (gtype, rtype);
- }
- TYPE_NAME (type) = type_decl = build_decl (input_location,
- TYPE_DECL, NULL, gtype);
- DECL_ORIGINAL_TYPE (type_decl) = gtype;
- }
+ if (packed == PACKED_FULL || packed == PACKED_STATIC)
+ GFC_TYPE_PACKED_ARRAY (type) = 1;
- if (packed != PACKED_STATIC || !known_stride
- || (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
+ GFC_TYPE_ARRAY_RANK (type) = as->rank;
+ GFC_TYPE_ARRAY_CORANK (type) = as->corank;
+ GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
+ GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = build_pointer_type (type);
+ if (restricted)
+ GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
+ build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
+ TYPE_QUAL_RESTRICT);
+
+ if (packed != PACKED_STATIC
+ || (!known_stride && as->rank != 0)
+ || ((as->corank || as->rank == 0) && flag_coarray == GFC_FCOARRAY_LIB))
{
/* For dummy arrays and automatic (heap allocated) arrays we
want a pointer to the array. */
@@ -2028,9 +2073,9 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
}
-array_type_done:
mpz_clear (offset);
mpz_clear (stride);
+ mpz_clear (spc);
mpz_clear (delta);
return type;
@@ -2134,7 +2179,8 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
tree
gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
tree * ubound, int packed,
- enum gfc_array_kind akind, bool restricted)
+ enum gfc_array_kind akind, bool restricted,
+ bt type_type)
{
char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
@@ -2185,15 +2231,34 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
+ if (type_type != BT_UNKNOWN
+ && type_type != BT_CLASS
+ && (type_type != BT_CHARACTER
+ || (TREE_CODE (etype) == ARRAY_TYPE
+ && TYPE_SIZE_UNIT (etype) != NULL_TREE)))
+ GFC_TYPE_ARRAY_ELEM_LEN (fat_type) = TYPE_SIZE_UNIT (etype);
+
/* Build an array descriptor record type. */
- if (packed != 0)
- stride = gfc_index_one_node;
+ tree spacing;
+ if (packed != PACKED_NO
+ && GFC_TYPE_ARRAY_ELEM_LEN (fat_type))
+ {
+ stride = gfc_index_one_node;
+ if (dimen == 0)
+ spacing = NULL_TREE;
+ else
+ spacing = fold_convert_loc (input_location, gfc_array_index_type,
+ GFC_TYPE_ARRAY_ELEM_LEN (fat_type));
+ }
else
- stride = NULL_TREE;
+ {
+ stride = NULL_TREE;
+ spacing = NULL_TREE;
+ }
for (n = 0; n < dimen + codimen; n++)
{
if (n < dimen)
- GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
+ GFC_TYPE_ARRAY_SPACING (fat_type, n) = spacing;
if (lbound)
lower = lbound[n];
@@ -2223,20 +2288,26 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
if (n >= dimen)
continue;
- if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
+ if (upper != NULL_TREE && lower != NULL_TREE
+ && (stride != NULL_TREE || spacing != NULL_TREE))
{
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, upper, lower);
- tmp = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, tmp,
- gfc_index_one_node);
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp, stride);
- /* Check the folding worked. */
- gcc_assert (INTEGER_CST_P (stride));
+ tmp = gfc_conv_array_extent_dim (lower, upper, nullptr);
+ if (stride != NULL_TREE)
+ {
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, stride);
+ /* Check the folding worked. */
+ gcc_assert (INTEGER_CST_P (stride));
+ }
+ if (spacing != NULL_TREE)
+ spacing = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, spacing);
}
else
- stride = NULL_TREE;
+ {
+ stride = NULL_TREE;
+ spacing = NULL_TREE;
+ }
}
GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
@@ -2253,14 +2324,48 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
return fat_type;
}
+ bool contiguous = packed == PACKED_FULL
+ || packed == PACKED_STATIC
+ || akind == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ || akind == GFC_ARRAY_ALLOCATABLE
+ || akind == GFC_ARRAY_POINTER_CONT;
+ if (contiguous)
+ GFC_TYPE_PACKED_ARRAY (fat_type) = 1;
+
/* We define data as an array with the correct size if possible.
Much better than doing pointer arithmetic. */
- if (stride)
- rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
- int_const_binop (MINUS_EXPR, stride,
- build_int_cst (TREE_TYPE (stride), 1)));
+ bool known_zero_size = false;
+ if (stride && contiguous)
+ {
+ tree range_bound = int_const_binop (MINUS_EXPR, stride,
+ build_int_cst (TREE_TYPE (stride),
+ 1));
+ rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ range_bound);
+ if (integer_minus_onep (range_bound))
+ known_zero_size = true;
+ }
else
- rtype = gfc_array_range_type;
+ rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ NULL_TREE);
+ if (known_zero_size
+ && TREE_CODE (etype) == ARRAY_TYPE
+ && TYPE_DOMAIN (etype)
+ && TYPE_MAX_VALUE (TYPE_DOMAIN (etype))
+ && TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (etype))) != INTEGER_CST)
+ {
+ tree elt = TREE_TYPE (etype);
+ tree domain = TYPE_DOMAIN (etype);
+ tree min = TYPE_MIN_VALUE (domain);
+ domain = build_range_type (TREE_TYPE (domain), min, min);
+ tree new_etype = build_array_type (elt, domain);
+ TYPE_STRING_FLAG (new_etype) = TYPE_STRING_FLAG (etype);
+ layout_type (new_etype);
+ etype = new_etype;
+ }
arraytype = build_array_type (etype, rtype);
arraytype = build_pointer_type (arraytype);
if (restricted)
@@ -2540,7 +2645,8 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
type = gfc_get_nodesc_array_type (type, sym->as,
byref ? PACKED_FULL
: PACKED_STATIC,
- restricted);
+ restricted,
+ sym->ts.type);
byref = 0;
}
}
@@ -2553,7 +2659,8 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
else if (sym->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
type = gfc_build_array_type (type, sym->as, akind, restricted,
- sym->attr.contiguous, sym->as->corank);
+ sym->attr.contiguous, sym->as->corank,
+ sym->ts.type);
}
}
else
@@ -2815,6 +2922,69 @@ cobounds_match_decl (const gfc_symbol *derived)
return true;
}
+
+gfc_symbol *
+get_class_canonical_type (gfc_symbol *derived, gfc_array_spec *as)
+{
+
+ int rank = as ? as->rank : 0;
+ int corank = as ? as->corank : 0;
+ const char *class_name = gfc_class_name (derived, rank, corank, 0, 0);
+
+ gfc_namespace *ns = gfc_class_namespace (derived);
+
+ gfc_symbol *canonical_class = nullptr;
+ gfc_find_symbol (class_name, ns, 0, &canonical_class);
+
+ if (canonical_class != nullptr)
+ {
+ gfc_array_spec *found_as = canonical_class->components->as;
+ if (gfc_compare_array_spec (as, found_as))
+ return canonical_class;
+ else
+ return nullptr;
+ }
+
+ gfc_typespec ts;
+ memset (&ts, 0, sizeof (ts));
+ ts.type = BT_CLASS;
+ ts.u.derived = derived;
+
+ symbol_attribute attr;
+ memset (&attr, 0, sizeof (attr));
+ attr.dummy = 1;
+ attr.dimension = rank != 0;
+ attr.codimension = corank != 0;
+
+ gfc_array_spec *tmp_as = gfc_copy_array_spec (as);
+
+ gfc_build_class_symbol (&ts, &attr, &tmp_as);
+
+ gfc_find_symbol (class_name, ns, 0, &canonical_class);
+ if (canonical_class)
+ {
+ if (derived->module)
+ canonical_class->module = gfc_get_string ("%s", derived->module);
+ gfc_resolve_symbol (canonical_class);
+ }
+
+ return canonical_class;
+}
+
+
+gfc_symbol *
+get_class_canonical_type (gfc_symbol *cls)
+{
+ gcc_assert (cls->attr.is_class);
+
+ gfc_component * data_comp = cls->components;
+
+ gfc_symbol *derived = data_comp->ts.u.derived;
+
+ return get_class_canonical_type (derived, data_comp->as);
+}
+
+
/* Build a tree node for a derived type. If there are equal
derived types, with different local names, these are built
at the same time. If an equal derived type has been built
@@ -2824,9 +2994,9 @@ tree
gfc_get_derived_type (gfc_symbol * derived, int codimen)
{
tree typenode = NULL, field = NULL, field_type = NULL;
- tree canonical = NULL_TREE;
- tree *chain = NULL;
+ tree canonical = NULL_TREE, class_canonical = NULL_TREE;
bool got_canonical = false;
+ bool self_is_canonical = false;
bool unlimited_entity = false;
gfc_component *c;
gfc_namespace *ns;
@@ -2886,9 +3056,21 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
if (derived->backend_decl == NULL
&& (derived->attr.use_assoc || derived->attr.used_in_submodule)
&& derived->module
- && gfc_get_module_backend_decl (derived))
+ && gfc_get_module_backend_decl (derived, false))
goto copy_derived_types;
+ if (derived->attr.is_class)
+ {
+ gfc_symbol * canonical_sym = get_class_canonical_type (derived);
+ if (canonical_sym == derived)
+ self_is_canonical = true;
+ else if (canonical_sym != nullptr)
+ {
+ tree canonical_decl = gfc_get_derived_type (canonical_sym, codimen);
+ class_canonical = TYPE_CANONICAL (canonical_decl);
+ }
+ }
+
/* The derived types from an earlier namespace can be used as the
canonical type. */
if (derived->backend_decl == NULL
@@ -2925,6 +3107,8 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
derived->backend_decl = NULL_TREE;
}
+ else if (class_canonical)
+ canonical = class_canonical;
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
@@ -3034,135 +3218,219 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
through only the top-level linked list of components so we correctly
build UNION_TYPE nodes for BT_UNION components. MAPs and other nested
types are built as part of gfc_get_union_type. */
- for (c = derived->components; c; c = c->next)
- {
- bool same_alloc_type = c->attr.allocatable
- && derived == c->ts.u.derived;
- /* Prevent infinite recursion, when the procedure pointer type is
- the same as derived, by forcing the procedure pointer component to
- be built as if the explicit interface does not exist. */
- if (c->attr.proc_pointer
- && (c->ts.type != BT_DERIVED || (c->ts.u.derived
- && !gfc_compare_derived_types (derived, c->ts.u.derived)))
- && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
- && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
- field_type = gfc_get_ppc_type (c);
- else if (c->attr.proc_pointer && derived->backend_decl)
- {
- tmp = build_function_type (derived->backend_decl, NULL_TREE);
- field_type = build_pointer_type (tmp);
- }
- else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
- field_type = c->ts.u.derived->backend_decl;
- else if (c->attr.caf_token)
- field_type = pvoid_type_node;
- else
- {
- if (c->ts.type == BT_CHARACTER
- && !c->ts.deferred && !c->attr.pdt_string)
- {
- /* Evaluate the string length. */
- gfc_conv_const_charlen (c->ts.u.cl);
- gcc_assert (c->ts.u.cl->backend_decl);
- }
- else if (c->ts.type == BT_CHARACTER)
- c->ts.u.cl->backend_decl
- = build_int_cst (gfc_charlen_type_node, 0);
+ {
+ auto_vec <tree> fields;
- field_type = gfc_typenode_for_spec (&c->ts, codimen);
- }
+ unsigned i;
+ bool do_loop = true;
+ while (do_loop)
+ {
+ do_loop = false;
+ for (c = derived->components, i = 0; c; c = c->next, i++)
+ {
+ if (fields.length () > i
+ && fields[i] != nullptr)
+ continue;
- /* This returns an array descriptor type. Initialization may be
- required. */
- if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
- {
- if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
- {
- enum gfc_array_kind akind;
- bool is_ptr = ((c == derived->components
- && derived->components->ts.type == BT_DERIVED
- && startswith (derived->name, "__class")
- && (strcmp (derived->components->name, "_data")
- == 0))
- ? c->attr.class_pointer : c->attr.pointer);
- if (is_ptr)
- akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
- : GFC_ARRAY_POINTER;
- else if (c->attr.allocatable)
- akind = GFC_ARRAY_ALLOCATABLE;
- else if (c->as->type == AS_ASSUMED_RANK)
- akind = GFC_ARRAY_ASSUMED_RANK;
- else
- /* FIXME – see PR fortran/104651. Additionally, the following
- gfc_build_array_type should use !is_ptr instead of
- c->attr.pointer and codim unconditionally without '? :'. */
- akind = GFC_ARRAY_ASSUMED_SHAPE;
- /* Pointers to arrays aren't actually pointer types. The
- descriptors are separate, but the data is common. Every
- array pointer in a coarray derived type needs to provide space
- for the coarray management, too. Therefore treat coarrays
- and pointers to coarrays in derived types the same. */
- field_type = gfc_build_array_type
- (
- field_type, c->as, akind, !c->attr.target && !c->attr.pointer,
- c->attr.contiguous,
- c->attr.codimension || c->attr.pointer ? codimen : 0
- );
- }
- else
- field_type = gfc_get_nodesc_array_type (field_type, c->as,
- PACKED_STATIC,
- !c->attr.target);
- }
- else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
- && !c->attr.proc_pointer
- && !(unlimited_entity && c == derived->components))
- field_type = build_pointer_type (field_type);
-
- if (c->attr.pointer || same_alloc_type)
- field_type = gfc_nonrestricted_type (field_type);
-
- /* vtype fields can point to different types to the base type. */
- if (c->ts.type == BT_DERIVED
- && c->ts.u.derived && c->ts.u.derived->attr.vtype)
- field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
- ptr_mode, true);
-
- /* Ensure that the CLASS language specific flag is set. */
- if (c->ts.type == BT_CLASS)
- {
- if (POINTER_TYPE_P (field_type))
- GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
- else
- GFC_CLASS_TYPE_P (field_type) = 1;
- }
+ bool same_alloc_type = c->attr.allocatable
+ && derived == c->ts.u.derived;
+ /* Prevent infinite recursion, when the procedure pointer type is
+ the same as derived, by forcing the procedure pointer component to
+ be built as if the explicit interface does not exist. */
+ if (c->attr.proc_pointer
+ && (c->ts.type != BT_DERIVED || (c->ts.u.derived
+ && !gfc_compare_derived_types (derived, c->ts.u.derived)))
+ && (c->ts.type != BT_CLASS || (CLASS_DATA (c)->ts.u.derived
+ && !gfc_compare_derived_types (derived, CLASS_DATA (c)->ts.u.derived))))
+ field_type = gfc_get_ppc_type (c);
+ else if (c->attr.proc_pointer && derived->backend_decl)
+ {
+ tmp = build_function_type (derived->backend_decl, NULL_TREE);
+ field_type = build_pointer_type (tmp);
+ }
+ else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ field_type = c->ts.u.derived->backend_decl;
+ else if (c->attr.caf_token)
+ field_type = pvoid_type_node;
+ else
+ {
+ if (c->ts.type == BT_CHARACTER
+ && !c->ts.deferred && !c->attr.pdt_string)
+ {
+ /* Evaluate the string length. */
+ gfc_conv_const_charlen (c->ts.u.cl);
+ gcc_assert (c->ts.u.cl->backend_decl);
+ }
- field = gfc_add_field_to_struct (typenode,
- get_identifier (c->name),
- field_type, &chain);
- if (GFC_LOCUS_IS_SET (c->loc))
- gfc_set_decl_location (field, &c->loc);
- else if (GFC_LOCUS_IS_SET (derived->declared_at))
- gfc_set_decl_location (field, &derived->declared_at);
+ field_type = gfc_typenode_for_spec (&c->ts, codimen);
+ tree strlen_field;
+ if (gfc_deferred_strlen (c, &strlen_field))
+ {
+ if (strlen_field == nullptr)
+ {
+ do_loop = true;
+ continue;
+ }
+
+ gcc_assert (TREE_CODE (field_type) == ARRAY_TYPE);
+ if (TYPE_MAX_VALUE (TYPE_DOMAIN (field_type)) == NULL_TREE)
+ {
+ tree domain_type = TYPE_DOMAIN (field_type);
+ domain_type = build_distinct_type_copy (domain_type);
+ field_type = build_distinct_type_copy (field_type);
+ TYPE_DOMAIN (field_type) = domain_type;
+ tree max = build3 (COMPONENT_REF, TREE_TYPE (strlen_field),
+ build0 (PLACEHOLDER_EXPR, typenode),
+ strlen_field, NULL_TREE);
+ TYPE_MAX_VALUE (domain_type) = max;
+ }
+ }
+ }
- gfc_finish_decl_attrs (field, &c->attr);
+ /* This returns an array descriptor type. Initialization may be
+ required. */
+ if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
+ {
+ if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
+ {
+ enum gfc_array_kind akind;
+ bool is_ptr = ((c == derived->components
+ && derived->components->ts.type == BT_DERIVED
+ && startswith (derived->name, "__class")
+ && (strcmp (derived->components->name, "_data")
+ == 0))
+ ? c->attr.class_pointer : c->attr.pointer);
+ if (is_ptr)
+ akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
+ : GFC_ARRAY_POINTER;
+ else if (c->attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ else if (c->as->type == AS_ASSUMED_RANK)
+ akind = GFC_ARRAY_ASSUMED_RANK;
+ else
+ /* FIXME – see PR fortran/104651. Additionally, the following
+ gfc_build_array_type should use !is_ptr instead of
+ c->attr.pointer and codim unconditionally without '? :'. */
+ akind = GFC_ARRAY_ASSUMED_SHAPE;
+
+ /* Use char as array element type for unlimited_polymorphic
+ entities. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.unlimited_polymorphic
+ && field_type == ptr_type_node)
+ field_type = char_type_node;
+
+ bt type_type = derived->attr.is_class
+ && strcmp (c->name, "_data") == 0
+ ? BT_CLASS : c->ts.type;
+
+ /* Pointers to arrays aren't actually pointer types. The
+ descriptors are separate, but the data is common. Every
+ array pointer in a coarray derived type needs to provide space
+ for the coarray management, too. Therefore treat coarrays
+ and pointers to coarrays in derived types the same. */
+ field_type = gfc_build_array_type
+ (
+ field_type, c->as, akind, !c->attr.target && !c->attr.pointer,
+ c->attr.contiguous,
+ c->attr.codimension || c->attr.pointer ? codimen : 0,
+ type_type
+ );
+ }
+ else
+ field_type = gfc_get_nodesc_array_type (field_type, c->as,
+ PACKED_STATIC,
+ !c->attr.target,
+ c->ts.type);
+ }
+ else if ((c->attr.pointer || c->attr.allocatable || c->attr.pdt_string)
+ && !c->attr.proc_pointer
+ && !(unlimited_entity && c == derived->components))
+ field_type = build_pointer_type (field_type);
+
+ if (c->attr.pointer || same_alloc_type)
+ field_type = gfc_nonrestricted_type (field_type);
+
+ /* vtype fields can point to different types to the base type. */
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.vtype)
+ field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
+ ptr_mode, true);
+
+ /* Ensure that the CLASS language specific flag is set. */
+ if (c->ts.type == BT_CLASS)
+ {
+ if (POINTER_TYPE_P (field_type))
+ GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
+ else
+ GFC_CLASS_TYPE_P (field_type) = 1;
+ }
- DECL_PACKED (field) |= TYPE_PACKED (typenode);
+ field = gfc_add_field_to_struct (typenode,
+ get_identifier (c->name),
+ field_type, nullptr);
+ if (i >= fields.length ())
+ fields.safe_grow_cleared (i + 1);
- gcc_assert (field);
- /* Overwrite for class array to supply different bounds for different
- types. */
- if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
- c->backend_decl = field;
+ fields[i] = field;
- if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
- && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
- GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
- }
+ if (GFC_LOCUS_IS_SET (c->loc))
+ gfc_set_decl_location (field, &c->loc);
+ else if (GFC_LOCUS_IS_SET (derived->declared_at))
+ gfc_set_decl_location (field, &derived->declared_at);
+
+ gfc_finish_decl_attrs (field, &c->attr);
+
+ DECL_PACKED (field) |= TYPE_PACKED (typenode);
+
+ gcc_assert (field);
+ /* Overwrite for class array to supply different bounds for different
+ types. */
+ if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
+ c->backend_decl = field;
+
+ if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
+ && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
+ GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
+ }
+ }
+
+ tree* ptr = &TYPE_FIELDS (typenode);
+ for (c = derived->components, i = 0; c; c = c->next, i++)
+ {
+ tree field = fields[i];
+ *ptr = field;
+ ptr = &DECL_CHAIN (field);
+ }
+ }
+
+ if (derived->attr.is_class)
+ GFC_CLASS_TYPE_P (typenode) = 1;
/* Now lay out the derived type, including the fields. */
if (canonical)
TYPE_CANONICAL (typenode) = canonical;
+ else if (self_is_canonical)
+ TYPE_CANONICAL (typenode) = typenode;
+
+ if (derived->attr.is_class)
+ {
+ gfc_component * data_comp = derived->components;
+ gfc_symbol *orig_type = data_comp->ts.u.derived;
+ if (orig_type->attr.extension)
+ {
+ gfc_symbol * parent_type = orig_type->components->ts.u.derived;
+ gfc_symbol * parent_wrapper = get_class_canonical_type (parent_type,
+ data_comp->as);
+ if (parent_wrapper != nullptr)
+ {
+ tree wrapper_decl = gfc_get_derived_type (parent_wrapper, codimen);
+ if (!TYPE_LANG_SPECIFIC (typenode))
+ TYPE_LANG_SPECIFIC (typenode) = ggc_cleared_alloc<struct lang_type> ();
+ GFC_TYPE_PARENT_CLASS_TYPE (typenode) = wrapper_decl;
+ }
+ }
+ }
gfc_finish_type (typenode);
gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
@@ -3712,8 +3980,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
int rank, dim;
bool indirect = false;
tree etype, ptype, t, base_decl;
- tree data_off, span_off, dim_off, dtype_off, dim_size, elem_size;
- tree lower_suboff, upper_suboff, stride_suboff;
+ tree data_off, span_off, dim_off, dtype_off, dim_size;
+ tree lower_suboff, upper_suboff, spacing_suboff;
tree dtype, field, rank_off;
if (! GFC_DESCRIPTOR_TYPE_P (type))
@@ -3768,12 +4036,9 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
base_decl = build1 (INDIRECT_REF, ptype, base_decl);
gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &span_off,
- &dim_off, &dim_size, &stride_suboff,
+ &dim_off, &dim_size, &spacing_suboff,
&lower_suboff, &upper_suboff);
- t = fold_build_pointer_plus (base_decl, span_off);
- elem_size = build1 (INDIRECT_REF, gfc_array_index_type, t);
-
t = base_decl;
if (!integer_zerop (data_off))
t = fold_build_pointer_plus (t, data_off);
@@ -3843,9 +4108,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
}
t = fold_build_pointer_plus (base_decl,
size_binop (PLUS_EXPR,
- dim_off, stride_suboff));
+ dim_off, spacing_suboff));
t = build1 (INDIRECT_REF, gfc_array_index_type, t);
- t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
info->dimen[dim].stride = t;
if (dim + 1 < rank)
dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
@@ -4149,4 +4413,171 @@ gfc_get_cfi_type (int dimen, bool restricted)
return CFI_cdesc_t;
}
+
+/* Variant of build_array_type that doesn't call layout_type. */
+
+tree
+gfc_build_incomplete_array_type (tree elt_type, tree index_type)
+{
+ tree type = make_node (ARRAY_TYPE);
+ TREE_TYPE (type) = elt_type;
+ TYPE_DOMAIN (type) = index_type;
+ TYPE_ADDR_SPACE (type) = TYPE_ADDR_SPACE (elt_type);
+
+ /* Set TYPE_STRUCTURAL_EQUALITY_P. */
+ if (TYPE_STRUCTURAL_EQUALITY_P (elt_type)
+ || (index_type && TYPE_STRUCTURAL_EQUALITY_P (index_type))
+ || in_lto_p)
+ SET_TYPE_STRUCTURAL_EQUALITY (type);
+
+ return type;
+}
+
+
+tree
+gfc_get_unbounded_array_type (tree type)
+{
+ bool ptr_wrapper = TREE_CODE (type) == POINTER_TYPE;
+
+ tree array_type;
+ if (ptr_wrapper)
+ array_type = TREE_TYPE (type);
+ else
+ array_type = type;
+
+ gcc_assert (TREE_CODE (array_type) == ARRAY_TYPE);
+ tree index_type = TYPE_DOMAIN (array_type);
+ if (TYPE_MAX_VALUE (index_type) == NULL_TREE
+ && TYPE_SIZE (array_type) == NULL_TREE
+ && TYPE_SIZE_UNIT (array_type) == NULL_TREE)
+ return type;
+
+ tree modified_index_type = build_distinct_type_copy (index_type);
+ TYPE_MAX_VALUE (modified_index_type) = NULL_TREE;
+
+ tree modified_array_type = build_distinct_type_copy (array_type);
+ TYPE_DOMAIN (modified_array_type) = modified_index_type;
+ TYPE_SIZE (modified_array_type) = NULL_TREE;
+ TYPE_SIZE_UNIT (modified_array_type) = NULL_TREE;
+ layout_type (modified_array_type);
+
+ tree modified_type;
+ if (ptr_wrapper)
+ modified_type = build_pointer_type (modified_array_type);
+ else
+ modified_type = modified_array_type;
+
+ return modified_type;
+}
+
+
+bool
+gfc_type_contains_placeholder_p (tree type)
+{
+ /* The middle-end function doesn't look at
+ pointer target type, circumvent it here. */
+ if (TREE_CODE (type) == POINTER_TYPE)
+ return gfc_type_contains_placeholder_p (TREE_TYPE (type));
+ else
+ return type_contains_placeholder_p (type);
+}
+
+
+static tree
+substitute_in_expr (tree expr, tree repl_expr, stmtblock_t *block)
+{
+ tree new_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR (expr, repl_expr);
+ if (new_expr != expr
+ && !VAR_P (new_expr))
+ {
+ if (block == nullptr)
+ return save_expr (new_expr);
+ else
+ return gfc_evaluate_now (new_expr, block);
+ }
+ else
+ return new_expr;
+}
+
+
+tree
+gfc_substitute_placeholder_in_type (tree type, tree root_struct, stmtblock_t *block)
+{
+ tree type_size = TYPE_SIZE (type);
+ tree new_type_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (type_size, root_struct);
+
+ tree type_size_unit = TYPE_SIZE_UNIT (type);
+ tree new_type_size_unit = SUBSTITUTE_PLACEHOLDER_IN_EXPR (type_size_unit,
+ root_struct);
+
+ switch (TREE_CODE (type))
+ {
+ case POINTER_TYPE:
+ {
+ tree subtype = TREE_TYPE (type);
+ tree new_subtype = gfc_substitute_placeholder_in_type (subtype,
+ root_struct,
+ block);
+ if (new_subtype == subtype
+ && new_type_size == type_size
+ && new_type_size_unit == type_size_unit)
+ return type;
+ else
+ return build_pointer_type (new_subtype);
+ }
+ break;
+
+ case ARRAY_TYPE:
+ {
+ tree elt_type = TREE_TYPE (type);
+ tree new_elt_type = gfc_substitute_placeholder_in_type (elt_type,
+ root_struct,
+ block);
+ tree idx_type = TYPE_DOMAIN (type);
+ tree new_idx_type = gfc_substitute_placeholder_in_type (idx_type,
+ root_struct,
+ block);
+ if (new_elt_type == elt_type
+ && new_idx_type == idx_type
+ && new_type_size == type_size
+ && new_type_size_unit == type_size_unit)
+ return type;
+ else
+ {
+ tree new_type = build_array_type (new_elt_type, new_idx_type);
+ TYPE_STRING_FLAG (new_type) = TYPE_STRING_FLAG (type);
+ return new_type;
+ }
+ }
+ break;
+
+ case INTEGER_TYPE:
+ {
+ tree min_val = TYPE_MIN_VALUE (type);
+ tree new_min_val = substitute_in_expr (min_val, root_struct, block);
+
+ tree max_val = TYPE_MAX_VALUE (type);
+ tree new_max_val = substitute_in_expr (max_val, root_struct, block);
+
+ if (new_min_val == min_val
+ && new_max_val == max_val
+ && new_type_size == type_size
+ && new_type_size_unit == type_size_unit)
+ return type;
+ else
+ {
+ tree new_type = build_range_type (type, new_min_val, new_max_val);
+ TYPE_SIZE (new_type) = new_type_size;
+ TYPE_SIZE_UNIT (new_type) = new_type_size_unit;
+ return new_type;
+ }
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
#include "gt-fortran-trans-types.h"
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index aba841da9cb5..6a5a7b6d8078 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -100,8 +100,8 @@ tree gfc_build_uint_type (int);
tree gfc_get_element_type (tree);
tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int,
- enum gfc_array_kind, bool);
-tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
+ enum gfc_array_kind, bool, bt);
+tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool, bt);
/* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE. */
tree gfc_add_field_to_struct (tree, tree, tree, tree **);
@@ -116,10 +116,18 @@ bool gfc_return_by_reference (gfc_symbol *);
bool gfc_is_nodesc_array (gfc_symbol *);
/* Return the DTYPE for an array. */
+void gfc_get_type_info (tree, bt *, tree *);
tree gfc_get_dtype_rank_type (int, tree);
tree gfc_get_dtype (tree, int *rank = NULL);
tree gfc_get_caf_vector_type (int dim);
tree gfc_get_caf_reference_type ();
+tree gfc_build_incomplete_array_type (tree, tree);
+
+tree gfc_get_unbounded_array_type (tree);
+
+bool gfc_type_contains_placeholder_p (tree);
+tree gfc_substitute_placeholder_in_type (tree, tree, stmtblock_t *);
+
#endif
diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc
index 9d525e0c51ee..5eb993f29065 100644
--- a/gcc/fortran/trans.cc
+++ b/gcc/fortran/trans.cc
@@ -387,81 +387,6 @@ gfc_build_addr_expr (tree type, tree t)
}
-static tree
-get_array_span (tree type, tree decl)
-{
- tree span;
-
- /* Component references are guaranteed to have a reliable value for
- 'span'. Likewise indirect references since they emerge from the
- conversion of a CFI descriptor or the hidden dummy descriptor. */
- if (TREE_CODE (decl) == COMPONENT_REF
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
- return gfc_conv_descriptor_span_get (decl);
- else if (INDIRECT_REF_P (decl)
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
- return gfc_conv_descriptor_span_get (decl);
-
- /* Return the span for deferred character length array references. */
- if (type
- && (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == INTEGER_TYPE)
- && TYPE_STRING_FLAG (type))
- {
- if (TREE_CODE (decl) == PARM_DECL)
- decl = build_fold_indirect_ref_loc (input_location, decl);
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
- span = gfc_conv_descriptor_span_get (decl);
- else
- span = gfc_get_character_len_in_bytes (type);
- span = (span && !integer_zerop (span))
- ? (fold_convert (gfc_array_index_type, span)) : (NULL_TREE);
- }
- /* Likewise for class array or pointer array references. */
- else if (TREE_CODE (decl) == FIELD_DECL
- || VAR_OR_FUNCTION_DECL_P (decl)
- || TREE_CODE (decl) == PARM_DECL)
- {
- if (GFC_DECL_CLASS (decl))
- {
- /* When a temporary is in place for the class array, then the
- original class' declaration is stored in the saved
- descriptor. */
- if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
- decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
- else
- {
- /* Allow for dummy arguments and other good things. */
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
-
- /* Check if '_data' is an array descriptor. If it is not,
- the array must be one of the components of the class
- object, so return a null span. */
- if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (
- gfc_class_data_get (decl))))
- return NULL_TREE;
- }
- span = gfc_class_vtab_size_get (decl);
- /* For unlimited polymorphic entities then _len component needs
- to be multiplied with the size. */
- span = gfc_resize_class_size_with_len (NULL, decl, span);
- }
- else if (GFC_DECL_PTR_ARRAY_P (decl))
- {
- if (TREE_CODE (decl) == PARM_DECL)
- decl = build_fold_indirect_ref_loc (input_location, decl);
- span = gfc_conv_descriptor_span_get (decl);
- }
- else
- span = NULL_TREE;
- }
- else
- span = NULL_TREE;
-
- return span;
-}
-
-
tree
gfc_build_spanned_array_ref (tree base, tree offset, tree span)
{
@@ -482,84 +407,87 @@ gfc_build_spanned_array_ref (tree base, tree offset, tree span)
/* Build an ARRAY_REF with its natural type.
- NON_NEGATIVE_OFFSET indicates if it’s true that OFFSET can’t be negative,
+ NON_NEGATIVE_SPACING indicates if it’s true that SPACING can’t be negative,
and thus that an ARRAY_REF can safely be generated. If it’s false, we
have to play it safe and use pointer arithmetic. */
tree
-gfc_build_array_ref (tree base, tree offset, tree decl,
- bool non_negative_offset, tree vptr)
+gfc_build_array_ref (tree type, tree base, tree index, bool non_negative_offset,
+ tree min_idx, tree spacing_bytes, tree offset)
{
- tree type = TREE_TYPE (base);
- tree span = NULL_TREE;
-
- if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
- {
- gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
+ if (DECL_P (base))
+ TREE_ADDRESSABLE (base) = 1;
- return fold_convert (TYPE_MAIN_VARIANT (type), base);
- }
+ /* Strip NON_LVALUE_EXPR nodes. */
+ STRIP_TYPE_NOPS (index);
- /* Scalar coarray, there is nothing to do. */
- if (TREE_CODE (type) != ARRAY_TYPE)
+ if (non_negative_offset)
{
- gcc_assert (decl == NULL_TREE);
- gcc_assert (integer_zerop (offset));
- return base;
- }
+ tree base_type = TREE_TYPE (base);
+ if (TREE_CODE (base_type) == ARRAY_TYPE
+ && tree_int_cst_equal (min_idx,
+ TYPE_MIN_VALUE (TYPE_DOMAIN (base_type)))
+ && tree_int_cst_equal (spacing_bytes,
+ TYPE_SIZE_UNIT (TREE_TYPE (base_type))))
+ {
+ min_idx = NULL_TREE;
+ spacing_bytes = NULL_TREE;
+ }
- type = TREE_TYPE (type);
+ tree spacing;
+ if (spacing_bytes == NULL_TREE)
+ spacing = NULL_TREE;
+ else
+ {
+ gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE);
+ int elt_align = TYPE_ALIGN_UNIT (TREE_TYPE (TREE_TYPE (base)));
+ spacing = fold_build2_loc (input_location, EXACT_DIV_EXPR,
+ gfc_array_index_type, spacing_bytes,
+ build_int_cst (gfc_array_index_type,
+ elt_align));
+ }
+ tree ref = build4_loc (input_location, ARRAY_REF, type, base, index,
+ min_idx, spacing);
+ if (!offset || integer_zerop (offset))
+ return ref;
- if (DECL_P (base))
- TREE_ADDRESSABLE (base) = 1;
+ tree addr = gfc_build_addr_expr (NULL_TREE, ref);
- /* Strip NON_LVALUE_EXPR nodes. */
- STRIP_TYPE_NOPS (offset);
-
- /* If decl or vptr are non-null, pointer arithmetic for the array reference
- is likely. Generate the 'span' for the array reference. */
- if (vptr)
- {
- span = gfc_vptr_size_get (vptr);
-
- /* Check if this is an unlimited polymorphic object carrying a character
- payload. In this case, the 'len' field is non-zero. */
- if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- span = gfc_resize_class_size_with_len (NULL, decl, span);
- }
- else if (decl)
- span = get_array_span (type, decl);
-
- /* If a non-null span has been generated reference the element with
- pointer arithmetic. */
- if (span != NULL_TREE)
- return gfc_build_spanned_array_ref (base, offset, span);
- /* Else use a straightforward array reference if possible. */
- else if (non_negative_offset)
- return build4_loc (input_location, ARRAY_REF, type, base, offset,
- NULL_TREE, NULL_TREE);
+ tree ptr = fold_build_pointer_plus_loc (input_location, addr, offset);
+ return build_fold_indirect_ref_loc (input_location, ptr);
+ }
/* Otherwise use pointer arithmetic. */
else
{
gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE);
- tree min = NULL_TREE;
- if (TYPE_DOMAIN (TREE_TYPE (base))
- && !integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)))))
+ tree min = min_idx;
+ if (min == NULL_TREE
+ && TYPE_DOMAIN (TREE_TYPE (base)))
min = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base)));
tree zero_based_index
- = min ? fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- fold_convert (gfc_array_index_type, offset),
- fold_convert (gfc_array_index_type, min))
- : fold_convert (gfc_array_index_type, offset);
-
- tree elt_size = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (type));
+ = min && !integer_zerop (min)
+ ? fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ fold_convert (gfc_array_index_type, index),
+ fold_convert (gfc_array_index_type, min))
+ : fold_convert (gfc_array_index_type, index);
+
+ tree delta = spacing_bytes;
+ if (delta == NULL_TREE)
+ delta = fold_convert_loc (input_location, gfc_array_index_type,
+ TYPE_SIZE_UNIT (type));
tree offset_bytes = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- zero_based_index, elt_size);
+ zero_based_index, delta);
+ if (offset && !integer_zerop (offset))
+ offset_bytes = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ offset_bytes, offset);
+
+ offset_bytes = fold_convert_loc (input_location, sizetype,
+ offset_bytes);
tree base_addr = gfc_build_addr_expr (pvoid_type_node, base);
@@ -571,6 +499,31 @@ gfc_build_array_ref (tree base, tree offset, tree decl,
}
+tree
+gfc_build_array_ref (tree base, tree index, bool non_negative_offset,
+ tree min_idx, tree spacing, tree offset)
+{
+ tree type = TREE_TYPE (base);
+
+ if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
+ {
+ gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
+
+ return fold_convert (TYPE_MAIN_VARIANT (type), base);
+ }
+
+ /* Scalar coarray, there is nothing to do. */
+ if (TREE_CODE (type) != ARRAY_TYPE)
+ {
+ gcc_assert (integer_zerop (index));
+ return base;
+ }
+
+ return gfc_build_array_ref (TREE_TYPE (type), base, index, non_negative_offset,
+ min_idx, spacing, offset);
+}
+
+
/* Generate a call to print a runtime error possibly including multiple
arguments and a locus. */
@@ -1826,7 +1779,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen,
caf_type = TREE_TYPE (caf_decl);
STRIP_NOPS (pointer);
if (GFC_DESCRIPTOR_TYPE_P (caf_type))
- token = gfc_conv_descriptor_token (caf_decl);
+ token = gfc_conv_descriptor_token_get (caf_decl);
else if (DECL_LANG_SPECIFIC (caf_decl)
&& GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
token = GFC_DECL_TOKEN (caf_decl);
@@ -1926,8 +1879,12 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen,
omp_tmp, tmp);
}
gfc_add_expr_to_block (&non_null, tmp);
- gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
- 0));
+ if (descr)
+ gfc_conv_descriptor_data_set (&non_null, descr,
+ build_int_cst (ptr_type_node, 0));
+ else
+ gfc_add_modify (&non_null, pointer,
+ build_int_cst (TREE_TYPE (pointer), 0));
if (flag_openmp_allocators && descr)
gfc_conv_descriptor_version_set (&non_null, descr, integer_zero_node);
@@ -1993,10 +1950,19 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen,
if (status != NULL_TREE && !integer_zerop (status))
{
tree stat = build_fold_indirect_ref_loc (input_location, status);
- tree nullify = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, pointer,
- build_int_cst (TREE_TYPE (pointer),
- 0));
+ tree nullify;
+ if (descr)
+ {
+ stmtblock_t blk;
+ gfc_init_block (&blk);
+ gfc_conv_descriptor_data_set (&blk, descr,
+ build_int_cst (ptr_type_node, 0));
+ nullify = gfc_finish_block (&blk);
+ }
+ else
+ nullify = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, pointer,
+ build_int_cst (TREE_TYPE (pointer), 0));
TREE_USED (label_finish) = 1;
tmp = build1_v (GOTO_EXPR, label_finish);
@@ -2007,6 +1973,9 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree errlen,
tmp, nullify);
gfc_add_expr_to_block (&non_null, tmp);
}
+ else if (descr)
+ gfc_conv_descriptor_data_set (&non_null, descr,
+ build_int_cst (ptr_type_node, 0));
else
gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer),
0));
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 461b0cdac71c..9aa00228ee0b 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -61,9 +61,6 @@ typedef struct gfc_se
the reference to the class object here. */
tree class_container;
- /* Whether expr is a reference to an unlimited polymorphic object. */
- unsigned unlimited_polymorphic:1;
-
/* If set gfc_conv_variable will return an expression for the array
descriptor. When set, want_pointer should also be set.
If not set scalarizing variables will be substituted. */
@@ -197,21 +194,28 @@ typedef struct gfc_array_info
gfc_ref *ref;
/* The descriptor of this array. */
tree descriptor;
- /* holds the pointer to the data array. */
+ /* holds the pointer to the array. */
tree data;
+ /* value of the pointer to the array before the beginning of the loops. */
+ tree saved_data;
/* To move some of the array index calculation out of the innermost loop. */
tree offset;
- tree saved_offset;
- tree stride0;
+
/* Holds the SS for a subscript. Indexed by actual dimension. */
struct gfc_ss *subscript[GFC_MAX_DIMENSIONS];
- /* stride and delta are used to access this inside a scalarization loop.
+ /* stride, spacing and delta are used to access this inside a scalarization loop.
start is used in the calculation of these. Indexed by scalarizer
dimension. */
+ tree lbound[GFC_MAX_DIMENSIONS];
tree start[GFC_MAX_DIMENSIONS];
tree end[GFC_MAX_DIMENSIONS];
+ /* The spacing of indexes, that may be specified by the strides of array
+ references. */
tree stride[GFC_MAX_DIMENSIONS];
+ /* The spacing in memory of elements of consecutive indexes, for each
+ dimension. This is the intrinsic spacing of the array. */
+ tree spacing[GFC_MAX_DIMENSIONS];
tree delta[GFC_MAX_DIMENSIONS];
}
gfc_array_info;
@@ -289,6 +293,7 @@ typedef struct gfc_ss_info
struct
{
tree type;
+ unsigned preserve_bounds:1;
}
temp;
@@ -433,6 +438,7 @@ gfc_wrapped_block;
tree gfc_class_set_static_fields (tree, tree, tree);
tree gfc_class_data_get (tree);
tree gfc_class_vptr_get (tree);
+bool gfc_class_len_get (tree, tree *);
tree gfc_class_len_get (tree);
tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false,
@@ -464,7 +470,7 @@ bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
void gfc_finalize_tree_expr (gfc_se *, gfc_symbol *, symbol_attribute, int);
bool gfc_assignment_finalizer_call (gfc_se *, gfc_expr *, bool);
-void gfc_class_array_data_assign (stmtblock_t *, tree, tree, bool);
+void gfc_conv_remap_descriptor (stmtblock_t *, tree, tree, int, const gfc_array_ref &);
void gfc_conv_derived_to_class (gfc_se *, gfc_expr *, gfc_symbol *fsym, tree,
bool, bool, const char *, tree * = nullptr);
void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool, bool,
@@ -637,9 +643,12 @@ tree gfc_get_extern_function_decl (gfc_symbol *,
tree gfc_build_addr_expr (tree, tree);
/* Build an ARRAY_REF. */
-tree gfc_build_array_ref (tree, tree, tree,
- bool non_negative_offset = false,
- tree vptr = NULL_TREE);
+tree gfc_build_array_ref (tree, tree, bool non_negative_offset = false,
+ tree min_idx = NULL_TREE, tree spacing = NULL_TREE,
+ tree offset = NULL_TREE);
+tree gfc_build_array_ref (tree, tree, tree, bool non_negative_offset = false,
+ tree min_idx = NULL_TREE, tree spacing = NULL_TREE,
+ tree offset = NULL_TREE);
/* Build an array ref using pointer arithmetic. */
tree gfc_build_spanned_array_ref (tree base, tree offset, tree span);
@@ -661,7 +670,7 @@ void gfc_build_builtin_function_decls (void);
void gfc_set_decl_location (tree, locus *);
/* Get a module symbol backend_decl if possible. */
-bool gfc_get_module_backend_decl (gfc_symbol *);
+bool gfc_get_module_backend_decl (gfc_symbol *, bool = true);
/* Return the variable decl for a symbol. */
tree gfc_get_symbol_decl (gfc_symbol *);
@@ -1033,7 +1042,9 @@ struct GTY(()) lang_type {
enum gfc_array_kind akind;
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
- tree stride[GFC_MAX_DIMENSIONS];
+ tree spacing[GFC_MAX_DIMENSIONS];
+ tree elem_len;
+ tree align;
tree size;
tree offset;
tree dtype;
@@ -1042,6 +1053,7 @@ struct GTY(()) lang_type {
tree nonrestricted_type;
tree caf_token;
tree caf_offset;
+ tree parent_class_wrapper_type;
};
struct GTY(()) lang_decl {
@@ -1098,14 +1110,29 @@ struct GTY(()) lang_decl {
#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node)
/* Fortran CLASS type. */
#define GFC_CLASS_TYPE_P(node) TYPE_LANG_FLAG_4(node)
+#define GFC_TYPE_PACKED_ARRAY(node) TYPE_LANG_FLAG_5(node)
/* The GFC_TYPE_ARRAY_* members are present in both descriptor and
descriptorless array types. */
#define GFC_TYPE_ARRAY_LBOUND(node, dim) \
(TYPE_LANG_SPECIFIC(node)->lbound[dim])
#define GFC_TYPE_ARRAY_UBOUND(node, dim) \
(TYPE_LANG_SPECIFIC(node)->ubound[dim])
+#define GFC_TYPE_ARRAY_SPACING(node, dim) \
+ (TYPE_LANG_SPECIFIC(node)->spacing[dim])
+#define GFC_TYPE_ARRAY_EXTENT(node, dim) \
+ (fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, \
+ fold_build2_loc (input_location, MINUS_EXPR, \
+ gfc_array_index_type, \
+ GFC_TYPE_ARRAY_UBOUND((node), (dim)), \
+ GFC_TYPE_ARRAY_LBOUND((node), (dim))), \
+ gfc_index_one_node))
+#if 0
#define GFC_TYPE_ARRAY_STRIDE(node, dim) \
- (TYPE_LANG_SPECIFIC(node)->stride[dim])
+ (fold_build2_loc (input_location, EXACT_DIV_EXPR, gfc_array_index_type, \
+ GFC_TYPE_ARRAY_SPACING((node), (dim)), \
+ GFC_TYPE_ARRAY_ELEM_LEN((node))))
+#endif
+#define GFC_TYPE_ARRAY_ELEM_LEN(node) (TYPE_LANG_SPECIFIC(node)->elem_len)
#define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
#define GFC_TYPE_ARRAY_CORANK(node) (TYPE_LANG_SPECIFIC(node)->corank)
#define GFC_TYPE_ARRAY_CAF_TOKEN(node) (TYPE_LANG_SPECIFIC(node)->caf_token)
@@ -1120,7 +1147,8 @@ struct GTY(()) lang_decl {
(TYPE_LANG_SPECIFIC(node)->dataptr_type)
#define GFC_TYPE_ARRAY_BASE_DECL(node, internal) \
(TYPE_LANG_SPECIFIC(node)->base_decl[(internal)])
-
+#define GFC_TYPE_PARENT_CLASS_TYPE(node) \
+ (TYPE_LANG_SPECIFIC(node)->parent_class_wrapper_type)
/* Build an expression with void type. */
#define build1_v(code, arg) \
diff --git a/gcc/gimple-fold.cc b/gcc/gimple-fold.cc
index 729080ad6e5b..708083e6db0e 100644
--- a/gcc/gimple-fold.cc
+++ b/gcc/gimple-fold.cc
@@ -327,6 +327,12 @@ maybe_fold_reference (tree expr)
if (result && is_gimple_min_invariant (result))
return result;
+ if (result
+ && TREE_CODE (result) == MEM_REF
+ && TREE_CODE (expr) == ARRAY_REF
+ && TREE_CODE (TREE_OPERAND (expr, 0)) == MEM_REF)
+ return result;
+
return NULL_TREE;
}
@@ -10068,9 +10074,10 @@ fold_const_aggregate_ref_1 (tree t, tree (*valueize) (tree))
FIXME: This code can't handle nested references with variable indexes
(they will be handled only by iteration of ccp). Perhaps we can bring
get_ref_base_and_extent here and make it use a valueize callback. */
- if (TREE_CODE (TREE_OPERAND (t, 1)) == SSA_NAME
- && valueize
- && (idx = (*valueize) (TREE_OPERAND (t, 1)))
+ if (((TREE_CODE (TREE_OPERAND (t, 1)) == SSA_NAME
+ && valueize
+ && (idx = (*valueize) (TREE_OPERAND (t, 1))))
+ || (idx = TREE_OPERAND (t, 1)))
&& poly_int_tree_p (idx))
{
tree low_bound, unit_size;
@@ -10081,12 +10088,13 @@ fold_const_aggregate_ref_1 (tree t, tree (*valueize) (tree))
&& (unit_size = array_ref_element_size (t),
tree_fits_uhwi_p (unit_size)))
{
- poly_offset_int woffset
+ poly_offset_int woffset, woffset_bytes;
+ woffset_bytes
= wi::sext (wi::to_poly_offset (idx)
- wi::to_poly_offset (low_bound),
TYPE_PRECISION (sizetype));
- woffset *= tree_to_uhwi (unit_size);
- woffset *= BITS_PER_UNIT;
+ woffset_bytes *= tree_to_uhwi (unit_size);
+ woffset = woffset_bytes * BITS_PER_UNIT;
if (woffset.to_shwi (&offset))
{
base = TREE_OPERAND (t, 0);
@@ -10099,12 +10107,32 @@ fold_const_aggregate_ref_1 (tree t, tree (*valueize) (tree))
if (maybe_lt (offset, 0))
return NULL_TREE;
/* We cannot determine ctor. */
- if (!ctor)
- return NULL_TREE;
- return fold_ctor_reference (TREE_TYPE (t), ctor, offset,
- tree_to_uhwi (unit_size)
- * BITS_PER_UNIT,
- base);
+ if (ctor)
+ return fold_ctor_reference (TREE_TYPE (t), ctor, offset,
+ tree_to_uhwi (unit_size)
+ * BITS_PER_UNIT,
+ base);
+ if (TREE_CODE (base) == MEM_REF)
+ {
+ woffset_bytes += wi::to_offset (TREE_OPERAND (base, 1));
+ tree offset_type = TREE_TYPE (TREE_OPERAND (base, 1));
+ if (TREE_CODE (offset_type) == POINTER_TYPE
+ && TREE_CODE (TREE_TYPE (offset_type)) == ARRAY_TYPE)
+ {
+ tree type = build_pointer_type (
+ TREE_TYPE (TREE_TYPE (offset_type)));
+ if (wi::fits_to_tree_p (woffset_bytes, type))
+ {
+ tree offset = wide_int_to_tree (type,
+ woffset_bytes);
+ return fold_build2_loc (EXPR_LOCATION (t), MEM_REF,
+ TREE_TYPE (t),
+ TREE_OPERAND (base, 0),
+ offset);
+ }
+ }
+
+ }
}
}
}
diff --git a/gcc/gimple-loop-versioning.cc b/gcc/gimple-loop-versioning.cc
index 5c9b2fb77ff9..6140972fcd0b 100644
--- a/gcc/gimple-loop-versioning.cc
+++ b/gcc/gimple-loop-versioning.cc
@@ -41,6 +41,7 @@ along with GCC; see the file COPYING3. If not see
#include "tree-into-ssa.h"
#include "gimple-range.h"
#include "tree-cfg.h"
+#include "tree-dfa.h"
namespace {
@@ -172,6 +173,8 @@ struct address_term_info
/* True if STRIDE == 1 is a versioning opportunity when considered
in isolation. */
bool versioning_opportunity_p;
+
+ unsigned HOST_WIDE_INT versioning_value;
};
/* Information about an address calculation, and the range of constant
@@ -237,11 +240,23 @@ public:
(keyed off their SSA_NAME_VERSION) are all equal to 1 at runtime. */
bitmap_head unity_names;
+ /* We'd like to version the loop for the case in which these SSA names
+ (keyed off their SSA_NAME_VERSION) are equal to the respective access size
+ at runtime. */
+ typedef hash_map <unsigned, unsigned HOST_WIDE_INT,
+ simple_hashmap_traits <int_hash <unsigned, 0, UINT_MAX>,
+ unsigned HOST_WIDE_INT>>
+ name_value_map_t;
+ name_value_map_t non_unity_versioning_values;
+
/* If versioning succeeds, this points the version of the loop that
assumes the version conditions holds. */
class loop *optimized_loop;
};
+static void
+dump_inner_likelihood (address_info &, address_term_info &);
+
/* The main pass structure. */
class loop_versioning
{
@@ -283,13 +298,12 @@ private:
unsigned int max_insns_for_loop (class loop *);
bool expensive_stmt_p (gimple *);
- void version_for_unity (gimple *, tree);
+ void version_for_value (gimple *, tree, unsigned HOST_WIDE_INT);
bool acceptable_multiplier_p (tree, unsigned HOST_WIDE_INT,
unsigned HOST_WIDE_INT * = 0);
bool acceptable_type_p (tree, unsigned HOST_WIDE_INT *);
bool multiply_term_by (address_term_info &, tree);
inner_likelihood get_inner_likelihood (tree, unsigned HOST_WIDE_INT);
- void dump_inner_likelihood (address_info &, address_term_info &);
void analyze_stride (address_info &, address_term_info &,
tree, class loop *);
bool find_per_loop_multiplication (address_info &, address_term_info &);
@@ -487,7 +501,9 @@ bool
loop_info::worth_versioning_p () const
{
return (!rejected_p
- && (!bitmap_empty_p (&unity_names) || subloops_benefit_p));
+ && (!bitmap_empty_p (&unity_names)
+ || !non_unity_versioning_values.is_empty ()
+ || subloops_benefit_p));
}
loop_versioning::lv_dom_walker::lv_dom_walker (loop_versioning &lv)
@@ -512,9 +528,17 @@ loop_versioning::lv_dom_walker::before_dom_children (basic_block bb)
tree
loop_versioning::name_prop::value_of_expr (tree val, gimple *)
{
- if (TREE_CODE (val) == SSA_NAME
- && bitmap_bit_p (&m_li.unity_names, SSA_NAME_VERSION (val)))
+ if (TREE_CODE (val) != SSA_NAME)
+ return NULL_TREE;
+
+ if (bitmap_bit_p (&m_li.unity_names, SSA_NAME_VERSION (val)))
return build_one_cst (TREE_TYPE (val));
+
+ unsigned HOST_WIDE_INT *version_size;
+ version_size = m_li.non_unity_versioning_values.get (SSA_NAME_VERSION (val));
+ if (version_size)
+ return build_int_cst (TREE_TYPE (val), *version_size);
+
return NULL_TREE;
}
@@ -535,6 +559,7 @@ loop_versioning::loop_versioning (function *fn)
{
m_loops[i].outermost = get_loop (m_fn, 0);
bitmap_initialize (&m_loops[i].unity_names, &m_bitmap_obstack);
+ m_loops[i].non_unity_versioning_values.empty ();
}
/* Initialize the list of blocks that belong to each loop. */
@@ -606,12 +631,40 @@ loop_versioning::expensive_stmt_p (gimple *stmt)
is invariant in the loop. */
void
-loop_versioning::version_for_unity (gimple *stmt, tree name)
+loop_versioning::version_for_value (gimple *stmt, tree name,
+ unsigned HOST_WIDE_INT value)
{
class loop *loop = loop_containing_stmt (stmt);
loop_info &li = get_loop_info (loop);
- if (bitmap_set_bit (&li.unity_names, SSA_NAME_VERSION (name)))
+ bool changed = false;
+ if (value == 1
+ && bitmap_set_bit (&li.unity_names, SSA_NAME_VERSION (name)))
+ changed = true;
+ else
+ {
+ bool existed;
+ unsigned HOST_WIDE_INT &versioning_value
+ = li.non_unity_versioning_values.get_or_insert (
+ SSA_NAME_VERSION (name), &existed);
+ if (!existed)
+ {
+ versioning_value = value;
+ changed = true;
+ }
+ else if (versioning_value != value)
+ {
+ li.rejected_p = true;
+ if (dump_enabled_p ())
+ dump_printf_loc (MSG_NOTE, stmt, "disabling versioning of loop with"
+ " multiple values for %T: " HOST_WIDE_INT_PRINT_DEC
+ " and " HOST_WIDE_INT_PRINT_DEC "\n", name,
+ versioning_value, value);
+ return;
+ }
+ }
+
+ if (changed)
{
/* This is the first time we've wanted to version LOOP for NAME.
Keep track of the outermost loop that can handle all versioning
@@ -624,7 +677,8 @@ loop_versioning::version_for_unity (gimple *stmt, tree name)
if (dump_enabled_p ())
{
dump_printf_loc (MSG_NOTE, stmt, "want to version containing loop"
- " for when %T == 1", name);
+ " for when %T == " HOST_WIDE_INT_PRINT_UNSIGNED,
+ name, value);
if (outermost == loop)
dump_printf (MSG_NOTE, "; cannot hoist check further");
else
@@ -645,7 +699,8 @@ loop_versioning::version_for_unity (gimple *stmt, tree name)
/* This is a duplicate request. */
if (dump_enabled_p ())
dump_printf_loc (MSG_NOTE, stmt, "already asked to version containing"
- " loop for when %T == 1\n", name);
+ " loop for when %T == " HOST_WIDE_INT_PRINT_UNSIGNED "\n",
+ name, value);
}
}
@@ -785,9 +840,8 @@ loop_versioning::get_inner_likelihood (tree stride,
/* Dump the likelihood that TERM's stride is for the innermost dimension.
ADDRESS is the address that contains TERM. */
-void
-loop_versioning::dump_inner_likelihood (address_info &address,
- address_term_info &term)
+static void
+dump_inner_likelihood (address_info &address, address_term_info &term)
{
if (term.inner_likelihood == INNER_LIKELY)
dump_printf_loc (MSG_NOTE, address.stmt, "%T is likely to be the"
@@ -836,15 +890,24 @@ loop_versioning::analyze_stride (address_info &address,
- the stride is an SSA name that is invariant in STMT's loop,
since otherwise versioning isn't possible. */
unsigned HOST_WIDE_INT access_size = address.max_offset - address.min_offset;
- if (term.multiplier == access_size
+ if ((term.multiplier == access_size
+ || term.multiplier == 1)
&& address.loop == op_loop
&& TREE_CODE (stride) == SSA_NAME
&& expr_invariant_in_loop_p (address.loop, stride))
{
term.versioning_opportunity_p = true;
+ if (term.multiplier == access_size)
+ term.versioning_value = 1;
+ else
+ term.versioning_value = access_size;
+
if (dump_enabled_p ())
- dump_printf_loc (MSG_NOTE, address.stmt, "%T == 1 is a versioning"
- " opportunity\n", stride);
+ dump_printf_loc (MSG_NOTE, address.stmt, "%T == "
+ HOST_WIDE_INT_PRINT_DEC " is a versioning"
+ " opportunity\n", stride,
+ term.multiplier == access_size ? HOST_WIDE_INT_1U
+ : access_size);
}
}
@@ -991,6 +1054,185 @@ loop_versioning::analyze_arbitrary_term (address_info &address,
dump_inner_likelihood (address, term);
}
+
+static bool
+tree_same_expr_p (tree t1, tree t2)
+{
+ if (t1 == t2)
+ return true;
+
+ if (TREE_CODE (t1) != TREE_CODE (t2))
+ return false;
+
+ int len1 = TREE_OPERAND_LENGTH (t1);
+ int len2 = TREE_OPERAND_LENGTH (t2);
+ if (len1 != len2)
+ return false;
+
+ for (int i = 0; i < len1; ++i)
+ if (!tree_same_expr_p (TREE_OPERAND (t1, i),
+ TREE_OPERAND (t2, i)))
+ return false;
+
+ return true;
+}
+
+
+static void
+set_unknown_likelihood (address_info &address, address_term_info &term_info,
+ enum inner_likelihood value)
+
+{
+ if (term_info.inner_likelihood == INNER_DONT_KNOW)
+ {
+ term_info.inner_likelihood = value;
+ if (dump_enabled_p ())
+ dump_inner_likelihood (address, term_info);
+ }
+}
+
+
+static void
+guess_likelihood_from_offsets (address_info &address)
+{
+ struct stride_info
+ {
+ tree data_ref;
+ tree base;
+ HOST_WIDE_INT offset;
+ unsigned int idx;
+ };
+
+ auto_vec<stride_info> strides;
+ auto_vec<tree> worklist;
+
+ for (unsigned int i = 0; i < address.terms.length (); ++i)
+ {
+ worklist.safe_push (address.terms[i].expr);
+
+ while (!worklist.is_empty ())
+ {
+ tree expr = worklist.pop ();
+ tree old_expr = NULL_TREE;
+
+ while (expr != old_expr)
+ {
+ old_expr = expr;
+
+ expr = strip_casts (expr);
+ if (TREE_CODE (expr) == SSA_NAME)
+ {
+ gimple *stmt = SSA_NAME_DEF_STMT (expr);
+ if (!is_gimple_assign (stmt))
+ continue;
+
+ if (gimple_assign_single_p (stmt))
+ {
+ gassign *assign = as_a <gassign *> (stmt);
+ expr = gimple_assign_rhs1 (assign);
+ }
+ else if (gimple_assign_rhs_code (stmt) == MULT_EXPR)
+ {
+ worklist.safe_push (gimple_assign_rhs1 (stmt));
+ worklist.safe_push (gimple_assign_rhs2 (stmt));
+ expr = NULL_TREE;
+ break;
+ }
+ }
+ }
+
+ if (expr == NULL_TREE)
+ continue;
+
+ HOST_WIDE_INT offset;
+ HOST_WIDE_INT scratch_size;
+ bool scratch_reverse;
+ tree base = get_ref_base_and_extent_hwi (expr, &offset, &scratch_size,
+ &scratch_reverse);
+ if (base == NULL_TREE || offset < 0)
+ continue;
+
+ stride_info si;
+ si.data_ref = expr;
+ si.base = base;
+ si.offset = offset;
+ si.idx = i;
+
+ strides.safe_push (si);
+ }
+ }
+
+ unsigned int i;
+ stride_info *pinfo;
+ FOR_EACH_VEC_ELT (strides, i, pinfo)
+ if (pinfo->data_ref
+ && TREE_CODE (pinfo->data_ref) == COMPONENT_REF)
+ {
+ tree comp_base = TREE_OPERAND (pinfo->data_ref, 0);
+ if (TREE_CODE (comp_base) == ARRAY_REF)
+ {
+ unsigned int idx = pinfo->idx;
+ if (integer_zerop (TREE_OPERAND (comp_base, 1)))
+ set_unknown_likelihood (address, address.terms[idx],
+ INNER_LIKELY);
+ else if (TREE_CODE (TREE_OPERAND (comp_base, 1)) == INTEGER_CST)
+ set_unknown_likelihood (address, address.terms[idx],
+ INNER_UNLIKELY);
+ }
+ }
+
+ while (strides.length () > 0)
+ {
+ int j = strides.length () - 1;
+
+ stride_info min_offset_info = strides[j];
+ bool has_zero_offset = min_offset_info.offset == 0;
+ int count_non_zero_offset = min_offset_info.offset != 0;
+ strides.unordered_remove (j);
+
+ for (int i = j - 1; i >= 0; --i)
+ {
+ if (!tree_same_expr_p (strides[i].base, min_offset_info.base))
+ continue;
+
+ if (strides[i].offset == 0)
+ has_zero_offset = true;
+ else
+ {
+ if (min_offset_info.offset == 0)
+ min_offset_info = strides[i];
+ else
+ {
+ ++count_non_zero_offset;
+ if (strides[i].offset < min_offset_info.offset)
+ {
+ int idx = min_offset_info.idx;
+ set_unknown_likelihood (address, address.terms[idx],
+ INNER_UNLIKELY);
+
+ min_offset_info = strides[i];
+ }
+ else if (strides[i].offset > min_offset_info.offset)
+ {
+ int idx = strides[i].idx;
+ set_unknown_likelihood (address, address.terms[idx],
+ INNER_UNLIKELY);
+ }
+ }
+ }
+
+ strides.unordered_remove (i);
+ }
+
+ if (has_zero_offset
+ && count_non_zero_offset > 1
+ && min_offset_info.offset != 0)
+ set_unknown_likelihood (address, address.terms[min_offset_info.idx],
+ INNER_LIKELY);
+ }
+}
+
+
/* Try to identify loop strides in ADDRESS and try to choose realistic
versioning opportunities based on these strides.
@@ -1076,6 +1318,8 @@ loop_versioning::analyze_address_fragment (address_info &address)
&& !POINTER_TYPE_P (TREE_TYPE (address.terms[i].expr)))
analyze_arbitrary_term (address, address.terms[i]);
+ guess_likelihood_from_offsets (address);
+
/* Check for strides that are likely to be for the innermost dimension.
1. If there is a single likely inner stride, if it is an SSA name,
@@ -1125,36 +1369,39 @@ loop_versioning::analyze_address_fragment (address_info &address)
Pointer equality is enough to check for uniqueness in (1), since we
only care about SSA names. */
- tree chosen_stride = NULL_TREE;
- tree version_stride = NULL_TREE;
+ address_term_info *chosen_term = nullptr;
+ address_term_info *version_term = nullptr;
for (unsigned int i = 0; i < address.terms.length (); ++i)
- if (chosen_stride != address.terms[i].stride
- && address.terms[i].inner_likelihood == INNER_LIKELY)
+ if (address.terms[i].inner_likelihood == INNER_LIKELY)
{
- if (chosen_stride)
+ if (chosen_term == nullptr)
+ {
+ chosen_term = &address.terms[i];
+ if (address.terms[i].versioning_opportunity_p)
+ version_term = chosen_term;
+ }
+ else if (chosen_term->stride != address.terms[i].stride)
return;
- chosen_stride = address.terms[i].stride;
- if (address.terms[i].versioning_opportunity_p)
- version_stride = chosen_stride;
}
/* If there are no likely inner strides, see if there is a single
versioning opportunity for a stride that was rated as INNER_DONT_KNOW.
See the comment above the function for the cases that this code
handles. */
- if (!chosen_stride)
+ if (!chosen_term)
for (unsigned int i = 0; i < address.terms.length (); ++i)
- if (version_stride != address.terms[i].stride
- && address.terms[i].inner_likelihood == INNER_DONT_KNOW
+ i[...]
[diff truncated at 524288 bytes]
More information about the Gcc-cvs
mailing list