of refs following. */
gfc_expr *
-gfc_find_and_cut_at_last_class_ref (gfc_expr *e)
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
{
gfc_expr *base_expr;
gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
e->ref = NULL;
}
- base_expr = gfc_copy_expr (e);
+ 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)
}
-/* Obtain the vptr of the last class reference in an expression.
+/* Obtain the last class reference in an expression.
Return NULL_TREE if no class reference is found. */
tree
-gfc_get_vptr_from_expr (tree expr)
+gfc_get_class_from_expr (tree expr)
{
tree tmp;
tree type;
while (type)
{
if (GFC_CLASS_TYPE_P (type))
- return gfc_class_vptr_get (tmp);
+ return tmp;
if (type != TYPE_CANONICAL (type))
type = TYPE_CANONICAL (type);
else
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;
}
else
{
- gfc_error ("Can't compute the length of the char array at %L.",
- &e->where);
+ gfc_error ("Cannot compute the length of the char array "
+ "at %L.", &e->where);
}
}
}
{
gfc_ref *r;
tree length;
+ gfc_se se;
gcc_assert (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_CHARACTER);
/* 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:
- /* We should never got substring references here. These will be
- broken down by the scalarizer. */
gcc_unreachable ();
break;
}
start.expr = gfc_evaluate_now (start.expr, &se->pre);
/* Change the start of the string. */
- if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+ 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,
case EXPR_COMPCALL:
case EXPR_PPC:
+ case EXPR_UNKNOWN:
gcc_unreachable ();
break;
}
an actual argument derived type array is copied and then returned
after the function call. */
void
-gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
- sym_intent intent, bool formal_ptr)
+gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
+ sym_intent intent, bool formal_ptr,
+ const gfc_symbol *fsym, const char *proc_name,
+ gfc_symbol *sym, bool check_contiguous)
{
gfc_se lse;
gfc_se rse;
stmtblock_t body;
int n;
int dimen;
+ gfc_se work_se;
+ gfc_se *parmse;
+ bool pass_optional;
+
+ pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
+
+ if (pass_optional || check_contiguous)
+ {
+ gfc_init_se (&work_se, NULL);
+ parmse = &work_se;
+ }
+ else
+ parmse = se;
+
+ if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
+ {
+ /* We will create a temporary array, so let us warn. */
+ char * msg;
+
+ if (fsym && proc_name)
+ msg = xasprintf ("An array temporary was created for argument "
+ "'%s' of procedure '%s'", fsym->name, proc_name);
+ else
+ msg = xasprintf ("An array temporary was created");
+
+ tmp = build_int_cst (logical_type_node, 1);
+ gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
+ &expr->where, msg);
+ free (msg);
+ }
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
else
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ /* Basically make this into
+
+ if (present)
+ {
+ if (contiguous)
+ {
+ pointer = a;
+ }
+ else
+ {
+ parmse->pre();
+ pointer = parmse->expr;
+ }
+ }
+ else
+ pointer = NULL;
+
+ foo (pointer);
+ if (present && !contiguous)
+ se->post();
+
+ */
+
+ if (pass_optional || check_contiguous)
+ {
+ tree type;
+ stmtblock_t else_block;
+ tree pre_stmts, post_stmts;
+ tree pointer;
+ tree else_stmt;
+ tree present_var = NULL_TREE;
+ tree cont_var = NULL_TREE;
+ tree post_cond;
+
+ type = TREE_TYPE (parmse->expr);
+ pointer = gfc_create_var (type, "arg_ptr");
+
+ if (check_contiguous)
+ {
+ gfc_se cont_se, array_se;
+ stmtblock_t if_block, else_block;
+ tree if_stmt, else_stmt;
+ mpz_t size;
+ bool size_set;
+
+ cont_var = gfc_create_var (boolean_type_node, "contiguous");
+
+ /* If the size is known to be one at compile-time, set
+ cont_var to true unconditionally. This may look
+ inelegant, but we're only doing this during
+ optimization, so the statements will be optimized away,
+ and this saves complexity here. */
+
+ size_set = gfc_array_size (expr, &size);
+ if (size_set && mpz_cmp_ui (size, 1) == 0)
+ {
+ gfc_add_modify (&se->pre, cont_var,
+ build_one_cst (boolean_type_node));
+ }
+ else
+ {
+ /* cont_var = is_contiguous (expr); . */
+ gfc_init_se (&cont_se, parmse);
+ gfc_conv_is_contiguous_expr (&cont_se, expr);
+ gfc_add_block_to_block (&se->pre, &(&cont_se)->pre);
+ gfc_add_modify (&se->pre, cont_var, cont_se.expr);
+ gfc_add_block_to_block (&se->pre, &(&cont_se)->post);
+ }
+
+ if (size_set)
+ mpz_clear (size);
+
+ /* arrayse->expr = descriptor of a. */
+ gfc_init_se (&array_se, se);
+ gfc_conv_expr_descriptor (&array_se, expr);
+ gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
+ gfc_add_block_to_block (&se->pre, &(&array_se)->post);
+
+ /* if_stmt = { pointer = &a[0]; } . */
+ gfc_init_block (&if_block);
+ tmp = gfc_conv_array_data (array_se.expr);
+ tmp = fold_convert (type, tmp);
+ gfc_add_modify (&if_block, pointer, tmp);
+ if_stmt = gfc_finish_block (&if_block);
+
+ /* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
+ gfc_init_block (&else_block);
+ gfc_add_block_to_block (&else_block, &parmse->pre);
+ gfc_add_modify (&else_block, pointer, parmse->expr);
+ else_stmt = gfc_finish_block (&else_block);
+
+ /* And put the above into an if statement. */
+ pre_stmts = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_likely (cont_var,
+ PRED_FORTRAN_CONTIGUOUS),
+ if_stmt, else_stmt);
+ }
+ else
+ {
+ /* pointer = pramse->expr; . */
+ gfc_add_modify (&parmse->pre, pointer, parmse->expr);
+ pre_stmts = gfc_finish_block (&parmse->pre);
+ }
+
+ if (pass_optional)
+ {
+ present_var = gfc_create_var (boolean_type_node, "present");
+
+ /* present_var = present(sym); . */
+ tmp = gfc_conv_expr_present (sym);
+ tmp = fold_convert (boolean_type_node, tmp);
+ gfc_add_modify (&se->pre, present_var, tmp);
+
+ /* else_stmt = { pointer = NULL; } . */
+ gfc_init_block (&else_block);
+ gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
+ else_stmt = gfc_finish_block (&else_block);
+
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_likely (present_var,
+ PRED_FORTRAN_ABSENT_DUMMY),
+ pre_stmts, else_stmt);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ }
+ else
+ gfc_add_expr_to_block (&se->pre, pre_stmts);
+
+ post_stmts = gfc_finish_block (&parmse->post);
+
+ /* Put together the post stuff, plus the optional
+ deallocation. */
+ if (check_contiguous)
+ {
+ /* !cont_var. */
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ cont_var,
+ build_zero_cst (boolean_type_node));
+ tmp = gfc_unlikely (tmp, PRED_FORTRAN_CONTIGUOUS);
+
+ if (pass_optional)
+ {
+ tree present_likely = gfc_likely (present_var,
+ PRED_FORTRAN_ABSENT_DUMMY);
+ post_cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, present_likely,
+ tmp);
+ }
+ else
+ post_cond = tmp;
+ }
+ else
+ {
+ gcc_assert (pass_optional);
+ post_cond = present_var;
+ }
+
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
+ post_stmts, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+ se->expr = pointer;
+ }
+
return;
}
}
+/* A helper function to set the dtype for unallocated or unassociated
+ entities. */
+
+static void
+set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
+{
+ tree tmp;
+ tree desc;
+ tree cond;
+ tree type;
+ stmtblock_t block;
+
+ /* TODO Figure out how to handle optional dummies. */
+ if (e && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ return;
+
+ desc = parmse->expr;
+ if (desc == NULL_TREE)
+ return;
+
+ if (POINTER_TYPE_P (TREE_TYPE (desc)))
+ desc = build_fold_indirect_ref_loc (input_location, desc);
+
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+ return;
+
+ gfc_init_block (&block);
+ tmp = gfc_conv_descriptor_data_get (desc);
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ logical_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ tmp = gfc_conv_descriptor_dtype (desc);
+ type = gfc_get_element_type (TREE_TYPE (desc));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (tmp), tmp,
+ gfc_get_dtype_rank_type (e->rank, type));
+ gfc_add_expr_to_block (&block, tmp);
+ cond = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse->pre, cond);
+}
+
+
+
/* Provide an interface between gfortran array descriptors and the F2018:18.4
ISO_Fortran_binding array descriptors. */
tree tmp;
tree cfi_desc_ptr;
tree gfc_desc_ptr;
- tree ptr = NULL_TREE;
- tree size;
tree type;
+ tree cond;
+ tree desc_attr;
int attribute;
+ int cfi_attribute;
symbol_attribute attr = gfc_expr_attr (e);
/* If this is a full array or a scalar, the allocatable and pointer
attribute = 1;
}
+ /* If the formal argument is assumed shape and neither a pointer nor
+ allocatable, it is unconditionally CFI_attribute_other. */
+ if (fsym->as->type == AS_ASSUMED_SHAPE
+ && !fsym->attr.pointer && !fsym->attr.allocatable)
+ cfi_attribute = 2;
+ else
+ cfi_attribute = attribute;
+
if (e->rank != 0)
{
+ parmse->force_no_tmp = 1;
if (fsym->attr.contiguous
&& !gfc_is_simply_contiguous (e, false, true))
gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
parmse->expr = build_fold_indirect_ref_loc (input_location,
parmse->expr);
+ bool is_artificial = (INDIRECT_REF_P (parmse->expr)
+ ? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
+ : DECL_ARTIFICIAL (parmse->expr));
+
+ /* Unallocated allocatable arrays and unassociated pointer arrays
+ need their dtype setting if they are argument associated with
+ assumed rank dummies. */
+ if (fsym && fsym->as
+ && (gfc_expr_attr (e).pointer
+ || gfc_expr_attr (e).allocatable))
+ set_dtype_for_unallocated (parmse, e);
/* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
the expression type is different from the descriptor type, then
type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
NULL_TREE;
- if (type && DECL_ARTIFICIAL (parmse->expr)
+ if (type && is_artificial
&& type != gfc_get_element_type (TREE_TYPE (parmse->expr)))
{
/* Obtain the offset to the data. */
gfc_get_dtype_rank_type (e->rank, type));
}
else if (type == NULL_TREE
- || (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)))
+ || (!is_subref_array (e) && !is_artificial))
{
/* Make sure that the span is set for expressions where it
might not have been done already. */
tmp = fold_convert (gfc_array_index_type, tmp);
gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
}
-
- /* INTENT(IN) requires a temporary for the data. Assumed types do not
- work with the standard temporary generation schemes. */
- if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
- {
- /* Fix the descriptor and determine the size of the data. */
- parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
- size = build_call_expr_loc (input_location,
- gfor_fndecl_size0, 1,
- gfc_build_addr_expr (NULL, parmse->expr));
- size = fold_convert (size_type_node, size);
- tmp = gfc_conv_descriptor_span_get (parmse->expr);
- tmp = fold_convert (size_type_node, tmp);
- size = fold_build2_loc (input_location, MULT_EXPR,
- size_type_node, size, tmp);
- /* Fix the size and allocate. */
- size = gfc_evaluate_now (size, &parmse->pre);
- tmp = builtin_decl_explicit (BUILT_IN_MALLOC);
- ptr = build_call_expr_loc (input_location, tmp, 1, size);
- ptr = gfc_evaluate_now (ptr, &parmse->pre);
- /* Copy the data to the temporary descriptor. */
- tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
- tmp = build_call_expr_loc (input_location, tmp, 3, ptr,
- gfc_conv_descriptor_data_get (parmse->expr),
- size);
- gfc_add_expr_to_block (&parmse->pre, tmp);
-
- /* The temporary 'ptr' is freed below. */
- gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
- }
-
}
else
{
parmse->expr = build_fold_indirect_ref_loc (input_location,
parmse->expr);
- /* Copy the scalar for INTENT(IN). */
- if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
- {
- if (e->ts.type != BT_CHARACTER)
- parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
- else
- {
- /* The temporary string 'ptr' is freed below. */
- tmp = build_pointer_type (TREE_TYPE (parmse->expr));
- ptr = gfc_create_var (tmp, "str");
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MALLOC),
- 1, parmse->string_length);
- tmp = fold_convert (TREE_TYPE (ptr), tmp);
- gfc_add_modify (&parmse->pre, ptr, tmp);
- tmp = gfc_build_memcpy_call (ptr, parmse->expr,
- parmse->string_length);
- gfc_add_expr_to_block (&parmse->pre, tmp);
- parmse->expr = ptr;
- }
- }
-
parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
parmse->expr, attr);
}
- /* Set the CFI attribute field. */
- tmp = gfc_conv_descriptor_attribute (parmse->expr);
+ /* Set the CFI attribute field through a temporary value for the
+ gfc attribute. */
+ desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp), attribute));
+ void_type_node, desc_attr,
+ build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
gfc_add_expr_to_block (&parmse->pre, tmp);
/* Now pass the gfc_descriptor by reference. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
- /* Variables to point to the gfc and CFI descriptors. */
+ /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
+ that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
gfc_desc_ptr = parmse->expr;
cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
+ gfc_add_modify (&parmse->pre, cfi_desc_ptr, null_pointer_node);
- /* Allocate the CFI descriptor and fill the fields. */
+ /* Allocate the CFI descriptor itself and fill the fields. */
tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
gfc_add_expr_to_block (&parmse->pre, tmp);
+ /* Now set the gfc descriptor attribute. */
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ void_type_node, desc_attr,
+ build_int_cst (TREE_TYPE (desc_attr), attribute));
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+
/* The CFI descriptor is passed to the bind_C procedure. */
parmse->expr = cfi_desc_ptr;
- if (ptr)
- {
- /* Free both the temporary data and the CFI descriptor for
- INTENT(IN) arrays. */
- tmp = gfc_call_free (ptr);
- gfc_prepend_expr_to_block (&parmse->post, tmp);
- tmp = gfc_call_free (cfi_desc_ptr);
- gfc_prepend_expr_to_block (&parmse->post, tmp);
- return;
- }
+ /* Free the CFI descriptor. */
+ tmp = gfc_call_free (cfi_desc_ptr);
+ gfc_prepend_expr_to_block (&parmse->post, tmp);
- /* Transfer values back to gfc descriptor and free the CFI descriptor. */
+ /* Transfer values back to gfc descriptor. */
tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr);
tmp = build_call_expr_loc (input_location,
gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
gfc_prepend_expr_to_block (&parmse->post, tmp);
+
+ /* Deal with an optional dummy being passed to an optional formal arg
+ by finishing the pre and post blocks and making their execution
+ conditional on the dummy being present. */
+ if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ {
+ cond = gfc_conv_expr_present (e->symtree->n.sym);
+ tmp = fold_build2 (MODIFY_EXPR, void_type_node,
+ cfi_desc_ptr,
+ build_int_cst (pvoid_type_node, 0));
+ tmp = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&parmse->pre), tmp);
+ gfc_add_expr_to_block (&parmse->pre, tmp);
+ tmp = build3_v (COND_EXPR, cond,
+ gfc_finish_block (&parmse->post),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse->post, tmp);
+ }
}
}
else if (sym->attr.is_bind_c && e
- && ((fsym && fsym->attr.dimension
- && (fsym->attr.pointer
- || fsym->attr.allocatable
- || fsym->as->type == AS_ASSUMED_RANK
- || fsym->as->type == AS_ASSUMED_SHAPE))
+ && (is_CFI_desc (fsym, NULL)
|| non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
}
if (sym->attr.is_bind_c && e
- && fsym && fsym->attr.dimension
- && (fsym->attr.pointer
- || fsym->attr.allocatable
- || fsym->as->type == AS_ASSUMED_RANK
- || fsym->as->type == AS_ASSUMED_SHAPE
- || non_unity_length_string))
+ && (is_CFI_desc (fsym, NULL) || non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
sym->name, NULL);
+ /* Unallocated allocatable arrays and unassociated pointer arrays
+ need their dtype setting if they are argument associated with
+ assumed rank dummies. */
+ if (!sym->attr.is_bind_c && e && fsym && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)
+ {
+ if (gfc_expr_attr (e).pointer
+ || gfc_expr_attr (e).allocatable)
+ set_dtype_for_unallocated (&parmse, e);
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.dummy
+ && e->symtree->n.sym->as
+ && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+ {
+ tree minus_one;
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
+ minus_one = build_int_cst (gfc_array_index_type, -1);
+ gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+ gfc_rank_cst[e->rank - 1],
+ minus_one);
+ }
+ }
+
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
gfc_add_expr_to_block (&se->pre, tmp);
}
- tmp = build_fold_indirect_ref_loc (input_location,
- parmse.expr);
+ tmp = parmse.expr;
+ /* With bind(C), the actual argument is replaced by a bind-C
+ descriptor; in this case, the data component arrives here,
+ which shall not be dereferenced, but still freed and
+ nullified. */
+ if (TREE_TYPE(tmp) != pvoid_type_node)
+ tmp = build_fold_indirect_ref_loc (input_location,
+ parmse.expr);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_conv_descriptor_data_get (tmp);
tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE,
gfc_allocate_lang_decl (result);
GFC_DECL_SAVED_DESCRIPTOR (result) = parmse.expr;
gfc_free_expr (class_expr);
- gcc_assert (parmse.pre.head == NULL_TREE
- && parmse.post.head == NULL_TREE);
+ /* -fcheck= can add diagnostic code, which has to be placed before
+ the call. */
+ if (parmse.pre.head != NULL)
+ gfc_add_expr_to_block (&se->pre, parmse.pre.head);
+ gcc_assert (parmse.post.head == NULL_TREE);
}
/* Follow the function call with the argument post block. */
from_len = rse->string_length;
else if (re->ts.type == BT_CHARACTER && re->ts.u.cl->length)
{
- from_len = gfc_get_expr_charlen (re);
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, re->ts.u.cl->length);
gfc_add_block_to_block (block, &se.pre);
}
}
-/* Indentify class valued proc_pointer assignments. */
-
-static bool
-pointer_assignment_is_proc_pointer (gfc_expr * expr1, gfc_expr * expr2)
-{
- gfc_ref * ref;
-
- ref = expr1->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- return ref && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE;
-}
-
/* Do everything that is needed for a CLASS function expr2. */
tree desc;
tree tmp;
tree expr1_vptr = NULL_TREE;
- bool scalar, non_proc_pointer_assign;
+ bool scalar, non_proc_ptr_assign;
gfc_ss *ss;
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
- non_proc_pointer_assign = !pointer_assignment_is_proc_pointer (expr1, expr2);
+ non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
+ && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
gfc_free_ss_chain (ss);
if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS
- && expr2->expr_type != EXPR_FUNCTION && non_proc_pointer_assign)
+ && expr2->expr_type != EXPR_FUNCTION && non_proc_ptr_assign)
{
gfc_add_data_component (expr2);
/* The following is required as gfc_add_data_component doesn't
else
gfc_conv_expr (&rse, expr2);
- if (non_proc_pointer_assign && expr1->ts.type == BT_CLASS)
+ if (non_proc_ptr_assign && expr1->ts.type == BT_CLASS)
{
trans_class_vptr_len_assignment (&block, expr1, expr2, &rse, NULL,
NULL);
}
}
- /* Check string lengths if applicable. The check is only really added
- to the output code if -fbounds-check is enabled. */
- if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
- {
- gcc_assert (expr2->ts.type == BT_CHARACTER);
- gcc_assert (strlen_lhs && strlen_rhs);
- gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
- strlen_lhs, strlen_rhs, &block);
- }
-
/* If rank remapping was done, check with -fcheck=bounds that
the target is at least as large as the pointer. */
if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
gfc_add_modify (&block, tmp, build_zero_cst (TREE_TYPE (tmp)));
}
+ /* Check string lengths if applicable. The check is only really added
+ to the output code if -fbounds-check is enabled. */
+ if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
+ {
+ gcc_assert (expr2->ts.type == BT_CHARACTER);
+ gcc_assert (strlen_lhs && strlen_rhs);
+ gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
+ strlen_lhs, strlen_rhs, &block);
+ }
+
gfc_add_block_to_block (&block, &lse.post);
if (rank_remap)
gfc_add_block_to_block (&block, &rse.post);
return;
}
- if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
+ if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE
+ || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE)
+ && TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
{
if (TREE_CODE (se->expr) != INDIRECT_REF)
{
stype = gfc_typenode_for_spec (&expr2->ts);
src = gfc_build_constant_array_constructor (expr2, stype);
- stype = TREE_TYPE (src);
- if (POINTER_TYPE_P (stype))
- stype = TREE_TYPE (stype);
-
return gfc_build_memcpy_call (dst, src, len);
}
string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
else if (expr2->ts.type == BT_CHARACTER)
{
- if (expr1->ts.deferred && gfc_check_dependency (expr1, expr2, true))
- rse.string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
+ if (expr1->ts.deferred
+ && gfc_expr_attr (expr1).allocatable
+ && gfc_check_dependency (expr1, expr2, true))
+ rse.string_length =
+ gfc_evaluate_now_function_scope (rse.string_length, &rse.pre);
string_length = rse.string_length;
}
else
&& (gfc_is_class_array_function (expr2)
|| gfc_is_alloc_class_scalar_function (expr2)))
{
- tmp = rse.expr;
tmp = gfc_nullify_alloc_comp (expr1->ts.u.derived, rse.expr, 0);
gfc_prepend_expr_to_block (&rse.post, tmp);
if (lss != gfc_ss_terminator && rss == gfc_ss_terminator)
projects / platform / upstream / gcc.git / blobdiff