1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
56 dest->loop = src->loop;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se * se, gfc_se * parent)
69 memset (se, 0, sizeof (gfc_se));
70 gfc_init_block (&se->pre);
71 gfc_init_block (&se->post);
76 gfc_copy_se_loopvars (se, parent);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se * se)
89 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se * se)
113 if (CONSTANT_CLASS_P (se->expr))
116 /* We need a temporary for this result. */
117 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
118 gfc_add_modify (&se->pre, var, se->expr);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol * sym)
131 gcc_assert (sym->attr.dummy);
133 decl = gfc_get_symbol_decl (sym);
134 if (TREE_CODE (decl) != PARM_DECL)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
140 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
142 return fold_build2 (NE_EXPR, boolean_type_node, decl,
143 fold_convert (TREE_TYPE (decl), null_pointer_node));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
155 present = gfc_conv_expr_present (arg->symtree->n.sym);
159 /* Create a temporary and convert it to the correct type. */
160 tmp = gfc_get_int_type (kind);
161 tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
163 /* Test for a NULL value. */
164 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp,
165 fold_convert (TREE_TYPE (tmp), integer_one_node));
166 tmp = gfc_evaluate_now (tmp, &se->pre);
167 se->expr = gfc_build_addr_expr (NULL_TREE, tmp);
171 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
172 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
173 tmp = gfc_evaluate_now (tmp, &se->pre);
177 if (ts.type == BT_CHARACTER)
179 tmp = build_int_cst (gfc_charlen_type_node, 0);
180 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
181 present, se->string_length, tmp);
182 tmp = gfc_evaluate_now (tmp, &se->pre);
183 se->string_length = tmp;
189 /* Get the character length of an expression, looking through gfc_refs
193 gfc_get_expr_charlen (gfc_expr *e)
198 gcc_assert (e->expr_type == EXPR_VARIABLE
199 && e->ts.type == BT_CHARACTER);
201 length = NULL; /* To silence compiler warning. */
203 if (is_subref_array (e) && e->ts.cl->length)
206 gfc_init_se (&tmpse, NULL);
207 gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
208 e->ts.cl->backend_decl = tmpse.expr;
212 /* First candidate: if the variable is of type CHARACTER, the
213 expression's length could be the length of the character
215 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
216 length = e->symtree->n.sym->ts.cl->backend_decl;
218 /* Look through the reference chain for component references. */
219 for (r = e->ref; r; r = r->next)
224 if (r->u.c.component->ts.type == BT_CHARACTER)
225 length = r->u.c.component->ts.cl->backend_decl;
233 /* We should never got substring references here. These will be
234 broken down by the scalarizer. */
240 gcc_assert (length != NULL);
245 /* For each character array constructor subexpression without a ts.cl->length,
246 replace it by its first element (if there aren't any elements, the length
247 should already be set to zero). */
250 flatten_array_ctors_without_strlen (gfc_expr* e)
252 gfc_actual_arglist* arg;
258 switch (e->expr_type)
262 flatten_array_ctors_without_strlen (e->value.op.op1);
263 flatten_array_ctors_without_strlen (e->value.op.op2);
267 /* TODO: Implement as with EXPR_FUNCTION when needed. */
271 for (arg = e->value.function.actual; arg; arg = arg->next)
272 flatten_array_ctors_without_strlen (arg->expr);
277 /* We've found what we're looking for. */
278 if (e->ts.type == BT_CHARACTER && !e->ts.cl->length)
281 gcc_assert (e->value.constructor);
283 new_expr = e->value.constructor->expr;
284 e->value.constructor->expr = NULL;
286 flatten_array_ctors_without_strlen (new_expr);
287 gfc_replace_expr (e, new_expr);
291 /* Otherwise, fall through to handle constructor elements. */
293 for (c = e->value.constructor; c; c = c->next)
294 flatten_array_ctors_without_strlen (c->expr);
304 /* Generate code to initialize a string length variable. Returns the
305 value. For array constructors, cl->length might be NULL and in this case,
306 the first element of the constructor is needed. expr is the original
307 expression so we can access it but can be NULL if this is not needed. */
310 gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
314 gfc_init_se (&se, NULL);
316 /* If cl->length is NULL, use gfc_conv_expr to obtain the string length but
317 "flatten" array constructors by taking their first element; all elements
318 should be the same length or a cl->length should be present. */
324 expr_flat = gfc_copy_expr (expr);
325 flatten_array_ctors_without_strlen (expr_flat);
326 gfc_resolve_expr (expr_flat);
328 gfc_conv_expr (&se, expr_flat);
329 gfc_add_block_to_block (pblock, &se.pre);
330 cl->backend_decl = convert (gfc_charlen_type_node, se.string_length);
332 gfc_free_expr (expr_flat);
336 /* Convert cl->length. */
338 gcc_assert (cl->length);
340 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
341 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
342 build_int_cst (gfc_charlen_type_node, 0));
343 gfc_add_block_to_block (pblock, &se.pre);
345 if (cl->backend_decl)
346 gfc_add_modify (pblock, cl->backend_decl, se.expr);
348 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
353 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
354 const char *name, locus *where)
364 type = gfc_get_character_type (kind, ref->u.ss.length);
365 type = build_pointer_type (type);
368 gfc_init_se (&start, se);
369 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
370 gfc_add_block_to_block (&se->pre, &start.pre);
372 if (integer_onep (start.expr))
373 gfc_conv_string_parameter (se);
376 /* Avoid multiple evaluation of substring start. */
377 if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
378 start.expr = gfc_evaluate_now (start.expr, &se->pre);
380 /* Change the start of the string. */
381 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
384 tmp = build_fold_indirect_ref (se->expr);
385 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
386 se->expr = gfc_build_addr_expr (type, tmp);
389 /* Length = end + 1 - start. */
390 gfc_init_se (&end, se);
391 if (ref->u.ss.end == NULL)
392 end.expr = se->string_length;
395 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
396 gfc_add_block_to_block (&se->pre, &end.pre);
398 if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
399 end.expr = gfc_evaluate_now (end.expr, &se->pre);
401 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
403 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
404 start.expr, end.expr);
406 /* Check lower bound. */
407 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
408 build_int_cst (gfc_charlen_type_node, 1));
409 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
412 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
413 "is less than one", name);
415 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
417 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
418 fold_convert (long_integer_type_node,
422 /* Check upper bound. */
423 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
425 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
428 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
429 "exceeds string length (%%ld)", name);
431 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
432 "exceeds string length (%%ld)");
433 gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
434 fold_convert (long_integer_type_node, end.expr),
435 fold_convert (long_integer_type_node,
440 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
441 build_int_cst (gfc_charlen_type_node, 1),
443 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
444 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
445 build_int_cst (gfc_charlen_type_node, 0));
446 se->string_length = tmp;
450 /* Convert a derived type component reference. */
453 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
460 c = ref->u.c.component;
462 gcc_assert (c->backend_decl);
464 field = c->backend_decl;
465 gcc_assert (TREE_CODE (field) == FIELD_DECL);
467 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
471 if (c->ts.type == BT_CHARACTER)
473 tmp = c->ts.cl->backend_decl;
474 /* Components must always be constant length. */
475 gcc_assert (tmp && INTEGER_CST_P (tmp));
476 se->string_length = tmp;
479 if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
480 se->expr = build_fold_indirect_ref (se->expr);
484 /* This function deals with component references to components of the
485 parent type for derived type extensons. */
487 conv_parent_component_references (gfc_se * se, gfc_ref * ref)
495 c = ref->u.c.component;
497 /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
498 parent.type = REF_COMPONENT;
501 parent.u.c.component = dt->components;
503 if (dt->attr.extension && dt->components)
505 /* Return if the component is not in the parent type. */
506 for (cmp = dt->components->next; cmp; cmp = cmp->next)
507 if (strcmp (c->name, cmp->name) == 0)
510 /* Otherwise build the reference and call self. */
511 gfc_conv_component_ref (se, &parent);
512 parent.u.c.sym = dt->components->ts.derived;
513 parent.u.c.component = c;
514 conv_parent_component_references (se, &parent);
518 /* Return the contents of a variable. Also handles reference/pointer
519 variables (all Fortran pointer references are implicit). */
522 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
529 bool alternate_entry;
532 sym = expr->symtree->n.sym;
535 /* Check that something hasn't gone horribly wrong. */
536 gcc_assert (se->ss != gfc_ss_terminator);
537 gcc_assert (se->ss->expr == expr);
539 /* A scalarized term. We already know the descriptor. */
540 se->expr = se->ss->data.info.descriptor;
541 se->string_length = se->ss->string_length;
542 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
543 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
548 tree se_expr = NULL_TREE;
550 se->expr = gfc_get_symbol_decl (sym);
552 /* Deal with references to a parent results or entries by storing
553 the current_function_decl and moving to the parent_decl. */
554 return_value = sym->attr.function && sym->result == sym;
555 alternate_entry = sym->attr.function && sym->attr.entry
556 && sym->result == sym;
557 entry_master = sym->attr.result
558 && sym->ns->proc_name->attr.entry_master
559 && !gfc_return_by_reference (sym->ns->proc_name);
560 parent_decl = DECL_CONTEXT (current_function_decl);
562 if ((se->expr == parent_decl && return_value)
563 || (sym->ns && sym->ns->proc_name
565 && sym->ns->proc_name->backend_decl == parent_decl
566 && (alternate_entry || entry_master)))
571 /* Special case for assigning the return value of a function.
572 Self recursive functions must have an explicit return value. */
573 if (return_value && (se->expr == current_function_decl || parent_flag))
574 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
576 /* Similarly for alternate entry points. */
577 else if (alternate_entry
578 && (sym->ns->proc_name->backend_decl == current_function_decl
581 gfc_entry_list *el = NULL;
583 for (el = sym->ns->entries; el; el = el->next)
586 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
591 else if (entry_master
592 && (sym->ns->proc_name->backend_decl == current_function_decl
594 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
599 /* Procedure actual arguments. */
600 else if (sym->attr.flavor == FL_PROCEDURE
601 && se->expr != current_function_decl)
603 if (!sym->attr.dummy && !sym->attr.proc_pointer)
605 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
606 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
612 /* Dereference the expression, where needed. Since characters
613 are entirely different from other types, they are treated
615 if (sym->ts.type == BT_CHARACTER)
617 /* Dereference character pointer dummy arguments
619 if ((sym->attr.pointer || sym->attr.allocatable)
621 || sym->attr.function
622 || sym->attr.result))
623 se->expr = build_fold_indirect_ref (se->expr);
626 else if (!sym->attr.value)
628 /* Dereference non-character scalar dummy arguments. */
629 if (sym->attr.dummy && !sym->attr.dimension)
630 se->expr = build_fold_indirect_ref (se->expr);
632 /* Dereference scalar hidden result. */
633 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
634 && (sym->attr.function || sym->attr.result)
635 && !sym->attr.dimension && !sym->attr.pointer
636 && !sym->attr.always_explicit)
637 se->expr = build_fold_indirect_ref (se->expr);
639 /* Dereference non-character pointer variables.
640 These must be dummies, results, or scalars. */
641 if ((sym->attr.pointer || sym->attr.allocatable)
643 || sym->attr.function
645 || !sym->attr.dimension))
646 se->expr = build_fold_indirect_ref (se->expr);
652 /* For character variables, also get the length. */
653 if (sym->ts.type == BT_CHARACTER)
655 /* If the character length of an entry isn't set, get the length from
656 the master function instead. */
657 if (sym->attr.entry && !sym->ts.cl->backend_decl)
658 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
660 se->string_length = sym->ts.cl->backend_decl;
661 gcc_assert (se->string_length);
669 /* Return the descriptor if that's what we want and this is an array
670 section reference. */
671 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
673 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
674 /* Return the descriptor for array pointers and allocations. */
676 && ref->next == NULL && (se->descriptor_only))
679 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
680 /* Return a pointer to an element. */
684 if (ref->u.c.sym->attr.extension)
685 conv_parent_component_references (se, ref);
687 gfc_conv_component_ref (se, ref);
691 gfc_conv_substring (se, ref, expr->ts.kind,
692 expr->symtree->name, &expr->where);
701 /* Pointer assignment, allocation or pass by reference. Arrays are handled
703 if (se->want_pointer)
705 if (expr->ts.type == BT_CHARACTER)
706 gfc_conv_string_parameter (se);
708 se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
713 /* Unary ops are easy... Or they would be if ! was a valid op. */
716 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
721 gcc_assert (expr->ts.type != BT_CHARACTER);
722 /* Initialize the operand. */
723 gfc_init_se (&operand, se);
724 gfc_conv_expr_val (&operand, expr->value.op.op1);
725 gfc_add_block_to_block (&se->pre, &operand.pre);
727 type = gfc_typenode_for_spec (&expr->ts);
729 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
730 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
731 All other unary operators have an equivalent GIMPLE unary operator. */
732 if (code == TRUTH_NOT_EXPR)
733 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
734 build_int_cst (type, 0));
736 se->expr = fold_build1 (code, type, operand.expr);
740 /* Expand power operator to optimal multiplications when a value is raised
741 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
742 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
743 Programming", 3rd Edition, 1998. */
745 /* This code is mostly duplicated from expand_powi in the backend.
746 We establish the "optimal power tree" lookup table with the defined size.
747 The items in the table are the exponents used to calculate the index
748 exponents. Any integer n less than the value can get an "addition chain",
749 with the first node being one. */
750 #define POWI_TABLE_SIZE 256
752 /* The table is from builtins.c. */
753 static const unsigned char powi_table[POWI_TABLE_SIZE] =
755 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
756 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
757 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
758 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
759 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
760 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
761 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
762 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
763 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
764 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
765 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
766 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
767 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
768 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
769 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
770 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
771 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
772 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
773 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
774 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
775 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
776 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
777 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
778 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
779 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
780 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
781 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
782 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
783 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
784 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
785 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
786 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
789 /* If n is larger than lookup table's max index, we use the "window
791 #define POWI_WINDOW_SIZE 3
793 /* Recursive function to expand the power operator. The temporary
794 values are put in tmpvar. The function returns tmpvar[1] ** n. */
796 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
803 if (n < POWI_TABLE_SIZE)
808 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
809 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
813 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
814 op0 = gfc_conv_powi (se, n - digit, tmpvar);
815 op1 = gfc_conv_powi (se, digit, tmpvar);
819 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
823 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
824 tmp = gfc_evaluate_now (tmp, &se->pre);
826 if (n < POWI_TABLE_SIZE)
833 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
834 return 1. Else return 0 and a call to runtime library functions
835 will have to be built. */
837 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
842 tree vartmp[POWI_TABLE_SIZE];
844 unsigned HOST_WIDE_INT n;
847 /* If exponent is too large, we won't expand it anyway, so don't bother
848 with large integer values. */
849 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
852 m = double_int_to_shwi (TREE_INT_CST (rhs));
853 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
854 of the asymmetric range of the integer type. */
855 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
857 type = TREE_TYPE (lhs);
858 sgn = tree_int_cst_sgn (rhs);
860 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
861 || optimize_size) && (m > 2 || m < -1))
867 se->expr = gfc_build_const (type, integer_one_node);
871 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
872 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
874 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
875 lhs, build_int_cst (TREE_TYPE (lhs), -1));
876 cond = fold_build2 (EQ_EXPR, boolean_type_node,
877 lhs, build_int_cst (TREE_TYPE (lhs), 1));
880 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
883 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
884 se->expr = fold_build3 (COND_EXPR, type,
885 tmp, build_int_cst (type, 1),
886 build_int_cst (type, 0));
890 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
891 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
892 build_int_cst (type, 0));
893 se->expr = fold_build3 (COND_EXPR, type,
894 cond, build_int_cst (type, 1), tmp);
898 memset (vartmp, 0, sizeof (vartmp));
902 tmp = gfc_build_const (type, integer_one_node);
903 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
906 se->expr = gfc_conv_powi (se, n, vartmp);
912 /* Power op (**). Constant integer exponent has special handling. */
915 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
917 tree gfc_int4_type_node;
924 gfc_init_se (&lse, se);
925 gfc_conv_expr_val (&lse, expr->value.op.op1);
926 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
927 gfc_add_block_to_block (&se->pre, &lse.pre);
929 gfc_init_se (&rse, se);
930 gfc_conv_expr_val (&rse, expr->value.op.op2);
931 gfc_add_block_to_block (&se->pre, &rse.pre);
933 if (expr->value.op.op2->ts.type == BT_INTEGER
934 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
935 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
938 gfc_int4_type_node = gfc_get_int_type (4);
940 kind = expr->value.op.op1->ts.kind;
941 switch (expr->value.op.op2->ts.type)
944 ikind = expr->value.op.op2->ts.kind;
949 rse.expr = convert (gfc_int4_type_node, rse.expr);
971 if (expr->value.op.op1->ts.type == BT_INTEGER)
972 lse.expr = convert (gfc_int4_type_node, lse.expr);
997 switch (expr->value.op.op1->ts.type)
1000 if (kind == 3) /* Case 16 was not handled properly above. */
1002 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
1006 /* Use builtins for real ** int4. */
1012 fndecl = built_in_decls[BUILT_IN_POWIF];
1016 fndecl = built_in_decls[BUILT_IN_POWI];
1021 fndecl = built_in_decls[BUILT_IN_POWIL];
1029 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
1033 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
1045 fndecl = built_in_decls[BUILT_IN_POWF];
1048 fndecl = built_in_decls[BUILT_IN_POW];
1052 fndecl = built_in_decls[BUILT_IN_POWL];
1063 fndecl = built_in_decls[BUILT_IN_CPOWF];
1066 fndecl = built_in_decls[BUILT_IN_CPOW];
1070 fndecl = built_in_decls[BUILT_IN_CPOWL];
1082 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
1086 /* Generate code to allocate a string temporary. */
1089 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
1094 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
1096 if (gfc_can_put_var_on_stack (len))
1098 /* Create a temporary variable to hold the result. */
1099 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1100 build_int_cst (gfc_charlen_type_node, 1));
1101 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1103 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
1104 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
1106 tmp = build_array_type (TREE_TYPE (type), tmp);
1108 var = gfc_create_var (tmp, "str");
1109 var = gfc_build_addr_expr (type, var);
1113 /* Allocate a temporary to hold the result. */
1114 var = gfc_create_var (type, "pstr");
1115 tmp = gfc_call_malloc (&se->pre, type,
1116 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
1117 fold_convert (TREE_TYPE (len),
1118 TYPE_SIZE (type))));
1119 gfc_add_modify (&se->pre, var, tmp);
1121 /* Free the temporary afterwards. */
1122 tmp = gfc_call_free (convert (pvoid_type_node, var));
1123 gfc_add_expr_to_block (&se->post, tmp);
1130 /* Handle a string concatenation operation. A temporary will be allocated to
1134 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1137 tree len, type, var, tmp, fndecl;
1139 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1140 && expr->value.op.op2->ts.type == BT_CHARACTER);
1141 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1143 gfc_init_se (&lse, se);
1144 gfc_conv_expr (&lse, expr->value.op.op1);
1145 gfc_conv_string_parameter (&lse);
1146 gfc_init_se (&rse, se);
1147 gfc_conv_expr (&rse, expr->value.op.op2);
1148 gfc_conv_string_parameter (&rse);
1150 gfc_add_block_to_block (&se->pre, &lse.pre);
1151 gfc_add_block_to_block (&se->pre, &rse.pre);
1153 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
1154 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1155 if (len == NULL_TREE)
1157 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1158 lse.string_length, rse.string_length);
1161 type = build_pointer_type (type);
1163 var = gfc_conv_string_tmp (se, type, len);
1165 /* Do the actual concatenation. */
1166 if (expr->ts.kind == 1)
1167 fndecl = gfor_fndecl_concat_string;
1168 else if (expr->ts.kind == 4)
1169 fndecl = gfor_fndecl_concat_string_char4;
1173 tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
1174 rse.string_length, rse.expr);
1175 gfc_add_expr_to_block (&se->pre, tmp);
1177 /* Add the cleanup for the operands. */
1178 gfc_add_block_to_block (&se->pre, &rse.post);
1179 gfc_add_block_to_block (&se->pre, &lse.post);
1182 se->string_length = len;
1185 /* Translates an op expression. Common (binary) cases are handled by this
1186 function, others are passed on. Recursion is used in either case.
1187 We use the fact that (op1.ts == op2.ts) (except for the power
1189 Operators need no special handling for scalarized expressions as long as
1190 they call gfc_conv_simple_val to get their operands.
1191 Character strings get special handling. */
1194 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1196 enum tree_code code;
1205 switch (expr->value.op.op)
1207 case INTRINSIC_PARENTHESES:
1208 if (expr->ts.type == BT_REAL
1209 || expr->ts.type == BT_COMPLEX)
1211 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1212 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1217 case INTRINSIC_UPLUS:
1218 gfc_conv_expr (se, expr->value.op.op1);
1221 case INTRINSIC_UMINUS:
1222 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1226 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1229 case INTRINSIC_PLUS:
1233 case INTRINSIC_MINUS:
1237 case INTRINSIC_TIMES:
1241 case INTRINSIC_DIVIDE:
1242 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1243 an integer, we must round towards zero, so we use a
1245 if (expr->ts.type == BT_INTEGER)
1246 code = TRUNC_DIV_EXPR;
1251 case INTRINSIC_POWER:
1252 gfc_conv_power_op (se, expr);
1255 case INTRINSIC_CONCAT:
1256 gfc_conv_concat_op (se, expr);
1260 code = TRUTH_ANDIF_EXPR;
1265 code = TRUTH_ORIF_EXPR;
1269 /* EQV and NEQV only work on logicals, but since we represent them
1270 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1272 case INTRINSIC_EQ_OS:
1280 case INTRINSIC_NE_OS:
1281 case INTRINSIC_NEQV:
1288 case INTRINSIC_GT_OS:
1295 case INTRINSIC_GE_OS:
1302 case INTRINSIC_LT_OS:
1309 case INTRINSIC_LE_OS:
1315 case INTRINSIC_USER:
1316 case INTRINSIC_ASSIGN:
1317 /* These should be converted into function calls by the frontend. */
1321 fatal_error ("Unknown intrinsic op");
1325 /* The only exception to this is **, which is handled separately anyway. */
1326 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1328 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1332 gfc_init_se (&lse, se);
1333 gfc_conv_expr (&lse, expr->value.op.op1);
1334 gfc_add_block_to_block (&se->pre, &lse.pre);
1337 gfc_init_se (&rse, se);
1338 gfc_conv_expr (&rse, expr->value.op.op2);
1339 gfc_add_block_to_block (&se->pre, &rse.pre);
1343 gfc_conv_string_parameter (&lse);
1344 gfc_conv_string_parameter (&rse);
1346 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1347 rse.string_length, rse.expr,
1348 expr->value.op.op1->ts.kind);
1349 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1350 gfc_add_block_to_block (&lse.post, &rse.post);
1353 type = gfc_typenode_for_spec (&expr->ts);
1357 /* The result of logical ops is always boolean_type_node. */
1358 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1359 se->expr = convert (type, tmp);
1362 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1364 /* Add the post blocks. */
1365 gfc_add_block_to_block (&se->post, &rse.post);
1366 gfc_add_block_to_block (&se->post, &lse.post);
1369 /* If a string's length is one, we convert it to a single character. */
1372 string_to_single_character (tree len, tree str, int kind)
1374 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1376 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1377 && TREE_INT_CST_HIGH (len) == 0)
1379 str = fold_convert (gfc_get_pchar_type (kind), str);
1380 return build_fold_indirect_ref (str);
1388 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1391 if (sym->backend_decl)
1393 /* This becomes the nominal_type in
1394 function.c:assign_parm_find_data_types. */
1395 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1396 /* This becomes the passed_type in
1397 function.c:assign_parm_find_data_types. C promotes char to
1398 integer for argument passing. */
1399 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1401 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1406 /* If we have a constant character expression, make it into an
1408 if ((*expr)->expr_type == EXPR_CONSTANT)
1413 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1414 if ((*expr)->ts.kind != gfc_c_int_kind)
1416 /* The expr needs to be compatible with a C int. If the
1417 conversion fails, then the 2 causes an ICE. */
1418 ts.type = BT_INTEGER;
1419 ts.kind = gfc_c_int_kind;
1420 gfc_convert_type (*expr, &ts, 2);
1423 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1425 if ((*expr)->ref == NULL)
1427 se->expr = string_to_single_character
1428 (build_int_cst (integer_type_node, 1),
1429 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1431 ((*expr)->symtree->n.sym)),
1436 gfc_conv_variable (se, *expr);
1437 se->expr = string_to_single_character
1438 (build_int_cst (integer_type_node, 1),
1439 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1448 /* Compare two strings. If they are all single characters, the result is the
1449 subtraction of them. Otherwise, we build a library call. */
1452 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1458 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1459 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1461 sc1 = string_to_single_character (len1, str1, kind);
1462 sc2 = string_to_single_character (len2, str2, kind);
1464 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1466 /* Deal with single character specially. */
1467 sc1 = fold_convert (integer_type_node, sc1);
1468 sc2 = fold_convert (integer_type_node, sc2);
1469 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1473 /* Build a call for the comparison. */
1477 fndecl = gfor_fndecl_compare_string;
1479 fndecl = gfor_fndecl_compare_string_char4;
1483 tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2);
1490 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1494 if (sym->attr.dummy)
1496 tmp = gfc_get_symbol_decl (sym);
1497 if (sym->attr.proc_pointer)
1498 tmp = build_fold_indirect_ref (tmp);
1499 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1500 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1504 if (!sym->backend_decl)
1505 sym->backend_decl = gfc_get_extern_function_decl (sym);
1507 tmp = sym->backend_decl;
1509 if (sym->attr.cray_pointee)
1511 /* TODO - make the cray pointee a pointer to a procedure,
1512 assign the pointer to it and use it for the call. This
1514 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1515 gfc_get_symbol_decl (sym->cp_pointer));
1516 tmp = gfc_evaluate_now (tmp, &se->pre);
1519 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1521 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1522 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1529 /* Translate the call for an elemental subroutine call used in an operator
1530 assignment. This is a simplified version of gfc_conv_function_call. */
1533 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1540 /* Only elemental subroutines with two arguments. */
1541 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1542 gcc_assert (sym->formal->next->next == NULL);
1544 gfc_init_block (&block);
1546 gfc_add_block_to_block (&block, &lse->pre);
1547 gfc_add_block_to_block (&block, &rse->pre);
1549 /* Build the argument list for the call, including hidden string lengths. */
1550 args = gfc_chainon_list (NULL_TREE, gfc_build_addr_expr (NULL_TREE, lse->expr));
1551 args = gfc_chainon_list (args, gfc_build_addr_expr (NULL_TREE, rse->expr));
1552 if (lse->string_length != NULL_TREE)
1553 args = gfc_chainon_list (args, lse->string_length);
1554 if (rse->string_length != NULL_TREE)
1555 args = gfc_chainon_list (args, rse->string_length);
1557 /* Build the function call. */
1558 gfc_init_se (&se, NULL);
1559 gfc_conv_function_val (&se, sym);
1560 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1561 tmp = build_call_list (tmp, se.expr, args);
1562 gfc_add_expr_to_block (&block, tmp);
1564 gfc_add_block_to_block (&block, &lse->post);
1565 gfc_add_block_to_block (&block, &rse->post);
1567 return gfc_finish_block (&block);
1571 /* Initialize MAPPING. */
1574 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1576 mapping->syms = NULL;
1577 mapping->charlens = NULL;
1581 /* Free all memory held by MAPPING (but not MAPPING itself). */
1584 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1586 gfc_interface_sym_mapping *sym;
1587 gfc_interface_sym_mapping *nextsym;
1589 gfc_charlen *nextcl;
1591 for (sym = mapping->syms; sym; sym = nextsym)
1593 nextsym = sym->next;
1594 sym->new_sym->n.sym->formal = NULL;
1595 gfc_free_symbol (sym->new_sym->n.sym);
1596 gfc_free_expr (sym->expr);
1597 gfc_free (sym->new_sym);
1600 for (cl = mapping->charlens; cl; cl = nextcl)
1603 gfc_free_expr (cl->length);
1609 /* Return a copy of gfc_charlen CL. Add the returned structure to
1610 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1612 static gfc_charlen *
1613 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1616 gfc_charlen *new_charlen;
1618 new_charlen = gfc_get_charlen ();
1619 new_charlen->next = mapping->charlens;
1620 new_charlen->length = gfc_copy_expr (cl->length);
1622 mapping->charlens = new_charlen;
1627 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1628 array variable that can be used as the actual argument for dummy
1629 argument SYM. Add any initialization code to BLOCK. PACKED is as
1630 for gfc_get_nodesc_array_type and DATA points to the first element
1631 in the passed array. */
1634 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1635 gfc_packed packed, tree data)
1640 type = gfc_typenode_for_spec (&sym->ts);
1641 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1643 var = gfc_create_var (type, "ifm");
1644 gfc_add_modify (block, var, fold_convert (type, data));
1650 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1651 and offset of descriptorless array type TYPE given that it has the same
1652 size as DESC. Add any set-up code to BLOCK. */
1655 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1662 offset = gfc_index_zero_node;
1663 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1665 dim = gfc_rank_cst[n];
1666 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1667 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1669 GFC_TYPE_ARRAY_LBOUND (type, n)
1670 = gfc_conv_descriptor_lbound (desc, dim);
1671 GFC_TYPE_ARRAY_UBOUND (type, n)
1672 = gfc_conv_descriptor_ubound (desc, dim);
1674 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1676 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1677 gfc_conv_descriptor_ubound (desc, dim),
1678 gfc_conv_descriptor_lbound (desc, dim));
1679 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1680 GFC_TYPE_ARRAY_LBOUND (type, n),
1682 tmp = gfc_evaluate_now (tmp, block);
1683 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1685 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1686 GFC_TYPE_ARRAY_LBOUND (type, n),
1687 GFC_TYPE_ARRAY_STRIDE (type, n));
1688 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1690 offset = gfc_evaluate_now (offset, block);
1691 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1695 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1696 in SE. The caller may still use se->expr and se->string_length after
1697 calling this function. */
1700 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1701 gfc_symbol * sym, gfc_se * se,
1704 gfc_interface_sym_mapping *sm;
1708 gfc_symbol *new_sym;
1710 gfc_symtree *new_symtree;
1712 /* Create a new symbol to represent the actual argument. */
1713 new_sym = gfc_new_symbol (sym->name, NULL);
1714 new_sym->ts = sym->ts;
1715 new_sym->as = gfc_copy_array_spec (sym->as);
1716 new_sym->attr.referenced = 1;
1717 new_sym->attr.dimension = sym->attr.dimension;
1718 new_sym->attr.pointer = sym->attr.pointer;
1719 new_sym->attr.allocatable = sym->attr.allocatable;
1720 new_sym->attr.flavor = sym->attr.flavor;
1721 new_sym->attr.function = sym->attr.function;
1723 /* Ensure that the interface is available and that
1724 descriptors are passed for array actual arguments. */
1725 if (sym->attr.flavor == FL_PROCEDURE)
1727 new_sym->formal = expr->symtree->n.sym->formal;
1728 new_sym->attr.always_explicit
1729 = expr->symtree->n.sym->attr.always_explicit;
1732 /* Create a fake symtree for it. */
1734 new_symtree = gfc_new_symtree (&root, sym->name);
1735 new_symtree->n.sym = new_sym;
1736 gcc_assert (new_symtree == root);
1738 /* Create a dummy->actual mapping. */
1739 sm = XCNEW (gfc_interface_sym_mapping);
1740 sm->next = mapping->syms;
1742 sm->new_sym = new_symtree;
1743 sm->expr = gfc_copy_expr (expr);
1746 /* Stabilize the argument's value. */
1747 if (!sym->attr.function && se)
1748 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1750 if (sym->ts.type == BT_CHARACTER)
1752 /* Create a copy of the dummy argument's length. */
1753 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1754 sm->expr->ts.cl = new_sym->ts.cl;
1756 /* If the length is specified as "*", record the length that
1757 the caller is passing. We should use the callee's length
1758 in all other cases. */
1759 if (!new_sym->ts.cl->length && se)
1761 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1762 new_sym->ts.cl->backend_decl = se->string_length;
1769 /* Use the passed value as-is if the argument is a function. */
1770 if (sym->attr.flavor == FL_PROCEDURE)
1773 /* If the argument is either a string or a pointer to a string,
1774 convert it to a boundless character type. */
1775 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1777 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1778 tmp = build_pointer_type (tmp);
1779 if (sym->attr.pointer)
1780 value = build_fold_indirect_ref (se->expr);
1783 value = fold_convert (tmp, value);
1786 /* If the argument is a scalar, a pointer to an array or an allocatable,
1788 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1789 value = build_fold_indirect_ref (se->expr);
1791 /* For character(*), use the actual argument's descriptor. */
1792 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1793 value = build_fold_indirect_ref (se->expr);
1795 /* If the argument is an array descriptor, use it to determine
1796 information about the actual argument's shape. */
1797 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1798 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1800 /* Get the actual argument's descriptor. */
1801 desc = build_fold_indirect_ref (se->expr);
1803 /* Create the replacement variable. */
1804 tmp = gfc_conv_descriptor_data_get (desc);
1805 value = gfc_get_interface_mapping_array (&se->pre, sym,
1808 /* Use DESC to work out the upper bounds, strides and offset. */
1809 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1812 /* Otherwise we have a packed array. */
1813 value = gfc_get_interface_mapping_array (&se->pre, sym,
1814 PACKED_FULL, se->expr);
1816 new_sym->backend_decl = value;
1820 /* Called once all dummy argument mappings have been added to MAPPING,
1821 but before the mapping is used to evaluate expressions. Pre-evaluate
1822 the length of each argument, adding any initialization code to PRE and
1823 any finalization code to POST. */
1826 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1827 stmtblock_t * pre, stmtblock_t * post)
1829 gfc_interface_sym_mapping *sym;
1833 for (sym = mapping->syms; sym; sym = sym->next)
1834 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1835 && !sym->new_sym->n.sym->ts.cl->backend_decl)
1837 expr = sym->new_sym->n.sym->ts.cl->length;
1838 gfc_apply_interface_mapping_to_expr (mapping, expr);
1839 gfc_init_se (&se, NULL);
1840 gfc_conv_expr (&se, expr);
1841 se.expr = fold_convert (gfc_charlen_type_node, se.expr);
1842 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1843 gfc_add_block_to_block (pre, &se.pre);
1844 gfc_add_block_to_block (post, &se.post);
1846 sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
1851 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1855 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1856 gfc_constructor * c)
1858 for (; c; c = c->next)
1860 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1863 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1864 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1865 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1871 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1875 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1880 for (; ref; ref = ref->next)
1884 for (n = 0; n < ref->u.ar.dimen; n++)
1886 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1887 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1888 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1890 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1897 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1898 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1904 /* Convert intrinsic function calls into result expressions. */
1907 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping)
1915 arg1 = expr->value.function.actual->expr;
1916 if (expr->value.function.actual->next)
1917 arg2 = expr->value.function.actual->next->expr;
1921 sym = arg1->symtree->n.sym;
1923 if (sym->attr.dummy)
1928 switch (expr->value.function.isym->id)
1931 /* TODO figure out why this condition is necessary. */
1932 if (sym->attr.function
1933 && (arg1->ts.cl->length == NULL
1934 || (arg1->ts.cl->length->expr_type != EXPR_CONSTANT
1935 && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)))
1938 new_expr = gfc_copy_expr (arg1->ts.cl->length);
1945 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1947 dup = mpz_get_si (arg2->value.integer);
1952 dup = sym->as->rank;
1956 for (; d < dup; d++)
1960 if (!sym->as->upper[d] || !sym->as->lower[d])
1962 gfc_free_expr (new_expr);
1966 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1967 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1969 new_expr = gfc_multiply (new_expr, tmp);
1975 case GFC_ISYM_LBOUND:
1976 case GFC_ISYM_UBOUND:
1977 /* TODO These implementations of lbound and ubound do not limit if
1978 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1983 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1984 d = mpz_get_si (arg2->value.integer) - 1;
1986 /* TODO: If the need arises, this could produce an array of
1990 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1992 if (sym->as->lower[d])
1993 new_expr = gfc_copy_expr (sym->as->lower[d]);
1997 if (sym->as->upper[d])
1998 new_expr = gfc_copy_expr (sym->as->upper[d]);
2006 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
2010 gfc_replace_expr (expr, new_expr);
2016 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
2017 gfc_interface_mapping * mapping)
2019 gfc_formal_arglist *f;
2020 gfc_actual_arglist *actual;
2022 actual = expr->value.function.actual;
2023 f = map_expr->symtree->n.sym->formal;
2025 for (; f && actual; f = f->next, actual = actual->next)
2030 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
2033 if (map_expr->symtree->n.sym->attr.dimension)
2038 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
2040 for (d = 0; d < as->rank; d++)
2042 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
2043 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
2046 expr->value.function.esym->as = as;
2049 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
2051 expr->value.function.esym->ts.cl->length
2052 = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
2054 gfc_apply_interface_mapping_to_expr (mapping,
2055 expr->value.function.esym->ts.cl->length);
2060 /* EXPR is a copy of an expression that appeared in the interface
2061 associated with MAPPING. Walk it recursively looking for references to
2062 dummy arguments that MAPPING maps to actual arguments. Replace each such
2063 reference with a reference to the associated actual argument. */
2066 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
2069 gfc_interface_sym_mapping *sym;
2070 gfc_actual_arglist *actual;
2075 /* Copying an expression does not copy its length, so do that here. */
2076 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
2078 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
2079 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
2082 /* Apply the mapping to any references. */
2083 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
2085 /* ...and to the expression's symbol, if it has one. */
2086 /* TODO Find out why the condition on expr->symtree had to be moved into
2087 the loop rather than being outside it, as originally. */
2088 for (sym = mapping->syms; sym; sym = sym->next)
2089 if (expr->symtree && sym->old == expr->symtree->n.sym)
2091 if (sym->new_sym->n.sym->backend_decl)
2092 expr->symtree = sym->new_sym;
2094 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
2097 /* ...and to subexpressions in expr->value. */
2098 switch (expr->expr_type)
2103 case EXPR_SUBSTRING:
2107 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
2108 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
2112 for (actual = expr->value.function.actual; actual; actual = actual->next)
2113 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
2115 if (expr->value.function.esym == NULL
2116 && expr->value.function.isym != NULL
2117 && expr->value.function.actual->expr->symtree
2118 && gfc_map_intrinsic_function (expr, mapping))
2121 for (sym = mapping->syms; sym; sym = sym->next)
2122 if (sym->old == expr->value.function.esym)
2124 expr->value.function.esym = sym->new_sym->n.sym;
2125 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
2126 expr->value.function.esym->result = sym->new_sym->n.sym;
2131 case EXPR_STRUCTURE:
2132 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
2144 /* Evaluate interface expression EXPR using MAPPING. Store the result
2148 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
2149 gfc_se * se, gfc_expr * expr)
2151 expr = gfc_copy_expr (expr);
2152 gfc_apply_interface_mapping_to_expr (mapping, expr);
2153 gfc_conv_expr (se, expr);
2154 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2155 gfc_free_expr (expr);
2159 /* Returns a reference to a temporary array into which a component of
2160 an actual argument derived type array is copied and then returned
2161 after the function call. */
2163 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2164 int g77, sym_intent intent)
2180 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2182 gfc_init_se (&lse, NULL);
2183 gfc_init_se (&rse, NULL);
2185 /* Walk the argument expression. */
2186 rss = gfc_walk_expr (expr);
2188 gcc_assert (rss != gfc_ss_terminator);
2190 /* Initialize the scalarizer. */
2191 gfc_init_loopinfo (&loop);
2192 gfc_add_ss_to_loop (&loop, rss);
2194 /* Calculate the bounds of the scalarization. */
2195 gfc_conv_ss_startstride (&loop);
2197 /* Build an ss for the temporary. */
2198 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
2199 gfc_conv_string_length (expr->ts.cl, expr, &parmse->pre);
2201 base_type = gfc_typenode_for_spec (&expr->ts);
2202 if (GFC_ARRAY_TYPE_P (base_type)
2203 || GFC_DESCRIPTOR_TYPE_P (base_type))
2204 base_type = gfc_get_element_type (base_type);
2206 loop.temp_ss = gfc_get_ss ();;
2207 loop.temp_ss->type = GFC_SS_TEMP;
2208 loop.temp_ss->data.temp.type = base_type;
2210 if (expr->ts.type == BT_CHARACTER)
2211 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
2213 loop.temp_ss->string_length = NULL;
2215 parmse->string_length = loop.temp_ss->string_length;
2216 loop.temp_ss->data.temp.dimen = loop.dimen;
2217 loop.temp_ss->next = gfc_ss_terminator;
2219 /* Associate the SS with the loop. */
2220 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2222 /* Setup the scalarizing loops. */
2223 gfc_conv_loop_setup (&loop, &expr->where);
2225 /* Pass the temporary descriptor back to the caller. */
2226 info = &loop.temp_ss->data.info;
2227 parmse->expr = info->descriptor;
2229 /* Setup the gfc_se structures. */
2230 gfc_copy_loopinfo_to_se (&lse, &loop);
2231 gfc_copy_loopinfo_to_se (&rse, &loop);
2234 lse.ss = loop.temp_ss;
2235 gfc_mark_ss_chain_used (rss, 1);
2236 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2238 /* Start the scalarized loop body. */
2239 gfc_start_scalarized_body (&loop, &body);
2241 /* Translate the expression. */
2242 gfc_conv_expr (&rse, expr);
2244 gfc_conv_tmp_array_ref (&lse);
2245 gfc_advance_se_ss_chain (&lse);
2247 if (intent != INTENT_OUT)
2249 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2250 gfc_add_expr_to_block (&body, tmp);
2251 gcc_assert (rse.ss == gfc_ss_terminator);
2252 gfc_trans_scalarizing_loops (&loop, &body);
2256 /* Make sure that the temporary declaration survives by merging
2257 all the loop declarations into the current context. */
2258 for (n = 0; n < loop.dimen; n++)
2260 gfc_merge_block_scope (&body);
2261 body = loop.code[loop.order[n]];
2263 gfc_merge_block_scope (&body);
2266 /* Add the post block after the second loop, so that any
2267 freeing of allocated memory is done at the right time. */
2268 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2270 /**********Copy the temporary back again.*********/
2272 gfc_init_se (&lse, NULL);
2273 gfc_init_se (&rse, NULL);
2275 /* Walk the argument expression. */
2276 lss = gfc_walk_expr (expr);
2277 rse.ss = loop.temp_ss;
2280 /* Initialize the scalarizer. */
2281 gfc_init_loopinfo (&loop2);
2282 gfc_add_ss_to_loop (&loop2, lss);
2284 /* Calculate the bounds of the scalarization. */
2285 gfc_conv_ss_startstride (&loop2);
2287 /* Setup the scalarizing loops. */
2288 gfc_conv_loop_setup (&loop2, &expr->where);
2290 gfc_copy_loopinfo_to_se (&lse, &loop2);
2291 gfc_copy_loopinfo_to_se (&rse, &loop2);
2293 gfc_mark_ss_chain_used (lss, 1);
2294 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2296 /* Declare the variable to hold the temporary offset and start the
2297 scalarized loop body. */
2298 offset = gfc_create_var (gfc_array_index_type, NULL);
2299 gfc_start_scalarized_body (&loop2, &body);
2301 /* Build the offsets for the temporary from the loop variables. The
2302 temporary array has lbounds of zero and strides of one in all
2303 dimensions, so this is very simple. The offset is only computed
2304 outside the innermost loop, so the overall transfer could be
2305 optimized further. */
2306 info = &rse.ss->data.info;
2308 tmp_index = gfc_index_zero_node;
2309 for (n = info->dimen - 1; n > 0; n--)
2312 tmp = rse.loop->loopvar[n];
2313 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2314 tmp, rse.loop->from[n]);
2315 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2318 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2319 rse.loop->to[n-1], rse.loop->from[n-1]);
2320 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2321 tmp_str, gfc_index_one_node);
2323 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2327 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2328 tmp_index, rse.loop->from[0]);
2329 gfc_add_modify (&rse.loop->code[0], offset, tmp_index);
2331 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2332 rse.loop->loopvar[0], offset);
2334 /* Now use the offset for the reference. */
2335 tmp = build_fold_indirect_ref (info->data);
2336 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2338 if (expr->ts.type == BT_CHARACTER)
2339 rse.string_length = expr->ts.cl->backend_decl;
2341 gfc_conv_expr (&lse, expr);
2343 gcc_assert (lse.ss == gfc_ss_terminator);
2345 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2346 gfc_add_expr_to_block (&body, tmp);
2348 /* Generate the copying loops. */
2349 gfc_trans_scalarizing_loops (&loop2, &body);
2351 /* Wrap the whole thing up by adding the second loop to the post-block
2352 and following it by the post-block of the first loop. In this way,
2353 if the temporary needs freeing, it is done after use! */
2354 if (intent != INTENT_IN)
2356 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2357 gfc_add_block_to_block (&parmse->post, &loop2.post);
2360 gfc_add_block_to_block (&parmse->post, &loop.post);
2362 gfc_cleanup_loop (&loop);
2363 gfc_cleanup_loop (&loop2);
2365 /* Pass the string length to the argument expression. */
2366 if (expr->ts.type == BT_CHARACTER)
2367 parmse->string_length = expr->ts.cl->backend_decl;
2369 /* We want either the address for the data or the address of the descriptor,
2370 depending on the mode of passing array arguments. */
2372 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2374 parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
2380 /* Generate the code for argument list functions. */
2383 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2385 /* Pass by value for g77 %VAL(arg), pass the address
2386 indirectly for %LOC, else by reference. Thus %REF
2387 is a "do-nothing" and %LOC is the same as an F95
2389 if (strncmp (name, "%VAL", 4) == 0)
2390 gfc_conv_expr (se, expr);
2391 else if (strncmp (name, "%LOC", 4) == 0)
2393 gfc_conv_expr_reference (se, expr);
2394 se->expr = gfc_build_addr_expr (NULL, se->expr);
2396 else if (strncmp (name, "%REF", 4) == 0)
2397 gfc_conv_expr_reference (se, expr);
2399 gfc_error ("Unknown argument list function at %L", &expr->where);
2403 /* Generate code for a procedure call. Note can return se->post != NULL.
2404 If se->direct_byref is set then se->expr contains the return parameter.
2405 Return nonzero, if the call has alternate specifiers. */
2408 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2409 gfc_actual_arglist * arg, tree append_args)
2411 gfc_interface_mapping mapping;
2425 gfc_formal_arglist *formal;
2426 int has_alternate_specifier = 0;
2427 bool need_interface_mapping;
2434 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2436 arglist = NULL_TREE;
2437 retargs = NULL_TREE;
2438 stringargs = NULL_TREE;
2443 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2445 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2447 if (arg->expr->rank == 0)
2448 gfc_conv_expr_reference (se, arg->expr);
2452 /* This is really the actual arg because no formal arglist is
2453 created for C_LOC. */
2454 fsym = arg->expr->symtree->n.sym;
2456 /* We should want it to do g77 calling convention. */
2458 && !(fsym->attr.pointer || fsym->attr.allocatable)
2459 && fsym->as->type != AS_ASSUMED_SHAPE;
2460 f = f || !sym->attr.always_explicit;
2462 argss = gfc_walk_expr (arg->expr);
2463 gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
2466 /* TODO -- the following two lines shouldn't be necessary, but
2467 they're removed a bug is exposed later in the codepath.
2468 This is workaround was thus introduced, but will have to be
2469 removed; please see PR 35150 for details about the issue. */
2470 se->expr = convert (pvoid_type_node, se->expr);
2471 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2475 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2477 arg->expr->ts.type = sym->ts.derived->ts.type;
2478 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2479 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2480 gfc_conv_expr_reference (se, arg->expr);
2484 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2485 && arg->next->expr->rank == 0)
2486 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2488 /* Convert c_f_pointer if fptr is a scalar
2489 and convert c_f_procpointer. */
2493 gfc_init_se (&cptrse, NULL);
2494 gfc_conv_expr (&cptrse, arg->expr);
2495 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2496 gfc_add_block_to_block (&se->post, &cptrse.post);
2498 gfc_init_se (&fptrse, NULL);
2499 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2500 fptrse.want_pointer = 1;
2502 gfc_conv_expr (&fptrse, arg->next->expr);
2503 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2504 gfc_add_block_to_block (&se->post, &fptrse.post);
2506 tmp = arg->next->expr->symtree->n.sym->backend_decl;
2507 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
2508 fold_convert (TREE_TYPE (tmp), cptrse.expr));
2512 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2517 /* Build the addr_expr for the first argument. The argument is
2518 already an *address* so we don't need to set want_pointer in
2520 gfc_init_se (&arg1se, NULL);
2521 gfc_conv_expr (&arg1se, arg->expr);
2522 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2523 gfc_add_block_to_block (&se->post, &arg1se.post);
2525 /* See if we were given two arguments. */
2526 if (arg->next == NULL)
2527 /* Only given one arg so generate a null and do a
2528 not-equal comparison against the first arg. */
2529 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2530 fold_convert (TREE_TYPE (arg1se.expr),
2531 null_pointer_node));
2537 /* Given two arguments so build the arg2se from second arg. */
2538 gfc_init_se (&arg2se, NULL);
2539 gfc_conv_expr (&arg2se, arg->next->expr);
2540 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2541 gfc_add_block_to_block (&se->post, &arg2se.post);
2543 /* Generate test to compare that the two args are equal. */
2544 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2545 arg1se.expr, arg2se.expr);
2546 /* Generate test to ensure that the first arg is not null. */
2547 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2548 arg1se.expr, null_pointer_node);
2550 /* Finally, the generated test must check that both arg1 is not
2551 NULL and that it is equal to the second arg. */
2552 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2553 not_null_expr, eq_expr);
2562 if (!sym->attr.elemental)
2564 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2565 if (se->ss->useflags)
2567 gcc_assert (gfc_return_by_reference (sym)
2568 && sym->result->attr.dimension);
2569 gcc_assert (se->loop != NULL);
2571 /* Access the previously obtained result. */
2572 gfc_conv_tmp_array_ref (se);
2573 gfc_advance_se_ss_chain (se);
2577 info = &se->ss->data.info;
2582 gfc_init_block (&post);
2583 gfc_init_interface_mapping (&mapping);
2584 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2585 && sym->ts.cl->length
2586 && sym->ts.cl->length->expr_type
2588 || sym->attr.dimension);
2589 formal = sym->formal;
2590 /* Evaluate the arguments. */
2591 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2594 fsym = formal ? formal->sym : NULL;
2595 parm_kind = MISSING;
2599 if (se->ignore_optional)
2601 /* Some intrinsics have already been resolved to the correct
2605 else if (arg->label)
2607 has_alternate_specifier = 1;
2612 /* Pass a NULL pointer for an absent arg. */
2613 gfc_init_se (&parmse, NULL);
2614 parmse.expr = null_pointer_node;
2615 if (arg->missing_arg_type == BT_CHARACTER)
2616 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2619 else if (se->ss && se->ss->useflags)
2621 /* An elemental function inside a scalarized loop. */
2622 gfc_init_se (&parmse, se);
2623 gfc_conv_expr_reference (&parmse, e);
2624 parm_kind = ELEMENTAL;
2628 /* A scalar or transformational function. */
2629 gfc_init_se (&parmse, NULL);
2630 argss = gfc_walk_expr (e);
2632 if (argss == gfc_ss_terminator)
2634 if (e->expr_type == EXPR_VARIABLE
2635 && e->symtree->n.sym->attr.cray_pointee
2636 && fsym && fsym->attr.flavor == FL_PROCEDURE)
2638 /* The Cray pointer needs to be converted to a pointer to
2639 a type given by the expression. */
2640 gfc_conv_expr (&parmse, e);
2641 type = build_pointer_type (TREE_TYPE (parmse.expr));
2642 tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer);
2643 parmse.expr = convert (type, tmp);
2645 else if (fsym && fsym->attr.value)
2647 if (fsym->ts.type == BT_CHARACTER
2648 && fsym->ts.is_c_interop
2649 && fsym->ns->proc_name != NULL
2650 && fsym->ns->proc_name->attr.is_bind_c)
2653 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2654 if (parmse.expr == NULL)
2655 gfc_conv_expr (&parmse, e);
2658 gfc_conv_expr (&parmse, e);
2660 else if (arg->name && arg->name[0] == '%')
2661 /* Argument list functions %VAL, %LOC and %REF are signalled
2662 through arg->name. */
2663 conv_arglist_function (&parmse, arg->expr, arg->name);
2664 else if ((e->expr_type == EXPR_FUNCTION)
2665 && e->symtree->n.sym->attr.pointer
2666 && fsym && fsym->attr.target)
2668 gfc_conv_expr (&parmse, e);
2669 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2673 gfc_conv_expr_reference (&parmse, e);
2674 if (fsym && e->expr_type != EXPR_NULL
2675 && ((fsym->attr.pointer
2676 && fsym->attr.flavor != FL_PROCEDURE)
2677 || fsym->attr.proc_pointer))
2679 /* Scalar pointer dummy args require an extra level of
2680 indirection. The null pointer already contains
2681 this level of indirection. */
2682 parm_kind = SCALAR_POINTER;
2683 parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
2689 /* If the procedure requires an explicit interface, the actual
2690 argument is passed according to the corresponding formal
2691 argument. If the corresponding formal argument is a POINTER,
2692 ALLOCATABLE or assumed shape, we do not use g77's calling
2693 convention, and pass the address of the array descriptor
2694 instead. Otherwise we use g77's calling convention. */
2697 && !(fsym->attr.pointer || fsym->attr.allocatable)
2698 && fsym->as->type != AS_ASSUMED_SHAPE;
2699 f = f || !sym->attr.always_explicit;
2701 if (e->expr_type == EXPR_VARIABLE
2702 && is_subref_array (e))
2703 /* The actual argument is a component reference to an
2704 array of derived types. In this case, the argument
2705 is converted to a temporary, which is passed and then
2706 written back after the procedure call. */
2707 gfc_conv_subref_array_arg (&parmse, e, f,
2708 fsym ? fsym->attr.intent : INTENT_INOUT);
2710 gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
2713 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2714 allocated on entry, it must be deallocated. */
2715 if (fsym && fsym->attr.allocatable
2716 && fsym->attr.intent == INTENT_OUT)
2718 tmp = build_fold_indirect_ref (parmse.expr);
2719 tmp = gfc_trans_dealloc_allocated (tmp);
2720 gfc_add_expr_to_block (&se->pre, tmp);
2726 /* The case with fsym->attr.optional is that of a user subroutine
2727 with an interface indicating an optional argument. When we call
2728 an intrinsic subroutine, however, fsym is NULL, but we might still
2729 have an optional argument, so we proceed to the substitution
2731 if (e && (fsym == NULL || fsym->attr.optional))
2733 /* If an optional argument is itself an optional dummy argument,
2734 check its presence and substitute a null if absent. */
2735 if (e->expr_type == EXPR_VARIABLE
2736 && e->symtree->n.sym->attr.optional)
2737 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2738 e->representation.length);
2743 /* Obtain the character length of an assumed character length
2744 length procedure from the typespec. */
2745 if (fsym->ts.type == BT_CHARACTER
2746 && parmse.string_length == NULL_TREE
2747 && e->ts.type == BT_PROCEDURE
2748 && e->symtree->n.sym->ts.type == BT_CHARACTER
2749 && e->symtree->n.sym->ts.cl->length != NULL
2750 && e->symtree->n.sym->ts.cl->length->expr_type == EXPR_CONSTANT)
2752 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2753 parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2757 if (fsym && need_interface_mapping && e)
2758 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2760 gfc_add_block_to_block (&se->pre, &parmse.pre);
2761 gfc_add_block_to_block (&post, &parmse.post);
2763 /* Allocated allocatable components of derived types must be
2764 deallocated for non-variable scalars. Non-variable arrays are
2765 dealt with in trans-array.c(gfc_conv_array_parameter). */
2766 if (e && e->ts.type == BT_DERIVED
2767 && e->ts.derived->attr.alloc_comp
2768 && (e->expr_type != EXPR_VARIABLE && !e->rank))
2771 tmp = build_fold_indirect_ref (parmse.expr);
2772 parm_rank = e->rank;
2780 case (SCALAR_POINTER):
2781 tmp = build_fold_indirect_ref (tmp);
2785 if (e->expr_type == EXPR_OP
2786 && e->value.op.op == INTRINSIC_PARENTHESES
2787 && e->value.op.op1->expr_type == EXPR_VARIABLE)
2790 local_tmp = gfc_evaluate_now (tmp, &se->pre);
2791 local_tmp = gfc_copy_alloc_comp (e->ts.derived, local_tmp, tmp, parm_rank);
2792 gfc_add_expr_to_block (&se->post, local_tmp);
2795 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2797 gfc_add_expr_to_block (&se->post, tmp);
2800 /* Character strings are passed as two parameters, a length and a
2801 pointer - except for Bind(c) which only passes the pointer. */
2802 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2803 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2805 arglist = gfc_chainon_list (arglist, parmse.expr);
2807 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2810 if (ts.type == BT_CHARACTER && sym->attr.is_bind_c)
2811 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2812 else if (ts.type == BT_CHARACTER)
2814 if (sym->ts.cl->length == NULL)
2816 /* Assumed character length results are not allowed by 5.1.1.5 of the
2817 standard and are trapped in resolve.c; except in the case of SPREAD
2818 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2819 we take the character length of the first argument for the result.
2820 For dummies, we have to look through the formal argument list for
2821 this function and use the character length found there.*/
2822 if (!sym->attr.dummy)
2823 cl.backend_decl = TREE_VALUE (stringargs);
2826 formal = sym->ns->proc_name->formal;
2827 for (; formal; formal = formal->next)
2828 if (strcmp (formal->sym->name, sym->name) == 0)
2829 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2836 /* Calculate the length of the returned string. */
2837 gfc_init_se (&parmse, NULL);
2838 if (need_interface_mapping)
2839 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2841 gfc_conv_expr (&parmse, sym->ts.cl->length);
2842 gfc_add_block_to_block (&se->pre, &parmse.pre);
2843 gfc_add_block_to_block (&se->post, &parmse.post);
2845 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2846 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2847 build_int_cst (gfc_charlen_type_node, 0));
2848 cl.backend_decl = tmp;
2851 /* Set up a charlen structure for it. */
2856 len = cl.backend_decl;
2859 byref = gfc_return_by_reference (sym);
2862 if (se->direct_byref)
2864 /* Sometimes, too much indirection can be applied; e.g. for
2865 function_result = array_valued_recursive_function. */
2866 if (TREE_TYPE (TREE_TYPE (se->expr))
2867 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2868 && GFC_DESCRIPTOR_TYPE_P
2869 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2870 se->expr = build_fold_indirect_ref (se->expr);
2872 retargs = gfc_chainon_list (retargs, se->expr);
2874 else if (sym->result->attr.dimension)
2876 gcc_assert (se->loop && info);
2878 /* Set the type of the array. */
2879 tmp = gfc_typenode_for_spec (&ts);
2880 info->dimen = se->loop->dimen;
2882 /* Evaluate the bounds of the result, if known. */
2883 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2885 /* Create a temporary to store the result. In case the function
2886 returns a pointer, the temporary will be a shallow copy and
2887 mustn't be deallocated. */
2888 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2889 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2890 NULL_TREE, false, !sym->attr.pointer,
2891 callee_alloc, &se->ss->expr->where);
2893 /* Pass the temporary as the first argument. */
2894 tmp = info->descriptor;
2895 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2896 retargs = gfc_chainon_list (retargs, tmp);
2898 else if (ts.type == BT_CHARACTER)
2900 /* Pass the string length. */
2901 type = gfc_get_character_type (ts.kind, ts.cl);
2902 type = build_pointer_type (type);
2904 /* Return an address to a char[0:len-1]* temporary for
2905 character pointers. */
2906 if (sym->attr.pointer || sym->attr.allocatable)
2908 var = gfc_create_var (type, "pstr");
2910 /* Provide an address expression for the function arguments. */
2911 var = gfc_build_addr_expr (NULL_TREE, var);
2914 var = gfc_conv_string_tmp (se, type, len);
2916 retargs = gfc_chainon_list (retargs, var);
2920 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2922 type = gfc_get_complex_type (ts.kind);
2923 var = gfc_build_addr_expr (NULL_TREE, gfc_create_var (type, "cmplx"));
2924 retargs = gfc_chainon_list (retargs, var);
2927 /* Add the string length to the argument list. */
2928 if (ts.type == BT_CHARACTER)
2929 retargs = gfc_chainon_list (retargs, len);
2931 gfc_free_interface_mapping (&mapping);
2933 /* Add the return arguments. */
2934 arglist = chainon (retargs, arglist);
2936 /* Add the hidden string length parameters to the arguments. */
2937 arglist = chainon (arglist, stringargs);
2939 /* We may want to append extra arguments here. This is used e.g. for
2940 calls to libgfortran_matmul_??, which need extra information. */
2941 if (append_args != NULL_TREE)
2942 arglist = chainon (arglist, append_args);
2944 /* Generate the actual call. */
2945 gfc_conv_function_val (se, sym);
2947 /* If there are alternate return labels, function type should be
2948 integer. Can't modify the type in place though, since it can be shared
2949 with other functions. For dummy arguments, the typing is done to
2950 to this result, even if it has to be repeated for each call. */
2951 if (has_alternate_specifier
2952 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2954 if (!sym->attr.dummy)
2956 TREE_TYPE (sym->backend_decl)
2957 = build_function_type (integer_type_node,
2958 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2959 se->expr = gfc_build_addr_expr (NULL_TREE, sym->backend_decl);
2962 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2965 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2966 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2968 /* If we have a pointer function, but we don't want a pointer, e.g.
2971 where f is pointer valued, we have to dereference the result. */
2972 if (!se->want_pointer && !byref && sym->attr.pointer)
2973 se->expr = build_fold_indirect_ref (se->expr);
2975 /* f2c calling conventions require a scalar default real function to
2976 return a double precision result. Convert this back to default
2977 real. We only care about the cases that can happen in Fortran 77.
2979 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2980 && sym->ts.kind == gfc_default_real_kind
2981 && !sym->attr.always_explicit)
2982 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2984 /* A pure function may still have side-effects - it may modify its
2986 TREE_SIDE_EFFECTS (se->expr) = 1;
2988 if (!sym->attr.pure)
2989 TREE_SIDE_EFFECTS (se->expr) = 1;
2994 /* Add the function call to the pre chain. There is no expression. */
2995 gfc_add_expr_to_block (&se->pre, se->expr);
2996 se->expr = NULL_TREE;
2998 if (!se->direct_byref)
3000 if (sym->attr.dimension)
3002 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
3004 /* Check the data pointer hasn't been modified. This would
3005 happen in a function returning a pointer. */
3006 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3007 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3009 gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
3012 se->expr = info->descriptor;
3013 /* Bundle in the string length. */
3014 se->string_length = len;
3016 else if (sym->ts.type == BT_CHARACTER)
3018 /* Dereference for character pointer results. */
3019 if (sym->attr.pointer || sym->attr.allocatable)
3020 se->expr = build_fold_indirect_ref (var);
3024 se->string_length = len;
3028 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
3029 se->expr = build_fold_indirect_ref (var);
3034 /* Follow the function call with the argument post block. */
3036 gfc_add_block_to_block (&se->pre, &post);
3038 gfc_add_block_to_block (&se->post, &post);
3040 return has_alternate_specifier;
3044 /* Fill a character string with spaces. */
3047 fill_with_spaces (tree start, tree type, tree size)
3049 stmtblock_t block, loop;
3050 tree i, el, exit_label, cond, tmp;
3052 /* For a simple char type, we can call memset(). */
3053 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
3054 return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
3055 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
3056 lang_hooks.to_target_charset (' ')),
3059 /* Otherwise, we use a loop:
3060 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
3064 /* Initialize variables. */
3065 gfc_init_block (&block);
3066 i = gfc_create_var (sizetype, "i");
3067 gfc_add_modify (&block, i, fold_convert (sizetype, size));
3068 el = gfc_create_var (build_pointer_type (type), "el");
3069 gfc_add_modify (&block, el, fold_convert (TREE_TYPE (el), start));
3070 exit_label = gfc_build_label_decl (NULL_TREE);
3071 TREE_USED (exit_label) = 1;
3075 gfc_init_block (&loop);
3077 /* Exit condition. */
3078 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
3079 fold_convert (sizetype, integer_zero_node));
3080 tmp = build1_v (GOTO_EXPR, exit_label);
3081 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3082 gfc_add_expr_to_block (&loop, tmp);
3085 gfc_add_modify (&loop, fold_build1 (INDIRECT_REF, type, el),
3086 build_int_cst (type,
3087 lang_hooks.to_target_charset (' ')));
3089 /* Increment loop variables. */
3090 gfc_add_modify (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
3091 TYPE_SIZE_UNIT (type)));
3092 gfc_add_modify (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
3094 TYPE_SIZE_UNIT (type)));
3096 /* Making the loop... actually loop! */
3097 tmp = gfc_finish_block (&loop);
3098 tmp = build1_v (LOOP_EXPR, tmp);
3099 gfc_add_expr_to_block (&block, tmp);
3101 /* The exit label. */
3102 tmp = build1_v (LABEL_EXPR, exit_label);
3103 gfc_add_expr_to_block (&block, tmp);
3106 return gfc_finish_block (&block);
3110 /* Generate code to copy a string. */
3113 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
3114 int dkind, tree slength, tree src, int skind)
3116 tree tmp, dlen, slen;
3125 stmtblock_t tempblock;
3127 gcc_assert (dkind == skind);
3129 if (slength != NULL_TREE)
3131 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
3132 ssc = string_to_single_character (slen, src, skind);
3136 slen = build_int_cst (size_type_node, 1);
3140 if (dlength != NULL_TREE)
3142 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
3143 dsc = string_to_single_character (slen, dest, dkind);
3147 dlen = build_int_cst (size_type_node, 1);
3151 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
3152 ssc = string_to_single_character (slen, src, skind);
3153 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
3154 dsc = string_to_single_character (dlen, dest, dkind);
3157 /* Assign directly if the types are compatible. */
3158 if (dsc != NULL_TREE && ssc != NULL_TREE
3159 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
3161 gfc_add_modify (block, dsc, ssc);
3165 /* Do nothing if the destination length is zero. */
3166 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
3167 build_int_cst (size_type_node, 0));
3169 /* The following code was previously in _gfortran_copy_string:
3171 // The two strings may overlap so we use memmove.
3173 copy_string (GFC_INTEGER_4 destlen, char * dest,
3174 GFC_INTEGER_4 srclen, const char * src)
3176 if (srclen >= destlen)
3178 // This will truncate if too long.
3179 memmove (dest, src, destlen);
3183 memmove (dest, src, srclen);
3185 memset (&dest[srclen], ' ', destlen - srclen);
3189 We're now doing it here for better optimization, but the logic
3192 /* For non-default character kinds, we have to multiply the string
3193 length by the base type size. */
3194 chartype = gfc_get_char_type (dkind);
3195 slen = fold_build2 (MULT_EXPR, size_type_node,
3196 fold_convert (size_type_node, slen),
3197 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3198 dlen = fold_build2 (MULT_EXPR, size_type_node,
3199 fold_convert (size_type_node, dlen),
3200 fold_convert (size_type_node, TYPE_SIZE_UNIT (chartype)));
3203 dest = fold_convert (pvoid_type_node, dest);
3205 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3208 src = fold_convert (pvoid_type_node, src);
3210 src = gfc_build_addr_expr (pvoid_type_node, src);
3212 /* Truncate string if source is too long. */
3213 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3214 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3215 3, dest, src, dlen);
3217 /* Else copy and pad with spaces. */
3218 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3219 3, dest, src, slen);
3221 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3222 fold_convert (sizetype, slen));
3223 tmp4 = fill_with_spaces (tmp4, chartype,
3224 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3227 gfc_init_block (&tempblock);
3228 gfc_add_expr_to_block (&tempblock, tmp3);
3229 gfc_add_expr_to_block (&tempblock, tmp4);
3230 tmp3 = gfc_finish_block (&tempblock);
3232 /* The whole copy_string function is there. */
3233 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3234 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3235 gfc_add_expr_to_block (block, tmp);
3239 /* Translate a statement function.
3240 The value of a statement function reference is obtained by evaluating the
3241 expression using the values of the actual arguments for the values of the
3242 corresponding dummy arguments. */
3245 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3249 gfc_formal_arglist *fargs;
3250 gfc_actual_arglist *args;
3253 gfc_saved_var *saved_vars;
3259 sym = expr->symtree->n.sym;
3260 args = expr->value.function.actual;
3261 gfc_init_se (&lse, NULL);
3262 gfc_init_se (&rse, NULL);
3265 for (fargs = sym->formal; fargs; fargs = fargs->next)
3267 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3268 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3270 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3272 /* Each dummy shall be specified, explicitly or implicitly, to be
3274 gcc_assert (fargs->sym->attr.dimension == 0);
3277 /* Create a temporary to hold the value. */
3278 type = gfc_typenode_for_spec (&fsym->ts);
3279 temp_vars[n] = gfc_create_var (type, fsym->name);
3281 if (fsym->ts.type == BT_CHARACTER)
3283 /* Copy string arguments. */
3286 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
3287 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
3289 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3290 tmp = gfc_build_addr_expr (build_pointer_type (type),
3293 gfc_conv_expr (&rse, args->expr);
3294 gfc_conv_string_parameter (&rse);
3295 gfc_add_block_to_block (&se->pre, &lse.pre);
3296 gfc_add_block_to_block (&se->pre, &rse.pre);
3298 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3299 rse.string_length, rse.expr, fsym->ts.kind);
3300 gfc_add_block_to_block (&se->pre, &lse.post);
3301 gfc_add_block_to_block (&se->pre, &rse.post);
3305 /* For everything else, just evaluate the expression. */
3306 gfc_conv_expr (&lse, args->expr);
3308 gfc_add_block_to_block (&se->pre, &lse.pre);
3309 gfc_add_modify (&se->pre, temp_vars[n], lse.expr);
3310 gfc_add_block_to_block (&se->pre, &lse.post);
3316 /* Use the temporary variables in place of the real ones. */
3317 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3318 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3320 gfc_conv_expr (se, sym->value);
3322 if (sym->ts.type == BT_CHARACTER)
3324 gfc_conv_const_charlen (sym->ts.cl);
3326 /* Force the expression to the correct length. */
3327 if (!INTEGER_CST_P (se->string_length)
3328 || tree_int_cst_lt (se->string_length,
3329 sym->ts.cl->backend_decl))
3331 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
3332 tmp = gfc_create_var (type, sym->name);
3333 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3334 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
3335 sym->ts.kind, se->string_length, se->expr,
3339 se->string_length = sym->ts.cl->backend_decl;
3342 /* Restore the original variables. */
3343 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3344 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3345 gfc_free (saved_vars);
3349 /* Translate a function expression. */
3352 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3356 if (expr->value.function.isym)
3358 gfc_conv_intrinsic_function (se, expr);
3362 /* We distinguish statement functions from general functions to improve
3363 runtime performance. */
3364 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3366 gfc_conv_statement_function (se, expr);
3370 /* expr.value.function.esym is the resolved (specific) function symbol for
3371 most functions. However this isn't set for dummy procedures. */
3372 sym = expr->value.function.esym;
3374 sym = expr->symtree->n.sym;
3375 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
3380 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3382 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3383 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3385 gfc_conv_tmp_array_ref (se);
3386 gfc_advance_se_ss_chain (se);
3390 /* Build a static initializer. EXPR is the expression for the initial value.
3391 The other parameters describe the variable of the component being
3392 initialized. EXPR may be null. */
3395 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3396 bool array, bool pointer)
3400 if (!(expr || pointer))
3403 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3404 (these are the only two iso_c_binding derived types that can be
3405 used as initialization expressions). If so, we need to modify
3406 the 'expr' to be that for a (void *). */
3407 if (expr != NULL && expr->ts.type == BT_DERIVED
3408 && expr->ts.is_iso_c && expr->ts.derived)
3410 gfc_symbol *derived = expr->ts.derived;
3412 expr = gfc_int_expr (0);
3414 /* The derived symbol has already been converted to a (void *). Use
3416 expr->ts.f90_type = derived->ts.f90_type;
3417 expr->ts.kind = derived->ts.kind;
3422 /* Arrays need special handling. */
3424 return gfc_build_null_descriptor (type);
3426 return gfc_conv_array_initializer (type, expr);
3429 return fold_convert (type, null_pointer_node);
3435 gfc_init_se (&se, NULL);
3436 gfc_conv_structure (&se, expr, 1);
3440 return gfc_conv_string_init (ts->cl->backend_decl,expr);
3443 gfc_init_se (&se, NULL);
3444 gfc_conv_constant (&se, expr);
3451 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3463 gfc_start_block (&block);
3465 /* Initialize the scalarizer. */
3466 gfc_init_loopinfo (&loop);
3468 gfc_init_se (&lse, NULL);
3469 gfc_init_se (&rse, NULL);
3472 rss = gfc_walk_expr (expr);
3473 if (rss == gfc_ss_terminator)
3475 /* The rhs is scalar. Add a ss for the expression. */
3476 rss = gfc_get_ss ();
3477 rss->next = gfc_ss_terminator;
3478 rss->type = GFC_SS_SCALAR;
3482 /* Create a SS for the destination. */
3483 lss = gfc_get_ss ();
3484 lss->type = GFC_SS_COMPONENT;
3486 lss->shape = gfc_get_shape (cm->as->rank);
3487 lss->next = gfc_ss_terminator;
3488 lss->data.info.dimen = cm->as->rank;
3489 lss->data.info.descriptor = dest;
3490 lss->data.info.data = gfc_conv_array_data (dest);
3491 lss->data.info.offset = gfc_conv_array_offset (dest);
3492 for (n = 0; n < cm->as->rank; n++)
3494 lss->data.info.dim[n] = n;
3495 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3496 lss->data.info.stride[n] = gfc_index_one_node;
3498 mpz_init (lss->shape[n]);
3499 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3500 cm->as->lower[n]->value.integer);
3501 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3504 /* Associate the SS with the loop. */
3505 gfc_add_ss_to_loop (&loop, lss);
3506 gfc_add_ss_to_loop (&loop, rss);
3508 /* Calculate the bounds of the scalarization. */
3509 gfc_conv_ss_startstride (&loop);
3511 /* Setup the scalarizing loops. */
3512 gfc_conv_loop_setup (&loop, &expr->where);
3514 /* Setup the gfc_se structures. */
3515 gfc_copy_loopinfo_to_se (&lse, &loop);
3516 gfc_copy_loopinfo_to_se (&rse, &loop);
3519 gfc_mark_ss_chain_used (rss, 1);
3521 gfc_mark_ss_chain_used (lss, 1);
3523 /* Start the scalarized loop body. */
3524 gfc_start_scalarized_body (&loop, &body);
3526 gfc_conv_tmp_array_ref (&lse);
3527 if (cm->ts.type == BT_CHARACTER)
3528 lse.string_length = cm->ts.cl->backend_decl;
3530 gfc_conv_expr (&rse, expr);
3532 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3533 gfc_add_expr_to_block (&body, tmp);
3535 gcc_assert (rse.ss == gfc_ss_terminator);
3537 /* Generate the copying loops. */
3538 gfc_trans_scalarizing_loops (&loop, &body);
3540 /* Wrap the whole thing up. */
3541 gfc_add_block_to_block (&block, &loop.pre);
3542 gfc_add_block_to_block (&block, &loop.post);
3544 for (n = 0; n < cm->as->rank; n++)
3545 mpz_clear (lss->shape[n]);
3546 gfc_free (lss->shape);
3548 gfc_cleanup_loop (&loop);
3550 return gfc_finish_block (&block);
3554 /* Assign a single component of a derived type constructor. */
3557 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3567 gfc_start_block (&block);
3569 if (cm->attr.pointer)
3571 gfc_init_se (&se, NULL);
3572 /* Pointer component. */
3573 if (cm->attr.dimension)
3575 /* Array pointer. */
3576 if (expr->expr_type == EXPR_NULL)
3577 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3580 rss = gfc_walk_expr (expr);
3581 se.direct_byref = 1;
3583 gfc_conv_expr_descriptor (&se, expr, rss);
3584 gfc_add_block_to_block (&block, &se.pre);
3585 gfc_add_block_to_block (&block, &se.post);
3590 /* Scalar pointers. */
3591 se.want_pointer = 1;
3592 gfc_conv_expr (&se, expr);
3593 gfc_add_block_to_block (&block, &se.pre);
3594 gfc_add_modify (&block, dest,
3595 fold_convert (TREE_TYPE (dest), se.expr));
3596 gfc_add_block_to_block (&block, &se.post);
3599 else if (cm->attr.dimension)
3601 if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
3602 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3603 else if (cm->attr.allocatable)
3607 gfc_init_se (&se, NULL);
3609 rss = gfc_walk_expr (expr);
3610 se.want_pointer = 0;
3611 gfc_conv_expr_descriptor (&se, expr, rss);
3612 gfc_add_block_to_block (&block, &se.pre);
3614 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3615 gfc_add_modify (&block, dest, tmp);
3617 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3618 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3621 tmp = gfc_duplicate_allocatable (dest, se.expr,
3622 TREE_TYPE(cm->backend_decl),
3625 gfc_add_expr_to_block (&block, tmp);
3626 gfc_add_block_to_block (&block, &se.post);
3628 if (expr->expr_type != EXPR_VARIABLE)
3629 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3631 /* Shift the lbound and ubound of temporaries to being unity, rather
3632 than zero, based. Calculate the offset for all cases. */
3633 offset = gfc_conv_descriptor_offset (dest);
3634 gfc_add_modify (&block, offset, gfc_index_zero_node);
3635 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3636 for (n = 0; n < expr->rank; n++)
3638 if (expr->expr_type != EXPR_VARIABLE
3639 && expr->expr_type != EXPR_CONSTANT)
3642 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3643 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3644 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3645 gfc_add_modify (&block, tmp,
3646 fold_build2 (PLUS_EXPR,
3647 gfc_array_index_type,
3648 span, gfc_index_one_node));
3649 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3650 gfc_add_modify (&block, tmp, gfc_index_one_node);
3652 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3653 gfc_conv_descriptor_lbound (dest,
3655 gfc_conv_descriptor_stride (dest,
3657 gfc_add_modify (&block, tmp2, tmp);
3658 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3659 gfc_add_modify (&block, offset, tmp);
3662 if (expr->expr_type == EXPR_FUNCTION
3663 && expr->value.function.isym
3664 && expr->value.function.isym->conversion
3665 && expr->value.function.actual->expr
3666 && expr->value.function.actual->expr->expr_type
3669 /* If a conversion expression has a null data pointer
3670 argument, nullify the allocatable component. */
3674 s = expr->value.function.actual->expr->symtree->n.sym;
3675 if (s->attr.allocatable || s->attr.pointer)
3677 non_null_expr = gfc_finish_block (&block);
3678 gfc_start_block (&block);
3679 gfc_conv_descriptor_data_set (&block, dest,
3681 null_expr = gfc_finish_block (&block);
3682 tmp = gfc_conv_descriptor_data_get (s->backend_decl);
3683 tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
3684 fold_convert (TREE_TYPE (tmp),
3685 null_pointer_node));
3686 return build3_v (COND_EXPR, tmp, null_expr,
3693 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3694 gfc_add_expr_to_block (&block, tmp);
3697 else if (expr->ts.type == BT_DERIVED)
3699 if (expr->expr_type != EXPR_STRUCTURE)
3701 gfc_init_se (&se, NULL);
3702 gfc_conv_expr (&se, expr);
3703 gfc_add_block_to_block (&block, &se.pre);
3704 gfc_add_modify (&block, dest,
3705 fold_convert (TREE_TYPE (dest), se.expr));
3706 gfc_add_block_to_block (&block, &se.post);
3710 /* Nested constructors. */
3711 tmp = gfc_trans_structure_assign (dest, expr);
3712 gfc_add_expr_to_block (&block, tmp);
3717 /* Scalar component. */
3718 gfc_init_se (&se, NULL);
3719 gfc_init_se (&lse, NULL);
3721 gfc_conv_expr (&se, expr);
3722 if (cm->ts.type == BT_CHARACTER)
3723 lse.string_length = cm->ts.cl->backend_decl;
3725 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3726 gfc_add_expr_to_block (&block, tmp);
3728 return gfc_finish_block (&block);
3731 /* Assign a derived type constructor to a variable. */
3734 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3742 gfc_start_block (&block);
3743 cm = expr->ts.derived->components;
3744 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3746 /* Skip absent members in default initializers. */
3750 field = cm->backend_decl;
3751 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3752 dest, field, NULL_TREE);
3753 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3754 gfc_add_expr_to_block (&block, tmp);
3756 return gfc_finish_block (&block);
3759 /* Build an expression for a constructor. If init is nonzero then
3760 this is part of a static variable initializer. */
3763 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3770 VEC(constructor_elt,gc) *v = NULL;
3772 gcc_assert (se->ss == NULL);
3773 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3774 type = gfc_typenode_for_spec (&expr->ts);
3778 /* Create a temporary variable and fill it in. */
3779 se->expr = gfc_create_var (type, expr->ts.derived->name);
3780 tmp = gfc_trans_structure_assign (se->expr, expr);
3781 gfc_add_expr_to_block (&se->pre, tmp);
3785 cm = expr->ts.derived->components;
3787 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3789 /* Skip absent members in default initializers and allocatable
3790 components. Although the latter have a default initializer
3791 of EXPR_NULL,... by default, the static nullify is not needed
3792 since this is done every time we come into scope. */
3793 if (!c->expr || cm->attr.allocatable)
3796 val = gfc_conv_initializer (c->expr, &cm->ts,
3797 TREE_TYPE (cm->backend_decl), cm->attr.dimension, cm->attr.pointer);
3799 /* Append it to the constructor list. */
3800 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3802 se->expr = build_constructor (type, v);
3804 TREE_CONSTANT (se->expr) = 1;
3808 /* Translate a substring expression. */
3811 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3817 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3819 se->expr = gfc_build_wide_string_const (expr->ts.kind,
3820 expr->value.character.length,
3821 expr->value.character.string);
3823 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3824 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3827 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3831 /* Entry point for expression translation. Evaluates a scalar quantity.
3832 EXPR is the expression to be translated, and SE is the state structure if
3833 called from within the scalarized. */
3836 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3838 if (se->ss && se->ss->expr == expr
3839 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3841 /* Substitute a scalar expression evaluated outside the scalarization
3843 se->expr = se->ss->data.scalar.expr;
3844 se->string_length = se->ss->string_length;
3845 gfc_advance_se_ss_chain (se);
3849 /* We need to convert the expressions for the iso_c_binding derived types.
3850 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3851 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3852 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3853 updated to be an integer with a kind equal to the size of a (void *). */
3854 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3855 && expr->ts.derived->attr.is_iso_c)
3857 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3858 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3860 /* Set expr_type to EXPR_NULL, which will result in
3861 null_pointer_node being used below. */
3862 expr->expr_type = EXPR_NULL;
3866 /* Update the type/kind of the expression to be what the new
3867 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3868 expr->ts.type = expr->ts.derived->ts.type;
3869 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3870 expr->ts.kind = expr->ts.derived->ts.kind;
3874 switch (expr->expr_type)
3877 gfc_conv_expr_op (se, expr);
3881 gfc_conv_function_expr (se, expr);
3885 gfc_conv_constant (se, expr);
3889 gfc_conv_variable (se, expr);
3893 se->expr = null_pointer_node;
3896 case EXPR_SUBSTRING:
3897 gfc_conv_substring_expr (se, expr);
3900 case EXPR_STRUCTURE:
3901 gfc_conv_structure (se, expr, 0);
3905 gfc_conv_array_constructor_expr (se, expr);
3914 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3915 of an assignment. */
3917 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3919 gfc_conv_expr (se, expr);
3920 /* All numeric lvalues should have empty post chains. If not we need to
3921 figure out a way of rewriting an lvalue so that it has no post chain. */
3922 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3925 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3926 numeric expressions. Used for scalar values where inserting cleanup code
3929 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3933 gcc_assert (expr->ts.type != BT_CHARACTER);
3934 gfc_conv_expr (se, expr);
3937 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3938 gfc_add_modify (&se->pre, val, se->expr);
3940 gfc_add_block_to_block (&se->pre, &se->post);
3944 /* Helper to translate an expression and convert it to a particular type. */
3946 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3948 gfc_conv_expr_val (se, expr);
3949 se->expr = convert (type, se->expr);
3953 /* Converts an expression so that it can be passed by reference. Scalar
3957 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3961 if (se->ss && se->ss->expr == expr
3962 && se->ss->type == GFC_SS_REFERENCE)
3964 se->expr = se->ss->data.scalar.expr;
3965 se->string_length = se->ss->string_length;
3966 gfc_advance_se_ss_chain (se);
3970 if (expr->ts.type == BT_CHARACTER)
3972 gfc_conv_expr (se, expr);
3973 gfc_conv_string_parameter (se);
3977 if (expr->expr_type == EXPR_VARIABLE)
3979 se->want_pointer = 1;
3980 gfc_conv_expr (se, expr);
3983 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3984 gfc_add_modify (&se->pre, var, se->expr);
3985 gfc_add_block_to_block (&se->pre, &se->post);
3991 if (expr->expr_type == EXPR_FUNCTION
3992 && expr->symtree->n.sym->attr.pointer
3993 && !expr->symtree->n.sym->attr.dimension)
3995 se->want_pointer = 1;
3996 gfc_conv_expr (se, expr);
3997 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3998 gfc_add_modify (&se->pre, var, se->expr);
4004 gfc_conv_expr (se, expr);
4006 /* Create a temporary var to hold the value. */
4007 if (TREE_CONSTANT (se->expr))
4009 tree tmp = se->expr;
4010 STRIP_TYPE_NOPS (tmp);
4011 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
4012 DECL_INITIAL (var) = tmp;
4013 TREE_STATIC (var) = 1;
4018 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
4019 gfc_add_modify (&se->pre, var, se->expr);
4021 gfc_add_block_to_block (&se->pre, &se->post);
4023 /* Take the address of that value. */
4024 se->expr = gfc_build_addr_expr (NULL_TREE, var);
4029 gfc_trans_pointer_assign (gfc_code * code)
4031 return gfc_trans_pointer_assignment (code->expr, code->expr2);
4035 /* Generate code for a pointer assignment. */
4038 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
4049 gfc_start_block (&block);
4051 gfc_init_se (&lse, NULL);
4053 lss = gfc_walk_expr (expr1);
4054 rss = gfc_walk_expr (expr2);
4055 if (lss == gfc_ss_terminator)
4057 /* Scalar pointers. */
4058 lse.want_pointer = 1;
4059 gfc_conv_expr (&lse, expr1);
4060 gcc_assert (rss == gfc_ss_terminator);
4061 gfc_init_se (&rse, NULL);
4062 rse.want_pointer = 1;
4063 gfc_conv_expr (&rse, expr2);
4065 if (expr1->symtree->n.sym->attr.proc_pointer
4066 && expr1->symtree->n.sym->attr.dummy)
4067 lse.expr = build_fold_indirect_ref (lse.expr);
4069 gfc_add_block_to_block (&block, &lse.pre);
4070 gfc_add_block_to_block (&block, &rse.pre);
4072 /* Check character lengths if character expression. The test is only
4073 really added if -fbounds-check is enabled. */
4074 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4076 gcc_assert (expr2->ts.type == BT_CHARACTER);
4077 gcc_assert (lse.string_length && rse.string_length);
4078 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4079 lse.string_length, rse.string_length,
4083 gfc_add_modify (&block, lse.expr,
4084 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4086 gfc_add_block_to_block (&block, &rse.post);
4087 gfc_add_block_to_block (&block, &lse.post);
4092 tree strlen_rhs = NULL_TREE;
4094 /* Array pointer. */
4095 gfc_conv_expr_descriptor (&lse, expr1, lss);
4096 strlen_lhs = lse.string_length;
4097 switch (expr2->expr_type)
4100 /* Just set the data pointer to null. */
4101 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4105 /* Assign directly to the pointer's descriptor. */
4106 lse.direct_byref = 1;
4107 gfc_conv_expr_descriptor (&lse, expr2, rss);
4108 strlen_rhs = lse.string_length;
4110 /* If this is a subreference array pointer assignment, use the rhs
4111 descriptor element size for the lhs span. */
4112 if (expr1->symtree->n.sym->attr.subref_array_pointer)
4114 decl = expr1->symtree->n.sym->backend_decl;
4115 gfc_init_se (&rse, NULL);
4116 rse.descriptor_only = 1;
4117 gfc_conv_expr (&rse, expr2);
4118 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
4119 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
4120 if (!INTEGER_CST_P (tmp))
4121 gfc_add_block_to_block (&lse.post, &rse.pre);
4122 gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4128 /* Assign to a temporary descriptor and then copy that
4129 temporary to the pointer. */
4131 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4134 lse.direct_byref = 1;
4135 gfc_conv_expr_descriptor (&lse, expr2, rss);
4136 strlen_rhs = lse.string_length;
4137 gfc_add_modify (&lse.pre, desc, tmp);
4141 gfc_add_block_to_block (&block, &lse.pre);
4143 /* Check string lengths if applicable. The check is only really added
4144 to the output code if -fbounds-check is enabled. */
4145 if (expr1->ts.type == BT_CHARACTER && expr2->expr_type != EXPR_NULL)
4147 gcc_assert (expr2->ts.type == BT_CHARACTER);
4148 gcc_assert (strlen_lhs && strlen_rhs);
4149 gfc_trans_same_strlen_check ("pointer assignment", &expr1->where,
4150 strlen_lhs, strlen_rhs, &block);
4153 gfc_add_block_to_block (&block, &lse.post);
4155 return gfc_finish_block (&block);
4159 /* Makes sure se is suitable for passing as a function string parameter. */
4160 /* TODO: Need to check all callers of this function. It may be abused. */
4163 gfc_conv_string_parameter (gfc_se * se)
4167 if (TREE_CODE (se->expr) == STRING_CST)
4169 type = TREE_TYPE (TREE_TYPE (se->expr));
4170 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4174 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
4176 if (TREE_CODE (se->expr) != INDIRECT_REF)
4178 type = TREE_TYPE (se->expr);
4179 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
4183 type = gfc_get_character_type_len (gfc_default_character_kind,
4185 type = build_pointer_type (type);
4186 se->expr = gfc_build_addr_expr (type, se->expr);
4190 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
4191 gcc_assert (se->string_length
4192 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
4196 /* Generate code for assignment of scalar variables. Includes character
4197 strings and derived types with allocatable components. */
4200 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
4201 bool l_is_temp, bool r_is_var)
4207 gfc_init_block (&block);
4209 if (ts.type == BT_CHARACTER)
4214 if (lse->string_length != NULL_TREE)
4216 gfc_conv_string_parameter (lse);
4217 gfc_add_block_to_block (&block, &lse->pre);
4218 llen = lse->string_length;
4221 if (rse->string_length != NULL_TREE)
4223 gcc_assert (rse->string_length != NULL_TREE);
4224 gfc_conv_string_parameter (rse);
4225 gfc_add_block_to_block (&block, &rse->pre);
4226 rlen = rse->string_length;
4229 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4230 rse->expr, ts.kind);
4232 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
4236 /* Are the rhs and the lhs the same? */
4239 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4240 gfc_build_addr_expr (NULL_TREE, lse->expr),
4241 gfc_build_addr_expr (NULL_TREE, rse->expr));
4242 cond = gfc_evaluate_now (cond, &lse->pre);
4245 /* Deallocate the lhs allocated components as long as it is not
4246 the same as the rhs. This must be done following the assignment
4247 to prevent deallocating data that could be used in the rhs
4251 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4252 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
4254 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4255 gfc_add_expr_to_block (&lse->post, tmp);
4258 gfc_add_block_to_block (&block, &rse->pre);
4259 gfc_add_block_to_block (&block, &lse->pre);
4261 gfc_add_modify (&block, lse->expr,
4262 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4264 /* Do a deep copy if the rhs is a variable, if it is not the
4268 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
4269 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4270 gfc_add_expr_to_block (&block, tmp);
4275 gfc_add_block_to_block (&block, &lse->pre);
4276 gfc_add_block_to_block (&block, &rse->pre);
4278 gfc_add_modify (&block, lse->expr,
4279 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4282 gfc_add_block_to_block (&block, &lse->post);
4283 gfc_add_block_to_block (&block, &rse->post);
4285 return gfc_finish_block (&block);
4289 /* Try to translate array(:) = func (...), where func is a transformational
4290 array function, without using a temporary. Returns NULL is this isn't the
4294 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4299 bool seen_array_ref;
4301 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4302 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4305 /* Elemental functions don't need a temporary anyway. */
4306 if (expr2->value.function.esym != NULL
4307 && expr2->value.function.esym->attr.elemental)
4310 /* Fail if EXPR1 can't be expressed as a descriptor. */
4311 if (gfc_ref_needs_temporary_p (expr1->ref))
4314 /* Functions returning pointers need temporaries. */
4315 if (expr2->symtree->n.sym->attr.pointer
4316 || expr2->symtree->n.sym->attr.allocatable)
4319 /* Character array functions need temporaries unless the
4320 character lengths are the same. */
4321 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4323 if (expr1->ts.cl->length == NULL
4324 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
4327 if (expr2->ts.cl->length == NULL
4328 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
4331 if (mpz_cmp (expr1->ts.cl->length->value.integer,
4332 expr2->ts.cl->length->value.integer) != 0)
4336 /* Check that no LHS component references appear during an array
4337 reference. This is needed because we do not have the means to
4338 span any arbitrary stride with an array descriptor. This check
4339 is not needed for the rhs because the function result has to be
4341 seen_array_ref = false;
4342 for (ref = expr1->ref; ref; ref = ref->next)
4344 if (ref->type == REF_ARRAY)
4345 seen_array_ref= true;
4346 else if (ref->type == REF_COMPONENT && seen_array_ref)
4350 /* Check for a dependency. */
4351 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4352 expr2->value.function.esym,
4353 expr2->value.function.actual,
4357 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4359 gcc_assert (expr2->value.function.isym
4360 || (gfc_return_by_reference (expr2->value.function.esym)
4361 && expr2->value.function.esym->result->attr.dimension));
4363 ss = gfc_walk_expr (expr1);
4364 gcc_assert (ss != gfc_ss_terminator);
4365 gfc_init_se (&se, NULL);
4366 gfc_start_block (&se.pre);
4367 se.want_pointer = 1;
4369 gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
4371 se.direct_byref = 1;
4372 se.ss = gfc_walk_expr (expr2);
4373 gcc_assert (se.ss != gfc_ss_terminator);
4374 gfc_conv_function_expr (&se, expr2);
4375 gfc_add_block_to_block (&se.pre, &se.post);
4377 return gfc_finish_block (&se.pre);
4380 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4383 is_zero_initializer_p (gfc_expr * expr)
4385 if (expr->expr_type != EXPR_CONSTANT)
4388 /* We ignore constants with prescribed memory representations for now. */
4389 if (expr->representation.string)
4392 switch (expr->ts.type)
4395 return mpz_cmp_si (expr->value.integer, 0) == 0;
4398 return mpfr_zero_p (expr->value.real)
4399 && MPFR_SIGN (expr->value.real) >= 0;
4402 return expr->value.logical == 0;
4405 return mpfr_zero_p (expr->value.complex.r)
4406 && MPFR_SIGN (expr->value.complex.r) >= 0
4407 && mpfr_zero_p (expr->value.complex.i)
4408 && MPFR_SIGN (expr->value.complex.i) >= 0;
4416 /* Try to efficiently translate array(:) = 0. Return NULL if this
4420 gfc_trans_zero_assign (gfc_expr * expr)
4422 tree dest, len, type;
4426 sym = expr->symtree->n.sym;
4427 dest = gfc_get_symbol_decl (sym);
4429 type = TREE_TYPE (dest);
4430 if (POINTER_TYPE_P (type))
4431 type = TREE_TYPE (type);
4432 if (!GFC_ARRAY_TYPE_P (type))
4435 /* Determine the length of the array. */
4436 len = GFC_TYPE_ARRAY_SIZE (type);
4437 if (!len || TREE_CODE (len) != INTEGER_CST)
4440 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4441 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4442 fold_convert (gfc_array_index_type, tmp));
4444 /* Convert arguments to the correct types. */
4445 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4446 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4448 dest = fold_convert (pvoid_type_node, dest);
4449 len = fold_convert (size_type_node, len);
4451 /* Construct call to __builtin_memset. */
4452 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
4453 3, dest, integer_zero_node, len);
4454 return fold_convert (void_type_node, tmp);
4458 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4459 that constructs the call to __builtin_memcpy. */
4462 gfc_build_memcpy_call (tree dst, tree src, tree len)
4466 /* Convert arguments to the correct types. */
4467 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4468 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4470 dst = fold_convert (pvoid_type_node, dst);
4472 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4473 src = gfc_build_addr_expr (pvoid_type_node, src);
4475 src = fold_convert (pvoid_type_node, src);
4477 len = fold_convert (size_type_node, len);
4479 /* Construct call to __builtin_memcpy. */
4480 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4481 return fold_convert (void_type_node, tmp);
4485 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4486 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4487 source/rhs, both are gfc_full_array_ref_p which have been checked for
4491 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4493 tree dst, dlen, dtype;
4494 tree src, slen, stype;
4497 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4498 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4500 dtype = TREE_TYPE (dst);
4501 if (POINTER_TYPE_P (dtype))
4502 dtype = TREE_TYPE (dtype);
4503 stype = TREE_TYPE (src);
4504 if (POINTER_TYPE_P (stype))
4505 stype = TREE_TYPE (stype);
4507 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4510 /* Determine the lengths of the arrays. */
4511 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4512 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4514 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4515 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4516 fold_convert (gfc_array_index_type, tmp));
4518 slen = GFC_TYPE_ARRAY_SIZE (stype);
4519 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4521 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4522 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4523 fold_convert (gfc_array_index_type, tmp));
4525 /* Sanity check that they are the same. This should always be
4526 the case, as we should already have checked for conformance. */
4527 if (!tree_int_cst_equal (slen, dlen))
4530 return gfc_build_memcpy_call (dst, src, dlen);
4534 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4535 this can't be done. EXPR1 is the destination/lhs for which
4536 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4539 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4541 unsigned HOST_WIDE_INT nelem;
4547 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4551 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4552 dtype = TREE_TYPE (dst);
4553 if (POINTER_TYPE_P (dtype))
4554 dtype = TREE_TYPE (dtype);
4555 if (!GFC_ARRAY_TYPE_P (dtype))
4558 /* Determine the lengths of the array. */
4559 len = GFC_TYPE_ARRAY_SIZE (dtype);
4560 if (!len || TREE_CODE (len) != INTEGER_CST)
4563 /* Confirm that the constructor is the same size. */
4564 if (compare_tree_int (len, nelem) != 0)
4567 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4568 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4569 fold_convert (gfc_array_index_type, tmp));
4571 stype = gfc_typenode_for_spec (&expr2->ts);
4572 src = gfc_build_constant_array_constructor (expr2, stype);
4574 stype = TREE_TYPE (src);
4575 if (POINTER_TYPE_P (stype))
4576 stype = TREE_TYPE (stype);
4578 return gfc_build_memcpy_call (dst, src, len);
4582 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4583 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4586 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4591 gfc_ss *lss_section;
4598 bool scalar_to_array;
4601 /* Assignment of the form lhs = rhs. */
4602 gfc_start_block (&block);
4604 gfc_init_se (&lse, NULL);
4605 gfc_init_se (&rse, NULL);
4608 lss = gfc_walk_expr (expr1);
4610 if (lss != gfc_ss_terminator)
4612 /* Allow the scalarizer to workshare array assignments. */
4613 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4614 ompws_flags |= OMPWS_SCALARIZER_WS;
4616 /* The assignment needs scalarization. */
4619 /* Find a non-scalar SS from the lhs. */
4620 while (lss_section != gfc_ss_terminator
4621 && lss_section->type != GFC_SS_SECTION)
4622 lss_section = lss_section->next;
4624 gcc_assert (lss_section != gfc_ss_terminator);
4626 /* Initialize the scalarizer. */
4627 gfc_init_loopinfo (&loop);
4630 rss = gfc_walk_expr (expr2);
4631 if (rss == gfc_ss_terminator)
4633 /* The rhs is scalar. Add a ss for the expression. */
4634 rss = gfc_get_ss ();
4635 rss->next = gfc_ss_terminator;
4636 rss->type = GFC_SS_SCALAR;
4639 /* Associate the SS with the loop. */
4640 gfc_add_ss_to_loop (&loop, lss);
4641 gfc_add_ss_to_loop (&loop, rss);
4643 /* Calculate the bounds of the scalarization. */
4644 gfc_conv_ss_startstride (&loop);
4645 /* Resolve any data dependencies in the statement. */
4646 gfc_conv_resolve_dependencies (&loop, lss, rss);
4647 /* Setup the scalarizing loops. */
4648 gfc_conv_loop_setup (&loop, &expr2->where);
4650 /* Setup the gfc_se structures. */
4651 gfc_copy_loopinfo_to_se (&lse, &loop);
4652 gfc_copy_loopinfo_to_se (&rse, &loop);
4655 gfc_mark_ss_chain_used (rss, 1);
4656 if (loop.temp_ss == NULL)
4659 gfc_mark_ss_chain_used (lss, 1);
4663 lse.ss = loop.temp_ss;
4664 gfc_mark_ss_chain_used (lss, 3);
4665 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4668 /* Start the scalarized loop body. */
4669 gfc_start_scalarized_body (&loop, &body);
4672 gfc_init_block (&body);
4674 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4676 /* Translate the expression. */
4677 gfc_conv_expr (&rse, expr2);
4679 /* Stabilize a string length for temporaries. */
4680 if (expr2->ts.type == BT_CHARACTER)
4681 string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
4683 string_length = NULL_TREE;
4687 gfc_conv_tmp_array_ref (&lse);
4688 gfc_advance_se_ss_chain (&lse);
4689 if (expr2->ts.type == BT_CHARACTER)
4690 lse.string_length = string_length;
4693 gfc_conv_expr (&lse, expr1);
4695 /* Assignments of scalar derived types with allocatable components
4696 to arrays must be done with a deep copy and the rhs temporary
4697 must have its components deallocated afterwards. */
4698 scalar_to_array = (expr2->ts.type == BT_DERIVED
4699 && expr2->ts.derived->attr.alloc_comp
4700 && expr2->expr_type != EXPR_VARIABLE
4701 && !gfc_is_constant_expr (expr2)
4702 && expr1->rank && !expr2->rank);
4703 if (scalar_to_array)
4705 tmp = gfc_deallocate_alloc_comp (expr2->ts.derived, rse.expr, 0);
4706 gfc_add_expr_to_block (&loop.post, tmp);
4709 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4710 l_is_temp || init_flag,
4711 (expr2->expr_type == EXPR_VARIABLE)
4712 || scalar_to_array);
4713 gfc_add_expr_to_block (&body, tmp);
4715 if (lss == gfc_ss_terminator)
4717 /* Use the scalar assignment as is. */
4718 gfc_add_block_to_block (&block, &body);
4722 gcc_assert (lse.ss == gfc_ss_terminator
4723 && rse.ss == gfc_ss_terminator);
4727 gfc_trans_scalarized_loop_boundary (&loop, &body);
4729 /* We need to copy the temporary to the actual lhs. */
4730 gfc_init_se (&lse, NULL);
4731 gfc_init_se (&rse, NULL);
4732 gfc_copy_loopinfo_to_se (&lse, &loop);
4733 gfc_copy_loopinfo_to_se (&rse, &loop);
4735 rse.ss = loop.temp_ss;
4738 gfc_conv_tmp_array_ref (&rse);
4739 gfc_advance_se_ss_chain (&rse);
4740 gfc_conv_expr (&lse, expr1);
4742 gcc_assert (lse.ss == gfc_ss_terminator
4743 && rse.ss == gfc_ss_terminator);
4745 if (expr2->ts.type == BT_CHARACTER)
4746 rse.string_length = string_length;
4748 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4750 gfc_add_expr_to_block (&body, tmp);
4753 /* Generate the copying loops. */
4754 gfc_trans_scalarizing_loops (&loop, &body);
4756 /* Wrap the whole thing up. */
4757 gfc_add_block_to_block (&block, &loop.pre);
4758 gfc_add_block_to_block (&block, &loop.post);
4760 gfc_cleanup_loop (&loop);
4763 return gfc_finish_block (&block);
4767 /* Check whether EXPR is a copyable array. */
4770 copyable_array_p (gfc_expr * expr)
4772 if (expr->expr_type != EXPR_VARIABLE)
4775 /* First check it's an array. */
4776 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4779 if (!gfc_full_array_ref_p (expr->ref))
4782 /* Next check that it's of a simple enough type. */
4783 switch (expr->ts.type)
4795 return !expr->ts.derived->attr.alloc_comp;
4804 /* Translate an assignment. */
4807 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4811 /* Special case a single function returning an array. */
4812 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4814 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4819 /* Special case assigning an array to zero. */
4820 if (copyable_array_p (expr1)
4821 && is_zero_initializer_p (expr2))
4823 tmp = gfc_trans_zero_assign (expr1);
4828 /* Special case copying one array to another. */
4829 if (copyable_array_p (expr1)
4830 && copyable_array_p (expr2)
4831 && gfc_compare_types (&expr1->ts, &expr2->ts)
4832 && !gfc_check_dependency (expr1, expr2, 0))
4834 tmp = gfc_trans_array_copy (expr1, expr2);
4839 /* Special case initializing an array from a constant array constructor. */
4840 if (copyable_array_p (expr1)
4841 && expr2->expr_type == EXPR_ARRAY
4842 && gfc_compare_types (&expr1->ts, &expr2->ts))
4844 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4849 /* Fallback to the scalarizer to generate explicit loops. */
4850 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4854 gfc_trans_init_assign (gfc_code * code)
4856 return gfc_trans_assignment (code->expr, code->expr2, true);
4860 gfc_trans_assign (gfc_code * code)
4862 return gfc_trans_assignment (code->expr, code->expr2, false);