1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
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 void 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 gfc_add_block_to_block (pblock, &se.pre);
232 tmp = cl->backend_decl;
233 gfc_add_modify_expr (pblock, tmp, se.expr);
238 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
239 const char *name, locus *where)
249 type = gfc_get_character_type (kind, ref->u.ss.length);
250 type = build_pointer_type (type);
253 gfc_init_se (&start, se);
254 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
255 gfc_add_block_to_block (&se->pre, &start.pre);
257 if (integer_onep (start.expr))
258 gfc_conv_string_parameter (se);
261 /* Change the start of the string. */
262 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
265 tmp = build_fold_indirect_ref (se->expr);
266 tmp = gfc_build_array_ref (tmp, start.expr);
267 se->expr = gfc_build_addr_expr (type, tmp);
270 /* Length = end + 1 - start. */
271 gfc_init_se (&end, se);
272 if (ref->u.ss.end == NULL)
273 end.expr = se->string_length;
276 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
277 gfc_add_block_to_block (&se->pre, &end.pre);
279 if (flag_bounds_check)
281 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
282 start.expr, end.expr);
284 /* Check lower bound. */
285 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
286 build_int_cst (gfc_charlen_type_node, 1));
287 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
290 asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
291 "is less than one", name);
293 asprintf (&msg, "Substring out of bounds: lower bound "
295 gfc_trans_runtime_check (fault, msg, &se->pre, where);
298 /* Check upper bound. */
299 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
301 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
304 asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
305 "exceeds string length", name);
307 asprintf (&msg, "Substring out of bounds: upper bound "
308 "exceeds string length");
309 gfc_trans_runtime_check (fault, msg, &se->pre, where);
313 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
314 build_int_cst (gfc_charlen_type_node, 1),
316 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
317 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
318 build_int_cst (gfc_charlen_type_node, 0));
319 se->string_length = tmp;
323 /* Convert a derived type component reference. */
326 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
333 c = ref->u.c.component;
335 gcc_assert (c->backend_decl);
337 field = c->backend_decl;
338 gcc_assert (TREE_CODE (field) == FIELD_DECL);
340 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
344 if (c->ts.type == BT_CHARACTER)
346 tmp = c->ts.cl->backend_decl;
347 /* Components must always be constant length. */
348 gcc_assert (tmp && INTEGER_CST_P (tmp));
349 se->string_length = tmp;
352 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
353 se->expr = build_fold_indirect_ref (se->expr);
357 /* Return the contents of a variable. Also handles reference/pointer
358 variables (all Fortran pointer references are implicit). */
361 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
368 bool alternate_entry;
371 sym = expr->symtree->n.sym;
374 /* Check that something hasn't gone horribly wrong. */
375 gcc_assert (se->ss != gfc_ss_terminator);
376 gcc_assert (se->ss->expr == expr);
378 /* A scalarized term. We already know the descriptor. */
379 se->expr = se->ss->data.info.descriptor;
380 se->string_length = se->ss->string_length;
381 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
382 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
387 tree se_expr = NULL_TREE;
389 se->expr = gfc_get_symbol_decl (sym);
391 /* Deal with references to a parent results or entries by storing
392 the current_function_decl and moving to the parent_decl. */
393 return_value = sym->attr.function && sym->result == sym;
394 alternate_entry = sym->attr.function && sym->attr.entry
395 && sym->result == sym;
396 entry_master = sym->attr.result
397 && sym->ns->proc_name->attr.entry_master
398 && !gfc_return_by_reference (sym->ns->proc_name);
399 parent_decl = DECL_CONTEXT (current_function_decl);
401 if ((se->expr == parent_decl && return_value)
402 || (sym->ns && sym->ns->proc_name
404 && sym->ns->proc_name->backend_decl == parent_decl
405 && (alternate_entry || entry_master)))
410 /* Special case for assigning the return value of a function.
411 Self recursive functions must have an explicit return value. */
412 if (return_value && (se->expr == current_function_decl || parent_flag))
413 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
415 /* Similarly for alternate entry points. */
416 else if (alternate_entry
417 && (sym->ns->proc_name->backend_decl == current_function_decl
420 gfc_entry_list *el = NULL;
422 for (el = sym->ns->entries; el; el = el->next)
425 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
430 else if (entry_master
431 && (sym->ns->proc_name->backend_decl == current_function_decl
433 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
438 /* Procedure actual arguments. */
439 else if (sym->attr.flavor == FL_PROCEDURE
440 && se->expr != current_function_decl)
442 gcc_assert (se->want_pointer);
443 if (!sym->attr.dummy)
445 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
446 se->expr = build_fold_addr_expr (se->expr);
452 /* Dereference the expression, where needed. Since characters
453 are entirely different from other types, they are treated
455 if (sym->ts.type == BT_CHARACTER)
457 /* Dereference character pointer dummy arguments
459 if ((sym->attr.pointer || sym->attr.allocatable)
461 || sym->attr.function
462 || sym->attr.result))
463 se->expr = build_fold_indirect_ref (se->expr);
465 /* A character with VALUE attribute needs an address
468 se->expr = build_fold_addr_expr (se->expr);
471 else if (!sym->attr.value)
473 /* Dereference non-character scalar dummy arguments. */
474 if (sym->attr.dummy && !sym->attr.dimension)
475 se->expr = build_fold_indirect_ref (se->expr);
477 /* Dereference scalar hidden result. */
478 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
479 && (sym->attr.function || sym->attr.result)
480 && !sym->attr.dimension && !sym->attr.pointer)
481 se->expr = build_fold_indirect_ref (se->expr);
483 /* Dereference non-character pointer variables.
484 These must be dummies, results, or scalars. */
485 if ((sym->attr.pointer || sym->attr.allocatable)
487 || sym->attr.function
489 || !sym->attr.dimension))
490 se->expr = build_fold_indirect_ref (se->expr);
496 /* For character variables, also get the length. */
497 if (sym->ts.type == BT_CHARACTER)
499 /* If the character length of an entry isn't set, get the length from
500 the master function instead. */
501 if (sym->attr.entry && !sym->ts.cl->backend_decl)
502 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
504 se->string_length = sym->ts.cl->backend_decl;
505 gcc_assert (se->string_length);
513 /* Return the descriptor if that's what we want and this is an array
514 section reference. */
515 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
517 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
518 /* Return the descriptor for array pointers and allocations. */
520 && ref->next == NULL && (se->descriptor_only))
523 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
524 /* Return a pointer to an element. */
528 gfc_conv_component_ref (se, ref);
532 gfc_conv_substring (se, ref, expr->ts.kind,
533 expr->symtree->name, &expr->where);
542 /* Pointer assignment, allocation or pass by reference. Arrays are handled
544 if (se->want_pointer)
546 if (expr->ts.type == BT_CHARACTER)
547 gfc_conv_string_parameter (se);
549 se->expr = build_fold_addr_expr (se->expr);
554 /* Unary ops are easy... Or they would be if ! was a valid op. */
557 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
562 gcc_assert (expr->ts.type != BT_CHARACTER);
563 /* Initialize the operand. */
564 gfc_init_se (&operand, se);
565 gfc_conv_expr_val (&operand, expr->value.op.op1);
566 gfc_add_block_to_block (&se->pre, &operand.pre);
568 type = gfc_typenode_for_spec (&expr->ts);
570 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
571 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
572 All other unary operators have an equivalent GIMPLE unary operator. */
573 if (code == TRUTH_NOT_EXPR)
574 se->expr = build2 (EQ_EXPR, type, operand.expr,
575 build_int_cst (type, 0));
577 se->expr = build1 (code, type, operand.expr);
581 /* Expand power operator to optimal multiplications when a value is raised
582 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
583 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
584 Programming", 3rd Edition, 1998. */
586 /* This code is mostly duplicated from expand_powi in the backend.
587 We establish the "optimal power tree" lookup table with the defined size.
588 The items in the table are the exponents used to calculate the index
589 exponents. Any integer n less than the value can get an "addition chain",
590 with the first node being one. */
591 #define POWI_TABLE_SIZE 256
593 /* The table is from builtins.c. */
594 static const unsigned char powi_table[POWI_TABLE_SIZE] =
596 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
597 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
598 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
599 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
600 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
601 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
602 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
603 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
604 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
605 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
606 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
607 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
608 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
609 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
610 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
611 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
612 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
613 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
614 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
615 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
616 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
617 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
618 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
619 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
620 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
621 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
622 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
623 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
624 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
625 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
626 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
627 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
630 /* If n is larger than lookup table's max index, we use the "window
632 #define POWI_WINDOW_SIZE 3
634 /* Recursive function to expand the power operator. The temporary
635 values are put in tmpvar. The function returns tmpvar[1] ** n. */
637 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
644 if (n < POWI_TABLE_SIZE)
649 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
650 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
654 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
655 op0 = gfc_conv_powi (se, n - digit, tmpvar);
656 op1 = gfc_conv_powi (se, digit, tmpvar);
660 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
664 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
665 tmp = gfc_evaluate_now (tmp, &se->pre);
667 if (n < POWI_TABLE_SIZE)
674 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
675 return 1. Else return 0 and a call to runtime library functions
676 will have to be built. */
678 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
683 tree vartmp[POWI_TABLE_SIZE];
687 type = TREE_TYPE (lhs);
688 n = abs (TREE_INT_CST_LOW (rhs));
689 sgn = tree_int_cst_sgn (rhs);
691 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
692 && (n > 2 || n < -1))
698 se->expr = gfc_build_const (type, integer_one_node);
701 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
702 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
704 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
705 build_int_cst (TREE_TYPE (lhs), -1));
706 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
707 build_int_cst (TREE_TYPE (lhs), 1));
710 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
713 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
714 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
715 build_int_cst (type, 0));
719 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
720 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
721 build_int_cst (type, 0));
722 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
726 memset (vartmp, 0, sizeof (vartmp));
730 tmp = gfc_build_const (type, integer_one_node);
731 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
734 se->expr = gfc_conv_powi (se, n, vartmp);
740 /* Power op (**). Constant integer exponent has special handling. */
743 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
745 tree gfc_int4_type_node;
753 gfc_init_se (&lse, se);
754 gfc_conv_expr_val (&lse, expr->value.op.op1);
755 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
756 gfc_add_block_to_block (&se->pre, &lse.pre);
758 gfc_init_se (&rse, se);
759 gfc_conv_expr_val (&rse, expr->value.op.op2);
760 gfc_add_block_to_block (&se->pre, &rse.pre);
762 if (expr->value.op.op2->ts.type == BT_INTEGER
763 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
764 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
767 gfc_int4_type_node = gfc_get_int_type (4);
769 kind = expr->value.op.op1->ts.kind;
770 switch (expr->value.op.op2->ts.type)
773 ikind = expr->value.op.op2->ts.kind;
778 rse.expr = convert (gfc_int4_type_node, rse.expr);
800 if (expr->value.op.op1->ts.type == BT_INTEGER)
801 lse.expr = convert (gfc_int4_type_node, lse.expr);
826 switch (expr->value.op.op1->ts.type)
829 if (kind == 3) /* Case 16 was not handled properly above. */
831 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
835 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
839 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
851 fndecl = built_in_decls[BUILT_IN_POWF];
854 fndecl = built_in_decls[BUILT_IN_POW];
858 fndecl = built_in_decls[BUILT_IN_POWL];
869 fndecl = gfor_fndecl_math_cpowf;
872 fndecl = gfor_fndecl_math_cpow;
875 fndecl = gfor_fndecl_math_cpowl10;
878 fndecl = gfor_fndecl_math_cpowl16;
890 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
891 tmp = gfc_chainon_list (tmp, rse.expr);
892 se->expr = build_function_call_expr (fndecl, tmp);
896 /* Generate code to allocate a string temporary. */
899 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
905 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
907 if (gfc_can_put_var_on_stack (len))
909 /* Create a temporary variable to hold the result. */
910 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
911 build_int_cst (gfc_charlen_type_node, 1));
912 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
913 tmp = build_array_type (gfc_character1_type_node, tmp);
914 var = gfc_create_var (tmp, "str");
915 var = gfc_build_addr_expr (type, var);
919 /* Allocate a temporary to hold the result. */
920 var = gfc_create_var (type, "pstr");
921 args = gfc_chainon_list (NULL_TREE, len);
922 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
923 tmp = convert (type, tmp);
924 gfc_add_modify_expr (&se->pre, var, tmp);
926 /* Free the temporary afterwards. */
927 tmp = convert (pvoid_type_node, var);
928 args = gfc_chainon_list (NULL_TREE, tmp);
929 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
930 gfc_add_expr_to_block (&se->post, tmp);
937 /* Handle a string concatenation operation. A temporary will be allocated to
941 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
951 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
952 && expr->value.op.op2->ts.type == BT_CHARACTER);
954 gfc_init_se (&lse, se);
955 gfc_conv_expr (&lse, expr->value.op.op1);
956 gfc_conv_string_parameter (&lse);
957 gfc_init_se (&rse, se);
958 gfc_conv_expr (&rse, expr->value.op.op2);
959 gfc_conv_string_parameter (&rse);
961 gfc_add_block_to_block (&se->pre, &lse.pre);
962 gfc_add_block_to_block (&se->pre, &rse.pre);
964 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
965 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
966 if (len == NULL_TREE)
968 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
969 lse.string_length, rse.string_length);
972 type = build_pointer_type (type);
974 var = gfc_conv_string_tmp (se, type, len);
976 /* Do the actual concatenation. */
978 args = gfc_chainon_list (args, len);
979 args = gfc_chainon_list (args, var);
980 args = gfc_chainon_list (args, lse.string_length);
981 args = gfc_chainon_list (args, lse.expr);
982 args = gfc_chainon_list (args, rse.string_length);
983 args = gfc_chainon_list (args, rse.expr);
984 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
985 gfc_add_expr_to_block (&se->pre, tmp);
987 /* Add the cleanup for the operands. */
988 gfc_add_block_to_block (&se->pre, &rse.post);
989 gfc_add_block_to_block (&se->pre, &lse.post);
992 se->string_length = len;
995 /* Translates an op expression. Common (binary) cases are handled by this
996 function, others are passed on. Recursion is used in either case.
997 We use the fact that (op1.ts == op2.ts) (except for the power
999 Operators need no special handling for scalarized expressions as long as
1000 they call gfc_conv_simple_val to get their operands.
1001 Character strings get special handling. */
1004 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1006 enum tree_code code;
1016 switch (expr->value.op.operator)
1018 case INTRINSIC_UPLUS:
1019 case INTRINSIC_PARENTHESES:
1020 gfc_conv_expr (se, expr->value.op.op1);
1023 case INTRINSIC_UMINUS:
1024 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1028 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1031 case INTRINSIC_PLUS:
1035 case INTRINSIC_MINUS:
1039 case INTRINSIC_TIMES:
1043 case INTRINSIC_DIVIDE:
1044 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1045 an integer, we must round towards zero, so we use a
1047 if (expr->ts.type == BT_INTEGER)
1048 code = TRUNC_DIV_EXPR;
1053 case INTRINSIC_POWER:
1054 gfc_conv_power_op (se, expr);
1057 case INTRINSIC_CONCAT:
1058 gfc_conv_concat_op (se, expr);
1062 code = TRUTH_ANDIF_EXPR;
1067 code = TRUTH_ORIF_EXPR;
1071 /* EQV and NEQV only work on logicals, but since we represent them
1072 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1081 case INTRINSIC_NEQV:
1111 case INTRINSIC_USER:
1112 case INTRINSIC_ASSIGN:
1113 /* These should be converted into function calls by the frontend. */
1117 fatal_error ("Unknown intrinsic op");
1121 /* The only exception to this is **, which is handled separately anyway. */
1122 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1124 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1128 gfc_init_se (&lse, se);
1129 gfc_conv_expr (&lse, expr->value.op.op1);
1130 gfc_add_block_to_block (&se->pre, &lse.pre);
1133 gfc_init_se (&rse, se);
1134 gfc_conv_expr (&rse, expr->value.op.op2);
1135 gfc_add_block_to_block (&se->pre, &rse.pre);
1139 gfc_conv_string_parameter (&lse);
1140 gfc_conv_string_parameter (&rse);
1142 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1143 rse.string_length, rse.expr);
1144 rse.expr = integer_zero_node;
1145 gfc_add_block_to_block (&lse.post, &rse.post);
1148 type = gfc_typenode_for_spec (&expr->ts);
1152 /* The result of logical ops is always boolean_type_node. */
1153 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1154 se->expr = convert (type, tmp);
1157 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1159 /* Add the post blocks. */
1160 gfc_add_block_to_block (&se->post, &rse.post);
1161 gfc_add_block_to_block (&se->post, &lse.post);
1164 /* If a string's length is one, we convert it to a single character. */
1167 gfc_to_single_character (tree len, tree str)
1169 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1171 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1172 && TREE_INT_CST_HIGH (len) == 0)
1174 str = fold_convert (pchar_type_node, str);
1175 return build_fold_indirect_ref (str);
1181 /* Compare two strings. If they are all single characters, the result is the
1182 subtraction of them. Otherwise, we build a library call. */
1185 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1192 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1193 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1195 type = gfc_get_int_type (gfc_default_integer_kind);
1197 sc1 = gfc_to_single_character (len1, str1);
1198 sc2 = gfc_to_single_character (len2, str2);
1200 /* Deal with single character specially. */
1201 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1203 sc1 = fold_convert (type, sc1);
1204 sc2 = fold_convert (type, sc2);
1205 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1210 tmp = gfc_chainon_list (tmp, len1);
1211 tmp = gfc_chainon_list (tmp, str1);
1212 tmp = gfc_chainon_list (tmp, len2);
1213 tmp = gfc_chainon_list (tmp, str2);
1215 /* Build a call for the comparison. */
1216 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1223 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1227 if (sym->attr.dummy)
1229 tmp = gfc_get_symbol_decl (sym);
1230 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1231 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1235 if (!sym->backend_decl)
1236 sym->backend_decl = gfc_get_extern_function_decl (sym);
1238 tmp = sym->backend_decl;
1239 if (sym->attr.cray_pointee)
1240 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1241 gfc_get_symbol_decl (sym->cp_pointer));
1242 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1244 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1245 tmp = build_fold_addr_expr (tmp);
1252 /* Initialize MAPPING. */
1255 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1257 mapping->syms = NULL;
1258 mapping->charlens = NULL;
1262 /* Free all memory held by MAPPING (but not MAPPING itself). */
1265 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1267 gfc_interface_sym_mapping *sym;
1268 gfc_interface_sym_mapping *nextsym;
1270 gfc_charlen *nextcl;
1272 for (sym = mapping->syms; sym; sym = nextsym)
1274 nextsym = sym->next;
1275 gfc_free_symbol (sym->new->n.sym);
1276 gfc_free (sym->new);
1279 for (cl = mapping->charlens; cl; cl = nextcl)
1282 gfc_free_expr (cl->length);
1288 /* Return a copy of gfc_charlen CL. Add the returned structure to
1289 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1291 static gfc_charlen *
1292 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1297 new = gfc_get_charlen ();
1298 new->next = mapping->charlens;
1299 new->length = gfc_copy_expr (cl->length);
1301 mapping->charlens = new;
1306 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1307 array variable that can be used as the actual argument for dummy
1308 argument SYM. Add any initialization code to BLOCK. PACKED is as
1309 for gfc_get_nodesc_array_type and DATA points to the first element
1310 in the passed array. */
1313 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1314 int packed, tree data)
1319 type = gfc_typenode_for_spec (&sym->ts);
1320 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1322 var = gfc_create_var (type, "ifm");
1323 gfc_add_modify_expr (block, var, fold_convert (type, data));
1329 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1330 and offset of descriptorless array type TYPE given that it has the same
1331 size as DESC. Add any set-up code to BLOCK. */
1334 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1341 offset = gfc_index_zero_node;
1342 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1344 dim = gfc_rank_cst[n];
1345 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1346 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1348 GFC_TYPE_ARRAY_LBOUND (type, n)
1349 = gfc_conv_descriptor_lbound (desc, dim);
1350 GFC_TYPE_ARRAY_UBOUND (type, n)
1351 = gfc_conv_descriptor_ubound (desc, dim);
1353 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1355 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1356 gfc_conv_descriptor_ubound (desc, dim),
1357 gfc_conv_descriptor_lbound (desc, dim));
1358 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1359 GFC_TYPE_ARRAY_LBOUND (type, n),
1361 tmp = gfc_evaluate_now (tmp, block);
1362 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1364 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1365 GFC_TYPE_ARRAY_LBOUND (type, n),
1366 GFC_TYPE_ARRAY_STRIDE (type, n));
1367 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1369 offset = gfc_evaluate_now (offset, block);
1370 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1374 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1375 in SE. The caller may still use se->expr and se->string_length after
1376 calling this function. */
1379 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1380 gfc_symbol * sym, gfc_se * se)
1382 gfc_interface_sym_mapping *sm;
1386 gfc_symbol *new_sym;
1388 gfc_symtree *new_symtree;
1390 /* Create a new symbol to represent the actual argument. */
1391 new_sym = gfc_new_symbol (sym->name, NULL);
1392 new_sym->ts = sym->ts;
1393 new_sym->attr.referenced = 1;
1394 new_sym->attr.dimension = sym->attr.dimension;
1395 new_sym->attr.pointer = sym->attr.pointer;
1396 new_sym->attr.allocatable = sym->attr.allocatable;
1397 new_sym->attr.flavor = sym->attr.flavor;
1399 /* Create a fake symtree for it. */
1401 new_symtree = gfc_new_symtree (&root, sym->name);
1402 new_symtree->n.sym = new_sym;
1403 gcc_assert (new_symtree == root);
1405 /* Create a dummy->actual mapping. */
1406 sm = gfc_getmem (sizeof (*sm));
1407 sm->next = mapping->syms;
1409 sm->new = new_symtree;
1412 /* Stabilize the argument's value. */
1413 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1415 if (sym->ts.type == BT_CHARACTER)
1417 /* Create a copy of the dummy argument's length. */
1418 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1420 /* If the length is specified as "*", record the length that
1421 the caller is passing. We should use the callee's length
1422 in all other cases. */
1423 if (!new_sym->ts.cl->length)
1425 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1426 new_sym->ts.cl->backend_decl = se->string_length;
1430 /* Use the passed value as-is if the argument is a function. */
1431 if (sym->attr.flavor == FL_PROCEDURE)
1434 /* If the argument is either a string or a pointer to a string,
1435 convert it to a boundless character type. */
1436 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1438 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1439 tmp = build_pointer_type (tmp);
1440 if (sym->attr.pointer)
1441 value = build_fold_indirect_ref (se->expr);
1444 value = fold_convert (tmp, value);
1447 /* If the argument is a scalar, a pointer to an array or an allocatable,
1449 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1450 value = build_fold_indirect_ref (se->expr);
1452 /* For character(*), use the actual argument's descriptor. */
1453 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1454 value = build_fold_indirect_ref (se->expr);
1456 /* If the argument is an array descriptor, use it to determine
1457 information about the actual argument's shape. */
1458 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1459 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1461 /* Get the actual argument's descriptor. */
1462 desc = build_fold_indirect_ref (se->expr);
1464 /* Create the replacement variable. */
1465 tmp = gfc_conv_descriptor_data_get (desc);
1466 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1468 /* Use DESC to work out the upper bounds, strides and offset. */
1469 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1472 /* Otherwise we have a packed array. */
1473 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1475 new_sym->backend_decl = value;
1479 /* Called once all dummy argument mappings have been added to MAPPING,
1480 but before the mapping is used to evaluate expressions. Pre-evaluate
1481 the length of each argument, adding any initialization code to PRE and
1482 any finalization code to POST. */
1485 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1486 stmtblock_t * pre, stmtblock_t * post)
1488 gfc_interface_sym_mapping *sym;
1492 for (sym = mapping->syms; sym; sym = sym->next)
1493 if (sym->new->n.sym->ts.type == BT_CHARACTER
1494 && !sym->new->n.sym->ts.cl->backend_decl)
1496 expr = sym->new->n.sym->ts.cl->length;
1497 gfc_apply_interface_mapping_to_expr (mapping, expr);
1498 gfc_init_se (&se, NULL);
1499 gfc_conv_expr (&se, expr);
1501 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1502 gfc_add_block_to_block (pre, &se.pre);
1503 gfc_add_block_to_block (post, &se.post);
1505 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1510 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1514 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1515 gfc_constructor * c)
1517 for (; c; c = c->next)
1519 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1522 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1523 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1524 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1530 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1534 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1539 for (; ref; ref = ref->next)
1543 for (n = 0; n < ref->u.ar.dimen; n++)
1545 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1546 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1547 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1549 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1556 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1557 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1563 /* EXPR is a copy of an expression that appeared in the interface
1564 associated with MAPPING. Walk it recursively looking for references to
1565 dummy arguments that MAPPING maps to actual arguments. Replace each such
1566 reference with a reference to the associated actual argument. */
1569 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1572 gfc_interface_sym_mapping *sym;
1573 gfc_actual_arglist *actual;
1578 /* Copying an expression does not copy its length, so do that here. */
1579 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1581 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1582 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1585 /* Apply the mapping to any references. */
1586 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1588 /* ...and to the expression's symbol, if it has one. */
1590 for (sym = mapping->syms; sym; sym = sym->next)
1591 if (sym->old == expr->symtree->n.sym)
1592 expr->symtree = sym->new;
1594 /* ...and to subexpressions in expr->value. */
1595 switch (expr->expr_type)
1600 case EXPR_SUBSTRING:
1604 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1605 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1609 for (sym = mapping->syms; sym; sym = sym->next)
1610 if (sym->old == expr->value.function.esym)
1611 expr->value.function.esym = sym->new->n.sym;
1613 for (actual = expr->value.function.actual; actual; actual = actual->next)
1614 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1618 case EXPR_STRUCTURE:
1619 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1625 /* Evaluate interface expression EXPR using MAPPING. Store the result
1629 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1630 gfc_se * se, gfc_expr * expr)
1632 expr = gfc_copy_expr (expr);
1633 gfc_apply_interface_mapping_to_expr (mapping, expr);
1634 gfc_conv_expr (se, expr);
1635 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1636 gfc_free_expr (expr);
1639 /* Returns a reference to a temporary array into which a component of
1640 an actual argument derived type array is copied and then returned
1641 after the function call.
1642 TODO Get rid of this kludge, when array descriptors are capable of
1643 handling aliased arrays. */
1646 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1647 int g77, sym_intent intent)
1663 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1665 gfc_init_se (&lse, NULL);
1666 gfc_init_se (&rse, NULL);
1668 /* Walk the argument expression. */
1669 rss = gfc_walk_expr (expr);
1671 gcc_assert (rss != gfc_ss_terminator);
1673 /* Initialize the scalarizer. */
1674 gfc_init_loopinfo (&loop);
1675 gfc_add_ss_to_loop (&loop, rss);
1677 /* Calculate the bounds of the scalarization. */
1678 gfc_conv_ss_startstride (&loop);
1680 /* Build an ss for the temporary. */
1681 base_type = gfc_typenode_for_spec (&expr->ts);
1682 if (GFC_ARRAY_TYPE_P (base_type)
1683 || GFC_DESCRIPTOR_TYPE_P (base_type))
1684 base_type = gfc_get_element_type (base_type);
1686 loop.temp_ss = gfc_get_ss ();;
1687 loop.temp_ss->type = GFC_SS_TEMP;
1688 loop.temp_ss->data.temp.type = base_type;
1690 if (expr->ts.type == BT_CHARACTER)
1692 gfc_ref *char_ref = expr->ref;
1694 for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
1695 if (char_ref->type == REF_SUBSTRING)
1699 expr->ts.cl = gfc_get_charlen ();
1700 expr->ts.cl->next = char_ref->u.ss.length->next;
1701 char_ref->u.ss.length->next = expr->ts.cl;
1703 gfc_init_se (&tmp_se, NULL);
1704 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1705 gfc_array_index_type);
1706 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1707 tmp_se.expr, gfc_index_one_node);
1708 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1709 gfc_init_se (&tmp_se, NULL);
1710 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1711 gfc_array_index_type);
1712 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1714 expr->ts.cl->backend_decl = tmp;
1718 loop.temp_ss->data.temp.type
1719 = gfc_typenode_for_spec (&expr->ts);
1720 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1723 loop.temp_ss->data.temp.dimen = loop.dimen;
1724 loop.temp_ss->next = gfc_ss_terminator;
1726 /* Associate the SS with the loop. */
1727 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1729 /* Setup the scalarizing loops. */
1730 gfc_conv_loop_setup (&loop);
1732 /* Pass the temporary descriptor back to the caller. */
1733 info = &loop.temp_ss->data.info;
1734 parmse->expr = info->descriptor;
1736 /* Setup the gfc_se structures. */
1737 gfc_copy_loopinfo_to_se (&lse, &loop);
1738 gfc_copy_loopinfo_to_se (&rse, &loop);
1741 lse.ss = loop.temp_ss;
1742 gfc_mark_ss_chain_used (rss, 1);
1743 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1745 /* Start the scalarized loop body. */
1746 gfc_start_scalarized_body (&loop, &body);
1748 /* Translate the expression. */
1749 gfc_conv_expr (&rse, expr);
1751 gfc_conv_tmp_array_ref (&lse);
1752 gfc_advance_se_ss_chain (&lse);
1754 if (intent != INTENT_OUT)
1756 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1757 gfc_add_expr_to_block (&body, tmp);
1758 gcc_assert (rse.ss == gfc_ss_terminator);
1759 gfc_trans_scalarizing_loops (&loop, &body);
1763 /* Make sure that the temporary declaration survives by merging
1764 all the loop declarations into the current context. */
1765 for (n = 0; n < loop.dimen; n++)
1767 gfc_merge_block_scope (&body);
1768 body = loop.code[loop.order[n]];
1770 gfc_merge_block_scope (&body);
1773 /* Add the post block after the second loop, so that any
1774 freeing of allocated memory is done at the right time. */
1775 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1777 /**********Copy the temporary back again.*********/
1779 gfc_init_se (&lse, NULL);
1780 gfc_init_se (&rse, NULL);
1782 /* Walk the argument expression. */
1783 lss = gfc_walk_expr (expr);
1784 rse.ss = loop.temp_ss;
1787 /* Initialize the scalarizer. */
1788 gfc_init_loopinfo (&loop2);
1789 gfc_add_ss_to_loop (&loop2, lss);
1791 /* Calculate the bounds of the scalarization. */
1792 gfc_conv_ss_startstride (&loop2);
1794 /* Setup the scalarizing loops. */
1795 gfc_conv_loop_setup (&loop2);
1797 gfc_copy_loopinfo_to_se (&lse, &loop2);
1798 gfc_copy_loopinfo_to_se (&rse, &loop2);
1800 gfc_mark_ss_chain_used (lss, 1);
1801 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1803 /* Declare the variable to hold the temporary offset and start the
1804 scalarized loop body. */
1805 offset = gfc_create_var (gfc_array_index_type, NULL);
1806 gfc_start_scalarized_body (&loop2, &body);
1808 /* Build the offsets for the temporary from the loop variables. The
1809 temporary array has lbounds of zero and strides of one in all
1810 dimensions, so this is very simple. The offset is only computed
1811 outside the innermost loop, so the overall transfer could be
1812 optimized further. */
1813 info = &rse.ss->data.info;
1815 tmp_index = gfc_index_zero_node;
1816 for (n = info->dimen - 1; n > 0; n--)
1819 tmp = rse.loop->loopvar[n];
1820 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1821 tmp, rse.loop->from[n]);
1822 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1825 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1826 rse.loop->to[n-1], rse.loop->from[n-1]);
1827 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1828 tmp_str, gfc_index_one_node);
1830 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1834 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1835 tmp_index, rse.loop->from[0]);
1836 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1838 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1839 rse.loop->loopvar[0], offset);
1841 /* Now use the offset for the reference. */
1842 tmp = build_fold_indirect_ref (info->data);
1843 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1845 if (expr->ts.type == BT_CHARACTER)
1846 rse.string_length = expr->ts.cl->backend_decl;
1848 gfc_conv_expr (&lse, expr);
1850 gcc_assert (lse.ss == gfc_ss_terminator);
1852 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1853 gfc_add_expr_to_block (&body, tmp);
1855 /* Generate the copying loops. */
1856 gfc_trans_scalarizing_loops (&loop2, &body);
1858 /* Wrap the whole thing up by adding the second loop to the post-block
1859 and following it by the post-block of the first loop. In this way,
1860 if the temporary needs freeing, it is done after use! */
1861 if (intent != INTENT_IN)
1863 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1864 gfc_add_block_to_block (&parmse->post, &loop2.post);
1867 gfc_add_block_to_block (&parmse->post, &loop.post);
1869 gfc_cleanup_loop (&loop);
1870 gfc_cleanup_loop (&loop2);
1872 /* Pass the string length to the argument expression. */
1873 if (expr->ts.type == BT_CHARACTER)
1874 parmse->string_length = expr->ts.cl->backend_decl;
1876 /* We want either the address for the data or the address of the descriptor,
1877 depending on the mode of passing array arguments. */
1879 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1881 parmse->expr = build_fold_addr_expr (parmse->expr);
1886 /* Is true if an array reference is followed by a component or substring
1890 is_aliased_array (gfc_expr * e)
1896 for (ref = e->ref; ref; ref = ref->next)
1898 if (ref->type == REF_ARRAY
1899 && ref->u.ar.type != AR_ELEMENT)
1903 && ref->type != REF_ARRAY)
1909 /* Generate code for a procedure call. Note can return se->post != NULL.
1910 If se->direct_byref is set then se->expr contains the return parameter.
1911 Return nonzero, if the call has alternate specifiers. */
1914 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1915 gfc_actual_arglist * arg, tree append_args)
1917 gfc_interface_mapping mapping;
1931 gfc_formal_arglist *formal;
1932 int has_alternate_specifier = 0;
1933 bool need_interface_mapping;
1940 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1942 arglist = NULL_TREE;
1943 retargs = NULL_TREE;
1944 stringargs = NULL_TREE;
1950 if (!sym->attr.elemental)
1952 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1953 if (se->ss->useflags)
1955 gcc_assert (gfc_return_by_reference (sym)
1956 && sym->result->attr.dimension);
1957 gcc_assert (se->loop != NULL);
1959 /* Access the previously obtained result. */
1960 gfc_conv_tmp_array_ref (se);
1961 gfc_advance_se_ss_chain (se);
1965 info = &se->ss->data.info;
1970 gfc_init_block (&post);
1971 gfc_init_interface_mapping (&mapping);
1972 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1973 && sym->ts.cl->length
1974 && sym->ts.cl->length->expr_type
1976 || sym->attr.dimension);
1977 formal = sym->formal;
1978 /* Evaluate the arguments. */
1979 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1982 fsym = formal ? formal->sym : NULL;
1983 parm_kind = MISSING;
1987 if (se->ignore_optional)
1989 /* Some intrinsics have already been resolved to the correct
1993 else if (arg->label)
1995 has_alternate_specifier = 1;
2000 /* Pass a NULL pointer for an absent arg. */
2001 gfc_init_se (&parmse, NULL);
2002 parmse.expr = null_pointer_node;
2003 if (arg->missing_arg_type == BT_CHARACTER)
2004 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2007 else if (se->ss && se->ss->useflags)
2009 /* An elemental function inside a scalarized loop. */
2010 gfc_init_se (&parmse, se);
2011 gfc_conv_expr_reference (&parmse, e);
2012 parm_kind = ELEMENTAL;
2016 /* A scalar or transformational function. */
2017 gfc_init_se (&parmse, NULL);
2018 argss = gfc_walk_expr (e);
2020 if (argss == gfc_ss_terminator)
2023 if (fsym && fsym->attr.value)
2025 gfc_conv_expr (&parmse, e);
2029 gfc_conv_expr_reference (&parmse, e);
2030 if (fsym && fsym->attr.pointer
2031 && e->expr_type != EXPR_NULL)
2033 /* Scalar pointer dummy args require an extra level of
2034 indirection. The null pointer already contains
2035 this level of indirection. */
2036 parm_kind = SCALAR_POINTER;
2037 parmse.expr = build_fold_addr_expr (parmse.expr);
2043 /* If the procedure requires an explicit interface, the actual
2044 argument is passed according to the corresponding formal
2045 argument. If the corresponding formal argument is a POINTER,
2046 ALLOCATABLE or assumed shape, we do not use g77's calling
2047 convention, and pass the address of the array descriptor
2048 instead. Otherwise we use g77's calling convention. */
2051 && !(fsym->attr.pointer || fsym->attr.allocatable)
2052 && fsym->as->type != AS_ASSUMED_SHAPE;
2053 f = f || !sym->attr.always_explicit;
2055 if (e->expr_type == EXPR_VARIABLE
2056 && is_aliased_array (e))
2057 /* The actual argument is a component reference to an
2058 array of derived types. In this case, the argument
2059 is converted to a temporary, which is passed and then
2060 written back after the procedure call. */
2061 gfc_conv_aliased_arg (&parmse, e, f,
2062 fsym ? fsym->attr.intent : INTENT_INOUT);
2064 gfc_conv_array_parameter (&parmse, e, argss, f);
2066 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2067 allocated on entry, it must be deallocated. */
2068 if (fsym && fsym->attr.allocatable
2069 && fsym->attr.intent == INTENT_OUT)
2071 tmp = e->symtree->n.sym->backend_decl;
2072 if (e->symtree->n.sym->attr.dummy)
2073 tmp = build_fold_indirect_ref (tmp);
2074 tmp = gfc_trans_dealloc_allocated (tmp);
2075 gfc_add_expr_to_block (&se->pre, tmp);
2085 /* If an optional argument is itself an optional dummy
2086 argument, check its presence and substitute a null
2088 if (e->expr_type == EXPR_VARIABLE
2089 && e->symtree->n.sym->attr.optional
2090 && fsym->attr.optional)
2091 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2093 /* If an INTENT(OUT) dummy of derived type has a default
2094 initializer, it must be (re)initialized here. */
2095 if (fsym->attr.intent == INTENT_OUT
2096 && fsym->ts.type == BT_DERIVED
2099 gcc_assert (!fsym->attr.allocatable);
2100 tmp = gfc_trans_assignment (e, fsym->value, false);
2101 gfc_add_expr_to_block (&se->pre, tmp);
2104 /* Obtain the character length of an assumed character
2105 length procedure from the typespec. */
2106 if (fsym->ts.type == BT_CHARACTER
2107 && parmse.string_length == NULL_TREE
2108 && e->ts.type == BT_PROCEDURE
2109 && e->symtree->n.sym->ts.type == BT_CHARACTER
2110 && e->symtree->n.sym->ts.cl->length != NULL)
2112 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2113 parmse.string_length
2114 = e->symtree->n.sym->ts.cl->backend_decl;
2118 if (need_interface_mapping)
2119 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2122 gfc_add_block_to_block (&se->pre, &parmse.pre);
2123 gfc_add_block_to_block (&post, &parmse.post);
2125 /* Allocated allocatable components of derived types must be
2126 deallocated for INTENT(OUT) dummy arguments and non-variable
2127 scalars. Non-variable arrays are dealt with in trans-array.c
2128 (gfc_conv_array_parameter). */
2129 if (e && e->ts.type == BT_DERIVED
2130 && e->ts.derived->attr.alloc_comp
2131 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2133 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2136 tmp = build_fold_indirect_ref (parmse.expr);
2137 parm_rank = e->rank;
2145 case (SCALAR_POINTER):
2146 tmp = build_fold_indirect_ref (tmp);
2153 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2154 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2155 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2156 tmp, build_empty_stmt ());
2158 if (e->expr_type != EXPR_VARIABLE)
2159 /* Don't deallocate non-variables until they have been used. */
2160 gfc_add_expr_to_block (&se->post, tmp);
2163 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2164 gfc_add_expr_to_block (&se->pre, tmp);
2168 /* Character strings are passed as two parameters, a length and a
2170 if (parmse.string_length != NULL_TREE)
2171 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2173 arglist = gfc_chainon_list (arglist, parmse.expr);
2175 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2178 if (ts.type == BT_CHARACTER)
2180 if (sym->ts.cl->length == NULL)
2182 /* Assumed character length results are not allowed by 5.1.1.5 of the
2183 standard and are trapped in resolve.c; except in the case of SPREAD
2184 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2185 we take the character length of the first argument for the result.
2186 For dummies, we have to look through the formal argument list for
2187 this function and use the character length found there.*/
2188 if (!sym->attr.dummy)
2189 cl.backend_decl = TREE_VALUE (stringargs);
2192 formal = sym->ns->proc_name->formal;
2193 for (; formal; formal = formal->next)
2194 if (strcmp (formal->sym->name, sym->name) == 0)
2195 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2200 /* Calculate the length of the returned string. */
2201 gfc_init_se (&parmse, NULL);
2202 if (need_interface_mapping)
2203 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2205 gfc_conv_expr (&parmse, sym->ts.cl->length);
2206 gfc_add_block_to_block (&se->pre, &parmse.pre);
2207 gfc_add_block_to_block (&se->post, &parmse.post);
2208 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
2211 /* Set up a charlen structure for it. */
2216 len = cl.backend_decl;
2219 byref = gfc_return_by_reference (sym);
2222 if (se->direct_byref)
2223 retargs = gfc_chainon_list (retargs, se->expr);
2224 else if (sym->result->attr.dimension)
2226 gcc_assert (se->loop && info);
2228 /* Set the type of the array. */
2229 tmp = gfc_typenode_for_spec (&ts);
2230 info->dimen = se->loop->dimen;
2232 /* Evaluate the bounds of the result, if known. */
2233 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2235 /* Create a temporary to store the result. In case the function
2236 returns a pointer, the temporary will be a shallow copy and
2237 mustn't be deallocated. */
2238 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2239 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2240 false, !sym->attr.pointer, callee_alloc,
2243 /* Pass the temporary as the first argument. */
2244 tmp = info->descriptor;
2245 tmp = build_fold_addr_expr (tmp);
2246 retargs = gfc_chainon_list (retargs, tmp);
2248 else if (ts.type == BT_CHARACTER)
2250 /* Pass the string length. */
2251 type = gfc_get_character_type (ts.kind, ts.cl);
2252 type = build_pointer_type (type);
2254 /* Return an address to a char[0:len-1]* temporary for
2255 character pointers. */
2256 if (sym->attr.pointer || sym->attr.allocatable)
2258 /* Build char[0:len-1] * pstr. */
2259 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2260 build_int_cst (gfc_charlen_type_node, 1));
2261 tmp = build_range_type (gfc_array_index_type,
2262 gfc_index_zero_node, tmp);
2263 tmp = build_array_type (gfc_character1_type_node, tmp);
2264 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2266 /* Provide an address expression for the function arguments. */
2267 var = build_fold_addr_expr (var);
2270 var = gfc_conv_string_tmp (se, type, len);
2272 retargs = gfc_chainon_list (retargs, var);
2276 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2278 type = gfc_get_complex_type (ts.kind);
2279 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2280 retargs = gfc_chainon_list (retargs, var);
2283 /* Add the string length to the argument list. */
2284 if (ts.type == BT_CHARACTER)
2285 retargs = gfc_chainon_list (retargs, len);
2287 gfc_free_interface_mapping (&mapping);
2289 /* Add the return arguments. */
2290 arglist = chainon (retargs, arglist);
2292 /* Add the hidden string length parameters to the arguments. */
2293 arglist = chainon (arglist, stringargs);
2295 /* We may want to append extra arguments here. This is used e.g. for
2296 calls to libgfortran_matmul_??, which need extra information. */
2297 if (append_args != NULL_TREE)
2298 arglist = chainon (arglist, append_args);
2300 /* Generate the actual call. */
2301 gfc_conv_function_val (se, sym);
2302 /* If there are alternate return labels, function type should be
2303 integer. Can't modify the type in place though, since it can be shared
2304 with other functions. */
2305 if (has_alternate_specifier
2306 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2308 gcc_assert (! sym->attr.dummy);
2309 TREE_TYPE (sym->backend_decl)
2310 = build_function_type (integer_type_node,
2311 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2312 se->expr = build_fold_addr_expr (sym->backend_decl);
2315 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2316 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2317 arglist, NULL_TREE);
2319 /* If we have a pointer function, but we don't want a pointer, e.g.
2322 where f is pointer valued, we have to dereference the result. */
2323 if (!se->want_pointer && !byref && sym->attr.pointer)
2324 se->expr = build_fold_indirect_ref (se->expr);
2326 /* f2c calling conventions require a scalar default real function to
2327 return a double precision result. Convert this back to default
2328 real. We only care about the cases that can happen in Fortran 77.
2330 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2331 && sym->ts.kind == gfc_default_real_kind
2332 && !sym->attr.always_explicit)
2333 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2335 /* A pure function may still have side-effects - it may modify its
2337 TREE_SIDE_EFFECTS (se->expr) = 1;
2339 if (!sym->attr.pure)
2340 TREE_SIDE_EFFECTS (se->expr) = 1;
2345 /* Add the function call to the pre chain. There is no expression. */
2346 gfc_add_expr_to_block (&se->pre, se->expr);
2347 se->expr = NULL_TREE;
2349 if (!se->direct_byref)
2351 if (sym->attr.dimension)
2353 if (flag_bounds_check)
2355 /* Check the data pointer hasn't been modified. This would
2356 happen in a function returning a pointer. */
2357 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2358 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2360 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2362 se->expr = info->descriptor;
2363 /* Bundle in the string length. */
2364 se->string_length = len;
2366 else if (sym->ts.type == BT_CHARACTER)
2368 /* Dereference for character pointer results. */
2369 if (sym->attr.pointer || sym->attr.allocatable)
2370 se->expr = build_fold_indirect_ref (var);
2374 se->string_length = len;
2378 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2379 se->expr = build_fold_indirect_ref (var);
2384 /* Follow the function call with the argument post block. */
2386 gfc_add_block_to_block (&se->pre, &post);
2388 gfc_add_block_to_block (&se->post, &post);
2390 return has_alternate_specifier;
2394 /* Generate code to copy a string. */
2397 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2398 tree slength, tree src)
2400 tree tmp, dlen, slen;
2408 stmtblock_t tempblock;
2410 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2411 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2413 /* Deal with single character specially. */
2414 dsc = gfc_to_single_character (dlen, dest);
2415 ssc = gfc_to_single_character (slen, src);
2416 if (dsc != NULL_TREE && ssc != NULL_TREE)
2418 gfc_add_modify_expr (block, dsc, ssc);
2422 /* Do nothing if the destination length is zero. */
2423 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2424 build_int_cst (gfc_charlen_type_node, 0));
2426 /* The following code was previously in _gfortran_copy_string:
2428 // The two strings may overlap so we use memmove.
2430 copy_string (GFC_INTEGER_4 destlen, char * dest,
2431 GFC_INTEGER_4 srclen, const char * src)
2433 if (srclen >= destlen)
2435 // This will truncate if too long.
2436 memmove (dest, src, destlen);
2440 memmove (dest, src, srclen);
2442 memset (&dest[srclen], ' ', destlen - srclen);
2446 We're now doing it here for better optimization, but the logic
2449 /* Truncate string if source is too long. */
2450 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2451 tmp2 = gfc_chainon_list (NULL_TREE, dest);
2452 tmp2 = gfc_chainon_list (tmp2, src);
2453 tmp2 = gfc_chainon_list (tmp2, dlen);
2454 tmp2 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp2);
2456 /* Else copy and pad with spaces. */
2457 tmp3 = gfc_chainon_list (NULL_TREE, dest);
2458 tmp3 = gfc_chainon_list (tmp3, src);
2459 tmp3 = gfc_chainon_list (tmp3, slen);
2460 tmp3 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp3);
2462 tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
2463 fold_convert (pchar_type_node, slen));
2464 tmp4 = gfc_chainon_list (NULL_TREE, tmp4);
2465 tmp4 = gfc_chainon_list (tmp4, build_int_cst
2466 (gfc_get_int_type (gfc_c_int_kind),
2467 lang_hooks.to_target_charset (' ')));
2468 tmp4 = gfc_chainon_list (tmp4, fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2470 tmp4 = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], tmp4);
2472 gfc_init_block (&tempblock);
2473 gfc_add_expr_to_block (&tempblock, tmp3);
2474 gfc_add_expr_to_block (&tempblock, tmp4);
2475 tmp3 = gfc_finish_block (&tempblock);
2477 /* The whole copy_string function is there. */
2478 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2479 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2480 gfc_add_expr_to_block (block, tmp);
2484 /* Translate a statement function.
2485 The value of a statement function reference is obtained by evaluating the
2486 expression using the values of the actual arguments for the values of the
2487 corresponding dummy arguments. */
2490 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2494 gfc_formal_arglist *fargs;
2495 gfc_actual_arglist *args;
2498 gfc_saved_var *saved_vars;
2504 sym = expr->symtree->n.sym;
2505 args = expr->value.function.actual;
2506 gfc_init_se (&lse, NULL);
2507 gfc_init_se (&rse, NULL);
2510 for (fargs = sym->formal; fargs; fargs = fargs->next)
2512 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2513 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2515 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2517 /* Each dummy shall be specified, explicitly or implicitly, to be
2519 gcc_assert (fargs->sym->attr.dimension == 0);
2522 /* Create a temporary to hold the value. */
2523 type = gfc_typenode_for_spec (&fsym->ts);
2524 temp_vars[n] = gfc_create_var (type, fsym->name);
2526 if (fsym->ts.type == BT_CHARACTER)
2528 /* Copy string arguments. */
2531 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2532 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2534 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2535 tmp = gfc_build_addr_expr (build_pointer_type (type),
2538 gfc_conv_expr (&rse, args->expr);
2539 gfc_conv_string_parameter (&rse);
2540 gfc_add_block_to_block (&se->pre, &lse.pre);
2541 gfc_add_block_to_block (&se->pre, &rse.pre);
2543 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2545 gfc_add_block_to_block (&se->pre, &lse.post);
2546 gfc_add_block_to_block (&se->pre, &rse.post);
2550 /* For everything else, just evaluate the expression. */
2551 gfc_conv_expr (&lse, args->expr);
2553 gfc_add_block_to_block (&se->pre, &lse.pre);
2554 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2555 gfc_add_block_to_block (&se->pre, &lse.post);
2561 /* Use the temporary variables in place of the real ones. */
2562 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2563 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2565 gfc_conv_expr (se, sym->value);
2567 if (sym->ts.type == BT_CHARACTER)
2569 gfc_conv_const_charlen (sym->ts.cl);
2571 /* Force the expression to the correct length. */
2572 if (!INTEGER_CST_P (se->string_length)
2573 || tree_int_cst_lt (se->string_length,
2574 sym->ts.cl->backend_decl))
2576 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2577 tmp = gfc_create_var (type, sym->name);
2578 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2579 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2580 se->string_length, se->expr);
2583 se->string_length = sym->ts.cl->backend_decl;
2586 /* Restore the original variables. */
2587 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2588 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2589 gfc_free (saved_vars);
2593 /* Translate a function expression. */
2596 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2600 if (expr->value.function.isym)
2602 gfc_conv_intrinsic_function (se, expr);
2606 /* We distinguish statement functions from general functions to improve
2607 runtime performance. */
2608 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2610 gfc_conv_statement_function (se, expr);
2614 /* expr.value.function.esym is the resolved (specific) function symbol for
2615 most functions. However this isn't set for dummy procedures. */
2616 sym = expr->value.function.esym;
2618 sym = expr->symtree->n.sym;
2619 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2624 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2626 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2627 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2629 gfc_conv_tmp_array_ref (se);
2630 gfc_advance_se_ss_chain (se);
2634 /* Build a static initializer. EXPR is the expression for the initial value.
2635 The other parameters describe the variable of the component being
2636 initialized. EXPR may be null. */
2639 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2640 bool array, bool pointer)
2644 if (!(expr || pointer))
2649 /* Arrays need special handling. */
2651 return gfc_build_null_descriptor (type);
2653 return gfc_conv_array_initializer (type, expr);
2656 return fold_convert (type, null_pointer_node);
2662 gfc_init_se (&se, NULL);
2663 gfc_conv_structure (&se, expr, 1);
2667 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2670 gfc_init_se (&se, NULL);
2671 gfc_conv_constant (&se, expr);
2678 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2690 gfc_start_block (&block);
2692 /* Initialize the scalarizer. */
2693 gfc_init_loopinfo (&loop);
2695 gfc_init_se (&lse, NULL);
2696 gfc_init_se (&rse, NULL);
2699 rss = gfc_walk_expr (expr);
2700 if (rss == gfc_ss_terminator)
2702 /* The rhs is scalar. Add a ss for the expression. */
2703 rss = gfc_get_ss ();
2704 rss->next = gfc_ss_terminator;
2705 rss->type = GFC_SS_SCALAR;
2709 /* Create a SS for the destination. */
2710 lss = gfc_get_ss ();
2711 lss->type = GFC_SS_COMPONENT;
2713 lss->shape = gfc_get_shape (cm->as->rank);
2714 lss->next = gfc_ss_terminator;
2715 lss->data.info.dimen = cm->as->rank;
2716 lss->data.info.descriptor = dest;
2717 lss->data.info.data = gfc_conv_array_data (dest);
2718 lss->data.info.offset = gfc_conv_array_offset (dest);
2719 for (n = 0; n < cm->as->rank; n++)
2721 lss->data.info.dim[n] = n;
2722 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2723 lss->data.info.stride[n] = gfc_index_one_node;
2725 mpz_init (lss->shape[n]);
2726 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2727 cm->as->lower[n]->value.integer);
2728 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2731 /* Associate the SS with the loop. */
2732 gfc_add_ss_to_loop (&loop, lss);
2733 gfc_add_ss_to_loop (&loop, rss);
2735 /* Calculate the bounds of the scalarization. */
2736 gfc_conv_ss_startstride (&loop);
2738 /* Setup the scalarizing loops. */
2739 gfc_conv_loop_setup (&loop);
2741 /* Setup the gfc_se structures. */
2742 gfc_copy_loopinfo_to_se (&lse, &loop);
2743 gfc_copy_loopinfo_to_se (&rse, &loop);
2746 gfc_mark_ss_chain_used (rss, 1);
2748 gfc_mark_ss_chain_used (lss, 1);
2750 /* Start the scalarized loop body. */
2751 gfc_start_scalarized_body (&loop, &body);
2753 gfc_conv_tmp_array_ref (&lse);
2754 if (cm->ts.type == BT_CHARACTER)
2755 lse.string_length = cm->ts.cl->backend_decl;
2757 gfc_conv_expr (&rse, expr);
2759 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2760 gfc_add_expr_to_block (&body, tmp);
2762 gcc_assert (rse.ss == gfc_ss_terminator);
2764 /* Generate the copying loops. */
2765 gfc_trans_scalarizing_loops (&loop, &body);
2767 /* Wrap the whole thing up. */
2768 gfc_add_block_to_block (&block, &loop.pre);
2769 gfc_add_block_to_block (&block, &loop.post);
2771 for (n = 0; n < cm->as->rank; n++)
2772 mpz_clear (lss->shape[n]);
2773 gfc_free (lss->shape);
2775 gfc_cleanup_loop (&loop);
2777 return gfc_finish_block (&block);
2781 /* Assign a single component of a derived type constructor. */
2784 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2794 gfc_start_block (&block);
2798 gfc_init_se (&se, NULL);
2799 /* Pointer component. */
2802 /* Array pointer. */
2803 if (expr->expr_type == EXPR_NULL)
2804 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2807 rss = gfc_walk_expr (expr);
2808 se.direct_byref = 1;
2810 gfc_conv_expr_descriptor (&se, expr, rss);
2811 gfc_add_block_to_block (&block, &se.pre);
2812 gfc_add_block_to_block (&block, &se.post);
2817 /* Scalar pointers. */
2818 se.want_pointer = 1;
2819 gfc_conv_expr (&se, expr);
2820 gfc_add_block_to_block (&block, &se.pre);
2821 gfc_add_modify_expr (&block, dest,
2822 fold_convert (TREE_TYPE (dest), se.expr));
2823 gfc_add_block_to_block (&block, &se.post);
2826 else if (cm->dimension)
2828 if (cm->allocatable && expr->expr_type == EXPR_NULL)
2829 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2830 else if (cm->allocatable)
2834 gfc_init_se (&se, NULL);
2836 rss = gfc_walk_expr (expr);
2837 se.want_pointer = 0;
2838 gfc_conv_expr_descriptor (&se, expr, rss);
2839 gfc_add_block_to_block (&block, &se.pre);
2841 tmp = fold_convert (TREE_TYPE (dest), se.expr);
2842 gfc_add_modify_expr (&block, dest, tmp);
2844 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2845 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2848 tmp = gfc_duplicate_allocatable (dest, se.expr,
2849 TREE_TYPE(cm->backend_decl),
2852 gfc_add_expr_to_block (&block, tmp);
2854 gfc_add_block_to_block (&block, &se.post);
2855 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2857 /* Shift the lbound and ubound of temporaries to being unity, rather
2858 than zero, based. Calculate the offset for all cases. */
2859 offset = gfc_conv_descriptor_offset (dest);
2860 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2861 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2862 for (n = 0; n < expr->rank; n++)
2864 if (expr->expr_type != EXPR_VARIABLE
2865 && expr->expr_type != EXPR_CONSTANT)
2867 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2868 gfc_add_modify_expr (&block, tmp,
2869 fold_build2 (PLUS_EXPR,
2870 gfc_array_index_type,
2871 tmp, gfc_index_one_node));
2872 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2873 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2875 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2876 gfc_conv_descriptor_lbound (dest,
2878 gfc_conv_descriptor_stride (dest,
2880 gfc_add_modify_expr (&block, tmp2, tmp);
2881 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2882 gfc_add_modify_expr (&block, offset, tmp);
2887 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2888 gfc_add_expr_to_block (&block, tmp);
2891 else if (expr->ts.type == BT_DERIVED)
2893 if (expr->expr_type != EXPR_STRUCTURE)
2895 gfc_init_se (&se, NULL);
2896 gfc_conv_expr (&se, expr);
2897 gfc_add_modify_expr (&block, dest,
2898 fold_convert (TREE_TYPE (dest), se.expr));
2902 /* Nested constructors. */
2903 tmp = gfc_trans_structure_assign (dest, expr);
2904 gfc_add_expr_to_block (&block, tmp);
2909 /* Scalar component. */
2910 gfc_init_se (&se, NULL);
2911 gfc_init_se (&lse, NULL);
2913 gfc_conv_expr (&se, expr);
2914 if (cm->ts.type == BT_CHARACTER)
2915 lse.string_length = cm->ts.cl->backend_decl;
2917 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2918 gfc_add_expr_to_block (&block, tmp);
2920 return gfc_finish_block (&block);
2923 /* Assign a derived type constructor to a variable. */
2926 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2934 gfc_start_block (&block);
2935 cm = expr->ts.derived->components;
2936 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2938 /* Skip absent members in default initializers. */
2942 field = cm->backend_decl;
2943 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2944 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2945 gfc_add_expr_to_block (&block, tmp);
2947 return gfc_finish_block (&block);
2950 /* Build an expression for a constructor. If init is nonzero then
2951 this is part of a static variable initializer. */
2954 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2961 VEC(constructor_elt,gc) *v = NULL;
2963 gcc_assert (se->ss == NULL);
2964 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2965 type = gfc_typenode_for_spec (&expr->ts);
2969 /* Create a temporary variable and fill it in. */
2970 se->expr = gfc_create_var (type, expr->ts.derived->name);
2971 tmp = gfc_trans_structure_assign (se->expr, expr);
2972 gfc_add_expr_to_block (&se->pre, tmp);
2976 cm = expr->ts.derived->components;
2978 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2980 /* Skip absent members in default initializers and allocatable
2981 components. Although the latter have a default initializer
2982 of EXPR_NULL,... by default, the static nullify is not needed
2983 since this is done every time we come into scope. */
2984 if (!c->expr || cm->allocatable)
2987 val = gfc_conv_initializer (c->expr, &cm->ts,
2988 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2990 /* Append it to the constructor list. */
2991 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2993 se->expr = build_constructor (type, v);
2997 /* Translate a substring expression. */
3000 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3006 gcc_assert (ref->type == REF_SUBSTRING);
3008 se->expr = gfc_build_string_const(expr->value.character.length,
3009 expr->value.character.string);
3010 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3011 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
3013 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
3017 /* Entry point for expression translation. Evaluates a scalar quantity.
3018 EXPR is the expression to be translated, and SE is the state structure if
3019 called from within the scalarized. */
3022 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3024 if (se->ss && se->ss->expr == expr
3025 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3027 /* Substitute a scalar expression evaluated outside the scalarization
3029 se->expr = se->ss->data.scalar.expr;
3030 se->string_length = se->ss->string_length;
3031 gfc_advance_se_ss_chain (se);
3035 switch (expr->expr_type)
3038 gfc_conv_expr_op (se, expr);
3042 gfc_conv_function_expr (se, expr);
3046 gfc_conv_constant (se, expr);
3050 gfc_conv_variable (se, expr);
3054 se->expr = null_pointer_node;
3057 case EXPR_SUBSTRING:
3058 gfc_conv_substring_expr (se, expr);
3061 case EXPR_STRUCTURE:
3062 gfc_conv_structure (se, expr, 0);
3066 gfc_conv_array_constructor_expr (se, expr);
3075 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3076 of an assignment. */
3078 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3080 gfc_conv_expr (se, expr);
3081 /* All numeric lvalues should have empty post chains. If not we need to
3082 figure out a way of rewriting an lvalue so that it has no post chain. */
3083 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3086 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3087 numeric expressions. Used for scalar values where inserting cleanup code
3090 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3094 gcc_assert (expr->ts.type != BT_CHARACTER);
3095 gfc_conv_expr (se, expr);
3098 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3099 gfc_add_modify_expr (&se->pre, val, se->expr);
3101 gfc_add_block_to_block (&se->pre, &se->post);
3105 /* Helper to translate and expression and convert it to a particular type. */
3107 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3109 gfc_conv_expr_val (se, expr);
3110 se->expr = convert (type, se->expr);
3114 /* Converts an expression so that it can be passed by reference. Scalar
3118 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3122 if (se->ss && se->ss->expr == expr
3123 && se->ss->type == GFC_SS_REFERENCE)
3125 se->expr = se->ss->data.scalar.expr;
3126 se->string_length = se->ss->string_length;
3127 gfc_advance_se_ss_chain (se);
3131 if (expr->ts.type == BT_CHARACTER)
3133 gfc_conv_expr (se, expr);
3134 gfc_conv_string_parameter (se);
3138 if (expr->expr_type == EXPR_VARIABLE)
3140 se->want_pointer = 1;
3141 gfc_conv_expr (se, expr);
3144 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3145 gfc_add_modify_expr (&se->pre, var, se->expr);
3146 gfc_add_block_to_block (&se->pre, &se->post);
3152 gfc_conv_expr (se, expr);
3154 /* Create a temporary var to hold the value. */
3155 if (TREE_CONSTANT (se->expr))
3157 tree tmp = se->expr;
3158 STRIP_TYPE_NOPS (tmp);
3159 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3160 DECL_INITIAL (var) = tmp;
3161 TREE_STATIC (var) = 1;
3166 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3167 gfc_add_modify_expr (&se->pre, var, se->expr);
3169 gfc_add_block_to_block (&se->pre, &se->post);
3171 /* Take the address of that value. */
3172 se->expr = build_fold_addr_expr (var);
3177 gfc_trans_pointer_assign (gfc_code * code)
3179 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3183 /* Generate code for a pointer assignment. */
3186 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3196 gfc_start_block (&block);
3198 gfc_init_se (&lse, NULL);
3200 lss = gfc_walk_expr (expr1);
3201 rss = gfc_walk_expr (expr2);
3202 if (lss == gfc_ss_terminator)
3204 /* Scalar pointers. */
3205 lse.want_pointer = 1;
3206 gfc_conv_expr (&lse, expr1);
3207 gcc_assert (rss == gfc_ss_terminator);
3208 gfc_init_se (&rse, NULL);
3209 rse.want_pointer = 1;
3210 gfc_conv_expr (&rse, expr2);
3211 gfc_add_block_to_block (&block, &lse.pre);
3212 gfc_add_block_to_block (&block, &rse.pre);
3213 gfc_add_modify_expr (&block, lse.expr,
3214 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3215 gfc_add_block_to_block (&block, &rse.post);
3216 gfc_add_block_to_block (&block, &lse.post);
3220 /* Array pointer. */
3221 gfc_conv_expr_descriptor (&lse, expr1, lss);
3222 switch (expr2->expr_type)
3225 /* Just set the data pointer to null. */
3226 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3230 /* Assign directly to the pointer's descriptor. */
3231 lse.direct_byref = 1;
3232 gfc_conv_expr_descriptor (&lse, expr2, rss);
3236 /* Assign to a temporary descriptor and then copy that
3237 temporary to the pointer. */
3239 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3242 lse.direct_byref = 1;
3243 gfc_conv_expr_descriptor (&lse, expr2, rss);
3244 gfc_add_modify_expr (&lse.pre, desc, tmp);
3247 gfc_add_block_to_block (&block, &lse.pre);
3248 gfc_add_block_to_block (&block, &lse.post);
3250 return gfc_finish_block (&block);
3254 /* Makes sure se is suitable for passing as a function string parameter. */
3255 /* TODO: Need to check all callers fo this function. It may be abused. */
3258 gfc_conv_string_parameter (gfc_se * se)
3262 if (TREE_CODE (se->expr) == STRING_CST)
3264 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3268 type = TREE_TYPE (se->expr);
3269 if (TYPE_STRING_FLAG (type))
3271 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3272 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3275 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3276 gcc_assert (se->string_length
3277 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3281 /* Generate code for assignment of scalar variables. Includes character
3282 strings and derived types with allocatable components. */
3285 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3286 bool l_is_temp, bool r_is_var)
3292 gfc_init_block (&block);
3294 if (ts.type == BT_CHARACTER)
3296 gcc_assert (lse->string_length != NULL_TREE
3297 && rse->string_length != NULL_TREE);
3299 gfc_conv_string_parameter (lse);
3300 gfc_conv_string_parameter (rse);
3302 gfc_add_block_to_block (&block, &lse->pre);
3303 gfc_add_block_to_block (&block, &rse->pre);
3305 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3306 rse->string_length, rse->expr);
3308 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3312 /* Are the rhs and the lhs the same? */
3315 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3316 build_fold_addr_expr (lse->expr),
3317 build_fold_addr_expr (rse->expr));
3318 cond = gfc_evaluate_now (cond, &lse->pre);
3321 /* Deallocate the lhs allocated components as long as it is not
3322 the same as the rhs. */
3325 tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3327 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3328 gfc_add_expr_to_block (&lse->pre, tmp);
3331 gfc_add_block_to_block (&block, &lse->pre);
3332 gfc_add_block_to_block (&block, &rse->pre);
3334 gfc_add_modify_expr (&block, lse->expr,
3335 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3337 /* Do a deep copy if the rhs is a variable, if it is not the
3341 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3342 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3343 gfc_add_expr_to_block (&block, tmp);
3348 gfc_add_block_to_block (&block, &lse->pre);
3349 gfc_add_block_to_block (&block, &rse->pre);
3351 gfc_add_modify_expr (&block, lse->expr,
3352 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3355 gfc_add_block_to_block (&block, &lse->post);
3356 gfc_add_block_to_block (&block, &rse->post);
3358 return gfc_finish_block (&block);
3362 /* Try to translate array(:) = func (...), where func is a transformational
3363 array function, without using a temporary. Returns NULL is this isn't the
3367 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3372 bool seen_array_ref;
3374 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3375 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3378 /* Elemental functions don't need a temporary anyway. */
3379 if (expr2->value.function.esym != NULL
3380 && expr2->value.function.esym->attr.elemental)
3383 /* Fail if EXPR1 can't be expressed as a descriptor. */
3384 if (gfc_ref_needs_temporary_p (expr1->ref))
3387 /* Functions returning pointers need temporaries. */
3388 if (expr2->symtree->n.sym->attr.pointer
3389 || expr2->symtree->n.sym->attr.allocatable)
3392 /* Character array functions need temporaries unless the
3393 character lengths are the same. */
3394 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
3396 if (expr1->ts.cl->length == NULL
3397 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
3400 if (expr2->ts.cl->length == NULL
3401 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
3404 if (mpz_cmp (expr1->ts.cl->length->value.integer,
3405 expr2->ts.cl->length->value.integer) != 0)
3409 /* Check that no LHS component references appear during an array
3410 reference. This is needed because we do not have the means to
3411 span any arbitrary stride with an array descriptor. This check
3412 is not needed for the rhs because the function result has to be
3414 seen_array_ref = false;
3415 for (ref = expr1->ref; ref; ref = ref->next)
3417 if (ref->type == REF_ARRAY)
3418 seen_array_ref= true;
3419 else if (ref->type == REF_COMPONENT && seen_array_ref)
3423 /* Check for a dependency. */
3424 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3425 expr2->value.function.esym,
3426 expr2->value.function.actual))
3429 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3431 gcc_assert (expr2->value.function.isym
3432 || (gfc_return_by_reference (expr2->value.function.esym)
3433 && expr2->value.function.esym->result->attr.dimension));
3435 ss = gfc_walk_expr (expr1);
3436 gcc_assert (ss != gfc_ss_terminator);
3437 gfc_init_se (&se, NULL);
3438 gfc_start_block (&se.pre);
3439 se.want_pointer = 1;
3441 gfc_conv_array_parameter (&se, expr1, ss, 0);
3443 se.direct_byref = 1;
3444 se.ss = gfc_walk_expr (expr2);
3445 gcc_assert (se.ss != gfc_ss_terminator);
3446 gfc_conv_function_expr (&se, expr2);
3447 gfc_add_block_to_block (&se.pre, &se.post);
3449 return gfc_finish_block (&se.pre);
3453 /* Translate an assignment. Most of the code is concerned with
3454 setting up the scalarizer. */
3457 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3462 gfc_ss *lss_section;
3470 /* Special case a single function returning an array. */
3471 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3473 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3478 /* Assignment of the form lhs = rhs. */
3479 gfc_start_block (&block);
3481 gfc_init_se (&lse, NULL);
3482 gfc_init_se (&rse, NULL);
3485 lss = gfc_walk_expr (expr1);
3487 if (lss != gfc_ss_terminator)
3489 /* The assignment needs scalarization. */
3492 /* Find a non-scalar SS from the lhs. */
3493 while (lss_section != gfc_ss_terminator
3494 && lss_section->type != GFC_SS_SECTION)
3495 lss_section = lss_section->next;
3497 gcc_assert (lss_section != gfc_ss_terminator);
3499 /* Initialize the scalarizer. */
3500 gfc_init_loopinfo (&loop);
3503 rss = gfc_walk_expr (expr2);
3504 if (rss == gfc_ss_terminator)
3506 /* The rhs is scalar. Add a ss for the expression. */
3507 rss = gfc_get_ss ();
3508 rss->next = gfc_ss_terminator;
3509 rss->type = GFC_SS_SCALAR;
3512 /* Associate the SS with the loop. */
3513 gfc_add_ss_to_loop (&loop, lss);
3514 gfc_add_ss_to_loop (&loop, rss);
3516 /* Calculate the bounds of the scalarization. */
3517 gfc_conv_ss_startstride (&loop);
3518 /* Resolve any data dependencies in the statement. */
3519 gfc_conv_resolve_dependencies (&loop, lss, rss);
3520 /* Setup the scalarizing loops. */
3521 gfc_conv_loop_setup (&loop);
3523 /* Setup the gfc_se structures. */
3524 gfc_copy_loopinfo_to_se (&lse, &loop);
3525 gfc_copy_loopinfo_to_se (&rse, &loop);
3528 gfc_mark_ss_chain_used (rss, 1);
3529 if (loop.temp_ss == NULL)
3532 gfc_mark_ss_chain_used (lss, 1);
3536 lse.ss = loop.temp_ss;
3537 gfc_mark_ss_chain_used (lss, 3);
3538 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3541 /* Start the scalarized loop body. */
3542 gfc_start_scalarized_body (&loop, &body);
3545 gfc_init_block (&body);
3547 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3549 /* Translate the expression. */
3550 gfc_conv_expr (&rse, expr2);
3554 gfc_conv_tmp_array_ref (&lse);
3555 gfc_advance_se_ss_chain (&lse);
3558 gfc_conv_expr (&lse, expr1);
3560 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3561 l_is_temp || init_flag,
3562 expr2->expr_type == EXPR_VARIABLE);
3563 gfc_add_expr_to_block (&body, tmp);
3565 if (lss == gfc_ss_terminator)
3567 /* Use the scalar assignment as is. */
3568 gfc_add_block_to_block (&block, &body);
3572 gcc_assert (lse.ss == gfc_ss_terminator
3573 && rse.ss == gfc_ss_terminator);
3577 gfc_trans_scalarized_loop_boundary (&loop, &body);
3579 /* We need to copy the temporary to the actual lhs. */
3580 gfc_init_se (&lse, NULL);
3581 gfc_init_se (&rse, NULL);
3582 gfc_copy_loopinfo_to_se (&lse, &loop);
3583 gfc_copy_loopinfo_to_se (&rse, &loop);
3585 rse.ss = loop.temp_ss;
3588 gfc_conv_tmp_array_ref (&rse);
3589 gfc_advance_se_ss_chain (&rse);
3590 gfc_conv_expr (&lse, expr1);
3592 gcc_assert (lse.ss == gfc_ss_terminator
3593 && rse.ss == gfc_ss_terminator);
3595 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3597 gfc_add_expr_to_block (&body, tmp);
3600 /* Generate the copying loops. */
3601 gfc_trans_scalarizing_loops (&loop, &body);
3603 /* Wrap the whole thing up. */
3604 gfc_add_block_to_block (&block, &loop.pre);
3605 gfc_add_block_to_block (&block, &loop.post);
3607 gfc_cleanup_loop (&loop);
3610 return gfc_finish_block (&block);
3614 gfc_trans_init_assign (gfc_code * code)
3616 return gfc_trans_assignment (code->expr, code->expr2, true);
3620 gfc_trans_assign (gfc_code * code)
3622 return gfc_trans_assignment (code->expr, code->expr2, false);