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 of '%s' "
300 "is less than one", name);
302 asprintf (&msg, "Substring out of bounds: lower bound "
304 gfc_trans_runtime_check (fault, msg, &se->pre, where);
307 /* Check upper bound. */
308 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
310 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
313 asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
314 "exceeds string length", name);
316 asprintf (&msg, "Substring out of bounds: upper bound "
317 "exceeds string length");
318 gfc_trans_runtime_check (fault, msg, &se->pre, where);
322 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
323 build_int_cst (gfc_charlen_type_node, 1),
325 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
326 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
327 build_int_cst (gfc_charlen_type_node, 0));
328 se->string_length = tmp;
332 /* Convert a derived type component reference. */
335 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
342 c = ref->u.c.component;
344 gcc_assert (c->backend_decl);
346 field = c->backend_decl;
347 gcc_assert (TREE_CODE (field) == FIELD_DECL);
349 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
353 if (c->ts.type == BT_CHARACTER)
355 tmp = c->ts.cl->backend_decl;
356 /* Components must always be constant length. */
357 gcc_assert (tmp && INTEGER_CST_P (tmp));
358 se->string_length = tmp;
361 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
362 se->expr = build_fold_indirect_ref (se->expr);
366 /* Return the contents of a variable. Also handles reference/pointer
367 variables (all Fortran pointer references are implicit). */
370 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
377 bool alternate_entry;
380 sym = expr->symtree->n.sym;
383 /* Check that something hasn't gone horribly wrong. */
384 gcc_assert (se->ss != gfc_ss_terminator);
385 gcc_assert (se->ss->expr == expr);
387 /* A scalarized term. We already know the descriptor. */
388 se->expr = se->ss->data.info.descriptor;
389 se->string_length = se->ss->string_length;
390 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
391 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
396 tree se_expr = NULL_TREE;
398 se->expr = gfc_get_symbol_decl (sym);
400 /* Deal with references to a parent results or entries by storing
401 the current_function_decl and moving to the parent_decl. */
402 return_value = sym->attr.function && sym->result == sym;
403 alternate_entry = sym->attr.function && sym->attr.entry
404 && sym->result == sym;
405 entry_master = sym->attr.result
406 && sym->ns->proc_name->attr.entry_master
407 && !gfc_return_by_reference (sym->ns->proc_name);
408 parent_decl = DECL_CONTEXT (current_function_decl);
410 if ((se->expr == parent_decl && return_value)
411 || (sym->ns && sym->ns->proc_name
413 && sym->ns->proc_name->backend_decl == parent_decl
414 && (alternate_entry || entry_master)))
419 /* Special case for assigning the return value of a function.
420 Self recursive functions must have an explicit return value. */
421 if (return_value && (se->expr == current_function_decl || parent_flag))
422 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
424 /* Similarly for alternate entry points. */
425 else if (alternate_entry
426 && (sym->ns->proc_name->backend_decl == current_function_decl
429 gfc_entry_list *el = NULL;
431 for (el = sym->ns->entries; el; el = el->next)
434 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
439 else if (entry_master
440 && (sym->ns->proc_name->backend_decl == current_function_decl
442 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
447 /* Procedure actual arguments. */
448 else if (sym->attr.flavor == FL_PROCEDURE
449 && se->expr != current_function_decl)
451 gcc_assert (se->want_pointer);
452 if (!sym->attr.dummy)
454 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
455 se->expr = build_fold_addr_expr (se->expr);
461 /* Dereference the expression, where needed. Since characters
462 are entirely different from other types, they are treated
464 if (sym->ts.type == BT_CHARACTER)
466 /* Dereference character pointer dummy arguments
468 if ((sym->attr.pointer || sym->attr.allocatable)
470 || sym->attr.function
471 || sym->attr.result))
472 se->expr = build_fold_indirect_ref (se->expr);
475 else if (!sym->attr.value)
477 /* Dereference non-character scalar dummy arguments. */
478 if (sym->attr.dummy && !sym->attr.dimension)
479 se->expr = build_fold_indirect_ref (se->expr);
481 /* Dereference scalar hidden result. */
482 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
483 && (sym->attr.function || sym->attr.result)
484 && !sym->attr.dimension && !sym->attr.pointer)
485 se->expr = build_fold_indirect_ref (se->expr);
487 /* Dereference non-character pointer variables.
488 These must be dummies, results, or scalars. */
489 if ((sym->attr.pointer || sym->attr.allocatable)
491 || sym->attr.function
493 || !sym->attr.dimension))
494 se->expr = build_fold_indirect_ref (se->expr);
500 /* For character variables, also get the length. */
501 if (sym->ts.type == BT_CHARACTER)
503 /* If the character length of an entry isn't set, get the length from
504 the master function instead. */
505 if (sym->attr.entry && !sym->ts.cl->backend_decl)
506 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
508 se->string_length = sym->ts.cl->backend_decl;
509 gcc_assert (se->string_length);
517 /* Return the descriptor if that's what we want and this is an array
518 section reference. */
519 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
521 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
522 /* Return the descriptor for array pointers and allocations. */
524 && ref->next == NULL && (se->descriptor_only))
527 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
528 /* Return a pointer to an element. */
532 gfc_conv_component_ref (se, ref);
536 gfc_conv_substring (se, ref, expr->ts.kind,
537 expr->symtree->name, &expr->where);
546 /* Pointer assignment, allocation or pass by reference. Arrays are handled
548 if (se->want_pointer)
550 if (expr->ts.type == BT_CHARACTER)
551 gfc_conv_string_parameter (se);
553 se->expr = build_fold_addr_expr (se->expr);
558 /* Unary ops are easy... Or they would be if ! was a valid op. */
561 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
566 gcc_assert (expr->ts.type != BT_CHARACTER);
567 /* Initialize the operand. */
568 gfc_init_se (&operand, se);
569 gfc_conv_expr_val (&operand, expr->value.op.op1);
570 gfc_add_block_to_block (&se->pre, &operand.pre);
572 type = gfc_typenode_for_spec (&expr->ts);
574 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
575 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
576 All other unary operators have an equivalent GIMPLE unary operator. */
577 if (code == TRUTH_NOT_EXPR)
578 se->expr = build2 (EQ_EXPR, type, operand.expr,
579 build_int_cst (type, 0));
581 se->expr = build1 (code, type, operand.expr);
585 /* Expand power operator to optimal multiplications when a value is raised
586 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
587 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
588 Programming", 3rd Edition, 1998. */
590 /* This code is mostly duplicated from expand_powi in the backend.
591 We establish the "optimal power tree" lookup table with the defined size.
592 The items in the table are the exponents used to calculate the index
593 exponents. Any integer n less than the value can get an "addition chain",
594 with the first node being one. */
595 #define POWI_TABLE_SIZE 256
597 /* The table is from builtins.c. */
598 static const unsigned char powi_table[POWI_TABLE_SIZE] =
600 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
601 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
602 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
603 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
604 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
605 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
606 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
607 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
608 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
609 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
610 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
611 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
612 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
613 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
614 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
615 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
616 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
617 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
618 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
619 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
620 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
621 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
622 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
623 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
624 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
625 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
626 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
627 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
628 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
629 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
630 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
631 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
634 /* If n is larger than lookup table's max index, we use the "window
636 #define POWI_WINDOW_SIZE 3
638 /* Recursive function to expand the power operator. The temporary
639 values are put in tmpvar. The function returns tmpvar[1] ** n. */
641 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
648 if (n < POWI_TABLE_SIZE)
653 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
654 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
658 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
659 op0 = gfc_conv_powi (se, n - digit, tmpvar);
660 op1 = gfc_conv_powi (se, digit, tmpvar);
664 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
668 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
669 tmp = gfc_evaluate_now (tmp, &se->pre);
671 if (n < POWI_TABLE_SIZE)
678 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
679 return 1. Else return 0 and a call to runtime library functions
680 will have to be built. */
682 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
687 tree vartmp[POWI_TABLE_SIZE];
689 unsigned HOST_WIDE_INT n;
692 /* If exponent is too large, we won't expand it anyway, so don't bother
693 with large integer values. */
694 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
697 m = double_int_to_shwi (TREE_INT_CST (rhs));
698 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
699 of the asymmetric range of the integer type. */
700 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
702 type = TREE_TYPE (lhs);
703 sgn = tree_int_cst_sgn (rhs);
705 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
706 || optimize_size) && (m > 2 || m < -1))
712 se->expr = gfc_build_const (type, integer_one_node);
716 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
717 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
719 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
720 build_int_cst (TREE_TYPE (lhs), -1));
721 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
722 build_int_cst (TREE_TYPE (lhs), 1));
725 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
728 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
729 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
730 build_int_cst (type, 0));
734 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
735 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
736 build_int_cst (type, 0));
737 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
741 memset (vartmp, 0, sizeof (vartmp));
745 tmp = gfc_build_const (type, integer_one_node);
746 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
749 se->expr = gfc_conv_powi (se, n, vartmp);
755 /* Power op (**). Constant integer exponent has special handling. */
758 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
760 tree gfc_int4_type_node;
767 gfc_init_se (&lse, se);
768 gfc_conv_expr_val (&lse, expr->value.op.op1);
769 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
770 gfc_add_block_to_block (&se->pre, &lse.pre);
772 gfc_init_se (&rse, se);
773 gfc_conv_expr_val (&rse, expr->value.op.op2);
774 gfc_add_block_to_block (&se->pre, &rse.pre);
776 if (expr->value.op.op2->ts.type == BT_INTEGER
777 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
778 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
781 gfc_int4_type_node = gfc_get_int_type (4);
783 kind = expr->value.op.op1->ts.kind;
784 switch (expr->value.op.op2->ts.type)
787 ikind = expr->value.op.op2->ts.kind;
792 rse.expr = convert (gfc_int4_type_node, rse.expr);
814 if (expr->value.op.op1->ts.type == BT_INTEGER)
815 lse.expr = convert (gfc_int4_type_node, lse.expr);
840 switch (expr->value.op.op1->ts.type)
843 if (kind == 3) /* Case 16 was not handled properly above. */
845 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
849 /* Use builtins for real ** int4. */
855 fndecl = built_in_decls[BUILT_IN_POWIF];
859 fndecl = built_in_decls[BUILT_IN_POWI];
864 fndecl = built_in_decls[BUILT_IN_POWIL];
872 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
876 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
888 fndecl = built_in_decls[BUILT_IN_POWF];
891 fndecl = built_in_decls[BUILT_IN_POW];
895 fndecl = built_in_decls[BUILT_IN_POWL];
906 fndecl = gfor_fndecl_math_cpowf;
909 fndecl = gfor_fndecl_math_cpow;
912 fndecl = gfor_fndecl_math_cpowl10;
915 fndecl = gfor_fndecl_math_cpowl16;
927 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
931 /* Generate code to allocate a string temporary. */
934 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
939 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
941 if (gfc_can_put_var_on_stack (len))
943 /* Create a temporary variable to hold the result. */
944 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
945 build_int_cst (gfc_charlen_type_node, 1));
946 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
947 tmp = build_array_type (gfc_character1_type_node, tmp);
948 var = gfc_create_var (tmp, "str");
949 var = gfc_build_addr_expr (type, var);
953 /* Allocate a temporary to hold the result. */
954 var = gfc_create_var (type, "pstr");
955 tmp = gfc_call_malloc (&se->pre, type, len);
956 gfc_add_modify_expr (&se->pre, var, tmp);
958 /* Free the temporary afterwards. */
959 tmp = gfc_call_free (convert (pvoid_type_node, var));
960 gfc_add_expr_to_block (&se->post, tmp);
967 /* Handle a string concatenation operation. A temporary will be allocated to
971 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
980 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
981 && expr->value.op.op2->ts.type == BT_CHARACTER);
983 gfc_init_se (&lse, se);
984 gfc_conv_expr (&lse, expr->value.op.op1);
985 gfc_conv_string_parameter (&lse);
986 gfc_init_se (&rse, se);
987 gfc_conv_expr (&rse, expr->value.op.op2);
988 gfc_conv_string_parameter (&rse);
990 gfc_add_block_to_block (&se->pre, &lse.pre);
991 gfc_add_block_to_block (&se->pre, &rse.pre);
993 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
994 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
995 if (len == NULL_TREE)
997 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
998 lse.string_length, rse.string_length);
1001 type = build_pointer_type (type);
1003 var = gfc_conv_string_tmp (se, type, len);
1005 /* Do the actual concatenation. */
1006 tmp = build_call_expr (gfor_fndecl_concat_string, 6,
1008 lse.string_length, lse.expr,
1009 rse.string_length, rse.expr);
1010 gfc_add_expr_to_block (&se->pre, tmp);
1012 /* Add the cleanup for the operands. */
1013 gfc_add_block_to_block (&se->pre, &rse.post);
1014 gfc_add_block_to_block (&se->pre, &lse.post);
1017 se->string_length = len;
1020 /* Translates an op expression. Common (binary) cases are handled by this
1021 function, others are passed on. Recursion is used in either case.
1022 We use the fact that (op1.ts == op2.ts) (except for the power
1024 Operators need no special handling for scalarized expressions as long as
1025 they call gfc_conv_simple_val to get their operands.
1026 Character strings get special handling. */
1029 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1031 enum tree_code code;
1041 switch (expr->value.op.operator)
1043 case INTRINSIC_UPLUS:
1044 case INTRINSIC_PARENTHESES:
1045 gfc_conv_expr (se, expr->value.op.op1);
1048 case INTRINSIC_UMINUS:
1049 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1053 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1056 case INTRINSIC_PLUS:
1060 case INTRINSIC_MINUS:
1064 case INTRINSIC_TIMES:
1068 case INTRINSIC_DIVIDE:
1069 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1070 an integer, we must round towards zero, so we use a
1072 if (expr->ts.type == BT_INTEGER)
1073 code = TRUNC_DIV_EXPR;
1078 case INTRINSIC_POWER:
1079 gfc_conv_power_op (se, expr);
1082 case INTRINSIC_CONCAT:
1083 gfc_conv_concat_op (se, expr);
1087 code = TRUTH_ANDIF_EXPR;
1092 code = TRUTH_ORIF_EXPR;
1096 /* EQV and NEQV only work on logicals, but since we represent them
1097 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1099 case INTRINSIC_EQ_OS:
1107 case INTRINSIC_NE_OS:
1108 case INTRINSIC_NEQV:
1115 case INTRINSIC_GT_OS:
1122 case INTRINSIC_GE_OS:
1129 case INTRINSIC_LT_OS:
1136 case INTRINSIC_LE_OS:
1142 case INTRINSIC_USER:
1143 case INTRINSIC_ASSIGN:
1144 /* These should be converted into function calls by the frontend. */
1148 fatal_error ("Unknown intrinsic op");
1152 /* The only exception to this is **, which is handled separately anyway. */
1153 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1155 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1159 gfc_init_se (&lse, se);
1160 gfc_conv_expr (&lse, expr->value.op.op1);
1161 gfc_add_block_to_block (&se->pre, &lse.pre);
1164 gfc_init_se (&rse, se);
1165 gfc_conv_expr (&rse, expr->value.op.op2);
1166 gfc_add_block_to_block (&se->pre, &rse.pre);
1170 gfc_conv_string_parameter (&lse);
1171 gfc_conv_string_parameter (&rse);
1173 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1174 rse.string_length, rse.expr);
1175 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1176 gfc_add_block_to_block (&lse.post, &rse.post);
1179 type = gfc_typenode_for_spec (&expr->ts);
1183 /* The result of logical ops is always boolean_type_node. */
1184 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1185 se->expr = convert (type, tmp);
1188 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1190 /* Add the post blocks. */
1191 gfc_add_block_to_block (&se->post, &rse.post);
1192 gfc_add_block_to_block (&se->post, &lse.post);
1195 /* If a string's length is one, we convert it to a single character. */
1198 gfc_to_single_character (tree len, tree str)
1200 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1202 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1203 && TREE_INT_CST_HIGH (len) == 0)
1205 str = fold_convert (pchar_type_node, str);
1206 return build_fold_indirect_ref (str);
1212 /* Compare two strings. If they are all single characters, the result is the
1213 subtraction of them. Otherwise, we build a library call. */
1216 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1223 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1224 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1226 type = gfc_get_int_type (gfc_default_integer_kind);
1228 sc1 = gfc_to_single_character (len1, str1);
1229 sc2 = gfc_to_single_character (len2, str2);
1231 /* Deal with single character specially. */
1232 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1234 sc1 = fold_convert (type, sc1);
1235 sc2 = fold_convert (type, sc2);
1236 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1239 /* Build a call for the comparison. */
1240 tmp = build_call_expr (gfor_fndecl_compare_string, 4,
1241 len1, str1, len2, str2);
1246 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1250 if (sym->attr.dummy)
1252 tmp = gfc_get_symbol_decl (sym);
1253 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1254 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1258 if (!sym->backend_decl)
1259 sym->backend_decl = gfc_get_extern_function_decl (sym);
1261 tmp = sym->backend_decl;
1262 if (sym->attr.cray_pointee)
1263 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1264 gfc_get_symbol_decl (sym->cp_pointer));
1265 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1267 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1268 tmp = build_fold_addr_expr (tmp);
1275 /* Translate the call for an elemental subroutine call used in an operator
1276 assignment. This is a simplified version of gfc_conv_function_call. */
1279 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1286 /* Only elemental subroutines with two arguments. */
1287 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1288 gcc_assert (sym->formal->next->next == NULL);
1290 gfc_init_block (&block);
1292 gfc_add_block_to_block (&block, &lse->pre);
1293 gfc_add_block_to_block (&block, &rse->pre);
1295 /* Build the argument list for the call, including hidden string lengths. */
1296 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1297 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1298 if (lse->string_length != NULL_TREE)
1299 args = gfc_chainon_list (args, lse->string_length);
1300 if (rse->string_length != NULL_TREE)
1301 args = gfc_chainon_list (args, rse->string_length);
1303 /* Build the function call. */
1304 gfc_init_se (&se, NULL);
1305 gfc_conv_function_val (&se, sym);
1306 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1307 tmp = build_call_list (tmp, se.expr, args);
1308 gfc_add_expr_to_block (&block, tmp);
1310 gfc_add_block_to_block (&block, &lse->post);
1311 gfc_add_block_to_block (&block, &rse->post);
1313 return gfc_finish_block (&block);
1317 /* Initialize MAPPING. */
1320 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1322 mapping->syms = NULL;
1323 mapping->charlens = NULL;
1327 /* Free all memory held by MAPPING (but not MAPPING itself). */
1330 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1332 gfc_interface_sym_mapping *sym;
1333 gfc_interface_sym_mapping *nextsym;
1335 gfc_charlen *nextcl;
1337 for (sym = mapping->syms; sym; sym = nextsym)
1339 nextsym = sym->next;
1340 gfc_free_symbol (sym->new->n.sym);
1341 gfc_free (sym->new);
1344 for (cl = mapping->charlens; cl; cl = nextcl)
1347 gfc_free_expr (cl->length);
1353 /* Return a copy of gfc_charlen CL. Add the returned structure to
1354 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1356 static gfc_charlen *
1357 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1362 new = gfc_get_charlen ();
1363 new->next = mapping->charlens;
1364 new->length = gfc_copy_expr (cl->length);
1366 mapping->charlens = new;
1371 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1372 array variable that can be used as the actual argument for dummy
1373 argument SYM. Add any initialization code to BLOCK. PACKED is as
1374 for gfc_get_nodesc_array_type and DATA points to the first element
1375 in the passed array. */
1378 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1379 gfc_packed packed, tree data)
1384 type = gfc_typenode_for_spec (&sym->ts);
1385 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1387 var = gfc_create_var (type, "ifm");
1388 gfc_add_modify_expr (block, var, fold_convert (type, data));
1394 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1395 and offset of descriptorless array type TYPE given that it has the same
1396 size as DESC. Add any set-up code to BLOCK. */
1399 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1406 offset = gfc_index_zero_node;
1407 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1409 dim = gfc_rank_cst[n];
1410 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1411 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1413 GFC_TYPE_ARRAY_LBOUND (type, n)
1414 = gfc_conv_descriptor_lbound (desc, dim);
1415 GFC_TYPE_ARRAY_UBOUND (type, n)
1416 = gfc_conv_descriptor_ubound (desc, dim);
1418 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1420 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1421 gfc_conv_descriptor_ubound (desc, dim),
1422 gfc_conv_descriptor_lbound (desc, dim));
1423 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1424 GFC_TYPE_ARRAY_LBOUND (type, n),
1426 tmp = gfc_evaluate_now (tmp, block);
1427 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1429 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1430 GFC_TYPE_ARRAY_LBOUND (type, n),
1431 GFC_TYPE_ARRAY_STRIDE (type, n));
1432 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1434 offset = gfc_evaluate_now (offset, block);
1435 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1439 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1440 in SE. The caller may still use se->expr and se->string_length after
1441 calling this function. */
1444 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1445 gfc_symbol * sym, gfc_se * se)
1447 gfc_interface_sym_mapping *sm;
1451 gfc_symbol *new_sym;
1453 gfc_symtree *new_symtree;
1455 /* Create a new symbol to represent the actual argument. */
1456 new_sym = gfc_new_symbol (sym->name, NULL);
1457 new_sym->ts = sym->ts;
1458 new_sym->attr.referenced = 1;
1459 new_sym->attr.dimension = sym->attr.dimension;
1460 new_sym->attr.pointer = sym->attr.pointer;
1461 new_sym->attr.allocatable = sym->attr.allocatable;
1462 new_sym->attr.flavor = sym->attr.flavor;
1464 /* Create a fake symtree for it. */
1466 new_symtree = gfc_new_symtree (&root, sym->name);
1467 new_symtree->n.sym = new_sym;
1468 gcc_assert (new_symtree == root);
1470 /* Create a dummy->actual mapping. */
1471 sm = gfc_getmem (sizeof (*sm));
1472 sm->next = mapping->syms;
1474 sm->new = new_symtree;
1477 /* Stabilize the argument's value. */
1478 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1480 if (sym->ts.type == BT_CHARACTER)
1482 /* Create a copy of the dummy argument's length. */
1483 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1485 /* If the length is specified as "*", record the length that
1486 the caller is passing. We should use the callee's length
1487 in all other cases. */
1488 if (!new_sym->ts.cl->length)
1490 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1491 new_sym->ts.cl->backend_decl = se->string_length;
1495 /* Use the passed value as-is if the argument is a function. */
1496 if (sym->attr.flavor == FL_PROCEDURE)
1499 /* If the argument is either a string or a pointer to a string,
1500 convert it to a boundless character type. */
1501 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1503 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1504 tmp = build_pointer_type (tmp);
1505 if (sym->attr.pointer)
1506 value = build_fold_indirect_ref (se->expr);
1509 value = fold_convert (tmp, value);
1512 /* If the argument is a scalar, a pointer to an array or an allocatable,
1514 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1515 value = build_fold_indirect_ref (se->expr);
1517 /* For character(*), use the actual argument's descriptor. */
1518 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1519 value = build_fold_indirect_ref (se->expr);
1521 /* If the argument is an array descriptor, use it to determine
1522 information about the actual argument's shape. */
1523 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1524 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1526 /* Get the actual argument's descriptor. */
1527 desc = build_fold_indirect_ref (se->expr);
1529 /* Create the replacement variable. */
1530 tmp = gfc_conv_descriptor_data_get (desc);
1531 value = gfc_get_interface_mapping_array (&se->pre, sym,
1534 /* Use DESC to work out the upper bounds, strides and offset. */
1535 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1538 /* Otherwise we have a packed array. */
1539 value = gfc_get_interface_mapping_array (&se->pre, sym,
1540 PACKED_FULL, se->expr);
1542 new_sym->backend_decl = value;
1546 /* Called once all dummy argument mappings have been added to MAPPING,
1547 but before the mapping is used to evaluate expressions. Pre-evaluate
1548 the length of each argument, adding any initialization code to PRE and
1549 any finalization code to POST. */
1552 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1553 stmtblock_t * pre, stmtblock_t * post)
1555 gfc_interface_sym_mapping *sym;
1559 for (sym = mapping->syms; sym; sym = sym->next)
1560 if (sym->new->n.sym->ts.type == BT_CHARACTER
1561 && !sym->new->n.sym->ts.cl->backend_decl)
1563 expr = sym->new->n.sym->ts.cl->length;
1564 gfc_apply_interface_mapping_to_expr (mapping, expr);
1565 gfc_init_se (&se, NULL);
1566 gfc_conv_expr (&se, expr);
1568 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1569 gfc_add_block_to_block (pre, &se.pre);
1570 gfc_add_block_to_block (post, &se.post);
1572 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1577 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1581 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1582 gfc_constructor * c)
1584 for (; c; c = c->next)
1586 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1589 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1590 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1591 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1597 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1601 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1606 for (; ref; ref = ref->next)
1610 for (n = 0; n < ref->u.ar.dimen; n++)
1612 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1613 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1614 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1616 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1623 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1624 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1630 /* EXPR is a copy of an expression that appeared in the interface
1631 associated with MAPPING. Walk it recursively looking for references to
1632 dummy arguments that MAPPING maps to actual arguments. Replace each such
1633 reference with a reference to the associated actual argument. */
1636 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1639 gfc_interface_sym_mapping *sym;
1640 gfc_actual_arglist *actual;
1641 int seen_result = 0;
1646 /* Copying an expression does not copy its length, so do that here. */
1647 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1649 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1650 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1653 /* Apply the mapping to any references. */
1654 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1656 /* ...and to the expression's symbol, if it has one. */
1658 for (sym = mapping->syms; sym; sym = sym->next)
1659 if (sym->old == expr->symtree->n.sym)
1660 expr->symtree = sym->new;
1662 /* ...and to subexpressions in expr->value. */
1663 switch (expr->expr_type)
1666 if (expr->symtree->n.sym->attr.result)
1670 case EXPR_SUBSTRING:
1674 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1675 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1679 if (expr->value.function.esym == NULL
1680 && expr->value.function.isym != NULL
1681 && expr->value.function.isym->id == GFC_ISYM_LEN
1682 && expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
1683 && gfc_apply_interface_mapping_to_expr (mapping,
1684 expr->value.function.actual->expr))
1687 new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
1689 gfc_free (new_expr);
1690 gfc_apply_interface_mapping_to_expr (mapping, expr);
1694 for (sym = mapping->syms; sym; sym = sym->next)
1695 if (sym->old == expr->value.function.esym)
1696 expr->value.function.esym = sym->new->n.sym;
1698 for (actual = expr->value.function.actual; actual; actual = actual->next)
1699 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1703 case EXPR_STRUCTURE:
1704 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1711 /* Evaluate interface expression EXPR using MAPPING. Store the result
1715 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1716 gfc_se * se, gfc_expr * expr)
1718 expr = gfc_copy_expr (expr);
1719 gfc_apply_interface_mapping_to_expr (mapping, expr);
1720 gfc_conv_expr (se, expr);
1721 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1722 gfc_free_expr (expr);
1725 /* Returns a reference to a temporary array into which a component of
1726 an actual argument derived type array is copied and then returned
1727 after the function call.
1728 TODO Get rid of this kludge, when array descriptors are capable of
1729 handling arrays with a bigger stride in bytes than size. */
1732 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1733 int g77, sym_intent intent)
1749 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1751 gfc_init_se (&lse, NULL);
1752 gfc_init_se (&rse, NULL);
1754 /* Walk the argument expression. */
1755 rss = gfc_walk_expr (expr);
1757 gcc_assert (rss != gfc_ss_terminator);
1759 /* Initialize the scalarizer. */
1760 gfc_init_loopinfo (&loop);
1761 gfc_add_ss_to_loop (&loop, rss);
1763 /* Calculate the bounds of the scalarization. */
1764 gfc_conv_ss_startstride (&loop);
1766 /* Build an ss for the temporary. */
1767 base_type = gfc_typenode_for_spec (&expr->ts);
1768 if (GFC_ARRAY_TYPE_P (base_type)
1769 || GFC_DESCRIPTOR_TYPE_P (base_type))
1770 base_type = gfc_get_element_type (base_type);
1772 loop.temp_ss = gfc_get_ss ();;
1773 loop.temp_ss->type = GFC_SS_TEMP;
1774 loop.temp_ss->data.temp.type = base_type;
1776 if (expr->ts.type == BT_CHARACTER)
1778 gfc_ref *char_ref = expr->ref;
1780 for (; char_ref; char_ref = char_ref->next)
1781 if (char_ref->type == REF_SUBSTRING)
1785 expr->ts.cl = gfc_get_charlen ();
1786 expr->ts.cl->next = char_ref->u.ss.length->next;
1787 char_ref->u.ss.length->next = expr->ts.cl;
1789 gfc_init_se (&tmp_se, NULL);
1790 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1791 gfc_array_index_type);
1792 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1793 tmp_se.expr, gfc_index_one_node);
1794 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1795 gfc_init_se (&tmp_se, NULL);
1796 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1797 gfc_array_index_type);
1798 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1800 expr->ts.cl->backend_decl = tmp;
1804 loop.temp_ss->data.temp.type
1805 = gfc_typenode_for_spec (&expr->ts);
1806 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1809 loop.temp_ss->data.temp.dimen = loop.dimen;
1810 loop.temp_ss->next = gfc_ss_terminator;
1812 /* Associate the SS with the loop. */
1813 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1815 /* Setup the scalarizing loops. */
1816 gfc_conv_loop_setup (&loop);
1818 /* Pass the temporary descriptor back to the caller. */
1819 info = &loop.temp_ss->data.info;
1820 parmse->expr = info->descriptor;
1822 /* Setup the gfc_se structures. */
1823 gfc_copy_loopinfo_to_se (&lse, &loop);
1824 gfc_copy_loopinfo_to_se (&rse, &loop);
1827 lse.ss = loop.temp_ss;
1828 gfc_mark_ss_chain_used (rss, 1);
1829 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1831 /* Start the scalarized loop body. */
1832 gfc_start_scalarized_body (&loop, &body);
1834 /* Translate the expression. */
1835 gfc_conv_expr (&rse, expr);
1837 gfc_conv_tmp_array_ref (&lse);
1838 gfc_advance_se_ss_chain (&lse);
1840 if (intent != INTENT_OUT)
1842 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1843 gfc_add_expr_to_block (&body, tmp);
1844 gcc_assert (rse.ss == gfc_ss_terminator);
1845 gfc_trans_scalarizing_loops (&loop, &body);
1849 /* Make sure that the temporary declaration survives by merging
1850 all the loop declarations into the current context. */
1851 for (n = 0; n < loop.dimen; n++)
1853 gfc_merge_block_scope (&body);
1854 body = loop.code[loop.order[n]];
1856 gfc_merge_block_scope (&body);
1859 /* Add the post block after the second loop, so that any
1860 freeing of allocated memory is done at the right time. */
1861 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1863 /**********Copy the temporary back again.*********/
1865 gfc_init_se (&lse, NULL);
1866 gfc_init_se (&rse, NULL);
1868 /* Walk the argument expression. */
1869 lss = gfc_walk_expr (expr);
1870 rse.ss = loop.temp_ss;
1873 /* Initialize the scalarizer. */
1874 gfc_init_loopinfo (&loop2);
1875 gfc_add_ss_to_loop (&loop2, lss);
1877 /* Calculate the bounds of the scalarization. */
1878 gfc_conv_ss_startstride (&loop2);
1880 /* Setup the scalarizing loops. */
1881 gfc_conv_loop_setup (&loop2);
1883 gfc_copy_loopinfo_to_se (&lse, &loop2);
1884 gfc_copy_loopinfo_to_se (&rse, &loop2);
1886 gfc_mark_ss_chain_used (lss, 1);
1887 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1889 /* Declare the variable to hold the temporary offset and start the
1890 scalarized loop body. */
1891 offset = gfc_create_var (gfc_array_index_type, NULL);
1892 gfc_start_scalarized_body (&loop2, &body);
1894 /* Build the offsets for the temporary from the loop variables. The
1895 temporary array has lbounds of zero and strides of one in all
1896 dimensions, so this is very simple. The offset is only computed
1897 outside the innermost loop, so the overall transfer could be
1898 optimized further. */
1899 info = &rse.ss->data.info;
1901 tmp_index = gfc_index_zero_node;
1902 for (n = info->dimen - 1; n > 0; n--)
1905 tmp = rse.loop->loopvar[n];
1906 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1907 tmp, rse.loop->from[n]);
1908 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1911 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1912 rse.loop->to[n-1], rse.loop->from[n-1]);
1913 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1914 tmp_str, gfc_index_one_node);
1916 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1920 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1921 tmp_index, rse.loop->from[0]);
1922 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1924 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1925 rse.loop->loopvar[0], offset);
1927 /* Now use the offset for the reference. */
1928 tmp = build_fold_indirect_ref (info->data);
1929 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1931 if (expr->ts.type == BT_CHARACTER)
1932 rse.string_length = expr->ts.cl->backend_decl;
1934 gfc_conv_expr (&lse, expr);
1936 gcc_assert (lse.ss == gfc_ss_terminator);
1938 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1939 gfc_add_expr_to_block (&body, tmp);
1941 /* Generate the copying loops. */
1942 gfc_trans_scalarizing_loops (&loop2, &body);
1944 /* Wrap the whole thing up by adding the second loop to the post-block
1945 and following it by the post-block of the first loop. In this way,
1946 if the temporary needs freeing, it is done after use! */
1947 if (intent != INTENT_IN)
1949 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1950 gfc_add_block_to_block (&parmse->post, &loop2.post);
1953 gfc_add_block_to_block (&parmse->post, &loop.post);
1955 gfc_cleanup_loop (&loop);
1956 gfc_cleanup_loop (&loop2);
1958 /* Pass the string length to the argument expression. */
1959 if (expr->ts.type == BT_CHARACTER)
1960 parmse->string_length = expr->ts.cl->backend_decl;
1962 /* We want either the address for the data or the address of the descriptor,
1963 depending on the mode of passing array arguments. */
1965 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1967 parmse->expr = build_fold_addr_expr (parmse->expr);
1972 /* Is true if an array reference is followed by a component or substring
1976 is_aliased_array (gfc_expr * e)
1982 for (ref = e->ref; ref; ref = ref->next)
1984 if (ref->type == REF_ARRAY
1985 && ref->u.ar.type != AR_ELEMENT)
1989 && ref->type != REF_ARRAY)
1995 /* Generate the code for argument list functions. */
1998 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2000 /* Pass by value for g77 %VAL(arg), pass the address
2001 indirectly for %LOC, else by reference. Thus %REF
2002 is a "do-nothing" and %LOC is the same as an F95
2004 if (strncmp (name, "%VAL", 4) == 0)
2005 gfc_conv_expr (se, expr);
2006 else if (strncmp (name, "%LOC", 4) == 0)
2008 gfc_conv_expr_reference (se, expr);
2009 se->expr = gfc_build_addr_expr (NULL, se->expr);
2011 else if (strncmp (name, "%REF", 4) == 0)
2012 gfc_conv_expr_reference (se, expr);
2014 gfc_error ("Unknown argument list function at %L", &expr->where);
2018 /* Generate code for a procedure call. Note can return se->post != NULL.
2019 If se->direct_byref is set then se->expr contains the return parameter.
2020 Return nonzero, if the call has alternate specifiers. */
2023 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2024 gfc_actual_arglist * arg, tree append_args)
2026 gfc_interface_mapping mapping;
2040 gfc_formal_arglist *formal;
2041 int has_alternate_specifier = 0;
2042 bool need_interface_mapping;
2049 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2051 arglist = NULL_TREE;
2052 retargs = NULL_TREE;
2053 stringargs = NULL_TREE;
2057 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2059 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2061 if (arg->expr->rank == 0)
2062 gfc_conv_expr_reference (se, arg->expr);
2066 /* This is really the actual arg because no formal arglist is
2067 created for C_LOC. */
2068 fsym = arg->expr->symtree->n.sym;
2070 /* We should want it to do g77 calling convention. */
2072 && !(fsym->attr.pointer || fsym->attr.allocatable)
2073 && fsym->as->type != AS_ASSUMED_SHAPE;
2074 f = f || !sym->attr.always_explicit;
2076 argss = gfc_walk_expr (arg->expr);
2077 gfc_conv_array_parameter (se, arg->expr, argss, f);
2082 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2084 arg->expr->ts.type = sym->ts.derived->ts.type;
2085 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2086 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2087 gfc_conv_expr_reference (se, arg->expr);
2095 if (!sym->attr.elemental)
2097 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2098 if (se->ss->useflags)
2100 gcc_assert (gfc_return_by_reference (sym)
2101 && sym->result->attr.dimension);
2102 gcc_assert (se->loop != NULL);
2104 /* Access the previously obtained result. */
2105 gfc_conv_tmp_array_ref (se);
2106 gfc_advance_se_ss_chain (se);
2110 info = &se->ss->data.info;
2115 gfc_init_block (&post);
2116 gfc_init_interface_mapping (&mapping);
2117 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2118 && sym->ts.cl->length
2119 && sym->ts.cl->length->expr_type
2121 || sym->attr.dimension);
2122 formal = sym->formal;
2123 /* Evaluate the arguments. */
2124 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2127 fsym = formal ? formal->sym : NULL;
2128 parm_kind = MISSING;
2132 if (se->ignore_optional)
2134 /* Some intrinsics have already been resolved to the correct
2138 else if (arg->label)
2140 has_alternate_specifier = 1;
2145 /* Pass a NULL pointer for an absent arg. */
2146 gfc_init_se (&parmse, NULL);
2147 parmse.expr = null_pointer_node;
2148 if (arg->missing_arg_type == BT_CHARACTER)
2149 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2152 else if (se->ss && se->ss->useflags)
2154 /* An elemental function inside a scalarized loop. */
2155 gfc_init_se (&parmse, se);
2156 gfc_conv_expr_reference (&parmse, e);
2157 parm_kind = ELEMENTAL;
2161 /* A scalar or transformational function. */
2162 gfc_init_se (&parmse, NULL);
2163 argss = gfc_walk_expr (e);
2165 if (argss == gfc_ss_terminator)
2167 if (fsym && fsym->attr.value)
2169 gfc_conv_expr (&parmse, e);
2171 else if (arg->name && arg->name[0] == '%')
2172 /* Argument list functions %VAL, %LOC and %REF are signalled
2173 through arg->name. */
2174 conv_arglist_function (&parmse, arg->expr, arg->name);
2175 else if ((e->expr_type == EXPR_FUNCTION)
2176 && e->symtree->n.sym->attr.pointer
2177 && fsym && fsym->attr.target)
2179 gfc_conv_expr (&parmse, e);
2180 parmse.expr = build_fold_addr_expr (parmse.expr);
2184 gfc_conv_expr_reference (&parmse, e);
2185 if (fsym && fsym->attr.pointer
2186 && fsym->attr.flavor != FL_PROCEDURE
2187 && e->expr_type != EXPR_NULL)
2189 /* Scalar pointer dummy args require an extra level of
2190 indirection. The null pointer already contains
2191 this level of indirection. */
2192 parm_kind = SCALAR_POINTER;
2193 parmse.expr = build_fold_addr_expr (parmse.expr);
2199 /* If the procedure requires an explicit interface, the actual
2200 argument is passed according to the corresponding formal
2201 argument. If the corresponding formal argument is a POINTER,
2202 ALLOCATABLE or assumed shape, we do not use g77's calling
2203 convention, and pass the address of the array descriptor
2204 instead. Otherwise we use g77's calling convention. */
2207 && !(fsym->attr.pointer || fsym->attr.allocatable)
2208 && fsym->as->type != AS_ASSUMED_SHAPE;
2209 f = f || !sym->attr.always_explicit;
2211 if (e->expr_type == EXPR_VARIABLE
2212 && is_aliased_array (e))
2213 /* The actual argument is a component reference to an
2214 array of derived types. In this case, the argument
2215 is converted to a temporary, which is passed and then
2216 written back after the procedure call. */
2217 gfc_conv_aliased_arg (&parmse, e, f,
2218 fsym ? fsym->attr.intent : INTENT_INOUT);
2220 gfc_conv_array_parameter (&parmse, e, argss, f);
2222 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2223 allocated on entry, it must be deallocated. */
2224 if (fsym && fsym->attr.allocatable
2225 && fsym->attr.intent == INTENT_OUT)
2227 tmp = build_fold_indirect_ref (parmse.expr);
2228 tmp = gfc_trans_dealloc_allocated (tmp);
2229 gfc_add_expr_to_block (&se->pre, tmp);
2239 /* If an optional argument is itself an optional dummy
2240 argument, check its presence and substitute a null
2242 if (e->expr_type == EXPR_VARIABLE
2243 && e->symtree->n.sym->attr.optional
2244 && fsym->attr.optional)
2245 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2247 /* Obtain the character length of an assumed character
2248 length procedure from the typespec. */
2249 if (fsym->ts.type == BT_CHARACTER
2250 && parmse.string_length == NULL_TREE
2251 && e->ts.type == BT_PROCEDURE
2252 && e->symtree->n.sym->ts.type == BT_CHARACTER
2253 && e->symtree->n.sym->ts.cl->length != NULL)
2255 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2256 parmse.string_length
2257 = e->symtree->n.sym->ts.cl->backend_decl;
2261 if (need_interface_mapping)
2262 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2265 gfc_add_block_to_block (&se->pre, &parmse.pre);
2266 gfc_add_block_to_block (&post, &parmse.post);
2268 /* Allocated allocatable components of derived types must be
2269 deallocated for INTENT(OUT) dummy arguments and non-variable
2270 scalars. Non-variable arrays are dealt with in trans-array.c
2271 (gfc_conv_array_parameter). */
2272 if (e && e->ts.type == BT_DERIVED
2273 && e->ts.derived->attr.alloc_comp
2274 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2276 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2279 tmp = build_fold_indirect_ref (parmse.expr);
2280 parm_rank = e->rank;
2288 case (SCALAR_POINTER):
2289 tmp = build_fold_indirect_ref (tmp);
2296 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2297 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2298 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2299 tmp, build_empty_stmt ());
2301 if (e->expr_type != EXPR_VARIABLE)
2302 /* Don't deallocate non-variables until they have been used. */
2303 gfc_add_expr_to_block (&se->post, tmp);
2306 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2307 gfc_add_expr_to_block (&se->pre, tmp);
2311 /* Character strings are passed as two parameters, a length and a
2313 if (parmse.string_length != NULL_TREE)
2314 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2316 arglist = gfc_chainon_list (arglist, parmse.expr);
2318 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2321 if (ts.type == BT_CHARACTER)
2323 if (sym->ts.cl->length == NULL)
2325 /* Assumed character length results are not allowed by 5.1.1.5 of the
2326 standard and are trapped in resolve.c; except in the case of SPREAD
2327 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2328 we take the character length of the first argument for the result.
2329 For dummies, we have to look through the formal argument list for
2330 this function and use the character length found there.*/
2331 if (!sym->attr.dummy)
2332 cl.backend_decl = TREE_VALUE (stringargs);
2335 formal = sym->ns->proc_name->formal;
2336 for (; formal; formal = formal->next)
2337 if (strcmp (formal->sym->name, sym->name) == 0)
2338 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2345 /* Calculate the length of the returned string. */
2346 gfc_init_se (&parmse, NULL);
2347 if (need_interface_mapping)
2348 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2350 gfc_conv_expr (&parmse, sym->ts.cl->length);
2351 gfc_add_block_to_block (&se->pre, &parmse.pre);
2352 gfc_add_block_to_block (&se->post, &parmse.post);
2354 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2355 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2356 build_int_cst (gfc_charlen_type_node, 0));
2357 cl.backend_decl = tmp;
2360 /* Set up a charlen structure for it. */
2365 len = cl.backend_decl;
2368 byref = gfc_return_by_reference (sym);
2371 if (se->direct_byref)
2373 /* Sometimes, too much indirection can be applied; eg. for
2374 function_result = array_valued_recursive_function. */
2375 if (TREE_TYPE (TREE_TYPE (se->expr))
2376 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2377 && GFC_DESCRIPTOR_TYPE_P
2378 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2379 se->expr = build_fold_indirect_ref (se->expr);
2381 retargs = gfc_chainon_list (retargs, se->expr);
2383 else if (sym->result->attr.dimension)
2385 gcc_assert (se->loop && info);
2387 /* Set the type of the array. */
2388 tmp = gfc_typenode_for_spec (&ts);
2389 info->dimen = se->loop->dimen;
2391 /* Evaluate the bounds of the result, if known. */
2392 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2394 /* Create a temporary to store the result. In case the function
2395 returns a pointer, the temporary will be a shallow copy and
2396 mustn't be deallocated. */
2397 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2398 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2399 false, !sym->attr.pointer, callee_alloc);
2401 /* Pass the temporary as the first argument. */
2402 tmp = info->descriptor;
2403 tmp = build_fold_addr_expr (tmp);
2404 retargs = gfc_chainon_list (retargs, tmp);
2406 else if (ts.type == BT_CHARACTER)
2408 /* Pass the string length. */
2409 type = gfc_get_character_type (ts.kind, ts.cl);
2410 type = build_pointer_type (type);
2412 /* Return an address to a char[0:len-1]* temporary for
2413 character pointers. */
2414 if (sym->attr.pointer || sym->attr.allocatable)
2416 /* Build char[0:len-1] * pstr. */
2417 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2418 build_int_cst (gfc_charlen_type_node, 1));
2419 tmp = build_range_type (gfc_array_index_type,
2420 gfc_index_zero_node, tmp);
2421 tmp = build_array_type (gfc_character1_type_node, tmp);
2422 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2424 /* Provide an address expression for the function arguments. */
2425 var = build_fold_addr_expr (var);
2428 var = gfc_conv_string_tmp (se, type, len);
2430 retargs = gfc_chainon_list (retargs, var);
2434 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2436 type = gfc_get_complex_type (ts.kind);
2437 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2438 retargs = gfc_chainon_list (retargs, var);
2441 /* Add the string length to the argument list. */
2442 if (ts.type == BT_CHARACTER)
2443 retargs = gfc_chainon_list (retargs, len);
2445 gfc_free_interface_mapping (&mapping);
2447 /* Add the return arguments. */
2448 arglist = chainon (retargs, arglist);
2450 /* Add the hidden string length parameters to the arguments. */
2451 arglist = chainon (arglist, stringargs);
2453 /* We may want to append extra arguments here. This is used e.g. for
2454 calls to libgfortran_matmul_??, which need extra information. */
2455 if (append_args != NULL_TREE)
2456 arglist = chainon (arglist, append_args);
2458 /* Generate the actual call. */
2459 gfc_conv_function_val (se, sym);
2461 /* If there are alternate return labels, function type should be
2462 integer. Can't modify the type in place though, since it can be shared
2463 with other functions. For dummy arguments, the typing is done to
2464 to this result, even if it has to be repeated for each call. */
2465 if (has_alternate_specifier
2466 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2468 if (!sym->attr.dummy)
2470 TREE_TYPE (sym->backend_decl)
2471 = build_function_type (integer_type_node,
2472 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2473 se->expr = build_fold_addr_expr (sym->backend_decl);
2476 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2479 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2480 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2482 /* If we have a pointer function, but we don't want a pointer, e.g.
2485 where f is pointer valued, we have to dereference the result. */
2486 if (!se->want_pointer && !byref && sym->attr.pointer)
2487 se->expr = build_fold_indirect_ref (se->expr);
2489 /* f2c calling conventions require a scalar default real function to
2490 return a double precision result. Convert this back to default
2491 real. We only care about the cases that can happen in Fortran 77.
2493 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2494 && sym->ts.kind == gfc_default_real_kind
2495 && !sym->attr.always_explicit)
2496 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2498 /* A pure function may still have side-effects - it may modify its
2500 TREE_SIDE_EFFECTS (se->expr) = 1;
2502 if (!sym->attr.pure)
2503 TREE_SIDE_EFFECTS (se->expr) = 1;
2508 /* Add the function call to the pre chain. There is no expression. */
2509 gfc_add_expr_to_block (&se->pre, se->expr);
2510 se->expr = NULL_TREE;
2512 if (!se->direct_byref)
2514 if (sym->attr.dimension)
2516 if (flag_bounds_check)
2518 /* Check the data pointer hasn't been modified. This would
2519 happen in a function returning a pointer. */
2520 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2521 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2523 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2525 se->expr = info->descriptor;
2526 /* Bundle in the string length. */
2527 se->string_length = len;
2529 else if (sym->ts.type == BT_CHARACTER)
2531 /* Dereference for character pointer results. */
2532 if (sym->attr.pointer || sym->attr.allocatable)
2533 se->expr = build_fold_indirect_ref (var);
2537 se->string_length = len;
2541 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2542 se->expr = build_fold_indirect_ref (var);
2547 /* Follow the function call with the argument post block. */
2549 gfc_add_block_to_block (&se->pre, &post);
2551 gfc_add_block_to_block (&se->post, &post);
2553 return has_alternate_specifier;
2557 /* Generate code to copy a string. */
2560 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2561 tree slength, tree src)
2563 tree tmp, dlen, slen;
2571 stmtblock_t tempblock;
2573 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2574 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2576 /* Deal with single character specially. */
2577 dsc = gfc_to_single_character (dlen, dest);
2578 ssc = gfc_to_single_character (slen, src);
2579 if (dsc != NULL_TREE && ssc != NULL_TREE)
2581 gfc_add_modify_expr (block, dsc, ssc);
2585 /* Do nothing if the destination length is zero. */
2586 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2587 build_int_cst (size_type_node, 0));
2589 /* The following code was previously in _gfortran_copy_string:
2591 // The two strings may overlap so we use memmove.
2593 copy_string (GFC_INTEGER_4 destlen, char * dest,
2594 GFC_INTEGER_4 srclen, const char * src)
2596 if (srclen >= destlen)
2598 // This will truncate if too long.
2599 memmove (dest, src, destlen);
2603 memmove (dest, src, srclen);
2605 memset (&dest[srclen], ' ', destlen - srclen);
2609 We're now doing it here for better optimization, but the logic
2612 /* Truncate string if source is too long. */
2613 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2614 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2615 3, dest, src, dlen);
2617 /* Else copy and pad with spaces. */
2618 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
2619 3, dest, src, slen);
2621 tmp4 = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, dest,
2622 fold_convert (sizetype, slen));
2623 tmp4 = build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3,
2625 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2626 lang_hooks.to_target_charset (' ')),
2627 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2630 gfc_init_block (&tempblock);
2631 gfc_add_expr_to_block (&tempblock, tmp3);
2632 gfc_add_expr_to_block (&tempblock, tmp4);
2633 tmp3 = gfc_finish_block (&tempblock);
2635 /* The whole copy_string function is there. */
2636 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2637 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2638 gfc_add_expr_to_block (block, tmp);
2642 /* Translate a statement function.
2643 The value of a statement function reference is obtained by evaluating the
2644 expression using the values of the actual arguments for the values of the
2645 corresponding dummy arguments. */
2648 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2652 gfc_formal_arglist *fargs;
2653 gfc_actual_arglist *args;
2656 gfc_saved_var *saved_vars;
2662 sym = expr->symtree->n.sym;
2663 args = expr->value.function.actual;
2664 gfc_init_se (&lse, NULL);
2665 gfc_init_se (&rse, NULL);
2668 for (fargs = sym->formal; fargs; fargs = fargs->next)
2670 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2671 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2673 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2675 /* Each dummy shall be specified, explicitly or implicitly, to be
2677 gcc_assert (fargs->sym->attr.dimension == 0);
2680 /* Create a temporary to hold the value. */
2681 type = gfc_typenode_for_spec (&fsym->ts);
2682 temp_vars[n] = gfc_create_var (type, fsym->name);
2684 if (fsym->ts.type == BT_CHARACTER)
2686 /* Copy string arguments. */
2689 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2690 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2692 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2693 tmp = gfc_build_addr_expr (build_pointer_type (type),
2696 gfc_conv_expr (&rse, args->expr);
2697 gfc_conv_string_parameter (&rse);
2698 gfc_add_block_to_block (&se->pre, &lse.pre);
2699 gfc_add_block_to_block (&se->pre, &rse.pre);
2701 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2703 gfc_add_block_to_block (&se->pre, &lse.post);
2704 gfc_add_block_to_block (&se->pre, &rse.post);
2708 /* For everything else, just evaluate the expression. */
2709 gfc_conv_expr (&lse, args->expr);
2711 gfc_add_block_to_block (&se->pre, &lse.pre);
2712 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2713 gfc_add_block_to_block (&se->pre, &lse.post);
2719 /* Use the temporary variables in place of the real ones. */
2720 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2721 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2723 gfc_conv_expr (se, sym->value);
2725 if (sym->ts.type == BT_CHARACTER)
2727 gfc_conv_const_charlen (sym->ts.cl);
2729 /* Force the expression to the correct length. */
2730 if (!INTEGER_CST_P (se->string_length)
2731 || tree_int_cst_lt (se->string_length,
2732 sym->ts.cl->backend_decl))
2734 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2735 tmp = gfc_create_var (type, sym->name);
2736 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2737 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2738 se->string_length, se->expr);
2741 se->string_length = sym->ts.cl->backend_decl;
2744 /* Restore the original variables. */
2745 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2746 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2747 gfc_free (saved_vars);
2751 /* Translate a function expression. */
2754 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2758 if (expr->value.function.isym)
2760 gfc_conv_intrinsic_function (se, expr);
2764 /* We distinguish statement functions from general functions to improve
2765 runtime performance. */
2766 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2768 gfc_conv_statement_function (se, expr);
2772 /* expr.value.function.esym is the resolved (specific) function symbol for
2773 most functions. However this isn't set for dummy procedures. */
2774 sym = expr->value.function.esym;
2776 sym = expr->symtree->n.sym;
2777 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2782 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2784 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2785 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2787 gfc_conv_tmp_array_ref (se);
2788 gfc_advance_se_ss_chain (se);
2792 /* Build a static initializer. EXPR is the expression for the initial value.
2793 The other parameters describe the variable of the component being
2794 initialized. EXPR may be null. */
2797 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2798 bool array, bool pointer)
2802 if (!(expr || pointer))
2805 if (expr != NULL && expr->ts.type == BT_DERIVED
2806 && expr->ts.is_iso_c && expr->ts.derived
2807 && (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
2808 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR))
2809 expr = gfc_int_expr (0);
2813 /* Arrays need special handling. */
2815 return gfc_build_null_descriptor (type);
2817 return gfc_conv_array_initializer (type, expr);
2820 return fold_convert (type, null_pointer_node);
2826 gfc_init_se (&se, NULL);
2827 gfc_conv_structure (&se, expr, 1);
2831 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2834 gfc_init_se (&se, NULL);
2835 gfc_conv_constant (&se, expr);
2842 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2854 gfc_start_block (&block);
2856 /* Initialize the scalarizer. */
2857 gfc_init_loopinfo (&loop);
2859 gfc_init_se (&lse, NULL);
2860 gfc_init_se (&rse, NULL);
2863 rss = gfc_walk_expr (expr);
2864 if (rss == gfc_ss_terminator)
2866 /* The rhs is scalar. Add a ss for the expression. */
2867 rss = gfc_get_ss ();
2868 rss->next = gfc_ss_terminator;
2869 rss->type = GFC_SS_SCALAR;
2873 /* Create a SS for the destination. */
2874 lss = gfc_get_ss ();
2875 lss->type = GFC_SS_COMPONENT;
2877 lss->shape = gfc_get_shape (cm->as->rank);
2878 lss->next = gfc_ss_terminator;
2879 lss->data.info.dimen = cm->as->rank;
2880 lss->data.info.descriptor = dest;
2881 lss->data.info.data = gfc_conv_array_data (dest);
2882 lss->data.info.offset = gfc_conv_array_offset (dest);
2883 for (n = 0; n < cm->as->rank; n++)
2885 lss->data.info.dim[n] = n;
2886 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2887 lss->data.info.stride[n] = gfc_index_one_node;
2889 mpz_init (lss->shape[n]);
2890 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2891 cm->as->lower[n]->value.integer);
2892 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2895 /* Associate the SS with the loop. */
2896 gfc_add_ss_to_loop (&loop, lss);
2897 gfc_add_ss_to_loop (&loop, rss);
2899 /* Calculate the bounds of the scalarization. */
2900 gfc_conv_ss_startstride (&loop);
2902 /* Setup the scalarizing loops. */
2903 gfc_conv_loop_setup (&loop);
2905 /* Setup the gfc_se structures. */
2906 gfc_copy_loopinfo_to_se (&lse, &loop);
2907 gfc_copy_loopinfo_to_se (&rse, &loop);
2910 gfc_mark_ss_chain_used (rss, 1);
2912 gfc_mark_ss_chain_used (lss, 1);
2914 /* Start the scalarized loop body. */
2915 gfc_start_scalarized_body (&loop, &body);
2917 gfc_conv_tmp_array_ref (&lse);
2918 if (cm->ts.type == BT_CHARACTER)
2919 lse.string_length = cm->ts.cl->backend_decl;
2921 gfc_conv_expr (&rse, expr);
2923 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2924 gfc_add_expr_to_block (&body, tmp);
2926 gcc_assert (rse.ss == gfc_ss_terminator);
2928 /* Generate the copying loops. */
2929 gfc_trans_scalarizing_loops (&loop, &body);
2931 /* Wrap the whole thing up. */
2932 gfc_add_block_to_block (&block, &loop.pre);
2933 gfc_add_block_to_block (&block, &loop.post);
2935 for (n = 0; n < cm->as->rank; n++)
2936 mpz_clear (lss->shape[n]);
2937 gfc_free (lss->shape);
2939 gfc_cleanup_loop (&loop);
2941 return gfc_finish_block (&block);
2945 /* Assign a single component of a derived type constructor. */
2948 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2958 gfc_start_block (&block);
2962 gfc_init_se (&se, NULL);
2963 /* Pointer component. */
2966 /* Array pointer. */
2967 if (expr->expr_type == EXPR_NULL)
2968 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2971 rss = gfc_walk_expr (expr);
2972 se.direct_byref = 1;
2974 gfc_conv_expr_descriptor (&se, expr, rss);
2975 gfc_add_block_to_block (&block, &se.pre);
2976 gfc_add_block_to_block (&block, &se.post);
2981 /* Scalar pointers. */
2982 se.want_pointer = 1;
2983 gfc_conv_expr (&se, expr);
2984 gfc_add_block_to_block (&block, &se.pre);
2985 gfc_add_modify_expr (&block, dest,
2986 fold_convert (TREE_TYPE (dest), se.expr));
2987 gfc_add_block_to_block (&block, &se.post);
2990 else if (cm->dimension)
2992 if (cm->allocatable && expr->expr_type == EXPR_NULL)
2993 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2994 else if (cm->allocatable)
2998 gfc_init_se (&se, NULL);
3000 rss = gfc_walk_expr (expr);
3001 se.want_pointer = 0;
3002 gfc_conv_expr_descriptor (&se, expr, rss);
3003 gfc_add_block_to_block (&block, &se.pre);
3005 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3006 gfc_add_modify_expr (&block, dest, tmp);
3008 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3009 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3012 tmp = gfc_duplicate_allocatable (dest, se.expr,
3013 TREE_TYPE(cm->backend_decl),
3016 gfc_add_expr_to_block (&block, tmp);
3018 gfc_add_block_to_block (&block, &se.post);
3019 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3021 /* Shift the lbound and ubound of temporaries to being unity, rather
3022 than zero, based. Calculate the offset for all cases. */
3023 offset = gfc_conv_descriptor_offset (dest);
3024 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
3025 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3026 for (n = 0; n < expr->rank; n++)
3028 if (expr->expr_type != EXPR_VARIABLE
3029 && expr->expr_type != EXPR_CONSTANT)
3032 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3033 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3034 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3035 gfc_add_modify_expr (&block, tmp,
3036 fold_build2 (PLUS_EXPR,
3037 gfc_array_index_type,
3038 span, gfc_index_one_node));
3039 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3040 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
3042 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3043 gfc_conv_descriptor_lbound (dest,
3045 gfc_conv_descriptor_stride (dest,
3047 gfc_add_modify_expr (&block, tmp2, tmp);
3048 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3049 gfc_add_modify_expr (&block, offset, tmp);
3054 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3055 gfc_add_expr_to_block (&block, tmp);
3058 else if (expr->ts.type == BT_DERIVED)
3060 if (expr->expr_type != EXPR_STRUCTURE)
3062 gfc_init_se (&se, NULL);
3063 gfc_conv_expr (&se, expr);
3064 gfc_add_modify_expr (&block, dest,
3065 fold_convert (TREE_TYPE (dest), se.expr));
3069 /* Nested constructors. */
3070 tmp = gfc_trans_structure_assign (dest, expr);
3071 gfc_add_expr_to_block (&block, tmp);
3076 /* Scalar component. */
3077 gfc_init_se (&se, NULL);
3078 gfc_init_se (&lse, NULL);
3080 gfc_conv_expr (&se, expr);
3081 if (cm->ts.type == BT_CHARACTER)
3082 lse.string_length = cm->ts.cl->backend_decl;
3084 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3085 gfc_add_expr_to_block (&block, tmp);
3087 return gfc_finish_block (&block);
3090 /* Assign a derived type constructor to a variable. */
3093 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3101 gfc_start_block (&block);
3102 cm = expr->ts.derived->components;
3103 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3105 /* Skip absent members in default initializers. */
3109 field = cm->backend_decl;
3110 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
3111 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3112 gfc_add_expr_to_block (&block, tmp);
3114 return gfc_finish_block (&block);
3117 /* Build an expression for a constructor. If init is nonzero then
3118 this is part of a static variable initializer. */
3121 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3128 VEC(constructor_elt,gc) *v = NULL;
3130 gcc_assert (se->ss == NULL);
3131 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3132 type = gfc_typenode_for_spec (&expr->ts);
3136 /* Create a temporary variable and fill it in. */
3137 se->expr = gfc_create_var (type, expr->ts.derived->name);
3138 tmp = gfc_trans_structure_assign (se->expr, expr);
3139 gfc_add_expr_to_block (&se->pre, tmp);
3143 cm = expr->ts.derived->components;
3145 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3147 /* Skip absent members in default initializers and allocatable
3148 components. Although the latter have a default initializer
3149 of EXPR_NULL,... by default, the static nullify is not needed
3150 since this is done every time we come into scope. */
3151 if (!c->expr || cm->allocatable)
3154 val = gfc_conv_initializer (c->expr, &cm->ts,
3155 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3157 /* Append it to the constructor list. */
3158 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3160 se->expr = build_constructor (type, v);
3164 /* Translate a substring expression. */
3167 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3173 gcc_assert (ref->type == REF_SUBSTRING);
3175 se->expr = gfc_build_string_const(expr->value.character.length,
3176 expr->value.character.string);
3177 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3178 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3180 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3184 /* Entry point for expression translation. Evaluates a scalar quantity.
3185 EXPR is the expression to be translated, and SE is the state structure if
3186 called from within the scalarized. */
3189 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3191 if (se->ss && se->ss->expr == expr
3192 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3194 /* Substitute a scalar expression evaluated outside the scalarization
3196 se->expr = se->ss->data.scalar.expr;
3197 se->string_length = se->ss->string_length;
3198 gfc_advance_se_ss_chain (se);
3202 /* We need to convert the expressions for the iso_c_binding derived types.
3203 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3204 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3205 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3206 updated to be an integer with a kind equal to the size of a (void *). */
3207 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3208 && expr->ts.derived->attr.is_iso_c)
3210 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3211 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3213 /* Set expr_type to EXPR_NULL, which will result in
3214 null_pointer_node being used below. */
3215 expr->expr_type = EXPR_NULL;
3219 /* Update the type/kind of the expression to be what the new
3220 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3221 expr->ts.type = expr->ts.derived->ts.type;
3222 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3223 expr->ts.kind = expr->ts.derived->ts.kind;
3227 switch (expr->expr_type)
3230 gfc_conv_expr_op (se, expr);
3234 gfc_conv_function_expr (se, expr);
3238 gfc_conv_constant (se, expr);
3242 gfc_conv_variable (se, expr);
3246 se->expr = null_pointer_node;
3249 case EXPR_SUBSTRING:
3250 gfc_conv_substring_expr (se, expr);
3253 case EXPR_STRUCTURE:
3254 gfc_conv_structure (se, expr, 0);
3258 gfc_conv_array_constructor_expr (se, expr);
3267 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3268 of an assignment. */
3270 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3272 gfc_conv_expr (se, expr);
3273 /* All numeric lvalues should have empty post chains. If not we need to
3274 figure out a way of rewriting an lvalue so that it has no post chain. */
3275 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3278 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3279 numeric expressions. Used for scalar values where inserting cleanup code
3282 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3286 gcc_assert (expr->ts.type != BT_CHARACTER);
3287 gfc_conv_expr (se, expr);
3290 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3291 gfc_add_modify_expr (&se->pre, val, se->expr);
3293 gfc_add_block_to_block (&se->pre, &se->post);
3297 /* Helper to translate and expression and convert it to a particular type. */
3299 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3301 gfc_conv_expr_val (se, expr);
3302 se->expr = convert (type, se->expr);
3306 /* Converts an expression so that it can be passed by reference. Scalar
3310 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3314 if (se->ss && se->ss->expr == expr
3315 && se->ss->type == GFC_SS_REFERENCE)
3317 se->expr = se->ss->data.scalar.expr;
3318 se->string_length = se->ss->string_length;
3319 gfc_advance_se_ss_chain (se);
3323 if (expr->ts.type == BT_CHARACTER)
3325 gfc_conv_expr (se, expr);
3326 gfc_conv_string_parameter (se);
3330 if (expr->expr_type == EXPR_VARIABLE)
3332 se->want_pointer = 1;
3333 gfc_conv_expr (se, expr);
3336 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3337 gfc_add_modify_expr (&se->pre, var, se->expr);
3338 gfc_add_block_to_block (&se->pre, &se->post);
3344 if (expr->expr_type == EXPR_FUNCTION
3345 && expr->symtree->n.sym->attr.pointer
3346 && !expr->symtree->n.sym->attr.dimension)
3348 se->want_pointer = 1;
3349 gfc_conv_expr (se, expr);
3350 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3351 gfc_add_modify_expr (&se->pre, var, se->expr);
3357 gfc_conv_expr (se, expr);
3359 /* Create a temporary var to hold the value. */
3360 if (TREE_CONSTANT (se->expr))
3362 tree tmp = se->expr;
3363 STRIP_TYPE_NOPS (tmp);
3364 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3365 DECL_INITIAL (var) = tmp;
3366 TREE_STATIC (var) = 1;
3371 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3372 gfc_add_modify_expr (&se->pre, var, se->expr);
3374 gfc_add_block_to_block (&se->pre, &se->post);
3376 /* Take the address of that value. */
3377 se->expr = build_fold_addr_expr (var);
3382 gfc_trans_pointer_assign (gfc_code * code)
3384 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3388 /* Generate code for a pointer assignment. */
3391 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3401 gfc_start_block (&block);
3403 gfc_init_se (&lse, NULL);
3405 lss = gfc_walk_expr (expr1);
3406 rss = gfc_walk_expr (expr2);
3407 if (lss == gfc_ss_terminator)
3409 /* Scalar pointers. */
3410 lse.want_pointer = 1;
3411 gfc_conv_expr (&lse, expr1);
3412 gcc_assert (rss == gfc_ss_terminator);
3413 gfc_init_se (&rse, NULL);
3414 rse.want_pointer = 1;
3415 gfc_conv_expr (&rse, expr2);
3416 gfc_add_block_to_block (&block, &lse.pre);
3417 gfc_add_block_to_block (&block, &rse.pre);
3418 gfc_add_modify_expr (&block, lse.expr,
3419 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3420 gfc_add_block_to_block (&block, &rse.post);
3421 gfc_add_block_to_block (&block, &lse.post);
3425 /* Array pointer. */
3426 gfc_conv_expr_descriptor (&lse, expr1, lss);
3427 switch (expr2->expr_type)
3430 /* Just set the data pointer to null. */
3431 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3435 /* Assign directly to the pointer's descriptor. */
3436 lse.direct_byref = 1;
3437 gfc_conv_expr_descriptor (&lse, expr2, rss);
3441 /* Assign to a temporary descriptor and then copy that
3442 temporary to the pointer. */
3444 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3447 lse.direct_byref = 1;
3448 gfc_conv_expr_descriptor (&lse, expr2, rss);
3449 gfc_add_modify_expr (&lse.pre, desc, tmp);
3452 gfc_add_block_to_block (&block, &lse.pre);
3453 gfc_add_block_to_block (&block, &lse.post);
3455 return gfc_finish_block (&block);
3459 /* Makes sure se is suitable for passing as a function string parameter. */
3460 /* TODO: Need to check all callers fo this function. It may be abused. */
3463 gfc_conv_string_parameter (gfc_se * se)
3467 if (TREE_CODE (se->expr) == STRING_CST)
3469 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3473 type = TREE_TYPE (se->expr);
3474 if (TYPE_STRING_FLAG (type))
3476 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3477 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3480 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3481 gcc_assert (se->string_length
3482 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3486 /* Generate code for assignment of scalar variables. Includes character
3487 strings and derived types with allocatable components. */
3490 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3491 bool l_is_temp, bool r_is_var)
3497 gfc_init_block (&block);
3499 if (ts.type == BT_CHARACTER)
3501 gcc_assert (lse->string_length != NULL_TREE
3502 && rse->string_length != NULL_TREE);
3504 gfc_conv_string_parameter (lse);
3505 gfc_conv_string_parameter (rse);
3507 gfc_add_block_to_block (&block, &lse->pre);
3508 gfc_add_block_to_block (&block, &rse->pre);
3510 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3511 rse->string_length, rse->expr);
3513 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3517 /* Are the rhs and the lhs the same? */
3520 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3521 build_fold_addr_expr (lse->expr),
3522 build_fold_addr_expr (rse->expr));
3523 cond = gfc_evaluate_now (cond, &lse->pre);
3526 /* Deallocate the lhs allocated components as long as it is not
3527 the same as the rhs. This must be done following the assignment
3528 to prevent deallocating data that could be used in the rhs
3532 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
3533 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
3535 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3536 gfc_add_expr_to_block (&lse->post, tmp);
3539 gfc_add_block_to_block (&block, &rse->pre);
3540 gfc_add_block_to_block (&block, &lse->pre);
3542 gfc_add_modify_expr (&block, lse->expr,
3543 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3545 /* Do a deep copy if the rhs is a variable, if it is not the
3549 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3550 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3551 gfc_add_expr_to_block (&block, tmp);
3556 gfc_add_block_to_block (&block, &lse->pre);
3557 gfc_add_block_to_block (&block, &rse->pre);
3559 gfc_add_modify_expr (&block, lse->expr,
3560 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3563 gfc_add_block_to_block (&block, &lse->post);
3564 gfc_add_block_to_block (&block, &rse->post);
3566 return gfc_finish_block (&block);
3570 /* Try to translate array(:) = func (...), where func is a transformational
3571 array function, without using a temporary. Returns NULL is this isn't the
3575 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3580 bool seen_array_ref;
3582 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3583 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3586 /* Elemental functions don't need a temporary anyway. */
3587 if (expr2->value.function.esym != NULL
3588 && expr2->value.function.esym->attr.elemental)
3591 /* Fail if EXPR1 can't be expressed as a descriptor. */
3592 if (gfc_ref_needs_temporary_p (expr1->ref))
3595 /* Functions returning pointers need temporaries. */
3596 if (expr2->symtree->n.sym->attr.pointer
3597 || expr2->symtree->n.sym->attr.allocatable)
3600 /* Character array functions need temporaries unless the
3601 character lengths are the same. */
3602 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3604 if (expr1->ts.cl->length == NULL
3605 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3608 if (expr2->ts.cl->length == NULL
3609 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3612 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3613 expr2->ts.cl->length->value.integer) != 0)
3617 /* Check that no LHS component references appear during an array
3618 reference. This is needed because we do not have the means to
3619 span any arbitrary stride with an array descriptor. This check
3620 is not needed for the rhs because the function result has to be
3622 seen_array_ref = false;
3623 for (ref = expr1->ref; ref; ref = ref->next)
3625 if (ref->type == REF_ARRAY)
3626 seen_array_ref= true;
3627 else if (ref->type == REF_COMPONENT && seen_array_ref)
3631 /* Check for a dependency. */
3632 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3633 expr2->value.function.esym,
3634 expr2->value.function.actual))
3637 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3639 gcc_assert (expr2->value.function.isym
3640 || (gfc_return_by_reference (expr2->value.function.esym)
3641 && expr2->value.function.esym->result->attr.dimension));
3643 ss = gfc_walk_expr (expr1);
3644 gcc_assert (ss != gfc_ss_terminator);
3645 gfc_init_se (&se, NULL);
3646 gfc_start_block (&se.pre);
3647 se.want_pointer = 1;
3649 gfc_conv_array_parameter (&se, expr1, ss, 0);
3651 se.direct_byref = 1;
3652 se.ss = gfc_walk_expr (expr2);
3653 gcc_assert (se.ss != gfc_ss_terminator);
3654 gfc_conv_function_expr (&se, expr2);
3655 gfc_add_block_to_block (&se.pre, &se.post);
3657 return gfc_finish_block (&se.pre);
3660 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
3663 is_zero_initializer_p (gfc_expr * expr)
3665 if (expr->expr_type != EXPR_CONSTANT)
3668 /* We ignore constants with prescribed memory representations for now. */
3669 if (expr->representation.string)
3672 switch (expr->ts.type)
3675 return mpz_cmp_si (expr->value.integer, 0) == 0;
3678 return mpfr_zero_p (expr->value.real)
3679 && MPFR_SIGN (expr->value.real) >= 0;
3682 return expr->value.logical == 0;
3685 return mpfr_zero_p (expr->value.complex.r)
3686 && MPFR_SIGN (expr->value.complex.r) >= 0
3687 && mpfr_zero_p (expr->value.complex.i)
3688 && MPFR_SIGN (expr->value.complex.i) >= 0;
3696 /* Try to efficiently translate array(:) = 0. Return NULL if this
3700 gfc_trans_zero_assign (gfc_expr * expr)
3702 tree dest, len, type;
3706 sym = expr->symtree->n.sym;
3707 dest = gfc_get_symbol_decl (sym);
3709 type = TREE_TYPE (dest);
3710 if (POINTER_TYPE_P (type))
3711 type = TREE_TYPE (type);
3712 if (!GFC_ARRAY_TYPE_P (type))
3715 /* Determine the length of the array. */
3716 len = GFC_TYPE_ARRAY_SIZE (type);
3717 if (!len || TREE_CODE (len) != INTEGER_CST)
3720 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
3721 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3722 fold_convert (gfc_array_index_type, tmp));
3724 /* Convert arguments to the correct types. */
3725 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
3726 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3728 dest = fold_convert (pvoid_type_node, dest);
3729 len = fold_convert (size_type_node, len);
3731 /* Construct call to __builtin_memset. */
3732 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
3733 3, dest, integer_zero_node, len);
3734 return fold_convert (void_type_node, tmp);
3738 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
3739 that constructs the call to __builtin_memcpy. */
3742 gfc_build_memcpy_call (tree dst, tree src, tree len)
3746 /* Convert arguments to the correct types. */
3747 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
3748 dst = gfc_build_addr_expr (pvoid_type_node, dst);
3750 dst = fold_convert (pvoid_type_node, dst);
3752 if (!POINTER_TYPE_P (TREE_TYPE (src)))
3753 src = gfc_build_addr_expr (pvoid_type_node, src);
3755 src = fold_convert (pvoid_type_node, src);
3757 len = fold_convert (size_type_node, len);
3759 /* Construct call to __builtin_memcpy. */
3760 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
3761 return fold_convert (void_type_node, tmp);
3765 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
3766 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
3767 source/rhs, both are gfc_full_array_ref_p which have been checked for
3771 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
3773 tree dst, dlen, dtype;
3774 tree src, slen, stype;
3777 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3778 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
3780 dtype = TREE_TYPE (dst);
3781 if (POINTER_TYPE_P (dtype))
3782 dtype = TREE_TYPE (dtype);
3783 stype = TREE_TYPE (src);
3784 if (POINTER_TYPE_P (stype))
3785 stype = TREE_TYPE (stype);
3787 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
3790 /* Determine the lengths of the arrays. */
3791 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
3792 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
3794 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3795 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
3796 fold_convert (gfc_array_index_type, tmp));
3798 slen = GFC_TYPE_ARRAY_SIZE (stype);
3799 if (!slen || TREE_CODE (slen) != INTEGER_CST)
3801 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
3802 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
3803 fold_convert (gfc_array_index_type, tmp));
3805 /* Sanity check that they are the same. This should always be
3806 the case, as we should already have checked for conformance. */
3807 if (!tree_int_cst_equal (slen, dlen))
3810 return gfc_build_memcpy_call (dst, src, dlen);
3814 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
3815 this can't be done. EXPR1 is the destination/lhs for which
3816 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
3819 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
3821 unsigned HOST_WIDE_INT nelem;
3827 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
3831 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
3832 dtype = TREE_TYPE (dst);
3833 if (POINTER_TYPE_P (dtype))
3834 dtype = TREE_TYPE (dtype);
3835 if (!GFC_ARRAY_TYPE_P (dtype))
3838 /* Determine the lengths of the array. */
3839 len = GFC_TYPE_ARRAY_SIZE (dtype);
3840 if (!len || TREE_CODE (len) != INTEGER_CST)
3843 /* Confirm that the constructor is the same size. */
3844 if (compare_tree_int (len, nelem) != 0)
3847 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
3848 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
3849 fold_convert (gfc_array_index_type, tmp));
3851 stype = gfc_typenode_for_spec (&expr2->ts);
3852 src = gfc_build_constant_array_constructor (expr2, stype);
3854 stype = TREE_TYPE (src);
3855 if (POINTER_TYPE_P (stype))
3856 stype = TREE_TYPE (stype);
3858 return gfc_build_memcpy_call (dst, src, len);
3862 /* Subroutine of gfc_trans_assignment that actually scalarizes the
3863 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
3866 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3871 gfc_ss *lss_section;
3879 /* Assignment of the form lhs = rhs. */
3880 gfc_start_block (&block);
3882 gfc_init_se (&lse, NULL);
3883 gfc_init_se (&rse, NULL);
3886 lss = gfc_walk_expr (expr1);
3888 if (lss != gfc_ss_terminator)
3890 /* The assignment needs scalarization. */
3893 /* Find a non-scalar SS from the lhs. */
3894 while (lss_section != gfc_ss_terminator
3895 && lss_section->type != GFC_SS_SECTION)
3896 lss_section = lss_section->next;
3898 gcc_assert (lss_section != gfc_ss_terminator);
3900 /* Initialize the scalarizer. */
3901 gfc_init_loopinfo (&loop);
3904 rss = gfc_walk_expr (expr2);
3905 if (rss == gfc_ss_terminator)
3907 /* The rhs is scalar. Add a ss for the expression. */
3908 rss = gfc_get_ss ();
3909 rss->next = gfc_ss_terminator;
3910 rss->type = GFC_SS_SCALAR;
3913 /* Associate the SS with the loop. */
3914 gfc_add_ss_to_loop (&loop, lss);
3915 gfc_add_ss_to_loop (&loop, rss);
3917 /* Calculate the bounds of the scalarization. */
3918 gfc_conv_ss_startstride (&loop);
3919 /* Resolve any data dependencies in the statement. */
3920 gfc_conv_resolve_dependencies (&loop, lss, rss);
3921 /* Setup the scalarizing loops. */
3922 gfc_conv_loop_setup (&loop);
3924 /* Setup the gfc_se structures. */
3925 gfc_copy_loopinfo_to_se (&lse, &loop);
3926 gfc_copy_loopinfo_to_se (&rse, &loop);
3929 gfc_mark_ss_chain_used (rss, 1);
3930 if (loop.temp_ss == NULL)
3933 gfc_mark_ss_chain_used (lss, 1);
3937 lse.ss = loop.temp_ss;
3938 gfc_mark_ss_chain_used (lss, 3);
3939 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3942 /* Start the scalarized loop body. */
3943 gfc_start_scalarized_body (&loop, &body);
3946 gfc_init_block (&body);
3948 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3950 /* Translate the expression. */
3951 gfc_conv_expr (&rse, expr2);
3955 gfc_conv_tmp_array_ref (&lse);
3956 gfc_advance_se_ss_chain (&lse);
3959 gfc_conv_expr (&lse, expr1);
3961 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3962 l_is_temp || init_flag,
3963 expr2->expr_type == EXPR_VARIABLE);
3964 gfc_add_expr_to_block (&body, tmp);
3966 if (lss == gfc_ss_terminator)
3968 /* Use the scalar assignment as is. */
3969 gfc_add_block_to_block (&block, &body);
3973 gcc_assert (lse.ss == gfc_ss_terminator
3974 && rse.ss == gfc_ss_terminator);
3978 gfc_trans_scalarized_loop_boundary (&loop, &body);
3980 /* We need to copy the temporary to the actual lhs. */
3981 gfc_init_se (&lse, NULL);
3982 gfc_init_se (&rse, NULL);
3983 gfc_copy_loopinfo_to_se (&lse, &loop);
3984 gfc_copy_loopinfo_to_se (&rse, &loop);
3986 rse.ss = loop.temp_ss;
3989 gfc_conv_tmp_array_ref (&rse);
3990 gfc_advance_se_ss_chain (&rse);
3991 gfc_conv_expr (&lse, expr1);
3993 gcc_assert (lse.ss == gfc_ss_terminator
3994 && rse.ss == gfc_ss_terminator);
3996 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3998 gfc_add_expr_to_block (&body, tmp);
4001 /* Generate the copying loops. */
4002 gfc_trans_scalarizing_loops (&loop, &body);
4004 /* Wrap the whole thing up. */
4005 gfc_add_block_to_block (&block, &loop.pre);
4006 gfc_add_block_to_block (&block, &loop.post);
4008 gfc_cleanup_loop (&loop);
4011 return gfc_finish_block (&block);
4015 /* Check whether EXPR, which is an EXPR_VARIABLE, is a copyable array. */
4018 copyable_array_p (gfc_expr * expr)
4020 /* First check it's an array. */
4021 if (expr->rank < 1 || !expr->ref)
4024 /* Next check that it's of a simple enough type. */
4025 switch (expr->ts.type)
4037 return !expr->ts.derived->attr.alloc_comp;
4046 /* Translate an assignment. */
4049 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4053 /* Special case a single function returning an array. */
4054 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4056 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4061 /* Special case assigning an array to zero. */
4062 if (expr1->expr_type == EXPR_VARIABLE
4065 && expr1->ref->next == NULL
4066 && gfc_full_array_ref_p (expr1->ref)
4067 && is_zero_initializer_p (expr2))
4069 tmp = gfc_trans_zero_assign (expr1);
4074 /* Special case copying one array to another. */
4075 if (expr1->expr_type == EXPR_VARIABLE
4076 && copyable_array_p (expr1)
4077 && gfc_full_array_ref_p (expr1->ref)
4078 && expr2->expr_type == EXPR_VARIABLE
4079 && copyable_array_p (expr2)
4080 && gfc_full_array_ref_p (expr2->ref)
4081 && gfc_compare_types (&expr1->ts, &expr2->ts)
4082 && !gfc_check_dependency (expr1, expr2, 0))
4084 tmp = gfc_trans_array_copy (expr1, expr2);
4089 /* Special case initializing an array from a constant array constructor. */
4090 if (expr1->expr_type == EXPR_VARIABLE
4091 && copyable_array_p (expr1)
4092 && gfc_full_array_ref_p (expr1->ref)
4093 && expr2->expr_type == EXPR_ARRAY
4094 && gfc_compare_types (&expr1->ts, &expr2->ts))
4096 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4101 /* Fallback to the scalarizer to generate explicit loops. */
4102 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4106 gfc_trans_init_assign (gfc_code * code)
4108 return gfc_trans_assignment (code->expr, code->expr2, true);
4112 gfc_trans_assign (gfc_code * code)
4114 return gfc_trans_assignment (code->expr, code->expr2, false);