| /* Expression translation |
| Copyright (C) 2002-2021 Free Software Foundation, Inc. |
| Contributed by Paul Brook <paul@nowt.org> |
| and Steven Bosscher <s.bosscher@student.tudelft.nl> |
| |
| This file is part of GCC. |
| |
| GCC is free software; you can redistribute it and/or modify it under |
| the terms of the GNU General Public License as published by the Free |
| Software Foundation; either version 3, or (at your option) any later |
| version. |
| |
| GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| 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/>. */ |
| |
| /* trans-expr.c-- generate GENERIC trees for gfc_expr. */ |
| |
| #include "config.h" |
| #include "system.h" |
| #include "coretypes.h" |
| #include "options.h" |
| #include "tree.h" |
| #include "gfortran.h" |
| #include "trans.h" |
| #include "stringpool.h" |
| #include "diagnostic-core.h" /* For fatal_error. */ |
| #include "fold-const.h" |
| #include "langhooks.h" |
| #include "arith.h" |
| #include "constructor.h" |
| #include "trans-const.h" |
| #include "trans-types.h" |
| #include "trans-array.h" |
| /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ |
| #include "trans-stmt.h" |
| #include "dependency.h" |
| #include "gimplify.h" |
| |
| |
| /* Calculate the number of characters in a string. */ |
| |
| tree |
| gfc_get_character_len (tree type) |
| { |
| tree len; |
| |
| gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE |
| && TYPE_STRING_FLAG (type)); |
| |
| len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); |
| len = (len) ? (len) : (integer_zero_node); |
| return fold_convert (gfc_charlen_type_node, len); |
| } |
| |
| |
| |
| /* Calculate the number of bytes in a string. */ |
| |
| tree |
| gfc_get_character_len_in_bytes (tree type) |
| { |
| tree tmp, len; |
| |
| gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE |
| && TYPE_STRING_FLAG (type)); |
| |
| tmp = TYPE_SIZE_UNIT (TREE_TYPE (type)); |
| tmp = (tmp && !integer_zerop (tmp)) |
| ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE); |
| len = gfc_get_character_len (type); |
| if (tmp && len && !integer_zerop (len)) |
| len = fold_build2_loc (input_location, MULT_EXPR, |
| gfc_charlen_type_node, len, tmp); |
| return len; |
| } |
| |
| |
| /* Convert a scalar to an array descriptor. To be used for assumed-rank |
| arrays. */ |
| |
| static tree |
| 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)); |
| } |
| |
| tree |
| gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) |
| { |
| tree desc, type, etype; |
| |
| type = get_scalar_to_descriptor_type (scalar, attr); |
| etype = TREE_TYPE (scalar); |
| desc = gfc_create_var (type, "desc"); |
| DECL_ARTIFICIAL (desc) = 1; |
| |
| if (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); |
| else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE) |
| etype = TREE_TYPE (etype); |
| gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc), |
| gfc_get_dtype_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 (desc)); |
| |
| /* 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; |
| } |
| |
| |
| /* Get the coarray token from the ultimate array or component ref. |
| Returns a NULL_TREE, when the ref object is not allocatable or pointer. */ |
| |
| tree |
| gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr) |
| { |
| gfc_symbol *sym = expr->symtree->n.sym; |
| bool is_coarray = sym->attr.codimension; |
| gfc_expr *caf_expr = gfc_copy_expr (expr); |
| gfc_ref *ref = caf_expr->ref, *last_caf_ref = NULL; |
| |
| while (ref) |
| { |
| if (ref->type == REF_COMPONENT |
| && (ref->u.c.component->attr.allocatable |
| || ref->u.c.component->attr.pointer) |
| && (is_coarray || ref->u.c.component->attr.codimension)) |
| last_caf_ref = ref; |
| ref = ref->next; |
| } |
| |
| if (last_caf_ref == NULL) |
| return NULL_TREE; |
| |
| tree comp = last_caf_ref->u.c.component->caf_token, caf; |
| gfc_se se; |
| bool comp_ref = !last_caf_ref->u.c.component->attr.dimension; |
| if (comp == NULL_TREE && comp_ref) |
| return NULL_TREE; |
| gfc_init_se (&se, outerse); |
| gfc_free_ref_list (last_caf_ref->next); |
| last_caf_ref->next = NULL; |
| caf_expr->rank = comp_ref ? 0 : last_caf_ref->u.c.component->as->rank; |
| se.want_pointer = comp_ref; |
| gfc_conv_expr (&se, caf_expr); |
| gfc_add_block_to_block (&outerse->pre, &se.pre); |
| |
| if (TREE_CODE (se.expr) == COMPONENT_REF && comp_ref) |
| se.expr = TREE_OPERAND (se.expr, 0); |
| gfc_free_expr (caf_expr); |
| |
| if (comp_ref) |
| caf = fold_build3_loc (input_location, COMPONENT_REF, |
| TREE_TYPE (comp), se.expr, comp, NULL_TREE); |
| else |
| caf = gfc_conv_descriptor_token (se.expr); |
| return gfc_build_addr_expr (NULL_TREE, caf); |
| } |
| |
| |
| /* This is the seed for an eventual trans-class.c |
| |
| The following parameters should not be used directly since they might |
| in future implementations. Use the corresponding APIs. */ |
| #define CLASS_DATA_FIELD 0 |
| #define CLASS_VPTR_FIELD 1 |
| #define CLASS_LEN_FIELD 2 |
| #define VTABLE_HASH_FIELD 0 |
| #define VTABLE_SIZE_FIELD 1 |
| #define VTABLE_EXTENDS_FIELD 2 |
| #define VTABLE_DEF_INIT_FIELD 3 |
| #define VTABLE_COPY_FIELD 4 |
| #define VTABLE_FINAL_FIELD 5 |
| #define VTABLE_DEALLOCATE_FIELD 6 |
| |
| |
| tree |
| gfc_class_set_static_fields (tree decl, tree vptr, tree data) |
| { |
| tree tmp; |
| tree field; |
| vec<constructor_elt, va_gc> *init = NULL; |
| |
| field = TYPE_FIELDS (TREE_TYPE (decl)); |
| tmp = gfc_advance_chain (field, CLASS_DATA_FIELD); |
| CONSTRUCTOR_APPEND_ELT (init, tmp, data); |
| |
| tmp = gfc_advance_chain (field, CLASS_VPTR_FIELD); |
| CONSTRUCTOR_APPEND_ELT (init, tmp, vptr); |
| |
| return build_constructor (TREE_TYPE (decl), init); |
| } |
| |
| |
| tree |
| gfc_class_data_get (tree decl) |
| { |
| tree data; |
| if (POINTER_TYPE_P (TREE_TYPE (decl))) |
| decl = build_fold_indirect_ref_loc (input_location, decl); |
| data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), |
| CLASS_DATA_FIELD); |
| return fold_build3_loc (input_location, COMPONENT_REF, |
| TREE_TYPE (data), decl, data, |
| NULL_TREE); |
| } |
| |
| |
| tree |
| gfc_class_vptr_get (tree decl) |
| { |
| tree vptr; |
| /* 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); |
| vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), |
| CLASS_VPTR_FIELD); |
| return fold_build3_loc (input_location, COMPONENT_REF, |
| TREE_TYPE (vptr), decl, vptr, |
| NULL_TREE); |
| } |
| |
| |
| tree |
| gfc_class_len_get (tree decl) |
| { |
| tree len; |
| /* For class arrays decl may be a temporary descriptor handle, the len 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 fold_build3_loc (input_location, COMPONENT_REF, |
| TREE_TYPE (len), decl, len, |
| NULL_TREE); |
| } |
| |
| |
| /* Try to get the _len component of a class. When the class is not unlimited |
| poly, i.e. no _len field exists, then return a zero node. */ |
| |
| 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 |
| gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size) |
| { |
| tree tmp; |
| tree tmp2; |
| tree type; |
| |
| tmp = gfc_class_len_or_zero_get (class_expr); |
| |
| /* Include the len value in the element size if present. */ |
| if (!integer_zerop (tmp)) |
| { |
| type = TREE_TYPE (size); |
| if (block) |
| { |
| size = gfc_evaluate_now (size, block); |
| tmp = gfc_evaluate_now (fold_convert (type , tmp), block); |
| } |
| tmp2 = fold_build2_loc (input_location, MULT_EXPR, |
| type, size, tmp); |
| tmp = fold_build2_loc (input_location, GT_EXPR, |
| logical_type_node, tmp, |
| build_zero_cst (type)); |
| size = fold_build3_loc (input_location, COND_EXPR, |
| type, tmp, tmp2, size); |
| } |
| else |
| return size; |
| |
| if (block) |
| size = gfc_evaluate_now (size, block); |
| |
| return size; |
| } |
| |
| |
| /* Get the specified FIELD from the VPTR. */ |
| |
| static tree |
| vptr_field_get (tree vptr, int fieldno) |
| { |
| tree field; |
| vptr = build_fold_indirect_ref_loc (input_location, vptr); |
| field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)), |
| fieldno); |
| field = fold_build3_loc (input_location, COMPONENT_REF, |
| TREE_TYPE (field), vptr, field, |
| NULL_TREE); |
| gcc_assert (field); |
| return field; |
| } |
| |
| |
| /* Get the field from the class' vptr. */ |
| |
| static tree |
| class_vtab_field_get (tree decl, int fieldno) |
| { |
| tree vptr; |
| vptr = gfc_class_vptr_get (decl); |
| return vptr_field_get (vptr, fieldno); |
| } |
| |
| |
| /* Define a macro for creating the class_vtab_* and vptr_* accessors in |
| unison. */ |
| #define VTAB_GET_FIELD_GEN(name, field) tree \ |
| gfc_class_vtab_## name ##_get (tree cl) \ |
| { \ |
| return class_vtab_field_get (cl, field); \ |
| } \ |
| \ |
| tree \ |
| gfc_vptr_## name ##_get (tree vptr) \ |
| { \ |
| return vptr_field_get (vptr, field); \ |
| } |
| |
| VTAB_GET_FIELD_GEN (hash, VTABLE_HASH_FIELD) |
| VTAB_GET_FIELD_GEN (extends, VTABLE_EXTENDS_FIELD) |
| VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD) |
| VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD) |
| VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD) |
| VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD) |
| |
| |
| /* The size field is returned as an array index type. Therefore treat |
| it and only it specially. */ |
| |
| tree |
| gfc_class_vtab_size_get (tree cl) |
| { |
| tree size; |
| size = class_vtab_field_get (cl, VTABLE_SIZE_FIELD); |
| /* Always return size as an array index type. */ |
| size = fold_convert (gfc_array_index_type, size); |
| gcc_assert (size); |
| return size; |
| } |
| |
| tree |
| gfc_vptr_size_get (tree vptr) |
| { |
| tree size; |
| size = vptr_field_get (vptr, VTABLE_SIZE_FIELD); |
| /* Always return size as an array index type. */ |
| size = fold_convert (gfc_array_index_type, size); |
| gcc_assert (size); |
| return size; |
| } |
| |
| |
| #undef CLASS_DATA_FIELD |
| #undef CLASS_VPTR_FIELD |
| #undef CLASS_LEN_FIELD |
| #undef VTABLE_HASH_FIELD |
| #undef VTABLE_SIZE_FIELD |
| #undef VTABLE_EXTENDS_FIELD |
| #undef VTABLE_DEF_INIT_FIELD |
| #undef VTABLE_COPY_FIELD |
| #undef VTABLE_FINAL_FIELD |
| |
| |
| /* IF ts is null (default), search for the last _class ref in the chain |
| of references of the expression and cut the chain there. Although |
| this routine is similiar to class.c:gfc_add_component_ref (), there |
| is a significant difference: gfc_add_component_ref () concentrates |
| on an array ref that is the last ref in the chain and is oblivious |
| to the kind of refs following. |
| ELSE IF ts is non-null the cut is at the class entity or component |
| that is followed by an array reference, which is not an element. |
| These calls come from trans-array.c:build_class_array_ref, which |
| handles scalarized class array references.*/ |
| |
| gfc_expr * |
| gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold, |
| gfc_typespec **ts) |
| { |
| gfc_expr *base_expr; |
| gfc_ref *ref, *class_ref, *tail = NULL, *array_ref; |
| |
| /* Find the last class reference. */ |
| class_ref = NULL; |
| array_ref = NULL; |
| |
| if (ts) |
| { |
| if (e->symtree |
| && e->symtree->n.sym->ts.type == BT_CLASS) |
| *ts = &e->symtree->n.sym->ts; |
| else |
| *ts = NULL; |
| } |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| { |
| if (ts) |
| { |
| if (ref->type == REF_COMPONENT |
| && ref->u.c.component->ts.type == BT_CLASS |
| && ref->next && ref->next->type == REF_COMPONENT |
| && !strcmp (ref->next->u.c.component->name, "_data") |
| && ref->next->next |
| && ref->next->next->type == REF_ARRAY |
| && ref->next->next->u.ar.type != AR_ELEMENT) |
| { |
| *ts = &ref->u.c.component->ts; |
| class_ref = ref; |
| break; |
| } |
| |
| if (ref->next == NULL) |
| break; |
| } |
| else |
| { |
| if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) |
| array_ref = ref; |
| |
| if (ref->type == REF_COMPONENT |
| && ref->u.c.component->ts.type == BT_CLASS) |
| { |
| /* Component to the right of a part reference with nonzero |
| rank must not have the ALLOCATABLE attribute. If attempts |
| are made to reference such a component reference, an error |
| results followed by an ICE. */ |
| if (array_ref |
| && CLASS_DATA (ref->u.c.component)->attr.allocatable) |
| return NULL; |
| class_ref = ref; |
| } |
| } |
| } |
| |
| if (ts && *ts == NULL) |
| return NULL; |
| |
| /* Remove and store all subsequent references after the |
| CLASS reference. */ |
| if (class_ref) |
| { |
| tail = class_ref->next; |
| class_ref->next = NULL; |
| } |
| else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) |
| { |
| tail = e->ref; |
| e->ref = NULL; |
| } |
| |
| if (is_mold) |
| base_expr = gfc_expr_to_initialize (e); |
| else |
| base_expr = gfc_copy_expr (e); |
| |
| /* Restore the original tail expression. */ |
| if (class_ref) |
| { |
| gfc_free_ref_list (class_ref->next); |
| class_ref->next = tail; |
| } |
| else if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) |
| { |
| gfc_free_ref_list (e->ref); |
| e->ref = tail; |
| } |
| return base_expr; |
| } |
| |
| |
| /* Reset the vptr to the declared type, e.g. after deallocation. */ |
| |
| void |
| gfc_reset_vptr (stmtblock_t *block, gfc_expr *e) |
| { |
| gfc_symbol *vtab; |
| tree vptr; |
| tree vtable; |
| gfc_se se; |
| |
| /* Evaluate the expression and obtain the vptr from it. */ |
| gfc_init_se (&se, NULL); |
| if (e->rank) |
| gfc_conv_expr_descriptor (&se, e); |
| else |
| gfc_conv_expr (&se, e); |
| gfc_add_block_to_block (block, &se.pre); |
| vptr = gfc_get_vptr_from_expr (se.expr); |
| |
| /* If a vptr is not found, we can do nothing more. */ |
| if (vptr == NULL_TREE) |
| return; |
| |
| if (UNLIMITED_POLY (e)) |
| gfc_add_modify (block, vptr, build_int_cst (TREE_TYPE (vptr), 0)); |
| else |
| { |
| /* Return the vptr to the address of the declared type. */ |
| vtab = gfc_find_derived_vtab (e->ts.u.derived); |
| vtable = vtab->backend_decl; |
| if (vtable == NULL_TREE) |
| vtable = gfc_get_symbol_decl (vtab); |
| vtable = gfc_build_addr_expr (NULL, vtable); |
| vtable = fold_convert (TREE_TYPE (vptr), vtable); |
| gfc_add_modify (block, vptr, vtable); |
| } |
| } |
| |
| |
| /* Reset the len for unlimited polymorphic objects. */ |
| |
| void |
| gfc_reset_len (stmtblock_t *block, gfc_expr *expr) |
| { |
| gfc_expr *e; |
| gfc_se se_len; |
| e = gfc_find_and_cut_at_last_class_ref (expr); |
| if (e == NULL) |
| return; |
| gfc_add_len_component (e); |
| gfc_init_se (&se_len, NULL); |
| gfc_conv_expr (&se_len, e); |
| gfc_add_modify (block, se_len.expr, |
| fold_convert (TREE_TYPE (se_len.expr), integer_zero_node)); |
| gfc_free_expr (e); |
| } |
| |
| |
| /* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class |
| reference is found. Note that it is up to the caller to avoid using this |
| for expressions other than variables. */ |
| |
| tree |
| gfc_get_class_from_gfc_expr (gfc_expr *e) |
| { |
| gfc_expr *class_expr; |
| gfc_se cse; |
| class_expr = gfc_find_and_cut_at_last_class_ref (e); |
| if (class_expr == NULL) |
| return NULL_TREE; |
| gfc_init_se (&cse, NULL); |
| gfc_conv_expr (&cse, class_expr); |
| gfc_free_expr (class_expr); |
| return cse.expr; |
| } |
| |
| |
| /* Obtain the last class reference in an expression. |
| Return NULL_TREE if no class reference is found. */ |
| |
| tree |
| gfc_get_class_from_expr (tree expr) |
| { |
| tree tmp; |
| tree type; |
| |
| for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)) |
| { |
| if (CONSTANT_CLASS_P (tmp)) |
| return NULL_TREE; |
| |
| type = TREE_TYPE (tmp); |
| while (type) |
| { |
| if (GFC_CLASS_TYPE_P (type)) |
| return tmp; |
| if (type != TYPE_CANONICAL (type)) |
| type = TYPE_CANONICAL (type); |
| else |
| type = NULL_TREE; |
| } |
| if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL) |
| break; |
| } |
| |
| if (POINTER_TYPE_P (TREE_TYPE (tmp))) |
| tmp = build_fold_indirect_ref_loc (input_location, tmp); |
| |
| if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) |
| return tmp; |
| |
| return NULL_TREE; |
| } |
| |
| |
| /* Obtain the vptr of the last class reference in an expression. |
| Return NULL_TREE if no class reference is found. */ |
| |
| tree |
| gfc_get_vptr_from_expr (tree expr) |
| { |
| tree tmp; |
| |
| tmp = gfc_get_class_from_expr (expr); |
| |
| if (tmp != NULL_TREE) |
| return gfc_class_vptr_get (tmp); |
| |
| return NULL_TREE; |
| } |
| |
| |
| static void |
| 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_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc), |
| gfc_conv_descriptor_dtype (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 vptr is not NULL, this is |
| used for the temporary class object. |
| optional_alloc_ptr is false when the dummy is neither allocatable |
| nor a pointer; that's only relevant for the optional handling. |
| The optional argument 'derived_array' is used to preserve the parmse |
| expression for deallocation of allocatable components. Assumed rank |
| formal arguments made this necessary. */ |
| void |
| gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, |
| gfc_typespec class_ts, tree vptr, bool optional, |
| bool optional_alloc_ptr, |
| tree *derived_array) |
| { |
| gfc_symbol *vtab; |
| tree cond_optional = NULL_TREE; |
| gfc_ss *ss; |
| tree ctree; |
| tree var; |
| tree tmp; |
| int dim; |
| |
| /* The derived type needs to be converted to a temporary |
| CLASS object. */ |
| tmp = gfc_typenode_for_spec (&class_ts); |
| var = gfc_create_var (tmp, "class"); |
| |
| /* Set the vptr. */ |
| ctree = gfc_class_vptr_get (var); |
| |
| if (vptr != NULL_TREE) |
| { |
| /* Use the dynamic vptr. */ |
| tmp = vptr; |
| } |
| else |
| { |
| /* In this case the vtab corresponds to the derived type and the |
| vptr must point to it. */ |
| vtab = gfc_find_derived_vtab (e->ts.u.derived); |
| gcc_assert (vtab); |
| tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); |
| } |
| gfc_add_modify (&parmse->pre, ctree, |
| fold_convert (TREE_TYPE (ctree), tmp)); |
| |
| /* Now set the data field. */ |
| ctree = gfc_class_data_get (var); |
| |
| if (optional) |
| cond_optional = gfc_conv_expr_present (e->symtree->n.sym); |
| |
| if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr))) |
| { |
| /* If there is a ready made pointer to a derived type, use it |
| rather than evaluating the expression again. */ |
| tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); |
| gfc_add_modify (&parmse->pre, ctree, tmp); |
| } |
| else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags) |
| { |
| /* For an array reference in an elemental procedure call we need |
| to retain the ss to provide the scalarized array reference. */ |
| gfc_conv_expr_reference (parmse, e); |
| tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); |
| if (optional) |
| tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), |
| cond_optional, tmp, |
| fold_convert (TREE_TYPE (tmp), null_pointer_node)); |
| gfc_add_modify (&parmse->pre, ctree, tmp); |
| } |
| else |
| { |
| ss = gfc_walk_expr (e); |
| if (ss == gfc_ss_terminator) |
| { |
| parmse->ss = NULL; |
| gfc_conv_expr_reference (parmse, e); |
| |
| /* Scalar to an assumed-rank array. */ |
| if (class_ts.u.derived->components->as) |
| { |
| tree type; |
| type = get_scalar_to_descriptor_type (parmse->expr, |
| gfc_expr_attr (e)); |
| gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (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); |
| } |
| else |
| { |
| tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); |
| if (optional) |
| tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), |
| cond_optional, tmp, |
| fold_convert (TREE_TYPE (tmp), |
| null_pointer_node)); |
| gfc_add_modify (&parmse->pre, ctree, tmp); |
| } |
| } |
| else |
| { |
| stmtblock_t block; |
| gfc_init_block (&block); |
| gfc_ref *ref; |
| |
| parmse->ss = ss; |
| parmse->use_offset = 1; |
| gfc_conv_expr_descriptor (parmse, e); |
| |
| /* 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) |
| { |
| for (dim = 0; dim < e->rank; ++dim) |
| gfc_conv_shift_descriptor_lbound (&block, parmse->expr, dim, |
| gfc_index_one_node); |
| } |
| |
| if (e->rank != class_ts.u.derived->components->as->rank) |
| { |
| gcc_assert (class_ts.u.derived->components->as->type |
| == AS_ASSUMED_RANK); |
| if (derived_array |
| && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr))) |
| { |
| *derived_array = gfc_create_var (TREE_TYPE (parmse->expr), |
| "array"); |
| gfc_add_modify (&block, *derived_array , parmse->expr); |
| } |
| class_array_data_assign (&block, ctree, parmse->expr, false); |
| } |
| else |
| { |
| if (gfc_expr_attr (e).codimension) |
| parmse->expr = fold_build1_loc (input_location, |
| VIEW_CONVERT_EXPR, |
| TREE_TYPE (ctree), |
| parmse->expr); |
| gfc_add_modify (&block, ctree, parmse->expr); |
| } |
| |
| if (optional) |
| { |
| tmp = gfc_finish_block (&block); |
| |
| gfc_init_block (&block); |
| gfc_conv_descriptor_data_set (&block, ctree, null_pointer_node); |
| if (derived_array && *derived_array != NULL_TREE) |
| gfc_conv_descriptor_data_set (&block, *derived_array, |
| null_pointer_node); |
| |
| tmp = build3_v (COND_EXPR, cond_optional, tmp, |
| gfc_finish_block (&block)); |
| gfc_add_expr_to_block (&parmse->pre, tmp); |
| } |
| else |
| gfc_add_block_to_block (&parmse->pre, &block); |
| } |
| } |
| |
| if (class_ts.u.derived->components->ts.type == BT_DERIVED |
| && class_ts.u.derived->components->ts.u.derived |
| ->attr.unlimited_polymorphic) |
| { |
| /* Take care about initializing the _len component correctly. */ |
| ctree = gfc_class_len_get (var); |
| if (UNLIMITED_POLY (e)) |
| { |
| gfc_expr *len; |
| gfc_se se; |
| |
| len = gfc_find_and_cut_at_last_class_ref (e); |
| gfc_add_len_component (len); |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr (&se, len); |
| if (optional) |
| tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se.expr), |
| cond_optional, se.expr, |
| fold_convert (TREE_TYPE (se.expr), |
| integer_zero_node)); |
| else |
| tmp = se.expr; |
| gfc_free_expr (len); |
| } |
| else |
| tmp = integer_zero_node; |
| gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), |
| tmp)); |
| } |
| /* Pass the address of the class object. */ |
| parmse->expr = gfc_build_addr_expr (NULL_TREE, var); |
| |
| if (optional && optional_alloc_ptr) |
| 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)); |
| } |
| |
| |
| /* Create a new class container, which is required as scalar coarrays |
| have an array descriptor while normal scalars haven't. Optionally, |
| NULL pointer checks are added if the argument is OPTIONAL. */ |
| |
| static void |
| class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e, |
| gfc_typespec class_ts, bool optional) |
| { |
| tree var, ctree, tmp; |
| stmtblock_t block; |
| gfc_ref *ref; |
| gfc_ref *class_ref; |
| |
| gfc_init_block (&block); |
| |
| class_ref = NULL; |
| for (ref = e->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_COMPONENT |
| && ref->u.c.component->ts.type == BT_CLASS) |
| class_ref = ref; |
| } |
| |
| if (class_ref == NULL |
| && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) |
| tmp = e->symtree->n.sym->backend_decl; |
| else |
| { |
| /* Remove everything after the last class reference, convert the |
| expression and then recover its tailend once more. */ |
| gfc_se tmpse; |
| ref = class_ref->next; |
| class_ref->next = NULL; |
| gfc_init_se (&tmpse, NULL); |
| gfc_conv_expr (&tmpse, e); |
| class_ref->next = ref; |
| tmp = tmpse.expr; |
| } |
| |
| var = gfc_typenode_for_spec (&class_ts); |
| var = gfc_create_var (var, "class"); |
| |
| ctree = gfc_class_vptr_get (var); |
| gfc_add_modify (&block, ctree, |
| fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp))); |
| |
| ctree = gfc_class_data_get (var); |
| tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp)); |
| gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp)); |
| |
| /* Pass the address of the class object. */ |
| parmse->expr = gfc_build_addr_expr (NULL_TREE, var); |
| |
| if (optional) |
| { |
| tree cond = gfc_conv_expr_present (e->symtree->n.sym); |
| tree tmp2; |
| |
| tmp = gfc_finish_block (&block); |
| |
| gfc_init_block (&block); |
| tmp2 = gfc_class_data_get (var); |
| gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), |
| null_pointer_node)); |
| tmp2 = gfc_finish_block (&block); |
| |
| tmp = build3_loc (input_location, COND_EXPR, void_type_node, |
| cond, tmp, tmp2); |
| gfc_add_expr_to_block (&parmse->pre, tmp); |
| } |
| else |
| gfc_add_block_to_block (&parmse->pre, &block); |
| } |
| |
| |
| /* Takes an intrinsic type expression and returns the address of a temporary |
| class object of the 'declared' type. */ |
| void |
| gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, |
| gfc_typespec class_ts) |
| { |
| gfc_symbol *vtab; |
| gfc_ss *ss; |
| tree ctree; |
| tree var; |
| tree tmp; |
| int dim; |
| |
| /* The intrinsic type needs to be converted to a temporary |
| CLASS object. */ |
| tmp = gfc_typenode_for_spec (&class_ts); |
| var = gfc_create_var (tmp, "class"); |
| |
| /* Set the vptr. */ |
| ctree = gfc_class_vptr_get (var); |
| |
| vtab = gfc_find_vtab (&e->ts); |
| gcc_assert (vtab); |
| tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); |
| gfc_add_modify (&parmse->pre, ctree, |
| fold_convert (TREE_TYPE (ctree), tmp)); |
| |
| /* Now set the data field. */ |
| ctree = gfc_class_data_get (var); |
| if (parmse->ss && parmse->ss->info->useflags) |
| { |
| /* For an array reference in an elemental procedure call we need |
| to retain the ss to provide the scalarized array reference. */ |
| gfc_conv_expr_reference (parmse, e); |
| tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); |
| gfc_add_modify (&parmse->pre, ctree, tmp); |
| } |
| else |
| { |
| ss = gfc_walk_expr (e); |
| if (ss == gfc_ss_terminator) |
| { |
| parmse->ss = NULL; |
| gfc_conv_expr_reference (parmse, e); |
| if (class_ts.u.derived->components->as |
| && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK) |
| { |
| tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr, |
| gfc_expr_attr (e)); |
| tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, |
| TREE_TYPE (ctree), tmp); |
| } |
| else |
| tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); |
| gfc_add_modify (&parmse->pre, ctree, tmp); |
| } |
| else |
| { |
| parmse->ss = ss; |
| parmse->use_offset = 1; |
| gfc_conv_expr_descriptor (parmse, 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); |
| } |
| |
| if (class_ts.u.derived->components->as->rank != e->rank) |
| { |
| tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, |
| TREE_TYPE (ctree), parmse->expr); |
| gfc_add_modify (&parmse->pre, ctree, tmp); |
| } |
| else |
| gfc_add_modify (&parmse->pre, ctree, parmse->expr); |
| } |
| } |
| |
| gcc_assert (class_ts.type == BT_CLASS); |
| if (class_ts.u.derived->components->ts.type == BT_DERIVED |
| && class_ts.u.derived->components->ts.u.derived |
| ->attr.unlimited_polymorphic) |
| { |
| ctree = gfc_class_len_get (var); |
| /* When the actual arg is a char array, then set the _len component of the |
| unlimited polymorphic entity to the length of the string. */ |
| if (e->ts.type == BT_CHARACTER) |
| { |
| /* Start with parmse->string_length because this seems to be set to a |
| correct value more often. */ |
| if (parmse->string_length) |
| tmp = parmse->string_length; |
| /* When the string_length is not yet set, then try the backend_decl of |
| the cl. */ |
| else if (e->ts.u.cl->backend_decl) |
| tmp = e->ts.u.cl->backend_decl; |
| /* If both of the above approaches fail, then try to generate an |
| expression from the input, which is only feasible currently, when the |
| expression can be evaluated to a constant one. */ |
| else |
| { |
| /* Try to simplify the expression. */ |
| gfc_simplify_expr (e, 0); |
| if (e->expr_type == EXPR_CONSTANT && !e->ts.u.cl->resolved) |
| { |
| /* Amazingly all data is present to compute the length of a |
| constant string, but the expression is not yet there. */ |
| e->ts.u.cl->length = gfc_get_constant_expr (BT_INTEGER, |
| gfc_charlen_int_kind, |
| &e->where); |
| mpz_set_ui (e->ts.u.cl->length->value.integer, |
| e->value.character.length); |
| gfc_conv_const_charlen (e->ts.u.cl); |
| e->ts.u.cl->resolved = 1; |
| tmp = e->ts.u.cl->backend_decl; |
| } |
| else |
| { |
| gfc_error ("Cannot compute the length of the char array " |
| "at %L.", &e->where); |
| } |
| } |
| } |
| else |
| tmp = integer_zero_node; |
| |
| gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp)); |
| } |
| else if (class_ts.type == BT_CLASS |
| && class_ts.u.derived->components |
| && class_ts.u.derived->components->ts.u |
| .derived->attr.unlimited_polymorphic) |
| { |
| ctree = gfc_class_len_get (var); |
| gfc_add_modify (&parmse->pre, ctree, |
| fold_convert (TREE_TYPE (ctree), |
| integer_zero_node)); |
| } |
| /* Pass the address of the class object. */ |
| parmse->expr = gfc_build_addr_expr (NULL_TREE, var); |
| } |
| |
| |
| /* Takes a scalarized class array expression and returns the |
| address of a temporary scalar class object of the 'declared' |
| type. |
| OOP-TODO: This could be improved by adding code that branched on |
| the dynamic type being the same as the declared type. In this case |
| the original class expression can be passed directly. |
| optional_alloc_ptr is false when the dummy is neither allocatable |
| nor a pointer; that's relevant for the optional handling. |
| Set copyback to true if class container's _data and _vtab pointers |
| might get modified. */ |
| |
| void |
| gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts, |
| bool elemental, bool copyback, bool optional, |
| bool optional_alloc_ptr) |
| { |
| tree ctree; |
| tree var; |
| tree tmp; |
| tree vptr; |
| tree cond = NULL_TREE; |
| tree slen = NULL_TREE; |
| gfc_ref *ref; |
| gfc_ref *class_ref; |
| stmtblock_t block; |
| bool full_array = false; |
| |
| gfc_init_block (&block); |
| |
| class_ref = NULL; |
| for (ref = e->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_COMPONENT |
| && ref->u.c.component->ts.type == BT_CLASS) |
| class_ref = ref; |
| |
| if (ref->next == NULL) |
| break; |
| } |
| |
| if ((ref == NULL || class_ref == ref) |
| && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE) |
| && (!class_ts.u.derived->components->as |
| || class_ts.u.derived->components->as->rank != -1)) |
| return; |
| |
| /* Test for FULL_ARRAY. */ |
| if (e->rank == 0 && gfc_expr_attr (e).codimension |
| && gfc_expr_attr (e).dimension) |
| full_array = true; |
| else |
| gfc_is_class_array_ref (e, &full_array); |
| |
| /* The derived type needs to be converted to a temporary |
| CLASS object. */ |
| tmp = gfc_typenode_for_spec (&class_ts); |
| var = gfc_create_var (tmp, "class"); |
| |
| /* Set the data. */ |
| ctree = gfc_class_data_get (var); |
| if (class_ts.u.derived->components->as |
| && e->rank != class_ts.u.derived->components->as->rank) |
| { |
| if (e->rank == 0) |
| { |
| tree type = get_scalar_to_descriptor_type (parmse->expr, |
| gfc_expr_attr (e)); |
| gfc_add_modify (&block, gfc_conv_descriptor_dtype (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); |
| } |
| else |
| 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); |
| } |
| |
| /* Return the data component, except in the case of scalarized array |
| references, where nullification of the cannot occur and so there |
| is no need. */ |
| if (!elemental && full_array && copyback) |
| { |
| if (class_ts.u.derived->components->as |
| && e->rank != class_ts.u.derived->components->as->rank) |
| { |
| if (e->rank == 0) |
| gfc_add_modify (&parmse->post, gfc_class_data_get (parmse->expr), |
| gfc_conv_descriptor_data_get (ctree)); |
| else |
| class_array_data_assign (&parmse->post, parmse->expr, ctree, true); |
| } |
| else |
| gfc_add_modify (&parmse->post, parmse->expr, ctree); |
| } |
| |
| /* Set the vptr. */ |
| ctree = gfc_class_vptr_get (var); |
| |
| /* The vptr is the second field of the actual argument. |
| First we have to find the corresponding class reference. */ |
| |
| tmp = NULL_TREE; |
| if (gfc_is_class_array_function (e) |
| && parmse->class_vptr != NULL_TREE) |
| tmp = parmse->class_vptr; |
| else if (class_ref == NULL |
| && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) |
| { |
| tmp = e->symtree->n.sym->backend_decl; |
| |
| if (TREE_CODE (tmp) == FUNCTION_DECL) |
| tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); |
| |
| if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp)) |
| tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp); |
| |
| slen = build_zero_cst (size_type_node); |
| } |
| else |
| { |
| /* Remove everything after the last class reference, convert the |
| expression and then recover its tailend once more. */ |
| gfc_se tmpse; |
| ref = class_ref->next; |
| class_ref->next = NULL; |
| gfc_init_se (&tmpse, NULL); |
| gfc_conv_expr (&tmpse, e); |
| class_ref->next = ref; |
| tmp = tmpse.expr; |
| slen = tmpse.string_length; |
| } |
| |
| gcc_assert (tmp != NULL_TREE); |
| |
| /* Dereference if needs be. */ |
| if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE) |
| tmp = build_fold_indirect_ref_loc (input_location, tmp); |
| |
| if (!(gfc_is_class_array_function (e) && parmse->class_vptr)) |
| vptr = gfc_class_vptr_get (tmp); |
| else |
| vptr = tmp; |
| |
| gfc_add_modify (&block, ctree, |
| fold_convert (TREE_TYPE (ctree), vptr)); |
| |
| /* Return the vptr component, except in the case of scalarized array |
| references, where the dynamic type cannot change. */ |
| if (!elemental && full_array && copyback) |
| gfc_add_modify (&parmse->post, vptr, |
| fold_convert (TREE_TYPE (vptr), ctree)); |
| |
| /* For unlimited polymorphic objects also set the _len component. */ |
| if (class_ts.type == BT_CLASS |
| && class_ts.u.derived->components |
| && class_ts.u.derived->components->ts.u |
| .derived->attr.unlimited_polymorphic) |
| { |
| ctree = gfc_class_len_get (var); |
| if (UNLIMITED_POLY (e)) |
| tmp = gfc_class_len_get (tmp); |
| else if (e->ts.type == BT_CHARACTER) |
| { |
| gcc_assert (slen != NULL_TREE); |
| tmp = slen; |
| } |
| else |
| tmp = build_zero_cst (size_type_node); |
| gfc_add_modify (&parmse->pre, ctree, |
| fold_convert (TREE_TYPE (ctree), tmp)); |
| |
| /* Return the len component, except in the case of scalarized array |
| references, where the dynamic type cannot change. */ |
| if (!elemental && full_array && copyback |
| && (UNLIMITED_POLY (e) || VAR_P (tmp))) |
| gfc_add_modify (&parmse->post, tmp, |
| fold_convert (TREE_TYPE (tmp), ctree)); |
| } |
| |
| if (optional) |
| { |
| tree tmp2; |
| |
| cond = gfc_conv_expr_present (e->symtree->n.sym); |
| /* parmse->pre may contain some preparatory instructions for the |
| temporary array descriptor. Those may only be executed when the |
| optional argument is set, therefore add parmse->pre's instructions |
| to block, which is later guarded by an if (optional_arg_given). */ |
| gfc_add_block_to_block (&parmse->pre, &block); |
| block.head = parmse->pre.head; |
| parmse->pre.head = NULL_TREE; |
| tmp = gfc_finish_block (&block); |
| |
| if (optional_alloc_ptr) |
| tmp2 = build_empty_stmt (input_location); |
| else |
| { |
| gfc_init_block (&block); |
| |
| tmp2 = gfc_conv_descriptor_data_get (gfc_class_data_get (var)); |
| gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), |
| null_pointer_node)); |
| tmp2 = gfc_finish_block (&block); |
| } |
| |
| tmp = build3_loc (input_location, COND_EXPR, void_type_node, |
| cond, tmp, tmp2); |
| gfc_add_expr_to_block (&parmse->pre, tmp); |
| } |
| else |
| gfc_add_block_to_block (&parmse->pre, &block); |
| |
| /* Pass the address of the class object. */ |
| parmse->expr = gfc_build_addr_expr (NULL_TREE, var); |
| |
| if (optional && optional_alloc_ptr) |
| parmse->expr = build3_loc (input_location, COND_EXPR, |
| TREE_TYPE (parmse->expr), |
| cond, parmse->expr, |
| fold_convert (TREE_TYPE (parmse->expr), |
| null_pointer_node)); |
| } |
| |
| |
| /* Given a class array declaration and an index, returns the address |
| of the referenced element. */ |
| |
| tree |
| gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp, |
| bool unlimited) |
| { |
| tree data, size, tmp, ctmp, offset, ptr; |
| |
| data = data_comp != NULL_TREE ? data_comp : |
| gfc_class_data_get (class_decl); |
| size = gfc_class_vtab_size_get (class_decl); |
| |
| if (unlimited) |
| { |
| tmp = fold_convert (gfc_array_index_type, |
| gfc_class_len_get (class_decl)); |
| ctmp = fold_build2_loc (input_location, MULT_EXPR, |
| gfc_array_index_type, size, tmp); |
| tmp = fold_build2_loc (input_location, GT_EXPR, |
| logical_type_node, tmp, |
| build_zero_cst (TREE_TYPE (tmp))); |
| size = fold_build3_loc (input_location, COND_EXPR, |
| gfc_array_index_type, tmp, ctmp, size); |
| } |
| |
| offset = fold_build2_loc (input_location, MULT_EXPR, |
| gfc_array_index_type, |
| index, size); |
| |
| data = gfc_conv_descriptor_data_get (data); |
| ptr = fold_convert (pvoid_type_node, data); |
| ptr = fold_build_pointer_plus_loc (input_location, ptr, offset); |
| return fold_convert (TREE_TYPE (data), ptr); |
| } |
| |
| |
| /* Copies one class expression to another, assuming that if either |
| 'to' or 'from' are arrays they are packed. Should 'from' be |
| NULL_TREE, the initialization expression for 'to' is used, assuming |
| that the _vptr is set. */ |
| |
| tree |
| gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) |
| { |
| tree fcn; |
| tree fcn_type; |
| tree from_data; |
| tree from_len; |
| tree to_data; |
| tree to_len; |
| tree to_ref; |
| tree from_ref; |
| vec<tree, va_gc> *args; |
| tree tmp; |
| tree stdcopy; |
| tree extcopy; |
| tree index; |
| bool is_from_desc = false, is_to_class = false; |
| |
| args = NULL; |
| /* To prevent warnings on uninitialized variables. */ |
| from_len = to_len = NULL_TREE; |
| |
| if (from != NULL_TREE) |
| fcn = gfc_class_vtab_copy_get (from); |
| else |
| fcn = gfc_class_vtab_copy_get (to); |
| |
| fcn_type = TREE_TYPE (TREE_TYPE (fcn)); |
| |
| if (from != NULL_TREE) |
| { |
| is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from)); |
| if (is_from_desc) |
| { |
| from_data = from; |
| from = GFC_DECL_SAVED_DESCRIPTOR (from); |
| } |
| else |
| { |
| /* Check that from is a class. When the class is part of a coarray, |
| then from is a common pointer and is to be used as is. */ |
| tmp = POINTER_TYPE_P (TREE_TYPE (from)) |
| ? build_fold_indirect_ref (from) : from; |
| from_data = |
| (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) |
| || (DECL_P (tmp) && GFC_DECL_CLASS (tmp))) |
| ? gfc_class_data_get (from) : from; |
| is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)); |
| } |
| } |
| else |
| from_data = gfc_class_vtab_def_init_get (to); |
| |
| if (unlimited) |
| { |
| if (from != NULL_TREE && unlimited) |
| from_len = gfc_class_len_or_zero_get (from); |
| else |
| from_len = build_zero_cst (size_type_node); |
| } |
| |
| if (GFC_CLASS_TYPE_P (TREE_TYPE (to))) |
| { |
| is_to_class = true; |
| to_data = gfc_class_data_get (to); |
| if (unlimited) |
| to_len = gfc_class_len_get (to); |
| } |
| else |
| /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to. */ |
| to_data = to; |
| |
| if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data))) |
| { |
| stmtblock_t loopbody; |
| stmtblock_t body; |
| stmtblock_t ifbody; |
| gfc_loopinfo loop; |
| tree orig_nelems = nelems; /* Needed for bounds check. */ |
| |
| gfc_init_block (&body); |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_array_index_type, nelems, |
| gfc_index_one_node); |
| nelems = gfc_evaluate_now (tmp, &body); |
| index = gfc_create_var (gfc_array_index_type, "S"); |
| |
| if (is_from_desc) |
| { |
| from_ref = gfc_get_class_array_ref (index, from, from_data, |
| unlimited); |
| vec_safe_push (args, from_ref); |
| } |
| else |
| vec_safe_push (args, from_data); |
| |
| if (is_to_class) |
| to_ref = gfc_get_class_array_ref (index, to, to_data, unlimited); |
| else |
| { |
| tmp = gfc_conv_array_data (to); |
| tmp = build_fold_indirect_ref_loc (input_location, tmp); |
| to_ref = gfc_build_addr_expr (NULL_TREE, |
| gfc_build_array_ref (tmp, index, to)); |
| } |
| vec_safe_push (args, to_ref); |
| |
| /* Add bounds check. */ |
| if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) > 0 && is_from_desc) |
| { |
| char *msg; |
| const char *name = "<<unknown>>"; |
| tree from_len; |
| |
| if (DECL_P (to)) |
| name = (const char *)(DECL_NAME (to)->identifier.id.str); |
| |
| from_len = gfc_conv_descriptor_size (from_data, 1); |
| tmp = fold_build2_loc (input_location, NE_EXPR, |
| logical_type_node, from_len, orig_nelems); |
| msg = xasprintf ("Array bound mismatch for dimension %d " |
| "of array '%s' (%%ld/%%ld)", |
| 1, name); |
| |
| gfc_trans_runtime_check (true, false, tmp, &body, |
| &gfc_current_locus, msg, |
| fold_convert (long_integer_type_node, orig_nelems), |
| fold_convert (long_integer_type_node, from_len)); |
| |
| free (msg); |
| } |
| |
| tmp = build_call_vec (fcn_type, fcn, args); |
| |
| /* Build the body of the loop. */ |
| gfc_init_block (&loopbody); |
| gfc_add_expr_to_block (&loopbody, tmp); |
| |
| /* Build the loop and return. */ |
| gfc_init_loopinfo (&loop); |
| loop.dimen = 1; |
| loop.from[0] = gfc_index_zero_node; |
| loop.loopvar[0] = index; |
| loop.to[0] = nelems; |
| gfc_trans_scalarizing_loops (&loop, &loopbody); |
| gfc_init_block (&ifbody); |
| gfc_add_block_to_block (&ifbody, &loop.pre); |
| stdcopy = gfc_finish_block (&ifbody); |
| /* In initialization mode from_len is a constant zero. */ |
| if (unlimited && !integer_zerop (from_len)) |
| { |
| vec_safe_push (args, from_len); |
| vec_safe_push (args, to_len); |
| tmp = build_call_vec (fcn_type, fcn, args); |
| /* Build the body of the loop. */ |
| gfc_init_block (&loopbody); |
| gfc_add_expr_to_block (&loopbody, tmp); |
| |
| /* Build the loop and return. */ |
| gfc_init_loopinfo (&loop); |
| loop.dimen = 1; |
| loop.from[0] = gfc_index_zero_node; |
| loop.loopvar[0] = index; |
| loop.to[0] = nelems; |
| gfc_trans_scalarizing_loops (&loop, &loopbody); |
| gfc_init_block (&ifbody); |
| gfc_add_block_to_block (&ifbody, &loop.pre); |
| extcopy = gfc_finish_block (&ifbody); |
| |
| tmp = fold_build2_loc (input_location, GT_EXPR, |
| logical_type_node, from_len, |
| build_zero_cst (TREE_TYPE (from_len))); |
| tmp = fold_build3_loc (input_location, COND_EXPR, |
| void_type_node, tmp, extcopy, stdcopy); |
| gfc_add_expr_to_block (&body, tmp); |
| tmp = gfc_finish_block (&body); |
| } |
| else |
| { |
| gfc_add_expr_to_block (&body, stdcopy); |
| tmp = gfc_finish_block (&body); |
| } |
| gfc_cleanup_loop (&loop); |
| } |
| else |
| { |
| gcc_assert (!is_from_desc); |
| vec_safe_push (args, from_data); |
| vec_safe_push (args, to_data); |
| stdcopy = build_call_vec (fcn_type, fcn, args); |
| |
| /* In initialization mode from_len is a constant zero. */ |
| if (unlimited && !integer_zerop (from_len)) |
| { |
| vec_safe_push (args, from_len); |
| vec_safe_push (args, to_len); |
| extcopy = build_call_vec (fcn_type, unshare_expr (fcn), args); |
| tmp = fold_build2_loc (input_location, GT_EXPR, |
| logical_type_node, from_len, |
| build_zero_cst (TREE_TYPE (from_len))); |
| tmp = fold_build3_loc (input_location, COND_EXPR, |
| void_type_node, tmp, extcopy, stdcopy); |
| } |
| else |
| tmp = stdcopy; |
| } |
| |
| /* Only copy _def_init to to_data, when it is not a NULL-pointer. */ |
| if (from == NULL_TREE) |
| { |
| tree cond; |
| cond = fold_build2_loc (input_location, NE_EXPR, |
| logical_type_node, |
| from_data, null_pointer_node); |
| tmp = fold_build3_loc (input_location, COND_EXPR, |
| void_type_node, cond, |
| tmp, build_empty_stmt (input_location)); |
| } |
| |
| return tmp; |
| } |
| |
| |
| static tree |
| gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) |
| { |
| gfc_actual_arglist *actual; |
| gfc_expr *ppc; |
| gfc_code *ppc_code; |
| tree res; |
| |
| actual = gfc_get_actual_arglist (); |
| actual->expr = gfc_copy_expr (rhs); |
| actual->next = gfc_get_actual_arglist (); |
| actual->next->expr = gfc_copy_expr (lhs); |
| ppc = gfc_copy_expr (obj); |
| gfc_add_vptr_component (ppc); |
| gfc_add_component_ref (ppc, "_copy"); |
| ppc_code = gfc_get_code (EXEC_CALL); |
| ppc_code->resolved_sym = ppc->symtree->n.sym; |
| /* Although '_copy' is set to be elemental in class.c, it is |
| not staying that way. Find out why, sometime.... */ |
| ppc_code->resolved_sym->attr.elemental = 1; |
| ppc_code->ext.actual = actual; |
| ppc_code->expr1 = ppc; |
| /* Since '_copy' is elemental, the scalarizer will take care |
| of arrays in gfc_trans_call. */ |
| res = gfc_trans_call (ppc_code, false, NULL, NULL, false); |
| gfc_free_statements (ppc_code); |
| |
| if (UNLIMITED_POLY(obj)) |
| { |
| /* Check if rhs is non-NULL. */ |
| gfc_se src; |
| gfc_init_se (&src, NULL); |
| gfc_conv_expr (&src, rhs); |
| src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); |
| tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, |
| src.expr, fold_convert (TREE_TYPE (src.expr), |
| null_pointer_node)); |
| res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res, |
| build_empty_stmt (input_location)); |
| } |
| |
| return res; |
| } |
| |
| /* Special case for initializing a polymorphic dummy with INTENT(OUT). |
| A MEMCPY is needed to copy the full data from the default initializer |
| of the dynamic type. */ |
| |
| tree |
| gfc_trans_class_init_assign (gfc_code *code) |
| { |
| stmtblock_t block; |
| tree tmp; |
| gfc_se dst,src,memsz; |
| gfc_expr *lhs, *rhs, *sz; |
| |
| gfc_start_block (&block); |
| |
| lhs = gfc_copy_expr (code->expr1); |
| |
| rhs = gfc_copy_expr (code->expr1); |
| gfc_add_vptr_component (rhs); |
| |
| /* Make sure that the component backend_decls have been built, which |
| will not have happened if the derived types concerned have not |
| been referenced. */ |
| gfc_get_derived_type (rhs->ts.u.derived); |
| gfc_add_def_init_component (rhs); |
| /* The _def_init is always scalar. */ |
| rhs->rank = 0; |
| |
| if (code->expr1->ts.type == BT_CLASS |
| && CLASS_DATA (code->expr1)->attr.dimension) |
| { |
| gfc_array_spec *tmparr = gfc_get_array_spec (); |
| *tmparr = *CLASS_DATA (code->expr1)->as; |
| /* Adding the array ref to the class expression results in correct |
| indexing to the dynamic type. */ |
| gfc_add_full_array_ref (lhs, tmparr); |
| tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); |
| } |
| else |
| { |
| /* Scalar initialization needs the _data component. */ |
| gfc_add_data_component (lhs); |
| sz = gfc_copy_expr (code->expr1); |
| gfc_add_vptr_component (sz); |
| gfc_add_size_component (sz); |
| |
| gfc_init_se (&dst, NULL); |
| gfc_init_se (&src, NULL); |
| gfc_init_se (&memsz, NULL); |
| gfc_conv_expr (&dst, lhs); |
| gfc_conv_expr (&src, rhs); |
| gfc_conv_expr (&memsz, sz); |
| gfc_add_block_to_block (&block, &src.pre); |
| src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); |
| |
| tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); |
| |
| if (UNLIMITED_POLY(code->expr1)) |
| { |
| /* Check if _def_init is non-NULL. */ |
| tree cond = fold_build2_loc (input_location, NE_EXPR, |
| logical_type_node, src.expr, |
| fold_convert (TREE_TYPE (src.expr), |
| null_pointer_node)); |
| tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, |
| tmp, build_empty_stmt (input_location)); |
| } |
| } |
| |
| if (code->expr1->symtree->n.sym->attr.dummy |
| && (code->expr1->symtree->n.sym->attr.optional |
| || code->expr1->symtree->n.sym->ns->proc_name->attr.entry_master)) |
| { |
| tree present = gfc_conv_expr_present (code->expr1->symtree->n.sym); |
| tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), |
| present, tmp, |
| build_empty_stmt (input_location)); |
| } |
| |
| gfc_add_expr_to_block (&block, tmp); |
| |
| return gfc_finish_block (&block); |
| } |
| |
| |
| /* Class valued elemental function calls or class array elements arriving |
| in gfc_trans_scalar_assign come here. Wherever possible the vptr copy |
| is used to ensure that the rhs dynamic type is assigned to the lhs. */ |
| |
| static bool |
| trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse) |
| { |
| tree fcn; |
| tree rse_expr; |
| tree class_data; |
| tree tmp; |
| tree zero; |
| tree cond; |
| tree final_cond; |
| stmtblock_t inner_block; |
| bool is_descriptor; |
| bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR; |
| bool not_lhs_array_type; |
| |
| /* Temporaries arising from depencies in assignment get cast as a |
| character type of the dynamic size of the rhs. Use the vptr copy |
| for this case. */ |
| tmp = TREE_TYPE (lse->expr); |
| not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE |
| && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE); |
| |
| /* Use ordinary assignment if the rhs is not a call expression or |
| the lhs is not a class entity or an array(ie. character) type. */ |
| if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE) |
| && not_lhs_array_type) |
| return false; |
| |
| /* Ordinary assignment can be used if both sides are class expressions |
| since the dynamic type is preserved by copying the vptr. This |
| should only occur, where temporaries are involved. */ |
| if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) |
| && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))) |
| return false; |
| |
| /* Fix the class expression and the class data of the rhs. */ |
| if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) |
| || not_call_expr) |
| { |
| tmp = gfc_get_class_from_expr (rse->expr); |
| if (tmp == NULL_TREE) |
| return false; |
| rse_expr = gfc_evaluate_now (tmp, block); |
| } |
| else |
| rse_expr = gfc_evaluate_now (rse->expr, block); |
| |
| class_data = gfc_class_data_get (rse_expr); |
| |
| /* Check that the rhs data is not null. */ |
| is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data)); |
| if (is_descriptor) |
| class_data = gfc_conv_descriptor_data_get (class_data); |
| class_data = gfc_evaluate_now (class_data, block); |
| |
| zero = build_int_cst (TREE_TYPE (class_data), 0); |
| cond = fold_build2_loc (input_location, NE_EXPR, |
| logical_type_node, |
| class_data, zero); |
| |
| /* Copy the rhs to the lhs. */ |
| fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr)); |
| fcn = build_fold_indirect_ref_loc (input_location, fcn); |
| tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block); |
| tmp = is_descriptor ? tmp : class_data; |
| tmp = build_call_expr_loc (input_location, fcn, 2, tmp, |
| gfc_build_addr_expr (NULL, lse->expr)); |
| gfc_add_expr_to_block (block, tmp); |
| |
| /* Only elemental function results need to be finalised and freed. */ |
| if (not_call_expr) |
| return true; |
| |
| /* Finalize the class data if needed. */ |
| gfc_init_block (&inner_block); |
| fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr)); |
| zero = build_int_cst (TREE_TYPE (fcn), 0); |
| final_cond = fold_build2_loc (input_location, NE_EXPR, |
| logical_type_node, fcn, zero); |
| fcn = build_fold_indirect_ref_loc (input_location, fcn); |
| tmp = build_call_expr_loc (input_location, fcn, 1, class_data); |
| tmp = build3_v (COND_EXPR, final_cond, |
| tmp, build_empty_stmt (input_location)); |
| gfc_add_expr_to_block (&inner_block, tmp); |
| |
| /* Free the class data. */ |
| tmp = gfc_call_free (class_data); |
| tmp = build3_v (COND_EXPR, cond, tmp, |
| build_empty_stmt (input_location)); |
| gfc_add_expr_to_block (&inner_block, tmp); |
| |
| /* Finish the inner block and subject it to the condition on the |
| class data being non-zero. */ |
| tmp = gfc_finish_block (&inner_block); |
| tmp = build3_v (COND_EXPR, cond, tmp, |
| build_empty_stmt (input_location)); |
| gfc_add_expr_to_block (block, tmp); |
| |
| return true; |
| } |
| |
| /* End of prototype trans-class.c */ |
| |
| |
| static void |
| realloc_lhs_warning (bt type, bool array, locus *where) |
| { |
| if (array && type != BT_CLASS && type != BT_DERIVED && warn_realloc_lhs) |
| gfc_warning (OPT_Wrealloc_lhs, |
| "Code for reallocating the allocatable array at %L will " |
| "be added", where); |
| else if (warn_realloc_lhs_all) |
| gfc_warning (OPT_Wrealloc_lhs_all, |
| "Code for reallocating the allocatable variable at %L " |
| "will be added", where); |
| } |
| |
| |
| static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, |
| gfc_expr *); |
| |
| /* Copy the scalarization loop variables. */ |
| |
| static void |
| gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src) |
| { |
| dest->ss = src->ss; |
| dest->loop = src->loop; |
| } |
| |
| |
| /* Initialize a simple expression holder. |
| |
| Care must be taken when multiple se are created with the same parent. |
| The child se must be kept in sync. The easiest way is to delay creation |
| of a child se until after the previous se has been translated. */ |
| |
| void |
| gfc_init_se (gfc_se * se, gfc_se * parent) |
| { |
| memset (se, 0, sizeof (gfc_se)); |
| gfc_init_block (&se->pre); |
| gfc_init_block (&se->post); |
| |
| se->parent = parent; |
| |
| if (parent) |
| gfc_copy_se_loopvars (se, parent); |
| } |
| |
| |
| /* Advances to the next SS in the chain. Use this rather than setting |
| se->ss = se->ss->next because all the parents needs to be kept in sync. |
| See gfc_init_se. */ |
| |
| void |
| gfc_advance_se_ss_chain (gfc_se * se) |
| { |
| gfc_se *p; |
| gfc_ss *ss; |
| |
| gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator); |
| |
| p = se; |
| /* Walk down the parent chain. */ |
| while (p != NULL) |
| { |
| /* Simple consistency check. */ |
| gcc_assert (p->parent == NULL || p->parent->ss == p->ss |
| || p->parent->ss->nested_ss == p->ss); |
| |
| /* If we were in a nested loop, the next scalarized expression can be |
| on the parent ss' next pointer. Thus we should not take the next |
| pointer blindly, but rather go up one nest level as long as next |
| is the end of chain. */ |
| ss = p->ss; |
| while (ss->next == gfc_ss_terminator && ss->parent != NULL) |
| ss = ss->parent; |
| |
| p->ss = ss->next; |
| |
| p = p->parent; |
| } |
| } |
| |
| |
| /* Ensures the result of the expression as either a temporary variable |
| or a constant so that it can be used repeatedly. */ |
| |
| void |
| gfc_make_safe_expr (gfc_se * se) |
| { |
| tree var; |
| |
| if (CONSTANT_CLASS_P (se->expr)) |
| return; |
| |
| /* We need a temporary for this result. */ |
| var = gfc_create_var (TREE_TYPE (se->expr), NULL); |
| gfc_add_modify (&se->pre, var, se->expr); |
| se->expr = var; |
| } |
| |
| |
| /* Return an expression which determines if a dummy parameter is present. |
| Also used for arguments to procedures with multiple entry points. */ |
| |
| tree |
| gfc_conv_expr_present (gfc_symbol * sym, bool use_saved_desc) |
| { |
| tree decl, orig_decl, cond; |
| |
| gcc_assert (sym->attr.dummy); |
| orig_decl = decl = gfc_get_symbol_decl (sym); |
| |
| /* Intrinsic scalars with VALUE attribute which are passed by value |
| use a hidden argument to denote the present status. */ |
| if (sym->attr.value && sym->ts.type != BT_CHARACTER |
| && sym->ts.type != BT_CLASS && sym->ts.type != BT_DERIVED |
| && !sym->attr.dimension) |
| { |
| char name[GFC_MAX_SYMBOL_LEN + 2]; |
| tree tree_name; |
| |
| gcc_assert (TREE_CODE (decl) == PARM_DECL); |
| name[0] = '_'; |
| strcpy (&name[1], sym->name); |
| tree_name = get_identifier (name); |
| |
| /* Walk function argument list to find hidden arg. */ |
| cond = DECL_ARGUMENTS (DECL_CONTEXT (decl)); |
| for ( ; cond != NULL_TREE; cond = TREE_CHAIN (cond)) |
| if (DECL_NAME (cond) == tree_name |
| && DECL_ARTIFICIAL (cond)) |
| break; |
| |
| gcc_assert (cond); |
| return cond; |
| } |
| |
| /* Assumed-shape arrays use a local variable for the array data; |
| the actual PARAM_DECL is in a saved decl. As the local variable |
| is NULL, it can be checked instead, unless use_saved_desc is |
| requested. */ |
| |
| if (use_saved_desc && TREE_CODE (decl) != PARM_DECL) |
| { |
| gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) |
| || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); |
| decl = GFC_DECL_SAVED_DESCRIPTOR (decl); |
| } |
| |
| cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl, |
| fold_convert (TREE_TYPE (decl), null_pointer_node)); |
| |
| /* Fortran 2008 allows to pass null pointers and non-associated pointers |
| as actual argument to denote absent dummies. For array descriptors, |
| we thus also need to check the array descriptor. For BT_CLASS, it |
| can also occur for scalars and F2003 due to type->class wrapping and |
| class->class wrapping. Note further that BT_CLASS always uses an |
| array descriptor for arrays, also for explicit-shape/assumed-size. |
| For assumed-rank arrays, no local variable is generated, hence, |
| the following also applies with !use_saved_desc. */ |
| |
| if ((use_saved_desc || TREE_CODE (orig_decl) == PARM_DECL) |
| && !sym->attr.allocatable |
| && ((sym->ts.type != BT_CLASS && !sym->attr.pointer) |
| || (sym->ts.type == BT_CLASS |
| && !CLASS_DATA (sym)->attr.allocatable |
| && !CLASS_DATA (sym)->attr.class_pointer)) |
| && ((gfc_option.allow_std & GFC_STD_F2008) != 0 |
| || sym->ts.type == BT_CLASS)) |
| { |
| tree tmp; |
| |
| if ((sym->as && (sym->as->type == AS_ASSUMED_SHAPE |
| || sym->as->type == AS_ASSUMED_RANK |
| || sym->attr.codimension)) |
| || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)) |
| { |
| tmp = build_fold_indirect_ref_loc (input_location, decl); |
| if (sym->ts.type == BT_CLASS) |
| tmp = gfc_class_data_get (tmp); |
| tmp = gfc_conv_array_data (tmp); |
| } |
| else if (sym->ts.type == BT_CLASS) |
| tmp = gfc_class_data_get (decl); |
| else |
| tmp = NULL_TREE; |
| |
| if (tmp != NULL_TREE) |
| { |
| tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, |
| fold_convert (TREE_TYPE (tmp), null_pointer_node)); |
| cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, |
| logical_type_node, cond, tmp); |
| } |
| } |
| |
| return cond; |
| } |
| |
| |
| /* Converts a missing, dummy argument into a null or zero. */ |
| |
| void |
| gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind) |
| { |
| tree present; |
| tree tmp; |
| |
| present = gfc_conv_expr_present (arg->symtree->n.sym); |
| |
| if (kind > 0) |
| { |
| /* Create a temporary and convert it to the correct type. */ |
| tmp = gfc_get_int_type (kind); |
| tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location, |
| se->expr)); |
| |
| /* Test for a NULL value. */ |
| tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, |
| tmp, fold_convert (TREE_TYPE (tmp), integer_one_node)); |
| tmp = gfc_evaluate_now (tmp, &se->pre); |
| se->expr = gfc_build_addr_expr (NULL_TREE, tmp); |
| } |
| else |
| { |
| tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (se->expr), |
| present, se->expr, |
| build_zero_cst (TREE_TYPE (se->expr))); |
| tmp = gfc_evaluate_now (tmp, &se->pre); |
| se->expr = tmp; |
| } |
| |
| if (ts.type == BT_CHARACTER) |
| { |
| tmp = build_int_cst (gfc_charlen_type_node, 0); |
| tmp = fold_build3_loc (input_location, COND_EXPR, gfc_charlen_type_node, |
| present, se->string_length, tmp); |
| tmp = gfc_evaluate_now (tmp, &se->pre); |
| se->string_length = tmp; |
| } |
| return; |
| } |
| |
| |
| /* Get the character length of an expression, looking through gfc_refs |
| if necessary. */ |
| |
| tree |
| gfc_get_expr_charlen (gfc_expr *e) |
| { |
| gfc_ref *r; |
| tree length; |
| gfc_se se; |
| |
| gcc_assert (e->expr_type == EXPR_VARIABLE |
| && e->ts.type == BT_CHARACTER); |
| |
| length = NULL; /* To silence compiler warning. */ |
| |
| if (is_subref_array (e) && e->ts.u.cl->length) |
| { |
| gfc_se tmpse; |
| gfc_init_se (&tmpse, NULL); |
| gfc_conv_expr_type (&tmpse, e->ts.u.cl->length, gfc_charlen_type_node); |
| e->ts.u.cl->backend_decl = tmpse.expr; |
| return tmpse.expr; |
| } |
| |
| /* First candidate: if the variable is of type CHARACTER, the |
| expression's length could be the length of the character |
| variable. */ |
| if (e->symtree->n.sym->ts.type == BT_CHARACTER) |
| length = e->symtree->n.sym->ts.u.cl->backend_decl; |
| |
| /* Look through the reference chain for component references. */ |
| for (r = e->ref; r; r = r->next) |
| { |
| switch (r->type) |
| { |
| case REF_COMPONENT: |
| if (r->u.c.component->ts.type == BT_CHARACTER) |
| length = r->u.c.component->ts.u.cl->backend_decl; |
| break; |
| |
| case REF_ARRAY: |
| /* Do nothing. */ |
| break; |
| |
| case REF_SUBSTRING: |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_type (&se, r->u.ss.start, gfc_charlen_type_node); |
| length = se.expr; |
| gfc_conv_expr_type (&se, r->u.ss.end, gfc_charlen_type_node); |
| length = fold_build2_loc (input_location, MINUS_EXPR, |
| gfc_charlen_type_node, |
| se.expr, length); |
| length = fold_build2_loc (input_location, PLUS_EXPR, |
| gfc_charlen_type_node, length, |
| gfc_index_one_node); |
| break; |
| |
| default: |
| gcc_unreachable (); |
| break; |
| } |
| } |
| |
| gcc_assert (length != NULL); |
| return length; |
| } |
| |
| |
| /* Return for an expression the backend decl of the coarray. */ |
| |
| tree |
| gfc_get_tree_for_caf_expr (gfc_expr *expr) |
| { |
| tree caf_decl; |
| bool found = false; |
| gfc_ref *ref; |
| |
| gcc_assert (expr && expr->expr_type == EXPR_VARIABLE); |
| |
| /* Not-implemented diagnostic. */ |
| if (expr->symtree->n.sym->ts.type == BT_CLASS |
| && UNLIMITED_POLY (expr->symtree->n.sym) |
| && CLASS_DATA (expr->symtree->n.sym)->attr.codimension) |
| gfc_error ("Sorry, coindexed access to an unlimited polymorphic object at " |
| "%L is not supported", &expr->where); |
| |
| for (ref = expr->ref; ref; ref = ref->next) |
| if (ref->type == REF_COMPONENT) |
| { |
| if (ref->u.c.component->ts.type == BT_CLASS |
| && UNLIMITED_POLY (ref->u.c.component) |
| && CLASS_DATA (ref->u.c.component)->attr.codimension) |
| gfc_error ("Sorry, coindexed access to an unlimited polymorphic " |
| "component at %L is not supported", &expr->where); |
| } |
| |
| /* Make sure the backend_decl is present before accessing it. */ |
| caf_decl = expr->symtree->n.sym->backend_decl == NULL_TREE |
| ? gfc_get_symbol_decl (expr->symtree->n.sym) |
| : expr->symtree->n.sym->backend_decl; |
| |
| if (expr->symtree->n.sym->ts.type == BT_CLASS) |
| { |
| if (expr->ref && expr->ref->type == REF_ARRAY) |
| { |
| caf_decl = gfc_class_data_get (caf_decl); |
| if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension) |
| return caf_decl; |
| } |
| for (ref = expr->ref; ref; ref = ref->next) |
| { |
| if (ref->type == REF_COMPONENT |
| && strcmp (ref->u.c.component->name, "_data") != 0) |
| { |
| caf_decl = gfc_class_data_get (caf_decl); |
| if (CLASS_DATA (expr->symtree->n.sym)->attr.codimension) |
| return caf_decl; |
| break; |
| } |
| else if (ref->type == REF_ARRAY && ref->u.ar.dimen) |
| break; |
| } |
| } |
| if (expr->symtree->n.sym->attr.codimension) |
| return caf_decl; |
| |
| /* The following code assumes that the coarray is a component reachable via |
| only scalar components/variables; the Fortran standard guarantees this. */ |
| |
| for (ref = expr->ref; ref; ref = ref->next) |
| if (ref->type == REF_COMPONENT) |
| { |
| gfc_component *comp = ref->u.c.component; |
| |
| if (POINTER_TYPE_P (TREE_TYPE (caf_decl))) |
| caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl); |
| caf_decl = fold_build3_loc (input_location, COMPONENT_REF, |
| TREE_TYPE (comp->backend_decl), caf_decl, |
| comp->backend_decl, NULL_TREE); |
| if (comp->ts.type == BT_CLASS) |
| { |
| caf_decl = gfc_class_data_get (caf_decl); |
| if (CLASS_DATA (comp)->attr.codimension) |
| { |
| found = true; |
| break; |
| } |
| } |
| if (comp->attr.codimension) |
| { |
| found = true; |
| break; |
| } |
| } |
| gcc_assert (found && caf_decl); |
| return caf_decl; |
| } |
| |
| |
| /* Obtain the Coarray token - and optionally also the offset. */ |
| |
| void |
| gfc_get_caf_token_offset (gfc_se *se, tree *token, tree *offset, tree caf_decl, |
| tree se_expr, gfc_expr *expr) |
| { |
| tree tmp; |
| |
| /* Coarray token. */ |
| if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) |
| { |
| gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) |
| == GFC_ARRAY_ALLOCATABLE |
| || expr->symtree->n.sym->attr.select_type_temporary); |
| *token = gfc_conv_descriptor_token (caf_decl); |
| } |
| else if (DECL_LANG_SPECIFIC (caf_decl) |
| && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) |
| *token = GFC_DECL_TOKEN (caf_decl); |
| else |
| { |
| gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl)) |
| && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE); |
| *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)); |
| } |
| |
| if (offset == NULL) |
| return; |
| |
| /* Offset between the coarray base address and the address wanted. */ |
| if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)) |
| && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE |
| || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER)) |
| *offset = build_int_cst (gfc_array_index_type, 0); |
| else if (DECL_LANG_SPECIFIC (caf_decl) |
| && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE) |
| *offset = GFC_DECL_CAF_OFFSET (caf_decl); |
| else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE) |
| *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)); |
| else |
| *offset = build_int_cst (gfc_array_index_type, 0); |
| |
| if (POINTER_TYPE_P (TREE_TYPE (se_expr)) |
| && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr)))) |
| { |
| tmp = build_fold_indirect_ref_loc (input_location, se_expr); |
| tmp = gfc_conv_descriptor_data_get (tmp); |
| } |
| else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr))) |
| tmp = gfc_conv_descriptor_data_get (se_expr); |
| else |
| { |
| gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr))); |
| tmp = se_expr; |
| } |
| |
| *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
| *offset, fold_convert (gfc_array_index_type, tmp)); |
| |
| if (expr->symtree->n.sym->ts.type == BT_DERIVED |
| && expr->symtree->n.sym->attr.codimension |
| && expr->symtree->n.sym->ts.u.derived->attr.alloc_comp) |
| { |
| gfc_expr *base_expr = gfc_copy_expr (expr); |
| gfc_ref *ref = base_expr->ref; |
| gfc_se base_se; |
| |
| // Iterate through the refs until the last one. |
| while (ref->next) |
| ref = ref->next; |
| |
| if (ref->type == REF_ARRAY |
| && ref->u.ar.type != AR_FULL) |
| { |
| const int ranksum = ref->u.ar.dimen + ref->u.ar.codimen; |
| int i; |
| for (i = 0; i < ranksum; ++i) |
| { |
| ref->u.ar.start[i] = NULL; |
| ref->u.ar.end[i] = NULL; |
| } |
| ref->u.ar.type = AR_FULL; |
| } |
| gfc_init_se (&base_se, NULL); |
| if (gfc_caf_attr (base_expr).dimension) |
| { |
| gfc_conv_expr_descriptor (&base_se, base_expr); |
| tmp = gfc_conv_descriptor_data_get (base_se.expr); |
| } |
| else |
| { |
| gfc_conv_expr (&base_se, base_expr); |
| tmp = base_se.expr; |
| } |
| |
| gfc_free_expr (base_expr); |
| gfc_add_block_to_block (&se->pre, &base_se.pre); |
| gfc_add_block_to_block (&se->post, &base_se.post); |
| } |
| else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))) |
| tmp = gfc_conv_descriptor_data_get (caf_decl); |
| else |
| { |
| gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl))); |
| tmp = caf_decl; |
| } |
| |
| *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, |
| fold_convert (gfc_array_index_type, *offset), |
| fold_convert (gfc_array_index_type, tmp)); |
| } |
| |
| |
| /* Convert the coindex of a coarray into an image index; the result is |
| image_num = (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2))*extent(1) |
| + (idx(3)-lcobound(3))*extend(1)*extent(2) + ... */ |
| |
| tree |
| gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc) |
| { |
| gfc_ref *ref; |
| tree lbound, ubound, extent, tmp, img_idx; |
| gfc_se se; |
| int i; |
| |
| for (ref = e->ref; ref; ref = ref->next) |
| if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) |
| break; |
| gcc_assert (ref != NULL); |
| |
| if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE) |
| { |
| return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1, |
| integer_zero_node); |
| } |
| |
| img_idx = build_zero_cst (gfc_array_index_type); |
| extent = build_one_cst (gfc_array_index_type); |
| if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) |
| for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) |
| { |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type); |
| gfc_add_block_to_block (block, &se.pre); |
| lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| TREE_TYPE (lbound), se.expr, lbound); |
| tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), |
| extent, tmp); |
| img_idx = fold_build2_loc (input_location, PLUS_EXPR, |
| 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); |
| extent = fold_build2_loc (input_location, MULT_EXPR, |
| TREE_TYPE (tmp), extent, tmp); |
| } |
| } |
| else |
| for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) |
| { |
| gfc_init_se (&se, NULL); |
| gfc_conv_expr_type (&se, ref->u.ar.start[i], gfc_array_index_type); |
| gfc_add_block_to_block (block, &se.pre); |
| lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i); |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| TREE_TYPE (lbound), se.expr, lbound); |
| tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), |
| extent, tmp); |
| img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), |
| img_idx, tmp); |
| if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1) |
| { |
| ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i); |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, |
| TREE_TYPE (ubound), ubound, lbound); |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), |
| tmp, build_one_cst (TREE_TYPE (tmp))); |
| extent = fold_build2_loc (input_location, MULT_EXPR, |
| TREE_TYPE (tmp), extent, tmp); |
| } |
| } |
| img_idx = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (img_idx), |
| img_idx, build_one_cst (TREE_TYPE (img_idx))); |
| return fold_convert (integer_type_node, img_idx); |
| } |
| |
| |
| /* For each character array constructor subexpression without a ts.u.cl->length, |
| replace it by its first element (if there aren't any elements, the length |
| should already be set to zero). */ |
| |
| static void |
| flatten_array_ctors_without_strlen (gfc_expr* e) |
| { |
| gfc_actual_arglist* arg; |
| gfc_constructor* c; |
| |
| if (!e) |
| return; |
| |
| switch (e->expr_type) |
| { |
| |
| case EXPR_OP: |
| flatten_array_ctors_without_strlen (e->value.op.op1); |
| flatten_array_ctors_without_strlen (e->value.op.op2); |
| break; |
| |
| case EXPR_COMPCALL: |
| /* TODO: Implement as with EXPR_FUNCTION when needed. */ |
| gcc_unreachable (); |
| |
| case EXPR_FUNCTION: |
| for (arg = e->value.function.actual; arg; arg = arg->next) |
| flatten_array_ctors_without_strlen (arg->expr); |
| break; |
| |
| case EXPR_ARRAY: |
| |
| /* We've found what we're looking for. */ |
| if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) |
| { |
| gfc_constructor *c; |
| gfc_expr* new_expr; |
| |
| gcc_assert (e->value.constructor); |
| |
| c = gfc_constructor_first (e->value.constructor); |
| new_expr = c->expr; |
| c->expr = NULL; |
| |
| flatten_array_ctors_without_strlen (new_expr); |
| gfc_replace_expr (e, new_expr); |
| break; |
| } |
| |
| /* Otherwise, fall through to handle constructor elements. */ |
| gcc_fallthrough (); |
| case EXPR_STRUCTURE: |
| for (c = gfc_constructor_first (e->value.constructor); |
| c; c = gfc_constructor_next (c)) |
| flatten_array_ctors_without_strlen (c->expr); |
| break; |
| |
| default: |
| break; |
| |
| } |
| } |
| |
| |
| /* Generate code to initialize a string length variable. Returns the |
| value. For array constructors, cl->length might be NULL and in this case, |
| the first element of the constructor is needed. expr is the original |
| expression so we can access it but can be NULL if this is not needed. */ |
| |
| void |
| gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock) |
| { |
| gfc_se se; |
| |
| gfc_init_se (&se, NULL); |
| |
| if (!cl->length && cl->backend_decl && VAR_P (cl->backend_decl)) |
| return; |
| |
| /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but |
| "flatten" array constructors by taking their first element; all elements |
| should be the same length or a cl->length should be present. */ |
| if (!cl->length) |
| { |
| gfc_expr* expr_flat; |
| if (!expr) |
| return; |
| expr_flat = gfc_copy_expr (expr); |
| flatten_array_ctors_without_strlen (expr_flat); |
| gfc_resolve_expr (expr_flat); |
| |
| gfc_conv_expr (&se, expr_flat); |
| gfc_add_block_to_block (pblock, &se.pre); |
| cl->backend_decl = convert (gfc_charlen_type_node, se.string_length); |
| |
| gfc_free_expr (expr_flat); |
| return; |
| } |
| |
| /* Convert cl->length. */ |
| |
| gcc_assert (cl->length); |
| |
| gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node); |
| se.expr = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, |
| se.expr, build_zero_cst (TREE_TYPE (se.expr))); |
| gfc_add_block_to_block (pblock, &se.pre); |
| |
| if (cl->backend_decl && VAR_P (cl->backend_decl)) |
| gfc_add_modify (pblock, cl->backend_decl, se.expr); |
| else |
| cl->backend_decl = gfc_evaluate_now (se.expr, pblock); |
| } |
| |
| |
| static void |
| gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, |
| const char *name, locus *where) |
| { |
| tree tmp; |
| tree type; |
| tree fault; |
| gfc_se start; |
| gfc_se end; |
| char *msg; |
| mpz_t length; |
| |
| type = gfc_get_character_type (kind, ref->u.ss.length); |
| type = build_pointer_type (type); |
| |
| gfc_init_se (&start, se); |
| gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node); |
| gfc_add_block_to_block (&se->pre, &start.pre); |
| |
| if (integer_onep (start.expr)) |
| gfc_conv_string_parameter (se); |
| else |
| { |
| tmp = start.expr; |
| STRIP_NOPS (tmp); |
| /* Avoid multiple evaluation of substring start. */ |
| if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) |
| start.expr = gfc_evaluate_now (start.expr, &se->pre); |
| |
| /* Change the start of the string. */ |
| if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE |
| || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) |
| && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) |
| tmp = se->expr; |
| else |
| tmp = build_fold_indirect_ref_loc (input_location, |
| se->expr); |
| /* 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); |
| se->expr = gfc_build_addr_expr (type, tmp); |
| } |
| } |
| |
| /* Length = end + 1 - start. */ |
| gfc_init_se (&end, se); |
| if (ref->u.ss.end == NULL) |
| end.expr = se->string_length; |
| else |
| { |
| gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node); |
| gfc_add_block_to_block (&se->pre, &end.pre); |
| } |
| tmp = end.expr; |
| STRIP_NOPS (tmp); |
| if (!CONSTANT_CLASS_P (tmp) && !DECL_P (tmp)) |
| end.expr = gfc_evaluate_now (end.expr, &se->pre); |
| |
| if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) |
| && (ref->u.ss.start->symtree |
| && !ref->u.ss.start->symtree->n.sym->attr.implied_index)) |
| { |
| tree nonempty = fold_build2_loc (input_location, LE_EXPR, |
| logical_type_node, start.expr, |
| end.expr); |
| |
| /* Check lower bound. */ |
| fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, |
| start.expr, |
| build_one_cst (TREE_TYPE (start.expr))); |
| fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, |
| logical_type_node, nonempty, fault); |
| if (name) |
| msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' " |
| "is less than one", name); |
| else |
| msg = xasprintf ("Substring out of bounds: lower bound (%%ld) " |
| "is less than one"); |
| gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, |
| fold_convert (long_integer_type_node, |
| start.expr)); |
| free (msg); |
| |
| /* Check upper bound. */ |
| fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, |
| end.expr, se->string_length); |
| fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, |
| logical_type_node, nonempty, fault); |
| if (name) |
| msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' " |
| "exceeds string length (%%ld)", name); |
| else |
| msg = xasprintf ("Substring out of bounds: upper bound (%%ld) " |
| "exceeds string length (%%ld)"); |
| gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, |
| fold_convert (long_integer_type_node, end.expr), |
| fold_convert (long_integer_type_node, |
| se->string_length)); |
| free (msg); |
| } |
| |
| /* Try to calculate the length from the start and end expressions. */ |
| if (ref->u.ss.end |
| && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length)) |
| { |
| HOST_WIDE_INT i_len; |
| |
| i_len = gfc_mpz_get_hwi (length) + 1; |
| if (i_len < 0) |
| i_len = 0; |
| |
| tmp = build_int_cst (gfc_charlen_type_node, i_len); |
| mpz_clear (length); /* Was initialized by gfc_dep_difference. */ |
| } |
| else |
| { |
| tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, |
| fold_convert (gfc_charlen_type_node, end.expr), |
| fold_convert (gfc_charlen_type_node, start.expr)); |
| tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_charlen_type_node, |
| build_int_cst (gfc_charlen_type_node, 1), tmp); |
| tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_charlen_type_node, |
| tmp, build_int_cst (gfc_charlen_type_node, 0)); |
| } |
| |
| se->string_length = tmp; |
| } |
| |
| |
| /* Convert a derived type component reference. */ |
| |
| void |
| gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) |
| { |
| gfc_component *c; |
| tree tmp; |
| tree decl; |
| tree field; |
| tree context; |
| |
| c = ref->u.c.component; |
| |
| if (c->backend_decl == NULL_TREE |
| && ref->u.c.sym != NULL) |
| gfc_get_derived_type (ref->u.c.sym); |
| |
| field = c->backend_decl; |
| gcc_assert (field && TREE_CODE (field) == FIELD_DECL); |
| decl = se->expr; |
| context = DECL_FIELD_CONTEXT (field); |
| |
| /* Components can correspond to fields of different containing |
| types, as components are created without context, whereas |
| a concrete use of a component has the type of decl as context. |
| So, if the type doesn't match, we search the corresponding |
| FIELD_DECL in the parent type. To not waste too much time |
| we cache this result in norestrict_decl. |
| On the other hand, if the context is a UNION or a MAP (a |
| RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */ |
| |
| if (context != TREE_TYPE (decl) |
| && !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */ |
| || TREE_CODE (context) == UNION_TYPE)) /* Field is map */ |
| { |
| tree f2 = c->norestrict_decl; |
| if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl)) |
| for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2)) |
| if (TREE_CODE (f2) == FIELD_DECL |
| && DECL_NAME (f2) == DECL_NAME (field)) |
| break; |
| gcc_assert (f2); |
| c->norestrict_decl = f2; |
| field = f2; |
| } |
| |
| if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS |
| && strcmp ("_data", c->name) == 0) |
| { |
| /* Found a ref to the _data component. Store the associated ref to |
| the vptr in se->class_vptr. */ |
| se->class_vptr = gfc_class_vptr_get (decl); |
| } |
| else |
| se->class_vptr = NULL_TREE; |
| |
| tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), |
| decl, field, NULL_TREE); |
| |
| se->expr = tmp; |
| |
| /* Allocatable deferred char arrays are to be handled by the gfc_deferred_ |
| strlen () conditional below. */ |
| if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer |
| && !c->ts.deferred |
| && !c->attr.pdt_string) |
| { |
| tmp = c->ts.u.cl->backend_decl; |
| /* Components must always be constant length. */ |
| gcc_assert (tmp && INTEGER_CST_P (tmp)); |
| se->string_length = tmp; |
| } |
| |
| if (gfc_deferred_strlen (c, &field)) |
| { |
| tmp = fold_build3_loc (input_location, COMPONENT_REF, |
| TREE_TYPE (field), |
| decl, field, NULL_TREE); |
| se->string_length = tmp; |
| } |
| |
| if (((c->attr.pointer || c->attr.allocatable) |
| && (!c->attr.dimension && !c->attr.codimension) |
| && c->ts.type != BT_CHARACTER) |
| || c->attr.proc_pointer) |
| se->expr = build_fold_indirect_ref_loc (input_location, |
| se->expr); |
| } |
| |
| |
| /* This function deals with component references to components of the |
| parent type for derived type extensions. */ |
| void |
| conv_parent_component_references (gfc_se * se, gfc_ref * ref) |
| { |
| gfc_component *c; |
| gfc_component *cmp; |
| gfc_symbol *dt; |
| gfc_ref parent; |
| |
| dt = ref->u.c.sym; |
| c = ref->u.c.component; |
| |
| /* Return if the component is in the parent type. */ |
| for (cmp = dt->components; cmp; cmp = cmp->next) |
| if (strcmp (c->name, cmp->name) == 0) |
| return; |
| |
| /* Build a gfc_ref to recursively call gfc_conv_component_ref. */ |
| parent.type = REF_COMPONENT; |
| parent.next = NULL; |
| parent.u.c.sym = dt; |
| parent.u.c.component = dt->components; |
| |
| if (dt->backend_decl == NULL) |
| gfc_get_derived_type (dt); |
| |
| /* Build the reference and call self. */ |
| gfc_conv_component_ref (se, &parent); |
| parent.u.c.sym = dt->components->ts.u.derived; |
| parent.u.c.component = c; |
| conv_parent_component_references (se, &parent); |
| } |
| |
| |
| static void |
| conv_inquiry (gfc_se * se, gfc_ref * ref, gfc_expr *expr, gfc_typespec *ts) |
| { |
| tree res = se->expr; |
| |
| switch (ref->u.i) |
| { |
| case INQUIRY_RE: |
| res = fold_build1_loc (input_location, REALPART_EXPR, |
| TREE_TYPE (TREE_TYPE (res)), res); |
| break; |
| |
| case INQUIRY_IM: |
| res = fold_build1_loc (input_location, IMAGPART_EXPR, |
| TREE_TYPE (TREE_TYPE (res)), res); |
| break; |
| |
| case INQUIRY_KIND: |
| res = build_int_cst (gfc_typenode_for_spec (&expr->ts), |
| ts->kind); |
| break; |
| |
| case INQUIRY_LEN: |
| res = fold_convert (gfc_typenode_for_spec (&expr->ts), |
| se->string_length); |
| break; |
| |
| default: |
| gcc_unreachable (); |
| } |
| se->expr = res; |
| } |
| |
| /* Dereference VAR where needed if it is a pointer, reference, etc. |
| according to Fortran semantics. */ |
| |
| tree |
| gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p, |
| bool is_classarray) |
| { |
| /* Characters are entirely different from other types, they are treated |
| separately. */ |
| if (sym->ts.type == BT_CHARACTER) |
| { |
| /* Dereference character pointer dummy arguments |
| or results. */ |
| if ((sym->attr.pointer || sym->attr.allocatable |
| || (sym->as && sym->as->type == AS_ASSUMED_RANK)) |
| && (sym->attr.dummy |
| || sym->attr.function |
| || sym->attr.result)) |
| var = build_fold_indirect_ref_loc (input_location, var); |
| } |
| else if (!sym->attr.value) |
| { |
| /* Dereference temporaries for class array dummy arguments. */ |
| if (sym->attr.dummy && is_classarray |
| && GFC_ARRAY_TYPE_P (TREE_TYPE (var))) |
| { |
| if (!descriptor_only_p) |
| var = GFC_DECL_SAVED_DESCRIPTOR (var); |
| |
| var = build_fold_indirect_ref_loc (input_location, var); |
| } |
| |
| /* Dereference non-character scalar dummy arguments. */ |
| if (sym->attr.dummy && !sym->attr.dimension |
| && !(sym->attr.codimension && sym->attr.allocatable) |
| && (sym->ts.type != BT_CLASS |
| || (!CLASS_DATA (sym)->attr.dimension |
| && !(CLASS_DATA (sym)->attr.codimension |
| && CLASS_DATA (sym)->attr.allocatable)))) |
| var = build_fold_indirect_ref_loc (input_location, var); |
| |
| /* Dereference scalar hidden result. */ |
| if (flag_f2c && sym->ts.type == BT_COMPLEX |
| && (sym->attr.function || sym->attr.result) |
| && !sym->attr.dimension && !sym->attr.pointer |
| && !sym->attr.always_explicit) |
| var = build_fold_indirect_ref_loc (input_location, var); |
| |
| /* Dereference non-character, non-class pointer variables. |
| These must be dummies, results, or scalars. */ |
| if (!is_classarray |
| && (sym->attr.pointer || sym->attr.allocatable |
| || gfc_is_associate_pointer (sym) |
| || (sym->as && sym->as->type == AS_ASSUMED_RANK)) |
| && (sym->attr.dummy |
| || sym->attr.function |
| || sym->attr.result |
| || (!sym->attr.dimension |
| && (!sym->attr.codimension || !sym->attr.allocatable)))) |
| var = build_fold_indirect_ref_loc (input_location, var); |
| /* Now treat the class array pointer variables accordingly. */ |
| else if (sym->ts.type == BT_CLASS |
| && sym->attr.dummy |
| && (CLASS_DATA (sym)->attr.dimension |
| || CLASS_DATA (sym)->attr.codimension) |
| && ((CLASS_DATA (sym)->as |
| && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) |
| || CLASS_DATA (sym)->attr.allocatable |
| || CLASS_DATA (sym)->attr.class_pointer)) |
| var = build_fold_indirect_ref_loc (input_location, var); |
| /* And the case where a non-dummy, non-result, non-function, |
| non-allotable and non-pointer classarray is present. This case was |
| previously covered by the first if, but with introducing the |
| condition !is_classarray there, that case has to be covered |
| explicitly. */ |
| else if (sym->ts.type == BT_CLASS |
| && !sym->attr.dummy |
| && !sym->attr.function |
| && !sym->attr.result |
| && (CLASS_DATA (sym)->attr.dimension |
| || CLASS_DATA (sym)->attr.codimension) |
| && (sym->assoc |
| || !CLASS_DATA (sym)->attr.allocatable) |
| && !CLASS_DATA (sym)->attr.class_pointer) |
| var = build_fold_indirect_ref_loc (input_location, var); |
| } |
| |
| return var; |
| } |
| |
| /* Return the contents of a variable. Also handles reference/pointer |
| variables (all Fortran pointer references are implicit). */ |
| |
| static void |
| gfc_conv_variable (gfc_se * se, gfc_expr * expr) |
| { |
| gfc_ss *ss; |
| gfc_ref *ref; |
| gfc_symbol *sym; |
| tree parent_decl = NULL_TREE; |
| int parent_flag; |
| bool return_value; |
| bool alternate_entry; |
| bool entry_master; |
| bool is_classarray; |
| bool first_time = true; |
| |
| sym = expr->symtree->n.sym; |
| is_classarray = IS_CLASS_ARRAY (sym); |
| ss = se->ss; |
| if (ss != NULL) |
| { |
| gfc_ss_info *ss_info = ss->info; |
| |
| /* Check that something hasn't gone horribly wrong. */ |
| gcc_assert (ss != gfc_ss_terminator); |
| gcc_assert (ss_info->expr == expr); |
| |
| /* A scalarized term. We already know the descriptor. */ |
| se->expr = ss_info->data.array.descriptor; |
| se->string_length = ss_info->string_length; |
| ref = ss_info->data.array.ref; |
| if (ref) |
| gcc_assert (ref->type == REF_ARRAY |
| && ref->u.ar.type != AR_ELEMENT); |
| else |
| gfc_conv_tmp_array_ref (se); |
| } |
| else |
| { |
| tree se_expr = NULL_TREE; |
| |
| se->expr = gfc_get_symbol_decl (sym); |
| |
| /* Deal with references to a parent results or entries by storing |
| the current_function_decl and moving to the parent_decl. */ |
| return_value = sym->attr.function && sym->result == sym; |
| alternate_entry = sym->attr.function && sym->attr.entry |
| && sym->result == sym; |
| entry_master = sym->attr.result |
| && sym->ns->proc_name->attr.entry_master |
| && !gfc_return_by_reference (sym->ns->proc_name); |
| if (current_function_decl) |
| parent_decl = DECL_CONTEXT (current_function_decl); |
| |
| if ((se->expr == parent_decl && return_value) |
| || (sym->ns && sym->ns->proc_name |
| && parent_decl |
| && sym->ns->proc_name->backend_decl == parent_decl |
| && (alternate_entry || entry_master))) |
| parent_flag = 1; |
| else |
| parent_flag = 0; |
| |
| /* Special case for assigning the return value of a function. |
| Self recursive functions must have an explicit return value. */ |
| if (return_value && (se->expr == current_function_decl || parent_flag)) |
| se_expr = gfc_get_fake_result_decl (sym, parent_flag); |
| |
| /* Similarly for alternate entry points. */ |
| else if (alternate_entry |
| && (sym->ns->proc_name->backend_decl == current_function_decl |
| || parent_flag)) |
| { |
| gfc_entry_list *el = NULL; |
| |
| for (el = sym->ns->entries; el; el = el->next) |
| if (sym == el->sym) |
| { |
| se_expr = gfc_get_fake_result_decl (sym, parent_flag); |
|
|