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;
1045 switch (expr->value.op.operator)
1047 case INTRINSIC_UPLUS:
1048 case INTRINSIC_PARENTHESES:
1049 gfc_conv_expr (se, expr->value.op.op1);
1052 case INTRINSIC_UMINUS:
1053 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1057 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1060 case INTRINSIC_PLUS:
1064 case INTRINSIC_MINUS:
1068 case INTRINSIC_TIMES:
1072 case INTRINSIC_DIVIDE:
1073 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1074 an integer, we must round towards zero, so we use a
1076 if (expr->ts.type == BT_INTEGER)
1077 code = TRUNC_DIV_EXPR;
1082 case INTRINSIC_POWER:
1083 gfc_conv_power_op (se, expr);
1086 case INTRINSIC_CONCAT:
1087 gfc_conv_concat_op (se, expr);
1091 code = TRUTH_ANDIF_EXPR;
1096 code = TRUTH_ORIF_EXPR;
1100 /* EQV and NEQV only work on logicals, but since we represent them
1101 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1103 case INTRINSIC_EQ_OS:
1111 case INTRINSIC_NE_OS:
1112 case INTRINSIC_NEQV:
1119 case INTRINSIC_GT_OS:
1126 case INTRINSIC_GE_OS:
1133 case INTRINSIC_LT_OS:
1140 case INTRINSIC_LE_OS:
1146 case INTRINSIC_USER:
1147 case INTRINSIC_ASSIGN:
1148 /* These should be converted into function calls by the frontend. */
1152 fatal_error ("Unknown intrinsic op");
1156 /* The only exception to this is **, which is handled separately anyway. */
1157 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1159 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1163 gfc_init_se (&lse, se);
1164 gfc_conv_expr (&lse, expr->value.op.op1);
1165 gfc_add_block_to_block (&se->pre, &lse.pre);
1168 gfc_init_se (&rse, se);
1169 gfc_conv_expr (&rse, expr->value.op.op2);
1170 gfc_add_block_to_block (&se->pre, &rse.pre);
1174 gfc_conv_string_parameter (&lse);
1175 gfc_conv_string_parameter (&rse);
1177 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1178 rse.string_length, rse.expr);
1179 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1180 gfc_add_block_to_block (&lse.post, &rse.post);
1183 type = gfc_typenode_for_spec (&expr->ts);
1187 /* The result of logical ops is always boolean_type_node. */
1188 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1189 se->expr = convert (type, tmp);
1192 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1194 /* Add the post blocks. */
1195 gfc_add_block_to_block (&se->post, &rse.post);
1196 gfc_add_block_to_block (&se->post, &lse.post);
1199 /* If a string's length is one, we convert it to a single character. */
1202 gfc_to_single_character (tree len, tree str)
1204 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1206 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1207 && TREE_INT_CST_HIGH (len) == 0)
1209 str = fold_convert (pchar_type_node, str);
1210 return build_fold_indirect_ref (str);
1218 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1221 if (sym->backend_decl)
1223 /* This becomes the nominal_type in
1224 function.c:assign_parm_find_data_types. */
1225 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1226 /* This becomes the passed_type in
1227 function.c:assign_parm_find_data_types. C promotes char to
1228 integer for argument passing. */
1229 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1231 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1236 /* If we have a constant character expression, make it into an
1238 if ((*expr)->expr_type == EXPR_CONSTANT)
1242 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1243 if ((*expr)->ts.kind != gfc_c_int_kind)
1245 /* The expr needs to be compatible with a C int. If the
1246 conversion fails, then the 2 causes an ICE. */
1247 ts.type = BT_INTEGER;
1248 ts.kind = gfc_c_int_kind;
1249 gfc_convert_type (*expr, &ts, 2);
1252 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1254 if ((*expr)->ref == NULL)
1256 se->expr = gfc_to_single_character
1257 (build_int_cst (integer_type_node, 1),
1258 gfc_build_addr_expr (pchar_type_node,
1260 ((*expr)->symtree->n.sym)));
1264 gfc_conv_variable (se, *expr);
1265 se->expr = gfc_to_single_character
1266 (build_int_cst (integer_type_node, 1),
1267 gfc_build_addr_expr (pchar_type_node, se->expr));
1274 /* Compare two strings. If they are all single characters, the result is the
1275 subtraction of them. Otherwise, we build a library call. */
1278 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1284 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1285 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1287 sc1 = gfc_to_single_character (len1, str1);
1288 sc2 = gfc_to_single_character (len2, str2);
1290 /* Deal with single character specially. */
1291 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1293 sc1 = fold_convert (integer_type_node, sc1);
1294 sc2 = fold_convert (integer_type_node, sc2);
1295 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1298 /* Build a call for the comparison. */
1299 tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1300 len1, str1, len2, str2);
1305 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1309 if (sym->attr.dummy)
1311 tmp = gfc_get_symbol_decl (sym);
1312 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1313 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1317 if (!sym->backend_decl)
1318 sym->backend_decl = gfc_get_extern_function_decl (sym);
1320 tmp = sym->backend_decl;
1321 if (sym->attr.cray_pointee)
1322 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1323 gfc_get_symbol_decl (sym->cp_pointer));
1324 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1326 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1327 tmp = build_fold_addr_expr (tmp);
1334 /* Translate the call for an elemental subroutine call used in an operator
1335 assignment. This is a simplified version of gfc_conv_function_call. */
1338 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1345 /* Only elemental subroutines with two arguments. */
1346 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1347 gcc_assert (sym->formal->next->next == NULL);
1349 gfc_init_block (&block);
1351 gfc_add_block_to_block (&block, &lse->pre);
1352 gfc_add_block_to_block (&block, &rse->pre);
1354 /* Build the argument list for the call, including hidden string lengths. */
1355 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1356 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1357 if (lse->string_length != NULL_TREE)
1358 args = gfc_chainon_list (args, lse->string_length);
1359 if (rse->string_length != NULL_TREE)
1360 args = gfc_chainon_list (args, rse->string_length);
1362 /* Build the function call. */
1363 gfc_init_se (&se, NULL);
1364 gfc_conv_function_val (&se, sym);
1365 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1366 tmp = build_call_list (tmp, se.expr, args);
1367 gfc_add_expr_to_block (&block, tmp);
1369 gfc_add_block_to_block (&block, &lse->post);
1370 gfc_add_block_to_block (&block, &rse->post);
1372 return gfc_finish_block (&block);
1376 /* Initialize MAPPING. */
1379 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1381 mapping->syms = NULL;
1382 mapping->charlens = NULL;
1386 /* Free all memory held by MAPPING (but not MAPPING itself). */
1389 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1391 gfc_interface_sym_mapping *sym;
1392 gfc_interface_sym_mapping *nextsym;
1394 gfc_charlen *nextcl;
1396 for (sym = mapping->syms; sym; sym = nextsym)
1398 nextsym = sym->next;
1399 gfc_free_symbol (sym->new->n.sym);
1400 gfc_free (sym->new);
1403 for (cl = mapping->charlens; cl; cl = nextcl)
1406 gfc_free_expr (cl->length);
1412 /* Return a copy of gfc_charlen CL. Add the returned structure to
1413 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1415 static gfc_charlen *
1416 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1421 new = gfc_get_charlen ();
1422 new->next = mapping->charlens;
1423 new->length = gfc_copy_expr (cl->length);
1425 mapping->charlens = new;
1430 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1431 array variable that can be used as the actual argument for dummy
1432 argument SYM. Add any initialization code to BLOCK. PACKED is as
1433 for gfc_get_nodesc_array_type and DATA points to the first element
1434 in the passed array. */
1437 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1438 gfc_packed packed, tree data)
1443 type = gfc_typenode_for_spec (&sym->ts);
1444 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1446 var = gfc_create_var (type, "ifm");
1447 gfc_add_modify_expr (block, var, fold_convert (type, data));
1453 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1454 and offset of descriptorless array type TYPE given that it has the same
1455 size as DESC. Add any set-up code to BLOCK. */
1458 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1465 offset = gfc_index_zero_node;
1466 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1468 dim = gfc_rank_cst[n];
1469 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1470 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1472 GFC_TYPE_ARRAY_LBOUND (type, n)
1473 = gfc_conv_descriptor_lbound (desc, dim);
1474 GFC_TYPE_ARRAY_UBOUND (type, n)
1475 = gfc_conv_descriptor_ubound (desc, dim);
1477 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1479 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1480 gfc_conv_descriptor_ubound (desc, dim),
1481 gfc_conv_descriptor_lbound (desc, dim));
1482 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1483 GFC_TYPE_ARRAY_LBOUND (type, n),
1485 tmp = gfc_evaluate_now (tmp, block);
1486 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1488 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1489 GFC_TYPE_ARRAY_LBOUND (type, n),
1490 GFC_TYPE_ARRAY_STRIDE (type, n));
1491 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1493 offset = gfc_evaluate_now (offset, block);
1494 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1498 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1499 in SE. The caller may still use se->expr and se->string_length after
1500 calling this function. */
1503 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1504 gfc_symbol * sym, gfc_se * se)
1506 gfc_interface_sym_mapping *sm;
1510 gfc_symbol *new_sym;
1512 gfc_symtree *new_symtree;
1514 /* Create a new symbol to represent the actual argument. */
1515 new_sym = gfc_new_symbol (sym->name, NULL);
1516 new_sym->ts = sym->ts;
1517 new_sym->attr.referenced = 1;
1518 new_sym->attr.dimension = sym->attr.dimension;
1519 new_sym->attr.pointer = sym->attr.pointer;
1520 new_sym->attr.allocatable = sym->attr.allocatable;
1521 new_sym->attr.flavor = sym->attr.flavor;
1523 /* Create a fake symtree for it. */
1525 new_symtree = gfc_new_symtree (&root, sym->name);
1526 new_symtree->n.sym = new_sym;
1527 gcc_assert (new_symtree == root);
1529 /* Create a dummy->actual mapping. */
1530 sm = gfc_getmem (sizeof (*sm));
1531 sm->next = mapping->syms;
1533 sm->new = new_symtree;
1536 /* Stabilize the argument's value. */
1537 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1539 if (sym->ts.type == BT_CHARACTER)
1541 /* Create a copy of the dummy argument's length. */
1542 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1544 /* If the length is specified as "*", record the length that
1545 the caller is passing. We should use the callee's length
1546 in all other cases. */
1547 if (!new_sym->ts.cl->length)
1549 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1550 new_sym->ts.cl->backend_decl = se->string_length;
1554 /* Use the passed value as-is if the argument is a function. */
1555 if (sym->attr.flavor == FL_PROCEDURE)
1558 /* If the argument is either a string or a pointer to a string,
1559 convert it to a boundless character type. */
1560 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1562 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1563 tmp = build_pointer_type (tmp);
1564 if (sym->attr.pointer)
1565 value = build_fold_indirect_ref (se->expr);
1568 value = fold_convert (tmp, value);
1571 /* If the argument is a scalar, a pointer to an array or an allocatable,
1573 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1574 value = build_fold_indirect_ref (se->expr);
1576 /* For character(*), use the actual argument's descriptor. */
1577 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1578 value = build_fold_indirect_ref (se->expr);
1580 /* If the argument is an array descriptor, use it to determine
1581 information about the actual argument's shape. */
1582 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1583 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1585 /* Get the actual argument's descriptor. */
1586 desc = build_fold_indirect_ref (se->expr);
1588 /* Create the replacement variable. */
1589 tmp = gfc_conv_descriptor_data_get (desc);
1590 value = gfc_get_interface_mapping_array (&se->pre, sym,
1593 /* Use DESC to work out the upper bounds, strides and offset. */
1594 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1597 /* Otherwise we have a packed array. */
1598 value = gfc_get_interface_mapping_array (&se->pre, sym,
1599 PACKED_FULL, se->expr);
1601 new_sym->backend_decl = value;
1605 /* Called once all dummy argument mappings have been added to MAPPING,
1606 but before the mapping is used to evaluate expressions. Pre-evaluate
1607 the length of each argument, adding any initialization code to PRE and
1608 any finalization code to POST. */
1611 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1612 stmtblock_t * pre, stmtblock_t * post)
1614 gfc_interface_sym_mapping *sym;
1618 for (sym = mapping->syms; sym; sym = sym->next)
1619 if (sym->new->n.sym->ts.type == BT_CHARACTER
1620 && !sym->new->n.sym->ts.cl->backend_decl)
1622 expr = sym->new->n.sym->ts.cl->length;
1623 gfc_apply_interface_mapping_to_expr (mapping, expr);
1624 gfc_init_se (&se, NULL);
1625 gfc_conv_expr (&se, expr);
1627 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1628 gfc_add_block_to_block (pre, &se.pre);
1629 gfc_add_block_to_block (post, &se.post);
1631 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1636 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1640 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1641 gfc_constructor * c)
1643 for (; c; c = c->next)
1645 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1648 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1649 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1650 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1656 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1660 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1665 for (; ref; ref = ref->next)
1669 for (n = 0; n < ref->u.ar.dimen; n++)
1671 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1672 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1673 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1675 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1682 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1683 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1689 /* EXPR is a copy of an expression that appeared in the interface
1690 associated with MAPPING. Walk it recursively looking for references to
1691 dummy arguments that MAPPING maps to actual arguments. Replace each such
1692 reference with a reference to the associated actual argument. */
1695 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1698 gfc_interface_sym_mapping *sym;
1699 gfc_actual_arglist *actual;
1700 int seen_result = 0;
1705 /* Copying an expression does not copy its length, so do that here. */
1706 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1708 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1709 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1712 /* Apply the mapping to any references. */
1713 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1715 /* ...and to the expression's symbol, if it has one. */
1717 for (sym = mapping->syms; sym; sym = sym->next)
1718 if (sym->old == expr->symtree->n.sym)
1719 expr->symtree = sym->new;
1721 /* ...and to subexpressions in expr->value. */
1722 switch (expr->expr_type)
1725 if (expr->symtree->n.sym->attr.result)
1729 case EXPR_SUBSTRING:
1733 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1734 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1738 if (expr->value.function.esym == NULL
1739 && expr->value.function.isym != NULL
1740 && expr->value.function.isym->id == GFC_ISYM_LEN
1741 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
1742 && gfc_apply_interface_mapping_to_expr (mapping,
1743 expr->value.function.actual->expr))
1746 new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
1748 gfc_free (new_expr);
1749 gfc_apply_interface_mapping_to_expr (mapping, expr);
1753 for (sym = mapping->syms; sym; sym = sym->next)
1754 if (sym->old == expr->value.function.esym)
1755 expr->value.function.esym = sym->new->n.sym;
1757 for (actual = expr->value.function.actual; actual; actual = actual->next)
1758 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1762 case EXPR_STRUCTURE:
1763 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1770 /* Evaluate interface expression EXPR using MAPPING. Store the result
1774 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1775 gfc_se * se, gfc_expr * expr)
1777 expr = gfc_copy_expr (expr);
1778 gfc_apply_interface_mapping_to_expr (mapping, expr);
1779 gfc_conv_expr (se, expr);
1780 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1781 gfc_free_expr (expr);
1784 /* Returns a reference to a temporary array into which a component of
1785 an actual argument derived type array is copied and then returned
1786 after the function call.
1787 TODO Get rid of this kludge, when array descriptors are capable of
1788 handling arrays with a bigger stride in bytes than size. */
1791 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1792 int g77, sym_intent intent)
1808 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1810 gfc_init_se (&lse, NULL);
1811 gfc_init_se (&rse, NULL);
1813 /* Walk the argument expression. */
1814 rss = gfc_walk_expr (expr);
1816 gcc_assert (rss != gfc_ss_terminator);
1818 /* Initialize the scalarizer. */
1819 gfc_init_loopinfo (&loop);
1820 gfc_add_ss_to_loop (&loop, rss);
1822 /* Calculate the bounds of the scalarization. */
1823 gfc_conv_ss_startstride (&loop);
1825 /* Build an ss for the temporary. */
1826 base_type = gfc_typenode_for_spec (&expr->ts);
1827 if (GFC_ARRAY_TYPE_P (base_type)
1828 || GFC_DESCRIPTOR_TYPE_P (base_type))
1829 base_type = gfc_get_element_type (base_type);
1831 loop.temp_ss = gfc_get_ss ();;
1832 loop.temp_ss->type = GFC_SS_TEMP;
1833 loop.temp_ss->data.temp.type = base_type;
1835 if (expr->ts.type == BT_CHARACTER)
1837 gfc_ref *char_ref = expr->ref;
1839 for (; char_ref; char_ref = char_ref->next)
1840 if (char_ref->type == REF_SUBSTRING)
1844 expr->ts.cl = gfc_get_charlen ();
1845 expr->ts.cl->next = char_ref->u.ss.length->next;
1846 char_ref->u.ss.length->next = expr->ts.cl;
1848 gfc_init_se (&tmp_se, NULL);
1849 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1850 gfc_array_index_type);
1851 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1852 tmp_se.expr, gfc_index_one_node);
1853 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1854 gfc_init_se (&tmp_se, NULL);
1855 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1856 gfc_array_index_type);
1857 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1859 tmp = fold_convert (gfc_charlen_type_node, tmp);
1860 expr->ts.cl->backend_decl = tmp;
1864 loop.temp_ss->data.temp.type
1865 = gfc_typenode_for_spec (&expr->ts);
1866 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1869 loop.temp_ss->data.temp.dimen = loop.dimen;
1870 loop.temp_ss->next = gfc_ss_terminator;
1872 /* Associate the SS with the loop. */
1873 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1875 /* Setup the scalarizing loops. */
1876 gfc_conv_loop_setup (&loop);
1878 /* Pass the temporary descriptor back to the caller. */
1879 info = &loop.temp_ss->data.info;
1880 parmse->expr = info->descriptor;
1882 /* Setup the gfc_se structures. */
1883 gfc_copy_loopinfo_to_se (&lse, &loop);
1884 gfc_copy_loopinfo_to_se (&rse, &loop);
1887 lse.ss = loop.temp_ss;
1888 gfc_mark_ss_chain_used (rss, 1);
1889 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1891 /* Start the scalarized loop body. */
1892 gfc_start_scalarized_body (&loop, &body);
1894 /* Translate the expression. */
1895 gfc_conv_expr (&rse, expr);
1897 gfc_conv_tmp_array_ref (&lse);
1898 gfc_advance_se_ss_chain (&lse);
1900 if (intent != INTENT_OUT)
1902 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1903 gfc_add_expr_to_block (&body, tmp);
1904 gcc_assert (rse.ss == gfc_ss_terminator);
1905 gfc_trans_scalarizing_loops (&loop, &body);
1909 /* Make sure that the temporary declaration survives by merging
1910 all the loop declarations into the current context. */
1911 for (n = 0; n < loop.dimen; n++)
1913 gfc_merge_block_scope (&body);
1914 body = loop.code[loop.order[n]];
1916 gfc_merge_block_scope (&body);
1919 /* Add the post block after the second loop, so that any
1920 freeing of allocated memory is done at the right time. */
1921 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1923 /**********Copy the temporary back again.*********/
1925 gfc_init_se (&lse, NULL);
1926 gfc_init_se (&rse, NULL);
1928 /* Walk the argument expression. */
1929 lss = gfc_walk_expr (expr);
1930 rse.ss = loop.temp_ss;
1933 /* Initialize the scalarizer. */
1934 gfc_init_loopinfo (&loop2);
1935 gfc_add_ss_to_loop (&loop2, lss);
1937 /* Calculate the bounds of the scalarization. */
1938 gfc_conv_ss_startstride (&loop2);
1940 /* Setup the scalarizing loops. */
1941 gfc_conv_loop_setup (&loop2);
1943 gfc_copy_loopinfo_to_se (&lse, &loop2);
1944 gfc_copy_loopinfo_to_se (&rse, &loop2);
1946 gfc_mark_ss_chain_used (lss, 1);
1947 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1949 /* Declare the variable to hold the temporary offset and start the
1950 scalarized loop body. */
1951 offset = gfc_create_var (gfc_array_index_type, NULL);
1952 gfc_start_scalarized_body (&loop2, &body);
1954 /* Build the offsets for the temporary from the loop variables. The
1955 temporary array has lbounds of zero and strides of one in all
1956 dimensions, so this is very simple. The offset is only computed
1957 outside the innermost loop, so the overall transfer could be
1958 optimized further. */
1959 info = &rse.ss->data.info;
1961 tmp_index = gfc_index_zero_node;
1962 for (n = info->dimen - 1; n > 0; n--)
1965 tmp = rse.loop->loopvar[n];
1966 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1967 tmp, rse.loop->from[n]);
1968 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1971 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1972 rse.loop->to[n-1], rse.loop->from[n-1]);
1973 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1974 tmp_str, gfc_index_one_node);
1976 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1980 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1981 tmp_index, rse.loop->from[0]);
1982 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1984 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1985 rse.loop->loopvar[0], offset);
1987 /* Now use the offset for the reference. */
1988 tmp = build_fold_indirect_ref (info->data);
1989 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1991 if (expr->ts.type == BT_CHARACTER)
1992 rse.string_length = expr->ts.cl->backend_decl;
1994 gfc_conv_expr (&lse, expr);
1996 gcc_assert (lse.ss == gfc_ss_terminator);
1998 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1999 gfc_add_expr_to_block (&body, tmp);
2001 /* Generate the copying loops. */
2002 gfc_trans_scalarizing_loops (&loop2, &body);
2004 /* Wrap the whole thing up by adding the second loop to the post-block
2005 and following it by the post-block of the first loop. In this way,
2006 if the temporary needs freeing, it is done after use! */
2007 if (intent != INTENT_IN)
2009 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2010 gfc_add_block_to_block (&parmse->post, &loop2.post);
2013 gfc_add_block_to_block (&parmse->post, &loop.post);
2015 gfc_cleanup_loop (&loop);
2016 gfc_cleanup_loop (&loop2);
2018 /* Pass the string length to the argument expression. */
2019 if (expr->ts.type == BT_CHARACTER)
2020 parmse->string_length = expr->ts.cl->backend_decl;
2022 /* We want either the address for the data or the address of the descriptor,
2023 depending on the mode of passing array arguments. */
2025 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2027 parmse->expr = build_fold_addr_expr (parmse->expr);
2032 /* Is true if an array reference is followed by a component or substring
2036 is_aliased_array (gfc_expr * e)
2042 for (ref = e->ref; ref; ref = ref->next)
2044 if (ref->type == REF_ARRAY
2045 && ref->u.ar.type != AR_ELEMENT)
2049 && ref->type != REF_ARRAY)
2055 /* Generate the code for argument list functions. */
2058 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2060 /* Pass by value for g77 %VAL(arg), pass the address
2061 indirectly for %LOC, else by reference. Thus %REF
2062 is a "do-nothing" and %LOC is the same as an F95
2064 if (strncmp (name, "%VAL", 4) == 0)
2065 gfc_conv_expr (se, expr);
2066 else if (strncmp (name, "%LOC", 4) == 0)
2068 gfc_conv_expr_reference (se, expr);
2069 se->expr = gfc_build_addr_expr (NULL, se->expr);
2071 else if (strncmp (name, "%REF", 4) == 0)
2072 gfc_conv_expr_reference (se, expr);
2074 gfc_error ("Unknown argument list function at %L", &expr->where);
2078 /* Generate code for a procedure call. Note can return se->post != NULL.
2079 If se->direct_byref is set then se->expr contains the return parameter.
2080 Return nonzero, if the call has alternate specifiers. */
2083 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2084 gfc_actual_arglist * arg, tree append_args)
2086 gfc_interface_mapping mapping;
2100 gfc_formal_arglist *formal;
2101 int has_alternate_specifier = 0;
2102 bool need_interface_mapping;
2109 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2111 arglist = NULL_TREE;
2112 retargs = NULL_TREE;
2113 stringargs = NULL_TREE;
2117 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2119 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2121 if (arg->expr->rank == 0)
2122 gfc_conv_expr_reference (se, arg->expr);
2126 /* This is really the actual arg because no formal arglist is
2127 created for C_LOC. */
2128 fsym = arg->expr->symtree->n.sym;
2130 /* We should want it to do g77 calling convention. */
2132 && !(fsym->attr.pointer || fsym->attr.allocatable)
2133 && fsym->as->type != AS_ASSUMED_SHAPE;
2134 f = f || !sym->attr.always_explicit;
2136 argss = gfc_walk_expr (arg->expr);
2137 gfc_conv_array_parameter (se, arg->expr, argss, f);
2142 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2144 arg->expr->ts.type = sym->ts.derived->ts.type;
2145 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2146 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2147 gfc_conv_expr_reference (se, arg->expr);
2155 if (!sym->attr.elemental)
2157 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2158 if (se->ss->useflags)
2160 gcc_assert (gfc_return_by_reference (sym)
2161 && sym->result->attr.dimension);
2162 gcc_assert (se->loop != NULL);
2164 /* Access the previously obtained result. */
2165 gfc_conv_tmp_array_ref (se);
2166 gfc_advance_se_ss_chain (se);
2170 info = &se->ss->data.info;
2175 gfc_init_block (&post);
2176 gfc_init_interface_mapping (&mapping);
2177 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2178 && sym->ts.cl->length
2179 && sym->ts.cl->length->expr_type
2181 || sym->attr.dimension);
2182 formal = sym->formal;
2183 /* Evaluate the arguments. */
2184 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2187 fsym = formal ? formal->sym : NULL;
2188 parm_kind = MISSING;
2192 if (se->ignore_optional)
2194 /* Some intrinsics have already been resolved to the correct
2198 else if (arg->label)
2200 has_alternate_specifier = 1;
2205 /* Pass a NULL pointer for an absent arg. */
2206 gfc_init_se (&parmse, NULL);
2207 parmse.expr = null_pointer_node;
2208 if (arg->missing_arg_type == BT_CHARACTER)
2209 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2212 else if (se->ss && se->ss->useflags)
2214 /* An elemental function inside a scalarized loop. */
2215 gfc_init_se (&parmse, se);
2216 gfc_conv_expr_reference (&parmse, e);
2217 parm_kind = ELEMENTAL;
2221 /* A scalar or transformational function. */
2222 gfc_init_se (&parmse, NULL);
2223 argss = gfc_walk_expr (e);
2225 if (argss == gfc_ss_terminator)
2227 if (fsym && fsym->attr.value)
2229 if (fsym->ts.type == BT_CHARACTER
2230 && fsym->ts.is_c_interop
2231 && fsym->ns->proc_name != NULL
2232 && fsym->ns->proc_name->attr.is_bind_c)
2235 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2236 if (parmse.expr == NULL)
2237 gfc_conv_expr (&parmse, e);
2240 gfc_conv_expr (&parmse, e);
2242 else if (arg->name && arg->name[0] == '%')
2243 /* Argument list functions %VAL, %LOC and %REF are signalled
2244 through arg->name. */
2245 conv_arglist_function (&parmse, arg->expr, arg->name);
2246 else if ((e->expr_type == EXPR_FUNCTION)
2247 && e->symtree->n.sym->attr.pointer
2248 && fsym && fsym->attr.target)
2250 gfc_conv_expr (&parmse, e);
2251 parmse.expr = build_fold_addr_expr (parmse.expr);
2255 gfc_conv_expr_reference (&parmse, e);
2256 if (fsym && fsym->attr.pointer
2257 && fsym->attr.flavor != FL_PROCEDURE
2258 && e->expr_type != EXPR_NULL)
2260 /* Scalar pointer dummy args require an extra level of
2261 indirection. The null pointer already contains
2262 this level of indirection. */
2263 parm_kind = SCALAR_POINTER;
2264 parmse.expr = build_fold_addr_expr (parmse.expr);
2270 /* If the procedure requires an explicit interface, the actual
2271 argument is passed according to the corresponding formal
2272 argument. If the corresponding formal argument is a POINTER,
2273 ALLOCATABLE or assumed shape, we do not use g77's calling
2274 convention, and pass the address of the array descriptor
2275 instead. Otherwise we use g77's calling convention. */
2278 && !(fsym->attr.pointer || fsym->attr.allocatable)
2279 && fsym->as->type != AS_ASSUMED_SHAPE;
2280 f = f || !sym->attr.always_explicit;
2282 if (e->expr_type == EXPR_VARIABLE
2283 && is_aliased_array (e))
2284 /* The actual argument is a component reference to an
2285 array of derived types. In this case, the argument
2286 is converted to a temporary, which is passed and then
2287 written back after the procedure call. */
2288 gfc_conv_aliased_arg (&parmse, e, f,
2289 fsym ? fsym->attr.intent : INTENT_INOUT);
2291 gfc_conv_array_parameter (&parmse, e, argss, f);
2293 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2294 allocated on entry, it must be deallocated. */
2295 if (fsym && fsym->attr.allocatable
2296 && fsym->attr.intent == INTENT_OUT)
2298 tmp = build_fold_indirect_ref (parmse.expr);
2299 tmp = gfc_trans_dealloc_allocated (tmp);
2300 gfc_add_expr_to_block (&se->pre, tmp);
2310 /* If an optional argument is itself an optional dummy
2311 argument, check its presence and substitute a null
2313 if (e->expr_type == EXPR_VARIABLE
2314 && e->symtree->n.sym->attr.optional
2315 && fsym->attr.optional)
2316 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2318 /* Obtain the character length of an assumed character
2319 length procedure from the typespec. */
2320 if (fsym->ts.type == BT_CHARACTER
2321 && parmse.string_length == NULL_TREE
2322 && e->ts.type == BT_PROCEDURE
2323 && e->symtree->n.sym->ts.type == BT_CHARACTER
2324 && e->symtree->n.sym->ts.cl->length != NULL)
2326 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2327 parmse.string_length
2328 = e->symtree->n.sym->ts.cl->backend_decl;
2332 if (need_interface_mapping)
2333 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2336 gfc_add_block_to_block (&se->pre, &parmse.pre);
2337 gfc_add_block_to_block (&post, &parmse.post);
2339 /* Allocated allocatable components of derived types must be
2340 deallocated for INTENT(OUT) dummy arguments and non-variable
2341 scalars. Non-variable arrays are dealt with in trans-array.c
2342 (gfc_conv_array_parameter). */
2343 if (e && e->ts.type == BT_DERIVED
2344 && e->ts.derived->attr.alloc_comp
2345 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2347 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2350 tmp = build_fold_indirect_ref (parmse.expr);
2351 parm_rank = e->rank;
2359 case (SCALAR_POINTER):
2360 tmp = build_fold_indirect_ref (tmp);
2367 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2368 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2369 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2370 tmp, build_empty_stmt ());
2372 if (e->expr_type != EXPR_VARIABLE)
2373 /* Don't deallocate non-variables until they have been used. */
2374 gfc_add_expr_to_block (&se->post, tmp);
2377 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2378 gfc_add_expr_to_block (&se->pre, tmp);
2382 /* Character strings are passed as two parameters, a length and a
2384 if (parmse.string_length != NULL_TREE)
2385 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2387 arglist = gfc_chainon_list (arglist, parmse.expr);
2389 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2392 if (ts.type == BT_CHARACTER)
2394 if (sym->ts.cl->length == NULL)
2396 /* Assumed character length results are not allowed by 5.1.1.5 of the
2397 standard and are trapped in resolve.c; except in the case of SPREAD
2398 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2399 we take the character length of the first argument for the result.
2400 For dummies, we have to look through the formal argument list for
2401 this function and use the character length found there.*/
2402 if (!sym->attr.dummy)
2403 cl.backend_decl = TREE_VALUE (stringargs);
2406 formal = sym->ns->proc_name->formal;
2407 for (; formal; formal = formal->next)
2408 if (strcmp (formal->sym->name, sym->name) == 0)
2409 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2416 /* Calculate the length of the returned string. */
2417 gfc_init_se (&parmse, NULL);
2418 if (need_interface_mapping)
2419 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2421 gfc_conv_expr (&parmse, sym->ts.cl->length);
2422 gfc_add_block_to_block (&se->pre, &parmse.pre);
2423 gfc_add_block_to_block (&se->post, &parmse.post);
2425 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2426 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2427 build_int_cst (gfc_charlen_type_node, 0));
2428 cl.backend_decl = tmp;
2431 /* Set up a charlen structure for it. */
2436 len = cl.backend_decl;
2439 byref = gfc_return_by_reference (sym);
2442 if (se->direct_byref)
2444 /* Sometimes, too much indirection can be applied; eg. for
2445 function_result = array_valued_recursive_function. */
2446 if (TREE_TYPE (TREE_TYPE (se->expr))
2447 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2448 && GFC_DESCRIPTOR_TYPE_P
2449 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2450 se->expr = build_fold_indirect_ref (se->expr);
2452 retargs = gfc_chainon_list (retargs, se->expr);
2454 else if (sym->result->attr.dimension)
2456 gcc_assert (se->loop && info);
2458 /* Set the type of the array. */
2459 tmp = gfc_typenode_for_spec (&ts);
2460 info->dimen = se->loop->dimen;
2462 /* Evaluate the bounds of the result, if known. */
2463 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2465 /* Create a temporary to store the result. In case the function
2466 returns a pointer, the temporary will be a shallow copy and
2467 mustn't be deallocated. */
2468 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2469 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2470 false, !sym->attr.pointer, callee_alloc);
2472 /* Pass the temporary as the first argument. */
2473 tmp = info->descriptor;
2474 tmp = build_fold_addr_expr (tmp);
2475 retargs = gfc_chainon_list (retargs, tmp);
2477 else if (ts.type == BT_CHARACTER)
2479 /* Pass the string length. */
2480 type = gfc_get_character_type (ts.kind, ts.cl);
2481 type = build_pointer_type (type);
2483 /* Return an address to a char[0:len-1]* temporary for
2484 character pointers. */
2485 if (sym->attr.pointer || sym->attr.allocatable)
2487 /* Build char[0:len-1] * pstr. */
2488 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2489 build_int_cst (gfc_charlen_type_node, 1));
2490 tmp = build_range_type (gfc_array_index_type,
2491 gfc_index_zero_node, tmp);
2492 tmp = build_array_type (gfc_character1_type_node, tmp);
2493 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2495 /* Provide an address expression for the function arguments. */
2496 var = build_fold_addr_expr (var);
2499 var = gfc_conv_string_tmp (se, type, len);
2501 retargs = gfc_chainon_list (retargs, var);
2505 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2507 type = gfc_get_complex_type (ts.kind);
2508 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2509 retargs = gfc_chainon_list (retargs, var);
2512 /* Add the string length to the argument list. */
2513 if (ts.type == BT_CHARACTER)
2514 retargs = gfc_chainon_list (retargs, len);
2516 gfc_free_interface_mapping (&mapping);
2518 /* Add the return arguments. */
2519 arglist = chainon (retargs, arglist);
2521 /* Add the hidden string length parameters to the arguments. */
2522 arglist = chainon (arglist, stringargs);
2524 /* We may want to append extra arguments here. This is used e.g. for
2525 calls to libgfortran_matmul_??, which need extra information. */
2526 if (append_args != NULL_TREE)
2527 arglist = chainon (arglist, append_args);
2529 /* Generate the actual call. */
2530 gfc_conv_function_val (se, sym);
2532 /* If there are alternate return labels, function type should be
2533 integer. Can't modify the type in place though, since it can be shared
2534 with other functions. For dummy arguments, the typing is done to
2535 to this result, even if it has to be repeated for each call. */
2536 if (has_alternate_specifier
2537 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2539 if (!sym->attr.dummy)
2541 TREE_TYPE (sym->backend_decl)
2542 = build_function_type (integer_type_node,
2543 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2544 se->expr = build_fold_addr_expr (sym->backend_decl);
2547 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2550 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2551 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2553 /* If we have a pointer function, but we don't want a pointer, e.g.
2556 where f is pointer valued, we have to dereference the result. */
2557 if (!se->want_pointer && !byref && sym->attr.pointer)
2558 se->expr = build_fold_indirect_ref (se->expr);
2560 /* f2c calling conventions require a scalar default real function to
2561 return a double precision result. Convert this back to default
2562 real. We only care about the cases that can happen in Fortran 77.
2564 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2565 && sym->ts.kind == gfc_default_real_kind
2566 && !sym->attr.always_explicit)
2567 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2569 /* A pure function may still have side-effects - it may modify its
2571 TREE_SIDE_EFFECTS (se->expr) = 1;
2573 if (!sym->attr.pure)
2574 TREE_SIDE_EFFECTS (se->expr) = 1;
2579 /* Add the function call to the pre chain. There is no expression. */
2580 gfc_add_expr_to_block (&se->pre, se->expr);
2581 se->expr = NULL_TREE;
2583 if (!se->direct_byref)
2585 if (sym->attr.dimension)
2587 if (flag_bounds_check)
2589 /* Check the data pointer hasn't been modified. This would
2590 happen in a function returning a pointer. */
2591 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2592 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2594 gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
2596 se->expr = info->descriptor;
2597 /* Bundle in the string length. */
2598 se->string_length = len;
2600 else if (sym->ts.type == BT_CHARACTER)
2602 /* Dereference for character pointer results. */
2603 if (sym->attr.pointer || sym->attr.allocatable)
2604 se->expr = build_fold_indirect_ref (var);
2608 se->string_length = len;
2612 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2613 se->expr = build_fold_indirect_ref (var);
2618 /* Follow the function call with the argument post block. */
2620 gfc_add_block_to_block (&se->pre, &post);
2622 gfc_add_block_to_block (&se->post, &post);
2624 return has_alternate_specifier;
2628 /* Generate code to copy a string. */
2631 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2632 tree slength, tree src)
2634 tree tmp, dlen, slen;
2642 stmtblock_t tempblock;
2644 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2645 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2647 /* Deal with single character specially. */
2648 dsc = gfc_to_single_character (dlen, dest);
2649 ssc = gfc_to_single_character (slen, src);
2650 if (dsc != NULL_TREE && ssc != NULL_TREE)
2652 gfc_add_modify_expr (block, dsc, ssc);
2656 /* Do nothing if the destination length is zero. */
2657 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2658 build_int_cst (size_type_node, 0));
2660 /* The following code was previously in _gfortran_copy_string:
2662 // The two strings may overlap so we use memmove.
2664 copy_string (GFC_INTEGER_4 destlen, char * dest,
2665 GFC_INTEGER_4 srclen, const char * src)
2667 if (srclen >= destlen)
2669 // This will truncate if too long.
2670 memmove (dest, src, destlen);
2674 memmove (dest, src, srclen);
2676 memset (&dest[srclen], ' ', destlen - srclen);
2680 We're now doing it here for better optimization, but the logic
2683 /* Truncate string if source is too long. */
2684 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2685 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2686 3, dest, src, dlen);
2688 /* Else copy and pad with spaces. */
2689 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2690 3, dest, src, slen);
2692 tmp4 = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, dest,
2693 fold_convert (sizetype, slen));
2694 tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2696 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2697 lang_hooks.to_target_charset (' ')),
2698 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2701 gfc_init_block (&tempblock);
2702 gfc_add_expr_to_block (&tempblock, tmp3);
2703 gfc_add_expr_to_block (&tempblock, tmp4);
2704 tmp3 = gfc_finish_block (&tempblock);
2706 /* The whole copy_string function is there. */
2707 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2708 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2709 gfc_add_expr_to_block (block, tmp);
2713 /* Translate a statement function.
2714 The value of a statement function reference is obtained by evaluating the
2715 expression using the values of the actual arguments for the values of the
2716 corresponding dummy arguments. */
2719 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2723 gfc_formal_arglist *fargs;
2724 gfc_actual_arglist *args;
2727 gfc_saved_var *saved_vars;
2733 sym = expr->symtree->n.sym;
2734 args = expr->value.function.actual;
2735 gfc_init_se (&lse, NULL);
2736 gfc_init_se (&rse, NULL);
2739 for (fargs = sym->formal; fargs; fargs = fargs->next)
2741 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2742 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2744 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2746 /* Each dummy shall be specified, explicitly or implicitly, to be
2748 gcc_assert (fargs->sym->attr.dimension == 0);
2751 /* Create a temporary to hold the value. */
2752 type = gfc_typenode_for_spec (&fsym->ts);
2753 temp_vars[n] = gfc_create_var (type, fsym->name);
2755 if (fsym->ts.type == BT_CHARACTER)
2757 /* Copy string arguments. */
2760 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2761 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2763 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2764 tmp = gfc_build_addr_expr (build_pointer_type (type),
2767 gfc_conv_expr (&rse, args->expr);
2768 gfc_conv_string_parameter (&rse);
2769 gfc_add_block_to_block (&se->pre, &lse.pre);
2770 gfc_add_block_to_block (&se->pre, &rse.pre);
2772 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2774 gfc_add_block_to_block (&se->pre, &lse.post);
2775 gfc_add_block_to_block (&se->pre, &rse.post);
2779 /* For everything else, just evaluate the expression. */
2780 gfc_conv_expr (&lse, args->expr);
2782 gfc_add_block_to_block (&se->pre, &lse.pre);
2783 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2784 gfc_add_block_to_block (&se->pre, &lse.post);
2790 /* Use the temporary variables in place of the real ones. */
2791 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2792 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2794 gfc_conv_expr (se, sym->value);
2796 if (sym->ts.type == BT_CHARACTER)
2798 gfc_conv_const_charlen (sym->ts.cl);
2800 /* Force the expression to the correct length. */
2801 if (!INTEGER_CST_P (se->string_length)
2802 || tree_int_cst_lt (se->string_length,
2803 sym->ts.cl->backend_decl))
2805 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2806 tmp = gfc_create_var (type, sym->name);
2807 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2808 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2809 se->string_length, se->expr);
2812 se->string_length = sym->ts.cl->backend_decl;
2815 /* Restore the original variables. */
2816 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2817 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2818 gfc_free (saved_vars);
2822 /* Translate a function expression. */
2825 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2829 if (expr->value.function.isym)
2831 gfc_conv_intrinsic_function (se, expr);
2835 /* We distinguish statement functions from general functions to improve
2836 runtime performance. */
2837 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2839 gfc_conv_statement_function (se, expr);
2843 /* expr.value.function.esym is the resolved (specific) function symbol for
2844 most functions. However this isn't set for dummy procedures. */
2845 sym = expr->value.function.esym;
2847 sym = expr->symtree->n.sym;
2848 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2853 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2855 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2856 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2858 gfc_conv_tmp_array_ref (se);
2859 gfc_advance_se_ss_chain (se);
2863 /* Build a static initializer. EXPR is the expression for the initial value.
2864 The other parameters describe the variable of the component being
2865 initialized. EXPR may be null. */
2868 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2869 bool array, bool pointer)
2873 if (!(expr || pointer))
2876 if (expr != NULL && expr->ts.type == BT_DERIVED
2877 && expr->ts.is_iso_c && expr->ts.derived
2878 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
2879 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR))
2880 expr = gfc_int_expr (0);
2884 /* Arrays need special handling. */
2886 return gfc_build_null_descriptor (type);
2888 return gfc_conv_array_initializer (type, expr);
2891 return fold_convert (type, null_pointer_node);
2897 gfc_init_se (&se, NULL);
2898 gfc_conv_structure (&se, expr, 1);
2902 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2905 gfc_init_se (&se, NULL);
2906 gfc_conv_constant (&se, expr);
2913 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2925 gfc_start_block (&block);
2927 /* Initialize the scalarizer. */
2928 gfc_init_loopinfo (&loop);
2930 gfc_init_se (&lse, NULL);
2931 gfc_init_se (&rse, NULL);
2934 rss = gfc_walk_expr (expr);
2935 if (rss == gfc_ss_terminator)
2937 /* The rhs is scalar. Add a ss for the expression. */
2938 rss = gfc_get_ss ();
2939 rss->next = gfc_ss_terminator;
2940 rss->type = GFC_SS_SCALAR;
2944 /* Create a SS for the destination. */
2945 lss = gfc_get_ss ();
2946 lss->type = GFC_SS_COMPONENT;
2948 lss->shape = gfc_get_shape (cm->as->rank);
2949 lss->next = gfc_ss_terminator;
2950 lss->data.info.dimen = cm->as->rank;
2951 lss->data.info.descriptor = dest;
2952 lss->data.info.data = gfc_conv_array_data (dest);
2953 lss->data.info.offset = gfc_conv_array_offset (dest);
2954 for (n = 0; n < cm->as->rank; n++)
2956 lss->data.info.dim[n] = n;
2957 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2958 lss->data.info.stride[n] = gfc_index_one_node;
2960 mpz_init (lss->shape[n]);
2961 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2962 cm->as->lower[n]->value.integer);
2963 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2966 /* Associate the SS with the loop. */
2967 gfc_add_ss_to_loop (&loop, lss);
2968 gfc_add_ss_to_loop (&loop, rss);
2970 /* Calculate the bounds of the scalarization. */
2971 gfc_conv_ss_startstride (&loop);
2973 /* Setup the scalarizing loops. */
2974 gfc_conv_loop_setup (&loop);
2976 /* Setup the gfc_se structures. */
2977 gfc_copy_loopinfo_to_se (&lse, &loop);
2978 gfc_copy_loopinfo_to_se (&rse, &loop);
2981 gfc_mark_ss_chain_used (rss, 1);
2983 gfc_mark_ss_chain_used (lss, 1);
2985 /* Start the scalarized loop body. */
2986 gfc_start_scalarized_body (&loop, &body);
2988 gfc_conv_tmp_array_ref (&lse);
2989 if (cm->ts.type == BT_CHARACTER)
2990 lse.string_length = cm->ts.cl->backend_decl;
2992 gfc_conv_expr (&rse, expr);
2994 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2995 gfc_add_expr_to_block (&body, tmp);
2997 gcc_assert (rse.ss == gfc_ss_terminator);
2999 /* Generate the copying loops. */
3000 gfc_trans_scalarizing_loops (&loop, &body);
3002 /* Wrap the whole thing up. */
3003 gfc_add_block_to_block (&block, &loop.pre);
3004 gfc_add_block_to_block (&block, &loop.post);
3006 for (n = 0; n < cm->as->rank; n++)
3007 mpz_clear (lss->shape[n]);
3008 gfc_free (lss->shape);
3010 gfc_cleanup_loop (&loop);
3012 return gfc_finish_block (&block);
3016 /* Assign a single component of a derived type constructor. */
3019 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3029 gfc_start_block (&block);
3033 gfc_init_se (&se, NULL);
3034 /* Pointer component. */
3037 /* Array pointer. */
3038 if (expr->expr_type == EXPR_NULL)
3039 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3042 rss = gfc_walk_expr (expr);
3043 se.direct_byref = 1;
3045 gfc_conv_expr_descriptor (&se, expr, rss);
3046 gfc_add_block_to_block (&block, &se.pre);
3047 gfc_add_block_to_block (&block, &se.post);
3052 /* Scalar pointers. */
3053 se.want_pointer = 1;
3054 gfc_conv_expr (&se, expr);
3055 gfc_add_block_to_block (&block, &se.pre);
3056 gfc_add_modify_expr (&block, dest,
3057 fold_convert (TREE_TYPE (dest), se.expr));
3058 gfc_add_block_to_block (&block, &se.post);
3061 else if (cm->dimension)
3063 if (cm->allocatable && expr->expr_type == EXPR_NULL)
3064 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3065 else if (cm->allocatable)
3069 gfc_init_se (&se, NULL);
3071 rss = gfc_walk_expr (expr);
3072 se.want_pointer = 0;
3073 gfc_conv_expr_descriptor (&se, expr, rss);
3074 gfc_add_block_to_block (&block, &se.pre);
3076 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3077 gfc_add_modify_expr (&block, dest, tmp);
3079 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3080 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3083 tmp = gfc_duplicate_allocatable (dest, se.expr,
3084 TREE_TYPE(cm->backend_decl),
3087 gfc_add_expr_to_block (&block, tmp);
3089 gfc_add_block_to_block (&block, &se.post);
3090 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3092 /* Shift the lbound and ubound of temporaries to being unity, rather
3093 than zero, based. Calculate the offset for all cases. */
3094 offset = gfc_conv_descriptor_offset (dest);
3095 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
3096 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3097 for (n = 0; n < expr->rank; n++)
3099 if (expr->expr_type != EXPR_VARIABLE
3100 && expr->expr_type != EXPR_CONSTANT)
3103 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3104 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3105 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3106 gfc_add_modify_expr (&block, tmp,
3107 fold_build2 (PLUS_EXPR,
3108 gfc_array_index_type,
3109 span, gfc_index_one_node));
3110 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3111 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
3113 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3114 gfc_conv_descriptor_lbound (dest,
3116 gfc_conv_descriptor_stride (dest,
3118 gfc_add_modify_expr (&block, tmp2, tmp);
3119 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3120 gfc_add_modify_expr (&block, offset, tmp);
3125 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3126 gfc_add_expr_to_block (&block, tmp);
3129 else if (expr->ts.type == BT_DERIVED)
3131 if (expr->expr_type != EXPR_STRUCTURE)
3133 gfc_init_se (&se, NULL);
3134 gfc_conv_expr (&se, expr);
3135 gfc_add_modify_expr (&block, dest,
3136 fold_convert (TREE_TYPE (dest), se.expr));
3140 /* Nested constructors. */
3141 tmp = gfc_trans_structure_assign (dest, expr);
3142 gfc_add_expr_to_block (&block, tmp);
3147 /* Scalar component. */
3148 gfc_init_se (&se, NULL);
3149 gfc_init_se (&lse, NULL);
3151 gfc_conv_expr (&se, expr);
3152 if (cm->ts.type == BT_CHARACTER)
3153 lse.string_length = cm->ts.cl->backend_decl;
3155 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3156 gfc_add_expr_to_block (&block, tmp);
3158 return gfc_finish_block (&block);
3161 /* Assign a derived type constructor to a variable. */
3164 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3172 gfc_start_block (&block);
3173 cm = expr->ts.derived->components;
3174 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3176 /* Skip absent members in default initializers. */
3180 field = cm->backend_decl;
3181 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3182 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3183 gfc_add_expr_to_block (&block, tmp);
3185 return gfc_finish_block (&block);
3188 /* Build an expression for a constructor. If init is nonzero then
3189 this is part of a static variable initializer. */
3192 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3199 VEC(constructor_elt,gc) *v = NULL;
3201 gcc_assert (se->ss == NULL);
3202 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3203 type = gfc_typenode_for_spec (&expr->ts);
3207 /* Create a temporary variable and fill it in. */
3208 se->expr = gfc_create_var (type, expr->ts.derived->name);
3209 tmp = gfc_trans_structure_assign (se->expr, expr);
3210 gfc_add_expr_to_block (&se->pre, tmp);
3214 cm = expr->ts.derived->components;
3216 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3218 /* Skip absent members in default initializers and allocatable
3219 components. Although the latter have a default initializer
3220 of EXPR_NULL,... by default, the static nullify is not needed
3221 since this is done every time we come into scope. */
3222 if (!c->expr || cm->allocatable)
3225 val = gfc_conv_initializer (c->expr, &cm->ts,
3226 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3228 /* Append it to the constructor list. */
3229 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3231 se->expr = build_constructor (type, v);
3235 /* Translate a substring expression. */
3238 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3244 gcc_assert (ref->type == REF_SUBSTRING);
3246 se->expr = gfc_build_string_const(expr->value.character.length,
3247 expr->value.character.string);
3248 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3249 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3251 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3255 /* Entry point for expression translation. Evaluates a scalar quantity.
3256 EXPR is the expression to be translated, and SE is the state structure if
3257 called from within the scalarized. */
3260 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3262 if (se->ss && se->ss->expr == expr
3263 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3265 /* Substitute a scalar expression evaluated outside the scalarization
3267 se->expr = se->ss->data.scalar.expr;
3268 se->string_length = se->ss->string_length;
3269 gfc_advance_se_ss_chain (se);
3273 /* We need to convert the expressions for the iso_c_binding derived types.
3274 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3275 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3276 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3277 updated to be an integer with a kind equal to the size of a (void *). */
3278 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3279 && expr->ts.derived->attr.is_iso_c)
3281 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3282 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3284 /* Set expr_type to EXPR_NULL, which will result in
3285 null_pointer_node being used below. */
3286 expr->expr_type = EXPR_NULL;
3290 /* Update the type/kind of the expression to be what the new
3291 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3292 expr->ts.type = expr->ts.derived->ts.type;
3293 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3294 expr->ts.kind = expr->ts.derived->ts.kind;
3298 switch (expr->expr_type)
3301 gfc_conv_expr_op (se, expr);
3305 gfc_conv_function_expr (se, expr);
3309 gfc_conv_constant (se, expr);
3313 gfc_conv_variable (se, expr);
3317 se->expr = null_pointer_node;
3320 case EXPR_SUBSTRING:
3321 gfc_conv_substring_expr (se, expr);
3324 case EXPR_STRUCTURE:
3325 gfc_conv_structure (se, expr, 0);
3329 gfc_conv_array_constructor_expr (se, expr);
3338 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3339 of an assignment. */
3341 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3343 gfc_conv_expr (se, expr);
3344 /* All numeric lvalues should have empty post chains. If not we need to
3345 figure out a way of rewriting an lvalue so that it has no post chain. */
3346 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3349 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3350 numeric expressions. Used for scalar values where inserting cleanup code
3353 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3357 gcc_assert (expr->ts.type != BT_CHARACTER);
3358 gfc_conv_expr (se, expr);
3361 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3362 gfc_add_modify_expr (&se->pre, val, se->expr);
3364 gfc_add_block_to_block (&se->pre, &se->post);
3368 /* Helper to translate and expression and convert it to a particular type. */
3370 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3372 gfc_conv_expr_val (se, expr);
3373 se->expr = convert (type, se->expr);
3377 /* Converts an expression so that it can be passed by reference. Scalar
3381 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3385 if (se->ss && se->ss->expr == expr
3386 && se->ss->type == GFC_SS_REFERENCE)
3388 se->expr = se->ss->data.scalar.expr;
3389 se->string_length = se->ss->string_length;
3390 gfc_advance_se_ss_chain (se);
3394 if (expr->ts.type == BT_CHARACTER)
3396 gfc_conv_expr (se, expr);
3397 gfc_conv_string_parameter (se);
3401 if (expr->expr_type == EXPR_VARIABLE)
3403 se->want_pointer = 1;
3404 gfc_conv_expr (se, expr);
3407 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3408 gfc_add_modify_expr (&se->pre, var, se->expr);
3409 gfc_add_block_to_block (&se->pre, &se->post);
3415 if (expr->expr_type == EXPR_FUNCTION
3416 && expr->symtree->n.sym->attr.pointer
3417 && !expr->symtree->n.sym->attr.dimension)
3419 se->want_pointer = 1;
3420 gfc_conv_expr (se, expr);
3421 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3422 gfc_add_modify_expr (&se->pre, var, se->expr);
3428 gfc_conv_expr (se, expr);
3430 /* Create a temporary var to hold the value. */
3431 if (TREE_CONSTANT (se->expr))
3433 tree tmp = se->expr;
3434 STRIP_TYPE_NOPS (tmp);
3435 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3436 DECL_INITIAL (var) = tmp;
3437 TREE_STATIC (var) = 1;
3442 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3443 gfc_add_modify_expr (&se->pre, var, se->expr);
3445 gfc_add_block_to_block (&se->pre, &se->post);
3447 /* Take the address of that value. */
3448 se->expr = build_fold_addr_expr (var);
3453 gfc_trans_pointer_assign (gfc_code * code)
3455 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3459 /* Generate code for a pointer assignment. */
3462 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3472 gfc_start_block (&block);
3474 gfc_init_se (&lse, NULL);
3476 lss = gfc_walk_expr (expr1);
3477 rss = gfc_walk_expr (expr2);
3478 if (lss == gfc_ss_terminator)
3480 /* Scalar pointers. */
3481 lse.want_pointer = 1;
3482 gfc_conv_expr (&lse, expr1);
3483 gcc_assert (rss == gfc_ss_terminator);
3484 gfc_init_se (&rse, NULL);
3485 rse.want_pointer = 1;
3486 gfc_conv_expr (&rse, expr2);
3487 gfc_add_block_to_block (&block, &lse.pre);
3488 gfc_add_block_to_block (&block, &rse.pre);
3489 gfc_add_modify_expr (&block, lse.expr,
3490 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3491 gfc_add_block_to_block (&block, &rse.post);
3492 gfc_add_block_to_block (&block, &lse.post);
3496 /* Array pointer. */
3497 gfc_conv_expr_descriptor (&lse, expr1, lss);
3498 switch (expr2->expr_type)
3501 /* Just set the data pointer to null. */
3502 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3506 /* Assign directly to the pointer's descriptor. */
3507 lse.direct_byref = 1;
3508 gfc_conv_expr_descriptor (&lse, expr2, rss);
3512 /* Assign to a temporary descriptor and then copy that
3513 temporary to the pointer. */
3515 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3518 lse.direct_byref = 1;
3519 gfc_conv_expr_descriptor (&lse, expr2, rss);
3520 gfc_add_modify_expr (&lse.pre, desc, tmp);
3523 gfc_add_block_to_block (&block, &lse.pre);
3524 gfc_add_block_to_block (&block, &lse.post);
3526 return gfc_finish_block (&block);
3530 /* Makes sure se is suitable for passing as a function string parameter. */
3531 /* TODO: Need to check all callers fo this function. It may be abused. */
3534 gfc_conv_string_parameter (gfc_se * se)
3538 if (TREE_CODE (se->expr) == STRING_CST)
3540 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3544 type = TREE_TYPE (se->expr);
3545 if (TYPE_STRING_FLAG (type))
3547 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3548 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3551 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3552 gcc_assert (se->string_length
3553 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3557 /* Generate code for assignment of scalar variables. Includes character
3558 strings and derived types with allocatable components. */
3561 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3562 bool l_is_temp, bool r_is_var)
3568 gfc_init_block (&block);
3570 if (ts.type == BT_CHARACTER)
3572 gcc_assert (lse->string_length != NULL_TREE
3573 && rse->string_length != NULL_TREE);
3575 gfc_conv_string_parameter (lse);
3576 gfc_conv_string_parameter (rse);
3578 gfc_add_block_to_block (&block, &lse->pre);
3579 gfc_add_block_to_block (&block, &rse->pre);
3581 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3582 rse->string_length, rse->expr);
3584 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3588 /* Are the rhs and the lhs the same? */
3591 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3592 build_fold_addr_expr (lse->expr),
3593 build_fold_addr_expr (rse->expr));
3594 cond = gfc_evaluate_now (cond, &lse->pre);
3597 /* Deallocate the lhs allocated components as long as it is not
3598 the same as the rhs. This must be done following the assignment
3599 to prevent deallocating data that could be used in the rhs
3603 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
3604 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
3606 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3607 gfc_add_expr_to_block (&lse->post, tmp);
3610 gfc_add_block_to_block (&block, &rse->pre);
3611 gfc_add_block_to_block (&block, &lse->pre);
3613 gfc_add_modify_expr (&block, lse->expr,
3614 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3616 /* Do a deep copy if the rhs is a variable, if it is not the
3620 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3621 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3622 gfc_add_expr_to_block (&block, tmp);
3627 gfc_add_block_to_block (&block, &lse->pre);
3628 gfc_add_block_to_block (&block, &rse->pre);
3630 gfc_add_modify_expr (&block, lse->expr,
3631 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3634 gfc_add_block_to_block (&block, &lse->post);
3635 gfc_add_block_to_block (&block, &rse->post);
3637 return gfc_finish_block (&block);
3641 /* Try to translate array(:) = func (...), where func is a transformational
3642 array function, without using a temporary. Returns NULL is this isn't the
3646 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3651 bool seen_array_ref;
3653 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3654 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3657 /* Elemental functions don't need a temporary anyway. */
3658 if (expr2->value.function.esym != NULL
3659 && expr2->value.function.esym->attr.elemental)
3662 /* Fail if EXPR1 can't be expressed as a descriptor. */
3663 if (gfc_ref_needs_temporary_p (expr1->ref))
3666 /* Functions returning pointers need temporaries. */
3667 if (expr2->symtree->n.sym->attr.pointer
3668 || expr2->symtree->n.sym->attr.allocatable)
3671 /* Character array functions need temporaries unless the
3672 character lengths are the same. */
3673 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3675 if (expr1->ts.cl->length == NULL
3676 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3679 if (expr2->ts.cl->length == NULL
3680 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3683 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3684 expr2->ts.cl->length->value.integer) != 0)
3688 /* Check that no LHS component references appear during an array
3689 reference. This is needed because we do not have the means to
3690 span any arbitrary stride with an array descriptor. This check
3691 is not needed for the rhs because the function result has to be
3693 seen_array_ref = false;
3694 for (ref = expr1->ref; ref; ref = ref->next)
3696 if (ref->type == REF_ARRAY)
3697 seen_array_ref= true;
3698 else if (ref->type == REF_COMPONENT && seen_array_ref)
3702 /* Check for a dependency. */
3703 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3704 expr2->value.function.esym,
3705 expr2->value.function.actual))
3708 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3710 gcc_assert (expr2->value.function.isym
3711 || (gfc_return_by_reference (expr2->value.function.esym)
3712 && expr2->value.function.esym->result->attr.dimension));
3714 ss = gfc_walk_expr (expr1);
3715 gcc_assert (ss != gfc_ss_terminator);
3716 gfc_init_se (&se, NULL);
3717 gfc_start_block (&se.pre);
3718 se.want_pointer = 1;
3720 gfc_conv_array_parameter (&se, expr1, ss, 0);
3722 se.direct_byref = 1;
3723 se.ss = gfc_walk_expr (expr2);
3724 gcc_assert (se.ss != gfc_ss_terminator);
3725 gfc_conv_function_expr (&se, expr2);
3726 gfc_add_block_to_block (&se.pre, &se.post);
3728 return gfc_finish_block (&se.pre);
3731 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3734 is_zero_initializer_p (gfc_expr * expr)
3736 if (expr->expr_type != EXPR_CONSTANT)
3739 /* We ignore constants with prescribed memory representations for now. */
3740 if (expr->representation.string)
3743 switch (expr->ts.type)
3746 return mpz_cmp_si (expr->value.integer, 0) == 0;
3749 return mpfr_zero_p (expr->value.real)
3750 && MPFR_SIGN (expr->value.real) >= 0;
3753 return expr->value.logical == 0;
3756 return mpfr_zero_p (expr->value.complex.r)
3757 && MPFR_SIGN (expr->value.complex.r) >= 0
3758 && mpfr_zero_p (expr->value.complex.i)
3759 && MPFR_SIGN (expr->value.complex.i) >= 0;
3767 /* Try to efficiently translate array(:) = 0. Return NULL if this
3771 gfc_trans_zero_assign (gfc_expr * expr)
3773 tree dest, len, type;
3777 sym = expr->symtree->n.sym;
3778 dest = gfc_get_symbol_decl (sym);
3780 type = TREE_TYPE (dest);
3781 if (POINTER_TYPE_P (type))
3782 type = TREE_TYPE (type);
3783 if (!GFC_ARRAY_TYPE_P (type))
3786 /* Determine the length of the array. */
3787 len = GFC_TYPE_ARRAY_SIZE (type);
3788 if (!len || TREE_CODE (len) != INTEGER_CST)
3791 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3792 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3793 fold_convert (gfc_array_index_type, tmp));
3795 /* Convert arguments to the correct types. */
3796 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3797 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3799 dest = fold_convert (pvoid_type_node, dest);
3800 len = fold_convert (size_type_node, len);
3802 /* Construct call to __builtin_memset. */
3803 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
3804 3, dest, integer_zero_node, len);
3805 return fold_convert (void_type_node, tmp);
3809 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3810 that constructs the call to __builtin_memcpy. */
3813 gfc_build_memcpy_call (tree dst, tree src, tree len)
3817 /* Convert arguments to the correct types. */
3818 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3819 dst = gfc_build_addr_expr (pvoid_type_node, dst);
3821 dst = fold_convert (pvoid_type_node, dst);
3823 if (!POINTER_TYPE_P (TREE_TYPE (src)))
3824 src = gfc_build_addr_expr (pvoid_type_node, src);
3826 src = fold_convert (pvoid_type_node, src);
3828 len = fold_convert (size_type_node, len);
3830 /* Construct call to __builtin_memcpy. */
3831 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
3832 return fold_convert (void_type_node, tmp);
3836 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3837 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3838 source/rhs, both are gfc_full_array_ref_p which have been checked for
3842 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3844 tree dst, dlen, dtype;
3845 tree src, slen, stype;
3848 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3849 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3851 dtype = TREE_TYPE (dst);
3852 if (POINTER_TYPE_P (dtype))
3853 dtype = TREE_TYPE (dtype);
3854 stype = TREE_TYPE (src);
3855 if (POINTER_TYPE_P (stype))
3856 stype = TREE_TYPE (stype);
3858 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3861 /* Determine the lengths of the arrays. */
3862 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3863 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3865 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3866 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3867 fold_convert (gfc_array_index_type, tmp));
3869 slen = GFC_TYPE_ARRAY_SIZE (stype);
3870 if (!slen || TREE_CODE (slen) != INTEGER_CST)
3872 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
3873 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3874 fold_convert (gfc_array_index_type, tmp));
3876 /* Sanity check that they are the same. This should always be
3877 the case, as we should already have checked for conformance. */
3878 if (!tree_int_cst_equal (slen, dlen))
3881 return gfc_build_memcpy_call (dst, src, dlen);
3885 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3886 this can't be done. EXPR1 is the destination/lhs for which
3887 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3890 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3892 unsigned HOST_WIDE_INT nelem;
3898 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3902 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3903 dtype = TREE_TYPE (dst);
3904 if (POINTER_TYPE_P (dtype))
3905 dtype = TREE_TYPE (dtype);
3906 if (!GFC_ARRAY_TYPE_P (dtype))
3909 /* Determine the lengths of the array. */
3910 len = GFC_TYPE_ARRAY_SIZE (dtype);
3911 if (!len || TREE_CODE (len) != INTEGER_CST)
3914 /* Confirm that the constructor is the same size. */
3915 if (compare_tree_int (len, nelem) != 0)
3918 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3919 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3920 fold_convert (gfc_array_index_type, tmp));
3922 stype = gfc_typenode_for_spec (&expr2->ts);
3923 src = gfc_build_constant_array_constructor (expr2, stype);
3925 stype = TREE_TYPE (src);
3926 if (POINTER_TYPE_P (stype))
3927 stype = TREE_TYPE (stype);
3929 return gfc_build_memcpy_call (dst, src, len);
3933 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3934 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3937 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3942 gfc_ss *lss_section;
3950 /* Assignment of the form lhs = rhs. */
3951 gfc_start_block (&block);
3953 gfc_init_se (&lse, NULL);
3954 gfc_init_se (&rse, NULL);
3957 lss = gfc_walk_expr (expr1);
3959 if (lss != gfc_ss_terminator)
3961 /* The assignment needs scalarization. */
3964 /* Find a non-scalar SS from the lhs. */
3965 while (lss_section != gfc_ss_terminator
3966 && lss_section->type != GFC_SS_SECTION)
3967 lss_section = lss_section->next;
3969 gcc_assert (lss_section != gfc_ss_terminator);
3971 /* Initialize the scalarizer. */
3972 gfc_init_loopinfo (&loop);
3975 rss = gfc_walk_expr (expr2);
3976 if (rss == gfc_ss_terminator)
3978 /* The rhs is scalar. Add a ss for the expression. */
3979 rss = gfc_get_ss ();
3980 rss->next = gfc_ss_terminator;
3981 rss->type = GFC_SS_SCALAR;
3984 /* Associate the SS with the loop. */
3985 gfc_add_ss_to_loop (&loop, lss);
3986 gfc_add_ss_to_loop (&loop, rss);
3988 /* Calculate the bounds of the scalarization. */
3989 gfc_conv_ss_startstride (&loop);
3990 /* Resolve any data dependencies in the statement. */
3991 gfc_conv_resolve_dependencies (&loop, lss, rss);
3992 /* Setup the scalarizing loops. */
3993 gfc_conv_loop_setup (&loop);
3995 /* Setup the gfc_se structures. */
3996 gfc_copy_loopinfo_to_se (&lse, &loop);
3997 gfc_copy_loopinfo_to_se (&rse, &loop);
4000 gfc_mark_ss_chain_used (rss, 1);
4001 if (loop.temp_ss == NULL)
4004 gfc_mark_ss_chain_used (lss, 1);
4008 lse.ss = loop.temp_ss;
4009 gfc_mark_ss_chain_used (lss, 3);
4010 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4013 /* Start the scalarized loop body. */
4014 gfc_start_scalarized_body (&loop, &body);
4017 gfc_init_block (&body);
4019 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4021 /* Translate the expression. */
4022 gfc_conv_expr (&rse, expr2);
4026 gfc_conv_tmp_array_ref (&lse);
4027 gfc_advance_se_ss_chain (&lse);
4030 gfc_conv_expr (&lse, expr1);
4032 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4033 l_is_temp || init_flag,
4034 expr2->expr_type == EXPR_VARIABLE);
4035 gfc_add_expr_to_block (&body, tmp);
4037 if (lss == gfc_ss_terminator)
4039 /* Use the scalar assignment as is. */
4040 gfc_add_block_to_block (&block, &body);
4044 gcc_assert (lse.ss == gfc_ss_terminator
4045 && rse.ss == gfc_ss_terminator);
4049 gfc_trans_scalarized_loop_boundary (&loop, &body);
4051 /* We need to copy the temporary to the actual lhs. */
4052 gfc_init_se (&lse, NULL);
4053 gfc_init_se (&rse, NULL);
4054 gfc_copy_loopinfo_to_se (&lse, &loop);
4055 gfc_copy_loopinfo_to_se (&rse, &loop);
4057 rse.ss = loop.temp_ss;
4060 gfc_conv_tmp_array_ref (&rse);
4061 gfc_advance_se_ss_chain (&rse);
4062 gfc_conv_expr (&lse, expr1);
4064 gcc_assert (lse.ss == gfc_ss_terminator
4065 && rse.ss == gfc_ss_terminator);
4067 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4069 gfc_add_expr_to_block (&body, tmp);
4072 /* Generate the copying loops. */
4073 gfc_trans_scalarizing_loops (&loop, &body);
4075 /* Wrap the whole thing up. */
4076 gfc_add_block_to_block (&block, &loop.pre);
4077 gfc_add_block_to_block (&block, &loop.post);
4079 gfc_cleanup_loop (&loop);
4082 return gfc_finish_block (&block);
4086 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
4089 copyable_array_p (gfc_expr * expr)
4091 /* First check it's an array. */
4092 if (expr->rank < 1 || !expr->ref)
4095 /* Next check that it's of a simple enough type. */
4096 switch (expr->ts.type)
4108 return !expr->ts.derived->attr.alloc_comp;
4117 /* Translate an assignment. */
4120 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4124 /* Special case a single function returning an array. */
4125 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4127 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4132 /* Special case assigning an array to zero. */
4133 if (expr1->expr_type == EXPR_VARIABLE
4136 && expr1->ref->next == NULL
4137 && gfc_full_array_ref_p (expr1->ref)
4138 && is_zero_initializer_p (expr2))
4140 tmp = gfc_trans_zero_assign (expr1);
4145 /* Special case copying one array to another. */
4146 if (expr1->expr_type == EXPR_VARIABLE
4147 && copyable_array_p (expr1)
4148 && gfc_full_array_ref_p (expr1->ref)
4149 && expr2->expr_type == EXPR_VARIABLE
4150 && copyable_array_p (expr2)
4151 && gfc_full_array_ref_p (expr2->ref)
4152 && gfc_compare_types (&expr1->ts, &expr2->ts)
4153 && !gfc_check_dependency (expr1, expr2, 0))
4155 tmp = gfc_trans_array_copy (expr1, expr2);
4160 /* Special case initializing an array from a constant array constructor. */
4161 if (expr1->expr_type == EXPR_VARIABLE
4162 && copyable_array_p (expr1)
4163 && gfc_full_array_ref_p (expr1->ref)
4164 && expr2->expr_type == EXPR_ARRAY
4165 && gfc_compare_types (&expr1->ts, &expr2->ts))
4167 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4172 /* Fallback to the scalarizer to generate explicit loops. */
4173 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4177 gfc_trans_init_assign (gfc_code * code)
4179 return gfc_trans_assignment (code->expr, code->expr2, true);
4183 gfc_trans_assign (gfc_code * code)
4185 return gfc_trans_assignment (code->expr, code->expr2, false);