From ff3598bc73dbae3a612709daca41e56ab5aa6928 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 10 Sep 2017 17:02:53 +0000 Subject: [PATCH] re PR fortran/34640 (ICE when assigning item of a derived-component to a pointer) 2017-09-10 Paul Thomas PR fortran/34640 PR fortran/40737 PR fortran/55763 PR fortran/57019 PR fortran/57116 * expr.c (is_subref_array): Add class pointer array dummies to the list of expressions that return true. * trans-array.c: Add SPAN_FIELD and update indices for subsequent fields. (gfc_conv_descriptor_span, gfc_conv_descriptor_span_get, gfc_conv_descriptor_span_set, is_pointer_array, get_array_span): New functions. (gfc_get_descriptor_offsets_for_info): New function to preserve API for access to descriptor fields for trans-types.c. (gfc_conv_scalarized_array_ref): If the expression is a subref array, make sure that info->descriptor is a descriptor type. Otherwise, if info->descriptor is a pointer array, set 'decl' and fix it if it is a component reference. (build_array_ref): Simplify handling of class array refs by passing the vptr to gfc_build_array_ref rather than generating the pointer arithmetic in this function. (gfc_conv_array_ref): As in gfc_conv_scalarized_array_ref, set 'decl'. (gfc_array_allocate): Set the span field if this is a pointer array. Use the expr3 element size if it is available, so that the dynamic type element size is used. (gfc_conv_expr_descriptor): Set the span field for pointer assignments. * trans-array.h: Prototypes for gfc_conv_descriptor_span_get gfc_conv_descriptor_span_set and gfc_get_descriptor_offsets_for_info added. trans-decl.c (gfc_get_symbol_decl): If a non-class pointer array, mark the declaration as a GFC_DECL_PTR_ARRAY_P. Remove the setting of GFC_DECL_SPAN. (gfc_trans_deferred_vars): Set the span field to zero in thge originating scope. * trans-expr.c (gfc_conv_procedure_call): Do not use copy-in/ copy-out to pass subref expressions to a pointer dummy. (gfc_trans_pointer_assignment): Remove code for setting of GFC_DECL_SPAN. Set the 'span' field for non-class pointers to class function results. Likewise for rank remap. In the case that the target is not a whole array, use the target array ref for remap and, since the 'start' indices are missing, set the lbounds to one, as required by the standard. * trans-intrinsic.c (conv_expr_ref_to_caf_ref): Pick up the 'token' offset from the field decl in the descriptor. (conv_isocbinding_subroutine): Set the 'span' field. * trans-io.c (gfc_trans_transfer): Always scalarize pointer array io. * trans-stmt.c (trans_associate_var): Set the 'span' field. * trans-types.c (gfc_get_array_descriptor_base): Add the 'span' field to the array descriptor. (gfc_get_derived_type): Pointer array components are marked as GFC_DECL_PTR_ARRAY_P. (gfc_get_array_descr_info): Replaced API breaking code for descriptor offset calling gfc_get_descriptor_offsets_for_info. * trans.c (get_array_span): New function. (gfc_build_array_ref): Simplify by calling get_array_span and obtain 'span' if 'decl' or 'vptr' present. * trans.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P, as GFC_DECL_PTR_ARRAY_P. 2017-09-10 Paul Thomas PR fortran/34640 * gfortran.dg/associate_24.f90: New test. * gfortran.dg/assumed_type_2.f90: Adjust some of the tree dump checks. * gfortran.dg/no_arg_check_2.f90: Likewise. * gfortran.dg/pointer_array_1.f90: New test. * gfortran.dg/pointer_array_2.f90: New test. * gfortran.dg/pointer_array_7.f90: New test. * gfortran.dg/pointer_array_8.f90: New test. * gfortran.dg/pointer_array_component_1.f90: New test. * gfortran.dg/pointer_array_component_2.f90: New test. * gfortran.dg/goacc/kernels-alias-4.f95: Bump up both tree scan counts by 1. PR fortran/40737 * gfortran.dg/pointer_array_3.f90: New test. PR fortran/57116 * gfortran.dg/pointer_array_4.f90: New test. PR fortran/55763 * gfortran.dg/pointer_array_5.f90: New test. PR fortran/57019 * gfortran.dg/pointer_array_6.f90: New test. 2017-09-10 Paul Thomas PR fortran/34640 * libgfortran/libgfortran.h: Add span field to descriptor. * libgfortran/libtool-version : Bump up version number to 5:0:0. From-SVN: r251949 --- gcc/fortran/ChangeLog | 65 +++++ gcc/fortran/expr.c | 5 + gcc/fortran/trans-array.c | 258 +++++++++++++++--- gcc/fortran/trans-array.h | 5 + gcc/fortran/trans-decl.c | 40 ++- gcc/fortran/trans-expr.c | 69 +++-- gcc/fortran/trans-intrinsic.c | 12 +- gcc/fortran/trans-io.c | 9 + gcc/fortran/trans-stmt.c | 19 +- gcc/fortran/trans-types.c | 37 ++- gcc/fortran/trans.c | 139 +++++----- gcc/fortran/trans.h | 2 +- gcc/testsuite/ChangeLog | 28 ++ gcc/testsuite/gfortran.dg/associate_24.f90 | 33 +++ gcc/testsuite/gfortran.dg/assumed_type_2.f90 | 4 +- .../gfortran.dg/goacc/kernels-alias-4.f95 | 4 +- gcc/testsuite/gfortran.dg/no_arg_check_2.f90 | 4 +- gcc/testsuite/gfortran.dg/pointer_array_1.f90 | 60 ++++ gcc/testsuite/gfortran.dg/pointer_array_2.f90 | 143 ++++++++++ gcc/testsuite/gfortran.dg/pointer_array_3.f90 | 51 ++++ gcc/testsuite/gfortran.dg/pointer_array_4.f90 | 75 +++++ gcc/testsuite/gfortran.dg/pointer_array_5.f90 | 65 +++++ gcc/testsuite/gfortran.dg/pointer_array_6.f90 | 28 ++ gcc/testsuite/gfortran.dg/pointer_array_7.f90 | 46 ++++ gcc/testsuite/gfortran.dg/pointer_array_8.f90 | 81 ++++++ .../gfortran.dg/pointer_array_component_1.f90 | 47 ++++ .../gfortran.dg/pointer_array_component_2.f90 | 43 +++ libgfortran/ChangeLog | 6 + libgfortran/libgfortran.h | 1 + libgfortran/libtool-version | 2 +- 30 files changed, 1202 insertions(+), 179 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_24.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_5.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_6.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 140caf508c3..20fae5ae804 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,68 @@ +2017-09-10 Paul Thomas + + PR fortran/34640 + PR fortran/40737 + PR fortran/55763 + PR fortran/57019 + PR fortran/57116 + + * expr.c (is_subref_array): Add class pointer array dummies + to the list of expressions that return true. + * trans-array.c: Add SPAN_FIELD and update indices for + subsequent fields. + (gfc_conv_descriptor_span, gfc_conv_descriptor_span_get, + gfc_conv_descriptor_span_set, is_pointer_array, + get_array_span): New functions. + (gfc_get_descriptor_offsets_for_info): New function to preserve + API for access to descriptor fields for trans-types.c. + (gfc_conv_scalarized_array_ref): If the expression is a subref + array, make sure that info->descriptor is a descriptor type. + Otherwise, if info->descriptor is a pointer array, set 'decl' + and fix it if it is a component reference. + (build_array_ref): Simplify handling of class array refs by + passing the vptr to gfc_build_array_ref rather than generating + the pointer arithmetic in this function. + (gfc_conv_array_ref): As in gfc_conv_scalarized_array_ref, set + 'decl'. + (gfc_array_allocate): Set the span field if this is a pointer + array. Use the expr3 element size if it is available, so that + the dynamic type element size is used. + (gfc_conv_expr_descriptor): Set the span field for pointer + assignments. + * trans-array.h: Prototypes for gfc_conv_descriptor_span_get + gfc_conv_descriptor_span_set and + gfc_get_descriptor_offsets_for_info added. + trans-decl.c (gfc_get_symbol_decl): If a non-class pointer + array, mark the declaration as a GFC_DECL_PTR_ARRAY_P. Remove + the setting of GFC_DECL_SPAN. + (gfc_trans_deferred_vars): Set the span field to zero in thge + originating scope. + * trans-expr.c (gfc_conv_procedure_call): Do not use copy-in/ + copy-out to pass subref expressions to a pointer dummy. + (gfc_trans_pointer_assignment): Remove code for setting of + GFC_DECL_SPAN. Set the 'span' field for non-class pointers to + class function results. Likewise for rank remap. In the case + that the target is not a whole array, use the target array ref + for remap and, since the 'start' indices are missing, set the + lbounds to one, as required by the standard. + * trans-intrinsic.c (conv_expr_ref_to_caf_ref): Pick up the + 'token' offset from the field decl in the descriptor. + (conv_isocbinding_subroutine): Set the 'span' field. + * trans-io.c (gfc_trans_transfer): Always scalarize pointer + array io. + * trans-stmt.c (trans_associate_var): Set the 'span' field. + * trans-types.c (gfc_get_array_descriptor_base): Add the 'span' + field to the array descriptor. + (gfc_get_derived_type): Pointer array components are marked as + GFC_DECL_PTR_ARRAY_P. + (gfc_get_array_descr_info): Replaced API breaking code for + descriptor offset calling gfc_get_descriptor_offsets_for_info. + * trans.c (get_array_span): New function. + (gfc_build_array_ref): Simplify by calling get_array_span and + obtain 'span' if 'decl' or 'vptr' present. + * trans.h : Rename DECL_LANG_FLAG_6, GFC_DECL_SUBREF_ARRAY_P, + as GFC_DECL_PTR_ARRAY_P. + 2017-09-09 Paul Thomas * decl.c : Add decl_type_param_list, type_param_spec_list as diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 079a2ba9dbe..35df29c6652 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -995,6 +995,11 @@ is_subref_array (gfc_expr * e) if (e->symtree->n.sym->attr.subref_array_pointer) return true; + if (e->symtree->n.sym->ts.type == BT_CLASS + && e->symtree->n.sym->attr.dummy + && CLASS_DATA (e->symtree->n.sym)->attr.class_pointer) + return true; + seen_array = false; for (ref = e->ref; ref; ref = ref->next) { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 2b06903bffd..328da4e78b1 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -125,8 +125,9 @@ gfc_array_dataptr_type (tree desc) #define DATA_FIELD 0 #define OFFSET_FIELD 1 #define DTYPE_FIELD 2 -#define DIMENSION_FIELD 3 -#define CAF_TOKEN_FIELD 4 +#define SPAN_FIELD 3 +#define DIMENSION_FIELD 4 +#define CAF_TOKEN_FIELD 5 #define STRIDE_SUBFIELD 0 #define LBOUND_SUBFIELD 1 @@ -244,6 +245,36 @@ gfc_conv_descriptor_dtype (tree desc) desc, field, NULL_TREE); } +static tree +gfc_conv_descriptor_span (tree desc) +{ + tree type; + tree field; + + type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), SPAN_FIELD); + gcc_assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + +tree +gfc_conv_descriptor_span_get (tree desc) +{ + return gfc_conv_descriptor_span (desc); +} + +void +gfc_conv_descriptor_span_set (stmtblock_t *block, tree desc, + tree value) +{ + tree t = gfc_conv_descriptor_span (desc); + gfc_add_modify (block, t, fold_convert (TREE_TYPE (t), value)); +} + tree gfc_conv_descriptor_rank (tree desc) @@ -466,11 +497,41 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, } +/* Obtain offsets for trans-types.c(gfc_get_array_descr_info). */ + +void +gfc_get_descriptor_offsets_for_info (const_tree desc_type, tree *data_off, + tree *dtype_off, tree *dim_off, + tree *dim_size, tree *stride_suboff, + tree *lower_suboff, tree *upper_suboff) +{ + tree field; + tree type; + + type = TYPE_MAIN_VARIANT (desc_type); + field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_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), 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); +} + + /* 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 @@ -720,6 +781,84 @@ gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) } +/* Returns true if the expression is an array pointer. */ + +static bool +is_pointer_array (tree expr) +{ + if (flag_openmp) + return false; + + if (expr == NULL_TREE + || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr)) + || GFC_CLASS_TYPE_P (TREE_TYPE (expr))) + return false; + + if (TREE_CODE (expr) == VAR_DECL + && GFC_DECL_PTR_ARRAY_P (expr)) + return true; + + if (TREE_CODE (expr) == PARM_DECL + && GFC_DECL_PTR_ARRAY_P (expr)) + return true; + + if (TREE_CODE (expr) == INDIRECT_REF + && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 0))) + return true; + + /* The field declaration is marked as an pointer array. */ + if (TREE_CODE (expr) == COMPONENT_REF + && GFC_DECL_PTR_ARRAY_P (TREE_OPERAND (expr, 1)) + && !GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (expr, 1)))) + return true; + + return false; +} + + +/* Return the span of an array. */ + +static tree +get_array_span (tree desc, gfc_expr *expr) +{ + tree tmp; + + if (is_pointer_array (desc)) + /* This will have the span field set. */ + tmp = gfc_conv_descriptor_span_get (desc); + else if (TREE_CODE (desc) == COMPONENT_REF + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0)))) + { + /* The descriptor is a class _data field and so use the vtable + size for the receiving span field. */ + tmp = gfc_get_vptr_from_expr (desc); + tmp = gfc_vptr_size_get (tmp); + } + else if (expr && expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->ts.type == BT_CLASS + && expr->ref->type == REF_COMPONENT + && expr->ref->next->type == REF_ARRAY + && expr->ref->next->next == NULL + && CLASS_DATA (expr->symtree->n.sym)->attr.dimension) + { + /* Dummys come in sometimes with the descriptor detached from + the class field or declaration. */ + tmp = gfc_class_vptr_get (expr->symtree->n.sym->backend_decl); + tmp = gfc_vptr_size_get (tmp); + } + else + { + /* If none of the fancy stuff works, the span is the element + size of the array. */ + tmp = gfc_get_element_type (TREE_TYPE (desc)); + tmp = fold_convert (gfc_array_index_type, + size_in_bytes (tmp)); + } + return tmp; +} + + /* Generate an initializer for a static pointer or allocatable array. */ void @@ -3239,11 +3378,30 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, index, info->offset); - if (expr && (is_subref_array (expr) + if (expr && ((is_subref_array (expr) + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (info->descriptor))) || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_FUNCTION)))) decl = expr->symtree->n.sym->backend_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)) + { + if (TREE_CODE (info->descriptor) == COMPONENT_REF) + { + decl = gfc_evaluate_now (info->descriptor, &se->pre); + GFC_DECL_PTR_ARRAY_P (decl) = 1; + TREE_USED (decl) = 1; + } + else if (TREE_CODE (info->descriptor) == INDIRECT_REF) + decl = TREE_OPERAND (info->descriptor, 0); + + if (decl == NULL_TREE) + decl = info->descriptor; + } + tmp = build_fold_indirect_ref_loc (input_location, info->data); /* Use the vptr 'size' field to access a class the element of a class @@ -3288,45 +3446,27 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr) { tree tmp; tree type; - tree cdecl; - bool classarray = false; + 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))) - cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( + cdesc = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR ( TREE_OPERAND (desc, 0))); else - cdecl = desc; + 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 (cdecl)) - && TREE_CODE (cdecl) == COMPONENT_REF) + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdesc)) + && TREE_CODE (cdesc) == COMPONENT_REF) { - type = TREE_TYPE (TREE_OPERAND (cdecl, 0)); + type = TREE_TYPE (TREE_OPERAND (cdesc, 0)); if (TYPE_CANONICAL (type) && GFC_CLASS_TYPE_P (TYPE_CANONICAL (type))) - { - type = TREE_TYPE (desc); - classarray = true; - } - } - else - type = NULL; - - /* Class array references need special treatment because the assigned - type size needs to be used to point to the element. */ - if (classarray) - { - type = gfc_get_element_type (type); - tmp = TREE_OPERAND (cdecl, 0); - tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE); - tmp = fold_convert (build_pointer_type (type), tmp); - tmp = build_fold_indirect_ref_loc (input_location, tmp); - return tmp; + vptr = gfc_class_vptr_get (TREE_OPERAND (cdesc, 0)); } tmp = gfc_conv_array_data (desc); @@ -3350,6 +3490,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, tree offset, cst_offset; tree tmp; tree stride; + tree decl = NULL_TREE; gfc_se indexse; gfc_se tmpse; gfc_symbol * sym = expr->symtree->n.sym; @@ -3494,8 +3635,31 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, offset, cst_offset); - se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ? - NULL_TREE : sym->backend_decl, se->class_vptr); + /* 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. */ + if (!expr->ts.deferred && !sym->attr.codimension + && is_pointer_array (se->expr)) + { + if (TREE_CODE (se->expr) == COMPONENT_REF) + { + decl = gfc_evaluate_now (se->expr, &se->pre); + GFC_DECL_PTR_ARRAY_P (decl) = 1; + TREE_USED (decl) = 1; + } + else if (TREE_CODE (se->expr) == INDIRECT_REF) + 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)) + decl = sym->backend_decl; + else if (sym->ts.type == BT_CLASS) + decl = NULL_TREE; + + se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr); } @@ -5651,6 +5815,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, if (dimension) gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + /* Pointer arrays need the span field to be set. */ + if (is_pointer_array (se->expr) + || (expr->ts.type == BT_CLASS + && CLASS_DATA (expr)->attr.class_pointer)) + { + if (expr3 && expr3_elem_size != NULL_TREE) + tmp = expr3_elem_size; + else + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (se->expr))); + tmp = fold_convert (gfc_array_index_type, tmp); + gfc_conv_descriptor_span_set (&set_descriptor_block, se->expr, tmp); + } + set_descriptor = gfc_finish_block (&set_descriptor_block); if (status != NULL_TREE) { @@ -6854,6 +7031,10 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* 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. */ + tmp = get_array_span (desc, expr); + gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); } else if (se->want_pointer) { @@ -6889,8 +7070,18 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) se->ss = ss; 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); + gfc_free_ss_chain (ss); return; } @@ -7110,9 +7301,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) desc = info->descriptor; if (se->direct_byref && !se->byref_noassign) { - /* For pointer assignments we fill in the destination. */ + /* For pointer assignments we fill in the destination.... */ parm = se->expr; parmtype = TREE_TYPE (parm); + + /* ....and set the span field. */ + tmp = get_array_span (desc, expr); + gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); } else { @@ -7585,6 +7780,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, /* Every other type of array. */ se->want_pointer = 1; gfc_conv_expr_descriptor (se, expr); + if (size) array_parameter_size (build_fold_indirect_ref_loc (input_location, se->expr), diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 3cc08b346ff..e2a8737421f 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -156,9 +156,13 @@ tree gfc_conv_array_ubound (tree, int); void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *); /* Build expressions for accessing components of an array descriptor. */ +void gfc_get_descriptor_offsets_for_info (const_tree, tree *, tree *, tree *, tree *, + tree *, tree *, tree *); + tree gfc_conv_descriptor_data_get (tree); tree gfc_conv_descriptor_data_addr (tree); tree gfc_conv_descriptor_offset_get (tree); +tree gfc_conv_descriptor_span_get (tree); tree gfc_conv_descriptor_dtype (tree); tree gfc_conv_descriptor_rank (tree); tree gfc_get_descriptor_dimension (tree); @@ -169,6 +173,7 @@ tree gfc_conv_descriptor_token (tree); void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree); void gfc_conv_descriptor_offset_set (stmtblock_t *, tree, tree); +void gfc_conv_descriptor_span_set (stmtblock_t *, tree, tree); void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree); void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 30477c27994..830c53ac384 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1532,6 +1532,9 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Dummy variables should already have been created. */ gcc_assert (sym->backend_decl); + if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) + GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; + /* Create a character length variable. */ if (sym->ts.type == BT_CHARACTER) { @@ -1766,27 +1769,18 @@ gfc_get_symbol_decl (gfc_symbol * sym) if (sym->ts.type == BT_CHARACTER) /* Character variables need special handling. */ gfc_allocate_lang_decl (decl); - else if (sym->attr.subref_array_pointer) - /* We need the span for these beasts. */ - gfc_allocate_lang_decl (decl); - if (sym->attr.subref_array_pointer) - { - tree span; - GFC_DECL_SUBREF_ARRAY_P (decl) = 1; - span = build_decl (input_location, - VAR_DECL, create_tmp_var_name ("span"), - gfc_array_index_type); - gfc_finish_var_decl (span, sym); - TREE_STATIC (span) = TREE_STATIC (decl); - DECL_ARTIFICIAL (span) = 1; + if (sym->assoc && sym->attr.subref_array_pointer) + sym->attr.pointer = 1; - GFC_DECL_SPAN (decl) = span; - GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span; - } + if (sym->attr.pointer && sym->attr.dimension + && !sym->ts.deferred + && !(sym->attr.select_type_temporary + && !sym->attr.subref_array_pointer)) + GFC_DECL_PTR_ARRAY_P (decl) = 1; if (sym->ts.type == BT_CLASS) - GFC_DECL_CLASS(decl) = 1; + GFC_DECL_CLASS(decl) = 1; sym->backend_decl = decl; @@ -4347,13 +4341,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } } - if (sym->attr.subref_array_pointer - && GFC_DECL_SPAN (sym->backend_decl) - && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl))) + if (sym->attr.pointer && sym->attr.dimension + && !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_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl), - build_int_cst (gfc_array_index_type, 0)); + 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); } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b3104586ca6..8c8569f1d86 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5413,7 +5413,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } if (e->expr_type == EXPR_VARIABLE - && is_subref_array (e)) + && is_subref_array (e) + && !(fsym && fsym->attr.pointer)) /* The actual argument is a component reference to an array of derived types. In this case, the argument is converted to a temporary, which is passed and then @@ -8223,7 +8224,6 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) stmtblock_t block; tree desc; tree tmp; - tree decl; bool scalar, non_proc_pointer_assign; gfc_ss *ss; @@ -8412,30 +8412,24 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_conv_expr_descriptor (&lse, expr2); strlen_rhs = lse.string_length; - /* If this is a subreference array pointer assignment, use the rhs - descriptor element size for the lhs span. */ - if (expr1->symtree->n.sym->attr.subref_array_pointer) - { - decl = expr1->symtree->n.sym->backend_decl; - gfc_init_se (&rse, NULL); - rse.descriptor_only = 1; - gfc_conv_expr (&rse, expr2); - if (expr1->ts.type == BT_CLASS) - trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, - NULL, NULL); - tmp = gfc_get_element_type (TREE_TYPE (rse.expr)); - tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); - if (!INTEGER_CST_P (tmp)) - gfc_add_block_to_block (&lse.post, &rse.pre); - gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); - } - else if (expr1->ts.type == BT_CLASS) + if (expr1->ts.type == BT_CLASS) { rse.expr = NULL_TREE; rse.string_length = NULL_TREE; trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL, NULL); } + + if (remap == NULL) + { + /* If the target is not a whole array, use the target array + reference for remap. */ + for (remap = expr2->ref; remap; remap = remap->next) + if (remap->type == REF_ARRAY + && remap->u.ar.type == AR_FULL + && remap->next) + break; + } } else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) { @@ -8446,7 +8440,12 @@ 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 { expr1_vptr = trans_class_vptr_len_assignment (&block, expr1, @@ -8492,7 +8491,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) converted in rse and now have to build the correct LHS descriptor for it. */ - tree dtype, data; + tree dtype, data, span; tree offs, stride; tree lbound, ubound; @@ -8505,6 +8504,18 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) data = gfc_conv_descriptor_data_get (rse.expr); gfc_conv_descriptor_data_set (&block, desc, data); + /* Copy the span. */ + if (TREE_CODE (rse.expr) == VAR_DECL + && 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. */ offs = gfc_conv_descriptor_offset_get (rse.expr); @@ -8586,12 +8597,18 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { gfc_se lbound_se; - gcc_assert (remap->u.ar.start[dim]); gcc_assert (!remap->u.ar.end[dim]); gfc_init_se (&lbound_se, NULL); - gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]); - - gfc_add_block_to_block (&block, &lbound_se.pre); + 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); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 3c9e1d5e037..9bc465e43d9 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1225,10 +1225,9 @@ conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr) && ref->u.c.component->attr.dimension) { tree arr_desc_token_offset; - /* Get the token from the descriptor. */ - arr_desc_token_offset = gfc_advance_chain ( - TYPE_FIELDS (TREE_TYPE (ref->u.c.component->backend_decl)), - 4 /* CAF_TOKEN_FIELD */); + /* Get the token field from the descriptor. */ + arr_desc_token_offset = TREE_OPERAND ( + gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1); arr_desc_token_offset = compute_component_offset (arr_desc_token_offset, TREE_TYPE (tmp)); @@ -8129,6 +8128,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)); diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index aa974eb3805..026f9a993d2 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -2569,6 +2569,12 @@ gfc_trans_transfer (gfc_code * code) gcc_assert (ref && ref->type == REF_ARRAY); } + if (expr->ts.type != BT_CLASS + && expr->expr_type == EXPR_VARIABLE + && gfc_expr_attr (expr).pointer) + goto scalarize; + + if (!(gfc_bt_struct (expr->ts.type) || expr->ts.type == BT_CLASS) && ref && ref->next == NULL @@ -2603,6 +2609,7 @@ gfc_trans_transfer (gfc_code * code) goto finish_block_label; } +scalarize: /* Initialize the scalarizer. */ ss = gfc_walk_expr (expr); gfc_init_loopinfo (&loop); @@ -2618,7 +2625,9 @@ gfc_trans_transfer (gfc_code * code) gfc_copy_loopinfo_to_se (&se, &loop); se.ss = ss; + gfc_conv_expr_reference (&se, expr); + if (expr->ts.type == BT_CLASS) vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor); else diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 6a407f92614..925ea636258 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1531,6 +1531,8 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) int n; tree charlen; bool need_len_assign; + bool whole_array = true; + gfc_ref *ref; gcc_assert (sym->assoc); e = sym->assoc->target; @@ -1541,6 +1543,15 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) unlimited = UNLIMITED_POLY (e); + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && ref->u.ar.type == AR_FULL + && ref->next) + { + whole_array = false; + break; + } + /* Assignments to the string length need to be generated, when ( sym is a char array or sym has a _len component) @@ -1583,11 +1594,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* If we didn't already do the pointer assignment, set associate-name descriptor to the one generated for the temporary. */ - if (!sym->assoc->variable && !cst_array_ctor) + if ((!sym->assoc->variable && !cst_array_ctor) + || !whole_array) { int dim; - gfc_add_modify (&se.pre, desc, se.expr); + 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. */ @@ -1606,7 +1619,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) : e->symtree->n.sym->backend_decl; tmp = gfc_get_element_type (TREE_TYPE (tmp)); tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp)); - gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp); + gfc_conv_descriptor_span_set (&se.pre, desc, tmp); } /* Done, register stuff as init / cleanup code. */ diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 061222f5083..b106794205b 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "toplev.h" /* For rest_of_decl_compilation. */ #include "trans-types.h" #include "trans-const.h" +#include "trans-array.h" #include "dwarf2out.h" /* For struct array_descr_info. */ #include "attribs.h" @@ -1786,6 +1787,12 @@ gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted) gfc_array_index_type, &chain); TREE_NO_WARNING (decl) = 1; + /* Add the span component. */ + decl = gfc_add_field_to_struct_1 (fat_type, + get_identifier ("span"), + gfc_array_index_type, &chain); + TREE_NO_WARNING (decl) = 1; + /* Build the array type for the stride and bound components. */ if (dimen + codimen > 0) { @@ -2715,6 +2722,11 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen) if (!c->backend_decl) c->backend_decl = field; + if (c->attr.pointer && c->attr.dimension + && !(c->ts.type == BT_DERIVED + && strcmp (c->name, "_data") == 0)) + GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1; + /* Do not add a caf_token field for classes' data components. */ if (codimen && !c->attr.dimension && !c->attr.codimension && (c->attr.allocatable || c->attr.pointer) @@ -3154,7 +3166,7 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) { int rank, dim; bool indirect = false; - tree etype, ptype, field, t, base_decl; + tree etype, ptype, t, base_decl; tree data_off, dim_off, dtype_off, dim_size, elem_size; tree lower_suboff, upper_suboff, stride_suboff; @@ -3211,24 +3223,11 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) if (indirect) base_decl = build1 (INDIRECT_REF, ptype, base_decl); - if (GFC_TYPE_ARRAY_SPAN (type)) - elem_size = GFC_TYPE_ARRAY_SPAN (type); - else - elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); - field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type)); - data_off = byte_position (field); - field = DECL_CHAIN (field); - field = DECL_CHAIN (field); - dtype_off = byte_position (field); - field = DECL_CHAIN (field); - dim_off = byte_position (field); - dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field))); - field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field))); - stride_suboff = byte_position (field); - field = DECL_CHAIN (field); - lower_suboff = byte_position (field); - field = DECL_CHAIN (field); - upper_suboff = byte_position (field); + elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); + + gfc_get_descriptor_offsets_for_info (type, &data_off, &dtype_off, &dim_off, + &dim_size, &stride_suboff, + &lower_suboff, &upper_suboff); t = base_decl; if (!integer_zerop (data_off)) diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index cb6a57f6001..149f482586f 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -305,6 +305,67 @@ gfc_build_addr_expr (tree type, tree t) } +static tree +get_array_span (tree type, tree decl) +{ + tree span; + + /* Return the span for deferred character length array references. */ + if (type && TREE_CODE (type) == ARRAY_TYPE + && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE + && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) + || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF) + && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF + || TREE_CODE (decl) == FUNCTION_DECL + || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) + == DECL_CONTEXT (decl))) + { + span = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + span = fold_convert (gfc_array_index_type, span); + } + /* 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); + } + 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; +} + + /* Build an ARRAY_REF with its natural type. */ tree @@ -312,7 +373,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); tree tmp; - tree span; + tree span = NULL_TREE; if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) { @@ -331,77 +392,23 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) type = TREE_TYPE (type); - /* Use pointer arithmetic for deferred character length array - references. */ - if (type && TREE_CODE (type) == ARRAY_TYPE - && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE - && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) - || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF) - && decl - && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF - || TREE_CODE (decl) == FUNCTION_DECL - || (DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) - == DECL_CONTEXT (decl)))) - span = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - else - span = NULL_TREE; - if (DECL_P (base)) TREE_ADDRESSABLE (base) = 1; /* Strip NON_LVALUE_EXPR nodes. */ STRIP_TYPE_NOPS (offset); - /* If the array reference is to a pointer, whose target contains a - subreference, use the span that is stored with the backend decl - and reference the element with pointer arithmetic. */ - if ((decl && (TREE_CODE (decl) == FIELD_DECL - || VAR_OR_FUNCTION_DECL_P (decl) - || TREE_CODE (decl) == PARM_DECL) - && ((GFC_DECL_SUBREF_ARRAY_P (decl) - && !integer_zerop (GFC_DECL_SPAN (decl))) - || GFC_DECL_CLASS (decl) - || span != NULL_TREE)) - || vptr != NULL_TREE) - { - if (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 normal array reference. */ - if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( - gfc_class_data_get (decl)))) - return build4_loc (input_location, ARRAY_REF, type, base, - offset, NULL_TREE, NULL_TREE); - } - - span = gfc_class_vtab_size_get (decl); - } - else if (GFC_DECL_SUBREF_ARRAY_P (decl)) - span = GFC_DECL_SPAN (decl); - else if (span) - span = fold_convert (gfc_array_index_type, span); - else - gcc_unreachable (); - } - else if (vptr) - span = gfc_vptr_size_get (vptr); - else - gcc_unreachable (); + /* 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); + 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) + { offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, offset, span); @@ -412,8 +419,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) tmp = build_fold_indirect_ref_loc (input_location, tmp); return tmp; } + /* Otherwise use a straightforward array reference. */ else - /* Otherwise use a straightforward array reference. */ return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index d02f3470eeb..c970ace86f9 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -982,7 +982,7 @@ struct GTY(()) lang_decl { #define GFC_DECL_COMMON_OR_EQUIV(node) DECL_LANG_FLAG_3(node) #define GFC_DECL_CRAY_POINTEE(node) DECL_LANG_FLAG_4(node) #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node) -#define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node) +#define GFC_DECL_PTR_ARRAY_P(node) DECL_LANG_FLAG_6(node) #define GFC_DECL_ASSOCIATE_VAR_P(node) DECL_LANG_FLAG_7(node) #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fdd128c58cf..10f56bd5987 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,31 @@ +2017-09-10 Paul Thomas + + PR fortran/34640 + * gfortran.dg/associate_24.f90: New test. + * gfortran.dg/assumed_type_2.f90: Adjust some of the tree dump + checks. + * gfortran.dg/no_arg_check_2.f90: Likewise. + * gfortran.dg/pointer_array_1.f90: New test. + * gfortran.dg/pointer_array_2.f90: New test. + * gfortran.dg/pointer_array_7.f90: New test. + * gfortran.dg/pointer_array_8.f90: New test. + * gfortran.dg/pointer_array_component_1.f90: New test. + * gfortran.dg/pointer_array_component_2.f90: New test. + * gfortran.dg/goacc/kernels-alias-4.f95: Bump up both tree scan + counts by 1. + + PR fortran/40737 + * gfortran.dg/pointer_array_3.f90: New test. + + PR fortran/57116 + * gfortran.dg/pointer_array_4.f90: New test. + + PR fortran/55763 + * gfortran.dg/pointer_array_5.f90: New test. + + PR fortran/57019 + * gfortran.dg/pointer_array_6.f90: New test. + 2017-09-09 Jonathan Wakely PR c++/81852 diff --git a/gcc/testsuite/gfortran.dg/associate_24.f90 b/gcc/testsuite/gfortran.dg/associate_24.f90 new file mode 100644 index 00000000000..94ba378b6e5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_24.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! From posting by Spectrum to clf on thread entitled "Bounds for array pointer dummy argument". +! +PROGRAM X + implicit none + TYPE T + INTEGER :: I + END TYPE T + TYPE(T), TARGET :: T1( 0:3 ) + + associate( P => T1 % I ) + call check (lbound (P, 1), ubound (P, 1) ,1 , 4) + endassociate + + associate( P2 => T1(:) % I ) + call check (lbound (P2, 1), ubound (P2, 1) ,1 , 4) + endassociate + + associate( Q => T1 ) + call check (lbound (Q, 1), ubound (Q, 1) ,0 , 3) + endassociate + + associate( Q2 => T1(:) ) + call check (lbound (Q2, 1), ubound (Q2, 1) ,1 , 4) + endassociate +contains + subroutine check (lbnd, ubnd, lower, upper) + integer :: lbnd, ubnd, lower, upper + if (lbnd .ne. lower) call abort + if (ubnd .ne. upper) call abort + end subroutine +END PROGRAM X diff --git a/gcc/testsuite/gfortran.dg/assumed_type_2.f90 b/gcc/testsuite/gfortran.dg/assumed_type_2.f90 index f1a20747884..a0e1bc1b19c 100644 --- a/gcc/testsuite/gfortran.dg/assumed_type_2.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_type_2.f90 @@ -151,9 +151,9 @@ end ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 b/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 index 36f7f65fbac..415eb96344a 100644 --- a/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 +++ b/gcc/testsuite/gfortran.dg/goacc/kernels-alias-4.f95 @@ -16,5 +16,5 @@ program main end program main ! Only the omp_data_i related loads should be annotated with cliques. -! { dg-final { scan-tree-dump-times "clique 1 base 1" 3 "ealias" } } -! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 4 "ealias" } } +! { dg-final { scan-tree-dump-times "clique 1 base 1" 4 "ealias" } } +! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 5 "ealias" } } diff --git a/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 index b3fb4685efe..90e4c8cd515 100644 --- a/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 +++ b/gcc/testsuite/gfortran.dg/no_arg_check_2.f90 @@ -133,9 +133,9 @@ end ! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } -! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } ! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pointer_array_1.f90 b/gcc/testsuite/gfortran.dg/pointer_array_1.f90 new file mode 100644 index 00000000000..b43101fb31b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_1.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Check the fix for PR34640 comments 1 and 3. +! +! This involves passing and returning pointer array components that +! point to components of arrays of derived types. +! +MODULE test + IMPLICIT NONE + TYPE :: my_type + INTEGER :: value + integer :: tag + END TYPE +CONTAINS + SUBROUTINE get_values(values, switch) + INTEGER, POINTER :: values(:) + integer :: switch + TYPE(my_type), POINTER :: d(:) + allocate (d, source = [my_type(1,101), my_type(2,102)]) + if (switch .eq. 1) then + values => d(:)%value + if (any (values .ne. [1,2])) print *, values(2) + else + values => d(:)%tag + if (any (values .ne. [101,102])) call abort + end if + END SUBROUTINE + + function return_values(switch) result (values) + INTEGER, POINTER :: values(:) + integer :: switch + TYPE(my_type), POINTER :: d(:) + allocate (d, source = [my_type(1,101), my_type(2,102)]) + if (switch .eq. 1) then + values => d(:)%value + if (any (values .ne. [1,2])) call abort + else + values => d(:)%tag + if (any (values([2,1]) .ne. [102,101])) call abort + end if + END function +END MODULE + + use test + integer, pointer :: x(:) + type :: your_type + integer, pointer :: x(:) + end type + type(your_type) :: y + + call get_values (x, 1) + if (any (x .ne. [1,2])) call abort + call get_values (y%x, 2) + if (any (y%x .ne. [101,102])) call abort + + x => return_values (2) + if (any (x .ne. [101,102])) call abort + y%x => return_values (1) + if (any (y%x .ne. [1,2])) call abort +end diff --git a/gcc/testsuite/gfortran.dg/pointer_array_2.f90 b/gcc/testsuite/gfortran.dg/pointer_array_2.f90 new file mode 100644 index 00000000000..1f9c13796a4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_2.f90 @@ -0,0 +1,143 @@ +! { dg-do compile } +! +! Test the fix for PR40737 as part of the overall fix for PR34640. +! +! Contributed by David Hough +! +module testmod + +integer, parameter :: standard_integer = 1 +integer, parameter :: int = KIND( standard_integer) + +integer, parameter :: i8 = selected_int_kind(12) +integer, parameter :: i4 = selected_int_kind(8) +integer, parameter :: i2 = selected_int_kind(4) + +integer, parameter :: standard_real = 1. +integer, parameter :: std_real = KIND( standard_real) + +integer, parameter :: r8 = selected_real_kind(12) +integer, parameter :: r4 = selected_real_kind(6) +integer, parameter :: double = selected_real_kind(20) + +integer, parameter :: name_string_length = 40 +integer, parameter :: file_name_length = 60 +integer, parameter :: text_string_length = 80 +integer, parameter :: max_kwd_lgth = file_name_length + +integer(int) :: bytes_per_int = 4 +integer(int) :: bytes_per_real = 8 +integer(int) :: workcomm, spincomm + + integer(int), parameter :: nb_directions = 3, & + direction_x = 1, & + direction_y = 2, & + direction_z = 3, & + nb_ghost_cells = 5 ! might be different for the lagrange step? + + integer(int), parameter :: ends = 4, & + lower_ghost = 1, & + lower_interior = 2, & + upper_interior = 3, & + upper_ghost = 4 + + ! Neighbors + integer(int), parameter :: side = 2, & + lower_end = 1, & + upper_end = 2 + + + integer(int), parameter :: nb_variables = 5, & + ro_var = 1, & + ets_var = 2, & + u_var = 3, & + up1_var = 4, & + up2_var = 5, & + eis_var = 6, & + ecs_var = 7, & + p_var = 8, & + c_var = 9, & + nb_var_sortie = 9 + + type :: VARIABLES_LIGNE + sequence + real, pointer, dimension( :, :) :: l + end type VARIABLES_LIGNE + + type VARIABLES_MAILLE + sequence + real(r8), dimension( nb_variables) :: cell_var + end type VARIABLES_MAILLE + + integer(int), dimension( nb_directions) :: & + first_real_cell, & ! without ghost cells + last_real_cell, & ! + nb_real_cells, & ! + first_work_cell, & ! including ghost cells + last_work_cell, & ! + nb_work_cells, & ! + global_nb_cells ! number of real cells, for the entire grid + + integer(int) :: dim_probleme ! dimension du probleme (1, 2 ou 3) + + integer(int) :: largest_local_size ! the largest of the 3 dimensions of the local grid + + ! Hydro variables of the actual domain + ! There are 3 copies of these, for use according to current work direction + type (VARIABLES_MAILLE), allocatable, target, dimension( :, :, :) :: & + Hydro_vars_XYZ, & + Hydro_vars_YZX, & + Hydro_vars_ZXY + + ! Pointers to current and next Hydro var arrays + type (VARIABLES_MAILLE), pointer, dimension( :, :, :) :: Hydro_vars, & + Hydro_vars_next + + ! Which of these 3 copies of the 3D arrays has been updated last + integer(int) :: last_updated_3D_array = 0 + + real(r8), pointer, dimension( :) :: & + ! Variables "permanentes" (entrant dans la projection) + Ro, & ! densite + Ets, & ! energie totale specifique + Um, & ! vitesse aux mailles, dans la direction de travail + Xn, & ! abscisse en fin de pas de temps + ! Variables en lecture seulement + Um_p1, & ! vitesse aux mailles, dans les directions + Um_p2, & ! orthogonales + Xa, & ! abscisses des noeuds en debut de pas de temps + Dxa, & ! longueur des mailles en debut de pas de temps + U_dxa ! inverses des longueurs des mailles + +end module testmod + + +subroutine TF_AD_SPLITTING_DRIVER_PLANE + +use testmod + +implicit none +save + + real(r8), allocatable, dimension( :) :: & + ! Variables maille recalculees a chaque pas de temps + Eis, & ! energie interne specifique (seulement pour calculer la pression) + Vit_son, & ! comme son nom l'indique + C_f_l, & ! nombre de Courant + Pm, & ! pression aux mailles + ! Variables aux noeuds + Un, & ! vitesse des noeuds + Pn ! pression aux noeuds + + +integer(int) :: i, j, k +integer(int) :: first_cell, last_cell + + Ro => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ro_var) + Ets => Hydro_vars( first_cell:last_cell, j, k)%cell_var( ets_var) + Um => Hydro_vars( first_cell:last_cell, j, k)%cell_var( u_var) + Um_p1 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up1_var) + Um_p2 => Hydro_vars( first_cell:last_cell, j, k)%cell_var( up2_var) + +end subroutine TF_AD_SPLITTING_DRIVER_PLANE + diff --git a/gcc/testsuite/gfortran.dg/pointer_array_3.f90 b/gcc/testsuite/gfortran.dg/pointer_array_3.f90 new file mode 100644 index 00000000000..d760167b76f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_3.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Test the fix for PR40737 comment 17 as part of the overall fix for PR34640. +! +! Contributed by Josh Hykes +! + module test_mod +! + type t1 + character(8) :: string + end type t1 +! + type t2 + integer :: tab + type(t1), pointer :: fp(:) + end type t2 +! + type t3 + integer :: tab + type(t2), pointer :: as + end type t3 +! + type(t3), pointer :: as_typ(:) => null() +! + character(8), pointer, public :: p(:) +! + contains +! + subroutine as_set_alias (i) +! + implicit none +! + integer, intent(in) :: i +! + allocate (as_typ(2)) + allocate (as_typ(1)%as) + allocate (as_typ(1)%as%fp(2), source = [t1("abcdefgh"),t1("ijklmnop")]) + p => as_typ(i)%as%fp(:)%string +! + end subroutine as_set_alias +! + end module test_mod + + program test_prog + use test_mod + call as_set_alias(1) + if (any (p .ne. ["abcdefgh","ijklmnop"])) call abort + deallocate (as_typ(1)%as%fp) + deallocate (as_typ(1)%as) + deallocate (as_typ) + end program test_prog diff --git a/gcc/testsuite/gfortran.dg/pointer_array_4.f90 b/gcc/testsuite/gfortran.dg/pointer_array_4.f90 new file mode 100644 index 00000000000..31a90a55707 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_4.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! +! Test the fix for PR57116 as part of the overall fix for PR34640. +! +! Contributed by Reinhold Bader +! +module mod_rtti_ptr + implicit none + type :: foo + real :: v + integer :: i + end type foo +contains + subroutine extract(this, v, ic) + class(*), target :: this(:) + real, pointer :: v(:) + integer :: ic + select type (this) + type is (real) + v => this(ic:) + class is (foo) + v => this(ic:)%v + end select + end subroutine extract +end module + +program prog_rtti_ptr + use mod_rtti_ptr + class(*), allocatable, target :: o(:) + real, pointer :: v(:) + + allocate(o(3), source=[1.0, 2.0, 3.0]) + call extract(o, v, 2) + if (size(v) == 2 .and. all (v == [2.0, 3.0])) then + deallocate(o) + else + call abort + end if + + allocate(o(3), source=[foo(1.0, 1), foo(4.0, 4), foo(5.0, 5)]) + call extract(o, v, 2) + if (size(v) == 2 .and. all (v == [4.0, 5.0])) then + deallocate(o) + else + call abort + end if + +! The rest tests the case in comment 2 + + call extract1 (v, 1) + if (any (v /= [1.0, 2.0])) call abort + call extract1 (v, 2) ! Call to deallocate pointer. + +contains + subroutine extract1(v, flag) + type :: foo + real :: v + character(4) :: str + end type + class(foo), pointer, save :: this(:) + real, pointer :: v(:) + integer :: flag + + if (flag == 1) then + allocate (this(2), source = [foo (1.0, "one "), foo (2.0, "two ")]) + select type (this) + class is (foo) + v => this(1:2)%v + end select + else + deallocate (this) + end if + end subroutine + +end program prog_rtti_ptr diff --git a/gcc/testsuite/gfortran.dg/pointer_array_5.f90 b/gcc/testsuite/gfortran.dg/pointer_array_5.f90 new file mode 100644 index 00000000000..312d097854b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_5.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Test the fix for PR55763 comment 9 as part of the overall fix for PR34640. +! +! Contributed by Tobias Burnus +! + program change_field_type + use, intrinsic :: iso_c_binding + implicit none + REAL(kind=c_float), POINTER :: vector_comp(:) + TYPE, BIND(C) :: scalar_vector + REAL(kind=c_float) :: scalar + REAL(kind=c_float) :: vec(3) + END TYPE + TYPE, BIND(C) :: scalar_vector_matrix + REAL(kind=c_float) :: scalar + REAL(kind=c_float) :: vec(3) + REAL(kind=c_float) :: mat(3,3) + END TYPE + CLASS(*), ALLOCATABLE, TARGET :: one_d_field(:) + real, pointer :: v1(:) + + allocate(one_d_field(3), & + source = (/ scalar_vector( 1.0, (/ -1.0, 0.0, 1.0 /) ), & + scalar_vector( 1.1, (/ -1.2, 0.2, 0.9 /) ), & + scalar_vector( 1.2, (/ -1.4, 0.4, 0.8 /) ) /) ) + + call extract_vec(one_d_field, 1, 2) + if (any (abs (vector_comp - [0.0,0.2,0.4]) .gt. 1e-4)) call abort + deallocate(one_d_field) ! v1 becomes undefined + + allocate(one_d_field(1), & + source = (/ scalar_vector_matrix( 1.0, (/ -1.0, 0.0, 1.0 /), & + reshape( (/ 1.0, 0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0 /), & + (/3, 3/) ) ) /) ) + + call extract_vec(one_d_field, 2, 1) + if (abs (vector_comp(1) + 1.0) > 1e-4) call abort + call extract_vec(one_d_field, 2, 3) + if (abs (vector_comp(1) - 1.0) > 1e-4) call abort + deallocate(one_d_field) ! v1 becomes undefined + contains + subroutine extract_vec(field, tag, ic) + use, intrinsic :: iso_c_binding + CLASS(*), TARGET :: field(:) + INTEGER(kind=c_int), value :: tag, ic + + type(scalar_vector), pointer :: sv(:) + type(scalar_vector_matrix), pointer :: svm(:) + + select type (field) + type is (real(c_float)) + vector_comp => field + class default + select case (tag) + case (1) + sv => field + vector_comp => sv(:)%vec(ic) + case (2) + svm => field + vector_comp => svm(:)%vec(ic) + end select + end select + end subroutine + end program diff --git a/gcc/testsuite/gfortran.dg/pointer_array_6.f90 b/gcc/testsuite/gfortran.dg/pointer_array_6.f90 new file mode 100644 index 00000000000..86685563209 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_6.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR57019 comment 4 as part of the overall fix for PR34640. +! +! Contributed by +! + type cParticle + real(4) :: v(3) + endtype cParticle + + type pCItem + type(cParticle) :: Ele + end type pCItem + + type(pCItem), target, dimension(1:1,1:1) :: pCellArray + type(cParticle), pointer, dimension(:,:) :: pArray + real(4), pointer, dimension(:) :: v_pointer + real(4), dimension(3) :: v_real = 99. + + pArray => pCellArray%Ele + v_pointer => pArray(1,1)%v; + v_pointer = v_real !OK %%%%%%%%%%%% + if (any (int (pArray(1,1)%v) .ne. 99)) call abort + + v_real = 88 + pArray(1,1)%v = v_real !SEGFAULT %%%%%%%%%%%%%%%%%%%%%%%% + if (any (int (v_pointer) .ne. 88)) call abort +end diff --git a/gcc/testsuite/gfortran.dg/pointer_array_7.f90 b/gcc/testsuite/gfortran.dg/pointer_array_7.f90 new file mode 100644 index 00000000000..1aa48b7a078 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_7.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! Test for the fix for PR34640. In this case, final testing of the +! patch revealed that in some cases the actual descriptor was not +! being passed to procedure dummy pointers. +! +! Contributed by Thomas Koenig +! +module x + use iso_c_binding + implicit none + type foo + complex :: c + integer :: i + end type foo +contains + subroutine printit(c, a) + complex, pointer, dimension(:) :: c + integer :: i + integer(kind=c_intptr_t) :: a + a = transfer(c_loc(c(2)),a) + end subroutine printit +end module x + +program main + use x + use iso_c_binding + implicit none + type(foo), dimension(5), target :: a + integer :: i + complex, dimension(:), pointer :: pc + integer(kind=c_intptr_t) :: s1, s2, s3 + a%i = 0 + do i=1,5 + a(i)%c = cmplx(i**2,i) + end do + pc => a%c + call printit(pc, s3) + + s1 = transfer(c_loc(a(2)%c),s1) + if (s1 /= s3) call abort + + s2 = transfer(c_loc(pc(2)),s2) + if (s2 /= s3) call abort + +end program main diff --git a/gcc/testsuite/gfortran.dg/pointer_array_8.f90 b/gcc/testsuite/gfortran.dg/pointer_array_8.f90 new file mode 100644 index 00000000000..bbf2c997dd6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_8.f90 @@ -0,0 +1,81 @@ +! { dg-do run } +! +! Make sure that the fix for pr34640 works with class pointers. +! + type :: mytype + real :: r + integer :: i + end type + + type :: thytype + real :: r + integer :: i + type(mytype) :: der + end type + + type(thytype), dimension(0:2), target :: tgt + class(*), dimension(:), pointer :: cptr + class(mytype), dimension(:), pointer :: cptr1 + integer :: i + integer(8) :: s1, s2 + + tgt = [(thytype(int(i), i, mytype(int(2*i), 2*i)), i= 1,3)] + + cptr => tgt%i + if (lbound (cptr, 1) .ne. 1) Call abort ! Not a whole array target! + + s1 = loc(cptr) + call foo (cptr, s2) ! Check bounds not changed... + if (s1 .ne. s2) Call abort ! ...and that the descriptor is passed. + + select type (cptr) + type is (integer) + if (any (cptr .ne. [1,2,3])) call abort ! Check the the scalarizer works. + if (cptr(2) .ne. 2) call abort ! Check ordinary array indexing. + end select + + cptr(1:3) => tgt%der%r ! Something a tad more complicated! + + select type (cptr) + type is (real) + if (any (int(cptr) .ne. [2,4,6])) call abort + if (any (int(cptr([2,3,1])) .ne. [4,6,2])) call abort + if (int(cptr(3)) .ne. 6) call abort + end select + + cptr1(1:3) => tgt%der + + s1 = loc(cptr1) + call bar(cptr1, s2) + if (s1 .ne. s2) Call abort ! Check that the descriptor is passed. + + select type (cptr1) + type is (mytype) + if (any (cptr1%i .ne. [2,4,6])) call abort + if (cptr1(2)%i .ne. 4) call abort + end select + +contains + + subroutine foo (arg, addr) + class(*), dimension(:), pointer :: arg + integer(8) :: addr + addr = loc(arg) + select type (arg) + type is (integer) + if (any (arg .ne. [1,2,3])) call abort ! Check the the scalarizer works. + if (arg(2) .ne. 2) call abort ! Check ordinary array indexing. + end select + end subroutine + + subroutine bar (arg, addr) + class(mytype), dimension(:), pointer :: arg + integer(8) :: addr + addr = loc(arg) + select type (arg) + type is (mytype) + if (any (arg%i .ne. [2,4,6])) call abort + if (arg(2)%i .ne. 4) call abort + end select + end subroutine +end diff --git a/gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 b/gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 new file mode 100644 index 00000000000..b96071b178a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_component_1.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Check the fix for PR34640 comment 28. +! +! This involves pointer array components that point to components of arrays +! of derived types. +! + type var_tables + real, pointer :: rvar(:) + end type + + type real_vars + real r + real :: index + end type + + type(var_tables) :: vtab_r + type(real_vars), target :: x(2) + real, pointer :: z(:) + real :: y(2) + + x = [real_vars (11.0, 1.0), real_vars (42.0, 2.0)] + vtab_r%rvar => x%r + if (any (abs (vtab_r%rvar - [11.0, 42.0]) > 1.0e-5)) call abort ! Check skipping 'index; is OK. + + y = vtab_r%rvar + if (any (abs (y - [11.0, 42.0]) > 1.0e-5)) call abort ! Check that the component is usable in assignment. + + call foobar (vtab_r, [11.0, 42.0]) + + vtab_r = barfoo () + + call foobar (vtab_r, [111.0, 142.0]) + +contains + subroutine foobar (vtab, array) + type(var_tables) :: vtab + real :: array (:) + if (any (abs (vtab%rvar - array) > 1.0e-5)) call abort ! Check passing as a dummy. + if (abs (vtab%rvar(2) - array(2)) > 1.0e-5) call abort ! Check component reference. + end subroutine + + function barfoo () result(res) + type(var_tables) :: res + allocate (res%rvar(2), source = [111.0, 142.0]) ! Check allocation + end function +end diff --git a/gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 b/gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 new file mode 100644 index 00000000000..bde66f67e5a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_array_component_2.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! Test the fix for PR34640. In the first version of the fix, the first +! testcase in PR51218 failed with a segfault. This test extracts the +! failing part and checks that all is well. +! + type t_info_block + integer :: n = 0 ! number of elements + end type t_info_block + ! + type t_dec_info + integer :: n = 0 ! number of elements + integer :: n_b = 0 ! number of blocks + type (t_info_block) ,pointer :: b (:) => NULL() ! info blocks + end type t_dec_info + ! + type t_vector_segm + integer :: n = 0 ! number of elements + real ,pointer :: x(:) => NULL() ! coefficients + end type t_vector_segm + ! + type t_vector + type (t_dec_info) ,pointer :: info => NULL() ! decomposition info + integer :: n = 0 ! number of elements + integer :: n_s = 0 ! number of segments + integer :: alloc_l = 0 ! allocation level + type (t_vector_segm) ,pointer :: s (:) => NULL() ! vector blocks + end type t_vector + + + type(t_vector) :: z + type(t_vector_segm), pointer :: ss + + allocate (z%s(2)) + do i = 1, 2 + ss => z%s(i) + allocate (ss%x(2), source = [1.0, 2.0]*real(i)) + end do + +! These lines would segfault. + if (int (sum (z%s(1)%x)) .ne. 3) call abort + if (int (sum (z%s(1)%x * z%s(2)%x)) .ne. 10) call abort +end diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index ba57e616f99..3dd2718b9d7 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,9 @@ +2017-09-10 Paul Thomas + + PR fortran/34640 + * libgfortran/libgfortran.h: Add span field to descriptor. + * libgfortran/libtool-version : Bump up version number to 5:0:0. + 2017-08-27 Jerry DeLisle PR libgfortran/78387 diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 22f412357a7..cdbdd951687 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -339,6 +339,7 @@ struct {\ type *base_addr;\ size_t offset;\ index_type dtype;\ + index_type span;\ descriptor_dimension dim[r];\ } diff --git a/libgfortran/libtool-version b/libgfortran/libtool-version index 712199096eb..4ce57a911da 100644 --- a/libgfortran/libtool-version +++ b/libgfortran/libtool-version @@ -3,4 +3,4 @@ # This is a separate file so that version updates don't involve re-running # automake. # CURRENT:REVISION:AGE -4:0:0 +5:0:0 -- 2.30.2