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)
245 type = gfc_get_character_type (kind, ref->u.ss.length);
246 type = build_pointer_type (type);
249 gfc_init_se (&start, se);
250 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
251 gfc_add_block_to_block (&se->pre, &start.pre);
253 if (integer_onep (start.expr))
254 gfc_conv_string_parameter (se);
257 /* Change the start of the string. */
258 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
261 tmp = build_fold_indirect_ref (se->expr);
262 tmp = gfc_build_array_ref (tmp, start.expr);
263 se->expr = gfc_build_addr_expr (type, tmp);
266 /* Length = end + 1 - start. */
267 gfc_init_se (&end, se);
268 if (ref->u.ss.end == NULL)
269 end.expr = se->string_length;
272 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
273 gfc_add_block_to_block (&se->pre, &end.pre);
275 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
276 build_int_cst (gfc_charlen_type_node, 1),
278 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
279 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
280 build_int_cst (gfc_charlen_type_node, 0));
281 se->string_length = tmp;
285 /* Convert a derived type component reference. */
288 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
295 c = ref->u.c.component;
297 gcc_assert (c->backend_decl);
299 field = c->backend_decl;
300 gcc_assert (TREE_CODE (field) == FIELD_DECL);
302 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
306 if (c->ts.type == BT_CHARACTER)
308 tmp = c->ts.cl->backend_decl;
309 /* Components must always be constant length. */
310 gcc_assert (tmp && INTEGER_CST_P (tmp));
311 se->string_length = tmp;
314 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
315 se->expr = build_fold_indirect_ref (se->expr);
319 /* Return the contents of a variable. Also handles reference/pointer
320 variables (all Fortran pointer references are implicit). */
323 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
330 bool alternate_entry;
333 sym = expr->symtree->n.sym;
336 /* Check that something hasn't gone horribly wrong. */
337 gcc_assert (se->ss != gfc_ss_terminator);
338 gcc_assert (se->ss->expr == expr);
340 /* A scalarized term. We already know the descriptor. */
341 se->expr = se->ss->data.info.descriptor;
342 se->string_length = se->ss->string_length;
343 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
344 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
349 tree se_expr = NULL_TREE;
351 se->expr = gfc_get_symbol_decl (sym);
353 /* Deal with references to a parent results or entries by storing
354 the current_function_decl and moving to the parent_decl. */
355 return_value = sym->attr.function && sym->result == sym;
356 alternate_entry = sym->attr.function && sym->attr.entry
357 && sym->result == sym;
358 entry_master = sym->attr.result
359 && sym->ns->proc_name->attr.entry_master
360 && !gfc_return_by_reference (sym->ns->proc_name);
361 parent_decl = DECL_CONTEXT (current_function_decl);
363 if ((se->expr == parent_decl && return_value)
364 || (sym->ns && sym->ns->proc_name
366 && sym->ns->proc_name->backend_decl == parent_decl
367 && (alternate_entry || entry_master)))
372 /* Special case for assigning the return value of a function.
373 Self recursive functions must have an explicit return value. */
374 if (return_value && (se->expr == current_function_decl || parent_flag))
375 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
377 /* Similarly for alternate entry points. */
378 else if (alternate_entry
379 && (sym->ns->proc_name->backend_decl == current_function_decl
382 gfc_entry_list *el = NULL;
384 for (el = sym->ns->entries; el; el = el->next)
387 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
392 else if (entry_master
393 && (sym->ns->proc_name->backend_decl == current_function_decl
395 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
400 /* Procedure actual arguments. */
401 else if (sym->attr.flavor == FL_PROCEDURE
402 && se->expr != current_function_decl)
404 gcc_assert (se->want_pointer);
405 if (!sym->attr.dummy)
407 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
408 se->expr = build_fold_addr_expr (se->expr);
414 /* Dereference the expression, where needed. Since characters
415 are entirely different from other types, they are treated
417 if (sym->ts.type == BT_CHARACTER)
419 /* Dereference character pointer dummy arguments
421 if ((sym->attr.pointer || sym->attr.allocatable)
423 || sym->attr.function
424 || sym->attr.result))
425 se->expr = build_fold_indirect_ref (se->expr);
429 /* Dereference non-character scalar dummy arguments. */
430 if (sym->attr.dummy && !sym->attr.dimension)
431 se->expr = build_fold_indirect_ref (se->expr);
433 /* Dereference scalar hidden result. */
434 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
435 && (sym->attr.function || sym->attr.result)
436 && !sym->attr.dimension && !sym->attr.pointer)
437 se->expr = build_fold_indirect_ref (se->expr);
439 /* Dereference non-character pointer variables.
440 These must be dummies, results, or scalars. */
441 if ((sym->attr.pointer || sym->attr.allocatable)
443 || sym->attr.function
445 || !sym->attr.dimension))
446 se->expr = build_fold_indirect_ref (se->expr);
452 /* For character variables, also get the length. */
453 if (sym->ts.type == BT_CHARACTER)
455 /* If the character length of an entry isn't set, get the length from
456 the master function instead. */
457 if (sym->attr.entry && !sym->ts.cl->backend_decl)
458 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
460 se->string_length = sym->ts.cl->backend_decl;
461 gcc_assert (se->string_length);
469 /* Return the descriptor if that's what we want and this is an array
470 section reference. */
471 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
473 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
474 /* Return the descriptor for array pointers and allocations. */
476 && ref->next == NULL && (se->descriptor_only))
479 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
480 /* Return a pointer to an element. */
484 gfc_conv_component_ref (se, ref);
488 gfc_conv_substring (se, ref, expr->ts.kind);
497 /* Pointer assignment, allocation or pass by reference. Arrays are handled
499 if (se->want_pointer)
501 if (expr->ts.type == BT_CHARACTER)
502 gfc_conv_string_parameter (se);
504 se->expr = build_fold_addr_expr (se->expr);
509 /* Unary ops are easy... Or they would be if ! was a valid op. */
512 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
517 gcc_assert (expr->ts.type != BT_CHARACTER);
518 /* Initialize the operand. */
519 gfc_init_se (&operand, se);
520 gfc_conv_expr_val (&operand, expr->value.op.op1);
521 gfc_add_block_to_block (&se->pre, &operand.pre);
523 type = gfc_typenode_for_spec (&expr->ts);
525 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
526 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
527 All other unary operators have an equivalent GIMPLE unary operator. */
528 if (code == TRUTH_NOT_EXPR)
529 se->expr = build2 (EQ_EXPR, type, operand.expr,
530 build_int_cst (type, 0));
532 se->expr = build1 (code, type, operand.expr);
536 /* Expand power operator to optimal multiplications when a value is raised
537 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
538 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
539 Programming", 3rd Edition, 1998. */
541 /* This code is mostly duplicated from expand_powi in the backend.
542 We establish the "optimal power tree" lookup table with the defined size.
543 The items in the table are the exponents used to calculate the index
544 exponents. Any integer n less than the value can get an "addition chain",
545 with the first node being one. */
546 #define POWI_TABLE_SIZE 256
548 /* The table is from builtins.c. */
549 static const unsigned char powi_table[POWI_TABLE_SIZE] =
551 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
552 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
553 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
554 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
555 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
556 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
557 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
558 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
559 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
560 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
561 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
562 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
563 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
564 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
565 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
566 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
567 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
568 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
569 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
570 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
571 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
572 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
573 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
574 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
575 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
576 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
577 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
578 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
579 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
580 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
581 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
582 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
585 /* If n is larger than lookup table's max index, we use the "window
587 #define POWI_WINDOW_SIZE 3
589 /* Recursive function to expand the power operator. The temporary
590 values are put in tmpvar. The function returns tmpvar[1] ** n. */
592 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
599 if (n < POWI_TABLE_SIZE)
604 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
605 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
609 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
610 op0 = gfc_conv_powi (se, n - digit, tmpvar);
611 op1 = gfc_conv_powi (se, digit, tmpvar);
615 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
619 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
620 tmp = gfc_evaluate_now (tmp, &se->pre);
622 if (n < POWI_TABLE_SIZE)
629 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
630 return 1. Else return 0 and a call to runtime library functions
631 will have to be built. */
633 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
638 tree vartmp[POWI_TABLE_SIZE];
642 type = TREE_TYPE (lhs);
643 n = abs (TREE_INT_CST_LOW (rhs));
644 sgn = tree_int_cst_sgn (rhs);
646 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
647 && (n > 2 || n < -1))
653 se->expr = gfc_build_const (type, integer_one_node);
656 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
657 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
659 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
660 build_int_cst (TREE_TYPE (lhs), -1));
661 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
662 build_int_cst (TREE_TYPE (lhs), 1));
665 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
668 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
669 se->expr = build3 (COND_EXPR, type, tmp, build_int_cst (type, 1),
670 build_int_cst (type, 0));
674 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
675 tmp = build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
676 build_int_cst (type, 0));
677 se->expr = build3 (COND_EXPR, type, cond, build_int_cst (type, 1), tmp);
681 memset (vartmp, 0, sizeof (vartmp));
685 tmp = gfc_build_const (type, integer_one_node);
686 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
689 se->expr = gfc_conv_powi (se, n, vartmp);
695 /* Power op (**). Constant integer exponent has special handling. */
698 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
700 tree gfc_int4_type_node;
708 gfc_init_se (&lse, se);
709 gfc_conv_expr_val (&lse, expr->value.op.op1);
710 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
711 gfc_add_block_to_block (&se->pre, &lse.pre);
713 gfc_init_se (&rse, se);
714 gfc_conv_expr_val (&rse, expr->value.op.op2);
715 gfc_add_block_to_block (&se->pre, &rse.pre);
717 if (expr->value.op.op2->ts.type == BT_INTEGER
718 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
719 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
722 gfc_int4_type_node = gfc_get_int_type (4);
724 kind = expr->value.op.op1->ts.kind;
725 switch (expr->value.op.op2->ts.type)
728 ikind = expr->value.op.op2->ts.kind;
733 rse.expr = convert (gfc_int4_type_node, rse.expr);
755 if (expr->value.op.op1->ts.type == BT_INTEGER)
756 lse.expr = convert (gfc_int4_type_node, lse.expr);
781 switch (expr->value.op.op1->ts.type)
784 if (kind == 3) /* Case 16 was not handled properly above. */
786 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
790 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
794 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
806 fndecl = built_in_decls[BUILT_IN_POWF];
809 fndecl = built_in_decls[BUILT_IN_POW];
813 fndecl = built_in_decls[BUILT_IN_POWL];
824 fndecl = gfor_fndecl_math_cpowf;
827 fndecl = gfor_fndecl_math_cpow;
830 fndecl = gfor_fndecl_math_cpowl10;
833 fndecl = gfor_fndecl_math_cpowl16;
845 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
846 tmp = gfc_chainon_list (tmp, rse.expr);
847 se->expr = build_function_call_expr (fndecl, tmp);
851 /* Generate code to allocate a string temporary. */
854 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
860 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
862 if (gfc_can_put_var_on_stack (len))
864 /* Create a temporary variable to hold the result. */
865 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
866 build_int_cst (gfc_charlen_type_node, 1));
867 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
868 tmp = build_array_type (gfc_character1_type_node, tmp);
869 var = gfc_create_var (tmp, "str");
870 var = gfc_build_addr_expr (type, var);
874 /* Allocate a temporary to hold the result. */
875 var = gfc_create_var (type, "pstr");
876 args = gfc_chainon_list (NULL_TREE, len);
877 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
878 tmp = convert (type, tmp);
879 gfc_add_modify_expr (&se->pre, var, tmp);
881 /* Free the temporary afterwards. */
882 tmp = convert (pvoid_type_node, var);
883 args = gfc_chainon_list (NULL_TREE, tmp);
884 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
885 gfc_add_expr_to_block (&se->post, tmp);
892 /* Handle a string concatenation operation. A temporary will be allocated to
896 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
906 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
907 && expr->value.op.op2->ts.type == BT_CHARACTER);
909 gfc_init_se (&lse, se);
910 gfc_conv_expr (&lse, expr->value.op.op1);
911 gfc_conv_string_parameter (&lse);
912 gfc_init_se (&rse, se);
913 gfc_conv_expr (&rse, expr->value.op.op2);
914 gfc_conv_string_parameter (&rse);
916 gfc_add_block_to_block (&se->pre, &lse.pre);
917 gfc_add_block_to_block (&se->pre, &rse.pre);
919 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
920 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
921 if (len == NULL_TREE)
923 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
924 lse.string_length, rse.string_length);
927 type = build_pointer_type (type);
929 var = gfc_conv_string_tmp (se, type, len);
931 /* Do the actual concatenation. */
933 args = gfc_chainon_list (args, len);
934 args = gfc_chainon_list (args, var);
935 args = gfc_chainon_list (args, lse.string_length);
936 args = gfc_chainon_list (args, lse.expr);
937 args = gfc_chainon_list (args, rse.string_length);
938 args = gfc_chainon_list (args, rse.expr);
939 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
940 gfc_add_expr_to_block (&se->pre, tmp);
942 /* Add the cleanup for the operands. */
943 gfc_add_block_to_block (&se->pre, &rse.post);
944 gfc_add_block_to_block (&se->pre, &lse.post);
947 se->string_length = len;
950 /* Translates an op expression. Common (binary) cases are handled by this
951 function, others are passed on. Recursion is used in either case.
952 We use the fact that (op1.ts == op2.ts) (except for the power
954 Operators need no special handling for scalarized expressions as long as
955 they call gfc_conv_simple_val to get their operands.
956 Character strings get special handling. */
959 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
971 switch (expr->value.op.operator)
973 case INTRINSIC_UPLUS:
974 case INTRINSIC_PARENTHESES:
975 gfc_conv_expr (se, expr->value.op.op1);
978 case INTRINSIC_UMINUS:
979 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
983 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
990 case INTRINSIC_MINUS:
994 case INTRINSIC_TIMES:
998 case INTRINSIC_DIVIDE:
999 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1000 an integer, we must round towards zero, so we use a
1002 if (expr->ts.type == BT_INTEGER)
1003 code = TRUNC_DIV_EXPR;
1008 case INTRINSIC_POWER:
1009 gfc_conv_power_op (se, expr);
1012 case INTRINSIC_CONCAT:
1013 gfc_conv_concat_op (se, expr);
1017 code = TRUTH_ANDIF_EXPR;
1022 code = TRUTH_ORIF_EXPR;
1026 /* EQV and NEQV only work on logicals, but since we represent them
1027 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1036 case INTRINSIC_NEQV:
1066 case INTRINSIC_USER:
1067 case INTRINSIC_ASSIGN:
1068 /* These should be converted into function calls by the frontend. */
1072 fatal_error ("Unknown intrinsic op");
1076 /* The only exception to this is **, which is handled separately anyway. */
1077 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1079 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1083 gfc_init_se (&lse, se);
1084 gfc_conv_expr (&lse, expr->value.op.op1);
1085 gfc_add_block_to_block (&se->pre, &lse.pre);
1088 gfc_init_se (&rse, se);
1089 gfc_conv_expr (&rse, expr->value.op.op2);
1090 gfc_add_block_to_block (&se->pre, &rse.pre);
1094 gfc_conv_string_parameter (&lse);
1095 gfc_conv_string_parameter (&rse);
1097 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1098 rse.string_length, rse.expr);
1099 rse.expr = integer_zero_node;
1100 gfc_add_block_to_block (&lse.post, &rse.post);
1103 type = gfc_typenode_for_spec (&expr->ts);
1107 /* The result of logical ops is always boolean_type_node. */
1108 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1109 se->expr = convert (type, tmp);
1112 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1114 /* Add the post blocks. */
1115 gfc_add_block_to_block (&se->post, &rse.post);
1116 gfc_add_block_to_block (&se->post, &lse.post);
1119 /* If a string's length is one, we convert it to a single character. */
1122 gfc_to_single_character (tree len, tree str)
1124 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1126 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1127 && TREE_INT_CST_HIGH (len) == 0)
1129 str = fold_convert (pchar_type_node, str);
1130 return build_fold_indirect_ref (str);
1136 /* Compare two strings. If they are all single characters, the result is the
1137 subtraction of them. Otherwise, we build a library call. */
1140 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1147 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1148 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1150 type = gfc_get_int_type (gfc_default_integer_kind);
1152 sc1 = gfc_to_single_character (len1, str1);
1153 sc2 = gfc_to_single_character (len2, str2);
1155 /* Deal with single character specially. */
1156 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1158 sc1 = fold_convert (type, sc1);
1159 sc2 = fold_convert (type, sc2);
1160 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1165 tmp = gfc_chainon_list (tmp, len1);
1166 tmp = gfc_chainon_list (tmp, str1);
1167 tmp = gfc_chainon_list (tmp, len2);
1168 tmp = gfc_chainon_list (tmp, str2);
1170 /* Build a call for the comparison. */
1171 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1178 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1182 if (sym->attr.dummy)
1184 tmp = gfc_get_symbol_decl (sym);
1185 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1186 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1190 if (!sym->backend_decl)
1191 sym->backend_decl = gfc_get_extern_function_decl (sym);
1193 tmp = sym->backend_decl;
1194 if (sym->attr.cray_pointee)
1195 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1196 gfc_get_symbol_decl (sym->cp_pointer));
1197 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1199 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1200 tmp = build_fold_addr_expr (tmp);
1207 /* Initialize MAPPING. */
1210 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1212 mapping->syms = NULL;
1213 mapping->charlens = NULL;
1217 /* Free all memory held by MAPPING (but not MAPPING itself). */
1220 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1222 gfc_interface_sym_mapping *sym;
1223 gfc_interface_sym_mapping *nextsym;
1225 gfc_charlen *nextcl;
1227 for (sym = mapping->syms; sym; sym = nextsym)
1229 nextsym = sym->next;
1230 gfc_free_symbol (sym->new->n.sym);
1231 gfc_free (sym->new);
1234 for (cl = mapping->charlens; cl; cl = nextcl)
1237 gfc_free_expr (cl->length);
1243 /* Return a copy of gfc_charlen CL. Add the returned structure to
1244 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1246 static gfc_charlen *
1247 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1252 new = gfc_get_charlen ();
1253 new->next = mapping->charlens;
1254 new->length = gfc_copy_expr (cl->length);
1256 mapping->charlens = new;
1261 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1262 array variable that can be used as the actual argument for dummy
1263 argument SYM. Add any initialization code to BLOCK. PACKED is as
1264 for gfc_get_nodesc_array_type and DATA points to the first element
1265 in the passed array. */
1268 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1269 int packed, tree data)
1274 type = gfc_typenode_for_spec (&sym->ts);
1275 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1277 var = gfc_create_var (type, "ifm");
1278 gfc_add_modify_expr (block, var, fold_convert (type, data));
1284 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1285 and offset of descriptorless array type TYPE given that it has the same
1286 size as DESC. Add any set-up code to BLOCK. */
1289 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1296 offset = gfc_index_zero_node;
1297 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1299 dim = gfc_rank_cst[n];
1300 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1301 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1303 GFC_TYPE_ARRAY_LBOUND (type, n)
1304 = gfc_conv_descriptor_lbound (desc, dim);
1305 GFC_TYPE_ARRAY_UBOUND (type, n)
1306 = gfc_conv_descriptor_ubound (desc, dim);
1308 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1310 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1311 gfc_conv_descriptor_ubound (desc, dim),
1312 gfc_conv_descriptor_lbound (desc, dim));
1313 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1314 GFC_TYPE_ARRAY_LBOUND (type, n),
1316 tmp = gfc_evaluate_now (tmp, block);
1317 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1319 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1320 GFC_TYPE_ARRAY_LBOUND (type, n),
1321 GFC_TYPE_ARRAY_STRIDE (type, n));
1322 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1324 offset = gfc_evaluate_now (offset, block);
1325 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1329 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1330 in SE. The caller may still use se->expr and se->string_length after
1331 calling this function. */
1334 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1335 gfc_symbol * sym, gfc_se * se)
1337 gfc_interface_sym_mapping *sm;
1341 gfc_symbol *new_sym;
1343 gfc_symtree *new_symtree;
1345 /* Create a new symbol to represent the actual argument. */
1346 new_sym = gfc_new_symbol (sym->name, NULL);
1347 new_sym->ts = sym->ts;
1348 new_sym->attr.referenced = 1;
1349 new_sym->attr.dimension = sym->attr.dimension;
1350 new_sym->attr.pointer = sym->attr.pointer;
1351 new_sym->attr.allocatable = sym->attr.allocatable;
1352 new_sym->attr.flavor = sym->attr.flavor;
1354 /* Create a fake symtree for it. */
1356 new_symtree = gfc_new_symtree (&root, sym->name);
1357 new_symtree->n.sym = new_sym;
1358 gcc_assert (new_symtree == root);
1360 /* Create a dummy->actual mapping. */
1361 sm = gfc_getmem (sizeof (*sm));
1362 sm->next = mapping->syms;
1364 sm->new = new_symtree;
1367 /* Stabilize the argument's value. */
1368 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1370 if (sym->ts.type == BT_CHARACTER)
1372 /* Create a copy of the dummy argument's length. */
1373 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1375 /* If the length is specified as "*", record the length that
1376 the caller is passing. We should use the callee's length
1377 in all other cases. */
1378 if (!new_sym->ts.cl->length)
1380 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1381 new_sym->ts.cl->backend_decl = se->string_length;
1385 /* Use the passed value as-is if the argument is a function. */
1386 if (sym->attr.flavor == FL_PROCEDURE)
1389 /* If the argument is either a string or a pointer to a string,
1390 convert it to a boundless character type. */
1391 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1393 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1394 tmp = build_pointer_type (tmp);
1395 if (sym->attr.pointer)
1396 value = build_fold_indirect_ref (se->expr);
1399 value = fold_convert (tmp, value);
1402 /* If the argument is a scalar, a pointer to an array or an allocatable,
1404 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1405 value = build_fold_indirect_ref (se->expr);
1407 /* For character(*), use the actual argument's descriptor. */
1408 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1409 value = build_fold_indirect_ref (se->expr);
1411 /* If the argument is an array descriptor, use it to determine
1412 information about the actual argument's shape. */
1413 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1414 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1416 /* Get the actual argument's descriptor. */
1417 desc = build_fold_indirect_ref (se->expr);
1419 /* Create the replacement variable. */
1420 tmp = gfc_conv_descriptor_data_get (desc);
1421 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1423 /* Use DESC to work out the upper bounds, strides and offset. */
1424 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1427 /* Otherwise we have a packed array. */
1428 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1430 new_sym->backend_decl = value;
1434 /* Called once all dummy argument mappings have been added to MAPPING,
1435 but before the mapping is used to evaluate expressions. Pre-evaluate
1436 the length of each argument, adding any initialization code to PRE and
1437 any finalization code to POST. */
1440 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1441 stmtblock_t * pre, stmtblock_t * post)
1443 gfc_interface_sym_mapping *sym;
1447 for (sym = mapping->syms; sym; sym = sym->next)
1448 if (sym->new->n.sym->ts.type == BT_CHARACTER
1449 && !sym->new->n.sym->ts.cl->backend_decl)
1451 expr = sym->new->n.sym->ts.cl->length;
1452 gfc_apply_interface_mapping_to_expr (mapping, expr);
1453 gfc_init_se (&se, NULL);
1454 gfc_conv_expr (&se, expr);
1456 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1457 gfc_add_block_to_block (pre, &se.pre);
1458 gfc_add_block_to_block (post, &se.post);
1460 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1465 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1469 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1470 gfc_constructor * c)
1472 for (; c; c = c->next)
1474 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1477 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1478 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1479 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1485 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1489 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1494 for (; ref; ref = ref->next)
1498 for (n = 0; n < ref->u.ar.dimen; n++)
1500 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1501 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1502 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1504 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1511 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1512 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1518 /* EXPR is a copy of an expression that appeared in the interface
1519 associated with MAPPING. Walk it recursively looking for references to
1520 dummy arguments that MAPPING maps to actual arguments. Replace each such
1521 reference with a reference to the associated actual argument. */
1524 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1527 gfc_interface_sym_mapping *sym;
1528 gfc_actual_arglist *actual;
1533 /* Copying an expression does not copy its length, so do that here. */
1534 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1536 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1537 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1540 /* Apply the mapping to any references. */
1541 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1543 /* ...and to the expression's symbol, if it has one. */
1545 for (sym = mapping->syms; sym; sym = sym->next)
1546 if (sym->old == expr->symtree->n.sym)
1547 expr->symtree = sym->new;
1549 /* ...and to subexpressions in expr->value. */
1550 switch (expr->expr_type)
1555 case EXPR_SUBSTRING:
1559 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1560 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1564 for (sym = mapping->syms; sym; sym = sym->next)
1565 if (sym->old == expr->value.function.esym)
1566 expr->value.function.esym = sym->new->n.sym;
1568 for (actual = expr->value.function.actual; actual; actual = actual->next)
1569 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1573 case EXPR_STRUCTURE:
1574 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1580 /* Evaluate interface expression EXPR using MAPPING. Store the result
1584 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1585 gfc_se * se, gfc_expr * expr)
1587 expr = gfc_copy_expr (expr);
1588 gfc_apply_interface_mapping_to_expr (mapping, expr);
1589 gfc_conv_expr (se, expr);
1590 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1591 gfc_free_expr (expr);
1594 /* Returns a reference to a temporary array into which a component of
1595 an actual argument derived type array is copied and then returned
1596 after the function call.
1597 TODO Get rid of this kludge, when array descriptors are capable of
1598 handling aliased arrays. */
1601 gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
1602 int g77, sym_intent intent)
1618 gcc_assert (expr->expr_type == EXPR_VARIABLE);
1620 gfc_init_se (&lse, NULL);
1621 gfc_init_se (&rse, NULL);
1623 /* Walk the argument expression. */
1624 rss = gfc_walk_expr (expr);
1626 gcc_assert (rss != gfc_ss_terminator);
1628 /* Initialize the scalarizer. */
1629 gfc_init_loopinfo (&loop);
1630 gfc_add_ss_to_loop (&loop, rss);
1632 /* Calculate the bounds of the scalarization. */
1633 gfc_conv_ss_startstride (&loop);
1635 /* Build an ss for the temporary. */
1636 base_type = gfc_typenode_for_spec (&expr->ts);
1637 if (GFC_ARRAY_TYPE_P (base_type)
1638 || GFC_DESCRIPTOR_TYPE_P (base_type))
1639 base_type = gfc_get_element_type (base_type);
1641 loop.temp_ss = gfc_get_ss ();;
1642 loop.temp_ss->type = GFC_SS_TEMP;
1643 loop.temp_ss->data.temp.type = base_type;
1645 if (expr->ts.type == BT_CHARACTER)
1647 gfc_ref *char_ref = expr->ref;
1649 for (; expr->ts.cl == NULL && char_ref; char_ref = char_ref->next)
1650 if (char_ref->type == REF_SUBSTRING)
1654 expr->ts.cl = gfc_get_charlen ();
1655 expr->ts.cl->next = char_ref->u.ss.length->next;
1656 char_ref->u.ss.length->next = expr->ts.cl;
1658 gfc_init_se (&tmp_se, NULL);
1659 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
1660 gfc_array_index_type);
1661 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1662 tmp_se.expr, gfc_index_one_node);
1663 tmp = gfc_evaluate_now (tmp, &parmse->pre);
1664 gfc_init_se (&tmp_se, NULL);
1665 gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
1666 gfc_array_index_type);
1667 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1669 expr->ts.cl->backend_decl = tmp;
1673 loop.temp_ss->data.temp.type
1674 = gfc_typenode_for_spec (&expr->ts);
1675 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
1678 loop.temp_ss->data.temp.dimen = loop.dimen;
1679 loop.temp_ss->next = gfc_ss_terminator;
1681 /* Associate the SS with the loop. */
1682 gfc_add_ss_to_loop (&loop, loop.temp_ss);
1684 /* Setup the scalarizing loops. */
1685 gfc_conv_loop_setup (&loop);
1687 /* Pass the temporary descriptor back to the caller. */
1688 info = &loop.temp_ss->data.info;
1689 parmse->expr = info->descriptor;
1691 /* Setup the gfc_se structures. */
1692 gfc_copy_loopinfo_to_se (&lse, &loop);
1693 gfc_copy_loopinfo_to_se (&rse, &loop);
1696 lse.ss = loop.temp_ss;
1697 gfc_mark_ss_chain_used (rss, 1);
1698 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1700 /* Start the scalarized loop body. */
1701 gfc_start_scalarized_body (&loop, &body);
1703 /* Translate the expression. */
1704 gfc_conv_expr (&rse, expr);
1706 gfc_conv_tmp_array_ref (&lse);
1707 gfc_advance_se_ss_chain (&lse);
1709 if (intent != INTENT_OUT)
1711 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
1712 gfc_add_expr_to_block (&body, tmp);
1713 gcc_assert (rse.ss == gfc_ss_terminator);
1714 gfc_trans_scalarizing_loops (&loop, &body);
1718 /* Make sure that the temporary declaration survives by merging
1719 all the loop declarations into the current context. */
1720 for (n = 0; n < loop.dimen; n++)
1722 gfc_merge_block_scope (&body);
1723 body = loop.code[loop.order[n]];
1725 gfc_merge_block_scope (&body);
1728 /* Add the post block after the second loop, so that any
1729 freeing of allocated memory is done at the right time. */
1730 gfc_add_block_to_block (&parmse->pre, &loop.pre);
1732 /**********Copy the temporary back again.*********/
1734 gfc_init_se (&lse, NULL);
1735 gfc_init_se (&rse, NULL);
1737 /* Walk the argument expression. */
1738 lss = gfc_walk_expr (expr);
1739 rse.ss = loop.temp_ss;
1742 /* Initialize the scalarizer. */
1743 gfc_init_loopinfo (&loop2);
1744 gfc_add_ss_to_loop (&loop2, lss);
1746 /* Calculate the bounds of the scalarization. */
1747 gfc_conv_ss_startstride (&loop2);
1749 /* Setup the scalarizing loops. */
1750 gfc_conv_loop_setup (&loop2);
1752 gfc_copy_loopinfo_to_se (&lse, &loop2);
1753 gfc_copy_loopinfo_to_se (&rse, &loop2);
1755 gfc_mark_ss_chain_used (lss, 1);
1756 gfc_mark_ss_chain_used (loop.temp_ss, 1);
1758 /* Declare the variable to hold the temporary offset and start the
1759 scalarized loop body. */
1760 offset = gfc_create_var (gfc_array_index_type, NULL);
1761 gfc_start_scalarized_body (&loop2, &body);
1763 /* Build the offsets for the temporary from the loop variables. The
1764 temporary array has lbounds of zero and strides of one in all
1765 dimensions, so this is very simple. The offset is only computed
1766 outside the innermost loop, so the overall transfer could be
1767 optimized further. */
1768 info = &rse.ss->data.info;
1770 tmp_index = gfc_index_zero_node;
1771 for (n = info->dimen - 1; n > 0; n--)
1774 tmp = rse.loop->loopvar[n];
1775 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1776 tmp, rse.loop->from[n]);
1777 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1780 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1781 rse.loop->to[n-1], rse.loop->from[n-1]);
1782 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1783 tmp_str, gfc_index_one_node);
1785 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
1789 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1790 tmp_index, rse.loop->from[0]);
1791 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
1793 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1794 rse.loop->loopvar[0], offset);
1796 /* Now use the offset for the reference. */
1797 tmp = build_fold_indirect_ref (info->data);
1798 rse.expr = gfc_build_array_ref (tmp, tmp_index);
1800 if (expr->ts.type == BT_CHARACTER)
1801 rse.string_length = expr->ts.cl->backend_decl;
1803 gfc_conv_expr (&lse, expr);
1805 gcc_assert (lse.ss == gfc_ss_terminator);
1807 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1808 gfc_add_expr_to_block (&body, tmp);
1810 /* Generate the copying loops. */
1811 gfc_trans_scalarizing_loops (&loop2, &body);
1813 /* Wrap the whole thing up by adding the second loop to the post-block
1814 and following it by the post-block of the first loop. In this way,
1815 if the temporary needs freeing, it is done after use! */
1816 if (intent != INTENT_IN)
1818 gfc_add_block_to_block (&parmse->post, &loop2.pre);
1819 gfc_add_block_to_block (&parmse->post, &loop2.post);
1822 gfc_add_block_to_block (&parmse->post, &loop.post);
1824 gfc_cleanup_loop (&loop);
1825 gfc_cleanup_loop (&loop2);
1827 /* Pass the string length to the argument expression. */
1828 if (expr->ts.type == BT_CHARACTER)
1829 parmse->string_length = expr->ts.cl->backend_decl;
1831 /* We want either the address for the data or the address of the descriptor,
1832 depending on the mode of passing array arguments. */
1834 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
1836 parmse->expr = build_fold_addr_expr (parmse->expr);
1841 /* Is true if an array reference is followed by a component or substring
1845 is_aliased_array (gfc_expr * e)
1851 for (ref = e->ref; ref; ref = ref->next)
1853 if (ref->type == REF_ARRAY
1854 && ref->u.ar.type != AR_ELEMENT)
1858 && ref->type != REF_ARRAY)
1864 /* Generate code for a procedure call. Note can return se->post != NULL.
1865 If se->direct_byref is set then se->expr contains the return parameter.
1866 Return nonzero, if the call has alternate specifiers. */
1869 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1870 gfc_actual_arglist * arg, tree append_args)
1872 gfc_interface_mapping mapping;
1886 gfc_formal_arglist *formal;
1887 int has_alternate_specifier = 0;
1888 bool need_interface_mapping;
1895 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
1897 arglist = NULL_TREE;
1898 retargs = NULL_TREE;
1899 stringargs = NULL_TREE;
1905 if (!sym->attr.elemental)
1907 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1908 if (se->ss->useflags)
1910 gcc_assert (gfc_return_by_reference (sym)
1911 && sym->result->attr.dimension);
1912 gcc_assert (se->loop != NULL);
1914 /* Access the previously obtained result. */
1915 gfc_conv_tmp_array_ref (se);
1916 gfc_advance_se_ss_chain (se);
1920 info = &se->ss->data.info;
1925 gfc_init_block (&post);
1926 gfc_init_interface_mapping (&mapping);
1927 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1928 && sym->ts.cl->length
1929 && sym->ts.cl->length->expr_type
1931 || sym->attr.dimension);
1932 formal = sym->formal;
1933 /* Evaluate the arguments. */
1934 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1937 fsym = formal ? formal->sym : NULL;
1938 parm_kind = MISSING;
1942 if (se->ignore_optional)
1944 /* Some intrinsics have already been resolved to the correct
1948 else if (arg->label)
1950 has_alternate_specifier = 1;
1955 /* Pass a NULL pointer for an absent arg. */
1956 gfc_init_se (&parmse, NULL);
1957 parmse.expr = null_pointer_node;
1958 if (arg->missing_arg_type == BT_CHARACTER)
1959 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
1962 else if (se->ss && se->ss->useflags)
1964 /* An elemental function inside a scalarized loop. */
1965 gfc_init_se (&parmse, se);
1966 gfc_conv_expr_reference (&parmse, e);
1967 parm_kind = ELEMENTAL;
1971 /* A scalar or transformational function. */
1972 gfc_init_se (&parmse, NULL);
1973 argss = gfc_walk_expr (e);
1975 if (argss == gfc_ss_terminator)
1977 gfc_conv_expr_reference (&parmse, e);
1979 if (fsym && fsym->attr.pointer
1980 && e->expr_type != EXPR_NULL)
1982 /* Scalar pointer dummy args require an extra level of
1983 indirection. The null pointer already contains
1984 this level of indirection. */
1985 parm_kind = SCALAR_POINTER;
1986 parmse.expr = build_fold_addr_expr (parmse.expr);
1991 /* If the procedure requires an explicit interface, the actual
1992 argument is passed according to the corresponding formal
1993 argument. If the corresponding formal argument is a POINTER,
1994 ALLOCATABLE or assumed shape, we do not use g77's calling
1995 convention, and pass the address of the array descriptor
1996 instead. Otherwise we use g77's calling convention. */
1999 && !(fsym->attr.pointer || fsym->attr.allocatable)
2000 && fsym->as->type != AS_ASSUMED_SHAPE;
2001 f = f || !sym->attr.always_explicit;
2003 if (e->expr_type == EXPR_VARIABLE
2004 && is_aliased_array (e))
2005 /* The actual argument is a component reference to an
2006 array of derived types. In this case, the argument
2007 is converted to a temporary, which is passed and then
2008 written back after the procedure call. */
2009 gfc_conv_aliased_arg (&parmse, e, f,
2010 fsym ? fsym->attr.intent : INTENT_INOUT);
2012 gfc_conv_array_parameter (&parmse, e, argss, f);
2014 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2015 allocated on entry, it must be deallocated. */
2016 if (fsym && fsym->attr.allocatable
2017 && fsym->attr.intent == INTENT_OUT)
2019 tmp = e->symtree->n.sym->backend_decl;
2020 if (e->symtree->n.sym->attr.dummy)
2021 tmp = build_fold_indirect_ref (tmp);
2022 tmp = gfc_trans_dealloc_allocated (tmp);
2023 gfc_add_expr_to_block (&se->pre, tmp);
2033 /* If an optional argument is itself an optional dummy
2034 argument, check its presence and substitute a null
2036 if (e->expr_type == EXPR_VARIABLE
2037 && e->symtree->n.sym->attr.optional
2038 && fsym->attr.optional)
2039 gfc_conv_missing_dummy (&parmse, e, fsym->ts);
2041 /* If an INTENT(OUT) dummy of derived type has a default
2042 initializer, it must be (re)initialized here. */
2043 if (fsym->attr.intent == INTENT_OUT
2044 && fsym->ts.type == BT_DERIVED
2047 gcc_assert (!fsym->attr.allocatable);
2048 tmp = gfc_trans_assignment (e, fsym->value, false);
2049 gfc_add_expr_to_block (&se->pre, tmp);
2052 /* Obtain the character length of an assumed character
2053 length procedure from the typespec. */
2054 if (fsym->ts.type == BT_CHARACTER
2055 && parmse.string_length == NULL_TREE
2056 && e->ts.type == BT_PROCEDURE
2057 && e->symtree->n.sym->ts.type == BT_CHARACTER
2058 && e->symtree->n.sym->ts.cl->length != NULL)
2060 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2061 parmse.string_length
2062 = e->symtree->n.sym->ts.cl->backend_decl;
2066 if (need_interface_mapping)
2067 gfc_add_interface_mapping (&mapping, fsym, &parmse);
2070 gfc_add_block_to_block (&se->pre, &parmse.pre);
2071 gfc_add_block_to_block (&post, &parmse.post);
2073 /* Allocated allocatable components of derived types must be
2074 deallocated for INTENT(OUT) dummy arguments and non-variable
2075 scalars. Non-variable arrays are dealt with in trans-array.c
2076 (gfc_conv_array_parameter). */
2077 if (e && e->ts.type == BT_DERIVED
2078 && e->ts.derived->attr.alloc_comp
2079 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2081 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2084 tmp = build_fold_indirect_ref (parmse.expr);
2085 parm_rank = e->rank;
2093 case (SCALAR_POINTER):
2094 tmp = build_fold_indirect_ref (tmp);
2101 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2102 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2103 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2104 tmp, build_empty_stmt ());
2106 if (e->expr_type != EXPR_VARIABLE)
2107 /* Don't deallocate non-variables until they have been used. */
2108 gfc_add_expr_to_block (&se->post, tmp);
2111 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2112 gfc_add_expr_to_block (&se->pre, tmp);
2116 /* Character strings are passed as two parameters, a length and a
2118 if (parmse.string_length != NULL_TREE)
2119 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2121 arglist = gfc_chainon_list (arglist, parmse.expr);
2123 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2126 if (ts.type == BT_CHARACTER)
2128 if (sym->ts.cl->length == NULL)
2130 /* Assumed character length results are not allowed by 5.1.1.5 of the
2131 standard and are trapped in resolve.c; except in the case of SPREAD
2132 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2133 we take the character length of the first argument for the result.
2134 For dummies, we have to look through the formal argument list for
2135 this function and use the character length found there.*/
2136 if (!sym->attr.dummy)
2137 cl.backend_decl = TREE_VALUE (stringargs);
2140 formal = sym->ns->proc_name->formal;
2141 for (; formal; formal = formal->next)
2142 if (strcmp (formal->sym->name, sym->name) == 0)
2143 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2148 /* Calculate the length of the returned string. */
2149 gfc_init_se (&parmse, NULL);
2150 if (need_interface_mapping)
2151 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2153 gfc_conv_expr (&parmse, sym->ts.cl->length);
2154 gfc_add_block_to_block (&se->pre, &parmse.pre);
2155 gfc_add_block_to_block (&se->post, &parmse.post);
2156 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
2159 /* Set up a charlen structure for it. */
2164 len = cl.backend_decl;
2167 byref = gfc_return_by_reference (sym);
2170 if (se->direct_byref)
2171 retargs = gfc_chainon_list (retargs, se->expr);
2172 else if (sym->result->attr.dimension)
2174 gcc_assert (se->loop && info);
2176 /* Set the type of the array. */
2177 tmp = gfc_typenode_for_spec (&ts);
2178 info->dimen = se->loop->dimen;
2180 /* Evaluate the bounds of the result, if known. */
2181 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2183 /* Create a temporary to store the result. In case the function
2184 returns a pointer, the temporary will be a shallow copy and
2185 mustn't be deallocated. */
2186 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2187 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2188 false, !sym->attr.pointer, callee_alloc,
2191 /* Pass the temporary as the first argument. */
2192 tmp = info->descriptor;
2193 tmp = build_fold_addr_expr (tmp);
2194 retargs = gfc_chainon_list (retargs, tmp);
2196 else if (ts.type == BT_CHARACTER)
2198 /* Pass the string length. */
2199 type = gfc_get_character_type (ts.kind, ts.cl);
2200 type = build_pointer_type (type);
2202 /* Return an address to a char[0:len-1]* temporary for
2203 character pointers. */
2204 if (sym->attr.pointer || sym->attr.allocatable)
2206 /* Build char[0:len-1] * pstr. */
2207 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
2208 build_int_cst (gfc_charlen_type_node, 1));
2209 tmp = build_range_type (gfc_array_index_type,
2210 gfc_index_zero_node, tmp);
2211 tmp = build_array_type (gfc_character1_type_node, tmp);
2212 var = gfc_create_var (build_pointer_type (tmp), "pstr");
2214 /* Provide an address expression for the function arguments. */
2215 var = build_fold_addr_expr (var);
2218 var = gfc_conv_string_tmp (se, type, len);
2220 retargs = gfc_chainon_list (retargs, var);
2224 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2226 type = gfc_get_complex_type (ts.kind);
2227 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2228 retargs = gfc_chainon_list (retargs, var);
2231 /* Add the string length to the argument list. */
2232 if (ts.type == BT_CHARACTER)
2233 retargs = gfc_chainon_list (retargs, len);
2235 gfc_free_interface_mapping (&mapping);
2237 /* Add the return arguments. */
2238 arglist = chainon (retargs, arglist);
2240 /* Add the hidden string length parameters to the arguments. */
2241 arglist = chainon (arglist, stringargs);
2243 /* We may want to append extra arguments here. This is used e.g. for
2244 calls to libgfortran_matmul_??, which need extra information. */
2245 if (append_args != NULL_TREE)
2246 arglist = chainon (arglist, append_args);
2248 /* Generate the actual call. */
2249 gfc_conv_function_val (se, sym);
2250 /* If there are alternate return labels, function type should be
2251 integer. Can't modify the type in place though, since it can be shared
2252 with other functions. */
2253 if (has_alternate_specifier
2254 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2256 gcc_assert (! sym->attr.dummy);
2257 TREE_TYPE (sym->backend_decl)
2258 = build_function_type (integer_type_node,
2259 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2260 se->expr = build_fold_addr_expr (sym->backend_decl);
2263 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2264 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
2265 arglist, NULL_TREE);
2267 /* If we have a pointer function, but we don't want a pointer, e.g.
2270 where f is pointer valued, we have to dereference the result. */
2271 if (!se->want_pointer && !byref && sym->attr.pointer)
2272 se->expr = build_fold_indirect_ref (se->expr);
2274 /* f2c calling conventions require a scalar default real function to
2275 return a double precision result. Convert this back to default
2276 real. We only care about the cases that can happen in Fortran 77.
2278 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2279 && sym->ts.kind == gfc_default_real_kind
2280 && !sym->attr.always_explicit)
2281 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2283 /* A pure function may still have side-effects - it may modify its
2285 TREE_SIDE_EFFECTS (se->expr) = 1;
2287 if (!sym->attr.pure)
2288 TREE_SIDE_EFFECTS (se->expr) = 1;
2293 /* Add the function call to the pre chain. There is no expression. */
2294 gfc_add_expr_to_block (&se->pre, se->expr);
2295 se->expr = NULL_TREE;
2297 if (!se->direct_byref)
2299 if (sym->attr.dimension)
2301 if (flag_bounds_check)
2303 /* Check the data pointer hasn't been modified. This would
2304 happen in a function returning a pointer. */
2305 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2306 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2308 gfc_trans_runtime_check (tmp, gfc_msg_fault, &se->pre, NULL);
2310 se->expr = info->descriptor;
2311 /* Bundle in the string length. */
2312 se->string_length = len;
2314 else if (sym->ts.type == BT_CHARACTER)
2316 /* Dereference for character pointer results. */
2317 if (sym->attr.pointer || sym->attr.allocatable)
2318 se->expr = build_fold_indirect_ref (var);
2322 se->string_length = len;
2326 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2327 se->expr = build_fold_indirect_ref (var);
2332 /* Follow the function call with the argument post block. */
2334 gfc_add_block_to_block (&se->pre, &post);
2336 gfc_add_block_to_block (&se->post, &post);
2338 return has_alternate_specifier;
2342 /* Generate code to copy a string. */
2345 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2346 tree slength, tree src)
2348 tree tmp, dlen, slen;
2356 stmtblock_t tempblock;
2358 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2359 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2361 /* Deal with single character specially. */
2362 dsc = gfc_to_single_character (dlen, dest);
2363 ssc = gfc_to_single_character (slen, src);
2364 if (dsc != NULL_TREE && ssc != NULL_TREE)
2366 gfc_add_modify_expr (block, dsc, ssc);
2370 /* Do nothing if the destination length is zero. */
2371 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2372 build_int_cst (gfc_charlen_type_node, 0));
2374 /* The following code was previously in _gfortran_copy_string:
2376 // The two strings may overlap so we use memmove.
2378 copy_string (GFC_INTEGER_4 destlen, char * dest,
2379 GFC_INTEGER_4 srclen, const char * src)
2381 if (srclen >= destlen)
2383 // This will truncate if too long.
2384 memmove (dest, src, destlen);
2388 memmove (dest, src, srclen);
2390 memset (&dest[srclen], ' ', destlen - srclen);
2394 We're now doing it here for better optimization, but the logic
2397 /* Truncate string if source is too long. */
2398 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
2399 tmp2 = gfc_chainon_list (NULL_TREE, dest);
2400 tmp2 = gfc_chainon_list (tmp2, src);
2401 tmp2 = gfc_chainon_list (tmp2, dlen);
2402 tmp2 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp2);
2404 /* Else copy and pad with spaces. */
2405 tmp3 = gfc_chainon_list (NULL_TREE, dest);
2406 tmp3 = gfc_chainon_list (tmp3, src);
2407 tmp3 = gfc_chainon_list (tmp3, slen);
2408 tmp3 = build_function_call_expr (built_in_decls[BUILT_IN_MEMMOVE], tmp3);
2410 tmp4 = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
2411 fold_convert (pchar_type_node, slen));
2412 tmp4 = gfc_chainon_list (NULL_TREE, tmp4);
2413 tmp4 = gfc_chainon_list (tmp4, build_int_cst
2414 (gfc_get_int_type (gfc_c_int_kind),
2415 lang_hooks.to_target_charset (' ')));
2416 tmp4 = gfc_chainon_list (tmp4, fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
2418 tmp4 = build_function_call_expr (built_in_decls[BUILT_IN_MEMSET], tmp4);
2420 gfc_init_block (&tempblock);
2421 gfc_add_expr_to_block (&tempblock, tmp3);
2422 gfc_add_expr_to_block (&tempblock, tmp4);
2423 tmp3 = gfc_finish_block (&tempblock);
2425 /* The whole copy_string function is there. */
2426 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
2427 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2428 gfc_add_expr_to_block (block, tmp);
2432 /* Translate a statement function.
2433 The value of a statement function reference is obtained by evaluating the
2434 expression using the values of the actual arguments for the values of the
2435 corresponding dummy arguments. */
2438 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
2442 gfc_formal_arglist *fargs;
2443 gfc_actual_arglist *args;
2446 gfc_saved_var *saved_vars;
2452 sym = expr->symtree->n.sym;
2453 args = expr->value.function.actual;
2454 gfc_init_se (&lse, NULL);
2455 gfc_init_se (&rse, NULL);
2458 for (fargs = sym->formal; fargs; fargs = fargs->next)
2460 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
2461 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
2463 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2465 /* Each dummy shall be specified, explicitly or implicitly, to be
2467 gcc_assert (fargs->sym->attr.dimension == 0);
2470 /* Create a temporary to hold the value. */
2471 type = gfc_typenode_for_spec (&fsym->ts);
2472 temp_vars[n] = gfc_create_var (type, fsym->name);
2474 if (fsym->ts.type == BT_CHARACTER)
2476 /* Copy string arguments. */
2479 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
2480 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
2482 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
2483 tmp = gfc_build_addr_expr (build_pointer_type (type),
2486 gfc_conv_expr (&rse, args->expr);
2487 gfc_conv_string_parameter (&rse);
2488 gfc_add_block_to_block (&se->pre, &lse.pre);
2489 gfc_add_block_to_block (&se->pre, &rse.pre);
2491 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
2493 gfc_add_block_to_block (&se->pre, &lse.post);
2494 gfc_add_block_to_block (&se->pre, &rse.post);
2498 /* For everything else, just evaluate the expression. */
2499 gfc_conv_expr (&lse, args->expr);
2501 gfc_add_block_to_block (&se->pre, &lse.pre);
2502 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
2503 gfc_add_block_to_block (&se->pre, &lse.post);
2509 /* Use the temporary variables in place of the real ones. */
2510 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2511 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
2513 gfc_conv_expr (se, sym->value);
2515 if (sym->ts.type == BT_CHARACTER)
2517 gfc_conv_const_charlen (sym->ts.cl);
2519 /* Force the expression to the correct length. */
2520 if (!INTEGER_CST_P (se->string_length)
2521 || tree_int_cst_lt (se->string_length,
2522 sym->ts.cl->backend_decl))
2524 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
2525 tmp = gfc_create_var (type, sym->name);
2526 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
2527 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
2528 se->string_length, se->expr);
2531 se->string_length = sym->ts.cl->backend_decl;
2534 /* Restore the original variables. */
2535 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
2536 gfc_restore_sym (fargs->sym, &saved_vars[n]);
2537 gfc_free (saved_vars);
2541 /* Translate a function expression. */
2544 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2548 if (expr->value.function.isym)
2550 gfc_conv_intrinsic_function (se, expr);
2554 /* We distinguish statement functions from general functions to improve
2555 runtime performance. */
2556 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2558 gfc_conv_statement_function (se, expr);
2562 /* expr.value.function.esym is the resolved (specific) function symbol for
2563 most functions. However this isn't set for dummy procedures. */
2564 sym = expr->value.function.esym;
2566 sym = expr->symtree->n.sym;
2567 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
2572 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2574 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2575 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2577 gfc_conv_tmp_array_ref (se);
2578 gfc_advance_se_ss_chain (se);
2582 /* Build a static initializer. EXPR is the expression for the initial value.
2583 The other parameters describe the variable of the component being
2584 initialized. EXPR may be null. */
2587 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2588 bool array, bool pointer)
2592 if (!(expr || pointer))
2597 /* Arrays need special handling. */
2599 return gfc_build_null_descriptor (type);
2601 return gfc_conv_array_initializer (type, expr);
2604 return fold_convert (type, null_pointer_node);
2610 gfc_init_se (&se, NULL);
2611 gfc_conv_structure (&se, expr, 1);
2615 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2618 gfc_init_se (&se, NULL);
2619 gfc_conv_constant (&se, expr);
2626 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2638 gfc_start_block (&block);
2640 /* Initialize the scalarizer. */
2641 gfc_init_loopinfo (&loop);
2643 gfc_init_se (&lse, NULL);
2644 gfc_init_se (&rse, NULL);
2647 rss = gfc_walk_expr (expr);
2648 if (rss == gfc_ss_terminator)
2650 /* The rhs is scalar. Add a ss for the expression. */
2651 rss = gfc_get_ss ();
2652 rss->next = gfc_ss_terminator;
2653 rss->type = GFC_SS_SCALAR;
2657 /* Create a SS for the destination. */
2658 lss = gfc_get_ss ();
2659 lss->type = GFC_SS_COMPONENT;
2661 lss->shape = gfc_get_shape (cm->as->rank);
2662 lss->next = gfc_ss_terminator;
2663 lss->data.info.dimen = cm->as->rank;
2664 lss->data.info.descriptor = dest;
2665 lss->data.info.data = gfc_conv_array_data (dest);
2666 lss->data.info.offset = gfc_conv_array_offset (dest);
2667 for (n = 0; n < cm->as->rank; n++)
2669 lss->data.info.dim[n] = n;
2670 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2671 lss->data.info.stride[n] = gfc_index_one_node;
2673 mpz_init (lss->shape[n]);
2674 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2675 cm->as->lower[n]->value.integer);
2676 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2679 /* Associate the SS with the loop. */
2680 gfc_add_ss_to_loop (&loop, lss);
2681 gfc_add_ss_to_loop (&loop, rss);
2683 /* Calculate the bounds of the scalarization. */
2684 gfc_conv_ss_startstride (&loop);
2686 /* Setup the scalarizing loops. */
2687 gfc_conv_loop_setup (&loop);
2689 /* Setup the gfc_se structures. */
2690 gfc_copy_loopinfo_to_se (&lse, &loop);
2691 gfc_copy_loopinfo_to_se (&rse, &loop);
2694 gfc_mark_ss_chain_used (rss, 1);
2696 gfc_mark_ss_chain_used (lss, 1);
2698 /* Start the scalarized loop body. */
2699 gfc_start_scalarized_body (&loop, &body);
2701 gfc_conv_tmp_array_ref (&lse);
2702 if (cm->ts.type == BT_CHARACTER)
2703 lse.string_length = cm->ts.cl->backend_decl;
2705 gfc_conv_expr (&rse, expr);
2707 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
2708 gfc_add_expr_to_block (&body, tmp);
2710 gcc_assert (rse.ss == gfc_ss_terminator);
2712 /* Generate the copying loops. */
2713 gfc_trans_scalarizing_loops (&loop, &body);
2715 /* Wrap the whole thing up. */
2716 gfc_add_block_to_block (&block, &loop.pre);
2717 gfc_add_block_to_block (&block, &loop.post);
2719 for (n = 0; n < cm->as->rank; n++)
2720 mpz_clear (lss->shape[n]);
2721 gfc_free (lss->shape);
2723 gfc_cleanup_loop (&loop);
2725 return gfc_finish_block (&block);
2729 /* Assign a single component of a derived type constructor. */
2732 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2742 gfc_start_block (&block);
2746 gfc_init_se (&se, NULL);
2747 /* Pointer component. */
2750 /* Array pointer. */
2751 if (expr->expr_type == EXPR_NULL)
2752 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2755 rss = gfc_walk_expr (expr);
2756 se.direct_byref = 1;
2758 gfc_conv_expr_descriptor (&se, expr, rss);
2759 gfc_add_block_to_block (&block, &se.pre);
2760 gfc_add_block_to_block (&block, &se.post);
2765 /* Scalar pointers. */
2766 se.want_pointer = 1;
2767 gfc_conv_expr (&se, expr);
2768 gfc_add_block_to_block (&block, &se.pre);
2769 gfc_add_modify_expr (&block, dest,
2770 fold_convert (TREE_TYPE (dest), se.expr));
2771 gfc_add_block_to_block (&block, &se.post);
2774 else if (cm->dimension)
2776 if (cm->allocatable && expr->expr_type == EXPR_NULL)
2777 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2778 else if (cm->allocatable)
2782 gfc_init_se (&se, NULL);
2784 rss = gfc_walk_expr (expr);
2785 se.want_pointer = 0;
2786 gfc_conv_expr_descriptor (&se, expr, rss);
2787 gfc_add_block_to_block (&block, &se.pre);
2789 tmp = fold_convert (TREE_TYPE (dest), se.expr);
2790 gfc_add_modify_expr (&block, dest, tmp);
2792 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
2793 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
2796 tmp = gfc_duplicate_allocatable (dest, se.expr,
2797 TREE_TYPE(cm->backend_decl),
2800 gfc_add_expr_to_block (&block, tmp);
2802 gfc_add_block_to_block (&block, &se.post);
2803 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
2805 /* Shift the lbound and ubound of temporaries to being unity, rather
2806 than zero, based. Calculate the offset for all cases. */
2807 offset = gfc_conv_descriptor_offset (dest);
2808 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
2809 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
2810 for (n = 0; n < expr->rank; n++)
2812 if (expr->expr_type != EXPR_VARIABLE
2813 && expr->expr_type != EXPR_CONSTANT)
2815 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
2816 gfc_add_modify_expr (&block, tmp,
2817 fold_build2 (PLUS_EXPR,
2818 gfc_array_index_type,
2819 tmp, gfc_index_one_node));
2820 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
2821 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
2823 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2824 gfc_conv_descriptor_lbound (dest,
2826 gfc_conv_descriptor_stride (dest,
2828 gfc_add_modify_expr (&block, tmp2, tmp);
2829 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
2830 gfc_add_modify_expr (&block, offset, tmp);
2835 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2836 gfc_add_expr_to_block (&block, tmp);
2839 else if (expr->ts.type == BT_DERIVED)
2841 if (expr->expr_type != EXPR_STRUCTURE)
2843 gfc_init_se (&se, NULL);
2844 gfc_conv_expr (&se, expr);
2845 gfc_add_modify_expr (&block, dest,
2846 fold_convert (TREE_TYPE (dest), se.expr));
2850 /* Nested constructors. */
2851 tmp = gfc_trans_structure_assign (dest, expr);
2852 gfc_add_expr_to_block (&block, tmp);
2857 /* Scalar component. */
2858 gfc_init_se (&se, NULL);
2859 gfc_init_se (&lse, NULL);
2861 gfc_conv_expr (&se, expr);
2862 if (cm->ts.type == BT_CHARACTER)
2863 lse.string_length = cm->ts.cl->backend_decl;
2865 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
2866 gfc_add_expr_to_block (&block, tmp);
2868 return gfc_finish_block (&block);
2871 /* Assign a derived type constructor to a variable. */
2874 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2882 gfc_start_block (&block);
2883 cm = expr->ts.derived->components;
2884 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2886 /* Skip absent members in default initializers. */
2890 field = cm->backend_decl;
2891 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2892 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2893 gfc_add_expr_to_block (&block, tmp);
2895 return gfc_finish_block (&block);
2898 /* Build an expression for a constructor. If init is nonzero then
2899 this is part of a static variable initializer. */
2902 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2909 VEC(constructor_elt,gc) *v = NULL;
2911 gcc_assert (se->ss == NULL);
2912 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2913 type = gfc_typenode_for_spec (&expr->ts);
2917 /* Create a temporary variable and fill it in. */
2918 se->expr = gfc_create_var (type, expr->ts.derived->name);
2919 tmp = gfc_trans_structure_assign (se->expr, expr);
2920 gfc_add_expr_to_block (&se->pre, tmp);
2924 cm = expr->ts.derived->components;
2926 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2928 /* Skip absent members in default initializers and allocatable
2929 components. Although the latter have a default initializer
2930 of EXPR_NULL,... by default, the static nullify is not needed
2931 since this is done every time we come into scope. */
2932 if (!c->expr || cm->allocatable)
2935 val = gfc_conv_initializer (c->expr, &cm->ts,
2936 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2938 /* Append it to the constructor list. */
2939 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2941 se->expr = build_constructor (type, v);
2945 /* Translate a substring expression. */
2948 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2954 gcc_assert (ref->type == REF_SUBSTRING);
2956 se->expr = gfc_build_string_const(expr->value.character.length,
2957 expr->value.character.string);
2958 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2959 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2961 gfc_conv_substring(se,ref,expr->ts.kind);
2965 /* Entry point for expression translation. Evaluates a scalar quantity.
2966 EXPR is the expression to be translated, and SE is the state structure if
2967 called from within the scalarized. */
2970 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2972 if (se->ss && se->ss->expr == expr
2973 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2975 /* Substitute a scalar expression evaluated outside the scalarization
2977 se->expr = se->ss->data.scalar.expr;
2978 se->string_length = se->ss->string_length;
2979 gfc_advance_se_ss_chain (se);
2983 switch (expr->expr_type)
2986 gfc_conv_expr_op (se, expr);
2990 gfc_conv_function_expr (se, expr);
2994 gfc_conv_constant (se, expr);
2998 gfc_conv_variable (se, expr);
3002 se->expr = null_pointer_node;
3005 case EXPR_SUBSTRING:
3006 gfc_conv_substring_expr (se, expr);
3009 case EXPR_STRUCTURE:
3010 gfc_conv_structure (se, expr, 0);
3014 gfc_conv_array_constructor_expr (se, expr);
3023 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3024 of an assignment. */
3026 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3028 gfc_conv_expr (se, expr);
3029 /* All numeric lvalues should have empty post chains. If not we need to
3030 figure out a way of rewriting an lvalue so that it has no post chain. */
3031 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3034 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3035 numeric expressions. Used for scalar values where inserting cleanup code
3038 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3042 gcc_assert (expr->ts.type != BT_CHARACTER);
3043 gfc_conv_expr (se, expr);
3046 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3047 gfc_add_modify_expr (&se->pre, val, se->expr);
3049 gfc_add_block_to_block (&se->pre, &se->post);
3053 /* Helper to translate and expression and convert it to a particular type. */
3055 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3057 gfc_conv_expr_val (se, expr);
3058 se->expr = convert (type, se->expr);
3062 /* Converts an expression so that it can be passed by reference. Scalar
3066 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3070 if (se->ss && se->ss->expr == expr
3071 && se->ss->type == GFC_SS_REFERENCE)
3073 se->expr = se->ss->data.scalar.expr;
3074 se->string_length = se->ss->string_length;
3075 gfc_advance_se_ss_chain (se);
3079 if (expr->ts.type == BT_CHARACTER)
3081 gfc_conv_expr (se, expr);
3082 gfc_conv_string_parameter (se);
3086 if (expr->expr_type == EXPR_VARIABLE)
3088 se->want_pointer = 1;
3089 gfc_conv_expr (se, expr);
3092 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3093 gfc_add_modify_expr (&se->pre, var, se->expr);
3094 gfc_add_block_to_block (&se->pre, &se->post);
3100 gfc_conv_expr (se, expr);
3102 /* Create a temporary var to hold the value. */
3103 if (TREE_CONSTANT (se->expr))
3105 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
3106 DECL_INITIAL (var) = se->expr;
3111 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3112 gfc_add_modify_expr (&se->pre, var, se->expr);
3114 gfc_add_block_to_block (&se->pre, &se->post);
3116 /* Take the address of that value. */
3117 se->expr = build_fold_addr_expr (var);
3122 gfc_trans_pointer_assign (gfc_code * code)
3124 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3128 /* Generate code for a pointer assignment. */
3131 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3141 gfc_start_block (&block);
3143 gfc_init_se (&lse, NULL);
3145 lss = gfc_walk_expr (expr1);
3146 rss = gfc_walk_expr (expr2);
3147 if (lss == gfc_ss_terminator)
3149 /* Scalar pointers. */
3150 lse.want_pointer = 1;
3151 gfc_conv_expr (&lse, expr1);
3152 gcc_assert (rss == gfc_ss_terminator);
3153 gfc_init_se (&rse, NULL);
3154 rse.want_pointer = 1;
3155 gfc_conv_expr (&rse, expr2);
3156 gfc_add_block_to_block (&block, &lse.pre);
3157 gfc_add_block_to_block (&block, &rse.pre);
3158 gfc_add_modify_expr (&block, lse.expr,
3159 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3160 gfc_add_block_to_block (&block, &rse.post);
3161 gfc_add_block_to_block (&block, &lse.post);
3165 /* Array pointer. */
3166 gfc_conv_expr_descriptor (&lse, expr1, lss);
3167 switch (expr2->expr_type)
3170 /* Just set the data pointer to null. */
3171 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3175 /* Assign directly to the pointer's descriptor. */
3176 lse.direct_byref = 1;
3177 gfc_conv_expr_descriptor (&lse, expr2, rss);
3181 /* Assign to a temporary descriptor and then copy that
3182 temporary to the pointer. */
3184 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3187 lse.direct_byref = 1;
3188 gfc_conv_expr_descriptor (&lse, expr2, rss);
3189 gfc_add_modify_expr (&lse.pre, desc, tmp);
3192 gfc_add_block_to_block (&block, &lse.pre);
3193 gfc_add_block_to_block (&block, &lse.post);
3195 return gfc_finish_block (&block);
3199 /* Makes sure se is suitable for passing as a function string parameter. */
3200 /* TODO: Need to check all callers fo this function. It may be abused. */
3203 gfc_conv_string_parameter (gfc_se * se)
3207 if (TREE_CODE (se->expr) == STRING_CST)
3209 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3213 type = TREE_TYPE (se->expr);
3214 if (TYPE_STRING_FLAG (type))
3216 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
3217 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
3220 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3221 gcc_assert (se->string_length
3222 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3226 /* Generate code for assignment of scalar variables. Includes character
3227 strings and derived types with allocatable components. */
3230 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3231 bool l_is_temp, bool r_is_var)
3237 gfc_init_block (&block);
3239 if (ts.type == BT_CHARACTER)
3241 gcc_assert (lse->string_length != NULL_TREE
3242 && rse->string_length != NULL_TREE);
3244 gfc_conv_string_parameter (lse);
3245 gfc_conv_string_parameter (rse);
3247 gfc_add_block_to_block (&block, &lse->pre);
3248 gfc_add_block_to_block (&block, &rse->pre);
3250 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
3251 rse->string_length, rse->expr);
3253 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
3257 /* Are the rhs and the lhs the same? */
3260 cond = fold_build2 (EQ_EXPR, boolean_type_node,
3261 build_fold_addr_expr (lse->expr),
3262 build_fold_addr_expr (rse->expr));
3263 cond = gfc_evaluate_now (cond, &lse->pre);
3266 /* Deallocate the lhs allocated components as long as it is not
3267 the same as the rhs. */
3270 tmp = gfc_deallocate_alloc_comp (ts.derived, lse->expr, 0);
3272 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3273 gfc_add_expr_to_block (&lse->pre, tmp);
3276 gfc_add_block_to_block (&block, &lse->pre);
3277 gfc_add_block_to_block (&block, &rse->pre);
3279 gfc_add_modify_expr (&block, lse->expr,
3280 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3282 /* Do a deep copy if the rhs is a variable, if it is not the
3286 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
3287 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
3288 gfc_add_expr_to_block (&block, tmp);
3293 gfc_add_block_to_block (&block, &lse->pre);
3294 gfc_add_block_to_block (&block, &rse->pre);
3296 gfc_add_modify_expr (&block, lse->expr,
3297 fold_convert (TREE_TYPE (lse->expr), rse->expr));
3300 gfc_add_block_to_block (&block, &lse->post);
3301 gfc_add_block_to_block (&block, &rse->post);
3303 return gfc_finish_block (&block);
3307 /* Try to translate array(:) = func (...), where func is a transformational
3308 array function, without using a temporary. Returns NULL is this isn't the
3312 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
3317 bool seen_array_ref;
3319 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
3320 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
3323 /* Elemental functions don't need a temporary anyway. */
3324 if (expr2->value.function.esym != NULL
3325 && expr2->value.function.esym->attr.elemental)
3328 /* Fail if EXPR1 can't be expressed as a descriptor. */
3329 if (gfc_ref_needs_temporary_p (expr1->ref))
3332 /* Functions returning pointers need temporaries. */
3333 if (expr2->symtree->n.sym->attr.pointer
3334 || expr2->symtree->n.sym->attr.allocatable)
3337 /* Check that no LHS component references appear during an array
3338 reference. This is needed because we do not have the means to
3339 span any arbitrary stride with an array descriptor. This check
3340 is not needed for the rhs because the function result has to be
3342 seen_array_ref = false;
3343 for (ref = expr1->ref; ref; ref = ref->next)
3345 if (ref->type == REF_ARRAY)
3346 seen_array_ref= true;
3347 else if (ref->type == REF_COMPONENT && seen_array_ref)
3351 /* Check for a dependency. */
3352 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
3353 expr2->value.function.esym,
3354 expr2->value.function.actual))
3357 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
3359 gcc_assert (expr2->value.function.isym
3360 || (gfc_return_by_reference (expr2->value.function.esym)
3361 && expr2->value.function.esym->result->attr.dimension));
3363 ss = gfc_walk_expr (expr1);
3364 gcc_assert (ss != gfc_ss_terminator);
3365 gfc_init_se (&se, NULL);
3366 gfc_start_block (&se.pre);
3367 se.want_pointer = 1;
3369 gfc_conv_array_parameter (&se, expr1, ss, 0);
3371 se.direct_byref = 1;
3372 se.ss = gfc_walk_expr (expr2);
3373 gcc_assert (se.ss != gfc_ss_terminator);
3374 gfc_conv_function_expr (&se, expr2);
3375 gfc_add_block_to_block (&se.pre, &se.post);
3377 return gfc_finish_block (&se.pre);
3381 /* Translate an assignment. Most of the code is concerned with
3382 setting up the scalarizer. */
3385 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
3390 gfc_ss *lss_section;
3398 /* Special case a single function returning an array. */
3399 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3401 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3406 /* Assignment of the form lhs = rhs. */
3407 gfc_start_block (&block);
3409 gfc_init_se (&lse, NULL);
3410 gfc_init_se (&rse, NULL);
3413 lss = gfc_walk_expr (expr1);
3415 if (lss != gfc_ss_terminator)
3417 /* The assignment needs scalarization. */
3420 /* Find a non-scalar SS from the lhs. */
3421 while (lss_section != gfc_ss_terminator
3422 && lss_section->type != GFC_SS_SECTION)
3423 lss_section = lss_section->next;
3425 gcc_assert (lss_section != gfc_ss_terminator);
3427 /* Initialize the scalarizer. */
3428 gfc_init_loopinfo (&loop);
3431 rss = gfc_walk_expr (expr2);
3432 if (rss == gfc_ss_terminator)
3434 /* The rhs is scalar. Add a ss for the expression. */
3435 rss = gfc_get_ss ();
3436 rss->next = gfc_ss_terminator;
3437 rss->type = GFC_SS_SCALAR;
3440 /* Associate the SS with the loop. */
3441 gfc_add_ss_to_loop (&loop, lss);
3442 gfc_add_ss_to_loop (&loop, rss);
3444 /* Calculate the bounds of the scalarization. */
3445 gfc_conv_ss_startstride (&loop);
3446 /* Resolve any data dependencies in the statement. */
3447 gfc_conv_resolve_dependencies (&loop, lss, rss);
3448 /* Setup the scalarizing loops. */
3449 gfc_conv_loop_setup (&loop);
3451 /* Setup the gfc_se structures. */
3452 gfc_copy_loopinfo_to_se (&lse, &loop);
3453 gfc_copy_loopinfo_to_se (&rse, &loop);
3456 gfc_mark_ss_chain_used (rss, 1);
3457 if (loop.temp_ss == NULL)
3460 gfc_mark_ss_chain_used (lss, 1);
3464 lse.ss = loop.temp_ss;
3465 gfc_mark_ss_chain_used (lss, 3);
3466 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3469 /* Start the scalarized loop body. */
3470 gfc_start_scalarized_body (&loop, &body);
3473 gfc_init_block (&body);
3475 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
3477 /* Translate the expression. */
3478 gfc_conv_expr (&rse, expr2);
3482 gfc_conv_tmp_array_ref (&lse);
3483 gfc_advance_se_ss_chain (&lse);
3486 gfc_conv_expr (&lse, expr1);
3488 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3489 l_is_temp || init_flag,
3490 expr2->expr_type == EXPR_VARIABLE);
3491 gfc_add_expr_to_block (&body, tmp);
3493 if (lss == gfc_ss_terminator)
3495 /* Use the scalar assignment as is. */
3496 gfc_add_block_to_block (&block, &body);
3500 gcc_assert (lse.ss == gfc_ss_terminator
3501 && rse.ss == gfc_ss_terminator);
3505 gfc_trans_scalarized_loop_boundary (&loop, &body);
3507 /* We need to copy the temporary to the actual lhs. */
3508 gfc_init_se (&lse, NULL);
3509 gfc_init_se (&rse, NULL);
3510 gfc_copy_loopinfo_to_se (&lse, &loop);
3511 gfc_copy_loopinfo_to_se (&rse, &loop);
3513 rse.ss = loop.temp_ss;
3516 gfc_conv_tmp_array_ref (&rse);
3517 gfc_advance_se_ss_chain (&rse);
3518 gfc_conv_expr (&lse, expr1);
3520 gcc_assert (lse.ss == gfc_ss_terminator
3521 && rse.ss == gfc_ss_terminator);
3523 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3525 gfc_add_expr_to_block (&body, tmp);
3528 /* Generate the copying loops. */
3529 gfc_trans_scalarizing_loops (&loop, &body);
3531 /* Wrap the whole thing up. */
3532 gfc_add_block_to_block (&block, &loop.pre);
3533 gfc_add_block_to_block (&block, &loop.post);
3535 gfc_cleanup_loop (&loop);
3538 return gfc_finish_block (&block);
3542 gfc_trans_init_assign (gfc_code * code)
3544 return gfc_trans_assignment (code->expr, code->expr2, true);
3548 gfc_trans_assign (gfc_code * code)
3550 return gfc_trans_assignment (code->expr, code->expr2, false);