1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005 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 = gfc_build_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);
250 build2 (MINUS_EXPR, gfc_charlen_type_node,
251 fold_convert (gfc_charlen_type_node, integer_one_node),
253 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
254 se->string_length = fold (tmp);
258 /* Convert a derived type component reference. */
261 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
268 c = ref->u.c.component;
270 gcc_assert (c->backend_decl);
272 field = c->backend_decl;
273 gcc_assert (TREE_CODE (field) == FIELD_DECL);
275 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
279 if (c->ts.type == BT_CHARACTER)
281 tmp = c->ts.cl->backend_decl;
282 /* Components must always be constant length. */
283 gcc_assert (tmp && INTEGER_CST_P (tmp));
284 se->string_length = tmp;
287 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
288 se->expr = gfc_build_indirect_ref (se->expr);
292 /* Return the contents of a variable. Also handles reference/pointer
293 variables (all Fortran pointer references are implicit). */
296 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
301 sym = expr->symtree->n.sym;
304 /* Check that something hasn't gone horribly wrong. */
305 gcc_assert (se->ss != gfc_ss_terminator);
306 gcc_assert (se->ss->expr == expr);
308 /* A scalarized term. We already know the descriptor. */
309 se->expr = se->ss->data.info.descriptor;
310 se->string_length = se->ss->string_length;
311 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
312 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
317 tree se_expr = NULL_TREE;
319 se->expr = gfc_get_symbol_decl (sym);
321 /* Special case for assigning the return value of a function.
322 Self recursive functions must have an explicit return value. */
323 if (se->expr == current_function_decl && sym->attr.function
324 && (sym->result == sym))
325 se_expr = gfc_get_fake_result_decl (sym);
327 /* Similarly for alternate entry points. */
328 else if (sym->attr.function && sym->attr.entry
329 && (sym->result == sym)
330 && sym->ns->proc_name->backend_decl == current_function_decl)
332 gfc_entry_list *el = NULL;
334 for (el = sym->ns->entries; el; el = el->next)
337 se_expr = gfc_get_fake_result_decl (sym);
342 else if (sym->attr.result
343 && sym->ns->proc_name->backend_decl == current_function_decl
344 && sym->ns->proc_name->attr.entry_master
345 && !gfc_return_by_reference (sym->ns->proc_name))
346 se_expr = gfc_get_fake_result_decl (sym);
351 /* Procedure actual arguments. */
352 else if (sym->attr.flavor == FL_PROCEDURE
353 && se->expr != current_function_decl)
355 gcc_assert (se->want_pointer);
356 if (!sym->attr.dummy)
358 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
359 se->expr = gfc_build_addr_expr (NULL, se->expr);
365 /* Dereference the expression, where needed. Since characters
366 are entirely different from other types, they are treated
368 if (sym->ts.type == BT_CHARACTER)
370 /* Dereference character pointer dummy arguments
372 if ((sym->attr.pointer || sym->attr.allocatable)
374 || sym->attr.function
375 || sym->attr.result))
376 se->expr = gfc_build_indirect_ref (se->expr);
380 /* Dereference non-character scalar dummy arguments. */
381 if (sym->attr.dummy && !sym->attr.dimension)
382 se->expr = gfc_build_indirect_ref (se->expr);
384 /* Dereference scalar hidden result. */
385 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
386 && (sym->attr.function || sym->attr.result)
387 && !sym->attr.dimension && !sym->attr.pointer)
388 se->expr = gfc_build_indirect_ref (se->expr);
390 /* Dereference non-character pointer variables.
391 These must be dummies, results, or scalars. */
392 if ((sym->attr.pointer || sym->attr.allocatable)
394 || sym->attr.function
396 || !sym->attr.dimension))
397 se->expr = gfc_build_indirect_ref (se->expr);
403 /* For character variables, also get the length. */
404 if (sym->ts.type == BT_CHARACTER)
406 /* If the character length of an entry isn't set, get the length from
407 the master function instead. */
408 if (sym->attr.entry && !sym->ts.cl->backend_decl)
409 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
411 se->string_length = sym->ts.cl->backend_decl;
412 gcc_assert (se->string_length);
420 /* Return the descriptor if that's what we want and this is an array
421 section reference. */
422 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
424 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
425 /* Return the descriptor for array pointers and allocations. */
427 && ref->next == NULL && (se->descriptor_only))
430 gfc_conv_array_ref (se, &ref->u.ar);
431 /* Return a pointer to an element. */
435 gfc_conv_component_ref (se, ref);
439 gfc_conv_substring (se, ref, expr->ts.kind);
448 /* Pointer assignment, allocation or pass by reference. Arrays are handled
450 if (se->want_pointer)
452 if (expr->ts.type == BT_CHARACTER)
453 gfc_conv_string_parameter (se);
455 se->expr = gfc_build_addr_expr (NULL, se->expr);
460 /* Unary ops are easy... Or they would be if ! was a valid op. */
463 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
468 gcc_assert (expr->ts.type != BT_CHARACTER);
469 /* Initialize the operand. */
470 gfc_init_se (&operand, se);
471 gfc_conv_expr_val (&operand, expr->value.op.op1);
472 gfc_add_block_to_block (&se->pre, &operand.pre);
474 type = gfc_typenode_for_spec (&expr->ts);
476 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
477 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
478 All other unary operators have an equivalent GIMPLE unary operator. */
479 if (code == TRUTH_NOT_EXPR)
480 se->expr = build2 (EQ_EXPR, type, operand.expr,
481 convert (type, integer_zero_node));
483 se->expr = build1 (code, type, operand.expr);
487 /* Expand power operator to optimal multiplications when a value is raised
488 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
489 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
490 Programming", 3rd Edition, 1998. */
492 /* This code is mostly duplicated from expand_powi in the backend.
493 We establish the "optimal power tree" lookup table with the defined size.
494 The items in the table are the exponents used to calculate the index
495 exponents. Any integer n less than the value can get an "addition chain",
496 with the first node being one. */
497 #define POWI_TABLE_SIZE 256
499 /* The table is from builtins.c. */
500 static const unsigned char powi_table[POWI_TABLE_SIZE] =
502 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
503 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
504 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
505 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
506 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
507 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
508 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
509 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
510 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
511 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
512 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
513 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
514 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
515 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
516 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
517 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
518 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
519 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
520 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
521 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
522 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
523 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
524 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
525 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
526 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
527 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
528 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
529 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
530 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
531 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
532 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
533 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
536 /* If n is larger than lookup table's max index, we use the "window
538 #define POWI_WINDOW_SIZE 3
540 /* Recursive function to expand the power operator. The temporary
541 values are put in tmpvar. The function returns tmpvar[1] ** n. */
543 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
550 if (n < POWI_TABLE_SIZE)
555 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
556 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
560 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
561 op0 = gfc_conv_powi (se, n - digit, tmpvar);
562 op1 = gfc_conv_powi (se, digit, tmpvar);
566 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
570 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
571 tmp = gfc_evaluate_now (tmp, &se->pre);
573 if (n < POWI_TABLE_SIZE)
580 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
581 return 1. Else return 0 and a call to runtime library functions
582 will have to be built. */
584 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
589 tree vartmp[POWI_TABLE_SIZE];
593 type = TREE_TYPE (lhs);
594 n = abs (TREE_INT_CST_LOW (rhs));
595 sgn = tree_int_cst_sgn (rhs);
597 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
598 && (n > 2 || n < -1))
604 se->expr = gfc_build_const (type, integer_one_node);
607 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
608 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
610 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
611 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
612 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
613 convert (TREE_TYPE (lhs), integer_one_node));
616 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
619 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
620 se->expr = build3 (COND_EXPR, type, tmp,
621 convert (type, integer_one_node),
622 convert (type, integer_zero_node));
626 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
627 tmp = build3 (COND_EXPR, type, tmp,
628 convert (type, integer_minus_one_node),
629 convert (type, integer_zero_node));
630 se->expr = build3 (COND_EXPR, type, cond,
631 convert (type, integer_one_node),
636 memset (vartmp, 0, sizeof (vartmp));
640 tmp = gfc_build_const (type, integer_one_node);
641 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
644 se->expr = gfc_conv_powi (se, n, vartmp);
650 /* Power op (**). Constant integer exponent has special handling. */
653 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
655 tree gfc_int4_type_node;
663 gfc_init_se (&lse, se);
664 gfc_conv_expr_val (&lse, expr->value.op.op1);
665 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
666 gfc_add_block_to_block (&se->pre, &lse.pre);
668 gfc_init_se (&rse, se);
669 gfc_conv_expr_val (&rse, expr->value.op.op2);
670 gfc_add_block_to_block (&se->pre, &rse.pre);
672 if (expr->value.op.op2->ts.type == BT_INTEGER
673 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
674 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
677 gfc_int4_type_node = gfc_get_int_type (4);
679 kind = expr->value.op.op1->ts.kind;
680 switch (expr->value.op.op2->ts.type)
683 ikind = expr->value.op.op2->ts.kind;
688 rse.expr = convert (gfc_int4_type_node, rse.expr);
710 if (expr->value.op.op1->ts.type == BT_INTEGER)
711 lse.expr = convert (gfc_int4_type_node, lse.expr);
736 switch (expr->value.op.op1->ts.type)
739 if (kind == 3) /* Case 16 was not handled properly above. */
741 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
745 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
749 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
761 fndecl = built_in_decls[BUILT_IN_POWF];
764 fndecl = built_in_decls[BUILT_IN_POW];
768 fndecl = built_in_decls[BUILT_IN_POWL];
779 fndecl = gfor_fndecl_math_cpowf;
782 fndecl = gfor_fndecl_math_cpow;
785 fndecl = gfor_fndecl_math_cpowl10;
788 fndecl = gfor_fndecl_math_cpowl16;
800 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
801 tmp = gfc_chainon_list (tmp, rse.expr);
802 se->expr = fold (gfc_build_function_call (fndecl, tmp));
806 /* Generate code to allocate a string temporary. */
809 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
815 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
817 if (gfc_can_put_var_on_stack (len))
819 /* Create a temporary variable to hold the result. */
820 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
821 convert (gfc_charlen_type_node, integer_one_node));
822 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
823 tmp = build_array_type (gfc_character1_type_node, tmp);
824 var = gfc_create_var (tmp, "str");
825 var = gfc_build_addr_expr (type, var);
829 /* Allocate a temporary to hold the result. */
830 var = gfc_create_var (type, "pstr");
831 args = gfc_chainon_list (NULL_TREE, len);
832 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
833 tmp = convert (type, tmp);
834 gfc_add_modify_expr (&se->pre, var, tmp);
836 /* Free the temporary afterwards. */
837 tmp = convert (pvoid_type_node, var);
838 args = gfc_chainon_list (NULL_TREE, tmp);
839 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
840 gfc_add_expr_to_block (&se->post, tmp);
847 /* Handle a string concatenation operation. A temporary will be allocated to
851 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
861 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
862 && expr->value.op.op2->ts.type == BT_CHARACTER);
864 gfc_init_se (&lse, se);
865 gfc_conv_expr (&lse, expr->value.op.op1);
866 gfc_conv_string_parameter (&lse);
867 gfc_init_se (&rse, se);
868 gfc_conv_expr (&rse, expr->value.op.op2);
869 gfc_conv_string_parameter (&rse);
871 gfc_add_block_to_block (&se->pre, &lse.pre);
872 gfc_add_block_to_block (&se->pre, &rse.pre);
874 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
875 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
876 if (len == NULL_TREE)
878 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
879 lse.string_length, rse.string_length);
882 type = build_pointer_type (type);
884 var = gfc_conv_string_tmp (se, type, len);
886 /* Do the actual concatenation. */
888 args = gfc_chainon_list (args, len);
889 args = gfc_chainon_list (args, var);
890 args = gfc_chainon_list (args, lse.string_length);
891 args = gfc_chainon_list (args, lse.expr);
892 args = gfc_chainon_list (args, rse.string_length);
893 args = gfc_chainon_list (args, rse.expr);
894 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
895 gfc_add_expr_to_block (&se->pre, tmp);
897 /* Add the cleanup for the operands. */
898 gfc_add_block_to_block (&se->pre, &rse.post);
899 gfc_add_block_to_block (&se->pre, &lse.post);
902 se->string_length = len;
906 /* Translates an op expression. Common (binary) cases are handled by this
907 function, others are passed on. Recursion is used in either case.
908 We use the fact that (op1.ts == op2.ts) (except for the power
910 Operators need no special handling for scalarized expressions as long as
911 they call gfc_conv_simple_val to get their operands.
912 Character strings get special handling. */
915 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
927 switch (expr->value.op.operator)
929 case INTRINSIC_UPLUS:
930 gfc_conv_expr (se, expr->value.op.op1);
933 case INTRINSIC_UMINUS:
934 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
938 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
945 case INTRINSIC_MINUS:
949 case INTRINSIC_TIMES:
953 case INTRINSIC_DIVIDE:
954 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
955 an integer, we must round towards zero, so we use a
957 if (expr->ts.type == BT_INTEGER)
958 code = TRUNC_DIV_EXPR;
963 case INTRINSIC_POWER:
964 gfc_conv_power_op (se, expr);
967 case INTRINSIC_CONCAT:
968 gfc_conv_concat_op (se, expr);
972 code = TRUTH_ANDIF_EXPR;
977 code = TRUTH_ORIF_EXPR;
981 /* EQV and NEQV only work on logicals, but since we represent them
982 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1021 case INTRINSIC_USER:
1022 case INTRINSIC_ASSIGN:
1023 /* These should be converted into function calls by the frontend. */
1027 fatal_error ("Unknown intrinsic op");
1031 /* The only exception to this is **, which is handled separately anyway. */
1032 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1034 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1038 gfc_init_se (&lse, se);
1039 gfc_conv_expr (&lse, expr->value.op.op1);
1040 gfc_add_block_to_block (&se->pre, &lse.pre);
1043 gfc_init_se (&rse, se);
1044 gfc_conv_expr (&rse, expr->value.op.op2);
1045 gfc_add_block_to_block (&se->pre, &rse.pre);
1047 /* For string comparisons we generate a library call, and compare the return
1051 gfc_conv_string_parameter (&lse);
1052 gfc_conv_string_parameter (&rse);
1054 tmp = gfc_chainon_list (tmp, lse.string_length);
1055 tmp = gfc_chainon_list (tmp, lse.expr);
1056 tmp = gfc_chainon_list (tmp, rse.string_length);
1057 tmp = gfc_chainon_list (tmp, rse.expr);
1059 /* Build a call for the comparison. */
1060 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1061 gfc_add_block_to_block (&lse.post, &rse.post);
1063 rse.expr = integer_zero_node;
1066 type = gfc_typenode_for_spec (&expr->ts);
1070 /* The result of logical ops is always boolean_type_node. */
1071 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1072 se->expr = convert (type, tmp);
1075 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1077 /* Add the post blocks. */
1078 gfc_add_block_to_block (&se->post, &rse.post);
1079 gfc_add_block_to_block (&se->post, &lse.post);
1084 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1088 if (sym->attr.dummy)
1090 tmp = gfc_get_symbol_decl (sym);
1091 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1092 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1096 if (!sym->backend_decl)
1097 sym->backend_decl = gfc_get_extern_function_decl (sym);
1099 tmp = sym->backend_decl;
1100 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1102 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1103 tmp = gfc_build_addr_expr (NULL, tmp);
1110 /* Initialize MAPPING. */
1113 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1115 mapping->syms = NULL;
1116 mapping->charlens = NULL;
1120 /* Free all memory held by MAPPING (but not MAPPING itself). */
1123 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1125 gfc_interface_sym_mapping *sym;
1126 gfc_interface_sym_mapping *nextsym;
1128 gfc_charlen *nextcl;
1130 for (sym = mapping->syms; sym; sym = nextsym)
1132 nextsym = sym->next;
1133 gfc_free_symbol (sym->new->n.sym);
1134 gfc_free (sym->new);
1137 for (cl = mapping->charlens; cl; cl = nextcl)
1140 gfc_free_expr (cl->length);
1146 /* Return a copy of gfc_charlen CL. Add the returned structure to
1147 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1149 static gfc_charlen *
1150 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1155 new = gfc_get_charlen ();
1156 new->next = mapping->charlens;
1157 new->length = gfc_copy_expr (cl->length);
1159 mapping->charlens = new;
1164 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1165 array variable that can be used as the actual argument for dummy
1166 argument SYM. Add any initialization code to BLOCK. PACKED is as
1167 for gfc_get_nodesc_array_type and DATA points to the first element
1168 in the passed array. */
1171 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1172 int packed, tree data)
1177 type = gfc_typenode_for_spec (&sym->ts);
1178 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1180 var = gfc_create_var (type, "parm");
1181 gfc_add_modify_expr (block, var, fold_convert (type, data));
1187 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1188 and offset of descriptorless array type TYPE given that it has the same
1189 size as DESC. Add any set-up code to BLOCK. */
1192 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1199 offset = gfc_index_zero_node;
1200 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1202 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1203 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1205 dim = gfc_rank_cst[n];
1206 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1207 gfc_conv_descriptor_ubound (desc, dim),
1208 gfc_conv_descriptor_lbound (desc, dim));
1209 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1210 GFC_TYPE_ARRAY_LBOUND (type, n),
1212 tmp = gfc_evaluate_now (tmp, block);
1213 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1215 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1216 GFC_TYPE_ARRAY_LBOUND (type, n),
1217 GFC_TYPE_ARRAY_STRIDE (type, n));
1218 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1220 offset = gfc_evaluate_now (offset, block);
1221 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1225 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1226 in SE. The caller may still use se->expr and se->string_length after
1227 calling this function. */
1230 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1231 gfc_symbol * sym, gfc_se * se)
1233 gfc_interface_sym_mapping *sm;
1237 gfc_symbol *new_sym;
1239 gfc_symtree *new_symtree;
1241 /* Create a new symbol to represent the actual argument. */
1242 new_sym = gfc_new_symbol (sym->name, NULL);
1243 new_sym->ts = sym->ts;
1244 new_sym->attr.referenced = 1;
1245 new_sym->attr.dimension = sym->attr.dimension;
1246 new_sym->attr.pointer = sym->attr.pointer;
1247 new_sym->attr.flavor = sym->attr.flavor;
1249 /* Create a fake symtree for it. */
1251 new_symtree = gfc_new_symtree (&root, sym->name);
1252 new_symtree->n.sym = new_sym;
1253 gcc_assert (new_symtree == root);
1255 /* Create a dummy->actual mapping. */
1256 sm = gfc_getmem (sizeof (*sm));
1257 sm->next = mapping->syms;
1259 sm->new = new_symtree;
1262 /* Stabilize the argument's value. */
1263 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1265 if (sym->ts.type == BT_CHARACTER)
1267 /* Create a copy of the dummy argument's length. */
1268 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1270 /* If the length is specified as "*", record the length that
1271 the caller is passing. We should use the callee's length
1272 in all other cases. */
1273 if (!new_sym->ts.cl->length)
1275 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1276 new_sym->ts.cl->backend_decl = se->string_length;
1280 /* Use the passed value as-is if the argument is a function. */
1281 if (sym->attr.flavor == FL_PROCEDURE)
1284 /* If the argument is either a string or a pointer to a string,
1285 convert it to a boundless character type. */
1286 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1288 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1289 tmp = build_pointer_type (tmp);
1290 if (sym->attr.pointer)
1291 tmp = build_pointer_type (tmp);
1293 value = fold_convert (tmp, se->expr);
1294 if (sym->attr.pointer)
1295 value = gfc_build_indirect_ref (value);
1298 /* If the argument is a scalar or a pointer to an array, dereference it. */
1299 else if (!sym->attr.dimension || sym->attr.pointer)
1300 value = gfc_build_indirect_ref (se->expr);
1302 /* If the argument is an array descriptor, use it to determine
1303 information about the actual argument's shape. */
1304 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1305 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1307 /* Get the actual argument's descriptor. */
1308 desc = gfc_build_indirect_ref (se->expr);
1310 /* Create the replacement variable. */
1311 tmp = gfc_conv_descriptor_data_get (desc);
1312 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1314 /* Use DESC to work out the upper bounds, strides and offset. */
1315 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1318 /* Otherwise we have a packed array. */
1319 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1321 new_sym->backend_decl = value;
1325 /* Called once all dummy argument mappings have been added to MAPPING,
1326 but before the mapping is used to evaluate expressions. Pre-evaluate
1327 the length of each argument, adding any initialization code to PRE and
1328 any finalization code to POST. */
1331 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1332 stmtblock_t * pre, stmtblock_t * post)
1334 gfc_interface_sym_mapping *sym;
1338 for (sym = mapping->syms; sym; sym = sym->next)
1339 if (sym->new->n.sym->ts.type == BT_CHARACTER
1340 && !sym->new->n.sym->ts.cl->backend_decl)
1342 expr = sym->new->n.sym->ts.cl->length;
1343 gfc_apply_interface_mapping_to_expr (mapping, expr);
1344 gfc_init_se (&se, NULL);
1345 gfc_conv_expr (&se, expr);
1347 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1348 gfc_add_block_to_block (pre, &se.pre);
1349 gfc_add_block_to_block (post, &se.post);
1351 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1356 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1360 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1361 gfc_constructor * c)
1363 for (; c; c = c->next)
1365 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1368 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1369 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1370 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1376 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1380 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1385 for (; ref; ref = ref->next)
1389 for (n = 0; n < ref->u.ar.dimen; n++)
1391 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1392 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1393 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1395 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1402 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1403 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1409 /* EXPR is a copy of an expression that appeared in the interface
1410 associated with MAPPING. Walk it recursively looking for references to
1411 dummy arguments that MAPPING maps to actual arguments. Replace each such
1412 reference with a reference to the associated actual argument. */
1415 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1418 gfc_interface_sym_mapping *sym;
1419 gfc_actual_arglist *actual;
1424 /* Copying an expression does not copy its length, so do that here. */
1425 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1427 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1428 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1431 /* Apply the mapping to any references. */
1432 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1434 /* ...and to the expression's symbol, if it has one. */
1436 for (sym = mapping->syms; sym; sym = sym->next)
1437 if (sym->old == expr->symtree->n.sym)
1438 expr->symtree = sym->new;
1440 /* ...and to subexpressions in expr->value. */
1441 switch (expr->expr_type)
1446 case EXPR_SUBSTRING:
1450 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1451 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1455 for (sym = mapping->syms; sym; sym = sym->next)
1456 if (sym->old == expr->value.function.esym)
1457 expr->value.function.esym = sym->new->n.sym;
1459 for (actual = expr->value.function.actual; actual; actual = actual->next)
1460 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1464 case EXPR_STRUCTURE:
1465 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1471 /* Evaluate interface expression EXPR using MAPPING. Store the result
1475 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1476 gfc_se * se, gfc_expr * expr)
1478 expr = gfc_copy_expr (expr);
1479 gfc_apply_interface_mapping_to_expr (mapping, expr);
1480 gfc_conv_expr (se, expr);
1481 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1482 gfc_free_expr (expr);
1486 /* Generate code for a procedure call. Note can return se->post != NULL.
1487 If se->direct_byref is set then se->expr contains the return parameter.
1488 Return nonzero, if the call has alternate specifiers. */
1491 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1492 gfc_actual_arglist * arg)
1494 gfc_interface_mapping mapping;
1507 gfc_formal_arglist *formal;
1508 int has_alternate_specifier = 0;
1509 bool need_interface_mapping;
1513 arglist = NULL_TREE;
1514 retargs = NULL_TREE;
1515 stringargs = NULL_TREE;
1521 if (!sym->attr.elemental)
1523 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1524 if (se->ss->useflags)
1526 gcc_assert (gfc_return_by_reference (sym)
1527 && sym->result->attr.dimension);
1528 gcc_assert (se->loop != NULL);
1530 /* Access the previously obtained result. */
1531 gfc_conv_tmp_array_ref (se);
1532 gfc_advance_se_ss_chain (se);
1536 info = &se->ss->data.info;
1541 gfc_init_interface_mapping (&mapping);
1542 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
1543 && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
1544 || sym->attr.dimension);
1545 formal = sym->formal;
1546 /* Evaluate the arguments. */
1547 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1549 if (arg->expr == NULL)
1552 if (se->ignore_optional)
1554 /* Some intrinsics have already been resolved to the correct
1558 else if (arg->label)
1560 has_alternate_specifier = 1;
1565 /* Pass a NULL pointer for an absent arg. */
1566 gfc_init_se (&parmse, NULL);
1567 parmse.expr = null_pointer_node;
1568 if (arg->missing_arg_type == BT_CHARACTER)
1569 parmse.string_length = convert (gfc_charlen_type_node,
1573 else if (se->ss && se->ss->useflags)
1575 /* An elemental function inside a scalarized loop. */
1576 gfc_init_se (&parmse, se);
1577 gfc_conv_expr_reference (&parmse, arg->expr);
1581 /* A scalar or transformational function. */
1582 gfc_init_se (&parmse, NULL);
1583 argss = gfc_walk_expr (arg->expr);
1585 if (argss == gfc_ss_terminator)
1587 gfc_conv_expr_reference (&parmse, arg->expr);
1588 if (formal && formal->sym->attr.pointer
1589 && arg->expr->expr_type != EXPR_NULL)
1591 /* Scalar pointer dummy args require an extra level of
1592 indirection. The null pointer already contains
1593 this level of indirection. */
1594 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1599 /* If the procedure requires an explicit interface, the
1600 actual argument is passed according to the
1601 corresponding formal argument. If the corresponding
1602 formal argument is a POINTER or assumed shape, we do
1603 not use g77's calling convention, and pass the
1604 address of the array descriptor instead. Otherwise we
1605 use g77's calling convention. */
1607 f = (formal != NULL)
1608 && !formal->sym->attr.pointer
1609 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1610 f = f || !sym->attr.always_explicit;
1611 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1615 if (formal && need_interface_mapping)
1616 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1618 gfc_add_block_to_block (&se->pre, &parmse.pre);
1619 gfc_add_block_to_block (&se->post, &parmse.post);
1621 /* Character strings are passed as two parameters, a length and a
1623 if (parmse.string_length != NULL_TREE)
1624 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1626 arglist = gfc_chainon_list (arglist, parmse.expr);
1628 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1631 if (ts.type == BT_CHARACTER)
1633 /* Calculate the length of the returned string. */
1634 gfc_init_se (&parmse, NULL);
1635 if (need_interface_mapping)
1636 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1638 gfc_conv_expr (&parmse, sym->ts.cl->length);
1639 gfc_add_block_to_block (&se->pre, &parmse.pre);
1640 gfc_add_block_to_block (&se->post, &parmse.post);
1642 /* Set up a charlen structure for it. */
1645 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1648 len = cl.backend_decl;
1651 byref = gfc_return_by_reference (sym);
1654 if (se->direct_byref)
1655 retargs = gfc_chainon_list (retargs, se->expr);
1656 else if (sym->result->attr.dimension)
1658 gcc_assert (se->loop && info);
1660 /* Set the type of the array. */
1661 tmp = gfc_typenode_for_spec (&ts);
1662 info->dimen = se->loop->dimen;
1664 /* Evaluate the bounds of the result, if known. */
1665 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
1667 /* Allocate a temporary to store the result. */
1668 gfc_trans_allocate_temp_array (&se->pre, &se->post,
1669 se->loop, info, tmp, false);
1671 /* Zero the first stride to indicate a temporary. */
1672 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1673 gfc_add_modify_expr (&se->pre, tmp,
1674 convert (TREE_TYPE (tmp), integer_zero_node));
1676 /* Pass the temporary as the first argument. */
1677 tmp = info->descriptor;
1678 tmp = gfc_build_addr_expr (NULL, tmp);
1679 retargs = gfc_chainon_list (retargs, tmp);
1681 else if (ts.type == BT_CHARACTER)
1683 /* Pass the string length. */
1684 type = gfc_get_character_type (ts.kind, ts.cl);
1685 type = build_pointer_type (type);
1687 /* Return an address to a char[0:len-1]* temporary for
1688 character pointers. */
1689 if (sym->attr.pointer || sym->attr.allocatable)
1691 /* Build char[0:len-1] * pstr. */
1692 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1693 build_int_cst (gfc_charlen_type_node, 1));
1694 tmp = build_range_type (gfc_array_index_type,
1695 gfc_index_zero_node, tmp);
1696 tmp = build_array_type (gfc_character1_type_node, tmp);
1697 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1699 /* Provide an address expression for the function arguments. */
1700 var = gfc_build_addr_expr (NULL, var);
1703 var = gfc_conv_string_tmp (se, type, len);
1705 retargs = gfc_chainon_list (retargs, var);
1709 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
1711 type = gfc_get_complex_type (ts.kind);
1712 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1713 retargs = gfc_chainon_list (retargs, var);
1716 /* Add the string length to the argument list. */
1717 if (ts.type == BT_CHARACTER)
1718 retargs = gfc_chainon_list (retargs, len);
1720 gfc_free_interface_mapping (&mapping);
1722 /* Add the return arguments. */
1723 arglist = chainon (retargs, arglist);
1725 /* Add the hidden string length parameters to the arguments. */
1726 arglist = chainon (arglist, stringargs);
1728 /* Generate the actual call. */
1729 gfc_conv_function_val (se, sym);
1730 /* If there are alternate return labels, function type should be
1731 integer. Can't modify the type in place though, since it can be shared
1732 with other functions. */
1733 if (has_alternate_specifier
1734 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1736 gcc_assert (! sym->attr.dummy);
1737 TREE_TYPE (sym->backend_decl)
1738 = build_function_type (integer_type_node,
1739 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1740 se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
1743 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1744 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1745 arglist, NULL_TREE);
1747 /* If we have a pointer function, but we don't want a pointer, e.g.
1750 where f is pointer valued, we have to dereference the result. */
1751 if (!se->want_pointer && !byref && sym->attr.pointer)
1752 se->expr = gfc_build_indirect_ref (se->expr);
1754 /* f2c calling conventions require a scalar default real function to
1755 return a double precision result. Convert this back to default
1756 real. We only care about the cases that can happen in Fortran 77.
1758 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1759 && sym->ts.kind == gfc_default_real_kind
1760 && !sym->attr.always_explicit)
1761 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1763 /* A pure function may still have side-effects - it may modify its
1765 TREE_SIDE_EFFECTS (se->expr) = 1;
1767 if (!sym->attr.pure)
1768 TREE_SIDE_EFFECTS (se->expr) = 1;
1773 /* Add the function call to the pre chain. There is no expression. */
1774 gfc_add_expr_to_block (&se->pre, se->expr);
1775 se->expr = NULL_TREE;
1777 if (!se->direct_byref)
1779 if (sym->attr.dimension)
1781 if (flag_bounds_check)
1783 /* Check the data pointer hasn't been modified. This would
1784 happen in a function returning a pointer. */
1785 tmp = gfc_conv_descriptor_data_get (info->descriptor);
1786 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1787 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1789 se->expr = info->descriptor;
1790 /* Bundle in the string length. */
1791 se->string_length = len;
1793 else if (sym->ts.type == BT_CHARACTER)
1795 /* Dereference for character pointer results. */
1796 if (sym->attr.pointer || sym->attr.allocatable)
1797 se->expr = gfc_build_indirect_ref (var);
1801 se->string_length = len;
1805 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1806 se->expr = gfc_build_indirect_ref (var);
1811 return has_alternate_specifier;
1815 /* Generate code to copy a string. */
1818 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1819 tree slen, tree src)
1824 tmp = gfc_chainon_list (tmp, dlen);
1825 tmp = gfc_chainon_list (tmp, dest);
1826 tmp = gfc_chainon_list (tmp, slen);
1827 tmp = gfc_chainon_list (tmp, src);
1828 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1829 gfc_add_expr_to_block (block, tmp);
1833 /* Translate a statement function.
1834 The value of a statement function reference is obtained by evaluating the
1835 expression using the values of the actual arguments for the values of the
1836 corresponding dummy arguments. */
1839 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1843 gfc_formal_arglist *fargs;
1844 gfc_actual_arglist *args;
1847 gfc_saved_var *saved_vars;
1853 sym = expr->symtree->n.sym;
1854 args = expr->value.function.actual;
1855 gfc_init_se (&lse, NULL);
1856 gfc_init_se (&rse, NULL);
1859 for (fargs = sym->formal; fargs; fargs = fargs->next)
1861 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1862 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1864 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1866 /* Each dummy shall be specified, explicitly or implicitly, to be
1868 gcc_assert (fargs->sym->attr.dimension == 0);
1871 /* Create a temporary to hold the value. */
1872 type = gfc_typenode_for_spec (&fsym->ts);
1873 temp_vars[n] = gfc_create_var (type, fsym->name);
1875 if (fsym->ts.type == BT_CHARACTER)
1877 /* Copy string arguments. */
1880 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1881 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1883 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1884 tmp = gfc_build_addr_expr (build_pointer_type (type),
1887 gfc_conv_expr (&rse, args->expr);
1888 gfc_conv_string_parameter (&rse);
1889 gfc_add_block_to_block (&se->pre, &lse.pre);
1890 gfc_add_block_to_block (&se->pre, &rse.pre);
1892 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1894 gfc_add_block_to_block (&se->pre, &lse.post);
1895 gfc_add_block_to_block (&se->pre, &rse.post);
1899 /* For everything else, just evaluate the expression. */
1900 gfc_conv_expr (&lse, args->expr);
1902 gfc_add_block_to_block (&se->pre, &lse.pre);
1903 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1904 gfc_add_block_to_block (&se->pre, &lse.post);
1910 /* Use the temporary variables in place of the real ones. */
1911 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1912 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1914 gfc_conv_expr (se, sym->value);
1916 if (sym->ts.type == BT_CHARACTER)
1918 gfc_conv_const_charlen (sym->ts.cl);
1920 /* Force the expression to the correct length. */
1921 if (!INTEGER_CST_P (se->string_length)
1922 || tree_int_cst_lt (se->string_length,
1923 sym->ts.cl->backend_decl))
1925 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1926 tmp = gfc_create_var (type, sym->name);
1927 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1928 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1929 se->string_length, se->expr);
1932 se->string_length = sym->ts.cl->backend_decl;
1935 /* Restore the original variables. */
1936 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1937 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1938 gfc_free (saved_vars);
1942 /* Translate a function expression. */
1945 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1949 if (expr->value.function.isym)
1951 gfc_conv_intrinsic_function (se, expr);
1955 /* We distinguish statement functions from general functions to improve
1956 runtime performance. */
1957 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1959 gfc_conv_statement_function (se, expr);
1963 /* expr.value.function.esym is the resolved (specific) function symbol for
1964 most functions. However this isn't set for dummy procedures. */
1965 sym = expr->value.function.esym;
1967 sym = expr->symtree->n.sym;
1968 gfc_conv_function_call (se, sym, expr->value.function.actual);
1973 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
1975 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
1976 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
1978 gfc_conv_tmp_array_ref (se);
1979 gfc_advance_se_ss_chain (se);
1983 /* Build a static initializer. EXPR is the expression for the initial value.
1984 The other parameters describe the variable of the component being
1985 initialized. EXPR may be null. */
1988 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
1989 bool array, bool pointer)
1993 if (!(expr || pointer))
1998 /* Arrays need special handling. */
2000 return gfc_build_null_descriptor (type);
2002 return gfc_conv_array_initializer (type, expr);
2005 return fold_convert (type, null_pointer_node);
2011 gfc_init_se (&se, NULL);
2012 gfc_conv_structure (&se, expr, 1);
2016 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2019 gfc_init_se (&se, NULL);
2020 gfc_conv_constant (&se, expr);
2027 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2039 gfc_start_block (&block);
2041 /* Initialize the scalarizer. */
2042 gfc_init_loopinfo (&loop);
2044 gfc_init_se (&lse, NULL);
2045 gfc_init_se (&rse, NULL);
2048 rss = gfc_walk_expr (expr);
2049 if (rss == gfc_ss_terminator)
2051 /* The rhs is scalar. Add a ss for the expression. */
2052 rss = gfc_get_ss ();
2053 rss->next = gfc_ss_terminator;
2054 rss->type = GFC_SS_SCALAR;
2058 /* Create a SS for the destination. */
2059 lss = gfc_get_ss ();
2060 lss->type = GFC_SS_COMPONENT;
2062 lss->shape = gfc_get_shape (cm->as->rank);
2063 lss->next = gfc_ss_terminator;
2064 lss->data.info.dimen = cm->as->rank;
2065 lss->data.info.descriptor = dest;
2066 lss->data.info.data = gfc_conv_array_data (dest);
2067 lss->data.info.offset = gfc_conv_array_offset (dest);
2068 for (n = 0; n < cm->as->rank; n++)
2070 lss->data.info.dim[n] = n;
2071 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2072 lss->data.info.stride[n] = gfc_index_one_node;
2074 mpz_init (lss->shape[n]);
2075 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2076 cm->as->lower[n]->value.integer);
2077 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2080 /* Associate the SS with the loop. */
2081 gfc_add_ss_to_loop (&loop, lss);
2082 gfc_add_ss_to_loop (&loop, rss);
2084 /* Calculate the bounds of the scalarization. */
2085 gfc_conv_ss_startstride (&loop);
2087 /* Setup the scalarizing loops. */
2088 gfc_conv_loop_setup (&loop);
2090 /* Setup the gfc_se structures. */
2091 gfc_copy_loopinfo_to_se (&lse, &loop);
2092 gfc_copy_loopinfo_to_se (&rse, &loop);
2095 gfc_mark_ss_chain_used (rss, 1);
2097 gfc_mark_ss_chain_used (lss, 1);
2099 /* Start the scalarized loop body. */
2100 gfc_start_scalarized_body (&loop, &body);
2102 gfc_conv_tmp_array_ref (&lse);
2103 if (cm->ts.type == BT_CHARACTER)
2104 lse.string_length = cm->ts.cl->backend_decl;
2106 gfc_conv_expr (&rse, expr);
2108 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2109 gfc_add_expr_to_block (&body, tmp);
2111 gcc_assert (rse.ss == gfc_ss_terminator);
2113 /* Generate the copying loops. */
2114 gfc_trans_scalarizing_loops (&loop, &body);
2116 /* Wrap the whole thing up. */
2117 gfc_add_block_to_block (&block, &loop.pre);
2118 gfc_add_block_to_block (&block, &loop.post);
2120 for (n = 0; n < cm->as->rank; n++)
2121 mpz_clear (lss->shape[n]);
2122 gfc_free (lss->shape);
2124 gfc_cleanup_loop (&loop);
2126 return gfc_finish_block (&block);
2129 /* Assign a single component of a derived type constructor. */
2132 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2139 gfc_start_block (&block);
2142 gfc_init_se (&se, NULL);
2143 /* Pointer component. */
2146 /* Array pointer. */
2147 if (expr->expr_type == EXPR_NULL)
2148 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2151 rss = gfc_walk_expr (expr);
2152 se.direct_byref = 1;
2154 gfc_conv_expr_descriptor (&se, expr, rss);
2155 gfc_add_block_to_block (&block, &se.pre);
2156 gfc_add_block_to_block (&block, &se.post);
2161 /* Scalar pointers. */
2162 se.want_pointer = 1;
2163 gfc_conv_expr (&se, expr);
2164 gfc_add_block_to_block (&block, &se.pre);
2165 gfc_add_modify_expr (&block, dest,
2166 fold_convert (TREE_TYPE (dest), se.expr));
2167 gfc_add_block_to_block (&block, &se.post);
2170 else if (cm->dimension)
2172 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2173 gfc_add_expr_to_block (&block, tmp);
2175 else if (expr->ts.type == BT_DERIVED)
2177 /* Nested derived type. */
2178 tmp = gfc_trans_structure_assign (dest, expr);
2179 gfc_add_expr_to_block (&block, tmp);
2183 /* Scalar component. */
2186 gfc_init_se (&se, NULL);
2187 gfc_init_se (&lse, NULL);
2189 gfc_conv_expr (&se, expr);
2190 if (cm->ts.type == BT_CHARACTER)
2191 lse.string_length = cm->ts.cl->backend_decl;
2193 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2194 gfc_add_expr_to_block (&block, tmp);
2196 return gfc_finish_block (&block);
2199 /* Assign a derived type constructor to a variable. */
2202 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2210 gfc_start_block (&block);
2211 cm = expr->ts.derived->components;
2212 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2214 /* Skip absent members in default initializers. */
2218 field = cm->backend_decl;
2219 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2220 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2221 gfc_add_expr_to_block (&block, tmp);
2223 return gfc_finish_block (&block);
2226 /* Build an expression for a constructor. If init is nonzero then
2227 this is part of a static variable initializer. */
2230 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2237 VEC(constructor_elt,gc) *v = NULL;
2239 gcc_assert (se->ss == NULL);
2240 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2241 type = gfc_typenode_for_spec (&expr->ts);
2245 /* Create a temporary variable and fill it in. */
2246 se->expr = gfc_create_var (type, expr->ts.derived->name);
2247 tmp = gfc_trans_structure_assign (se->expr, expr);
2248 gfc_add_expr_to_block (&se->pre, tmp);
2252 cm = expr->ts.derived->components;
2253 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2255 /* Skip absent members in default initializers. */
2259 val = gfc_conv_initializer (c->expr, &cm->ts,
2260 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2262 /* Append it to the constructor list. */
2263 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2265 se->expr = build_constructor (type, v);
2269 /* Translate a substring expression. */
2272 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2278 gcc_assert (ref->type == REF_SUBSTRING);
2280 se->expr = gfc_build_string_const(expr->value.character.length,
2281 expr->value.character.string);
2282 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2283 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2285 gfc_conv_substring(se,ref,expr->ts.kind);
2289 /* Entry point for expression translation. Evaluates a scalar quantity.
2290 EXPR is the expression to be translated, and SE is the state structure if
2291 called from within the scalarized. */
2294 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2296 if (se->ss && se->ss->expr == expr
2297 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2299 /* Substitute a scalar expression evaluated outside the scalarization
2301 se->expr = se->ss->data.scalar.expr;
2302 se->string_length = se->ss->string_length;
2303 gfc_advance_se_ss_chain (se);
2307 switch (expr->expr_type)
2310 gfc_conv_expr_op (se, expr);
2314 gfc_conv_function_expr (se, expr);
2318 gfc_conv_constant (se, expr);
2322 gfc_conv_variable (se, expr);
2326 se->expr = null_pointer_node;
2329 case EXPR_SUBSTRING:
2330 gfc_conv_substring_expr (se, expr);
2333 case EXPR_STRUCTURE:
2334 gfc_conv_structure (se, expr, 0);
2338 gfc_conv_array_constructor_expr (se, expr);
2347 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2348 of an assignment. */
2350 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2352 gfc_conv_expr (se, expr);
2353 /* All numeric lvalues should have empty post chains. If not we need to
2354 figure out a way of rewriting an lvalue so that it has no post chain. */
2355 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2358 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2359 numeric expressions. Used for scalar values whee inserting cleanup code
2362 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2366 gcc_assert (expr->ts.type != BT_CHARACTER);
2367 gfc_conv_expr (se, expr);
2370 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2371 gfc_add_modify_expr (&se->pre, val, se->expr);
2373 gfc_add_block_to_block (&se->pre, &se->post);
2377 /* Helper to translate and expression and convert it to a particular type. */
2379 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2381 gfc_conv_expr_val (se, expr);
2382 se->expr = convert (type, se->expr);
2386 /* Converts an expression so that it can be passed by reference. Scalar
2390 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2394 if (se->ss && se->ss->expr == expr
2395 && se->ss->type == GFC_SS_REFERENCE)
2397 se->expr = se->ss->data.scalar.expr;
2398 se->string_length = se->ss->string_length;
2399 gfc_advance_se_ss_chain (se);
2403 if (expr->ts.type == BT_CHARACTER)
2405 gfc_conv_expr (se, expr);
2406 gfc_conv_string_parameter (se);
2410 if (expr->expr_type == EXPR_VARIABLE)
2412 se->want_pointer = 1;
2413 gfc_conv_expr (se, expr);
2416 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2417 gfc_add_modify_expr (&se->pre, var, se->expr);
2418 gfc_add_block_to_block (&se->pre, &se->post);
2424 gfc_conv_expr (se, expr);
2426 /* Create a temporary var to hold the value. */
2427 if (TREE_CONSTANT (se->expr))
2429 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2430 DECL_INITIAL (var) = se->expr;
2435 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2436 gfc_add_modify_expr (&se->pre, var, se->expr);
2438 gfc_add_block_to_block (&se->pre, &se->post);
2440 /* Take the address of that value. */
2441 se->expr = gfc_build_addr_expr (NULL, var);
2446 gfc_trans_pointer_assign (gfc_code * code)
2448 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2452 /* Generate code for a pointer assignment. */
2455 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2465 gfc_start_block (&block);
2467 gfc_init_se (&lse, NULL);
2469 lss = gfc_walk_expr (expr1);
2470 rss = gfc_walk_expr (expr2);
2471 if (lss == gfc_ss_terminator)
2473 /* Scalar pointers. */
2474 lse.want_pointer = 1;
2475 gfc_conv_expr (&lse, expr1);
2476 gcc_assert (rss == gfc_ss_terminator);
2477 gfc_init_se (&rse, NULL);
2478 rse.want_pointer = 1;
2479 gfc_conv_expr (&rse, expr2);
2480 gfc_add_block_to_block (&block, &lse.pre);
2481 gfc_add_block_to_block (&block, &rse.pre);
2482 gfc_add_modify_expr (&block, lse.expr,
2483 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2484 gfc_add_block_to_block (&block, &rse.post);
2485 gfc_add_block_to_block (&block, &lse.post);
2489 /* Array pointer. */
2490 gfc_conv_expr_descriptor (&lse, expr1, lss);
2491 switch (expr2->expr_type)
2494 /* Just set the data pointer to null. */
2495 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2499 /* Assign directly to the pointer's descriptor. */
2500 lse.direct_byref = 1;
2501 gfc_conv_expr_descriptor (&lse, expr2, rss);
2505 /* Assign to a temporary descriptor and then copy that
2506 temporary to the pointer. */
2508 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2511 lse.direct_byref = 1;
2512 gfc_conv_expr_descriptor (&lse, expr2, rss);
2513 gfc_add_modify_expr (&lse.pre, desc, tmp);
2516 gfc_add_block_to_block (&block, &lse.pre);
2517 gfc_add_block_to_block (&block, &lse.post);
2519 return gfc_finish_block (&block);
2523 /* Makes sure se is suitable for passing as a function string parameter. */
2524 /* TODO: Need to check all callers fo this function. It may be abused. */
2527 gfc_conv_string_parameter (gfc_se * se)
2531 if (TREE_CODE (se->expr) == STRING_CST)
2533 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2537 type = TREE_TYPE (se->expr);
2538 if (TYPE_STRING_FLAG (type))
2540 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2541 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2544 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2545 gcc_assert (se->string_length
2546 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2550 /* Generate code for assignment of scalar variables. Includes character
2554 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2558 gfc_init_block (&block);
2560 if (type == BT_CHARACTER)
2562 gcc_assert (lse->string_length != NULL_TREE
2563 && rse->string_length != NULL_TREE);
2565 gfc_conv_string_parameter (lse);
2566 gfc_conv_string_parameter (rse);
2568 gfc_add_block_to_block (&block, &lse->pre);
2569 gfc_add_block_to_block (&block, &rse->pre);
2571 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2572 rse->string_length, rse->expr);
2576 gfc_add_block_to_block (&block, &lse->pre);
2577 gfc_add_block_to_block (&block, &rse->pre);
2579 gfc_add_modify_expr (&block, lse->expr,
2580 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2583 gfc_add_block_to_block (&block, &lse->post);
2584 gfc_add_block_to_block (&block, &rse->post);
2586 return gfc_finish_block (&block);
2590 /* Try to translate array(:) = func (...), where func is a transformational
2591 array function, without using a temporary. Returns NULL is this isn't the
2595 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2600 bool seen_array_ref;
2602 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2603 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2606 /* Elemental functions don't need a temporary anyway. */
2607 if (expr2->value.function.esym != NULL
2608 && expr2->value.function.esym->attr.elemental)
2611 /* Fail if EXPR1 can't be expressed as a descriptor. */
2612 if (gfc_ref_needs_temporary_p (expr1->ref))
2615 /* Check that no LHS component references appear during an array
2616 reference. This is needed because we do not have the means to
2617 span any arbitrary stride with an array descriptor. This check
2618 is not needed for the rhs because the function result has to be
2620 seen_array_ref = false;
2621 for (ref = expr1->ref; ref; ref = ref->next)
2623 if (ref->type == REF_ARRAY)
2624 seen_array_ref= true;
2625 else if (ref->type == REF_COMPONENT && seen_array_ref)
2629 /* Check for a dependency. */
2630 if (gfc_check_fncall_dependency (expr1, expr2))
2633 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2635 gcc_assert (expr2->value.function.isym
2636 || (gfc_return_by_reference (expr2->value.function.esym)
2637 && expr2->value.function.esym->result->attr.dimension));
2639 ss = gfc_walk_expr (expr1);
2640 gcc_assert (ss != gfc_ss_terminator);
2641 gfc_init_se (&se, NULL);
2642 gfc_start_block (&se.pre);
2643 se.want_pointer = 1;
2645 gfc_conv_array_parameter (&se, expr1, ss, 0);
2647 se.direct_byref = 1;
2648 se.ss = gfc_walk_expr (expr2);
2649 gcc_assert (se.ss != gfc_ss_terminator);
2650 gfc_conv_function_expr (&se, expr2);
2651 gfc_add_block_to_block (&se.pre, &se.post);
2653 return gfc_finish_block (&se.pre);
2657 /* Translate an assignment. Most of the code is concerned with
2658 setting up the scalarizer. */
2661 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2666 gfc_ss *lss_section;
2673 /* Special case a single function returning an array. */
2674 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2676 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2681 /* Assignment of the form lhs = rhs. */
2682 gfc_start_block (&block);
2684 gfc_init_se (&lse, NULL);
2685 gfc_init_se (&rse, NULL);
2688 lss = gfc_walk_expr (expr1);
2690 if (lss != gfc_ss_terminator)
2692 /* The assignment needs scalarization. */
2695 /* Find a non-scalar SS from the lhs. */
2696 while (lss_section != gfc_ss_terminator
2697 && lss_section->type != GFC_SS_SECTION)
2698 lss_section = lss_section->next;
2700 gcc_assert (lss_section != gfc_ss_terminator);
2702 /* Initialize the scalarizer. */
2703 gfc_init_loopinfo (&loop);
2706 rss = gfc_walk_expr (expr2);
2707 if (rss == gfc_ss_terminator)
2709 /* The rhs is scalar. Add a ss for the expression. */
2710 rss = gfc_get_ss ();
2711 rss->next = gfc_ss_terminator;
2712 rss->type = GFC_SS_SCALAR;
2715 /* Associate the SS with the loop. */
2716 gfc_add_ss_to_loop (&loop, lss);
2717 gfc_add_ss_to_loop (&loop, rss);
2719 /* Calculate the bounds of the scalarization. */
2720 gfc_conv_ss_startstride (&loop);
2721 /* Resolve any data dependencies in the statement. */
2722 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2723 /* Setup the scalarizing loops. */
2724 gfc_conv_loop_setup (&loop);
2726 /* Setup the gfc_se structures. */
2727 gfc_copy_loopinfo_to_se (&lse, &loop);
2728 gfc_copy_loopinfo_to_se (&rse, &loop);
2731 gfc_mark_ss_chain_used (rss, 1);
2732 if (loop.temp_ss == NULL)
2735 gfc_mark_ss_chain_used (lss, 1);
2739 lse.ss = loop.temp_ss;
2740 gfc_mark_ss_chain_used (lss, 3);
2741 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2744 /* Start the scalarized loop body. */
2745 gfc_start_scalarized_body (&loop, &body);
2748 gfc_init_block (&body);
2750 /* Translate the expression. */
2751 gfc_conv_expr (&rse, expr2);
2753 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2755 gfc_conv_tmp_array_ref (&lse);
2756 gfc_advance_se_ss_chain (&lse);
2759 gfc_conv_expr (&lse, expr1);
2761 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2762 gfc_add_expr_to_block (&body, tmp);
2764 if (lss == gfc_ss_terminator)
2766 /* Use the scalar assignment as is. */
2767 gfc_add_block_to_block (&block, &body);
2771 gcc_assert (lse.ss == gfc_ss_terminator
2772 && rse.ss == gfc_ss_terminator);
2774 if (loop.temp_ss != NULL)
2776 gfc_trans_scalarized_loop_boundary (&loop, &body);
2778 /* We need to copy the temporary to the actual lhs. */
2779 gfc_init_se (&lse, NULL);
2780 gfc_init_se (&rse, NULL);
2781 gfc_copy_loopinfo_to_se (&lse, &loop);
2782 gfc_copy_loopinfo_to_se (&rse, &loop);
2784 rse.ss = loop.temp_ss;
2787 gfc_conv_tmp_array_ref (&rse);
2788 gfc_advance_se_ss_chain (&rse);
2789 gfc_conv_expr (&lse, expr1);
2791 gcc_assert (lse.ss == gfc_ss_terminator
2792 && rse.ss == gfc_ss_terminator);
2794 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2795 gfc_add_expr_to_block (&body, tmp);
2797 /* Generate the copying loops. */
2798 gfc_trans_scalarizing_loops (&loop, &body);
2800 /* Wrap the whole thing up. */
2801 gfc_add_block_to_block (&block, &loop.pre);
2802 gfc_add_block_to_block (&block, &loop.post);
2804 gfc_cleanup_loop (&loop);
2807 return gfc_finish_block (&block);
2811 gfc_trans_assign (gfc_code * code)
2813 return gfc_trans_assignment (code->expr, code->expr2);