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"
37 #include "trans-const.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
41 #include "trans-stmt.h"
42 #include "dependency.h"
44 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
48 /* Copy the scalarization loop variables. */
51 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
54 dest->loop = src->loop;
58 /* Initialize a simple expression holder.
60 Care must be taken when multiple se are created with the same parent.
61 The child se must be kept in sync. The easiest way is to delay creation
62 of a child se until after after the previous se has been translated. */
65 gfc_init_se (gfc_se * se, gfc_se * parent)
67 memset (se, 0, sizeof (gfc_se));
68 gfc_init_block (&se->pre);
69 gfc_init_block (&se->post);
74 gfc_copy_se_loopvars (se, parent);
78 /* Advances to the next SS in the chain. Use this rather than setting
79 se->ss = se->ss->next because all the parents needs to be kept in sync.
83 gfc_advance_se_ss_chain (gfc_se * se)
87 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
90 /* Walk down the parent chain. */
93 /* Simple consistency check. */
94 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
103 /* Ensures the result of the expression as either a temporary variable
104 or a constant so that it can be used repeatedly. */
107 gfc_make_safe_expr (gfc_se * se)
111 if (CONSTANT_CLASS_P (se->expr))
114 /* We need a temporary for this result. */
115 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
116 gfc_add_modify_expr (&se->pre, var, se->expr);
121 /* Return an expression which determines if a dummy parameter is present.
122 Also used for arguments to procedures with multiple entry points. */
125 gfc_conv_expr_present (gfc_symbol * sym)
129 gcc_assert (sym->attr.dummy);
131 decl = gfc_get_symbol_decl (sym);
132 if (TREE_CODE (decl) != PARM_DECL)
134 /* Array parameters use a temporary descriptor, we want the real
136 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
137 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
138 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
140 return build2 (NE_EXPR, boolean_type_node, decl,
141 fold_convert (TREE_TYPE (decl), null_pointer_node));
145 /* Get the character length of an expression, looking through gfc_refs
149 gfc_get_expr_charlen (gfc_expr *e)
154 gcc_assert (e->expr_type == EXPR_VARIABLE
155 && e->ts.type == BT_CHARACTER);
157 length = NULL; /* To silence compiler warning. */
159 /* First candidate: if the variable is of type CHARACTER, the
160 expression's length could be the length of the character
162 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
163 length = e->symtree->n.sym->ts.cl->backend_decl;
165 /* Look through the reference chain for component references. */
166 for (r = e->ref; r; r = r->next)
171 if (r->u.c.component->ts.type == BT_CHARACTER)
172 length = r->u.c.component->ts.cl->backend_decl;
180 /* We should never got substring references here. These will be
181 broken down by the scalarizer. */
186 gcc_assert (length != NULL);
192 /* Generate code to initialize a string length variable. Returns the
196 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
201 gfc_init_se (&se, NULL);
202 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
203 gfc_add_block_to_block (pblock, &se.pre);
205 tmp = cl->backend_decl;
206 gfc_add_modify_expr (pblock, tmp, se.expr);
211 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
219 type = gfc_get_character_type (kind, ref->u.ss.length);
220 type = build_pointer_type (type);
223 gfc_init_se (&start, se);
224 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
225 gfc_add_block_to_block (&se->pre, &start.pre);
227 if (integer_onep (start.expr))
228 gfc_conv_string_parameter (se);
231 /* Change the start of the string. */
232 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
235 tmp = build_fold_indirect_ref (se->expr);
236 tmp = gfc_build_array_ref (tmp, start.expr);
237 se->expr = gfc_build_addr_expr (type, tmp);
240 /* Length = end + 1 - start. */
241 gfc_init_se (&end, se);
242 if (ref->u.ss.end == NULL)
243 end.expr = se->string_length;
246 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
247 gfc_add_block_to_block (&se->pre, &end.pre);
249 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
250 build_int_cst (gfc_charlen_type_node, 1),
252 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
253 se->string_length = tmp;
257 /* Convert a derived type component reference. */
260 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
267 c = ref->u.c.component;
269 gcc_assert (c->backend_decl);
271 field = c->backend_decl;
272 gcc_assert (TREE_CODE (field) == FIELD_DECL);
274 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
278 if (c->ts.type == BT_CHARACTER)
280 tmp = c->ts.cl->backend_decl;
281 /* Components must always be constant length. */
282 gcc_assert (tmp && INTEGER_CST_P (tmp));
283 se->string_length = tmp;
286 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
287 se->expr = build_fold_indirect_ref (se->expr);
291 /* Return the contents of a variable. Also handles reference/pointer
292 variables (all Fortran pointer references are implicit). */
295 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
300 sym = expr->symtree->n.sym;
303 /* Check that something hasn't gone horribly wrong. */
304 gcc_assert (se->ss != gfc_ss_terminator);
305 gcc_assert (se->ss->expr == expr);
307 /* A scalarized term. We already know the descriptor. */
308 se->expr = se->ss->data.info.descriptor;
309 se->string_length = se->ss->string_length;
310 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
311 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
316 tree se_expr = NULL_TREE;
318 se->expr = gfc_get_symbol_decl (sym);
320 /* Special case for assigning the return value of a function.
321 Self recursive functions must have an explicit return value. */
322 if (se->expr == current_function_decl && sym->attr.function
323 && (sym->result == sym))
324 se_expr = gfc_get_fake_result_decl (sym);
326 /* Similarly for alternate entry points. */
327 else if (sym->attr.function && sym->attr.entry
328 && (sym->result == sym)
329 && sym->ns->proc_name->backend_decl == current_function_decl)
331 gfc_entry_list *el = NULL;
333 for (el = sym->ns->entries; el; el = el->next)
336 se_expr = gfc_get_fake_result_decl (sym);
341 else if (sym->attr.result
342 && sym->ns->proc_name->backend_decl == current_function_decl
343 && sym->ns->proc_name->attr.entry_master
344 && !gfc_return_by_reference (sym->ns->proc_name))
345 se_expr = gfc_get_fake_result_decl (sym);
350 /* Procedure actual arguments. */
351 else if (sym->attr.flavor == FL_PROCEDURE
352 && se->expr != current_function_decl)
354 gcc_assert (se->want_pointer);
355 if (!sym->attr.dummy)
357 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
358 se->expr = build_fold_addr_expr (se->expr);
364 /* Dereference the expression, where needed. Since characters
365 are entirely different from other types, they are treated
367 if (sym->ts.type == BT_CHARACTER)
369 /* Dereference character pointer dummy arguments
371 if ((sym->attr.pointer || sym->attr.allocatable)
373 || sym->attr.function
374 || sym->attr.result))
375 se->expr = build_fold_indirect_ref (se->expr);
379 /* Dereference non-character scalar dummy arguments. */
380 if (sym->attr.dummy && !sym->attr.dimension)
381 se->expr = build_fold_indirect_ref (se->expr);
383 /* Dereference scalar hidden result. */
384 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
385 && (sym->attr.function || sym->attr.result)
386 && !sym->attr.dimension && !sym->attr.pointer)
387 se->expr = build_fold_indirect_ref (se->expr);
389 /* Dereference non-character pointer variables.
390 These must be dummies, results, or scalars. */
391 if ((sym->attr.pointer || sym->attr.allocatable)
393 || sym->attr.function
395 || !sym->attr.dimension))
396 se->expr = build_fold_indirect_ref (se->expr);
402 /* For character variables, also get the length. */
403 if (sym->ts.type == BT_CHARACTER)
405 /* If the character length of an entry isn't set, get the length from
406 the master function instead. */
407 if (sym->attr.entry && !sym->ts.cl->backend_decl)
408 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
410 se->string_length = sym->ts.cl->backend_decl;
411 gcc_assert (se->string_length);
419 /* Return the descriptor if that's what we want and this is an array
420 section reference. */
421 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
423 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
424 /* Return the descriptor for array pointers and allocations. */
426 && ref->next == NULL && (se->descriptor_only))
429 gfc_conv_array_ref (se, &ref->u.ar);
430 /* Return a pointer to an element. */
434 gfc_conv_component_ref (se, ref);
438 gfc_conv_substring (se, ref, expr->ts.kind);
447 /* Pointer assignment, allocation or pass by reference. Arrays are handled
449 if (se->want_pointer)
451 if (expr->ts.type == BT_CHARACTER)
452 gfc_conv_string_parameter (se);
454 se->expr = build_fold_addr_expr (se->expr);
459 /* Unary ops are easy... Or they would be if ! was a valid op. */
462 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
467 gcc_assert (expr->ts.type != BT_CHARACTER);
468 /* Initialize the operand. */
469 gfc_init_se (&operand, se);
470 gfc_conv_expr_val (&operand, expr->value.op.op1);
471 gfc_add_block_to_block (&se->pre, &operand.pre);
473 type = gfc_typenode_for_spec (&expr->ts);
475 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
476 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
477 All other unary operators have an equivalent GIMPLE unary operator. */
478 if (code == TRUTH_NOT_EXPR)
479 se->expr = build2 (EQ_EXPR, type, operand.expr,
480 convert (type, integer_zero_node));
482 se->expr = build1 (code, type, operand.expr);
486 /* Expand power operator to optimal multiplications when a value is raised
487 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
488 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
489 Programming", 3rd Edition, 1998. */
491 /* This code is mostly duplicated from expand_powi in the backend.
492 We establish the "optimal power tree" lookup table with the defined size.
493 The items in the table are the exponents used to calculate the index
494 exponents. Any integer n less than the value can get an "addition chain",
495 with the first node being one. */
496 #define POWI_TABLE_SIZE 256
498 /* The table is from builtins.c. */
499 static const unsigned char powi_table[POWI_TABLE_SIZE] =
501 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
502 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
503 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
504 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
505 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
506 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
507 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
508 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
509 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
510 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
511 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
512 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
513 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
514 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
515 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
516 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
517 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
518 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
519 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
520 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
521 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
522 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
523 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
524 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
525 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
526 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
527 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
528 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
529 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
530 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
531 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
532 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
535 /* If n is larger than lookup table's max index, we use the "window
537 #define POWI_WINDOW_SIZE 3
539 /* Recursive function to expand the power operator. The temporary
540 values are put in tmpvar. The function returns tmpvar[1] ** n. */
542 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
549 if (n < POWI_TABLE_SIZE)
554 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
555 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
559 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
560 op0 = gfc_conv_powi (se, n - digit, tmpvar);
561 op1 = gfc_conv_powi (se, digit, tmpvar);
565 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
569 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
570 tmp = gfc_evaluate_now (tmp, &se->pre);
572 if (n < POWI_TABLE_SIZE)
579 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
580 return 1. Else return 0 and a call to runtime library functions
581 will have to be built. */
583 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
588 tree vartmp[POWI_TABLE_SIZE];
592 type = TREE_TYPE (lhs);
593 n = abs (TREE_INT_CST_LOW (rhs));
594 sgn = tree_int_cst_sgn (rhs);
596 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
597 && (n > 2 || n < -1))
603 se->expr = gfc_build_const (type, integer_one_node);
606 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
607 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
609 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
610 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
611 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
612 convert (TREE_TYPE (lhs), integer_one_node));
615 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
618 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
619 se->expr = build3 (COND_EXPR, type, tmp,
620 convert (type, integer_one_node),
621 convert (type, integer_zero_node));
625 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
626 tmp = build3 (COND_EXPR, type, tmp,
627 convert (type, integer_minus_one_node),
628 convert (type, integer_zero_node));
629 se->expr = build3 (COND_EXPR, type, cond,
630 convert (type, integer_one_node),
635 memset (vartmp, 0, sizeof (vartmp));
639 tmp = gfc_build_const (type, integer_one_node);
640 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
643 se->expr = gfc_conv_powi (se, n, vartmp);
649 /* Power op (**). Constant integer exponent has special handling. */
652 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
654 tree gfc_int4_type_node;
662 gfc_init_se (&lse, se);
663 gfc_conv_expr_val (&lse, expr->value.op.op1);
664 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
665 gfc_add_block_to_block (&se->pre, &lse.pre);
667 gfc_init_se (&rse, se);
668 gfc_conv_expr_val (&rse, expr->value.op.op2);
669 gfc_add_block_to_block (&se->pre, &rse.pre);
671 if (expr->value.op.op2->ts.type == BT_INTEGER
672 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
673 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
676 gfc_int4_type_node = gfc_get_int_type (4);
678 kind = expr->value.op.op1->ts.kind;
679 switch (expr->value.op.op2->ts.type)
682 ikind = expr->value.op.op2->ts.kind;
687 rse.expr = convert (gfc_int4_type_node, rse.expr);
709 if (expr->value.op.op1->ts.type == BT_INTEGER)
710 lse.expr = convert (gfc_int4_type_node, lse.expr);
735 switch (expr->value.op.op1->ts.type)
738 if (kind == 3) /* Case 16 was not handled properly above. */
740 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
744 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
748 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
760 fndecl = built_in_decls[BUILT_IN_POWF];
763 fndecl = built_in_decls[BUILT_IN_POW];
767 fndecl = built_in_decls[BUILT_IN_POWL];
778 fndecl = gfor_fndecl_math_cpowf;
781 fndecl = gfor_fndecl_math_cpow;
784 fndecl = gfor_fndecl_math_cpowl10;
787 fndecl = gfor_fndecl_math_cpowl16;
799 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
800 tmp = gfc_chainon_list (tmp, rse.expr);
801 se->expr = build_function_call_expr (fndecl, tmp);
805 /* Generate code to allocate a string temporary. */
808 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
814 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
816 if (gfc_can_put_var_on_stack (len))
818 /* Create a temporary variable to hold the result. */
819 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
820 convert (gfc_charlen_type_node, integer_one_node));
821 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
822 tmp = build_array_type (gfc_character1_type_node, tmp);
823 var = gfc_create_var (tmp, "str");
824 var = gfc_build_addr_expr (type, var);
828 /* Allocate a temporary to hold the result. */
829 var = gfc_create_var (type, "pstr");
830 args = gfc_chainon_list (NULL_TREE, len);
831 tmp = build_function_call_expr (gfor_fndecl_internal_malloc, args);
832 tmp = convert (type, tmp);
833 gfc_add_modify_expr (&se->pre, var, tmp);
835 /* Free the temporary afterwards. */
836 tmp = convert (pvoid_type_node, var);
837 args = gfc_chainon_list (NULL_TREE, tmp);
838 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
839 gfc_add_expr_to_block (&se->post, tmp);
846 /* Handle a string concatenation operation. A temporary will be allocated to
850 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
860 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
861 && expr->value.op.op2->ts.type == BT_CHARACTER);
863 gfc_init_se (&lse, se);
864 gfc_conv_expr (&lse, expr->value.op.op1);
865 gfc_conv_string_parameter (&lse);
866 gfc_init_se (&rse, se);
867 gfc_conv_expr (&rse, expr->value.op.op2);
868 gfc_conv_string_parameter (&rse);
870 gfc_add_block_to_block (&se->pre, &lse.pre);
871 gfc_add_block_to_block (&se->pre, &rse.pre);
873 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
874 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
875 if (len == NULL_TREE)
877 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
878 lse.string_length, rse.string_length);
881 type = build_pointer_type (type);
883 var = gfc_conv_string_tmp (se, type, len);
885 /* Do the actual concatenation. */
887 args = gfc_chainon_list (args, len);
888 args = gfc_chainon_list (args, var);
889 args = gfc_chainon_list (args, lse.string_length);
890 args = gfc_chainon_list (args, lse.expr);
891 args = gfc_chainon_list (args, rse.string_length);
892 args = gfc_chainon_list (args, rse.expr);
893 tmp = build_function_call_expr (gfor_fndecl_concat_string, args);
894 gfc_add_expr_to_block (&se->pre, tmp);
896 /* Add the cleanup for the operands. */
897 gfc_add_block_to_block (&se->pre, &rse.post);
898 gfc_add_block_to_block (&se->pre, &lse.post);
901 se->string_length = len;
904 /* Translates an op expression. Common (binary) cases are handled by this
905 function, others are passed on. Recursion is used in either case.
906 We use the fact that (op1.ts == op2.ts) (except for the power
908 Operators need no special handling for scalarized expressions as long as
909 they call gfc_conv_simple_val to get their operands.
910 Character strings get special handling. */
913 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
925 switch (expr->value.op.operator)
927 case INTRINSIC_UPLUS:
928 gfc_conv_expr (se, expr->value.op.op1);
931 case INTRINSIC_UMINUS:
932 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
936 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
943 case INTRINSIC_MINUS:
947 case INTRINSIC_TIMES:
951 case INTRINSIC_DIVIDE:
952 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
953 an integer, we must round towards zero, so we use a
955 if (expr->ts.type == BT_INTEGER)
956 code = TRUNC_DIV_EXPR;
961 case INTRINSIC_POWER:
962 gfc_conv_power_op (se, expr);
965 case INTRINSIC_CONCAT:
966 gfc_conv_concat_op (se, expr);
970 code = TRUTH_ANDIF_EXPR;
975 code = TRUTH_ORIF_EXPR;
979 /* EQV and NEQV only work on logicals, but since we represent them
980 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1019 case INTRINSIC_USER:
1020 case INTRINSIC_ASSIGN:
1021 /* These should be converted into function calls by the frontend. */
1025 fatal_error ("Unknown intrinsic op");
1029 /* The only exception to this is **, which is handled separately anyway. */
1030 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1032 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1036 gfc_init_se (&lse, se);
1037 gfc_conv_expr (&lse, expr->value.op.op1);
1038 gfc_add_block_to_block (&se->pre, &lse.pre);
1041 gfc_init_se (&rse, se);
1042 gfc_conv_expr (&rse, expr->value.op.op2);
1043 gfc_add_block_to_block (&se->pre, &rse.pre);
1047 gfc_conv_string_parameter (&lse);
1048 gfc_conv_string_parameter (&rse);
1050 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1051 rse.string_length, rse.expr);
1052 rse.expr = integer_zero_node;
1053 gfc_add_block_to_block (&lse.post, &rse.post);
1056 type = gfc_typenode_for_spec (&expr->ts);
1060 /* The result of logical ops is always boolean_type_node. */
1061 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1062 se->expr = convert (type, tmp);
1065 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1067 /* Add the post blocks. */
1068 gfc_add_block_to_block (&se->post, &rse.post);
1069 gfc_add_block_to_block (&se->post, &lse.post);
1072 /* If a string's length is one, we convert it to a single character. */
1075 gfc_to_single_character (tree len, tree str)
1077 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1079 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1080 && TREE_INT_CST_HIGH (len) == 0)
1082 str = fold_convert (pchar_type_node, str);
1083 return build_fold_indirect_ref (str);
1089 /* Compare two strings. If they are all single characters, the result is the
1090 subtraction of them. Otherwise, we build a library call. */
1093 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2)
1100 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1101 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1103 type = gfc_get_int_type (gfc_default_integer_kind);
1105 sc1 = gfc_to_single_character (len1, str1);
1106 sc2 = gfc_to_single_character (len2, str2);
1108 /* Deal with single character specially. */
1109 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1111 sc1 = fold_convert (type, sc1);
1112 sc2 = fold_convert (type, sc2);
1113 tmp = fold_build2 (MINUS_EXPR, type, sc1, sc2);
1118 tmp = gfc_chainon_list (tmp, len1);
1119 tmp = gfc_chainon_list (tmp, str1);
1120 tmp = gfc_chainon_list (tmp, len2);
1121 tmp = gfc_chainon_list (tmp, str2);
1123 /* Build a call for the comparison. */
1124 tmp = build_function_call_expr (gfor_fndecl_compare_string, tmp);
1131 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1135 if (sym->attr.dummy)
1137 tmp = gfc_get_symbol_decl (sym);
1138 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1139 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1143 if (!sym->backend_decl)
1144 sym->backend_decl = gfc_get_extern_function_decl (sym);
1146 tmp = sym->backend_decl;
1147 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1149 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1150 tmp = build_fold_addr_expr (tmp);
1157 /* Initialize MAPPING. */
1160 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1162 mapping->syms = NULL;
1163 mapping->charlens = NULL;
1167 /* Free all memory held by MAPPING (but not MAPPING itself). */
1170 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1172 gfc_interface_sym_mapping *sym;
1173 gfc_interface_sym_mapping *nextsym;
1175 gfc_charlen *nextcl;
1177 for (sym = mapping->syms; sym; sym = nextsym)
1179 nextsym = sym->next;
1180 gfc_free_symbol (sym->new->n.sym);
1181 gfc_free (sym->new);
1184 for (cl = mapping->charlens; cl; cl = nextcl)
1187 gfc_free_expr (cl->length);
1193 /* Return a copy of gfc_charlen CL. Add the returned structure to
1194 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1196 static gfc_charlen *
1197 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1202 new = gfc_get_charlen ();
1203 new->next = mapping->charlens;
1204 new->length = gfc_copy_expr (cl->length);
1206 mapping->charlens = new;
1211 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1212 array variable that can be used as the actual argument for dummy
1213 argument SYM. Add any initialization code to BLOCK. PACKED is as
1214 for gfc_get_nodesc_array_type and DATA points to the first element
1215 in the passed array. */
1218 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1219 int packed, tree data)
1224 type = gfc_typenode_for_spec (&sym->ts);
1225 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1227 var = gfc_create_var (type, "parm");
1228 gfc_add_modify_expr (block, var, fold_convert (type, data));
1234 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1235 and offset of descriptorless array type TYPE given that it has the same
1236 size as DESC. Add any set-up code to BLOCK. */
1239 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1246 offset = gfc_index_zero_node;
1247 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1249 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1250 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1252 dim = gfc_rank_cst[n];
1253 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1254 gfc_conv_descriptor_ubound (desc, dim),
1255 gfc_conv_descriptor_lbound (desc, dim));
1256 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1257 GFC_TYPE_ARRAY_LBOUND (type, n),
1259 tmp = gfc_evaluate_now (tmp, block);
1260 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1262 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1263 GFC_TYPE_ARRAY_LBOUND (type, n),
1264 GFC_TYPE_ARRAY_STRIDE (type, n));
1265 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1267 offset = gfc_evaluate_now (offset, block);
1268 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1272 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1273 in SE. The caller may still use se->expr and se->string_length after
1274 calling this function. */
1277 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1278 gfc_symbol * sym, gfc_se * se)
1280 gfc_interface_sym_mapping *sm;
1284 gfc_symbol *new_sym;
1286 gfc_symtree *new_symtree;
1288 /* Create a new symbol to represent the actual argument. */
1289 new_sym = gfc_new_symbol (sym->name, NULL);
1290 new_sym->ts = sym->ts;
1291 new_sym->attr.referenced = 1;
1292 new_sym->attr.dimension = sym->attr.dimension;
1293 new_sym->attr.pointer = sym->attr.pointer;
1294 new_sym->attr.flavor = sym->attr.flavor;
1296 /* Create a fake symtree for it. */
1298 new_symtree = gfc_new_symtree (&root, sym->name);
1299 new_symtree->n.sym = new_sym;
1300 gcc_assert (new_symtree == root);
1302 /* Create a dummy->actual mapping. */
1303 sm = gfc_getmem (sizeof (*sm));
1304 sm->next = mapping->syms;
1306 sm->new = new_symtree;
1309 /* Stabilize the argument's value. */
1310 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1312 if (sym->ts.type == BT_CHARACTER)
1314 /* Create a copy of the dummy argument's length. */
1315 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1317 /* If the length is specified as "*", record the length that
1318 the caller is passing. We should use the callee's length
1319 in all other cases. */
1320 if (!new_sym->ts.cl->length)
1322 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1323 new_sym->ts.cl->backend_decl = se->string_length;
1327 /* Use the passed value as-is if the argument is a function. */
1328 if (sym->attr.flavor == FL_PROCEDURE)
1331 /* If the argument is either a string or a pointer to a string,
1332 convert it to a boundless character type. */
1333 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1335 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1336 tmp = build_pointer_type (tmp);
1337 if (sym->attr.pointer)
1338 tmp = build_pointer_type (tmp);
1340 value = fold_convert (tmp, se->expr);
1341 if (sym->attr.pointer)
1342 value = build_fold_indirect_ref (value);
1345 /* If the argument is a scalar or a pointer to an array, dereference it. */
1346 else if (!sym->attr.dimension || sym->attr.pointer)
1347 value = build_fold_indirect_ref (se->expr);
1349 /* If the argument is an array descriptor, use it to determine
1350 information about the actual argument's shape. */
1351 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1352 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1354 /* Get the actual argument's descriptor. */
1355 desc = build_fold_indirect_ref (se->expr);
1357 /* Create the replacement variable. */
1358 tmp = gfc_conv_descriptor_data_get (desc);
1359 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1361 /* Use DESC to work out the upper bounds, strides and offset. */
1362 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1365 /* Otherwise we have a packed array. */
1366 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1368 new_sym->backend_decl = value;
1372 /* Called once all dummy argument mappings have been added to MAPPING,
1373 but before the mapping is used to evaluate expressions. Pre-evaluate
1374 the length of each argument, adding any initialization code to PRE and
1375 any finalization code to POST. */
1378 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1379 stmtblock_t * pre, stmtblock_t * post)
1381 gfc_interface_sym_mapping *sym;
1385 for (sym = mapping->syms; sym; sym = sym->next)
1386 if (sym->new->n.sym->ts.type == BT_CHARACTER
1387 && !sym->new->n.sym->ts.cl->backend_decl)
1389 expr = sym->new->n.sym->ts.cl->length;
1390 gfc_apply_interface_mapping_to_expr (mapping, expr);
1391 gfc_init_se (&se, NULL);
1392 gfc_conv_expr (&se, expr);
1394 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1395 gfc_add_block_to_block (pre, &se.pre);
1396 gfc_add_block_to_block (post, &se.post);
1398 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1403 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1407 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1408 gfc_constructor * c)
1410 for (; c; c = c->next)
1412 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1415 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1416 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1417 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1423 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1427 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1432 for (; ref; ref = ref->next)
1436 for (n = 0; n < ref->u.ar.dimen; n++)
1438 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1439 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1440 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1442 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1449 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1450 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1456 /* EXPR is a copy of an expression that appeared in the interface
1457 associated with MAPPING. Walk it recursively looking for references to
1458 dummy arguments that MAPPING maps to actual arguments. Replace each such
1459 reference with a reference to the associated actual argument. */
1462 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1465 gfc_interface_sym_mapping *sym;
1466 gfc_actual_arglist *actual;
1471 /* Copying an expression does not copy its length, so do that here. */
1472 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1474 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1475 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1478 /* Apply the mapping to any references. */
1479 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1481 /* ...and to the expression's symbol, if it has one. */
1483 for (sym = mapping->syms; sym; sym = sym->next)
1484 if (sym->old == expr->symtree->n.sym)
1485 expr->symtree = sym->new;
1487 /* ...and to subexpressions in expr->value. */
1488 switch (expr->expr_type)
1493 case EXPR_SUBSTRING:
1497 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1498 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1502 for (sym = mapping->syms; sym; sym = sym->next)
1503 if (sym->old == expr->value.function.esym)
1504 expr->value.function.esym = sym->new->n.sym;
1506 for (actual = expr->value.function.actual; actual; actual = actual->next)
1507 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1511 case EXPR_STRUCTURE:
1512 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1518 /* Evaluate interface expression EXPR using MAPPING. Store the result
1522 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1523 gfc_se * se, gfc_expr * expr)
1525 expr = gfc_copy_expr (expr);
1526 gfc_apply_interface_mapping_to_expr (mapping, expr);
1527 gfc_conv_expr (se, expr);
1528 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1529 gfc_free_expr (expr);
1533 /* Generate code for a procedure call. Note can return se->post != NULL.
1534 If se->direct_byref is set then se->expr contains the return parameter.
1535 Return nonzero, if the call has alternate specifiers. */
1538 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1539 gfc_actual_arglist * arg)
1541 gfc_interface_mapping mapping;
1554 gfc_formal_arglist *formal;
1555 int has_alternate_specifier = 0;
1556 bool need_interface_mapping;
1560 arglist = NULL_TREE;
1561 retargs = NULL_TREE;
1562 stringargs = NULL_TREE;
1568 if (!sym->attr.elemental)
1570 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1571 if (se->ss->useflags)
1573 gcc_assert (gfc_return_by_reference (sym)
1574 && sym->result->attr.dimension);
1575 gcc_assert (se->loop != NULL);
1577 /* Access the previously obtained result. */
1578 gfc_conv_tmp_array_ref (se);
1579 gfc_advance_se_ss_chain (se);
1583 info = &se->ss->data.info;
1588 gfc_init_interface_mapping (&mapping);
1589 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1590 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
1591 || sym->attr.dimension);
1592 formal = sym->formal;
1593 /* Evaluate the arguments. */
1594 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1596 if (arg->expr == NULL)
1599 if (se->ignore_optional)
1601 /* Some intrinsics have already been resolved to the correct
1605 else if (arg->label)
1607 has_alternate_specifier = 1;
1612 /* Pass a NULL pointer for an absent arg. */
1613 gfc_init_se (&parmse, NULL);
1614 parmse.expr = null_pointer_node;
1615 if (arg->missing_arg_type == BT_CHARACTER)
1616 parmse.string_length = convert (gfc_charlen_type_node,
1620 else if (se->ss && se->ss->useflags)
1622 /* An elemental function inside a scalarized loop. */
1623 gfc_init_se (&parmse, se);
1624 gfc_conv_expr_reference (&parmse, arg->expr);
1628 /* A scalar or transformational function. */
1629 gfc_init_se (&parmse, NULL);
1630 argss = gfc_walk_expr (arg->expr);
1632 if (argss == gfc_ss_terminator)
1634 gfc_conv_expr_reference (&parmse, arg->expr);
1635 if (formal && formal->sym->attr.pointer
1636 && arg->expr->expr_type != EXPR_NULL)
1638 /* Scalar pointer dummy args require an extra level of
1639 indirection. The null pointer already contains
1640 this level of indirection. */
1641 parmse.expr = build_fold_addr_expr (parmse.expr);
1646 /* If the procedure requires an explicit interface, the
1647 actual argument is passed according to the
1648 corresponding formal argument. If the corresponding
1649 formal argument is a POINTER or assumed shape, we do
1650 not use g77's calling convention, and pass the
1651 address of the array descriptor instead. Otherwise we
1652 use g77's calling convention. */
1654 f = (formal != NULL)
1655 && !formal->sym->attr.pointer
1656 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1657 f = f || !sym->attr.always_explicit;
1658 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1662 if (formal && need_interface_mapping)
1663 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1665 gfc_add_block_to_block (&se->pre, &parmse.pre);
1666 gfc_add_block_to_block (&se->post, &parmse.post);
1668 /* Character strings are passed as two parameters, a length and a
1670 if (parmse.string_length != NULL_TREE)
1671 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1673 arglist = gfc_chainon_list (arglist, parmse.expr);
1675 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1678 if (ts.type == BT_CHARACTER)
1680 /* Calculate the length of the returned string. */
1681 gfc_init_se (&parmse, NULL);
1682 if (need_interface_mapping)
1683 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1685 gfc_conv_expr (&parmse, sym->ts.cl->length);
1686 gfc_add_block_to_block (&se->pre, &parmse.pre);
1687 gfc_add_block_to_block (&se->post, &parmse.post);
1689 /* Set up a charlen structure for it. */
1692 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1695 len = cl.backend_decl;
1698 byref = gfc_return_by_reference (sym);
1701 if (se->direct_byref)
1702 retargs = gfc_chainon_list (retargs, se->expr);
1703 else if (sym->result->attr.dimension)
1705 gcc_assert (se->loop && info);
1707 /* Set the type of the array. */
1708 tmp = gfc_typenode_for_spec (&ts);
1709 info->dimen = se->loop->dimen;
1711 /* Evaluate the bounds of the result, if known. */
1712 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1714 /* Allocate a temporary to store the result. */
1715 gfc_trans_allocate_temp_array (&se->pre, &se->post,
1716 se->loop, info, tmp, false);
1718 /* Zero the first stride to indicate a temporary. */
1719 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1720 gfc_add_modify_expr (&se->pre, tmp,
1721 convert (TREE_TYPE (tmp), integer_zero_node));
1723 /* Pass the temporary as the first argument. */
1724 tmp = info->descriptor;
1725 tmp = build_fold_addr_expr (tmp);
1726 retargs = gfc_chainon_list (retargs, tmp);
1728 else if (ts.type == BT_CHARACTER)
1730 /* Pass the string length. */
1731 type = gfc_get_character_type (ts.kind, ts.cl);
1732 type = build_pointer_type (type);
1734 /* Return an address to a char[0:len-1]* temporary for
1735 character pointers. */
1736 if (sym->attr.pointer || sym->attr.allocatable)
1738 /* Build char[0:len-1] * pstr. */
1739 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1740 build_int_cst (gfc_charlen_type_node, 1));
1741 tmp = build_range_type (gfc_array_index_type,
1742 gfc_index_zero_node, tmp);
1743 tmp = build_array_type (gfc_character1_type_node, tmp);
1744 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1746 /* Provide an address expression for the function arguments. */
1747 var = build_fold_addr_expr (var);
1750 var = gfc_conv_string_tmp (se, type, len);
1752 retargs = gfc_chainon_list (retargs, var);
1756 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
1758 type = gfc_get_complex_type (ts.kind);
1759 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
1760 retargs = gfc_chainon_list (retargs, var);
1763 /* Add the string length to the argument list. */
1764 if (ts.type == BT_CHARACTER)
1765 retargs = gfc_chainon_list (retargs, len);
1767 gfc_free_interface_mapping (&mapping);
1769 /* Add the return arguments. */
1770 arglist = chainon (retargs, arglist);
1772 /* Add the hidden string length parameters to the arguments. */
1773 arglist = chainon (arglist, stringargs);
1775 /* Generate the actual call. */
1776 gfc_conv_function_val (se, sym);
1777 /* If there are alternate return labels, function type should be
1778 integer. Can't modify the type in place though, since it can be shared
1779 with other functions. */
1780 if (has_alternate_specifier
1781 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1783 gcc_assert (! sym->attr.dummy);
1784 TREE_TYPE (sym->backend_decl)
1785 = build_function_type (integer_type_node,
1786 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1787 se->expr = build_fold_addr_expr (sym->backend_decl);
1790 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1791 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1792 arglist, NULL_TREE);
1794 /* If we have a pointer function, but we don't want a pointer, e.g.
1797 where f is pointer valued, we have to dereference the result. */
1798 if (!se->want_pointer && !byref && sym->attr.pointer)
1799 se->expr = build_fold_indirect_ref (se->expr);
1801 /* f2c calling conventions require a scalar default real function to
1802 return a double precision result. Convert this back to default
1803 real. We only care about the cases that can happen in Fortran 77.
1805 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1806 && sym->ts.kind == gfc_default_real_kind
1807 && !sym->attr.always_explicit)
1808 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1810 /* A pure function may still have side-effects - it may modify its
1812 TREE_SIDE_EFFECTS (se->expr) = 1;
1814 if (!sym->attr.pure)
1815 TREE_SIDE_EFFECTS (se->expr) = 1;
1820 /* Add the function call to the pre chain. There is no expression. */
1821 gfc_add_expr_to_block (&se->pre, se->expr);
1822 se->expr = NULL_TREE;
1824 if (!se->direct_byref)
1826 if (sym->attr.dimension)
1828 if (flag_bounds_check)
1830 /* Check the data pointer hasn't been modified. This would
1831 happen in a function returning a pointer. */
1832 tmp = gfc_conv_descriptor_data_get (info->descriptor);
1833 tmp = fold_build2 (NE_EXPR, boolean_type_node,
1835 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1837 se->expr = info->descriptor;
1838 /* Bundle in the string length. */
1839 se->string_length = len;
1841 else if (sym->ts.type == BT_CHARACTER)
1843 /* Dereference for character pointer results. */
1844 if (sym->attr.pointer || sym->attr.allocatable)
1845 se->expr = build_fold_indirect_ref (var);
1849 se->string_length = len;
1853 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1854 se->expr = build_fold_indirect_ref (var);
1859 return has_alternate_specifier;
1863 /* Generate code to copy a string. */
1866 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1867 tree slen, tree src)
1873 /* Deal with single character specially. */
1874 dsc = gfc_to_single_character (dlen, dest);
1875 ssc = gfc_to_single_character (slen, src);
1876 if (dsc != NULL_TREE && ssc != NULL_TREE)
1878 gfc_add_modify_expr (block, dsc, ssc);
1883 tmp = gfc_chainon_list (tmp, dlen);
1884 tmp = gfc_chainon_list (tmp, dest);
1885 tmp = gfc_chainon_list (tmp, slen);
1886 tmp = gfc_chainon_list (tmp, src);
1887 tmp = build_function_call_expr (gfor_fndecl_copy_string, tmp);
1888 gfc_add_expr_to_block (block, tmp);
1892 /* Translate a statement function.
1893 The value of a statement function reference is obtained by evaluating the
1894 expression using the values of the actual arguments for the values of the
1895 corresponding dummy arguments. */
1898 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1902 gfc_formal_arglist *fargs;
1903 gfc_actual_arglist *args;
1906 gfc_saved_var *saved_vars;
1912 sym = expr->symtree->n.sym;
1913 args = expr->value.function.actual;
1914 gfc_init_se (&lse, NULL);
1915 gfc_init_se (&rse, NULL);
1918 for (fargs = sym->formal; fargs; fargs = fargs->next)
1920 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1921 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1923 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1925 /* Each dummy shall be specified, explicitly or implicitly, to be
1927 gcc_assert (fargs->sym->attr.dimension == 0);
1930 /* Create a temporary to hold the value. */
1931 type = gfc_typenode_for_spec (&fsym->ts);
1932 temp_vars[n] = gfc_create_var (type, fsym->name);
1934 if (fsym->ts.type == BT_CHARACTER)
1936 /* Copy string arguments. */
1939 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1940 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1942 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1943 tmp = gfc_build_addr_expr (build_pointer_type (type),
1946 gfc_conv_expr (&rse, args->expr);
1947 gfc_conv_string_parameter (&rse);
1948 gfc_add_block_to_block (&se->pre, &lse.pre);
1949 gfc_add_block_to_block (&se->pre, &rse.pre);
1951 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1953 gfc_add_block_to_block (&se->pre, &lse.post);
1954 gfc_add_block_to_block (&se->pre, &rse.post);
1958 /* For everything else, just evaluate the expression. */
1959 gfc_conv_expr (&lse, args->expr);
1961 gfc_add_block_to_block (&se->pre, &lse.pre);
1962 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1963 gfc_add_block_to_block (&se->pre, &lse.post);
1969 /* Use the temporary variables in place of the real ones. */
1970 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1971 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1973 gfc_conv_expr (se, sym->value);
1975 if (sym->ts.type == BT_CHARACTER)
1977 gfc_conv_const_charlen (sym->ts.cl);
1979 /* Force the expression to the correct length. */
1980 if (!INTEGER_CST_P (se->string_length)
1981 || tree_int_cst_lt (se->string_length,
1982 sym->ts.cl->backend_decl))
1984 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1985 tmp = gfc_create_var (type, sym->name);
1986 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1987 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1988 se->string_length, se->expr);
1991 se->string_length = sym->ts.cl->backend_decl;
1994 /* Restore the original variables. */
1995 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1996 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1997 gfc_free (saved_vars);
2001 /* Translate a function expression. */
2004 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
2008 if (expr->value.function.isym)
2010 gfc_conv_intrinsic_function (se, expr);
2014 /* We distinguish statement functions from general functions to improve
2015 runtime performance. */
2016 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
2018 gfc_conv_statement_function (se, expr);
2022 /* expr.value.function.esym is the resolved (specific) function symbol for
2023 most functions. However this isn't set for dummy procedures. */
2024 sym = expr->value.function.esym;
2026 sym = expr->symtree->n.sym;
2027 gfc_conv_function_call (se, sym, expr->value.function.actual);
2032 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2034 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2035 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2037 gfc_conv_tmp_array_ref (se);
2038 gfc_advance_se_ss_chain (se);
2042 /* Build a static initializer. EXPR is the expression for the initial value.
2043 The other parameters describe the variable of the component being
2044 initialized. EXPR may be null. */
2047 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2048 bool array, bool pointer)
2052 if (!(expr || pointer))
2057 /* Arrays need special handling. */
2059 return gfc_build_null_descriptor (type);
2061 return gfc_conv_array_initializer (type, expr);
2064 return fold_convert (type, null_pointer_node);
2070 gfc_init_se (&se, NULL);
2071 gfc_conv_structure (&se, expr, 1);
2075 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2078 gfc_init_se (&se, NULL);
2079 gfc_conv_constant (&se, expr);
2086 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2098 gfc_start_block (&block);
2100 /* Initialize the scalarizer. */
2101 gfc_init_loopinfo (&loop);
2103 gfc_init_se (&lse, NULL);
2104 gfc_init_se (&rse, NULL);
2107 rss = gfc_walk_expr (expr);
2108 if (rss == gfc_ss_terminator)
2110 /* The rhs is scalar. Add a ss for the expression. */
2111 rss = gfc_get_ss ();
2112 rss->next = gfc_ss_terminator;
2113 rss->type = GFC_SS_SCALAR;
2117 /* Create a SS for the destination. */
2118 lss = gfc_get_ss ();
2119 lss->type = GFC_SS_COMPONENT;
2121 lss->shape = gfc_get_shape (cm->as->rank);
2122 lss->next = gfc_ss_terminator;
2123 lss->data.info.dimen = cm->as->rank;
2124 lss->data.info.descriptor = dest;
2125 lss->data.info.data = gfc_conv_array_data (dest);
2126 lss->data.info.offset = gfc_conv_array_offset (dest);
2127 for (n = 0; n < cm->as->rank; n++)
2129 lss->data.info.dim[n] = n;
2130 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2131 lss->data.info.stride[n] = gfc_index_one_node;
2133 mpz_init (lss->shape[n]);
2134 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2135 cm->as->lower[n]->value.integer);
2136 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2139 /* Associate the SS with the loop. */
2140 gfc_add_ss_to_loop (&loop, lss);
2141 gfc_add_ss_to_loop (&loop, rss);
2143 /* Calculate the bounds of the scalarization. */
2144 gfc_conv_ss_startstride (&loop);
2146 /* Setup the scalarizing loops. */
2147 gfc_conv_loop_setup (&loop);
2149 /* Setup the gfc_se structures. */
2150 gfc_copy_loopinfo_to_se (&lse, &loop);
2151 gfc_copy_loopinfo_to_se (&rse, &loop);
2154 gfc_mark_ss_chain_used (rss, 1);
2156 gfc_mark_ss_chain_used (lss, 1);
2158 /* Start the scalarized loop body. */
2159 gfc_start_scalarized_body (&loop, &body);
2161 gfc_conv_tmp_array_ref (&lse);
2162 if (cm->ts.type == BT_CHARACTER)
2163 lse.string_length = cm->ts.cl->backend_decl;
2165 gfc_conv_expr (&rse, expr);
2167 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2168 gfc_add_expr_to_block (&body, tmp);
2170 gcc_assert (rse.ss == gfc_ss_terminator);
2172 /* Generate the copying loops. */
2173 gfc_trans_scalarizing_loops (&loop, &body);
2175 /* Wrap the whole thing up. */
2176 gfc_add_block_to_block (&block, &loop.pre);
2177 gfc_add_block_to_block (&block, &loop.post);
2179 for (n = 0; n < cm->as->rank; n++)
2180 mpz_clear (lss->shape[n]);
2181 gfc_free (lss->shape);
2183 gfc_cleanup_loop (&loop);
2185 return gfc_finish_block (&block);
2188 /* Assign a single component of a derived type constructor. */
2191 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2198 gfc_start_block (&block);
2201 gfc_init_se (&se, NULL);
2202 /* Pointer component. */
2205 /* Array pointer. */
2206 if (expr->expr_type == EXPR_NULL)
2207 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2210 rss = gfc_walk_expr (expr);
2211 se.direct_byref = 1;
2213 gfc_conv_expr_descriptor (&se, expr, rss);
2214 gfc_add_block_to_block (&block, &se.pre);
2215 gfc_add_block_to_block (&block, &se.post);
2220 /* Scalar pointers. */
2221 se.want_pointer = 1;
2222 gfc_conv_expr (&se, expr);
2223 gfc_add_block_to_block (&block, &se.pre);
2224 gfc_add_modify_expr (&block, dest,
2225 fold_convert (TREE_TYPE (dest), se.expr));
2226 gfc_add_block_to_block (&block, &se.post);
2229 else if (cm->dimension)
2231 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2232 gfc_add_expr_to_block (&block, tmp);
2234 else if (expr->ts.type == BT_DERIVED)
2236 /* Nested derived type. */
2237 tmp = gfc_trans_structure_assign (dest, expr);
2238 gfc_add_expr_to_block (&block, tmp);
2242 /* Scalar component. */
2245 gfc_init_se (&se, NULL);
2246 gfc_init_se (&lse, NULL);
2248 gfc_conv_expr (&se, expr);
2249 if (cm->ts.type == BT_CHARACTER)
2250 lse.string_length = cm->ts.cl->backend_decl;
2252 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2253 gfc_add_expr_to_block (&block, tmp);
2255 return gfc_finish_block (&block);
2258 /* Assign a derived type constructor to a variable. */
2261 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2269 gfc_start_block (&block);
2270 cm = expr->ts.derived->components;
2271 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2273 /* Skip absent members in default initializers. */
2277 field = cm->backend_decl;
2278 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2279 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2280 gfc_add_expr_to_block (&block, tmp);
2282 return gfc_finish_block (&block);
2285 /* Build an expression for a constructor. If init is nonzero then
2286 this is part of a static variable initializer. */
2289 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2296 VEC(constructor_elt,gc) *v = NULL;
2298 gcc_assert (se->ss == NULL);
2299 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2300 type = gfc_typenode_for_spec (&expr->ts);
2304 /* Create a temporary variable and fill it in. */
2305 se->expr = gfc_create_var (type, expr->ts.derived->name);
2306 tmp = gfc_trans_structure_assign (se->expr, expr);
2307 gfc_add_expr_to_block (&se->pre, tmp);
2311 cm = expr->ts.derived->components;
2312 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2314 /* Skip absent members in default initializers. */
2318 val = gfc_conv_initializer (c->expr, &cm->ts,
2319 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2321 /* Append it to the constructor list. */
2322 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2324 se->expr = build_constructor (type, v);
2328 /* Translate a substring expression. */
2331 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2337 gcc_assert (ref->type == REF_SUBSTRING);
2339 se->expr = gfc_build_string_const(expr->value.character.length,
2340 expr->value.character.string);
2341 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2342 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2344 gfc_conv_substring(se,ref,expr->ts.kind);
2348 /* Entry point for expression translation. Evaluates a scalar quantity.
2349 EXPR is the expression to be translated, and SE is the state structure if
2350 called from within the scalarized. */
2353 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2355 if (se->ss && se->ss->expr == expr
2356 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2358 /* Substitute a scalar expression evaluated outside the scalarization
2360 se->expr = se->ss->data.scalar.expr;
2361 se->string_length = se->ss->string_length;
2362 gfc_advance_se_ss_chain (se);
2366 switch (expr->expr_type)
2369 gfc_conv_expr_op (se, expr);
2373 gfc_conv_function_expr (se, expr);
2377 gfc_conv_constant (se, expr);
2381 gfc_conv_variable (se, expr);
2385 se->expr = null_pointer_node;
2388 case EXPR_SUBSTRING:
2389 gfc_conv_substring_expr (se, expr);
2392 case EXPR_STRUCTURE:
2393 gfc_conv_structure (se, expr, 0);
2397 gfc_conv_array_constructor_expr (se, expr);
2406 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2407 of an assignment. */
2409 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2411 gfc_conv_expr (se, expr);
2412 /* All numeric lvalues should have empty post chains. If not we need to
2413 figure out a way of rewriting an lvalue so that it has no post chain. */
2414 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2417 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2418 numeric expressions. Used for scalar values whee inserting cleanup code
2421 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2425 gcc_assert (expr->ts.type != BT_CHARACTER);
2426 gfc_conv_expr (se, expr);
2429 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2430 gfc_add_modify_expr (&se->pre, val, se->expr);
2432 gfc_add_block_to_block (&se->pre, &se->post);
2436 /* Helper to translate and expression and convert it to a particular type. */
2438 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2440 gfc_conv_expr_val (se, expr);
2441 se->expr = convert (type, se->expr);
2445 /* Converts an expression so that it can be passed by reference. Scalar
2449 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2453 if (se->ss && se->ss->expr == expr
2454 && se->ss->type == GFC_SS_REFERENCE)
2456 se->expr = se->ss->data.scalar.expr;
2457 se->string_length = se->ss->string_length;
2458 gfc_advance_se_ss_chain (se);
2462 if (expr->ts.type == BT_CHARACTER)
2464 gfc_conv_expr (se, expr);
2465 gfc_conv_string_parameter (se);
2469 if (expr->expr_type == EXPR_VARIABLE)
2471 se->want_pointer = 1;
2472 gfc_conv_expr (se, expr);
2475 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2476 gfc_add_modify_expr (&se->pre, var, se->expr);
2477 gfc_add_block_to_block (&se->pre, &se->post);
2483 gfc_conv_expr (se, expr);
2485 /* Create a temporary var to hold the value. */
2486 if (TREE_CONSTANT (se->expr))
2488 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2489 DECL_INITIAL (var) = se->expr;
2494 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2495 gfc_add_modify_expr (&se->pre, var, se->expr);
2497 gfc_add_block_to_block (&se->pre, &se->post);
2499 /* Take the address of that value. */
2500 se->expr = build_fold_addr_expr (var);
2505 gfc_trans_pointer_assign (gfc_code * code)
2507 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2511 /* Generate code for a pointer assignment. */
2514 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2524 gfc_start_block (&block);
2526 gfc_init_se (&lse, NULL);
2528 lss = gfc_walk_expr (expr1);
2529 rss = gfc_walk_expr (expr2);
2530 if (lss == gfc_ss_terminator)
2532 /* Scalar pointers. */
2533 lse.want_pointer = 1;
2534 gfc_conv_expr (&lse, expr1);
2535 gcc_assert (rss == gfc_ss_terminator);
2536 gfc_init_se (&rse, NULL);
2537 rse.want_pointer = 1;
2538 gfc_conv_expr (&rse, expr2);
2539 gfc_add_block_to_block (&block, &lse.pre);
2540 gfc_add_block_to_block (&block, &rse.pre);
2541 gfc_add_modify_expr (&block, lse.expr,
2542 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2543 gfc_add_block_to_block (&block, &rse.post);
2544 gfc_add_block_to_block (&block, &lse.post);
2548 /* Array pointer. */
2549 gfc_conv_expr_descriptor (&lse, expr1, lss);
2550 switch (expr2->expr_type)
2553 /* Just set the data pointer to null. */
2554 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2558 /* Assign directly to the pointer's descriptor. */
2559 lse.direct_byref = 1;
2560 gfc_conv_expr_descriptor (&lse, expr2, rss);
2564 /* Assign to a temporary descriptor and then copy that
2565 temporary to the pointer. */
2567 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2570 lse.direct_byref = 1;
2571 gfc_conv_expr_descriptor (&lse, expr2, rss);
2572 gfc_add_modify_expr (&lse.pre, desc, tmp);
2575 gfc_add_block_to_block (&block, &lse.pre);
2576 gfc_add_block_to_block (&block, &lse.post);
2578 return gfc_finish_block (&block);
2582 /* Makes sure se is suitable for passing as a function string parameter. */
2583 /* TODO: Need to check all callers fo this function. It may be abused. */
2586 gfc_conv_string_parameter (gfc_se * se)
2590 if (TREE_CODE (se->expr) == STRING_CST)
2592 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2596 type = TREE_TYPE (se->expr);
2597 if (TYPE_STRING_FLAG (type))
2599 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2600 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2603 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2604 gcc_assert (se->string_length
2605 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2609 /* Generate code for assignment of scalar variables. Includes character
2613 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2617 gfc_init_block (&block);
2619 if (type == BT_CHARACTER)
2621 gcc_assert (lse->string_length != NULL_TREE
2622 && rse->string_length != NULL_TREE);
2624 gfc_conv_string_parameter (lse);
2625 gfc_conv_string_parameter (rse);
2627 gfc_add_block_to_block (&block, &lse->pre);
2628 gfc_add_block_to_block (&block, &rse->pre);
2630 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2631 rse->string_length, rse->expr);
2635 gfc_add_block_to_block (&block, &lse->pre);
2636 gfc_add_block_to_block (&block, &rse->pre);
2638 gfc_add_modify_expr (&block, lse->expr,
2639 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2642 gfc_add_block_to_block (&block, &lse->post);
2643 gfc_add_block_to_block (&block, &rse->post);
2645 return gfc_finish_block (&block);
2649 /* Try to translate array(:) = func (...), where func is a transformational
2650 array function, without using a temporary. Returns NULL is this isn't the
2654 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2659 bool seen_array_ref;
2661 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2662 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2665 /* Elemental functions don't need a temporary anyway. */
2666 if (expr2->value.function.esym != NULL
2667 && expr2->value.function.esym->attr.elemental)
2670 /* Fail if EXPR1 can't be expressed as a descriptor. */
2671 if (gfc_ref_needs_temporary_p (expr1->ref))
2674 /* Check that no LHS component references appear during an array
2675 reference. This is needed because we do not have the means to
2676 span any arbitrary stride with an array descriptor. This check
2677 is not needed for the rhs because the function result has to be
2679 seen_array_ref = false;
2680 for (ref = expr1->ref; ref; ref = ref->next)
2682 if (ref->type == REF_ARRAY)
2683 seen_array_ref= true;
2684 else if (ref->type == REF_COMPONENT && seen_array_ref)
2688 /* Check for a dependency. */
2689 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
2690 expr2->value.function.esym,
2691 expr2->value.function.actual))
2694 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2696 gcc_assert (expr2->value.function.isym
2697 || (gfc_return_by_reference (expr2->value.function.esym)
2698 && expr2->value.function.esym->result->attr.dimension));
2700 ss = gfc_walk_expr (expr1);
2701 gcc_assert (ss != gfc_ss_terminator);
2702 gfc_init_se (&se, NULL);
2703 gfc_start_block (&se.pre);
2704 se.want_pointer = 1;
2706 gfc_conv_array_parameter (&se, expr1, ss, 0);
2708 se.direct_byref = 1;
2709 se.ss = gfc_walk_expr (expr2);
2710 gcc_assert (se.ss != gfc_ss_terminator);
2711 gfc_conv_function_expr (&se, expr2);
2712 gfc_add_block_to_block (&se.pre, &se.post);
2714 return gfc_finish_block (&se.pre);
2718 /* Translate an assignment. Most of the code is concerned with
2719 setting up the scalarizer. */
2722 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2727 gfc_ss *lss_section;
2734 /* Special case a single function returning an array. */
2735 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2737 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2742 /* Assignment of the form lhs = rhs. */
2743 gfc_start_block (&block);
2745 gfc_init_se (&lse, NULL);
2746 gfc_init_se (&rse, NULL);
2749 lss = gfc_walk_expr (expr1);
2751 if (lss != gfc_ss_terminator)
2753 /* The assignment needs scalarization. */
2756 /* Find a non-scalar SS from the lhs. */
2757 while (lss_section != gfc_ss_terminator
2758 && lss_section->type != GFC_SS_SECTION)
2759 lss_section = lss_section->next;
2761 gcc_assert (lss_section != gfc_ss_terminator);
2763 /* Initialize the scalarizer. */
2764 gfc_init_loopinfo (&loop);
2767 rss = gfc_walk_expr (expr2);
2768 if (rss == gfc_ss_terminator)
2770 /* The rhs is scalar. Add a ss for the expression. */
2771 rss = gfc_get_ss ();
2772 rss->next = gfc_ss_terminator;
2773 rss->type = GFC_SS_SCALAR;
2776 /* Associate the SS with the loop. */
2777 gfc_add_ss_to_loop (&loop, lss);
2778 gfc_add_ss_to_loop (&loop, rss);
2780 /* Calculate the bounds of the scalarization. */
2781 gfc_conv_ss_startstride (&loop);
2782 /* Resolve any data dependencies in the statement. */
2783 gfc_conv_resolve_dependencies (&loop, lss, rss);
2784 /* Setup the scalarizing loops. */
2785 gfc_conv_loop_setup (&loop);
2787 /* Setup the gfc_se structures. */
2788 gfc_copy_loopinfo_to_se (&lse, &loop);
2789 gfc_copy_loopinfo_to_se (&rse, &loop);
2792 gfc_mark_ss_chain_used (rss, 1);
2793 if (loop.temp_ss == NULL)
2796 gfc_mark_ss_chain_used (lss, 1);
2800 lse.ss = loop.temp_ss;
2801 gfc_mark_ss_chain_used (lss, 3);
2802 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2805 /* Start the scalarized loop body. */
2806 gfc_start_scalarized_body (&loop, &body);
2809 gfc_init_block (&body);
2811 /* Translate the expression. */
2812 gfc_conv_expr (&rse, expr2);
2814 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2816 gfc_conv_tmp_array_ref (&lse);
2817 gfc_advance_se_ss_chain (&lse);
2820 gfc_conv_expr (&lse, expr1);
2822 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2823 gfc_add_expr_to_block (&body, tmp);
2825 if (lss == gfc_ss_terminator)
2827 /* Use the scalar assignment as is. */
2828 gfc_add_block_to_block (&block, &body);
2832 gcc_assert (lse.ss == gfc_ss_terminator
2833 && rse.ss == gfc_ss_terminator);
2835 if (loop.temp_ss != NULL)
2837 gfc_trans_scalarized_loop_boundary (&loop, &body);
2839 /* We need to copy the temporary to the actual lhs. */
2840 gfc_init_se (&lse, NULL);
2841 gfc_init_se (&rse, NULL);
2842 gfc_copy_loopinfo_to_se (&lse, &loop);
2843 gfc_copy_loopinfo_to_se (&rse, &loop);
2845 rse.ss = loop.temp_ss;
2848 gfc_conv_tmp_array_ref (&rse);
2849 gfc_advance_se_ss_chain (&rse);
2850 gfc_conv_expr (&lse, expr1);
2852 gcc_assert (lse.ss == gfc_ss_terminator
2853 && rse.ss == gfc_ss_terminator);
2855 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2856 gfc_add_expr_to_block (&body, tmp);
2858 /* Generate the copying loops. */
2859 gfc_trans_scalarizing_loops (&loop, &body);
2861 /* Wrap the whole thing up. */
2862 gfc_add_block_to_block (&block, &loop.pre);
2863 gfc_add_block_to_block (&block, &loop.post);
2865 gfc_cleanup_loop (&loop);
2868 return gfc_finish_block (&block);
2872 gfc_trans_assign (gfc_code * code)
2874 return gfc_trans_assignment (code->expr, code->expr2);