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 build_int_cst (TREE_TYPE (se->expr), 0));
157 tmp = gfc_evaluate_now (tmp, &se->pre);
159 if (ts.type == BT_CHARACTER)
161 tmp = build_int_cst (gfc_charlen_type_node, 0);
162 tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
163 se->string_length, tmp);
164 tmp = gfc_evaluate_now (tmp, &se->pre);
165 se->string_length = tmp;
171 /* Get the character length of an expression, looking through gfc_refs
175 gfc_get_expr_charlen (gfc_expr *e)
180 gcc_assert (e->expr_type == EXPR_VARIABLE
181 && e->ts.type == BT_CHARACTER);
183 length = NULL; /* To silence compiler warning. */
185 /* First candidate: if the variable is of type CHARACTER, the
186 expression's length could be the length of the character
188 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
189 length = e->symtree->n.sym->ts.cl->backend_decl;
191 /* Look through the reference chain for component references. */
192 for (r = e->ref; r; r = r->next)
197 if (r->u.c.component->ts.type == BT_CHARACTER)
198 length = r->u.c.component->ts.cl->backend_decl;
206 /* We should never got substring references here. These will be
207 broken down by the scalarizer. */
212 gcc_assert (length != NULL);
218 /* Generate code to initialize a string length variable. Returns the
222 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
227 gfc_init_se (&se, NULL);
228 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
229 gfc_add_block_to_block (pblock, &se.pre);
231 tmp = cl->backend_decl;
232 gfc_add_modify_expr (pblock, tmp, se.expr);
237 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
238 const char *name, locus *where)
248 type = gfc_get_character_type (kind, ref->u.ss.length);
249 type = build_pointer_type (type);
252 gfc_init_se (&start, se);
253 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
254 gfc_add_block_to_block (&se->pre, &start.pre);
256 if (integer_onep (start.expr))
257 gfc_conv_string_parameter (se);
260 /* Change the start of the string. */
261 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
264 tmp = build_fold_indirect_ref (se->expr);
265 tmp = gfc_build_array_ref (tmp, start.expr);
266 se->expr = gfc_build_addr_expr (type, tmp);
269 /* Length = end + 1 - start. */
270 gfc_init_se (&end, se);
271 if (ref->u.ss.end == NULL)
272 end.expr = se->string_length;
275 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
276 gfc_add_block_to_block (&se->pre, &end.pre);
278 if (flag_bounds_check)
280 /* Check lower bound. */
281 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
282 build_int_cst (gfc_charlen_type_node, 1));
284 asprintf (&msg, "Substring out of bounds: lower bound of '%s' "
285 "is less than one", name);
287 asprintf (&msg, "Substring out of bounds: lower bound "
289 gfc_trans_runtime_check (fault, msg, &se->pre, where);
292 /* Check upper bound. */
293 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
296 asprintf (&msg, "Substring out of bounds: upper bound of '%s' "
297 "exceeds string length", name);
299 asprintf (&msg, "Substring out of bounds: upper bound "
300 "exceeds string length");
301 gfc_trans_runtime_check (fault, msg, &se->pre, where);
305 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
306 build_int_cst (gfc_charlen_type_node, 1),
308 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
309 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
310 build_int_cst (gfc_charlen_type_node, 0));
311 se->string_length = tmp;
315 /* Convert a derived type component reference. */
318 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
325 c = ref->u.c.component;
327 gcc_assert (c->backend_decl);
329 field = c->backend_decl;
330 gcc_assert (TREE_CODE (field) == FIELD_DECL);
332 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
336 if (c->ts.type == BT_CHARACTER)
338 tmp = c->ts.cl->backend_decl;
339 /* Components must always be constant length. */
340 gcc_assert (tmp && INTEGER_CST_P (tmp));
341 se->string_length = tmp;
344 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
345 se->expr = build_fold_indirect_ref (se->expr);
349 /* Return the contents of a variable. Also handles reference/pointer
350 variables (all Fortran pointer references are implicit). */
353 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
360 bool alternate_entry;
363 sym = expr->symtree->n.sym;
366 /* Check that something hasn't gone horribly wrong. */
367 gcc_assert (se->ss != gfc_ss_terminator);
368 gcc_assert (se->ss->expr == expr);
370 /* A scalarized term. We already know the descriptor. */
371 se->expr = se->ss->data.info.descriptor;
372 se->string_length = se->ss->string_length;
373 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
374 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
379 tree se_expr = NULL_TREE;
381 se->expr = gfc_get_symbol_decl (sym);
383 /* Deal with references to a parent results or entries by storing
384 the current_function_decl and moving to the parent_decl. */
385 return_value = sym->attr.function && sym->result == sym;
386 alternate_entry = sym->attr.function && sym->attr.entry
387 && sym->result == sym;
388 entry_master = sym->attr.result
389 && sym->ns->proc_name->attr.entry_master
390 && !gfc_return_by_reference (sym->ns->proc_name);
391 parent_decl = DECL_CONTEXT (current_function_decl);
393 if ((se->expr == parent_decl && return_value)
394 || (sym->ns && sym->ns->proc_name
396 && sym->ns->proc_name->backend_decl == parent_decl
397 && (alternate_entry || entry_master)))
402 /* Special case for assigning the return value of a function.
403 Self recursive functions must have an explicit return value. */
404 if (return_value && (se->expr == current_function_decl || parent_flag))
405 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
407 /* Similarly for alternate entry points. */
408 else if (alternate_entry
409 && (sym->ns->proc_name->backend_decl == current_function_decl
412 gfc_entry_list *el = NULL;
414 for (el = sym->ns->entries; el; el = el->next)
417 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
422 else if (entry_master
423 && (sym->ns->proc_name->backend_decl == current_function_decl
425 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
430 /* Procedure actual arguments. */
431 else if (sym->attr.flavor == FL_PROCEDURE
432 && se->expr != current_function_decl)
434 gcc_assert (se->want_pointer);
435 if (!sym->attr.dummy)
437 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
438 se->expr = build_fold_addr_expr (se->expr);
444 /* Dereference the expression, where needed. Since characters
445 are entirely different from other types, they are treated
447 if (sym->ts.type == BT_CHARACTER)
449 /* Dereference character pointer dummy arguments
451 if ((sym->attr.pointer || sym->attr.allocatable)
453 || sym->attr.function
454 || sym->attr.result))
455 se->expr = build_fold_indirect_ref (se->expr);
459 /* Dereference non-character scalar dummy arguments. */
460 if (sym->attr.dummy && !sym->attr.dimension)
461 se->expr = build_fold_indirect_ref (se->expr);
463 /* Dereference scalar hidden result. */
464 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
465 && (sym->attr.function || sym->attr.result)
466 && !sym->attr.dimension && !sym->attr.pointer)
467 se->expr = build_fold_indirect_ref (se->expr);
469 /* Dereference non-character pointer variables.
470 These must be dummies, results, or scalars. */
471 if ((sym->attr.pointer || sym->attr.allocatable)
473 || sym->attr.function
475 || !sym->attr.dimension))
476 se->expr = build_fold_indirect_ref (se->expr);
482 /* For character variables, also get the length. */
483 if (sym->ts.type == BT_CHARACTER)
485 /* If the character length of an entry isn't set, get the length from
486 the master function instead. */
487 if (sym->attr.entry && !sym->ts.cl->backend_decl)
488 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
490 se->string_length = sym->ts.cl->backend_decl;
491 gcc_assert (se->string_length);
499 /* Return the descriptor if that's what we want and this is an array
500 section reference. */
501 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
503 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
504 /* Return the descriptor for array pointers and allocations. */
506 && ref->next == NULL && (se->descriptor_only))
509 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
510 /* Return a pointer to an element. */
514 gfc_conv_component_ref (se, ref);
518 gfc_conv_substring (se, ref, expr->ts.kind,
519 expr->symtree->name, &expr->where);
528 /* Pointer assignment, allocation or pass by reference. Arrays are handled
530 if (se->want_pointer)
532 if (expr->ts.type == BT_CHARACTER)
533 gfc_conv_string_parameter (se);
535 se->expr = build_fold_addr_expr (se->expr);
540 /* Unary ops are easy... Or they would be if ! was a valid op. */
543 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
548 gcc_assert (expr->ts.type != BT_CHARACTER);
549 /* Initialize the operand. */
550 gfc_init_se (&operand, se);
551 gfc_conv_expr_val (&operand, expr->value.op.op1);
552 gfc_add_block_to_block (&se->pre, &operand.pre);
554 type = gfc_typenode_for_spec (&expr->ts);
556 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
557 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
558 All other unary operators have an equivalent GIMPLE unary operator. */
559 if (code == TRUTH_NOT_EXPR)
560 se->expr = build2 (EQ_EXPR, type, operand.expr,
561 build_int_cst (type, 0));
563 se->expr = build1 (code, type, operand.expr);
567 /* Expand power operator to optimal multiplications when a value is raised
568 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
569 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
570 Programming", 3rd Edition, 1998. */
572 /* This code is mostly duplicated from expand_powi in the backend.
573 We establish the "optimal power tree" lookup table with the defined size.
574 The items in the table are the exponents used to calculate the index
575 exponents. Any integer n less than the value can get an "addition chain",
576 with the first node being one. */
577 #define POWI_TABLE_SIZE 256
579 /* The table is from builtins.c. */
580 static const unsigned char powi_table[POWI_TABLE_SIZE] =
582 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
583 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
584 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
585 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
586 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
587 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
588 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
589 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
590 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
591 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
592 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
593 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
594 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
595 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
596 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
597 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
598 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
599 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
600 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
601 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
602 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
603 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
604 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
605 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
606 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
607 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
608 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
609 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
610 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
611 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
612 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
613 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
616 /* If n is larger than lookup table's max index, we use the "window
618 #define POWI_WINDOW_SIZE 3
620 /* Recursive function to expand the power operator. The temporary
621 values are put in tmpvar. The function returns tmpvar[1] ** n. */
623 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
630 if (n < POWI_TABLE_SIZE)
635 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
636 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
640 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
641 op0 = gfc_conv_powi (se, n - digit, tmpvar);
642 op1 = gfc_conv_powi (se, digit, tmpvar);
646 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
650 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
651 tmp = gfc_evaluate_now (tmp, &se->pre);
653 if (n < POWI_TABLE_SIZE)
660 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
661 return 1. Else return 0 and a call to runtime library functions
662 will have to be built. */
664 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
669 tree vartmp[POWI_TABLE_SIZE];
673 type = TREE_TYPE (lhs);
674 n = abs (TREE_INT_CST_LOW (rhs));
675 sgn = tree_int_cst_sgn (rhs);
677 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
678 && (n > 2 || n < -1))
684 se->expr = gfc_build_const (type, integer_one_node);
687 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
688 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
690 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
691 build_int_cst (TREE_TYPE (lhs), -1));
692 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
693 build_int_cst (TREE_TYPE (lhs), 1));
696 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
699 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
700 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
701 build_int_cst (type, 0));
705 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
706 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
707 build_int_cst (type, 0));
708 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
712 memset (vartmp, 0, sizeof (vartmp));
716 tmp = gfc_build_const (type, integer_one_node);
717 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
720 se->expr = gfc_conv_powi (se, n, vartmp);
726 /* Power op (**). Constant integer exponent has special handling. */
729 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
731 tree gfc_int4_type_node;
739 gfc_init_se (&lse, se);
740 gfc_conv_expr_val (&lse, expr->value.op.op1);
741 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
742 gfc_add_block_to_block (&se->pre, &lse.pre);
744 gfc_init_se (&rse, se);
745 gfc_conv_expr_val (&rse, expr->value.op.op2);
746 gfc_add_block_to_block (&se->pre, &rse.pre);
748 if (expr->value.op.op2->ts.type == BT_INTEGER
749 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
750 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
753 gfc_int4_type_node = gfc_get_int_type (4);
755 kind = expr->value.op.op1->ts.kind;
756 switch (expr->value.op.op2->ts.type)
759 ikind = expr->value.op.op2->ts.kind;
764 rse.expr = convert (gfc_int4_type_node, rse.expr);
786 if (expr->value.op.op1->ts.type == BT_INTEGER)
787 lse.expr = convert (gfc_int4_type_node, lse.expr);
812 switch (expr->value.op.op1->ts.type)
815 if (kind == 3) /* Case 16 was not handled properly above. */
817 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
821 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
825 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
837 fndecl = built_in_decls[BUILT_IN_POWF];
840 fndecl = built_in_decls[BUILT_IN_POW];
844 fndecl = built_in_decls[BUILT_IN_POWL];
855 fndecl = gfor_fndecl_math_cpowf;
858 fndecl = gfor_fndecl_math_cpow;
861 fndecl = gfor_fndecl_math_cpowl10;
864 fndecl = gfor_fndecl_math_cpowl16;
876 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
877 tmp = gfc_chainon_list (tmp, rse.expr);
878 se->expr = build_function_call_expr (fndecl, tmp);
882 /* Generate code to allocate a string temporary. */
885 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
891 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
893 if (gfc_can_put_var_on_stack (len))
895 /* Create a temporary variable to hold the result. */
896 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
897 build_int_cst (gfc_charlen_type_node, 1));
898 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
899 tmp = build_array_type (gfc_character1_type_node, tmp);
900 var = gfc_create_var (tmp, "str");
901 var = gfc_build_addr_expr (type, var);
905 /* Allocate a temporary to hold the result. */
906 var = gfc_create_var (type, "pstr");
907 args = gfc_chainon_list (NULL_TREE, len);
908 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
909 tmp = convert (type, tmp);
910 gfc_add_modify_expr (&se->pre, var, tmp);
912 /* Free the temporary afterwards. */
913 tmp = convert (pvoid_type_node, var);
914 args = gfc_chainon_list (NULL_TREE, tmp);
915 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
916 gfc_add_expr_to_block (&se->post, tmp);
923 /* Handle a string concatenation operation. A temporary will be allocated to
927 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
937 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
938 && expr->value.op.op2->ts.type == BT_CHARACTER);
940 gfc_init_se (&lse, se);
941 gfc_conv_expr (&lse, expr->value.op.op1);
942 gfc_conv_string_parameter (&lse);
943 gfc_init_se (&rse, se);
944 gfc_conv_expr (&rse, expr->value.op.op2);
945 gfc_conv_string_parameter (&rse);
947 gfc_add_block_to_block (&se->pre, &lse.pre);
948 gfc_add_block_to_block (&se->pre, &rse.pre);
950 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
951 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
952 if (len == NULL_TREE)
954 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
955 lse.string_length, rse.string_length);
958 type = build_pointer_type (type);
960 var = gfc_conv_string_tmp (se, type, len);
962 /* Do the actual concatenation. */
964 args = gfc_chainon_list (args, len);
965 args = gfc_chainon_list (args, var);
966 args = gfc_chainon_list (args, lse.string_length);
967 args = gfc_chainon_list (args, lse.expr);
968 args = gfc_chainon_list (args, rse.string_length);
969 args = gfc_chainon_list (args, rse.expr);
970 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
971 gfc_add_expr_to_block (&se->pre, tmp);
973 /* Add the cleanup for the operands. */
974 gfc_add_block_to_block (&se->pre, &rse.post);
975 gfc_add_block_to_block (&se->pre, &lse.post);
978 se->string_length = len;
981 /* Translates an op expression. Common (binary) cases are handled by this
982 function, others are passed on. Recursion is used in either case.
983 We use the fact that (op1.ts == op2.ts) (except for the power
985 Operators need no special handling for scalarized expressions as long as
986 they call gfc_conv_simple_val to get their operands.
987 Character strings get special handling. */
990 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1002 switch (expr->value.op.operator)
1004 case INTRINSIC_UPLUS:
1005 case INTRINSIC_PARENTHESES:
1006 gfc_conv_expr (se, expr->value.op.op1);
1009 case INTRINSIC_UMINUS:
1010 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1014 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1017 case INTRINSIC_PLUS:
1021 case INTRINSIC_MINUS:
1025 case INTRINSIC_TIMES:
1029 case INTRINSIC_DIVIDE:
1030 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1031 an integer, we must round towards zero, so we use a
1033 if (expr->ts.type == BT_INTEGER)
1034 code = TRUNC_DIV_EXPR;
1039 case INTRINSIC_POWER:
1040 gfc_conv_power_op (se, expr);
1043 case INTRINSIC_CONCAT:
1044 gfc_conv_concat_op (se, expr);
1048 code = TRUTH_ANDIF_EXPR;
1053 code = TRUTH_ORIF_EXPR;
1057 /* EQV and NEQV only work on logicals, but since we represent them
1058 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1067 case INTRINSIC_NEQV:
1097 case INTRINSIC_USER:
1098 case INTRINSIC_ASSIGN:
1099 /* These should be converted into function calls by the frontend. */
1103 fatal_error ("Unknown intrinsic op");
1107 /* The only exception to this is **, which is handled separately anyway. */
1108 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1110 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1114 gfc_init_se (&lse, se);
1115 gfc_conv_expr (&lse, expr->value.op.op1);
1116 gfc_add_block_to_block (&se->pre, &lse.pre);
1119 gfc_init_se (&rse, se);
1120 gfc_conv_expr (&rse, expr->value.op.op2);
1121 gfc_add_block_to_block (&se->pre, &rse.pre);
1125 gfc_conv_string_parameter (&lse);
1126 gfc_conv_string_parameter (&rse);
1128 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1129 rse.string_length, rse.expr);
1130 rse.expr = integer_zero_node;
1131 gfc_add_block_to_block (&lse.post, &rse.post);
1134 type = gfc_typenode_for_spec (&expr->ts);
1138 /* The result of logical ops is always boolean_type_node. */
1139 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1140 se->expr = convert (type, tmp);
1143 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1145 /* Add the post blocks. */
1146 gfc_add_block_to_block (&se->post, &rse.post);
1147 gfc_add_block_to_block (&se->post, &lse.post);
1150 /* If a string's length is one, we convert it to a single character. */
1153 gfc_to_single_character (tree len, tree str)
1155 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1157 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1158 && TREE_INT_CST_HIGH (len) == 0)
1160 str = fold_convert (pchar_type_node, str);
1161 return build_fold_indirect_ref (str);
1167 /* Compare two strings. If they are all single characters, the result is the
1168 subtraction of them. Otherwise, we build a library call. */
1171 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1178 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1179 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1181 type = gfc_get_int_type (gfc_default_integer_kind);
1183 sc1 = gfc_to_single_character (len1, str1);
1184 sc2 = gfc_to_single_character (len2, str2);
1186 /* Deal with single character specially. */
1187 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1189 sc1 = fold_convert (type, sc1);
1190 sc2 = fold_convert (type, sc2);
1191 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1196 tmp = gfc_chainon_list (tmp, len1);
1197 tmp = gfc_chainon_list (tmp, str1);
1198 tmp = gfc_chainon_list (tmp, len2);
1199 tmp = gfc_chainon_list (tmp, str2);
1201 /* Build a call for the comparison. */
1202 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1209 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1213 if (sym->attr.dummy)
1215 tmp = gfc_get_symbol_decl (sym);
1216 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1217 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1221 if (!sym->backend_decl)
1222 sym->backend_decl = gfc_get_extern_function_decl (sym);
1224 tmp = sym->backend_decl;
1225 if (sym->attr.cray_pointee)
1226 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1227 gfc_get_symbol_decl (sym->cp_pointer));
1228 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1230 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1231 tmp = build_fold_addr_expr (tmp);
1238 /* Initialize MAPPING. */
1241 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1243 mapping->syms = NULL;
1244 mapping->charlens = NULL;
1248 /* Free all memory held by MAPPING (but not MAPPING itself). */
1251 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1253 gfc_interface_sym_mapping *sym;
1254 gfc_interface_sym_mapping *nextsym;
1256 gfc_charlen *nextcl;
1258 for (sym = mapping->syms; sym; sym = nextsym)
1260 nextsym = sym->next;
1261 gfc_free_symbol (sym->new->n.sym);
1262 gfc_free (sym->new);
1265 for (cl = mapping->charlens; cl; cl = nextcl)
1268 gfc_free_expr (cl->length);
1274 /* Return a copy of gfc_charlen CL. Add the returned structure to
1275 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1277 static gfc_charlen *
1278 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1283 new = gfc_get_charlen ();
1284 new->next = mapping->charlens;
1285 new->length = gfc_copy_expr (cl->length);
1287 mapping->charlens = new;
1292 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1293 array variable that can be used as the actual argument for dummy
1294 argument SYM. Add any initialization code to BLOCK. PACKED is as
1295 for gfc_get_nodesc_array_type and DATA points to the first element
1296 in the passed array. */
1299 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1300 int packed, tree data)
1305 type = gfc_typenode_for_spec (&sym->ts);
1306 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1308 var = gfc_create_var (type, "ifm");
1309 gfc_add_modify_expr (block, var, fold_convert (type, data));
1315 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1316 and offset of descriptorless array type TYPE given that it has the same
1317 size as DESC. Add any set-up code to BLOCK. */
1320 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1327 offset = gfc_index_zero_node;
1328 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1330 dim = gfc_rank_cst[n];
1331 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1332 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1334 GFC_TYPE_ARRAY_LBOUND (type, n)
1335 = gfc_conv_descriptor_lbound (desc, dim);
1336 GFC_TYPE_ARRAY_UBOUND (type, n)
1337 = gfc_conv_descriptor_ubound (desc, dim);
1339 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1341 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1342 gfc_conv_descriptor_ubound (desc, dim),
1343 gfc_conv_descriptor_lbound (desc, dim));
1344 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1345 GFC_TYPE_ARRAY_LBOUND (type, n),
1347 tmp = gfc_evaluate_now (tmp, block);
1348 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1350 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1351 GFC_TYPE_ARRAY_LBOUND (type, n),
1352 GFC_TYPE_ARRAY_STRIDE (type, n));
1353 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1355 offset = gfc_evaluate_now (offset, block);
1356 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1360 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1361 in SE. The caller may still use se->expr and se->string_length after
1362 calling this function. */
1365 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1366 gfc_symbol * sym, gfc_se * se)
1368 gfc_interface_sym_mapping *sm;
1372 gfc_symbol *new_sym;
1374 gfc_symtree *new_symtree;
1376 /* Create a new symbol to represent the actual argument. */
1377 new_sym = gfc_new_symbol (sym->name, NULL);
1378 new_sym->ts = sym->ts;
1379 new_sym->attr.referenced = 1;
1380 new_sym->attr.dimension = sym->attr.dimension;
1381 new_sym->attr.pointer = sym->attr.pointer;
1382 new_sym->attr.allocatable = sym->attr.allocatable;
1383 new_sym->attr.flavor = sym->attr.flavor;
1385 /* Create a fake symtree for it. */
1387 new_symtree = gfc_new_symtree (&root, sym->name);
1388 new_symtree->n.sym = new_sym;
1389 gcc_assert (new_symtree == root);
1391 /* Create a dummy->actual mapping. */
1392 sm = gfc_getmem (sizeof (*sm));
1393 sm->next = mapping->syms;
1395 sm->new = new_symtree;
1398 /* Stabilize the argument's value. */
1399 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1401 if (sym->ts.type == BT_CHARACTER)
1403 /* Create a copy of the dummy argument's length. */
1404 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1406 /* If the length is specified as "*", record the length that
1407 the caller is passing. We should use the callee's length
1408 in all other cases. */
1409 if (!new_sym->ts.cl->length)
1411 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1412 new_sym->ts.cl->backend_decl = se->string_length;
1416 /* Use the passed value as-is if the argument is a function. */
1417 if (sym->attr.flavor == FL_PROCEDURE)
1420 /* If the argument is either a string or a pointer to a string,
1421 convert it to a boundless character type. */
1422 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1424 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1425 tmp = build_pointer_type (tmp);
1426 if (sym->attr.pointer)
1427 value = build_fold_indirect_ref (se->expr);
1430 value = fold_convert (tmp, value);
1433 /* If the argument is a scalar, a pointer to an array or an allocatable,
1435 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1436 value = build_fold_indirect_ref (se->expr);
1438 /* For character(*), use the actual argument's descriptor. */
1439 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1440 value = build_fold_indirect_ref (se->expr);
1442 /* If the argument is an array descriptor, use it to determine
1443 information about the actual argument's shape. */
1444 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1445 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1447 /* Get the actual argument's descriptor. */
1448 desc = build_fold_indirect_ref (se->expr);
1450 /* Create the replacement variable. */
1451 tmp = gfc_conv_descriptor_data_get (desc);
1452 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1454 /* Use DESC to work out the upper bounds, strides and offset. */
1455 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1458 /* Otherwise we have a packed array. */
1459 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1461 new_sym->backend_decl = value;
1465 /* Called once all dummy argument mappings have been added to MAPPING,
1466 but before the mapping is used to evaluate expressions. Pre-evaluate
1467 the length of each argument, adding any initialization code to PRE and
1468 any finalization code to POST. */
1471 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1472 stmtblock_t * pre, stmtblock_t * post)
1474 gfc_interface_sym_mapping *sym;
1478 for (sym = mapping->syms; sym; sym = sym->next)
1479 if (sym->new->n.sym->ts.type == BT_CHARACTER
1480 && !sym->new->n.sym->ts.cl->backend_decl)
1482 expr = sym->new->n.sym->ts.cl->length;
1483 gfc_apply_interface_mapping_to_expr (mapping, expr);
1484 gfc_init_se (&se, NULL);
1485 gfc_conv_expr (&se, expr);
1487 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1488 gfc_add_block_to_block (pre, &se.pre);
1489 gfc_add_block_to_block (post, &se.post);
1491 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1496 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1500 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1501 gfc_constructor * c)
1503 for (; c; c = c->next)
1505 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1508 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1509 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1510 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1516 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1520 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1525 for (; ref; ref = ref->next)
1529 for (n = 0; n < ref->u.ar.dimen; n++)
1531 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1532 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1533 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1535 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1542 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1543 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1549 /* EXPR is a copy of an expression that appeared in the interface
1550 associated with MAPPING. Walk it recursively looking for references to
1551 dummy arguments that MAPPING maps to actual arguments. Replace each such
1552 reference with a reference to the associated actual argument. */
1555 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1558 gfc_interface_sym_mapping *sym;
1559 gfc_actual_arglist *actual;
1564 /* Copying an expression does not copy its length, so do that here. */
1565 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1567 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1568 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1571 /* Apply the mapping to any references. */
1572 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1574 /* ...and to the expression's symbol, if it has one. */
1576 for (sym = mapping->syms; sym; sym = sym->next)
1577 if (sym->old == expr->symtree->n.sym)
1578 expr->symtree = sym->new;
1580 /* ...and to subexpressions in expr->value. */
1581 switch (expr->expr_type)
1586 case EXPR_SUBSTRING:
1590 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1591 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1595 for (sym = mapping->syms; sym; sym = sym->next)
1596 if (sym->old == expr->value.function.esym)
1597 expr->value.function.esym = sym->new->n.sym;
1599 for (actual = expr->value.function.actual; actual; actual = actual->next)
1600 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1604 case EXPR_STRUCTURE:
1605 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1611 /* Evaluate interface expression EXPR using MAPPING. Store the result
1615 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1616 gfc_se * se, gfc_expr * expr)
1618 expr = gfc_copy_expr (expr);
1619 gfc_apply_interface_mapping_to_expr (mapping, expr);
1620 gfc_conv_expr (se, expr);
1621 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1622 gfc_free_expr (expr);
1625 /* Returns a reference to a temporary array into which a component of
1626 an actual argument derived type array is copied and then returned
1627 after the function call.
1628 TODO Get rid of this kludge, when array descriptors are capable of
1629 handling aliased arrays. */
1632 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1633 int g77, sym_intent intent)
1649 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1651 gfc_init_se (&lse, NULL);
1652 gfc_init_se (&rse, NULL);
1654 /* Walk the argument expression. */
1655 rss = gfc_walk_expr (expr);
1657 gcc_assert (rss != gfc_ss_terminator);
1659 /* Initialize the scalarizer. */
1660 gfc_init_loopinfo (&loop);
1661 gfc_add_ss_to_loop (&loop, rss);
1663 /* Calculate the bounds of the scalarization. */
1664 gfc_conv_ss_startstride (&loop);
1666 /* Build an ss for the temporary. */
1667 base_type = gfc_typenode_for_spec (&expr->ts);
1668 if (GFC_ARRAY_TYPE_P (base_type)
1669 || GFC_DESCRIPTOR_TYPE_P (base_type))
1670 base_type = gfc_get_element_type (base_type);
1672 loop.temp_ss = gfc_get_ss ();;
1673 loop.temp_ss->type = GFC_SS_TEMP;
1674 loop.temp_ss->data.temp.type = base_type;
1676 if (expr->ts.type == BT_CHARACTER)
1678 gfc_ref *char_ref = expr->ref;
1680 for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
1681 if (char_ref->type == REF_SUBSTRING)
1685 expr->ts.cl = gfc_get_charlen ();
1686 expr->ts.cl->next = char_ref->u.ss.length->next;
1687 char_ref->u.ss.length->next = expr->ts.cl;
1689 gfc_init_se (&tmp_se, NULL);
1690 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1691 gfc_array_index_type);
1692 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1693 tmp_se.expr, gfc_index_one_node);
1694 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1695 gfc_init_se (&tmp_se, NULL);
1696 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1697 gfc_array_index_type);
1698 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1700 expr->ts.cl->backend_decl = tmp;
1704 loop.temp_ss->data.temp.type
1705 = gfc_typenode_for_spec (&expr->ts);
1706 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1709 loop.temp_ss->data.temp.dimen = loop.dimen;
1710 loop.temp_ss->next = gfc_ss_terminator;
1712 /* Associate the SS with the loop. */
1713 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1715 /* Setup the scalarizing loops. */
1716 gfc_conv_loop_setup (&loop);
1718 /* Pass the temporary descriptor back to the caller. */
1719 info = &loop.temp_ss->data.info;
1720 parmse->expr = info->descriptor;
1722 /* Setup the gfc_se structures. */
1723 gfc_copy_loopinfo_to_se (&lse, &loop);
1724 gfc_copy_loopinfo_to_se (&rse, &loop);
1727 lse.ss = loop.temp_ss;
1728 gfc_mark_ss_chain_used (rss, 1);
1729 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1731 /* Start the scalarized loop body. */
1732 gfc_start_scalarized_body (&loop, &body);
1734 /* Translate the expression. */
1735 gfc_conv_expr (&rse, expr);
1737 gfc_conv_tmp_array_ref (&lse);
1738 gfc_advance_se_ss_chain (&lse);
1740 if (intent != INTENT_OUT)
1742 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1743 gfc_add_expr_to_block (&body, tmp);
1744 gcc_assert (rse.ss == gfc_ss_terminator);
1745 gfc_trans_scalarizing_loops (&loop, &body);
1749 /* Make sure that the temporary declaration survives by merging
1750 all the loop declarations into the current context. */
1751 for (n = 0; n < loop.dimen; n++)
1753 gfc_merge_block_scope (&body);
1754 body = loop.code[loop.order[n]];
1756 gfc_merge_block_scope (&body);
1759 /* Add the post block after the second loop, so that any
1760 freeing of allocated memory is done at the right time. */
1761 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1763 /**********Copy the temporary back again.*********/
1765 gfc_init_se (&lse, NULL);
1766 gfc_init_se (&rse, NULL);
1768 /* Walk the argument expression. */
1769 lss = gfc_walk_expr (expr);
1770 rse.ss = loop.temp_ss;
1773 /* Initialize the scalarizer. */
1774 gfc_init_loopinfo (&loop2);
1775 gfc_add_ss_to_loop (&loop2, lss);
1777 /* Calculate the bounds of the scalarization. */
1778 gfc_conv_ss_startstride (&loop2);
1780 /* Setup the scalarizing loops. */
1781 gfc_conv_loop_setup (&loop2);
1783 gfc_copy_loopinfo_to_se (&lse, &loop2);
1784 gfc_copy_loopinfo_to_se (&rse, &loop2);
1786 gfc_mark_ss_chain_used (lss, 1);
1787 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1789 /* Declare the variable to hold the temporary offset and start the
1790 scalarized loop body. */
1791 offset = gfc_create_var (gfc_array_index_type, NULL);
1792 gfc_start_scalarized_body (&loop2, &body);
1794 /* Build the offsets for the temporary from the loop variables. The
1795 temporary array has lbounds of zero and strides of one in all
1796 dimensions, so this is very simple. The offset is only computed
1797 outside the innermost loop, so the overall transfer could be
1798 optimized further. */
1799 info = &rse.ss->data.info;
1801 tmp_index = gfc_index_zero_node;
1802 for (n = info->dimen - 1; n > 0; n--)
1805 tmp = rse.loop->loopvar[n];
1806 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1807 tmp, rse.loop->from[n]);
1808 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1811 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1812 rse.loop->to[n-1], rse.loop->from[n-1]);
1813 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1814 tmp_str, gfc_index_one_node);
1816 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1820 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1821 tmp_index, rse.loop->from[0]);
1822 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1824 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1825 rse.loop->loopvar[0], offset);
1827 /* Now use the offset for the reference. */
1828 tmp = build_fold_indirect_ref (info->data);
1829 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1831 if (expr->ts.type == BT_CHARACTER)
1832 rse.string_length = expr->ts.cl->backend_decl;
1834 gfc_conv_expr (&lse, expr);
1836 gcc_assert (lse.ss == gfc_ss_terminator);
1838 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1839 gfc_add_expr_to_block (&body, tmp);
1841 /* Generate the copying loops. */
1842 gfc_trans_scalarizing_loops (&loop2, &body);
1844 /* Wrap the whole thing up by adding the second loop to the post-block
1845 and following it by the post-block of the first loop. In this way,
1846 if the temporary needs freeing, it is done after use! */
1847 if (intent != INTENT_IN)
1849 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1850 gfc_add_block_to_block (&parmse->post, &loop2.post);
1853 gfc_add_block_to_block (&parmse->post, &loop.post);
1855 gfc_cleanup_loop (&loop);
1856 gfc_cleanup_loop (&loop2);
1858 /* Pass the string length to the argument expression. */
1859 if (expr->ts.type == BT_CHARACTER)
1860 parmse->string_length = expr->ts.cl->backend_decl;
1862 /* We want either the address for the data or the address of the descriptor,
1863 depending on the mode of passing array arguments. */
1865 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1867 parmse->expr = build_fold_addr_expr (parmse->expr);
1872 /* Is true if an array reference is followed by a component or substring
1876 is_aliased_array (gfc_expr * e)
1882 for (ref = e->ref; ref; ref = ref->next)
1884 if (ref->type == REF_ARRAY
1885 && ref->u.ar.type != AR_ELEMENT)
1889 && ref->type != REF_ARRAY)
1895 /* Generate code for a procedure call. Note can return se->post != NULL.
1896 If se->direct_byref is set then se->expr contains the return parameter.
1897 Return nonzero, if the call has alternate specifiers. */
1900 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1901 gfc_actual_arglist * arg, tree append_args)
1903 gfc_interface_mapping mapping;
1917 gfc_formal_arglist *formal;
1918 int has_alternate_specifier = 0;
1919 bool need_interface_mapping;
1926 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1928 arglist = NULL_TREE;
1929 retargs = NULL_TREE;
1930 stringargs = NULL_TREE;
1936 if (!sym->attr.elemental)
1938 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1939 if (se->ss->useflags)
1941 gcc_assert (gfc_return_by_reference (sym)
1942 && sym->result->attr.dimension);
1943 gcc_assert (se->loop != NULL);
1945 /* Access the previously obtained result. */
1946 gfc_conv_tmp_array_ref (se);
1947 gfc_advance_se_ss_chain (se);
1951 info = &se->ss->data.info;
1956 gfc_init_block (&post);
1957 gfc_init_interface_mapping (&mapping);
1958 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1959 && sym->ts.cl->length
1960 && sym->ts.cl->length->expr_type
1962 || sym->attr.dimension);
1963 formal = sym->formal;
1964 /* Evaluate the arguments. */
1965 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1968 fsym = formal ? formal->sym : NULL;
1969 parm_kind = MISSING;
1973 if (se->ignore_optional)
1975 /* Some intrinsics have already been resolved to the correct
1979 else if (arg->label)
1981 has_alternate_specifier = 1;
1986 /* Pass a NULL pointer for an absent arg. */
1987 gfc_init_se (&parmse, NULL);
1988 parmse.expr = null_pointer_node;
1989 if (arg->missing_arg_type == BT_CHARACTER)
1990 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
1993 else if (se->ss && se->ss->useflags)
1995 /* An elemental function inside a scalarized loop. */
1996 gfc_init_se (&parmse, se);
1997 gfc_conv_expr_reference (&parmse, e);
1998 parm_kind = ELEMENTAL;
2002 /* A scalar or transformational function. */
2003 gfc_init_se (&parmse, NULL);
2004 argss = gfc_walk_expr (e);
2006 if (argss == gfc_ss_terminator)
2008 gfc_conv_expr_reference (&parmse, e);
2010 if (fsym && fsym->attr.pointer
2011 && e->expr_type != EXPR_NULL)
2013 /* Scalar pointer dummy args require an extra level of
2014 indirection. The null pointer already contains
2015 this level of indirection. */
2016 parm_kind = SCALAR_POINTER;
2017 parmse.expr = build_fold_addr_expr (parmse.expr);
2022 /* If the procedure requires an explicit interface, the actual
2023 argument is passed according to the corresponding formal
2024 argument. If the corresponding formal argument is a POINTER,
2025 ALLOCATABLE or assumed shape, we do not use g77's calling
2026 convention, and pass the address of the array descriptor
2027 instead. Otherwise we use g77's calling convention. */
2030 && !(fsym->attr.pointer || fsym->attr.allocatable)
2031 && fsym->as->type != AS_ASSUMED_SHAPE;
2032 f = f || !sym->attr.always_explicit;
2034 if (e->expr_type == EXPR_VARIABLE
2035 && is_aliased_array (e))
2036 /* The actual argument is a component reference to an
2037 array of derived types. In this case, the argument
2038 is converted to a temporary, which is passed and then
2039 written back after the procedure call. */
2040 gfc_conv_aliased_arg (&parmse, e, f,
2041 fsym ? fsym->attr.intent : INTENT_INOUT);
2043 gfc_conv_array_parameter (&parmse, e, argss, f);
2045 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2046 allocated on entry, it must be deallocated. */
2047 if (fsym && fsym->attr.allocatable
2048 && fsym->attr.intent == INTENT_OUT)
2050 tmp = e->symtree->n.sym->backend_decl;
2051 if (e->symtree->n.sym->attr.dummy)
2052 tmp = build_fold_indirect_ref (tmp);
2053 tmp = gfc_trans_dealloc_allocated (tmp);
2054 gfc_add_expr_to_block (&se->pre, tmp);
2064 /* If an optional argument is itself an optional dummy
2065 argument, check its presence and substitute a null
2067 if (e->expr_type == EXPR_VARIABLE
2068 && e->symtree->n.sym->attr.optional
2069 && fsym->attr.optional)
2070 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2072 /* If an INTENT(OUT) dummy of derived type has a default
2073 initializer, it must be (re)initialized here. */
2074 if (fsym->attr.intent == INTENT_OUT
2075 && fsym->ts.type == BT_DERIVED
2078 gcc_assert (!fsym->attr.allocatable);
2079 tmp = gfc_trans_assignment (e, fsym->value, false);
2080 gfc_add_expr_to_block (&se->pre, tmp);
2083 /* Obtain the character length of an assumed character
2084 length procedure from the typespec. */
2085 if (fsym->ts.type == BT_CHARACTER
2086 && parmse.string_length == NULL_TREE
2087 && e->ts.type == BT_PROCEDURE
2088 && e->symtree->n.sym->ts.type == BT_CHARACTER
2089 && e->symtree->n.sym->ts.cl->length != NULL)
2091 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2092 parmse.string_length
2093 = e->symtree->n.sym->ts.cl->backend_decl;
2097 if (need_interface_mapping)
2098 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2101 gfc_add_block_to_block (&se->pre, &parmse.pre);
2102 gfc_add_block_to_block (&post, &parmse.post);
2104 /* Allocated allocatable components of derived types must be
2105 deallocated for INTENT(OUT) dummy arguments and non-variable
2106 scalars. Non-variable arrays are dealt with in trans-array.c
2107 (gfc_conv_array_parameter). */
2108 if (e && e->ts.type == BT_DERIVED
2109 && e->ts.derived->attr.alloc_comp
2110 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2112 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2115 tmp = build_fold_indirect_ref (parmse.expr);
2116 parm_rank = e->rank;
2124 case (SCALAR_POINTER):
2125 tmp = build_fold_indirect_ref (tmp);
2132 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2133 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2134 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2135 tmp, build_empty_stmt ());
2137 if (e->expr_type != EXPR_VARIABLE)
2138 /* Don't deallocate non-variables until they have been used. */
2139 gfc_add_expr_to_block (&se->post, tmp);
2142 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2143 gfc_add_expr_to_block (&se->pre, tmp);
2147 /* Character strings are passed as two parameters, a length and a
2149 if (parmse.string_length != NULL_TREE)
2150 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2152 arglist = gfc_chainon_list (arglist, parmse.expr);
2154 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2157 if (ts.type == BT_CHARACTER)
2159 if (sym->ts.cl->length == NULL)
2161 /* Assumed character length results are not allowed by 5.1.1.5 of the
2162 standard and are trapped in resolve.c; except in the case of SPREAD
2163 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2164 we take the character length of the first argument for the result.
2165 For dummies, we have to look through the formal argument list for
2166 this function and use the character length found there.*/
2167 if (!sym->attr.dummy)
2168 cl.backend_decl = TREE_VALUE (stringargs);
2171 formal = sym->ns->proc_name->formal;
2172 for (; formal; formal = formal->next)
2173 if (strcmp (formal->sym->name, sym->name) == 0)
2174 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2179 /* Calculate the length of the returned string. */
2180 gfc_init_se (&parmse, NULL);
2181 if (need_interface_mapping)
2182 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2184 gfc_conv_expr (&parmse, sym->ts.cl->length);
2185 gfc_add_block_to_block (&se->pre, &parmse.pre);
2186 gfc_add_block_to_block (&se->post, &parmse.post);
2187 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
2190 /* Set up a charlen structure for it. */
2195 len = cl.backend_decl;
2198 byref = gfc_return_by_reference (sym);
2201 if (se->direct_byref)
2202 retargs = gfc_chainon_list (retargs, se->expr);
2203 else if (sym->result->attr.dimension)
2205 gcc_assert (se->loop && info);
2207 /* Set the type of the array. */
2208 tmp = gfc_typenode_for_spec (&ts);
2209 info->dimen = se->loop->dimen;
2211 /* Evaluate the bounds of the result, if known. */
2212 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2214 /* Create a temporary to store the result. In case the function
2215 returns a pointer, the temporary will be a shallow copy and
2216 mustn't be deallocated. */
2217 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2218 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2219 false, !sym->attr.pointer, callee_alloc,
2222 /* Pass the temporary as the first argument. */
2223 tmp = info->descriptor;
2224 tmp = build_fold_addr_expr (tmp);
2225 retargs = gfc_chainon_list (retargs, tmp);
2227 else if (ts.type == BT_CHARACTER)
2229 /* Pass the string length. */
2230 type = gfc_get_character_type (ts.kind, ts.cl);
2231 type = build_pointer_type (type);
2233 /* Return an address to a char[0:len-1]* temporary for
2234 character pointers. */
2235 if (sym->attr.pointer || sym->attr.allocatable)
2237 /* Build char[0:len-1] * pstr. */
2238 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2239 build_int_cst (gfc_charlen_type_node, 1));
2240 tmp = build_range_type (gfc_array_index_type,
2241 gfc_index_zero_node, tmp);
2242 tmp = build_array_type (gfc_character1_type_node, tmp);
2243 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2245 /* Provide an address expression for the function arguments. */
2246 var = build_fold_addr_expr (var);
2249 var = gfc_conv_string_tmp (se, type, len);
2251 retargs = gfc_chainon_list (retargs, var);
2255 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2257 type = gfc_get_complex_type (ts.kind);
2258 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2259 retargs = gfc_chainon_list (retargs, var);
2262 /* Add the string length to the argument list. */
2263 if (ts.type == BT_CHARACTER)
2264 retargs = gfc_chainon_list (retargs, len);
2266 gfc_free_interface_mapping (&mapping);
2268 /* Add the return arguments. */
2269 arglist = chainon (retargs, arglist);
2271 /* Add the hidden string length parameters to the arguments. */
2272 arglist = chainon (arglist, stringargs);
2274 /* We may want to append extra arguments here. This is used e.g. for
2275 calls to libgfortran_matmul_??, which need extra information. */
2276 if (append_args != NULL_TREE)
2277 arglist = chainon (arglist, append_args);
2279 /* Generate the actual call. */
2280 gfc_conv_function_val (se, sym);
2281 /* If there are alternate return labels, function type should be
2282 integer. Can't modify the type in place though, since it can be shared
2283 with other functions. */
2284 if (has_alternate_specifier
2285 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2287 gcc_assert (! sym->attr.dummy);
2288 TREE_TYPE (sym->backend_decl)
2289 = build_function_type (integer_type_node,
2290 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2291 se->expr = build_fold_addr_expr (sym->backend_decl);
2294 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2295 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2296 arglist, NULL_TREE);
2298 /* If we have a pointer function, but we don't want a pointer, e.g.
2301 where f is pointer valued, we have to dereference the result. */
2302 if (!se->want_pointer && !byref && sym->attr.pointer)
2303 se->expr = build_fold_indirect_ref (se->expr);
2305 /* f2c calling conventions require a scalar default real function to
2306 return a double precision result. Convert this back to default
2307 real. We only care about the cases that can happen in Fortran 77.
2309 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2310 && sym->ts.kind == gfc_default_real_kind
2311 && !sym->attr.always_explicit)
2312 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2314 /* A pure function may still have side-effects - it may modify its
2316 TREE_SIDE_EFFECTS (se->expr) = 1;
2318 if (!sym->attr.pure)
2319 TREE_SIDE_EFFECTS (se->expr) = 1;
2324 /* Add the function call to the pre chain. There is no expression. */
2325 gfc_add_expr_to_block (&se->pre, se->expr);
2326 se->expr = NULL_TREE;
2328 if (!se->direct_byref)
2330 if (sym->attr.dimension)
2332 if (flag_bounds_check)
2334 /* Check the data pointer hasn't been modified. This would
2335 happen in a function returning a pointer. */
2336 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2337 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2339 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2341 se->expr = info->descriptor;
2342 /* Bundle in the string length. */
2343 se->string_length = len;
2345 else if (sym->ts.type == BT_CHARACTER)
2347 /* Dereference for character pointer results. */
2348 if (sym->attr.pointer || sym->attr.allocatable)
2349 se->expr = build_fold_indirect_ref (var);
2353 se->string_length = len;
2357 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2358 se->expr = build_fold_indirect_ref (var);
2363 /* Follow the function call with the argument post block. */
2365 gfc_add_block_to_block (&se->pre, &post);
2367 gfc_add_block_to_block (&se->post, &post);
2369 return has_alternate_specifier;
2373 /* Generate code to copy a string. */
2376 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2377 tree slength, tree src)
2379 tree tmp, dlen, slen;
2387 stmtblock_t tempblock;
2389 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2390 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2392 /* Deal with single character specially. */
2393 dsc = gfc_to_single_character (dlen, dest);
2394 ssc = gfc_to_single_character (slen, src);
2395 if (dsc != NULL_TREE && ssc != NULL_TREE)
2397 gfc_add_modify_expr (block, dsc, ssc);
2401 /* Do nothing if the destination length is zero. */
2402 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2403 build_int_cst (gfc_charlen_type_node, 0));
2405 /* The following code was previously in _gfortran_copy_string:
2407 // The two strings may overlap so we use memmove.
2409 copy_string (GFC_INTEGER_4 destlen, char * dest,
2410 GFC_INTEGER_4 srclen, const char * src)
2412 if (srclen >= destlen)
2414 // This will truncate if too long.
2415 memmove (dest, src, destlen);
2419 memmove (dest, src, srclen);
2421 memset (&dest[srclen], ' ', destlen - srclen);
2425 We're now doing it here for better optimization, but the logic
2428 /* Truncate string if source is too long. */
2429 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2430 tmp2 = gfc_chainon_list (NULL_TREE, dest);
2431 tmp2 = gfc_chainon_list (tmp2, src);
2432 tmp2 = gfc_chainon_list (tmp2, dlen);
2433 tmp2 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp2);
2435 /* Else copy and pad with spaces. */
2436 tmp3 = gfc_chainon_list (NULL_TREE, dest);
2437 tmp3 = gfc_chainon_list (tmp3, src);
2438 tmp3 = gfc_chainon_list (tmp3, slen);
2439 tmp3 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp3);
2441 tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
2442 fold_convert (pchar_type_node, slen));
2443 tmp4 = gfc_chainon_list (NULL_TREE, tmp4);
2444 tmp4 = gfc_chainon_list (tmp4, build_int_cst
2445 (gfc_get_int_type (gfc_c_int_kind),
2446 lang_hooks.to_target_charset (' ')));
2447 tmp4 = gfc_chainon_list (tmp4, fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2449 tmp4 = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], tmp4);
2451 gfc_init_block (&tempblock);
2452 gfc_add_expr_to_block (&tempblock, tmp3);
2453 gfc_add_expr_to_block (&tempblock, tmp4);
2454 tmp3 = gfc_finish_block (&tempblock);
2456 /* The whole copy_string function is there. */
2457 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2458 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2459 gfc_add_expr_to_block (block, tmp);
2463 /* Translate a statement function.
2464 The value of a statement function reference is obtained by evaluating the
2465 expression using the values of the actual arguments for the values of the
2466 corresponding dummy arguments. */
2469 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2473 gfc_formal_arglist *fargs;
2474 gfc_actual_arglist *args;
2477 gfc_saved_var *saved_vars;
2483 sym = expr->symtree->n.sym;
2484 args = expr->value.function.actual;
2485 gfc_init_se (&lse, NULL);
2486 gfc_init_se (&rse, NULL);
2489 for (fargs = sym->formal; fargs; fargs = fargs->next)
2491 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2492 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2494 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2496 /* Each dummy shall be specified, explicitly or implicitly, to be
2498 gcc_assert (fargs->sym->attr.dimension == 0);
2501 /* Create a temporary to hold the value. */
2502 type = gfc_typenode_for_spec (&fsym->ts);
2503 temp_vars[n] = gfc_create_var (type, fsym->name);
2505 if (fsym->ts.type == BT_CHARACTER)
2507 /* Copy string arguments. */
2510 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2511 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2513 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2514 tmp = gfc_build_addr_expr (build_pointer_type (type),
2517 gfc_conv_expr (&rse, args->expr);
2518 gfc_conv_string_parameter (&rse);
2519 gfc_add_block_to_block (&se->pre, &lse.pre);
2520 gfc_add_block_to_block (&se->pre, &rse.pre);
2522 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2524 gfc_add_block_to_block (&se->pre, &lse.post);
2525 gfc_add_block_to_block (&se->pre, &rse.post);
2529 /* For everything else, just evaluate the expression. */
2530 gfc_conv_expr (&lse, args->expr);
2532 gfc_add_block_to_block (&se->pre, &lse.pre);
2533 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2534 gfc_add_block_to_block (&se->pre, &lse.post);
2540 /* Use the temporary variables in place of the real ones. */
2541 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2542 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2544 gfc_conv_expr (se, sym->value);
2546 if (sym->ts.type == BT_CHARACTER)
2548 gfc_conv_const_charlen (sym->ts.cl);
2550 /* Force the expression to the correct length. */
2551 if (!INTEGER_CST_P (se->string_length)
2552 || tree_int_cst_lt (se->string_length,
2553 sym->ts.cl->backend_decl))
2555 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2556 tmp = gfc_create_var (type, sym->name);
2557 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2558 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2559 se->string_length, se->expr);
2562 se->string_length = sym->ts.cl->backend_decl;
2565 /* Restore the original variables. */
2566 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2567 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2568 gfc_free (saved_vars);
2572 /* Translate a function expression. */
2575 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2579 if (expr->value.function.isym)
2581 gfc_conv_intrinsic_function (se, expr);
2585 /* We distinguish statement functions from general functions to improve
2586 runtime performance. */
2587 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2589 gfc_conv_statement_function (se, expr);
2593 /* expr.value.function.esym is the resolved (specific) function symbol for
2594 most functions. However this isn't set for dummy procedures. */
2595 sym = expr->value.function.esym;
2597 sym = expr->symtree->n.sym;
2598 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2603 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2605 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2606 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2608 gfc_conv_tmp_array_ref (se);
2609 gfc_advance_se_ss_chain (se);
2613 /* Build a static initializer. EXPR is the expression for the initial value.
2614 The other parameters describe the variable of the component being
2615 initialized. EXPR may be null. */
2618 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2619 bool array, bool pointer)
2623 if (!(expr || pointer))
2628 /* Arrays need special handling. */
2630 return gfc_build_null_descriptor (type);
2632 return gfc_conv_array_initializer (type, expr);
2635 return fold_convert (type, null_pointer_node);
2641 gfc_init_se (&se, NULL);
2642 gfc_conv_structure (&se, expr, 1);
2646 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2649 gfc_init_se (&se, NULL);
2650 gfc_conv_constant (&se, expr);
2657 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2669 gfc_start_block (&block);
2671 /* Initialize the scalarizer. */
2672 gfc_init_loopinfo (&loop);
2674 gfc_init_se (&lse, NULL);
2675 gfc_init_se (&rse, NULL);
2678 rss = gfc_walk_expr (expr);
2679 if (rss == gfc_ss_terminator)
2681 /* The rhs is scalar. Add a ss for the expression. */
2682 rss = gfc_get_ss ();
2683 rss->next = gfc_ss_terminator;
2684 rss->type = GFC_SS_SCALAR;
2688 /* Create a SS for the destination. */
2689 lss = gfc_get_ss ();
2690 lss->type = GFC_SS_COMPONENT;
2692 lss->shape = gfc_get_shape (cm->as->rank);
2693 lss->next = gfc_ss_terminator;
2694 lss->data.info.dimen = cm->as->rank;
2695 lss->data.info.descriptor = dest;
2696 lss->data.info.data = gfc_conv_array_data (dest);
2697 lss->data.info.offset = gfc_conv_array_offset (dest);
2698 for (n = 0; n < cm->as->rank; n++)
2700 lss->data.info.dim[n] = n;
2701 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2702 lss->data.info.stride[n] = gfc_index_one_node;
2704 mpz_init (lss->shape[n]);
2705 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2706 cm->as->lower[n]->value.integer);
2707 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2710 /* Associate the SS with the loop. */
2711 gfc_add_ss_to_loop (&loop, lss);
2712 gfc_add_ss_to_loop (&loop, rss);
2714 /* Calculate the bounds of the scalarization. */
2715 gfc_conv_ss_startstride (&loop);
2717 /* Setup the scalarizing loops. */
2718 gfc_conv_loop_setup (&loop);
2720 /* Setup the gfc_se structures. */
2721 gfc_copy_loopinfo_to_se (&lse, &loop);
2722 gfc_copy_loopinfo_to_se (&rse, &loop);
2725 gfc_mark_ss_chain_used (rss, 1);
2727 gfc_mark_ss_chain_used (lss, 1);
2729 /* Start the scalarized loop body. */
2730 gfc_start_scalarized_body (&loop, &body);
2732 gfc_conv_tmp_array_ref (&lse);
2733 if (cm->ts.type == BT_CHARACTER)
2734 lse.string_length = cm->ts.cl->backend_decl;
2736 gfc_conv_expr (&rse, expr);
2738 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2739 gfc_add_expr_to_block (&body, tmp);
2741 gcc_assert (rse.ss == gfc_ss_terminator);
2743 /* Generate the copying loops. */
2744 gfc_trans_scalarizing_loops (&loop, &body);
2746 /* Wrap the whole thing up. */
2747 gfc_add_block_to_block (&block, &loop.pre);
2748 gfc_add_block_to_block (&block, &loop.post);
2750 for (n = 0; n < cm->as->rank; n++)
2751 mpz_clear (lss->shape[n]);
2752 gfc_free (lss->shape);
2754 gfc_cleanup_loop (&loop);
2756 return gfc_finish_block (&block);
2760 /* Assign a single component of a derived type constructor. */
2763 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2773 gfc_start_block (&block);
2777 gfc_init_se (&se, NULL);
2778 /* Pointer component. */
2781 /* Array pointer. */
2782 if (expr->expr_type == EXPR_NULL)
2783 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2786 rss = gfc_walk_expr (expr);
2787 se.direct_byref = 1;
2789 gfc_conv_expr_descriptor (&se, expr, rss);
2790 gfc_add_block_to_block (&block, &se.pre);
2791 gfc_add_block_to_block (&block, &se.post);
2796 /* Scalar pointers. */
2797 se.want_pointer = 1;
2798 gfc_conv_expr (&se, expr);
2799 gfc_add_block_to_block (&block, &se.pre);
2800 gfc_add_modify_expr (&block, dest,
2801 fold_convert (TREE_TYPE (dest), se.expr));
2802 gfc_add_block_to_block (&block, &se.post);
2805 else if (cm->dimension)
2807 if (cm->allocatable && expr->expr_type == EXPR_NULL)
2808 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2809 else if (cm->allocatable)
2813 gfc_init_se (&se, NULL);
2815 rss = gfc_walk_expr (expr);
2816 se.want_pointer = 0;
2817 gfc_conv_expr_descriptor (&se, expr, rss);
2818 gfc_add_block_to_block (&block, &se.pre);
2820 tmp = fold_convert (TREE_TYPE (dest), se.expr);
2821 gfc_add_modify_expr (&block, dest, tmp);
2823 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2824 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2827 tmp = gfc_duplicate_allocatable (dest, se.expr,
2828 TREE_TYPE(cm->backend_decl),
2831 gfc_add_expr_to_block (&block, tmp);
2833 gfc_add_block_to_block (&block, &se.post);
2834 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2836 /* Shift the lbound and ubound of temporaries to being unity, rather
2837 than zero, based. Calculate the offset for all cases. */
2838 offset = gfc_conv_descriptor_offset (dest);
2839 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2840 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2841 for (n = 0; n < expr->rank; n++)
2843 if (expr->expr_type != EXPR_VARIABLE
2844 && expr->expr_type != EXPR_CONSTANT)
2846 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2847 gfc_add_modify_expr (&block, tmp,
2848 fold_build2 (PLUS_EXPR,
2849 gfc_array_index_type,
2850 tmp, gfc_index_one_node));
2851 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2852 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2854 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2855 gfc_conv_descriptor_lbound (dest,
2857 gfc_conv_descriptor_stride (dest,
2859 gfc_add_modify_expr (&block, tmp2, tmp);
2860 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2861 gfc_add_modify_expr (&block, offset, tmp);
2866 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2867 gfc_add_expr_to_block (&block, tmp);
2870 else if (expr->ts.type == BT_DERIVED)
2872 if (expr->expr_type != EXPR_STRUCTURE)
2874 gfc_init_se (&se, NULL);
2875 gfc_conv_expr (&se, expr);
2876 gfc_add_modify_expr (&block, dest,
2877 fold_convert (TREE_TYPE (dest), se.expr));
2881 /* Nested constructors. */
2882 tmp = gfc_trans_structure_assign (dest, expr);
2883 gfc_add_expr_to_block (&block, tmp);
2888 /* Scalar component. */
2889 gfc_init_se (&se, NULL);
2890 gfc_init_se (&lse, NULL);
2892 gfc_conv_expr (&se, expr);
2893 if (cm->ts.type == BT_CHARACTER)
2894 lse.string_length = cm->ts.cl->backend_decl;
2896 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2897 gfc_add_expr_to_block (&block, tmp);
2899 return gfc_finish_block (&block);
2902 /* Assign a derived type constructor to a variable. */
2905 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2913 gfc_start_block (&block);
2914 cm = expr->ts.derived->components;
2915 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2917 /* Skip absent members in default initializers. */
2921 field = cm->backend_decl;
2922 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2923 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2924 gfc_add_expr_to_block (&block, tmp);
2926 return gfc_finish_block (&block);
2929 /* Build an expression for a constructor. If init is nonzero then
2930 this is part of a static variable initializer. */
2933 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2940 VEC(constructor_elt,gc) *v = NULL;
2942 gcc_assert (se->ss == NULL);
2943 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2944 type = gfc_typenode_for_spec (&expr->ts);
2948 /* Create a temporary variable and fill it in. */
2949 se->expr = gfc_create_var (type, expr->ts.derived->name);
2950 tmp = gfc_trans_structure_assign (se->expr, expr);
2951 gfc_add_expr_to_block (&se->pre, tmp);
2955 cm = expr->ts.derived->components;
2957 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2959 /* Skip absent members in default initializers and allocatable
2960 components. Although the latter have a default initializer
2961 of EXPR_NULL,... by default, the static nullify is not needed
2962 since this is done every time we come into scope. */
2963 if (!c->expr || cm->allocatable)
2966 val = gfc_conv_initializer (c->expr, &cm->ts,
2967 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2969 /* Append it to the constructor list. */
2970 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2972 se->expr = build_constructor (type, v);
2976 /* Translate a substring expression. */
2979 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2985 gcc_assert (ref->type == REF_SUBSTRING);
2987 se->expr = gfc_build_string_const(expr->value.character.length,
2988 expr->value.character.string);
2989 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2990 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2992 gfc_conv_substring(se,ref,expr->ts.kind,NULL,&expr->where);
2996 /* Entry point for expression translation. Evaluates a scalar quantity.
2997 EXPR is the expression to be translated, and SE is the state structure if
2998 called from within the scalarized. */
3001 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3003 if (se->ss && se->ss->expr == expr
3004 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3006 /* Substitute a scalar expression evaluated outside the scalarization
3008 se->expr = se->ss->data.scalar.expr;
3009 se->string_length = se->ss->string_length;
3010 gfc_advance_se_ss_chain (se);
3014 switch (expr->expr_type)
3017 gfc_conv_expr_op (se, expr);
3021 gfc_conv_function_expr (se, expr);
3025 gfc_conv_constant (se, expr);
3029 gfc_conv_variable (se, expr);
3033 se->expr = null_pointer_node;
3036 case EXPR_SUBSTRING:
3037 gfc_conv_substring_expr (se, expr);
3040 case EXPR_STRUCTURE:
3041 gfc_conv_structure (se, expr, 0);
3045 gfc_conv_array_constructor_expr (se, expr);
3054 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3055 of an assignment. */
3057 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3059 gfc_conv_expr (se, expr);
3060 /* All numeric lvalues should have empty post chains. If not we need to
3061 figure out a way of rewriting an lvalue so that it has no post chain. */
3062 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3065 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3066 numeric expressions. Used for scalar values where inserting cleanup code
3069 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3073 gcc_assert (expr->ts.type != BT_CHARACTER);
3074 gfc_conv_expr (se, expr);
3077 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3078 gfc_add_modify_expr (&se->pre, val, se->expr);
3080 gfc_add_block_to_block (&se->pre, &se->post);
3084 /* Helper to translate and expression and convert it to a particular type. */
3086 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3088 gfc_conv_expr_val (se, expr);
3089 se->expr = convert (type, se->expr);
3093 /* Converts an expression so that it can be passed by reference. Scalar
3097 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3101 if (se->ss && se->ss->expr == expr
3102 && se->ss->type == GFC_SS_REFERENCE)
3104 se->expr = se->ss->data.scalar.expr;
3105 se->string_length = se->ss->string_length;
3106 gfc_advance_se_ss_chain (se);
3110 if (expr->ts.type == BT_CHARACTER)
3112 gfc_conv_expr (se, expr);
3113 gfc_conv_string_parameter (se);
3117 if (expr->expr_type == EXPR_VARIABLE)
3119 se->want_pointer = 1;
3120 gfc_conv_expr (se, expr);
3123 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3124 gfc_add_modify_expr (&se->pre, var, se->expr);
3125 gfc_add_block_to_block (&se->pre, &se->post);
3131 gfc_conv_expr (se, expr);
3133 /* Create a temporary var to hold the value. */
3134 if (TREE_CONSTANT (se->expr))
3136 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
3137 DECL_INITIAL (var) = se->expr;
3138 TREE_STATIC (var) = 1;
3143 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3144 gfc_add_modify_expr (&se->pre, var, se->expr);
3146 gfc_add_block_to_block (&se->pre, &se->post);
3148 /* Take the address of that value. */
3149 se->expr = build_fold_addr_expr (var);
3154 gfc_trans_pointer_assign (gfc_code * code)
3156 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3160 /* Generate code for a pointer assignment. */
3163 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3173 gfc_start_block (&block);
3175 gfc_init_se (&lse, NULL);
3177 lss = gfc_walk_expr (expr1);
3178 rss = gfc_walk_expr (expr2);
3179 if (lss == gfc_ss_terminator)
3181 /* Scalar pointers. */
3182 lse.want_pointer = 1;
3183 gfc_conv_expr (&lse, expr1);
3184 gcc_assert (rss == gfc_ss_terminator);
3185 gfc_init_se (&rse, NULL);
3186 rse.want_pointer = 1;
3187 gfc_conv_expr (&rse, expr2);
3188 gfc_add_block_to_block (&block, &lse.pre);
3189 gfc_add_block_to_block (&block, &rse.pre);
3190 gfc_add_modify_expr (&block, lse.expr,
3191 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3192 gfc_add_block_to_block (&block, &rse.post);
3193 gfc_add_block_to_block (&block, &lse.post);
3197 /* Array pointer. */
3198 gfc_conv_expr_descriptor (&lse, expr1, lss);
3199 switch (expr2->expr_type)
3202 /* Just set the data pointer to null. */
3203 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3207 /* Assign directly to the pointer's descriptor. */
3208 lse.direct_byref = 1;
3209 gfc_conv_expr_descriptor (&lse, expr2, rss);
3213 /* Assign to a temporary descriptor and then copy that
3214 temporary to the pointer. */
3216 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3219 lse.direct_byref = 1;
3220 gfc_conv_expr_descriptor (&lse, expr2, rss);
3221 gfc_add_modify_expr (&lse.pre, desc, tmp);
3224 gfc_add_block_to_block (&block, &lse.pre);
3225 gfc_add_block_to_block (&block, &lse.post);
3227 return gfc_finish_block (&block);
3231 /* Makes sure se is suitable for passing as a function string parameter. */
3232 /* TODO: Need to check all callers fo this function. It may be abused. */
3235 gfc_conv_string_parameter (gfc_se * se)
3239 if (TREE_CODE (se->expr) == STRING_CST)
3241 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3245 type = TREE_TYPE (se->expr);
3246 if (TYPE_STRING_FLAG (type))
3248 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3249 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3252 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3253 gcc_assert (se->string_length
3254 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3258 /* Generate code for assignment of scalar variables. Includes character
3259 strings and derived types with allocatable components. */
3262 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3263 bool l_is_temp, bool r_is_var)
3269 gfc_init_block (&block);
3271 if (ts.type == BT_CHARACTER)
3273 gcc_assert (lse->string_length != NULL_TREE
3274 && rse->string_length != NULL_TREE);
3276 gfc_conv_string_parameter (lse);
3277 gfc_conv_string_parameter (rse);
3279 gfc_add_block_to_block (&block, &lse->pre);
3280 gfc_add_block_to_block (&block, &rse->pre);
3282 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3283 rse->string_length, rse->expr);
3285 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3289 /* Are the rhs and the lhs the same? */
3292 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3293 build_fold_addr_expr (lse->expr),
3294 build_fold_addr_expr (rse->expr));
3295 cond = gfc_evaluate_now (cond, &lse->pre);
3298 /* Deallocate the lhs allocated components as long as it is not
3299 the same as the rhs. */
3302 tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3304 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3305 gfc_add_expr_to_block (&lse->pre, tmp);
3308 gfc_add_block_to_block (&block, &lse->pre);
3309 gfc_add_block_to_block (&block, &rse->pre);
3311 gfc_add_modify_expr (&block, lse->expr,
3312 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3314 /* Do a deep copy if the rhs is a variable, if it is not the
3318 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3319 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3320 gfc_add_expr_to_block (&block, tmp);
3325 gfc_add_block_to_block (&block, &lse->pre);
3326 gfc_add_block_to_block (&block, &rse->pre);
3328 gfc_add_modify_expr (&block, lse->expr,
3329 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3332 gfc_add_block_to_block (&block, &lse->post);
3333 gfc_add_block_to_block (&block, &rse->post);
3335 return gfc_finish_block (&block);
3339 /* Try to translate array(:) = func (...), where func is a transformational
3340 array function, without using a temporary. Returns NULL is this isn't the
3344 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3349 bool seen_array_ref;
3351 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3352 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3355 /* Elemental functions don't need a temporary anyway. */
3356 if (expr2->value.function.esym != NULL
3357 && expr2->value.function.esym->attr.elemental)
3360 /* Fail if EXPR1 can't be expressed as a descriptor. */
3361 if (gfc_ref_needs_temporary_p (expr1->ref))
3364 /* Functions returning pointers need temporaries. */
3365 if (expr2->symtree->n.sym->attr.pointer
3366 || expr2->symtree->n.sym->attr.allocatable)
3369 /* Check that no LHS component references appear during an array
3370 reference. This is needed because we do not have the means to
3371 span any arbitrary stride with an array descriptor. This check
3372 is not needed for the rhs because the function result has to be
3374 seen_array_ref = false;
3375 for (ref = expr1->ref; ref; ref = ref->next)
3377 if (ref->type == REF_ARRAY)
3378 seen_array_ref= true;
3379 else if (ref->type == REF_COMPONENT && seen_array_ref)
3383 /* Check for a dependency. */
3384 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3385 expr2->value.function.esym,
3386 expr2->value.function.actual))
3389 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3391 gcc_assert (expr2->value.function.isym
3392 || (gfc_return_by_reference (expr2->value.function.esym)
3393 && expr2->value.function.esym->result->attr.dimension));
3395 ss = gfc_walk_expr (expr1);
3396 gcc_assert (ss != gfc_ss_terminator);
3397 gfc_init_se (&se, NULL);
3398 gfc_start_block (&se.pre);
3399 se.want_pointer = 1;
3401 gfc_conv_array_parameter (&se, expr1, ss, 0);
3403 se.direct_byref = 1;
3404 se.ss = gfc_walk_expr (expr2);
3405 gcc_assert (se.ss != gfc_ss_terminator);
3406 gfc_conv_function_expr (&se, expr2);
3407 gfc_add_block_to_block (&se.pre, &se.post);
3409 return gfc_finish_block (&se.pre);
3413 /* Translate an assignment. Most of the code is concerned with
3414 setting up the scalarizer. */
3417 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3422 gfc_ss *lss_section;
3430 /* Special case a single function returning an array. */
3431 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3433 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3438 /* Assignment of the form lhs = rhs. */
3439 gfc_start_block (&block);
3441 gfc_init_se (&lse, NULL);
3442 gfc_init_se (&rse, NULL);
3445 lss = gfc_walk_expr (expr1);
3447 if (lss != gfc_ss_terminator)
3449 /* The assignment needs scalarization. */
3452 /* Find a non-scalar SS from the lhs. */
3453 while (lss_section != gfc_ss_terminator
3454 && lss_section->type != GFC_SS_SECTION)
3455 lss_section = lss_section->next;
3457 gcc_assert (lss_section != gfc_ss_terminator);
3459 /* Initialize the scalarizer. */
3460 gfc_init_loopinfo (&loop);
3463 rss = gfc_walk_expr (expr2);
3464 if (rss == gfc_ss_terminator)
3466 /* The rhs is scalar. Add a ss for the expression. */
3467 rss = gfc_get_ss ();
3468 rss->next = gfc_ss_terminator;
3469 rss->type = GFC_SS_SCALAR;
3472 /* Associate the SS with the loop. */
3473 gfc_add_ss_to_loop (&loop, lss);
3474 gfc_add_ss_to_loop (&loop, rss);
3476 /* Calculate the bounds of the scalarization. */
3477 gfc_conv_ss_startstride (&loop);
3478 /* Resolve any data dependencies in the statement. */
3479 gfc_conv_resolve_dependencies (&loop, lss, rss);
3480 /* Setup the scalarizing loops. */
3481 gfc_conv_loop_setup (&loop);
3483 /* Setup the gfc_se structures. */
3484 gfc_copy_loopinfo_to_se (&lse, &loop);
3485 gfc_copy_loopinfo_to_se (&rse, &loop);
3488 gfc_mark_ss_chain_used (rss, 1);
3489 if (loop.temp_ss == NULL)
3492 gfc_mark_ss_chain_used (lss, 1);
3496 lse.ss = loop.temp_ss;
3497 gfc_mark_ss_chain_used (lss, 3);
3498 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3501 /* Start the scalarized loop body. */
3502 gfc_start_scalarized_body (&loop, &body);
3505 gfc_init_block (&body);
3507 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3509 /* Translate the expression. */
3510 gfc_conv_expr (&rse, expr2);
3514 gfc_conv_tmp_array_ref (&lse);
3515 gfc_advance_se_ss_chain (&lse);
3518 gfc_conv_expr (&lse, expr1);
3520 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3521 l_is_temp || init_flag,
3522 expr2->expr_type == EXPR_VARIABLE);
3523 gfc_add_expr_to_block (&body, tmp);
3525 if (lss == gfc_ss_terminator)
3527 /* Use the scalar assignment as is. */
3528 gfc_add_block_to_block (&block, &body);
3532 gcc_assert (lse.ss == gfc_ss_terminator
3533 && rse.ss == gfc_ss_terminator);
3537 gfc_trans_scalarized_loop_boundary (&loop, &body);
3539 /* We need to copy the temporary to the actual lhs. */
3540 gfc_init_se (&lse, NULL);
3541 gfc_init_se (&rse, NULL);
3542 gfc_copy_loopinfo_to_se (&lse, &loop);
3543 gfc_copy_loopinfo_to_se (&rse, &loop);
3545 rse.ss = loop.temp_ss;
3548 gfc_conv_tmp_array_ref (&rse);
3549 gfc_advance_se_ss_chain (&rse);
3550 gfc_conv_expr (&lse, expr1);
3552 gcc_assert (lse.ss == gfc_ss_terminator
3553 && rse.ss == gfc_ss_terminator);
3555 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3557 gfc_add_expr_to_block (&body, tmp);
3560 /* Generate the copying loops. */
3561 gfc_trans_scalarizing_loops (&loop, &body);
3563 /* Wrap the whole thing up. */
3564 gfc_add_block_to_block (&block, &loop.pre);
3565 gfc_add_block_to_block (&block, &loop.post);
3567 gfc_cleanup_loop (&loop);
3570 return gfc_finish_block (&block);
3574 gfc_trans_init_assign (gfc_code * code)
3576 return gfc_trans_assignment (code->expr, code->expr2, true);
3580 gfc_trans_assign (gfc_code * code)
3582 return gfc_trans_assignment (code->expr, code->expr2, false);