1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
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"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
42 #include "trans-stmt.h"
43 #include "dependency.h"
45 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
46 static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
49 /* Copy the scalarization loop variables. */
52 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
55 dest->loop = src->loop;
59 /* Initialize a simple expression holder.
61 Care must be taken when multiple se are created with the same parent.
62 The child se must be kept in sync. The easiest way is to delay creation
63 of a child se until after after the previous se has been translated. */
66 gfc_init_se (gfc_se * se, gfc_se * parent)
68 memset (se, 0, sizeof (gfc_se));
69 gfc_init_block (&se->pre);
70 gfc_init_block (&se->post);
75 gfc_copy_se_loopvars (se, parent);
79 /* Advances to the next SS in the chain. Use this rather than setting
80 se->ss = se->ss->next because all the parents needs to be kept in sync.
84 gfc_advance_se_ss_chain (gfc_se * se)
88 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
91 /* Walk down the parent chain. */
94 /* Simple consistency check. */
95 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
104 /* Ensures the result of the expression as either a temporary variable
105 or a constant so that it can be used repeatedly. */
108 gfc_make_safe_expr (gfc_se * se)
112 if (CONSTANT_CLASS_P (se->expr))
115 /* We need a temporary for this result. */
116 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
117 gfc_add_modify_expr (&se->pre, var, se->expr);
122 /* Return an expression which determines if a dummy parameter is present.
123 Also used for arguments to procedures with multiple entry points. */
126 gfc_conv_expr_present (gfc_symbol * sym)
130 gcc_assert (sym->attr.dummy);
132 decl = gfc_get_symbol_decl (sym);
133 if (TREE_CODE (decl) != PARM_DECL)
135 /* Array parameters use a temporary descriptor, we want the real
137 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
138 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
139 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
141 return build2 (NE_EXPR, boolean_type_node, decl,
142 fold_convert (TREE_TYPE (decl), null_pointer_node));
146 /* Converts a missing, dummy argument into a null or zero. */
149 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
154 present = gfc_conv_expr_present (arg->symtree->n.sym);
155 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
156 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
158 tmp = gfc_evaluate_now (tmp, &se->pre);
160 if (ts.type == BT_CHARACTER)
162 tmp = build_int_cst (gfc_charlen_type_node, 0);
163 tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
164 se->string_length, tmp);
165 tmp = gfc_evaluate_now (tmp, &se->pre);
166 se->string_length = tmp;
172 /* Get the character length of an expression, looking through gfc_refs
176 gfc_get_expr_charlen (gfc_expr *e)
181 gcc_assert (e->expr_type == EXPR_VARIABLE
182 && e->ts.type == BT_CHARACTER);
184 length = NULL; /* To silence compiler warning. */
186 /* First candidate: if the variable is of type CHARACTER, the
187 expression's length could be the length of the character
189 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
190 length = e->symtree->n.sym->ts.cl->backend_decl;
192 /* Look through the reference chain for component references. */
193 for (r = e->ref; r; r = r->next)
198 if (r->u.c.component->ts.type == BT_CHARACTER)
199 length = r->u.c.component->ts.cl->backend_decl;
207 /* We should never got substring references here. These will be
208 broken down by the scalarizer. */
213 gcc_assert (length != NULL);
219 /* Generate code to initialize a string length variable. Returns the
223 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
228 gfc_init_se (&se, NULL);
229 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
230 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
231 build_int_cst (gfc_charlen_type_node, 0));
232 gfc_add_block_to_block (pblock, &se.pre);
234 tmp = cl->backend_decl;
235 gfc_add_modify_expr (pblock, tmp, se.expr);
240 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
241 const char *name, locus *where)
251 type = gfc_get_character_type (kind, ref->u.ss.length);
252 type = build_pointer_type (type);
255 gfc_init_se (&start, se);
256 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
257 gfc_add_block_to_block (&se->pre, &start.pre);
259 if (integer_onep (start.expr))
260 gfc_conv_string_parameter (se);
263 /* Avoid multiple evaluation of substring start. */
264 if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
265 start.expr = gfc_evaluate_now (start.expr, &se->pre);
267 /* Change the start of the string. */
268 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
271 tmp = build_fold_indirect_ref (se->expr);
272 tmp = gfc_build_array_ref (tmp, start.expr);
273 se->expr = gfc_build_addr_expr (type, tmp);
276 /* Length = end + 1 - start. */
277 gfc_init_se (&end, se);
278 if (ref->u.ss.end == NULL)
279 end.expr = se->string_length;
282 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
283 gfc_add_block_to_block (&se->pre, &end.pre);
285 if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
286 end.expr = gfc_evaluate_now (end.expr, &se->pre);
288 if (flag_bounds_check)
290 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
291 start.expr, end.expr);
293 /* Check lower bound. */
294 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
295 build_int_cst (gfc_charlen_type_node, 1));
296 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
299 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
300 "is less than one", name);
302 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
304 gfc_trans_runtime_check (fault, &se->pre, where, msg,
305 fold_convert (long_integer_type_node,
309 /* Check upper bound. */
310 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
312 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
315 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
316 "exceeds string length (%%ld)", name);
318 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
319 "exceeds string length (%%ld)");
320 gfc_trans_runtime_check (fault, &se->pre, where, msg,
321 fold_convert (long_integer_type_node, end.expr),
322 fold_convert (long_integer_type_node,
327 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
328 build_int_cst (gfc_charlen_type_node, 1),
330 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
331 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
332 build_int_cst (gfc_charlen_type_node, 0));
333 se->string_length = tmp;
337 /* Convert a derived type component reference. */
340 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
347 c = ref->u.c.component;
349 gcc_assert (c->backend_decl);
351 field = c->backend_decl;
352 gcc_assert (TREE_CODE (field) == FIELD_DECL);
354 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
358 if (c->ts.type == BT_CHARACTER)
360 tmp = c->ts.cl->backend_decl;
361 /* Components must always be constant length. */
362 gcc_assert (tmp && INTEGER_CST_P (tmp));
363 se->string_length = tmp;
366 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
367 se->expr = build_fold_indirect_ref (se->expr);
371 /* Return the contents of a variable. Also handles reference/pointer
372 variables (all Fortran pointer references are implicit). */
375 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
382 bool alternate_entry;
385 sym = expr->symtree->n.sym;
388 /* Check that something hasn't gone horribly wrong. */
389 gcc_assert (se->ss != gfc_ss_terminator);
390 gcc_assert (se->ss->expr == expr);
392 /* A scalarized term. We already know the descriptor. */
393 se->expr = se->ss->data.info.descriptor;
394 se->string_length = se->ss->string_length;
395 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
396 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
401 tree se_expr = NULL_TREE;
403 se->expr = gfc_get_symbol_decl (sym);
405 /* Deal with references to a parent results or entries by storing
406 the current_function_decl and moving to the parent_decl. */
407 return_value = sym->attr.function && sym->result == sym;
408 alternate_entry = sym->attr.function && sym->attr.entry
409 && sym->result == sym;
410 entry_master = sym->attr.result
411 && sym->ns->proc_name->attr.entry_master
412 && !gfc_return_by_reference (sym->ns->proc_name);
413 parent_decl = DECL_CONTEXT (current_function_decl);
415 if ((se->expr == parent_decl && return_value)
416 || (sym->ns && sym->ns->proc_name
418 && sym->ns->proc_name->backend_decl == parent_decl
419 && (alternate_entry || entry_master)))
424 /* Special case for assigning the return value of a function.
425 Self recursive functions must have an explicit return value. */
426 if (return_value && (se->expr == current_function_decl || parent_flag))
427 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
429 /* Similarly for alternate entry points. */
430 else if (alternate_entry
431 && (sym->ns->proc_name->backend_decl == current_function_decl
434 gfc_entry_list *el = NULL;
436 for (el = sym->ns->entries; el; el = el->next)
439 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
444 else if (entry_master
445 && (sym->ns->proc_name->backend_decl == current_function_decl
447 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
452 /* Procedure actual arguments. */
453 else if (sym->attr.flavor == FL_PROCEDURE
454 && se->expr != current_function_decl)
456 gcc_assert (se->want_pointer);
457 if (!sym->attr.dummy)
459 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
460 se->expr = build_fold_addr_expr (se->expr);
466 /* Dereference the expression, where needed. Since characters
467 are entirely different from other types, they are treated
469 if (sym->ts.type == BT_CHARACTER)
471 /* Dereference character pointer dummy arguments
473 if ((sym->attr.pointer || sym->attr.allocatable)
475 || sym->attr.function
476 || sym->attr.result))
477 se->expr = build_fold_indirect_ref (se->expr);
480 else if (!sym->attr.value)
482 /* Dereference non-character scalar dummy arguments. */
483 if (sym->attr.dummy && !sym->attr.dimension)
484 se->expr = build_fold_indirect_ref (se->expr);
486 /* Dereference scalar hidden result. */
487 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
488 && (sym->attr.function || sym->attr.result)
489 && !sym->attr.dimension && !sym->attr.pointer)
490 se->expr = build_fold_indirect_ref (se->expr);
492 /* Dereference non-character pointer variables.
493 These must be dummies, results, or scalars. */
494 if ((sym->attr.pointer || sym->attr.allocatable)
496 || sym->attr.function
498 || !sym->attr.dimension))
499 se->expr = build_fold_indirect_ref (se->expr);
505 /* For character variables, also get the length. */
506 if (sym->ts.type == BT_CHARACTER)
508 /* If the character length of an entry isn't set, get the length from
509 the master function instead. */
510 if (sym->attr.entry && !sym->ts.cl->backend_decl)
511 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
513 se->string_length = sym->ts.cl->backend_decl;
514 gcc_assert (se->string_length);
522 /* Return the descriptor if that's what we want and this is an array
523 section reference. */
524 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
526 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
527 /* Return the descriptor for array pointers and allocations. */
529 && ref->next == NULL && (se->descriptor_only))
532 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
533 /* Return a pointer to an element. */
537 gfc_conv_component_ref (se, ref);
541 gfc_conv_substring (se, ref, expr->ts.kind,
542 expr->symtree->name, &expr->where);
551 /* Pointer assignment, allocation or pass by reference. Arrays are handled
553 if (se->want_pointer)
555 if (expr->ts.type == BT_CHARACTER)
556 gfc_conv_string_parameter (se);
558 se->expr = build_fold_addr_expr (se->expr);
563 /* Unary ops are easy... Or they would be if ! was a valid op. */
566 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
571 gcc_assert (expr->ts.type != BT_CHARACTER);
572 /* Initialize the operand. */
573 gfc_init_se (&operand, se);
574 gfc_conv_expr_val (&operand, expr->value.op.op1);
575 gfc_add_block_to_block (&se->pre, &operand.pre);
577 type = gfc_typenode_for_spec (&expr->ts);
579 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
580 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
581 All other unary operators have an equivalent GIMPLE unary operator. */
582 if (code == TRUTH_NOT_EXPR)
583 se->expr = build2 (EQ_EXPR, type, operand.expr,
584 build_int_cst (type, 0));
586 se->expr = build1 (code, type, operand.expr);
590 /* Expand power operator to optimal multiplications when a value is raised
591 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
592 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
593 Programming", 3rd Edition, 1998. */
595 /* This code is mostly duplicated from expand_powi in the backend.
596 We establish the "optimal power tree" lookup table with the defined size.
597 The items in the table are the exponents used to calculate the index
598 exponents. Any integer n less than the value can get an "addition chain",
599 with the first node being one. */
600 #define POWI_TABLE_SIZE 256
602 /* The table is from builtins.c. */
603 static const unsigned char powi_table[POWI_TABLE_SIZE] =
605 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
606 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
607 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
608 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
609 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
610 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
611 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
612 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
613 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
614 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
615 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
616 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
617 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
618 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
619 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
620 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
621 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
622 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
623 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
624 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
625 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
626 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
627 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
628 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
629 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
630 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
631 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
632 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
633 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
634 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
635 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
636 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
639 /* If n is larger than lookup table's max index, we use the "window
641 #define POWI_WINDOW_SIZE 3
643 /* Recursive function to expand the power operator. The temporary
644 values are put in tmpvar. The function returns tmpvar[1] ** n. */
646 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
653 if (n < POWI_TABLE_SIZE)
658 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
659 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
663 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
664 op0 = gfc_conv_powi (se, n - digit, tmpvar);
665 op1 = gfc_conv_powi (se, digit, tmpvar);
669 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
673 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
674 tmp = gfc_evaluate_now (tmp, &se->pre);
676 if (n < POWI_TABLE_SIZE)
683 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
684 return 1. Else return 0 and a call to runtime library functions
685 will have to be built. */
687 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
692 tree vartmp[POWI_TABLE_SIZE];
694 unsigned HOST_WIDE_INT n;
697 /* If exponent is too large, we won't expand it anyway, so don't bother
698 with large integer values. */
699 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
702 m = double_int_to_shwi (TREE_INT_CST (rhs));
703 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
704 of the asymmetric range of the integer type. */
705 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
707 type = TREE_TYPE (lhs);
708 sgn = tree_int_cst_sgn (rhs);
710 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
711 || optimize_size) && (m > 2 || m < -1))
717 se->expr = gfc_build_const (type, integer_one_node);
721 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
722 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
724 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
725 build_int_cst (TREE_TYPE (lhs), -1));
726 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
727 build_int_cst (TREE_TYPE (lhs), 1));
730 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
733 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
734 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
735 build_int_cst (type, 0));
739 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
740 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
741 build_int_cst (type, 0));
742 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
746 memset (vartmp, 0, sizeof (vartmp));
750 tmp = gfc_build_const (type, integer_one_node);
751 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
754 se->expr = gfc_conv_powi (se, n, vartmp);
760 /* Power op (**). Constant integer exponent has special handling. */
763 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
765 tree gfc_int4_type_node;
772 gfc_init_se (&lse, se);
773 gfc_conv_expr_val (&lse, expr->value.op.op1);
774 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
775 gfc_add_block_to_block (&se->pre, &lse.pre);
777 gfc_init_se (&rse, se);
778 gfc_conv_expr_val (&rse, expr->value.op.op2);
779 gfc_add_block_to_block (&se->pre, &rse.pre);
781 if (expr->value.op.op2->ts.type == BT_INTEGER
782 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
783 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
786 gfc_int4_type_node = gfc_get_int_type (4);
788 kind = expr->value.op.op1->ts.kind;
789 switch (expr->value.op.op2->ts.type)
792 ikind = expr->value.op.op2->ts.kind;
797 rse.expr = convert (gfc_int4_type_node, rse.expr);
819 if (expr->value.op.op1->ts.type == BT_INTEGER)
820 lse.expr = convert (gfc_int4_type_node, lse.expr);
845 switch (expr->value.op.op1->ts.type)
848 if (kind == 3) /* Case 16 was not handled properly above. */
850 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
854 /* Use builtins for real ** int4. */
860 fndecl = built_in_decls[BUILT_IN_POWIF];
864 fndecl = built_in_decls[BUILT_IN_POWI];
869 fndecl = built_in_decls[BUILT_IN_POWIL];
877 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
881 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
893 fndecl = built_in_decls[BUILT_IN_POWF];
896 fndecl = built_in_decls[BUILT_IN_POW];
900 fndecl = built_in_decls[BUILT_IN_POWL];
911 fndecl = gfor_fndecl_math_cpowf;
914 fndecl = gfor_fndecl_math_cpow;
917 fndecl = gfor_fndecl_math_cpowl10;
920 fndecl = gfor_fndecl_math_cpowl16;
932 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
936 /* Generate code to allocate a string temporary. */
939 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
944 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
946 if (gfc_can_put_var_on_stack (len))
948 /* Create a temporary variable to hold the result. */
949 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
950 build_int_cst (gfc_charlen_type_node, 1));
951 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
952 tmp = build_array_type (gfc_character1_type_node, tmp);
953 var = gfc_create_var (tmp, "str");
954 var = gfc_build_addr_expr (type, var);
958 /* Allocate a temporary to hold the result. */
959 var = gfc_create_var (type, "pstr");
960 tmp = gfc_call_malloc (&se->pre, type, len);
961 gfc_add_modify_expr (&se->pre, var, tmp);
963 /* Free the temporary afterwards. */
964 tmp = gfc_call_free (convert (pvoid_type_node, var));
965 gfc_add_expr_to_block (&se->post, tmp);
972 /* Handle a string concatenation operation. A temporary will be allocated to
976 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
985 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
986 && expr->value.op.op2->ts.type == BT_CHARACTER);
988 gfc_init_se (&lse, se);
989 gfc_conv_expr (&lse, expr->value.op.op1);
990 gfc_conv_string_parameter (&lse);
991 gfc_init_se (&rse, se);
992 gfc_conv_expr (&rse, expr->value.op.op2);
993 gfc_conv_string_parameter (&rse);
995 gfc_add_block_to_block (&se->pre, &lse.pre);
996 gfc_add_block_to_block (&se->pre, &rse.pre);
998 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
999 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1000 if (len == NULL_TREE)
1002 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1003 lse.string_length, rse.string_length);
1006 type = build_pointer_type (type);
1008 var = gfc_conv_string_tmp (se, type, len);
1010 /* Do the actual concatenation. */
1011 tmp = build_call_expr (gfor_fndecl_concat_string, 6,
1013 lse.string_length, lse.expr,
1014 rse.string_length, rse.expr);
1015 gfc_add_expr_to_block (&se->pre, tmp);
1017 /* Add the cleanup for the operands. */
1018 gfc_add_block_to_block (&se->pre, &rse.post);
1019 gfc_add_block_to_block (&se->pre, &lse.post);
1022 se->string_length = len;
1025 /* Translates an op expression. Common (binary) cases are handled by this
1026 function, others are passed on. Recursion is used in either case.
1027 We use the fact that (op1.ts == op2.ts) (except for the power
1029 Operators need no special handling for scalarized expressions as long as
1030 they call gfc_conv_simple_val to get their operands.
1031 Character strings get special handling. */
1034 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1036 enum tree_code code;
1046 switch (expr->value.op.operator)
1048 case INTRINSIC_UPLUS:
1049 case INTRINSIC_PARENTHESES:
1050 gfc_conv_expr (se, expr->value.op.op1);
1053 case INTRINSIC_UMINUS:
1054 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1058 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1061 case INTRINSIC_PLUS:
1065 case INTRINSIC_MINUS:
1069 case INTRINSIC_TIMES:
1073 case INTRINSIC_DIVIDE:
1074 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1075 an integer, we must round towards zero, so we use a
1077 if (expr->ts.type == BT_INTEGER)
1078 code = TRUNC_DIV_EXPR;
1083 case INTRINSIC_POWER:
1084 gfc_conv_power_op (se, expr);
1087 case INTRINSIC_CONCAT:
1088 gfc_conv_concat_op (se, expr);
1092 code = TRUTH_ANDIF_EXPR;
1097 code = TRUTH_ORIF_EXPR;
1101 /* EQV and NEQV only work on logicals, but since we represent them
1102 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1104 case INTRINSIC_EQ_OS:
1112 case INTRINSIC_NE_OS:
1113 case INTRINSIC_NEQV:
1120 case INTRINSIC_GT_OS:
1127 case INTRINSIC_GE_OS:
1134 case INTRINSIC_LT_OS:
1141 case INTRINSIC_LE_OS:
1147 case INTRINSIC_USER:
1148 case INTRINSIC_ASSIGN:
1149 /* These should be converted into function calls by the frontend. */
1153 fatal_error ("Unknown intrinsic op");
1157 /* The only exception to this is **, which is handled separately anyway. */
1158 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1160 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1164 gfc_init_se (&lse, se);
1165 gfc_conv_expr (&lse, expr->value.op.op1);
1166 gfc_add_block_to_block (&se->pre, &lse.pre);
1169 gfc_init_se (&rse, se);
1170 gfc_conv_expr (&rse, expr->value.op.op2);
1171 gfc_add_block_to_block (&se->pre, &rse.pre);
1175 gfc_conv_string_parameter (&lse);
1176 gfc_conv_string_parameter (&rse);
1178 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1179 rse.string_length, rse.expr);
1180 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1181 gfc_add_block_to_block (&lse.post, &rse.post);
1184 type = gfc_typenode_for_spec (&expr->ts);
1188 /* The result of logical ops is always boolean_type_node. */
1189 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1190 se->expr = convert (type, tmp);
1193 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1195 /* Add the post blocks. */
1196 gfc_add_block_to_block (&se->post, &rse.post);
1197 gfc_add_block_to_block (&se->post, &lse.post);
1200 /* If a string's length is one, we convert it to a single character. */
1203 gfc_to_single_character (tree len, tree str)
1205 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1207 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1208 && TREE_INT_CST_HIGH (len) == 0)
1210 str = fold_convert (pchar_type_node, str);
1211 return build_fold_indirect_ref (str);
1219 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1222 if (sym->backend_decl)
1224 /* This becomes the nominal_type in
1225 function.c:assign_parm_find_data_types. */
1226 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1227 /* This becomes the passed_type in
1228 function.c:assign_parm_find_data_types. C promotes char to
1229 integer for argument passing. */
1230 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1232 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1237 /* If we have a constant character expression, make it into an
1239 if ((*expr)->expr_type == EXPR_CONSTANT)
1243 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1244 if ((*expr)->ts.kind != gfc_c_int_kind)
1246 /* The expr needs to be compatible with a C int. If the
1247 conversion fails, then the 2 causes an ICE. */
1248 ts.type = BT_INTEGER;
1249 ts.kind = gfc_c_int_kind;
1250 gfc_convert_type (*expr, &ts, 2);
1253 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1255 if ((*expr)->ref == NULL)
1257 se->expr = gfc_to_single_character
1258 (build_int_cst (integer_type_node, 1),
1259 gfc_build_addr_expr (pchar_type_node,
1261 ((*expr)->symtree->n.sym)));
1265 gfc_conv_variable (se, *expr);
1266 se->expr = gfc_to_single_character
1267 (build_int_cst (integer_type_node, 1),
1268 gfc_build_addr_expr (pchar_type_node, se->expr));
1275 /* Compare two strings. If they are all single characters, the result is the
1276 subtraction of them. Otherwise, we build a library call. */
1279 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1286 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1287 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1289 type = gfc_get_int_type (gfc_default_integer_kind);
1291 sc1 = gfc_to_single_character (len1, str1);
1292 sc2 = gfc_to_single_character (len2, str2);
1294 /* Deal with single character specially. */
1295 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1297 sc1 = fold_convert (type, sc1);
1298 sc2 = fold_convert (type, sc2);
1299 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1302 /* Build a call for the comparison. */
1303 tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1304 len1, str1, len2, str2);
1309 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1313 if (sym->attr.dummy)
1315 tmp = gfc_get_symbol_decl (sym);
1316 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1317 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1321 if (!sym->backend_decl)
1322 sym->backend_decl = gfc_get_extern_function_decl (sym);
1324 tmp = sym->backend_decl;
1325 if (sym->attr.cray_pointee)
1326 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1327 gfc_get_symbol_decl (sym->cp_pointer));
1328 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1330 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1331 tmp = build_fold_addr_expr (tmp);
1338 /* Translate the call for an elemental subroutine call used in an operator
1339 assignment. This is a simplified version of gfc_conv_function_call. */
1342 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1349 /* Only elemental subroutines with two arguments. */
1350 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1351 gcc_assert (sym->formal->next->next == NULL);
1353 gfc_init_block (&block);
1355 gfc_add_block_to_block (&block, &lse->pre);
1356 gfc_add_block_to_block (&block, &rse->pre);
1358 /* Build the argument list for the call, including hidden string lengths. */
1359 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1360 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1361 if (lse->string_length != NULL_TREE)
1362 args = gfc_chainon_list (args, lse->string_length);
1363 if (rse->string_length != NULL_TREE)
1364 args = gfc_chainon_list (args, rse->string_length);
1366 /* Build the function call. */
1367 gfc_init_se (&se, NULL);
1368 gfc_conv_function_val (&se, sym);
1369 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1370 tmp = build_call_list (tmp, se.expr, args);
1371 gfc_add_expr_to_block (&block, tmp);
1373 gfc_add_block_to_block (&block, &lse->post);
1374 gfc_add_block_to_block (&block, &rse->post);
1376 return gfc_finish_block (&block);
1380 /* Initialize MAPPING. */
1383 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1385 mapping->syms = NULL;
1386 mapping->charlens = NULL;
1390 /* Free all memory held by MAPPING (but not MAPPING itself). */
1393 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1395 gfc_interface_sym_mapping *sym;
1396 gfc_interface_sym_mapping *nextsym;
1398 gfc_charlen *nextcl;
1400 for (sym = mapping->syms; sym; sym = nextsym)
1402 nextsym = sym->next;
1403 gfc_free_symbol (sym->new->n.sym);
1404 gfc_free (sym->new);
1407 for (cl = mapping->charlens; cl; cl = nextcl)
1410 gfc_free_expr (cl->length);
1416 /* Return a copy of gfc_charlen CL. Add the returned structure to
1417 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1419 static gfc_charlen *
1420 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1425 new = gfc_get_charlen ();
1426 new->next = mapping->charlens;
1427 new->length = gfc_copy_expr (cl->length);
1429 mapping->charlens = new;
1434 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1435 array variable that can be used as the actual argument for dummy
1436 argument SYM. Add any initialization code to BLOCK. PACKED is as
1437 for gfc_get_nodesc_array_type and DATA points to the first element
1438 in the passed array. */
1441 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1442 gfc_packed packed, tree data)
1447 type = gfc_typenode_for_spec (&sym->ts);
1448 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1450 var = gfc_create_var (type, "ifm");
1451 gfc_add_modify_expr (block, var, fold_convert (type, data));
1457 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1458 and offset of descriptorless array type TYPE given that it has the same
1459 size as DESC. Add any set-up code to BLOCK. */
1462 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1469 offset = gfc_index_zero_node;
1470 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1472 dim = gfc_rank_cst[n];
1473 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1474 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1476 GFC_TYPE_ARRAY_LBOUND (type, n)
1477 = gfc_conv_descriptor_lbound (desc, dim);
1478 GFC_TYPE_ARRAY_UBOUND (type, n)
1479 = gfc_conv_descriptor_ubound (desc, dim);
1481 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1483 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1484 gfc_conv_descriptor_ubound (desc, dim),
1485 gfc_conv_descriptor_lbound (desc, dim));
1486 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1487 GFC_TYPE_ARRAY_LBOUND (type, n),
1489 tmp = gfc_evaluate_now (tmp, block);
1490 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1492 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1493 GFC_TYPE_ARRAY_LBOUND (type, n),
1494 GFC_TYPE_ARRAY_STRIDE (type, n));
1495 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1497 offset = gfc_evaluate_now (offset, block);
1498 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1502 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1503 in SE. The caller may still use se->expr and se->string_length after
1504 calling this function. */
1507 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1508 gfc_symbol * sym, gfc_se * se)
1510 gfc_interface_sym_mapping *sm;
1514 gfc_symbol *new_sym;
1516 gfc_symtree *new_symtree;
1518 /* Create a new symbol to represent the actual argument. */
1519 new_sym = gfc_new_symbol (sym->name, NULL);
1520 new_sym->ts = sym->ts;
1521 new_sym->attr.referenced = 1;
1522 new_sym->attr.dimension = sym->attr.dimension;
1523 new_sym->attr.pointer = sym->attr.pointer;
1524 new_sym->attr.allocatable = sym->attr.allocatable;
1525 new_sym->attr.flavor = sym->attr.flavor;
1527 /* Create a fake symtree for it. */
1529 new_symtree = gfc_new_symtree (&root, sym->name);
1530 new_symtree->n.sym = new_sym;
1531 gcc_assert (new_symtree == root);
1533 /* Create a dummy->actual mapping. */
1534 sm = gfc_getmem (sizeof (*sm));
1535 sm->next = mapping->syms;
1537 sm->new = new_symtree;
1540 /* Stabilize the argument's value. */
1541 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1543 if (sym->ts.type == BT_CHARACTER)
1545 /* Create a copy of the dummy argument's length. */
1546 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1548 /* If the length is specified as "*", record the length that
1549 the caller is passing. We should use the callee's length
1550 in all other cases. */
1551 if (!new_sym->ts.cl->length)
1553 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1554 new_sym->ts.cl->backend_decl = se->string_length;
1558 /* Use the passed value as-is if the argument is a function. */
1559 if (sym->attr.flavor == FL_PROCEDURE)
1562 /* If the argument is either a string or a pointer to a string,
1563 convert it to a boundless character type. */
1564 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1566 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1567 tmp = build_pointer_type (tmp);
1568 if (sym->attr.pointer)
1569 value = build_fold_indirect_ref (se->expr);
1572 value = fold_convert (tmp, value);
1575 /* If the argument is a scalar, a pointer to an array or an allocatable,
1577 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1578 value = build_fold_indirect_ref (se->expr);
1580 /* For character(*), use the actual argument's descriptor. */
1581 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1582 value = build_fold_indirect_ref (se->expr);
1584 /* If the argument is an array descriptor, use it to determine
1585 information about the actual argument's shape. */
1586 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1587 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1589 /* Get the actual argument's descriptor. */
1590 desc = build_fold_indirect_ref (se->expr);
1592 /* Create the replacement variable. */
1593 tmp = gfc_conv_descriptor_data_get (desc);
1594 value = gfc_get_interface_mapping_array (&se->pre, sym,
1597 /* Use DESC to work out the upper bounds, strides and offset. */
1598 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1601 /* Otherwise we have a packed array. */
1602 value = gfc_get_interface_mapping_array (&se->pre, sym,
1603 PACKED_FULL, se->expr);
1605 new_sym->backend_decl = value;
1609 /* Called once all dummy argument mappings have been added to MAPPING,
1610 but before the mapping is used to evaluate expressions. Pre-evaluate
1611 the length of each argument, adding any initialization code to PRE and
1612 any finalization code to POST. */
1615 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1616 stmtblock_t * pre, stmtblock_t * post)
1618 gfc_interface_sym_mapping *sym;
1622 for (sym = mapping->syms; sym; sym = sym->next)
1623 if (sym->new->n.sym->ts.type == BT_CHARACTER
1624 && !sym->new->n.sym->ts.cl->backend_decl)
1626 expr = sym->new->n.sym->ts.cl->length;
1627 gfc_apply_interface_mapping_to_expr (mapping, expr);
1628 gfc_init_se (&se, NULL);
1629 gfc_conv_expr (&se, expr);
1631 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1632 gfc_add_block_to_block (pre, &se.pre);
1633 gfc_add_block_to_block (post, &se.post);
1635 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1640 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1644 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1645 gfc_constructor * c)
1647 for (; c; c = c->next)
1649 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1652 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1653 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1654 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1660 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1664 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1669 for (; ref; ref = ref->next)
1673 for (n = 0; n < ref->u.ar.dimen; n++)
1675 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1676 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1677 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1679 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1686 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1687 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1693 /* EXPR is a copy of an expression that appeared in the interface
1694 associated with MAPPING. Walk it recursively looking for references to
1695 dummy arguments that MAPPING maps to actual arguments. Replace each such
1696 reference with a reference to the associated actual argument. */
1699 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1702 gfc_interface_sym_mapping *sym;
1703 gfc_actual_arglist *actual;
1704 int seen_result = 0;
1709 /* Copying an expression does not copy its length, so do that here. */
1710 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1712 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1713 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1716 /* Apply the mapping to any references. */
1717 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1719 /* ...and to the expression's symbol, if it has one. */
1721 for (sym = mapping->syms; sym; sym = sym->next)
1722 if (sym->old == expr->symtree->n.sym)
1723 expr->symtree = sym->new;
1725 /* ...and to subexpressions in expr->value. */
1726 switch (expr->expr_type)
1729 if (expr->symtree->n.sym->attr.result)
1733 case EXPR_SUBSTRING:
1737 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1738 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1742 if (expr->value.function.esym == NULL
1743 && expr->value.function.isym != NULL
1744 && expr->value.function.isym->id == GFC_ISYM_LEN
1745 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
1746 && gfc_apply_interface_mapping_to_expr (mapping,
1747 expr->value.function.actual->expr))
1750 new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
1752 gfc_free (new_expr);
1753 gfc_apply_interface_mapping_to_expr (mapping, expr);
1757 for (sym = mapping->syms; sym; sym = sym->next)
1758 if (sym->old == expr->value.function.esym)
1759 expr->value.function.esym = sym->new->n.sym;
1761 for (actual = expr->value.function.actual; actual; actual = actual->next)
1762 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1766 case EXPR_STRUCTURE:
1767 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1774 /* Evaluate interface expression EXPR using MAPPING. Store the result
1778 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1779 gfc_se * se, gfc_expr * expr)
1781 expr = gfc_copy_expr (expr);
1782 gfc_apply_interface_mapping_to_expr (mapping, expr);
1783 gfc_conv_expr (se, expr);
1784 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1785 gfc_free_expr (expr);
1788 /* Returns a reference to a temporary array into which a component of
1789 an actual argument derived type array is copied and then returned
1790 after the function call.
1791 TODO Get rid of this kludge, when array descriptors are capable of
1792 handling arrays with a bigger stride in bytes than size. */
1795 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1796 int g77, sym_intent intent)
1812 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1814 gfc_init_se (&lse, NULL);
1815 gfc_init_se (&rse, NULL);
1817 /* Walk the argument expression. */
1818 rss = gfc_walk_expr (expr);
1820 gcc_assert (rss != gfc_ss_terminator);
1822 /* Initialize the scalarizer. */
1823 gfc_init_loopinfo (&loop);
1824 gfc_add_ss_to_loop (&loop, rss);
1826 /* Calculate the bounds of the scalarization. */
1827 gfc_conv_ss_startstride (&loop);
1829 /* Build an ss for the temporary. */
1830 base_type = gfc_typenode_for_spec (&expr->ts);
1831 if (GFC_ARRAY_TYPE_P (base_type)
1832 || GFC_DESCRIPTOR_TYPE_P (base_type))
1833 base_type = gfc_get_element_type (base_type);
1835 loop.temp_ss = gfc_get_ss ();;
1836 loop.temp_ss->type = GFC_SS_TEMP;
1837 loop.temp_ss->data.temp.type = base_type;
1839 if (expr->ts.type == BT_CHARACTER)
1841 gfc_ref *char_ref = expr->ref;
1843 for (; char_ref; char_ref = char_ref->next)
1844 if (char_ref->type == REF_SUBSTRING)
1848 expr->ts.cl = gfc_get_charlen ();
1849 expr->ts.cl->next = char_ref->u.ss.length->next;
1850 char_ref->u.ss.length->next = expr->ts.cl;
1852 gfc_init_se (&tmp_se, NULL);
1853 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1854 gfc_array_index_type);
1855 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1856 tmp_se.expr, gfc_index_one_node);
1857 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1858 gfc_init_se (&tmp_se, NULL);
1859 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1860 gfc_array_index_type);
1861 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1863 expr->ts.cl->backend_decl = tmp;
1867 loop.temp_ss->data.temp.type
1868 = gfc_typenode_for_spec (&expr->ts);
1869 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1872 loop.temp_ss->data.temp.dimen = loop.dimen;
1873 loop.temp_ss->next = gfc_ss_terminator;
1875 /* Associate the SS with the loop. */
1876 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1878 /* Setup the scalarizing loops. */
1879 gfc_conv_loop_setup (&loop);
1881 /* Pass the temporary descriptor back to the caller. */
1882 info = &loop.temp_ss->data.info;
1883 parmse->expr = info->descriptor;
1885 /* Setup the gfc_se structures. */
1886 gfc_copy_loopinfo_to_se (&lse, &loop);
1887 gfc_copy_loopinfo_to_se (&rse, &loop);
1890 lse.ss = loop.temp_ss;
1891 gfc_mark_ss_chain_used (rss, 1);
1892 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1894 /* Start the scalarized loop body. */
1895 gfc_start_scalarized_body (&loop, &body);
1897 /* Translate the expression. */
1898 gfc_conv_expr (&rse, expr);
1900 gfc_conv_tmp_array_ref (&lse);
1901 gfc_advance_se_ss_chain (&lse);
1903 if (intent != INTENT_OUT)
1905 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1906 gfc_add_expr_to_block (&body, tmp);
1907 gcc_assert (rse.ss == gfc_ss_terminator);
1908 gfc_trans_scalarizing_loops (&loop, &body);
1912 /* Make sure that the temporary declaration survives by merging
1913 all the loop declarations into the current context. */
1914 for (n = 0; n < loop.dimen; n++)
1916 gfc_merge_block_scope (&body);
1917 body = loop.code[loop.order[n]];
1919 gfc_merge_block_scope (&body);
1922 /* Add the post block after the second loop, so that any
1923 freeing of allocated memory is done at the right time. */
1924 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1926 /**********Copy the temporary back again.*********/
1928 gfc_init_se (&lse, NULL);
1929 gfc_init_se (&rse, NULL);
1931 /* Walk the argument expression. */
1932 lss = gfc_walk_expr (expr);
1933 rse.ss = loop.temp_ss;
1936 /* Initialize the scalarizer. */
1937 gfc_init_loopinfo (&loop2);
1938 gfc_add_ss_to_loop (&loop2, lss);
1940 /* Calculate the bounds of the scalarization. */
1941 gfc_conv_ss_startstride (&loop2);
1943 /* Setup the scalarizing loops. */
1944 gfc_conv_loop_setup (&loop2);
1946 gfc_copy_loopinfo_to_se (&lse, &loop2);
1947 gfc_copy_loopinfo_to_se (&rse, &loop2);
1949 gfc_mark_ss_chain_used (lss, 1);
1950 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1952 /* Declare the variable to hold the temporary offset and start the
1953 scalarized loop body. */
1954 offset = gfc_create_var (gfc_array_index_type, NULL);
1955 gfc_start_scalarized_body (&loop2, &body);
1957 /* Build the offsets for the temporary from the loop variables. The
1958 temporary array has lbounds of zero and strides of one in all
1959 dimensions, so this is very simple. The offset is only computed
1960 outside the innermost loop, so the overall transfer could be
1961 optimized further. */
1962 info = &rse.ss->data.info;
1964 tmp_index = gfc_index_zero_node;
1965 for (n = info->dimen - 1; n > 0; n--)
1968 tmp = rse.loop->loopvar[n];
1969 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1970 tmp, rse.loop->from[n]);
1971 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1974 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1975 rse.loop->to[n-1], rse.loop->from[n-1]);
1976 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1977 tmp_str, gfc_index_one_node);
1979 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1983 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1984 tmp_index, rse.loop->from[0]);
1985 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1987 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1988 rse.loop->loopvar[0], offset);
1990 /* Now use the offset for the reference. */
1991 tmp = build_fold_indirect_ref (info->data);
1992 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1994 if (expr->ts.type == BT_CHARACTER)
1995 rse.string_length = expr->ts.cl->backend_decl;
1997 gfc_conv_expr (&lse, expr);
1999 gcc_assert (lse.ss == gfc_ss_terminator);
2001 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2002 gfc_add_expr_to_block (&body, tmp);
2004 /* Generate the copying loops. */
2005 gfc_trans_scalarizing_loops (&loop2, &body);
2007 /* Wrap the whole thing up by adding the second loop to the post-block
2008 and following it by the post-block of the first loop. In this way,
2009 if the temporary needs freeing, it is done after use! */
2010 if (intent != INTENT_IN)
2012 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2013 gfc_add_block_to_block (&parmse->post, &loop2.post);
2016 gfc_add_block_to_block (&parmse->post, &loop.post);
2018 gfc_cleanup_loop (&loop);
2019 gfc_cleanup_loop (&loop2);
2021 /* Pass the string length to the argument expression. */
2022 if (expr->ts.type == BT_CHARACTER)
2023 parmse->string_length = expr->ts.cl->backend_decl;
2025 /* We want either the address for the data or the address of the descriptor,
2026 depending on the mode of passing array arguments. */
2028 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2030 parmse->expr = build_fold_addr_expr (parmse->expr);
2035 /* Is true if an array reference is followed by a component or substring
2039 is_aliased_array (gfc_expr * e)
2045 for (ref = e->ref; ref; ref = ref->next)
2047 if (ref->type == REF_ARRAY
2048 && ref->u.ar.type != AR_ELEMENT)
2052 && ref->type != REF_ARRAY)
2058 /* Generate the code for argument list functions. */
2061 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2063 /* Pass by value for g77 %VAL(arg), pass the address
2064 indirectly for %LOC, else by reference. Thus %REF
2065 is a "do-nothing" and %LOC is the same as an F95
2067 if (strncmp (name, "%VAL", 4) == 0)
2068 gfc_conv_expr (se, expr);
2069 else if (strncmp (name, "%LOC", 4) == 0)
2071 gfc_conv_expr_reference (se, expr);
2072 se->expr = gfc_build_addr_expr (NULL, se->expr);
2074 else if (strncmp (name, "%REF", 4) == 0)
2075 gfc_conv_expr_reference (se, expr);
2077 gfc_error ("Unknown argument list function at %L", &expr->where);
2081 /* Generate code for a procedure call. Note can return se->post != NULL.
2082 If se->direct_byref is set then se->expr contains the return parameter.
2083 Return nonzero, if the call has alternate specifiers. */
2086 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2087 gfc_actual_arglist * arg, tree append_args)
2089 gfc_interface_mapping mapping;
2103 gfc_formal_arglist *formal;
2104 int has_alternate_specifier = 0;
2105 bool need_interface_mapping;
2112 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2114 arglist = NULL_TREE;
2115 retargs = NULL_TREE;
2116 stringargs = NULL_TREE;
2120 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2122 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2124 if (arg->expr->rank == 0)
2125 gfc_conv_expr_reference (se, arg->expr);
2129 /* This is really the actual arg because no formal arglist is
2130 created for C_LOC. */
2131 fsym = arg->expr->symtree->n.sym;
2133 /* We should want it to do g77 calling convention. */
2135 && !(fsym->attr.pointer || fsym->attr.allocatable)
2136 && fsym->as->type != AS_ASSUMED_SHAPE;
2137 f = f || !sym->attr.always_explicit;
2139 argss = gfc_walk_expr (arg->expr);
2140 gfc_conv_array_parameter (se, arg->expr, argss, f);
2145 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2147 arg->expr->ts.type = sym->ts.derived->ts.type;
2148 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2149 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2150 gfc_conv_expr_reference (se, arg->expr);
2158 if (!sym->attr.elemental)
2160 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2161 if (se->ss->useflags)
2163 gcc_assert (gfc_return_by_reference (sym)
2164 && sym->result->attr.dimension);
2165 gcc_assert (se->loop != NULL);
2167 /* Access the previously obtained result. */
2168 gfc_conv_tmp_array_ref (se);
2169 gfc_advance_se_ss_chain (se);
2173 info = &se->ss->data.info;
2178 gfc_init_block (&post);
2179 gfc_init_interface_mapping (&mapping);
2180 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2181 && sym->ts.cl->length
2182 && sym->ts.cl->length->expr_type
2184 || sym->attr.dimension);
2185 formal = sym->formal;
2186 /* Evaluate the arguments. */
2187 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2190 fsym = formal ? formal->sym : NULL;
2191 parm_kind = MISSING;
2195 if (se->ignore_optional)
2197 /* Some intrinsics have already been resolved to the correct
2201 else if (arg->label)
2203 has_alternate_specifier = 1;
2208 /* Pass a NULL pointer for an absent arg. */
2209 gfc_init_se (&parmse, NULL);
2210 parmse.expr = null_pointer_node;
2211 if (arg->missing_arg_type == BT_CHARACTER)
2212 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2215 else if (se->ss && se->ss->useflags)
2217 /* An elemental function inside a scalarized loop. */
2218 gfc_init_se (&parmse, se);
2219 gfc_conv_expr_reference (&parmse, e);
2220 parm_kind = ELEMENTAL;
2224 /* A scalar or transformational function. */
2225 gfc_init_se (&parmse, NULL);
2226 argss = gfc_walk_expr (e);
2228 if (argss == gfc_ss_terminator)
2230 if (fsym && fsym->attr.value)
2232 if (fsym->ts.type == BT_CHARACTER
2233 && fsym->ts.is_c_interop
2234 && fsym->ns->proc_name != NULL
2235 && fsym->ns->proc_name->attr.is_bind_c)
2238 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2239 if (parmse.expr == NULL)
2240 gfc_conv_expr (&parmse, e);
2243 gfc_conv_expr (&parmse, e);
2245 else if (arg->name && arg->name[0] == '%')
2246 /* Argument list functions %VAL, %LOC and %REF are signalled
2247 through arg->name. */
2248 conv_arglist_function (&parmse, arg->expr, arg->name);
2249 else if ((e->expr_type == EXPR_FUNCTION)
2250 && e->symtree->n.sym->attr.pointer
2251 && fsym && fsym->attr.target)
2253 gfc_conv_expr (&parmse, e);
2254 parmse.expr = build_fold_addr_expr (parmse.expr);
2258 gfc_conv_expr_reference (&parmse, e);
2259 if (fsym && fsym->attr.pointer
2260 && fsym->attr.flavor != FL_PROCEDURE
2261 && e->expr_type != EXPR_NULL)
2263 /* Scalar pointer dummy args require an extra level of
2264 indirection. The null pointer already contains
2265 this level of indirection. */
2266 parm_kind = SCALAR_POINTER;
2267 parmse.expr = build_fold_addr_expr (parmse.expr);
2273 /* If the procedure requires an explicit interface, the actual
2274 argument is passed according to the corresponding formal
2275 argument. If the corresponding formal argument is a POINTER,
2276 ALLOCATABLE or assumed shape, we do not use g77's calling
2277 convention, and pass the address of the array descriptor
2278 instead. Otherwise we use g77's calling convention. */
2281 && !(fsym->attr.pointer || fsym->attr.allocatable)
2282 && fsym->as->type != AS_ASSUMED_SHAPE;
2283 f = f || !sym->attr.always_explicit;
2285 if (e->expr_type == EXPR_VARIABLE
2286 && is_aliased_array (e))
2287 /* The actual argument is a component reference to an
2288 array of derived types. In this case, the argument
2289 is converted to a temporary, which is passed and then
2290 written back after the procedure call. */
2291 gfc_conv_aliased_arg (&parmse, e, f,
2292 fsym ? fsym->attr.intent : INTENT_INOUT);
2294 gfc_conv_array_parameter (&parmse, e, argss, f);
2296 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2297 allocated on entry, it must be deallocated. */
2298 if (fsym && fsym->attr.allocatable
2299 && fsym->attr.intent == INTENT_OUT)
2301 tmp = build_fold_indirect_ref (parmse.expr);
2302 tmp = gfc_trans_dealloc_allocated (tmp);
2303 gfc_add_expr_to_block (&se->pre, tmp);
2313 /* If an optional argument is itself an optional dummy
2314 argument, check its presence and substitute a null
2316 if (e->expr_type == EXPR_VARIABLE
2317 && e->symtree->n.sym->attr.optional
2318 && fsym->attr.optional)
2319 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2321 /* Obtain the character length of an assumed character
2322 length procedure from the typespec. */
2323 if (fsym->ts.type == BT_CHARACTER
2324 && parmse.string_length == NULL_TREE
2325 && e->ts.type == BT_PROCEDURE
2326 && e->symtree->n.sym->ts.type == BT_CHARACTER
2327 && e->symtree->n.sym->ts.cl->length != NULL)
2329 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2330 parmse.string_length
2331 = e->symtree->n.sym->ts.cl->backend_decl;
2335 if (need_interface_mapping)
2336 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2339 gfc_add_block_to_block (&se->pre, &parmse.pre);
2340 gfc_add_block_to_block (&post, &parmse.post);
2342 /* Allocated allocatable components of derived types must be
2343 deallocated for INTENT(OUT) dummy arguments and non-variable
2344 scalars. Non-variable arrays are dealt with in trans-array.c
2345 (gfc_conv_array_parameter). */
2346 if (e && e->ts.type == BT_DERIVED
2347 && e->ts.derived->attr.alloc_comp
2348 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2350 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2353 tmp = build_fold_indirect_ref (parmse.expr);
2354 parm_rank = e->rank;
2362 case (SCALAR_POINTER):
2363 tmp = build_fold_indirect_ref (tmp);
2370 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2371 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2372 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2373 tmp, build_empty_stmt ());
2375 if (e->expr_type != EXPR_VARIABLE)
2376 /* Don't deallocate non-variables until they have been used. */
2377 gfc_add_expr_to_block (&se->post, tmp);
2380 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2381 gfc_add_expr_to_block (&se->pre, tmp);
2385 /* Character strings are passed as two parameters, a length and a
2387 if (parmse.string_length != NULL_TREE)
2388 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2390 arglist = gfc_chainon_list (arglist, parmse.expr);
2392 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2395 if (ts.type == BT_CHARACTER)
2397 if (sym->ts.cl->length == NULL)
2399 /* Assumed character length results are not allowed by 5.1.1.5 of the
2400 standard and are trapped in resolve.c; except in the case of SPREAD
2401 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2402 we take the character length of the first argument for the result.
2403 For dummies, we have to look through the formal argument list for
2404 this function and use the character length found there.*/
2405 if (!sym->attr.dummy)
2406 cl.backend_decl = TREE_VALUE (stringargs);
2409 formal = sym->ns->proc_name->formal;
2410 for (; formal; formal = formal->next)
2411 if (strcmp (formal->sym->name, sym->name) == 0)
2412 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2419 /* Calculate the length of the returned string. */
2420 gfc_init_se (&parmse, NULL);
2421 if (need_interface_mapping)
2422 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2424 gfc_conv_expr (&parmse, sym->ts.cl->length);
2425 gfc_add_block_to_block (&se->pre, &parmse.pre);
2426 gfc_add_block_to_block (&se->post, &parmse.post);
2428 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2429 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2430 build_int_cst (gfc_charlen_type_node, 0));
2431 cl.backend_decl = tmp;
2434 /* Set up a charlen structure for it. */
2439 len = cl.backend_decl;
2442 byref = gfc_return_by_reference (sym);
2445 if (se->direct_byref)
2447 /* Sometimes, too much indirection can be applied; eg. for
2448 function_result = array_valued_recursive_function. */
2449 if (TREE_TYPE (TREE_TYPE (se->expr))
2450 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2451 && GFC_DESCRIPTOR_TYPE_P
2452 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2453 se->expr = build_fold_indirect_ref (se->expr);
2455 retargs = gfc_chainon_list (retargs, se->expr);
2457 else if (sym->result->attr.dimension)
2459 gcc_assert (se->loop && info);
2461 /* Set the type of the array. */
2462 tmp = gfc_typenode_for_spec (&ts);
2463 info->dimen = se->loop->dimen;
2465 /* Evaluate the bounds of the result, if known. */
2466 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2468 /* Create a temporary to store the result. In case the function
2469 returns a pointer, the temporary will be a shallow copy and
2470 mustn't be deallocated. */
2471 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2472 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2473 false, !sym->attr.pointer, callee_alloc);
2475 /* Pass the temporary as the first argument. */
2476 tmp = info->descriptor;
2477 tmp = build_fold_addr_expr (tmp);
2478 retargs = gfc_chainon_list (retargs, tmp);
2480 else if (ts.type == BT_CHARACTER)
2482 /* Pass the string length. */
2483 type = gfc_get_character_type (ts.kind, ts.cl);
2484 type = build_pointer_type (type);
2486 /* Return an address to a char[0:len-1]* temporary for
2487 character pointers. */
2488 if (sym->attr.pointer || sym->attr.allocatable)
2490 /* Build char[0:len-1] * pstr. */
2491 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2492 build_int_cst (gfc_charlen_type_node, 1));
2493 tmp = build_range_type (gfc_array_index_type,
2494 gfc_index_zero_node, tmp);
2495 tmp = build_array_type (gfc_character1_type_node, tmp);
2496 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2498 /* Provide an address expression for the function arguments. */
2499 var = build_fold_addr_expr (var);
2502 var = gfc_conv_string_tmp (se, type, len);
2504 retargs = gfc_chainon_list (retargs, var);
2508 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2510 type = gfc_get_complex_type (ts.kind);
2511 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2512 retargs = gfc_chainon_list (retargs, var);
2515 /* Add the string length to the argument list. */
2516 if (ts.type == BT_CHARACTER)
2517 retargs = gfc_chainon_list (retargs, len);
2519 gfc_free_interface_mapping (&mapping);
2521 /* Add the return arguments. */
2522 arglist = chainon (retargs, arglist);
2524 /* Add the hidden string length parameters to the arguments. */
2525 arglist = chainon (arglist, stringargs);
2527 /* We may want to append extra arguments here. This is used e.g. for
2528 calls to libgfortran_matmul_??, which need extra information. */
2529 if (append_args != NULL_TREE)
2530 arglist = chainon (arglist, append_args);
2532 /* Generate the actual call. */
2533 gfc_conv_function_val (se, sym);
2535 /* If there are alternate return labels, function type should be
2536 integer. Can't modify the type in place though, since it can be shared
2537 with other functions. For dummy arguments, the typing is done to
2538 to this result, even if it has to be repeated for each call. */
2539 if (has_alternate_specifier
2540 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2542 if (!sym->attr.dummy)
2544 TREE_TYPE (sym->backend_decl)
2545 = build_function_type (integer_type_node,
2546 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2547 se->expr = build_fold_addr_expr (sym->backend_decl);
2550 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2553 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2554 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2556 /* If we have a pointer function, but we don't want a pointer, e.g.
2559 where f is pointer valued, we have to dereference the result. */
2560 if (!se->want_pointer && !byref && sym->attr.pointer)
2561 se->expr = build_fold_indirect_ref (se->expr);
2563 /* f2c calling conventions require a scalar default real function to
2564 return a double precision result. Convert this back to default
2565 real. We only care about the cases that can happen in Fortran 77.
2567 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2568 && sym->ts.kind == gfc_default_real_kind
2569 && !sym->attr.always_explicit)
2570 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2572 /* A pure function may still have side-effects - it may modify its
2574 TREE_SIDE_EFFECTS (se->expr) = 1;
2576 if (!sym->attr.pure)
2577 TREE_SIDE_EFFECTS (se->expr) = 1;
2582 /* Add the function call to the pre chain. There is no expression. */
2583 gfc_add_expr_to_block (&se->pre, se->expr);
2584 se->expr = NULL_TREE;
2586 if (!se->direct_byref)
2588 if (sym->attr.dimension)
2590 if (flag_bounds_check)
2592 /* Check the data pointer hasn't been modified. This would
2593 happen in a function returning a pointer. */
2594 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2595 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2597 gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
2599 se->expr = info->descriptor;
2600 /* Bundle in the string length. */
2601 se->string_length = len;
2603 else if (sym->ts.type == BT_CHARACTER)
2605 /* Dereference for character pointer results. */
2606 if (sym->attr.pointer || sym->attr.allocatable)
2607 se->expr = build_fold_indirect_ref (var);
2611 se->string_length = len;
2615 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2616 se->expr = build_fold_indirect_ref (var);
2621 /* Follow the function call with the argument post block. */
2623 gfc_add_block_to_block (&se->pre, &post);
2625 gfc_add_block_to_block (&se->post, &post);
2627 return has_alternate_specifier;
2631 /* Generate code to copy a string. */
2634 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2635 tree slength, tree src)
2637 tree tmp, dlen, slen;
2645 stmtblock_t tempblock;
2647 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2648 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2650 /* Deal with single character specially. */
2651 dsc = gfc_to_single_character (dlen, dest);
2652 ssc = gfc_to_single_character (slen, src);
2653 if (dsc != NULL_TREE && ssc != NULL_TREE)
2655 gfc_add_modify_expr (block, dsc, ssc);
2659 /* Do nothing if the destination length is zero. */
2660 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2661 build_int_cst (size_type_node, 0));
2663 /* The following code was previously in _gfortran_copy_string:
2665 // The two strings may overlap so we use memmove.
2667 copy_string (GFC_INTEGER_4 destlen, char * dest,
2668 GFC_INTEGER_4 srclen, const char * src)
2670 if (srclen >= destlen)
2672 // This will truncate if too long.
2673 memmove (dest, src, destlen);
2677 memmove (dest, src, srclen);
2679 memset (&dest[srclen], ' ', destlen - srclen);
2683 We're now doing it here for better optimization, but the logic
2686 /* Truncate string if source is too long. */
2687 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2688 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2689 3, dest, src, dlen);
2691 /* Else copy and pad with spaces. */
2692 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2693 3, dest, src, slen);
2695 tmp4 = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, dest,
2696 fold_convert (sizetype, slen));
2697 tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2699 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2700 lang_hooks.to_target_charset (' ')),
2701 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2704 gfc_init_block (&tempblock);
2705 gfc_add_expr_to_block (&tempblock, tmp3);
2706 gfc_add_expr_to_block (&tempblock, tmp4);
2707 tmp3 = gfc_finish_block (&tempblock);
2709 /* The whole copy_string function is there. */
2710 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2711 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2712 gfc_add_expr_to_block (block, tmp);
2716 /* Translate a statement function.
2717 The value of a statement function reference is obtained by evaluating the
2718 expression using the values of the actual arguments for the values of the
2719 corresponding dummy arguments. */
2722 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2726 gfc_formal_arglist *fargs;
2727 gfc_actual_arglist *args;
2730 gfc_saved_var *saved_vars;
2736 sym = expr->symtree->n.sym;
2737 args = expr->value.function.actual;
2738 gfc_init_se (&lse, NULL);
2739 gfc_init_se (&rse, NULL);
2742 for (fargs = sym->formal; fargs; fargs = fargs->next)
2744 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2745 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2747 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2749 /* Each dummy shall be specified, explicitly or implicitly, to be
2751 gcc_assert (fargs->sym->attr.dimension == 0);
2754 /* Create a temporary to hold the value. */
2755 type = gfc_typenode_for_spec (&fsym->ts);
2756 temp_vars[n] = gfc_create_var (type, fsym->name);
2758 if (fsym->ts.type == BT_CHARACTER)
2760 /* Copy string arguments. */
2763 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2764 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2766 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2767 tmp = gfc_build_addr_expr (build_pointer_type (type),
2770 gfc_conv_expr (&rse, args->expr);
2771 gfc_conv_string_parameter (&rse);
2772 gfc_add_block_to_block (&se->pre, &lse.pre);
2773 gfc_add_block_to_block (&se->pre, &rse.pre);
2775 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2777 gfc_add_block_to_block (&se->pre, &lse.post);
2778 gfc_add_block_to_block (&se->pre, &rse.post);
2782 /* For everything else, just evaluate the expression. */
2783 gfc_conv_expr (&lse, args->expr);
2785 gfc_add_block_to_block (&se->pre, &lse.pre);
2786 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2787 gfc_add_block_to_block (&se->pre, &lse.post);
2793 /* Use the temporary variables in place of the real ones. */
2794 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2795 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2797 gfc_conv_expr (se, sym->value);
2799 if (sym->ts.type == BT_CHARACTER)
2801 gfc_conv_const_charlen (sym->ts.cl);
2803 /* Force the expression to the correct length. */
2804 if (!INTEGER_CST_P (se->string_length)
2805 || tree_int_cst_lt (se->string_length,
2806 sym->ts.cl->backend_decl))
2808 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2809 tmp = gfc_create_var (type, sym->name);
2810 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2811 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2812 se->string_length, se->expr);
2815 se->string_length = sym->ts.cl->backend_decl;
2818 /* Restore the original variables. */
2819 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2820 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2821 gfc_free (saved_vars);
2825 /* Translate a function expression. */
2828 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2832 if (expr->value.function.isym)
2834 gfc_conv_intrinsic_function (se, expr);
2838 /* We distinguish statement functions from general functions to improve
2839 runtime performance. */
2840 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2842 gfc_conv_statement_function (se, expr);
2846 /* expr.value.function.esym is the resolved (specific) function symbol for
2847 most functions. However this isn't set for dummy procedures. */
2848 sym = expr->value.function.esym;
2850 sym = expr->symtree->n.sym;
2851 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2856 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2858 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2859 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2861 gfc_conv_tmp_array_ref (se);
2862 gfc_advance_se_ss_chain (se);
2866 /* Build a static initializer. EXPR is the expression for the initial value.
2867 The other parameters describe the variable of the component being
2868 initialized. EXPR may be null. */
2871 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2872 bool array, bool pointer)
2876 if (!(expr || pointer))
2879 if (expr != NULL && expr->ts.type == BT_DERIVED
2880 && expr->ts.is_iso_c && expr->ts.derived
2881 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
2882 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR))
2883 expr = gfc_int_expr (0);
2887 /* Arrays need special handling. */
2889 return gfc_build_null_descriptor (type);
2891 return gfc_conv_array_initializer (type, expr);
2894 return fold_convert (type, null_pointer_node);
2900 gfc_init_se (&se, NULL);
2901 gfc_conv_structure (&se, expr, 1);
2905 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2908 gfc_init_se (&se, NULL);
2909 gfc_conv_constant (&se, expr);
2916 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2928 gfc_start_block (&block);
2930 /* Initialize the scalarizer. */
2931 gfc_init_loopinfo (&loop);
2933 gfc_init_se (&lse, NULL);
2934 gfc_init_se (&rse, NULL);
2937 rss = gfc_walk_expr (expr);
2938 if (rss == gfc_ss_terminator)
2940 /* The rhs is scalar. Add a ss for the expression. */
2941 rss = gfc_get_ss ();
2942 rss->next = gfc_ss_terminator;
2943 rss->type = GFC_SS_SCALAR;
2947 /* Create a SS for the destination. */
2948 lss = gfc_get_ss ();
2949 lss->type = GFC_SS_COMPONENT;
2951 lss->shape = gfc_get_shape (cm->as->rank);
2952 lss->next = gfc_ss_terminator;
2953 lss->data.info.dimen = cm->as->rank;
2954 lss->data.info.descriptor = dest;
2955 lss->data.info.data = gfc_conv_array_data (dest);
2956 lss->data.info.offset = gfc_conv_array_offset (dest);
2957 for (n = 0; n < cm->as->rank; n++)
2959 lss->data.info.dim[n] = n;
2960 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2961 lss->data.info.stride[n] = gfc_index_one_node;
2963 mpz_init (lss->shape[n]);
2964 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2965 cm->as->lower[n]->value.integer);
2966 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2969 /* Associate the SS with the loop. */
2970 gfc_add_ss_to_loop (&loop, lss);
2971 gfc_add_ss_to_loop (&loop, rss);
2973 /* Calculate the bounds of the scalarization. */
2974 gfc_conv_ss_startstride (&loop);
2976 /* Setup the scalarizing loops. */
2977 gfc_conv_loop_setup (&loop);
2979 /* Setup the gfc_se structures. */
2980 gfc_copy_loopinfo_to_se (&lse, &loop);
2981 gfc_copy_loopinfo_to_se (&rse, &loop);
2984 gfc_mark_ss_chain_used (rss, 1);
2986 gfc_mark_ss_chain_used (lss, 1);
2988 /* Start the scalarized loop body. */
2989 gfc_start_scalarized_body (&loop, &body);
2991 gfc_conv_tmp_array_ref (&lse);
2992 if (cm->ts.type == BT_CHARACTER)
2993 lse.string_length = cm->ts.cl->backend_decl;
2995 gfc_conv_expr (&rse, expr);
2997 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2998 gfc_add_expr_to_block (&body, tmp);
3000 gcc_assert (rse.ss == gfc_ss_terminator);
3002 /* Generate the copying loops. */
3003 gfc_trans_scalarizing_loops (&loop, &body);
3005 /* Wrap the whole thing up. */
3006 gfc_add_block_to_block (&block, &loop.pre);
3007 gfc_add_block_to_block (&block, &loop.post);
3009 for (n = 0; n < cm->as->rank; n++)
3010 mpz_clear (lss->shape[n]);
3011 gfc_free (lss->shape);
3013 gfc_cleanup_loop (&loop);
3015 return gfc_finish_block (&block);
3019 /* Assign a single component of a derived type constructor. */
3022 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3032 gfc_start_block (&block);
3036 gfc_init_se (&se, NULL);
3037 /* Pointer component. */
3040 /* Array pointer. */
3041 if (expr->expr_type == EXPR_NULL)
3042 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3045 rss = gfc_walk_expr (expr);
3046 se.direct_byref = 1;
3048 gfc_conv_expr_descriptor (&se, expr, rss);
3049 gfc_add_block_to_block (&block, &se.pre);
3050 gfc_add_block_to_block (&block, &se.post);
3055 /* Scalar pointers. */
3056 se.want_pointer = 1;
3057 gfc_conv_expr (&se, expr);
3058 gfc_add_block_to_block (&block, &se.pre);
3059 gfc_add_modify_expr (&block, dest,
3060 fold_convert (TREE_TYPE (dest), se.expr));
3061 gfc_add_block_to_block (&block, &se.post);
3064 else if (cm->dimension)
3066 if (cm->allocatable && expr->expr_type == EXPR_NULL)
3067 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3068 else if (cm->allocatable)
3072 gfc_init_se (&se, NULL);
3074 rss = gfc_walk_expr (expr);
3075 se.want_pointer = 0;
3076 gfc_conv_expr_descriptor (&se, expr, rss);
3077 gfc_add_block_to_block (&block, &se.pre);
3079 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3080 gfc_add_modify_expr (&block, dest, tmp);
3082 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3083 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3086 tmp = gfc_duplicate_allocatable (dest, se.expr,
3087 TREE_TYPE(cm->backend_decl),
3090 gfc_add_expr_to_block (&block, tmp);
3092 gfc_add_block_to_block (&block, &se.post);
3093 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3095 /* Shift the lbound and ubound of temporaries to being unity, rather
3096 than zero, based. Calculate the offset for all cases. */
3097 offset = gfc_conv_descriptor_offset (dest);
3098 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
3099 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3100 for (n = 0; n < expr->rank; n++)
3102 if (expr->expr_type != EXPR_VARIABLE
3103 && expr->expr_type != EXPR_CONSTANT)
3106 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3107 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3108 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3109 gfc_add_modify_expr (&block, tmp,
3110 fold_build2 (PLUS_EXPR,
3111 gfc_array_index_type,
3112 span, gfc_index_one_node));
3113 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3114 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
3116 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3117 gfc_conv_descriptor_lbound (dest,
3119 gfc_conv_descriptor_stride (dest,
3121 gfc_add_modify_expr (&block, tmp2, tmp);
3122 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3123 gfc_add_modify_expr (&block, offset, tmp);
3128 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3129 gfc_add_expr_to_block (&block, tmp);
3132 else if (expr->ts.type == BT_DERIVED)
3134 if (expr->expr_type != EXPR_STRUCTURE)
3136 gfc_init_se (&se, NULL);
3137 gfc_conv_expr (&se, expr);
3138 gfc_add_modify_expr (&block, dest,
3139 fold_convert (TREE_TYPE (dest), se.expr));
3143 /* Nested constructors. */
3144 tmp = gfc_trans_structure_assign (dest, expr);
3145 gfc_add_expr_to_block (&block, tmp);
3150 /* Scalar component. */
3151 gfc_init_se (&se, NULL);
3152 gfc_init_se (&lse, NULL);
3154 gfc_conv_expr (&se, expr);
3155 if (cm->ts.type == BT_CHARACTER)
3156 lse.string_length = cm->ts.cl->backend_decl;
3158 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3159 gfc_add_expr_to_block (&block, tmp);
3161 return gfc_finish_block (&block);
3164 /* Assign a derived type constructor to a variable. */
3167 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3175 gfc_start_block (&block);
3176 cm = expr->ts.derived->components;
3177 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3179 /* Skip absent members in default initializers. */
3183 field = cm->backend_decl;
3184 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3185 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3186 gfc_add_expr_to_block (&block, tmp);
3188 return gfc_finish_block (&block);
3191 /* Build an expression for a constructor. If init is nonzero then
3192 this is part of a static variable initializer. */
3195 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3202 VEC(constructor_elt,gc) *v = NULL;
3204 gcc_assert (se->ss == NULL);
3205 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3206 type = gfc_typenode_for_spec (&expr->ts);
3210 /* Create a temporary variable and fill it in. */
3211 se->expr = gfc_create_var (type, expr->ts.derived->name);
3212 tmp = gfc_trans_structure_assign (se->expr, expr);
3213 gfc_add_expr_to_block (&se->pre, tmp);
3217 cm = expr->ts.derived->components;
3219 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3221 /* Skip absent members in default initializers and allocatable
3222 components. Although the latter have a default initializer
3223 of EXPR_NULL,... by default, the static nullify is not needed
3224 since this is done every time we come into scope. */
3225 if (!c->expr || cm->allocatable)
3228 val = gfc_conv_initializer (c->expr, &cm->ts,
3229 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3231 /* Append it to the constructor list. */
3232 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3234 se->expr = build_constructor (type, v);
3238 /* Translate a substring expression. */
3241 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3247 gcc_assert (ref->type == REF_SUBSTRING);
3249 se->expr = gfc_build_string_const(expr->value.character.length,
3250 expr->value.character.string);
3251 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3252 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3254 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3258 /* Entry point for expression translation. Evaluates a scalar quantity.
3259 EXPR is the expression to be translated, and SE is the state structure if
3260 called from within the scalarized. */
3263 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3265 if (se->ss && se->ss->expr == expr
3266 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3268 /* Substitute a scalar expression evaluated outside the scalarization
3270 se->expr = se->ss->data.scalar.expr;
3271 se->string_length = se->ss->string_length;
3272 gfc_advance_se_ss_chain (se);
3276 /* We need to convert the expressions for the iso_c_binding derived types.
3277 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3278 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3279 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3280 updated to be an integer with a kind equal to the size of a (void *). */
3281 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3282 && expr->ts.derived->attr.is_iso_c)
3284 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3285 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3287 /* Set expr_type to EXPR_NULL, which will result in
3288 null_pointer_node being used below. */
3289 expr->expr_type = EXPR_NULL;
3293 /* Update the type/kind of the expression to be what the new
3294 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3295 expr->ts.type = expr->ts.derived->ts.type;
3296 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3297 expr->ts.kind = expr->ts.derived->ts.kind;
3301 switch (expr->expr_type)
3304 gfc_conv_expr_op (se, expr);
3308 gfc_conv_function_expr (se, expr);
3312 gfc_conv_constant (se, expr);
3316 gfc_conv_variable (se, expr);
3320 se->expr = null_pointer_node;
3323 case EXPR_SUBSTRING:
3324 gfc_conv_substring_expr (se, expr);
3327 case EXPR_STRUCTURE:
3328 gfc_conv_structure (se, expr, 0);
3332 gfc_conv_array_constructor_expr (se, expr);
3341 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3342 of an assignment. */
3344 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3346 gfc_conv_expr (se, expr);
3347 /* All numeric lvalues should have empty post chains. If not we need to
3348 figure out a way of rewriting an lvalue so that it has no post chain. */
3349 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3352 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3353 numeric expressions. Used for scalar values where inserting cleanup code
3356 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3360 gcc_assert (expr->ts.type != BT_CHARACTER);
3361 gfc_conv_expr (se, expr);
3364 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3365 gfc_add_modify_expr (&se->pre, val, se->expr);
3367 gfc_add_block_to_block (&se->pre, &se->post);
3371 /* Helper to translate and expression and convert it to a particular type. */
3373 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3375 gfc_conv_expr_val (se, expr);
3376 se->expr = convert (type, se->expr);
3380 /* Converts an expression so that it can be passed by reference. Scalar
3384 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3388 if (se->ss && se->ss->expr == expr
3389 && se->ss->type == GFC_SS_REFERENCE)
3391 se->expr = se->ss->data.scalar.expr;
3392 se->string_length = se->ss->string_length;
3393 gfc_advance_se_ss_chain (se);
3397 if (expr->ts.type == BT_CHARACTER)
3399 gfc_conv_expr (se, expr);
3400 gfc_conv_string_parameter (se);
3404 if (expr->expr_type == EXPR_VARIABLE)
3406 se->want_pointer = 1;
3407 gfc_conv_expr (se, expr);
3410 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3411 gfc_add_modify_expr (&se->pre, var, se->expr);
3412 gfc_add_block_to_block (&se->pre, &se->post);
3418 if (expr->expr_type == EXPR_FUNCTION
3419 && expr->symtree->n.sym->attr.pointer
3420 && !expr->symtree->n.sym->attr.dimension)
3422 se->want_pointer = 1;
3423 gfc_conv_expr (se, expr);
3424 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3425 gfc_add_modify_expr (&se->pre, var, se->expr);
3431 gfc_conv_expr (se, expr);
3433 /* Create a temporary var to hold the value. */
3434 if (TREE_CONSTANT (se->expr))
3436 tree tmp = se->expr;
3437 STRIP_TYPE_NOPS (tmp);
3438 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3439 DECL_INITIAL (var) = tmp;
3440 TREE_STATIC (var) = 1;
3445 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3446 gfc_add_modify_expr (&se->pre, var, se->expr);
3448 gfc_add_block_to_block (&se->pre, &se->post);
3450 /* Take the address of that value. */
3451 se->expr = build_fold_addr_expr (var);
3456 gfc_trans_pointer_assign (gfc_code * code)
3458 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3462 /* Generate code for a pointer assignment. */
3465 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3475 gfc_start_block (&block);
3477 gfc_init_se (&lse, NULL);
3479 lss = gfc_walk_expr (expr1);
3480 rss = gfc_walk_expr (expr2);
3481 if (lss == gfc_ss_terminator)
3483 /* Scalar pointers. */
3484 lse.want_pointer = 1;
3485 gfc_conv_expr (&lse, expr1);
3486 gcc_assert (rss == gfc_ss_terminator);
3487 gfc_init_se (&rse, NULL);
3488 rse.want_pointer = 1;
3489 gfc_conv_expr (&rse, expr2);
3490 gfc_add_block_to_block (&block, &lse.pre);
3491 gfc_add_block_to_block (&block, &rse.pre);
3492 gfc_add_modify_expr (&block, lse.expr,
3493 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3494 gfc_add_block_to_block (&block, &rse.post);
3495 gfc_add_block_to_block (&block, &lse.post);
3499 /* Array pointer. */
3500 gfc_conv_expr_descriptor (&lse, expr1, lss);
3501 switch (expr2->expr_type)
3504 /* Just set the data pointer to null. */
3505 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3509 /* Assign directly to the pointer's descriptor. */
3510 lse.direct_byref = 1;
3511 gfc_conv_expr_descriptor (&lse, expr2, rss);
3515 /* Assign to a temporary descriptor and then copy that
3516 temporary to the pointer. */
3518 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3521 lse.direct_byref = 1;
3522 gfc_conv_expr_descriptor (&lse, expr2, rss);
3523 gfc_add_modify_expr (&lse.pre, desc, tmp);
3526 gfc_add_block_to_block (&block, &lse.pre);
3527 gfc_add_block_to_block (&block, &lse.post);
3529 return gfc_finish_block (&block);
3533 /* Makes sure se is suitable for passing as a function string parameter. */
3534 /* TODO: Need to check all callers fo this function. It may be abused. */
3537 gfc_conv_string_parameter (gfc_se * se)
3541 if (TREE_CODE (se->expr) == STRING_CST)
3543 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3547 type = TREE_TYPE (se->expr);
3548 if (TYPE_STRING_FLAG (type))
3550 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3551 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3554 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3555 gcc_assert (se->string_length
3556 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3560 /* Generate code for assignment of scalar variables. Includes character
3561 strings and derived types with allocatable components. */
3564 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3565 bool l_is_temp, bool r_is_var)
3571 gfc_init_block (&block);
3573 if (ts.type == BT_CHARACTER)
3575 gcc_assert (lse->string_length != NULL_TREE
3576 && rse->string_length != NULL_TREE);
3578 gfc_conv_string_parameter (lse);
3579 gfc_conv_string_parameter (rse);
3581 gfc_add_block_to_block (&block, &lse->pre);
3582 gfc_add_block_to_block (&block, &rse->pre);
3584 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3585 rse->string_length, rse->expr);
3587 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3591 /* Are the rhs and the lhs the same? */
3594 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3595 build_fold_addr_expr (lse->expr),
3596 build_fold_addr_expr (rse->expr));
3597 cond = gfc_evaluate_now (cond, &lse->pre);
3600 /* Deallocate the lhs allocated components as long as it is not
3601 the same as the rhs. This must be done following the assignment
3602 to prevent deallocating data that could be used in the rhs
3606 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
3607 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
3609 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3610 gfc_add_expr_to_block (&lse->post, tmp);
3613 gfc_add_block_to_block (&block, &rse->pre);
3614 gfc_add_block_to_block (&block, &lse->pre);
3616 gfc_add_modify_expr (&block, lse->expr,
3617 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3619 /* Do a deep copy if the rhs is a variable, if it is not the
3623 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3624 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3625 gfc_add_expr_to_block (&block, tmp);
3630 gfc_add_block_to_block (&block, &lse->pre);
3631 gfc_add_block_to_block (&block, &rse->pre);
3633 gfc_add_modify_expr (&block, lse->expr,
3634 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3637 gfc_add_block_to_block (&block, &lse->post);
3638 gfc_add_block_to_block (&block, &rse->post);
3640 return gfc_finish_block (&block);
3644 /* Try to translate array(:) = func (...), where func is a transformational
3645 array function, without using a temporary. Returns NULL is this isn't the
3649 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3654 bool seen_array_ref;
3656 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3657 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3660 /* Elemental functions don't need a temporary anyway. */
3661 if (expr2->value.function.esym != NULL
3662 && expr2->value.function.esym->attr.elemental)
3665 /* Fail if EXPR1 can't be expressed as a descriptor. */
3666 if (gfc_ref_needs_temporary_p (expr1->ref))
3669 /* Functions returning pointers need temporaries. */
3670 if (expr2->symtree->n.sym->attr.pointer
3671 || expr2->symtree->n.sym->attr.allocatable)
3674 /* Character array functions need temporaries unless the
3675 character lengths are the same. */
3676 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3678 if (expr1->ts.cl->length == NULL
3679 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3682 if (expr2->ts.cl->length == NULL
3683 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3686 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3687 expr2->ts.cl->length->value.integer) != 0)
3691 /* Check that no LHS component references appear during an array
3692 reference. This is needed because we do not have the means to
3693 span any arbitrary stride with an array descriptor. This check
3694 is not needed for the rhs because the function result has to be
3696 seen_array_ref = false;
3697 for (ref = expr1->ref; ref; ref = ref->next)
3699 if (ref->type == REF_ARRAY)
3700 seen_array_ref= true;
3701 else if (ref->type == REF_COMPONENT && seen_array_ref)
3705 /* Check for a dependency. */
3706 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3707 expr2->value.function.esym,
3708 expr2->value.function.actual))
3711 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3713 gcc_assert (expr2->value.function.isym
3714 || (gfc_return_by_reference (expr2->value.function.esym)
3715 && expr2->value.function.esym->result->attr.dimension));
3717 ss = gfc_walk_expr (expr1);
3718 gcc_assert (ss != gfc_ss_terminator);
3719 gfc_init_se (&se, NULL);
3720 gfc_start_block (&se.pre);
3721 se.want_pointer = 1;
3723 gfc_conv_array_parameter (&se, expr1, ss, 0);
3725 se.direct_byref = 1;
3726 se.ss = gfc_walk_expr (expr2);
3727 gcc_assert (se.ss != gfc_ss_terminator);
3728 gfc_conv_function_expr (&se, expr2);
3729 gfc_add_block_to_block (&se.pre, &se.post);
3731 return gfc_finish_block (&se.pre);
3734 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3737 is_zero_initializer_p (gfc_expr * expr)
3739 if (expr->expr_type != EXPR_CONSTANT)
3742 /* We ignore constants with prescribed memory representations for now. */
3743 if (expr->representation.string)
3746 switch (expr->ts.type)
3749 return mpz_cmp_si (expr->value.integer, 0) == 0;
3752 return mpfr_zero_p (expr->value.real)
3753 && MPFR_SIGN (expr->value.real) >= 0;
3756 return expr->value.logical == 0;
3759 return mpfr_zero_p (expr->value.complex.r)
3760 && MPFR_SIGN (expr->value.complex.r) >= 0
3761 && mpfr_zero_p (expr->value.complex.i)
3762 && MPFR_SIGN (expr->value.complex.i) >= 0;
3770 /* Try to efficiently translate array(:) = 0. Return NULL if this
3774 gfc_trans_zero_assign (gfc_expr * expr)
3776 tree dest, len, type;
3780 sym = expr->symtree->n.sym;
3781 dest = gfc_get_symbol_decl (sym);
3783 type = TREE_TYPE (dest);
3784 if (POINTER_TYPE_P (type))
3785 type = TREE_TYPE (type);
3786 if (!GFC_ARRAY_TYPE_P (type))
3789 /* Determine the length of the array. */
3790 len = GFC_TYPE_ARRAY_SIZE (type);
3791 if (!len || TREE_CODE (len) != INTEGER_CST)
3794 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3795 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3796 fold_convert (gfc_array_index_type, tmp));
3798 /* Convert arguments to the correct types. */
3799 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3800 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3802 dest = fold_convert (pvoid_type_node, dest);
3803 len = fold_convert (size_type_node, len);
3805 /* Construct call to __builtin_memset. */
3806 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
3807 3, dest, integer_zero_node, len);
3808 return fold_convert (void_type_node, tmp);
3812 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3813 that constructs the call to __builtin_memcpy. */
3816 gfc_build_memcpy_call (tree dst, tree src, tree len)
3820 /* Convert arguments to the correct types. */
3821 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3822 dst = gfc_build_addr_expr (pvoid_type_node, dst);
3824 dst = fold_convert (pvoid_type_node, dst);
3826 if (!POINTER_TYPE_P (TREE_TYPE (src)))
3827 src = gfc_build_addr_expr (pvoid_type_node, src);
3829 src = fold_convert (pvoid_type_node, src);
3831 len = fold_convert (size_type_node, len);
3833 /* Construct call to __builtin_memcpy. */
3834 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
3835 return fold_convert (void_type_node, tmp);
3839 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3840 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3841 source/rhs, both are gfc_full_array_ref_p which have been checked for
3845 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3847 tree dst, dlen, dtype;
3848 tree src, slen, stype;
3851 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3852 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3854 dtype = TREE_TYPE (dst);
3855 if (POINTER_TYPE_P (dtype))
3856 dtype = TREE_TYPE (dtype);
3857 stype = TREE_TYPE (src);
3858 if (POINTER_TYPE_P (stype))
3859 stype = TREE_TYPE (stype);
3861 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3864 /* Determine the lengths of the arrays. */
3865 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3866 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3868 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3869 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3870 fold_convert (gfc_array_index_type, tmp));
3872 slen = GFC_TYPE_ARRAY_SIZE (stype);
3873 if (!slen || TREE_CODE (slen) != INTEGER_CST)
3875 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
3876 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3877 fold_convert (gfc_array_index_type, tmp));
3879 /* Sanity check that they are the same. This should always be
3880 the case, as we should already have checked for conformance. */
3881 if (!tree_int_cst_equal (slen, dlen))
3884 return gfc_build_memcpy_call (dst, src, dlen);
3888 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3889 this can't be done. EXPR1 is the destination/lhs for which
3890 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3893 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3895 unsigned HOST_WIDE_INT nelem;
3901 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3905 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3906 dtype = TREE_TYPE (dst);
3907 if (POINTER_TYPE_P (dtype))
3908 dtype = TREE_TYPE (dtype);
3909 if (!GFC_ARRAY_TYPE_P (dtype))
3912 /* Determine the lengths of the array. */
3913 len = GFC_TYPE_ARRAY_SIZE (dtype);
3914 if (!len || TREE_CODE (len) != INTEGER_CST)
3917 /* Confirm that the constructor is the same size. */
3918 if (compare_tree_int (len, nelem) != 0)
3921 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3922 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3923 fold_convert (gfc_array_index_type, tmp));
3925 stype = gfc_typenode_for_spec (&expr2->ts);
3926 src = gfc_build_constant_array_constructor (expr2, stype);
3928 stype = TREE_TYPE (src);
3929 if (POINTER_TYPE_P (stype))
3930 stype = TREE_TYPE (stype);
3932 return gfc_build_memcpy_call (dst, src, len);
3936 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3937 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3940 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3945 gfc_ss *lss_section;
3953 /* Assignment of the form lhs = rhs. */
3954 gfc_start_block (&block);
3956 gfc_init_se (&lse, NULL);
3957 gfc_init_se (&rse, NULL);
3960 lss = gfc_walk_expr (expr1);
3962 if (lss != gfc_ss_terminator)
3964 /* The assignment needs scalarization. */
3967 /* Find a non-scalar SS from the lhs. */
3968 while (lss_section != gfc_ss_terminator
3969 && lss_section->type != GFC_SS_SECTION)
3970 lss_section = lss_section->next;
3972 gcc_assert (lss_section != gfc_ss_terminator);
3974 /* Initialize the scalarizer. */
3975 gfc_init_loopinfo (&loop);
3978 rss = gfc_walk_expr (expr2);
3979 if (rss == gfc_ss_terminator)
3981 /* The rhs is scalar. Add a ss for the expression. */
3982 rss = gfc_get_ss ();
3983 rss->next = gfc_ss_terminator;
3984 rss->type = GFC_SS_SCALAR;
3987 /* Associate the SS with the loop. */
3988 gfc_add_ss_to_loop (&loop, lss);
3989 gfc_add_ss_to_loop (&loop, rss);
3991 /* Calculate the bounds of the scalarization. */
3992 gfc_conv_ss_startstride (&loop);
3993 /* Resolve any data dependencies in the statement. */
3994 gfc_conv_resolve_dependencies (&loop, lss, rss);
3995 /* Setup the scalarizing loops. */
3996 gfc_conv_loop_setup (&loop);
3998 /* Setup the gfc_se structures. */
3999 gfc_copy_loopinfo_to_se (&lse, &loop);
4000 gfc_copy_loopinfo_to_se (&rse, &loop);
4003 gfc_mark_ss_chain_used (rss, 1);
4004 if (loop.temp_ss == NULL)
4007 gfc_mark_ss_chain_used (lss, 1);
4011 lse.ss = loop.temp_ss;
4012 gfc_mark_ss_chain_used (lss, 3);
4013 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4016 /* Start the scalarized loop body. */
4017 gfc_start_scalarized_body (&loop, &body);
4020 gfc_init_block (&body);
4022 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4024 /* Translate the expression. */
4025 gfc_conv_expr (&rse, expr2);
4029 gfc_conv_tmp_array_ref (&lse);
4030 gfc_advance_se_ss_chain (&lse);
4033 gfc_conv_expr (&lse, expr1);
4035 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4036 l_is_temp || init_flag,
4037 expr2->expr_type == EXPR_VARIABLE);
4038 gfc_add_expr_to_block (&body, tmp);
4040 if (lss == gfc_ss_terminator)
4042 /* Use the scalar assignment as is. */
4043 gfc_add_block_to_block (&block, &body);
4047 gcc_assert (lse.ss == gfc_ss_terminator
4048 && rse.ss == gfc_ss_terminator);
4052 gfc_trans_scalarized_loop_boundary (&loop, &body);
4054 /* We need to copy the temporary to the actual lhs. */
4055 gfc_init_se (&lse, NULL);
4056 gfc_init_se (&rse, NULL);
4057 gfc_copy_loopinfo_to_se (&lse, &loop);
4058 gfc_copy_loopinfo_to_se (&rse, &loop);
4060 rse.ss = loop.temp_ss;
4063 gfc_conv_tmp_array_ref (&rse);
4064 gfc_advance_se_ss_chain (&rse);
4065 gfc_conv_expr (&lse, expr1);
4067 gcc_assert (lse.ss == gfc_ss_terminator
4068 && rse.ss == gfc_ss_terminator);
4070 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4072 gfc_add_expr_to_block (&body, tmp);
4075 /* Generate the copying loops. */
4076 gfc_trans_scalarizing_loops (&loop, &body);
4078 /* Wrap the whole thing up. */
4079 gfc_add_block_to_block (&block, &loop.pre);
4080 gfc_add_block_to_block (&block, &loop.post);
4082 gfc_cleanup_loop (&loop);
4085 return gfc_finish_block (&block);
4089 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
4092 copyable_array_p (gfc_expr * expr)
4094 /* First check it's an array. */
4095 if (expr->rank < 1 || !expr->ref)
4098 /* Next check that it's of a simple enough type. */
4099 switch (expr->ts.type)
4111 return !expr->ts.derived->attr.alloc_comp;
4120 /* Translate an assignment. */
4123 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4127 /* Special case a single function returning an array. */
4128 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4130 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4135 /* Special case assigning an array to zero. */
4136 if (expr1->expr_type == EXPR_VARIABLE
4139 && expr1->ref->next == NULL
4140 && gfc_full_array_ref_p (expr1->ref)
4141 && is_zero_initializer_p (expr2))
4143 tmp = gfc_trans_zero_assign (expr1);
4148 /* Special case copying one array to another. */
4149 if (expr1->expr_type == EXPR_VARIABLE
4150 && copyable_array_p (expr1)
4151 && gfc_full_array_ref_p (expr1->ref)
4152 && expr2->expr_type == EXPR_VARIABLE
4153 && copyable_array_p (expr2)
4154 && gfc_full_array_ref_p (expr2->ref)
4155 && gfc_compare_types (&expr1->ts, &expr2->ts)
4156 && !gfc_check_dependency (expr1, expr2, 0))
4158 tmp = gfc_trans_array_copy (expr1, expr2);
4163 /* Special case initializing an array from a constant array constructor. */
4164 if (expr1->expr_type == EXPR_VARIABLE
4165 && copyable_array_p (expr1)
4166 && gfc_full_array_ref_p (expr1->ref)
4167 && expr2->expr_type == EXPR_ARRAY
4168 && gfc_compare_types (&expr1->ts, &expr2->ts))
4170 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4175 /* Fallback to the scalarizer to generate explicit loops. */
4176 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4180 gfc_trans_init_assign (gfc_code * code)
4182 return gfc_trans_assignment (code->expr, code->expr2, true);
4186 gfc_trans_assign (gfc_code * code)
4188 return gfc_trans_assignment (code->expr, code->expr2, false);