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"
43 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
45 /* Copy the scalarization loop variables. */
48 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
51 dest->loop = src->loop;
55 /* Initialize a simple expression holder.
57 Care must be taken when multiple se are created with the same parent.
58 The child se must be kept in sync. The easiest way is to delay creation
59 of a child se until after after the previous se has been translated. */
62 gfc_init_se (gfc_se * se, gfc_se * parent)
64 memset (se, 0, sizeof (gfc_se));
65 gfc_init_block (&se->pre);
66 gfc_init_block (&se->post);
71 gfc_copy_se_loopvars (se, parent);
75 /* Advances to the next SS in the chain. Use this rather than setting
76 se->ss = se->ss->next because all the parents needs to be kept in sync.
80 gfc_advance_se_ss_chain (gfc_se * se)
84 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
87 /* Walk down the parent chain. */
90 /* Simple consistency check. */
91 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
100 /* Ensures the result of the expression as either a temporary variable
101 or a constant so that it can be used repeatedly. */
104 gfc_make_safe_expr (gfc_se * se)
108 if (CONSTANT_CLASS_P (se->expr))
111 /* We need a temporary for this result. */
112 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
113 gfc_add_modify_expr (&se->pre, var, se->expr);
118 /* Return an expression which determines if a dummy parameter is present.
119 Also used for arguments to procedures with multiple entry points. */
122 gfc_conv_expr_present (gfc_symbol * sym)
126 gcc_assert (sym->attr.dummy);
128 decl = gfc_get_symbol_decl (sym);
129 if (TREE_CODE (decl) != PARM_DECL)
131 /* Array parameters use a temporary descriptor, we want the real
133 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
134 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
135 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
137 return build2 (NE_EXPR, boolean_type_node, decl,
138 fold_convert (TREE_TYPE (decl), null_pointer_node));
142 /* Get the character length of an expression, looking through gfc_refs
146 gfc_get_expr_charlen (gfc_expr *e)
151 gcc_assert (e->expr_type == EXPR_VARIABLE
152 && e->ts.type == BT_CHARACTER);
154 length = NULL; /* To silence compiler warning. */
156 /* First candidate: if the variable is of type CHARACTER, the
157 expression's length could be the length of the character
159 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
160 length = e->symtree->n.sym->ts.cl->backend_decl;
162 /* Look through the reference chain for component references. */
163 for (r = e->ref; r; r = r->next)
168 if (r->u.c.component->ts.type == BT_CHARACTER)
169 length = r->u.c.component->ts.cl->backend_decl;
177 /* We should never got substring references here. These will be
178 broken down by the scalarizer. */
183 gcc_assert (length != NULL);
189 /* Generate code to initialize a string length variable. Returns the
193 gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
198 gfc_init_se (&se, NULL);
199 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
200 gfc_add_block_to_block (pblock, &se.pre);
202 tmp = cl->backend_decl;
203 gfc_add_modify_expr (pblock, tmp, se.expr);
208 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind)
216 type = gfc_get_character_type (kind, ref->u.ss.length);
217 type = build_pointer_type (type);
220 gfc_init_se (&start, se);
221 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
222 gfc_add_block_to_block (&se->pre, &start.pre);
224 if (integer_onep (start.expr))
225 gfc_conv_string_parameter (se);
228 /* Change the start of the string. */
229 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
232 tmp = gfc_build_indirect_ref (se->expr);
233 tmp = gfc_build_array_ref (tmp, start.expr);
234 se->expr = gfc_build_addr_expr (type, tmp);
237 /* Length = end + 1 - start. */
238 gfc_init_se (&end, se);
239 if (ref->u.ss.end == NULL)
240 end.expr = se->string_length;
243 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
244 gfc_add_block_to_block (&se->pre, &end.pre);
247 build2 (MINUS_EXPR, gfc_charlen_type_node,
248 fold_convert (gfc_charlen_type_node, integer_one_node),
250 tmp = build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
251 se->string_length = fold (tmp);
255 /* Convert a derived type component reference. */
258 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
265 c = ref->u.c.component;
267 gcc_assert (c->backend_decl);
269 field = c->backend_decl;
270 gcc_assert (TREE_CODE (field) == FIELD_DECL);
272 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
276 if (c->ts.type == BT_CHARACTER)
278 tmp = c->ts.cl->backend_decl;
279 /* Components must always be constant length. */
280 gcc_assert (tmp && INTEGER_CST_P (tmp));
281 se->string_length = tmp;
284 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
285 se->expr = gfc_build_indirect_ref (se->expr);
289 /* Return the contents of a variable. Also handles reference/pointer
290 variables (all Fortran pointer references are implicit). */
293 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
298 sym = expr->symtree->n.sym;
301 /* Check that something hasn't gone horribly wrong. */
302 gcc_assert (se->ss != gfc_ss_terminator);
303 gcc_assert (se->ss->expr == expr);
305 /* A scalarized term. We already know the descriptor. */
306 se->expr = se->ss->data.info.descriptor;
307 se->string_length = se->ss->string_length;
308 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
309 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
314 tree se_expr = NULL_TREE;
316 se->expr = gfc_get_symbol_decl (sym);
318 /* Special case for assigning the return value of a function.
319 Self recursive functions must have an explicit return value. */
320 if (se->expr == current_function_decl && sym->attr.function
321 && (sym->result == sym))
322 se_expr = gfc_get_fake_result_decl (sym);
324 /* Similarly for alternate entry points. */
325 else if (sym->attr.function && sym->attr.entry
326 && (sym->result == sym)
327 && sym->ns->proc_name->backend_decl == current_function_decl)
329 gfc_entry_list *el = NULL;
331 for (el = sym->ns->entries; el; el = el->next)
334 se_expr = gfc_get_fake_result_decl (sym);
339 else if (sym->attr.result
340 && sym->ns->proc_name->backend_decl == current_function_decl
341 && sym->ns->proc_name->attr.entry_master
342 && !gfc_return_by_reference (sym->ns->proc_name))
343 se_expr = gfc_get_fake_result_decl (sym);
348 /* Procedure actual arguments. */
349 else if (sym->attr.flavor == FL_PROCEDURE
350 && se->expr != current_function_decl)
352 gcc_assert (se->want_pointer);
353 if (!sym->attr.dummy)
355 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
356 se->expr = gfc_build_addr_expr (NULL, se->expr);
362 /* Dereference the expression, where needed. Since characters
363 are entirely different from other types, they are treated
365 if (sym->ts.type == BT_CHARACTER)
367 /* Dereference character pointer dummy arguments
369 if ((sym->attr.pointer || sym->attr.allocatable)
371 || sym->attr.function
372 || sym->attr.result))
373 se->expr = gfc_build_indirect_ref (se->expr);
377 /* Dereference non-character scalar dummy arguments. */
378 if (sym->attr.dummy && !sym->attr.dimension)
379 se->expr = gfc_build_indirect_ref (se->expr);
381 /* Dereference scalar hidden result. */
382 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
383 && (sym->attr.function || sym->attr.result)
384 && !sym->attr.dimension && !sym->attr.pointer)
385 se->expr = gfc_build_indirect_ref (se->expr);
387 /* Dereference non-character pointer variables.
388 These must be dummies, results, or scalars. */
389 if ((sym->attr.pointer || sym->attr.allocatable)
391 || sym->attr.function
393 || !sym->attr.dimension))
394 se->expr = gfc_build_indirect_ref (se->expr);
400 /* For character variables, also get the length. */
401 if (sym->ts.type == BT_CHARACTER)
403 se->string_length = sym->ts.cl->backend_decl;
404 gcc_assert (se->string_length);
412 /* Return the descriptor if that's what we want and this is an array
413 section reference. */
414 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
416 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
417 /* Return the descriptor for array pointers and allocations. */
419 && ref->next == NULL && (se->descriptor_only))
422 gfc_conv_array_ref (se, &ref->u.ar);
423 /* Return a pointer to an element. */
427 gfc_conv_component_ref (se, ref);
431 gfc_conv_substring (se, ref, expr->ts.kind);
440 /* Pointer assignment, allocation or pass by reference. Arrays are handled
442 if (se->want_pointer)
444 if (expr->ts.type == BT_CHARACTER)
445 gfc_conv_string_parameter (se);
447 se->expr = gfc_build_addr_expr (NULL, se->expr);
452 /* Unary ops are easy... Or they would be if ! was a valid op. */
455 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
460 gcc_assert (expr->ts.type != BT_CHARACTER);
461 /* Initialize the operand. */
462 gfc_init_se (&operand, se);
463 gfc_conv_expr_val (&operand, expr->value.op.op1);
464 gfc_add_block_to_block (&se->pre, &operand.pre);
466 type = gfc_typenode_for_spec (&expr->ts);
468 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
469 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
470 All other unary operators have an equivalent GIMPLE unary operator. */
471 if (code == TRUTH_NOT_EXPR)
472 se->expr = build2 (EQ_EXPR, type, operand.expr,
473 convert (type, integer_zero_node));
475 se->expr = build1 (code, type, operand.expr);
479 /* Expand power operator to optimal multiplications when a value is raised
480 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
481 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
482 Programming", 3rd Edition, 1998. */
484 /* This code is mostly duplicated from expand_powi in the backend.
485 We establish the "optimal power tree" lookup table with the defined size.
486 The items in the table are the exponents used to calculate the index
487 exponents. Any integer n less than the value can get an "addition chain",
488 with the first node being one. */
489 #define POWI_TABLE_SIZE 256
491 /* The table is from builtins.c. */
492 static const unsigned char powi_table[POWI_TABLE_SIZE] =
494 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
495 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
496 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
497 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
498 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
499 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
500 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
501 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
502 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
503 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
504 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
505 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
506 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
507 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
508 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
509 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
510 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
511 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
512 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
513 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
514 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
515 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
516 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
517 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
518 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
519 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
520 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
521 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
522 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
523 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
524 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
525 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
528 /* If n is larger than lookup table's max index, we use the "window
530 #define POWI_WINDOW_SIZE 3
532 /* Recursive function to expand the power operator. The temporary
533 values are put in tmpvar. The function returns tmpvar[1] ** n. */
535 gfc_conv_powi (gfc_se * se, int n, tree * tmpvar)
542 if (n < POWI_TABLE_SIZE)
547 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
548 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
552 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
553 op0 = gfc_conv_powi (se, n - digit, tmpvar);
554 op1 = gfc_conv_powi (se, digit, tmpvar);
558 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
562 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
563 tmp = gfc_evaluate_now (tmp, &se->pre);
565 if (n < POWI_TABLE_SIZE)
572 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
573 return 1. Else return 0 and a call to runtime library functions
574 will have to be built. */
576 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
581 tree vartmp[POWI_TABLE_SIZE];
585 type = TREE_TYPE (lhs);
586 n = abs (TREE_INT_CST_LOW (rhs));
587 sgn = tree_int_cst_sgn (rhs);
589 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations) || optimize_size)
590 && (n > 2 || n < -1))
596 se->expr = gfc_build_const (type, integer_one_node);
599 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
600 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
602 tmp = build2 (EQ_EXPR, boolean_type_node, lhs,
603 fold_convert (TREE_TYPE (lhs), integer_minus_one_node));
604 cond = build2 (EQ_EXPR, boolean_type_node, lhs,
605 convert (TREE_TYPE (lhs), integer_one_node));
608 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
611 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
612 se->expr = build3 (COND_EXPR, type, tmp,
613 convert (type, integer_one_node),
614 convert (type, integer_zero_node));
618 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
619 tmp = build3 (COND_EXPR, type, tmp,
620 convert (type, integer_minus_one_node),
621 convert (type, integer_zero_node));
622 se->expr = build3 (COND_EXPR, type, cond,
623 convert (type, integer_one_node),
628 memset (vartmp, 0, sizeof (vartmp));
632 tmp = gfc_build_const (type, integer_one_node);
633 vartmp[1] = build2 (RDIV_EXPR, type, tmp, vartmp[1]);
636 se->expr = gfc_conv_powi (se, n, vartmp);
642 /* Power op (**). Constant integer exponent has special handling. */
645 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
647 tree gfc_int4_type_node;
655 gfc_init_se (&lse, se);
656 gfc_conv_expr_val (&lse, expr->value.op.op1);
657 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
658 gfc_add_block_to_block (&se->pre, &lse.pre);
660 gfc_init_se (&rse, se);
661 gfc_conv_expr_val (&rse, expr->value.op.op2);
662 gfc_add_block_to_block (&se->pre, &rse.pre);
664 if (expr->value.op.op2->ts.type == BT_INTEGER
665 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
666 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
669 gfc_int4_type_node = gfc_get_int_type (4);
671 kind = expr->value.op.op1->ts.kind;
672 switch (expr->value.op.op2->ts.type)
675 ikind = expr->value.op.op2->ts.kind;
680 rse.expr = convert (gfc_int4_type_node, rse.expr);
698 if (expr->value.op.op1->ts.type == BT_INTEGER)
699 lse.expr = convert (gfc_int4_type_node, lse.expr);
716 switch (expr->value.op.op1->ts.type)
719 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
723 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
727 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
739 fndecl = built_in_decls[BUILT_IN_POWF];
742 fndecl = built_in_decls[BUILT_IN_POW];
753 fndecl = gfor_fndecl_math_cpowf;
756 fndecl = gfor_fndecl_math_cpow;
768 tmp = gfc_chainon_list (NULL_TREE, lse.expr);
769 tmp = gfc_chainon_list (tmp, rse.expr);
770 se->expr = fold (gfc_build_function_call (fndecl, tmp));
774 /* Generate code to allocate a string temporary. */
777 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
783 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
785 if (gfc_can_put_var_on_stack (len))
787 /* Create a temporary variable to hold the result. */
788 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
789 convert (gfc_charlen_type_node, integer_one_node));
790 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
791 tmp = build_array_type (gfc_character1_type_node, tmp);
792 var = gfc_create_var (tmp, "str");
793 var = gfc_build_addr_expr (type, var);
797 /* Allocate a temporary to hold the result. */
798 var = gfc_create_var (type, "pstr");
799 args = gfc_chainon_list (NULL_TREE, len);
800 tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
801 tmp = convert (type, tmp);
802 gfc_add_modify_expr (&se->pre, var, tmp);
804 /* Free the temporary afterwards. */
805 tmp = convert (pvoid_type_node, var);
806 args = gfc_chainon_list (NULL_TREE, tmp);
807 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
808 gfc_add_expr_to_block (&se->post, tmp);
815 /* Handle a string concatenation operation. A temporary will be allocated to
819 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
829 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
830 && expr->value.op.op2->ts.type == BT_CHARACTER);
832 gfc_init_se (&lse, se);
833 gfc_conv_expr (&lse, expr->value.op.op1);
834 gfc_conv_string_parameter (&lse);
835 gfc_init_se (&rse, se);
836 gfc_conv_expr (&rse, expr->value.op.op2);
837 gfc_conv_string_parameter (&rse);
839 gfc_add_block_to_block (&se->pre, &lse.pre);
840 gfc_add_block_to_block (&se->pre, &rse.pre);
842 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
843 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
844 if (len == NULL_TREE)
846 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
847 lse.string_length, rse.string_length);
850 type = build_pointer_type (type);
852 var = gfc_conv_string_tmp (se, type, len);
854 /* Do the actual concatenation. */
856 args = gfc_chainon_list (args, len);
857 args = gfc_chainon_list (args, var);
858 args = gfc_chainon_list (args, lse.string_length);
859 args = gfc_chainon_list (args, lse.expr);
860 args = gfc_chainon_list (args, rse.string_length);
861 args = gfc_chainon_list (args, rse.expr);
862 tmp = gfc_build_function_call (gfor_fndecl_concat_string, args);
863 gfc_add_expr_to_block (&se->pre, tmp);
865 /* Add the cleanup for the operands. */
866 gfc_add_block_to_block (&se->pre, &rse.post);
867 gfc_add_block_to_block (&se->pre, &lse.post);
870 se->string_length = len;
874 /* Translates an op expression. Common (binary) cases are handled by this
875 function, others are passed on. Recursion is used in either case.
876 We use the fact that (op1.ts == op2.ts) (except for the power
878 Operators need no special handling for scalarized expressions as long as
879 they call gfc_conv_simple_val to get their operands.
880 Character strings get special handling. */
883 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
895 switch (expr->value.op.operator)
897 case INTRINSIC_UPLUS:
898 gfc_conv_expr (se, expr->value.op.op1);
901 case INTRINSIC_UMINUS:
902 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
906 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
913 case INTRINSIC_MINUS:
917 case INTRINSIC_TIMES:
921 case INTRINSIC_DIVIDE:
922 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
923 an integer, we must round towards zero, so we use a
925 if (expr->ts.type == BT_INTEGER)
926 code = TRUNC_DIV_EXPR;
931 case INTRINSIC_POWER:
932 gfc_conv_power_op (se, expr);
935 case INTRINSIC_CONCAT:
936 gfc_conv_concat_op (se, expr);
940 code = TRUTH_ANDIF_EXPR;
945 code = TRUTH_ORIF_EXPR;
949 /* EQV and NEQV only work on logicals, but since we represent them
950 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
990 case INTRINSIC_ASSIGN:
991 /* These should be converted into function calls by the frontend. */
995 fatal_error ("Unknown intrinsic op");
999 /* The only exception to this is **, which is handled separately anyway. */
1000 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1002 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1006 gfc_init_se (&lse, se);
1007 gfc_conv_expr (&lse, expr->value.op.op1);
1008 gfc_add_block_to_block (&se->pre, &lse.pre);
1011 gfc_init_se (&rse, se);
1012 gfc_conv_expr (&rse, expr->value.op.op2);
1013 gfc_add_block_to_block (&se->pre, &rse.pre);
1015 /* For string comparisons we generate a library call, and compare the return
1019 gfc_conv_string_parameter (&lse);
1020 gfc_conv_string_parameter (&rse);
1022 tmp = gfc_chainon_list (tmp, lse.string_length);
1023 tmp = gfc_chainon_list (tmp, lse.expr);
1024 tmp = gfc_chainon_list (tmp, rse.string_length);
1025 tmp = gfc_chainon_list (tmp, rse.expr);
1027 /* Build a call for the comparison. */
1028 lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp);
1029 gfc_add_block_to_block (&lse.post, &rse.post);
1031 rse.expr = integer_zero_node;
1034 type = gfc_typenode_for_spec (&expr->ts);
1038 /* The result of logical ops is always boolean_type_node. */
1039 tmp = fold_build2 (code, type, lse.expr, rse.expr);
1040 se->expr = convert (type, tmp);
1043 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1045 /* Add the post blocks. */
1046 gfc_add_block_to_block (&se->post, &rse.post);
1047 gfc_add_block_to_block (&se->post, &lse.post);
1052 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1056 if (sym->attr.dummy)
1058 tmp = gfc_get_symbol_decl (sym);
1059 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1060 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1064 if (!sym->backend_decl)
1065 sym->backend_decl = gfc_get_extern_function_decl (sym);
1067 tmp = sym->backend_decl;
1068 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1070 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1071 tmp = gfc_build_addr_expr (NULL, tmp);
1078 /* This group of functions allows a caller to evaluate an expression from
1079 the callee's interface. It establishes a mapping between the interface's
1080 dummy arguments and the caller's actual arguments, then applies that
1081 mapping to a given gfc_expr.
1083 You can initialize a mapping structure like so:
1085 gfc_interface_mapping mapping;
1087 gfc_init_interface_mapping (&mapping);
1089 You should then evaluate each actual argument into a temporary
1090 gfc_se structure, here called "se", and map the result to the
1091 dummy argument's symbol, here called "sym":
1093 gfc_add_interface_mapping (&mapping, sym, &se);
1095 After adding all mappings, you should call:
1097 gfc_finish_interface_mapping (&mapping, pre, post);
1099 where "pre" and "post" are statement blocks for initialization
1100 and finalization code respectively. You can then evaluate an
1101 interface expression "expr" as follows:
1103 gfc_apply_interface_mapping (&mapping, se, expr);
1105 Once you've evaluated all expressions, you should free
1106 the mapping structure with:
1108 gfc_free_interface_mapping (&mapping); */
1111 /* This structure represents a mapping from OLD to NEW, where OLD is a
1112 dummy argument symbol and NEW is a symbol that represents the value
1113 of an actual argument. Mappings are linked together using NEXT
1114 (in no particular order). */
1115 typedef struct gfc_interface_sym_mapping
1117 struct gfc_interface_sym_mapping *next;
1121 gfc_interface_sym_mapping;
1124 /* This structure is used by callers to evaluate an expression from
1125 a callee's interface. */
1126 typedef struct gfc_interface_mapping
1128 /* Maps the interface's dummy arguments to the values that the caller
1129 is passing. The whole list is owned by this gfc_interface_mapping. */
1130 gfc_interface_sym_mapping *syms;
1132 /* A list of gfc_charlens that were needed when creating copies of
1133 expressions. The whole list is owned by this gfc_interface_mapping. */
1134 gfc_charlen *charlens;
1136 gfc_interface_mapping;
1139 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
1142 /* Initialize MAPPING. */
1145 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1147 mapping->syms = NULL;
1148 mapping->charlens = NULL;
1152 /* Free all memory held by MAPPING (but not MAPPING itself). */
1155 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1157 gfc_interface_sym_mapping *sym;
1158 gfc_interface_sym_mapping *nextsym;
1160 gfc_charlen *nextcl;
1162 for (sym = mapping->syms; sym; sym = nextsym)
1164 nextsym = sym->next;
1165 gfc_free_symbol (sym->new->n.sym);
1166 gfc_free (sym->new);
1169 for (cl = mapping->charlens; cl; cl = nextcl)
1172 gfc_free_expr (cl->length);
1178 /* Return a copy of gfc_charlen CL. Add the returned structure to
1179 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1181 static gfc_charlen *
1182 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1187 new = gfc_get_charlen ();
1188 new->next = mapping->charlens;
1189 new->length = gfc_copy_expr (cl->length);
1191 mapping->charlens = new;
1196 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1197 array variable that can be used as the actual argument for dummy
1198 argument SYM. Add any initialization code to BLOCK. PACKED is as
1199 for gfc_get_nodesc_array_type and DATA points to the first element
1200 in the passed array. */
1203 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1204 int packed, tree data)
1209 type = gfc_typenode_for_spec (&sym->ts);
1210 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1212 var = gfc_create_var (type, "parm");
1213 gfc_add_modify_expr (block, var, fold_convert (type, data));
1219 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1220 and offset of descriptorless array type TYPE given that it has the same
1221 size as DESC. Add any set-up code to BLOCK. */
1224 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1231 offset = gfc_index_zero_node;
1232 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1234 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1235 if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1237 dim = gfc_rank_cst[n];
1238 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1239 gfc_conv_descriptor_ubound (desc, dim),
1240 gfc_conv_descriptor_lbound (desc, dim));
1241 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1242 GFC_TYPE_ARRAY_LBOUND (type, n),
1244 tmp = gfc_evaluate_now (tmp, block);
1245 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1247 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1248 GFC_TYPE_ARRAY_LBOUND (type, n),
1249 GFC_TYPE_ARRAY_STRIDE (type, n));
1250 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1252 offset = gfc_evaluate_now (offset, block);
1253 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1257 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1258 in SE. The caller may still use se->expr and se->string_length after
1259 calling this function. */
1262 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1263 gfc_symbol * sym, gfc_se * se)
1265 gfc_interface_sym_mapping *sm;
1269 gfc_symbol *new_sym;
1271 gfc_symtree *new_symtree;
1273 /* Create a new symbol to represent the actual argument. */
1274 new_sym = gfc_new_symbol (sym->name, NULL);
1275 new_sym->ts = sym->ts;
1276 new_sym->attr.referenced = 1;
1277 new_sym->attr.dimension = sym->attr.dimension;
1278 new_sym->attr.pointer = sym->attr.pointer;
1279 new_sym->attr.flavor = sym->attr.flavor;
1281 /* Create a fake symtree for it. */
1283 new_symtree = gfc_new_symtree (&root, sym->name);
1284 new_symtree->n.sym = new_sym;
1285 gcc_assert (new_symtree == root);
1287 /* Create a dummy->actual mapping. */
1288 sm = gfc_getmem (sizeof (*sm));
1289 sm->next = mapping->syms;
1291 sm->new = new_symtree;
1294 /* Stabilize the argument's value. */
1295 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1297 if (sym->ts.type == BT_CHARACTER)
1299 /* Create a copy of the dummy argument's length. */
1300 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1302 /* If the length is specified as "*", record the length that
1303 the caller is passing. We should use the callee's length
1304 in all other cases. */
1305 if (!new_sym->ts.cl->length)
1307 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1308 new_sym->ts.cl->backend_decl = se->string_length;
1312 /* Use the passed value as-is if the argument is a function. */
1313 if (sym->attr.flavor == FL_PROCEDURE)
1316 /* If the argument is either a string or a pointer to a string,
1317 convert it to a boundless character type. */
1318 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1320 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1321 tmp = build_pointer_type (tmp);
1322 if (sym->attr.pointer)
1323 tmp = build_pointer_type (tmp);
1325 value = fold_convert (tmp, se->expr);
1326 if (sym->attr.pointer)
1327 value = gfc_build_indirect_ref (value);
1330 /* If the argument is a scalar or a pointer to an array, dereference it. */
1331 else if (!sym->attr.dimension || sym->attr.pointer)
1332 value = gfc_build_indirect_ref (se->expr);
1334 /* If the argument is an array descriptor, use it to determine
1335 information about the actual argument's shape. */
1336 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1337 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1339 /* Get the actual argument's descriptor. */
1340 desc = gfc_build_indirect_ref (se->expr);
1342 /* Create the replacement variable. */
1343 tmp = gfc_conv_descriptor_data_get (desc);
1344 value = gfc_get_interface_mapping_array (&se->pre, sym, 0, tmp);
1346 /* Use DESC to work out the upper bounds, strides and offset. */
1347 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1350 /* Otherwise we have a packed array. */
1351 value = gfc_get_interface_mapping_array (&se->pre, sym, 2, se->expr);
1353 new_sym->backend_decl = value;
1357 /* Called once all dummy argument mappings have been added to MAPPING,
1358 but before the mapping is used to evaluate expressions. Pre-evaluate
1359 the length of each argument, adding any initialization code to PRE and
1360 any finalization code to POST. */
1363 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1364 stmtblock_t * pre, stmtblock_t * post)
1366 gfc_interface_sym_mapping *sym;
1370 for (sym = mapping->syms; sym; sym = sym->next)
1371 if (sym->new->n.sym->ts.type == BT_CHARACTER
1372 && !sym->new->n.sym->ts.cl->backend_decl)
1374 expr = sym->new->n.sym->ts.cl->length;
1375 gfc_apply_interface_mapping_to_expr (mapping, expr);
1376 gfc_init_se (&se, NULL);
1377 gfc_conv_expr (&se, expr);
1379 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1380 gfc_add_block_to_block (pre, &se.pre);
1381 gfc_add_block_to_block (post, &se.post);
1383 sym->new->n.sym->ts.cl->backend_decl = se.expr;
1388 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1392 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1393 gfc_constructor * c)
1395 for (; c; c = c->next)
1397 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1400 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1401 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1402 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1408 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1412 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1417 for (; ref; ref = ref->next)
1421 for (n = 0; n < ref->u.ar.dimen; n++)
1423 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1424 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1425 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1427 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1434 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1435 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1441 /* EXPR is a copy of an expression that appeared in the interface
1442 associated with MAPPING. Walk it recursively looking for references to
1443 dummy arguments that MAPPING maps to actual arguments. Replace each such
1444 reference with a reference to the associated actual argument. */
1447 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1450 gfc_interface_sym_mapping *sym;
1451 gfc_actual_arglist *actual;
1456 /* Copying an expression does not copy its length, so do that here. */
1457 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1459 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1460 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1463 /* Apply the mapping to any references. */
1464 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1466 /* ...and to the expression's symbol, if it has one. */
1468 for (sym = mapping->syms; sym; sym = sym->next)
1469 if (sym->old == expr->symtree->n.sym)
1470 expr->symtree = sym->new;
1472 /* ...and to subexpressions in expr->value. */
1473 switch (expr->expr_type)
1478 case EXPR_SUBSTRING:
1482 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1483 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1487 for (sym = mapping->syms; sym; sym = sym->next)
1488 if (sym->old == expr->value.function.esym)
1489 expr->value.function.esym = sym->new->n.sym;
1491 for (actual = expr->value.function.actual; actual; actual = actual->next)
1492 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1496 case EXPR_STRUCTURE:
1497 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1503 /* Evaluate interface expression EXPR using MAPPING. Store the result
1507 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1508 gfc_se * se, gfc_expr * expr)
1510 expr = gfc_copy_expr (expr);
1511 gfc_apply_interface_mapping_to_expr (mapping, expr);
1512 gfc_conv_expr (se, expr);
1513 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1514 gfc_free_expr (expr);
1518 /* Generate code for a procedure call. Note can return se->post != NULL.
1519 If se->direct_byref is set then se->expr contains the return parameter.
1520 Return nonzero, if the call has alternate specifiers. */
1523 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
1524 gfc_actual_arglist * arg)
1526 gfc_interface_mapping mapping;
1539 gfc_formal_arglist *formal;
1540 int has_alternate_specifier = 0;
1541 bool need_interface_mapping;
1545 arglist = NULL_TREE;
1546 retargs = NULL_TREE;
1547 stringargs = NULL_TREE;
1553 if (!sym->attr.elemental)
1555 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
1556 if (se->ss->useflags)
1558 gcc_assert (gfc_return_by_reference (sym)
1559 && sym->result->attr.dimension);
1560 gcc_assert (se->loop != NULL);
1562 /* Access the previously obtained result. */
1563 gfc_conv_tmp_array_ref (se);
1564 gfc_advance_se_ss_chain (se);
1568 info = &se->ss->data.info;
1573 gfc_init_interface_mapping (&mapping);
1574 need_interface_mapping = (sym->ts.type == BT_CHARACTER
1575 && sym->ts.cl->length->expr_type != EXPR_CONSTANT);
1576 formal = sym->formal;
1577 /* Evaluate the arguments. */
1578 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
1580 if (arg->expr == NULL)
1583 if (se->ignore_optional)
1585 /* Some intrinsics have already been resolved to the correct
1589 else if (arg->label)
1591 has_alternate_specifier = 1;
1596 /* Pass a NULL pointer for an absent arg. */
1597 gfc_init_se (&parmse, NULL);
1598 parmse.expr = null_pointer_node;
1599 if (arg->missing_arg_type == BT_CHARACTER)
1600 parmse.string_length = convert (gfc_charlen_type_node,
1604 else if (se->ss && se->ss->useflags)
1606 /* An elemental function inside a scalarized loop. */
1607 gfc_init_se (&parmse, se);
1608 gfc_conv_expr_reference (&parmse, arg->expr);
1612 /* A scalar or transformational function. */
1613 gfc_init_se (&parmse, NULL);
1614 argss = gfc_walk_expr (arg->expr);
1616 if (argss == gfc_ss_terminator)
1618 gfc_conv_expr_reference (&parmse, arg->expr);
1619 if (formal && formal->sym->attr.pointer
1620 && arg->expr->expr_type != EXPR_NULL)
1622 /* Scalar pointer dummy args require an extra level of
1623 indirection. The null pointer already contains
1624 this level of indirection. */
1625 parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
1630 /* If the procedure requires an explicit interface, the
1631 actual argument is passed according to the
1632 corresponding formal argument. If the corresponding
1633 formal argument is a POINTER or assumed shape, we do
1634 not use g77's calling convention, and pass the
1635 address of the array descriptor instead. Otherwise we
1636 use g77's calling convention. */
1638 f = (formal != NULL)
1639 && !formal->sym->attr.pointer
1640 && formal->sym->as->type != AS_ASSUMED_SHAPE;
1641 f = f || !sym->attr.always_explicit;
1642 gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
1646 if (formal && need_interface_mapping)
1647 gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
1649 gfc_add_block_to_block (&se->pre, &parmse.pre);
1650 gfc_add_block_to_block (&se->post, &parmse.post);
1652 /* Character strings are passed as two parameters, a length and a
1654 if (parmse.string_length != NULL_TREE)
1655 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
1657 arglist = gfc_chainon_list (arglist, parmse.expr);
1659 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
1662 if (ts.type == BT_CHARACTER)
1664 /* Calculate the length of the returned string. */
1665 gfc_init_se (&parmse, NULL);
1666 if (need_interface_mapping)
1667 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
1669 gfc_conv_expr (&parmse, sym->ts.cl->length);
1670 gfc_add_block_to_block (&se->pre, &parmse.pre);
1671 gfc_add_block_to_block (&se->post, &parmse.post);
1673 /* Set up a charlen structure for it. */
1676 cl.backend_decl = fold_convert (gfc_charlen_type_node, parmse.expr);
1679 len = cl.backend_decl;
1681 gfc_free_interface_mapping (&mapping);
1683 byref = gfc_return_by_reference (sym);
1686 if (se->direct_byref)
1687 retargs = gfc_chainon_list (retargs, se->expr);
1688 else if (sym->result->attr.dimension)
1690 gcc_assert (se->loop && info);
1692 /* Set the type of the array. */
1693 tmp = gfc_typenode_for_spec (&ts);
1694 info->dimen = se->loop->dimen;
1696 /* Allocate a temporary to store the result. */
1697 gfc_trans_allocate_temp_array (se->loop, info, tmp);
1699 /* Zero the first stride to indicate a temporary. */
1700 tmp = gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
1701 gfc_add_modify_expr (&se->pre, tmp,
1702 convert (TREE_TYPE (tmp), integer_zero_node));
1704 /* Pass the temporary as the first argument. */
1705 tmp = info->descriptor;
1706 tmp = gfc_build_addr_expr (NULL, tmp);
1707 retargs = gfc_chainon_list (retargs, tmp);
1709 else if (ts.type == BT_CHARACTER)
1711 /* Pass the string length. */
1712 type = gfc_get_character_type (ts.kind, ts.cl);
1713 type = build_pointer_type (type);
1715 /* Return an address to a char[0:len-1]* temporary for
1716 character pointers. */
1717 if (sym->attr.pointer || sym->attr.allocatable)
1719 /* Build char[0:len-1] * pstr. */
1720 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
1721 build_int_cst (gfc_charlen_type_node, 1));
1722 tmp = build_range_type (gfc_array_index_type,
1723 gfc_index_zero_node, tmp);
1724 tmp = build_array_type (gfc_character1_type_node, tmp);
1725 var = gfc_create_var (build_pointer_type (tmp), "pstr");
1727 /* Provide an address expression for the function arguments. */
1728 var = gfc_build_addr_expr (NULL, var);
1731 var = gfc_conv_string_tmp (se, type, len);
1733 retargs = gfc_chainon_list (retargs, var);
1737 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
1739 type = gfc_get_complex_type (ts.kind);
1740 var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
1741 retargs = gfc_chainon_list (retargs, var);
1744 /* Add the string length to the argument list. */
1745 if (ts.type == BT_CHARACTER)
1746 retargs = gfc_chainon_list (retargs, len);
1749 /* Add the return arguments. */
1750 arglist = chainon (retargs, arglist);
1752 /* Add the hidden string length parameters to the arguments. */
1753 arglist = chainon (arglist, stringargs);
1755 /* Generate the actual call. */
1756 gfc_conv_function_val (se, sym);
1757 /* If there are alternate return labels, function type should be
1758 integer. Can't modify the type in place though, since it can be shared
1759 with other functions. */
1760 if (has_alternate_specifier
1761 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
1763 gcc_assert (! sym->attr.dummy);
1764 TREE_TYPE (sym->backend_decl)
1765 = build_function_type (integer_type_node,
1766 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
1767 se->expr = gfc_build_addr_expr (NULL, sym->backend_decl);
1770 fntype = TREE_TYPE (TREE_TYPE (se->expr));
1771 se->expr = build3 (CALL_EXPR, TREE_TYPE (fntype), se->expr,
1772 arglist, NULL_TREE);
1774 /* If we have a pointer function, but we don't want a pointer, e.g.
1777 where f is pointer valued, we have to dereference the result. */
1778 if (!se->want_pointer && !byref && sym->attr.pointer)
1779 se->expr = gfc_build_indirect_ref (se->expr);
1781 /* f2c calling conventions require a scalar default real function to
1782 return a double precision result. Convert this back to default
1783 real. We only care about the cases that can happen in Fortran 77.
1785 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
1786 && sym->ts.kind == gfc_default_real_kind
1787 && !sym->attr.always_explicit)
1788 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
1790 /* A pure function may still have side-effects - it may modify its
1792 TREE_SIDE_EFFECTS (se->expr) = 1;
1794 if (!sym->attr.pure)
1795 TREE_SIDE_EFFECTS (se->expr) = 1;
1800 /* Add the function call to the pre chain. There is no expression. */
1801 gfc_add_expr_to_block (&se->pre, se->expr);
1802 se->expr = NULL_TREE;
1804 if (!se->direct_byref)
1806 if (sym->attr.dimension)
1808 if (flag_bounds_check)
1810 /* Check the data pointer hasn't been modified. This would
1811 happen in a function returning a pointer. */
1812 tmp = gfc_conv_descriptor_data_get (info->descriptor);
1813 tmp = build2 (NE_EXPR, boolean_type_node, tmp, info->data);
1814 gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
1816 se->expr = info->descriptor;
1817 /* Bundle in the string length. */
1818 se->string_length = len;
1820 else if (sym->ts.type == BT_CHARACTER)
1822 /* Dereference for character pointer results. */
1823 if (sym->attr.pointer || sym->attr.allocatable)
1824 se->expr = gfc_build_indirect_ref (var);
1828 se->string_length = len;
1832 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
1833 se->expr = gfc_build_indirect_ref (var);
1838 return has_alternate_specifier;
1842 /* Generate code to copy a string. */
1845 gfc_trans_string_copy (stmtblock_t * block, tree dlen, tree dest,
1846 tree slen, tree src)
1851 tmp = gfc_chainon_list (tmp, dlen);
1852 tmp = gfc_chainon_list (tmp, dest);
1853 tmp = gfc_chainon_list (tmp, slen);
1854 tmp = gfc_chainon_list (tmp, src);
1855 tmp = gfc_build_function_call (gfor_fndecl_copy_string, tmp);
1856 gfc_add_expr_to_block (block, tmp);
1860 /* Translate a statement function.
1861 The value of a statement function reference is obtained by evaluating the
1862 expression using the values of the actual arguments for the values of the
1863 corresponding dummy arguments. */
1866 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
1870 gfc_formal_arglist *fargs;
1871 gfc_actual_arglist *args;
1874 gfc_saved_var *saved_vars;
1880 sym = expr->symtree->n.sym;
1881 args = expr->value.function.actual;
1882 gfc_init_se (&lse, NULL);
1883 gfc_init_se (&rse, NULL);
1886 for (fargs = sym->formal; fargs; fargs = fargs->next)
1888 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
1889 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
1891 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1893 /* Each dummy shall be specified, explicitly or implicitly, to be
1895 gcc_assert (fargs->sym->attr.dimension == 0);
1898 /* Create a temporary to hold the value. */
1899 type = gfc_typenode_for_spec (&fsym->ts);
1900 temp_vars[n] = gfc_create_var (type, fsym->name);
1902 if (fsym->ts.type == BT_CHARACTER)
1904 /* Copy string arguments. */
1907 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
1908 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
1910 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1911 tmp = gfc_build_addr_expr (build_pointer_type (type),
1914 gfc_conv_expr (&rse, args->expr);
1915 gfc_conv_string_parameter (&rse);
1916 gfc_add_block_to_block (&se->pre, &lse.pre);
1917 gfc_add_block_to_block (&se->pre, &rse.pre);
1919 gfc_trans_string_copy (&se->pre, arglen, tmp, rse.string_length,
1921 gfc_add_block_to_block (&se->pre, &lse.post);
1922 gfc_add_block_to_block (&se->pre, &rse.post);
1926 /* For everything else, just evaluate the expression. */
1927 gfc_conv_expr (&lse, args->expr);
1929 gfc_add_block_to_block (&se->pre, &lse.pre);
1930 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
1931 gfc_add_block_to_block (&se->pre, &lse.post);
1937 /* Use the temporary variables in place of the real ones. */
1938 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1939 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
1941 gfc_conv_expr (se, sym->value);
1943 if (sym->ts.type == BT_CHARACTER)
1945 gfc_conv_const_charlen (sym->ts.cl);
1947 /* Force the expression to the correct length. */
1948 if (!INTEGER_CST_P (se->string_length)
1949 || tree_int_cst_lt (se->string_length,
1950 sym->ts.cl->backend_decl))
1952 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
1953 tmp = gfc_create_var (type, sym->name);
1954 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
1955 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
1956 se->string_length, se->expr);
1959 se->string_length = sym->ts.cl->backend_decl;
1962 /* Restore the original variables. */
1963 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
1964 gfc_restore_sym (fargs->sym, &saved_vars[n]);
1965 gfc_free (saved_vars);
1969 /* Translate a function expression. */
1972 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
1976 if (expr->value.function.isym)
1978 gfc_conv_intrinsic_function (se, expr);
1982 /* We distinguish statement functions from general functions to improve
1983 runtime performance. */
1984 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
1986 gfc_conv_statement_function (se, expr);
1990 /* expr.value.function.esym is the resolved (specific) function symbol for
1991 most functions. However this isn't set for dummy procedures. */
1992 sym = expr->value.function.esym;
1994 sym = expr->symtree->n.sym;
1995 gfc_conv_function_call (se, sym, expr->value.function.actual);
2000 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
2002 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
2003 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
2005 gfc_conv_tmp_array_ref (se);
2006 gfc_advance_se_ss_chain (se);
2010 /* Build a static initializer. EXPR is the expression for the initial value.
2011 The other parameters describe the variable of the component being
2012 initialized. EXPR may be null. */
2015 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
2016 bool array, bool pointer)
2020 if (!(expr || pointer))
2025 /* Arrays need special handling. */
2027 return gfc_build_null_descriptor (type);
2029 return gfc_conv_array_initializer (type, expr);
2032 return fold_convert (type, null_pointer_node);
2038 gfc_init_se (&se, NULL);
2039 gfc_conv_structure (&se, expr, 1);
2043 return gfc_conv_string_init (ts->cl->backend_decl,expr);
2046 gfc_init_se (&se, NULL);
2047 gfc_conv_constant (&se, expr);
2054 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2066 gfc_start_block (&block);
2068 /* Initialize the scalarizer. */
2069 gfc_init_loopinfo (&loop);
2071 gfc_init_se (&lse, NULL);
2072 gfc_init_se (&rse, NULL);
2075 rss = gfc_walk_expr (expr);
2076 if (rss == gfc_ss_terminator)
2078 /* The rhs is scalar. Add a ss for the expression. */
2079 rss = gfc_get_ss ();
2080 rss->next = gfc_ss_terminator;
2081 rss->type = GFC_SS_SCALAR;
2085 /* Create a SS for the destination. */
2086 lss = gfc_get_ss ();
2087 lss->type = GFC_SS_COMPONENT;
2089 lss->shape = gfc_get_shape (cm->as->rank);
2090 lss->next = gfc_ss_terminator;
2091 lss->data.info.dimen = cm->as->rank;
2092 lss->data.info.descriptor = dest;
2093 lss->data.info.data = gfc_conv_array_data (dest);
2094 lss->data.info.offset = gfc_conv_array_offset (dest);
2095 for (n = 0; n < cm->as->rank; n++)
2097 lss->data.info.dim[n] = n;
2098 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
2099 lss->data.info.stride[n] = gfc_index_one_node;
2101 mpz_init (lss->shape[n]);
2102 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
2103 cm->as->lower[n]->value.integer);
2104 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
2107 /* Associate the SS with the loop. */
2108 gfc_add_ss_to_loop (&loop, lss);
2109 gfc_add_ss_to_loop (&loop, rss);
2111 /* Calculate the bounds of the scalarization. */
2112 gfc_conv_ss_startstride (&loop);
2114 /* Setup the scalarizing loops. */
2115 gfc_conv_loop_setup (&loop);
2117 /* Setup the gfc_se structures. */
2118 gfc_copy_loopinfo_to_se (&lse, &loop);
2119 gfc_copy_loopinfo_to_se (&rse, &loop);
2122 gfc_mark_ss_chain_used (rss, 1);
2124 gfc_mark_ss_chain_used (lss, 1);
2126 /* Start the scalarized loop body. */
2127 gfc_start_scalarized_body (&loop, &body);
2129 gfc_conv_tmp_array_ref (&lse);
2130 if (cm->ts.type == BT_CHARACTER)
2131 lse.string_length = cm->ts.cl->backend_decl;
2133 gfc_conv_expr (&rse, expr);
2135 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);
2136 gfc_add_expr_to_block (&body, tmp);
2138 gcc_assert (rse.ss == gfc_ss_terminator);
2140 /* Generate the copying loops. */
2141 gfc_trans_scalarizing_loops (&loop, &body);
2143 /* Wrap the whole thing up. */
2144 gfc_add_block_to_block (&block, &loop.pre);
2145 gfc_add_block_to_block (&block, &loop.post);
2147 for (n = 0; n < cm->as->rank; n++)
2148 mpz_clear (lss->shape[n]);
2149 gfc_free (lss->shape);
2151 gfc_cleanup_loop (&loop);
2153 return gfc_finish_block (&block);
2156 /* Assign a single component of a derived type constructor. */
2159 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
2166 gfc_start_block (&block);
2169 gfc_init_se (&se, NULL);
2170 /* Pointer component. */
2173 /* Array pointer. */
2174 if (expr->expr_type == EXPR_NULL)
2175 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
2178 rss = gfc_walk_expr (expr);
2179 se.direct_byref = 1;
2181 gfc_conv_expr_descriptor (&se, expr, rss);
2182 gfc_add_block_to_block (&block, &se.pre);
2183 gfc_add_block_to_block (&block, &se.post);
2188 /* Scalar pointers. */
2189 se.want_pointer = 1;
2190 gfc_conv_expr (&se, expr);
2191 gfc_add_block_to_block (&block, &se.pre);
2192 gfc_add_modify_expr (&block, dest,
2193 fold_convert (TREE_TYPE (dest), se.expr));
2194 gfc_add_block_to_block (&block, &se.post);
2197 else if (cm->dimension)
2199 tmp = gfc_trans_subarray_assign (dest, cm, expr);
2200 gfc_add_expr_to_block (&block, tmp);
2202 else if (expr->ts.type == BT_DERIVED)
2204 /* Nested derived type. */
2205 tmp = gfc_trans_structure_assign (dest, expr);
2206 gfc_add_expr_to_block (&block, tmp);
2210 /* Scalar component. */
2213 gfc_init_se (&se, NULL);
2214 gfc_init_se (&lse, NULL);
2216 gfc_conv_expr (&se, expr);
2217 if (cm->ts.type == BT_CHARACTER)
2218 lse.string_length = cm->ts.cl->backend_decl;
2220 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts.type);
2221 gfc_add_expr_to_block (&block, tmp);
2223 return gfc_finish_block (&block);
2226 /* Assign a derived type constructor to a variable. */
2229 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
2237 gfc_start_block (&block);
2238 cm = expr->ts.derived->components;
2239 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2241 /* Skip absent members in default initializers. */
2245 field = cm->backend_decl;
2246 tmp = build3 (COMPONENT_REF, TREE_TYPE (field), dest, field, NULL_TREE);
2247 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
2248 gfc_add_expr_to_block (&block, tmp);
2250 return gfc_finish_block (&block);
2253 /* Build an expression for a constructor. If init is nonzero then
2254 this is part of a static variable initializer. */
2257 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
2264 VEC(constructor_elt,gc) *v = NULL;
2266 gcc_assert (se->ss == NULL);
2267 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
2268 type = gfc_typenode_for_spec (&expr->ts);
2272 /* Create a temporary variable and fill it in. */
2273 se->expr = gfc_create_var (type, expr->ts.derived->name);
2274 tmp = gfc_trans_structure_assign (se->expr, expr);
2275 gfc_add_expr_to_block (&se->pre, tmp);
2279 cm = expr->ts.derived->components;
2280 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
2282 /* Skip absent members in default initializers. */
2286 val = gfc_conv_initializer (c->expr, &cm->ts,
2287 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
2289 /* Append it to the constructor list. */
2290 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
2292 se->expr = build_constructor (type, v);
2296 /* Translate a substring expression. */
2299 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
2305 gcc_assert (ref->type == REF_SUBSTRING);
2307 se->expr = gfc_build_string_const(expr->value.character.length,
2308 expr->value.character.string);
2309 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
2310 TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1;
2312 gfc_conv_substring(se,ref,expr->ts.kind);
2316 /* Entry point for expression translation. Evaluates a scalar quantity.
2317 EXPR is the expression to be translated, and SE is the state structure if
2318 called from within the scalarized. */
2321 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
2323 if (se->ss && se->ss->expr == expr
2324 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
2326 /* Substitute a scalar expression evaluated outside the scalarization
2328 se->expr = se->ss->data.scalar.expr;
2329 se->string_length = se->ss->string_length;
2330 gfc_advance_se_ss_chain (se);
2334 switch (expr->expr_type)
2337 gfc_conv_expr_op (se, expr);
2341 gfc_conv_function_expr (se, expr);
2345 gfc_conv_constant (se, expr);
2349 gfc_conv_variable (se, expr);
2353 se->expr = null_pointer_node;
2356 case EXPR_SUBSTRING:
2357 gfc_conv_substring_expr (se, expr);
2360 case EXPR_STRUCTURE:
2361 gfc_conv_structure (se, expr, 0);
2365 gfc_conv_array_constructor_expr (se, expr);
2374 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
2375 of an assignment. */
2377 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
2379 gfc_conv_expr (se, expr);
2380 /* All numeric lvalues should have empty post chains. If not we need to
2381 figure out a way of rewriting an lvalue so that it has no post chain. */
2382 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
2385 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
2386 numeric expressions. Used for scalar values whee inserting cleanup code
2389 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
2393 gcc_assert (expr->ts.type != BT_CHARACTER);
2394 gfc_conv_expr (se, expr);
2397 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
2398 gfc_add_modify_expr (&se->pre, val, se->expr);
2400 gfc_add_block_to_block (&se->pre, &se->post);
2404 /* Helper to translate and expression and convert it to a particular type. */
2406 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
2408 gfc_conv_expr_val (se, expr);
2409 se->expr = convert (type, se->expr);
2413 /* Converts an expression so that it can be passed by reference. Scalar
2417 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
2421 if (se->ss && se->ss->expr == expr
2422 && se->ss->type == GFC_SS_REFERENCE)
2424 se->expr = se->ss->data.scalar.expr;
2425 se->string_length = se->ss->string_length;
2426 gfc_advance_se_ss_chain (se);
2430 if (expr->ts.type == BT_CHARACTER)
2432 gfc_conv_expr (se, expr);
2433 gfc_conv_string_parameter (se);
2437 if (expr->expr_type == EXPR_VARIABLE)
2439 se->want_pointer = 1;
2440 gfc_conv_expr (se, expr);
2443 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2444 gfc_add_modify_expr (&se->pre, var, se->expr);
2445 gfc_add_block_to_block (&se->pre, &se->post);
2451 gfc_conv_expr (se, expr);
2453 /* Create a temporary var to hold the value. */
2454 if (TREE_CONSTANT (se->expr))
2456 var = build_decl (CONST_DECL, NULL, TREE_TYPE (se->expr));
2457 DECL_INITIAL (var) = se->expr;
2462 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
2463 gfc_add_modify_expr (&se->pre, var, se->expr);
2465 gfc_add_block_to_block (&se->pre, &se->post);
2467 /* Take the address of that value. */
2468 se->expr = gfc_build_addr_expr (NULL, var);
2473 gfc_trans_pointer_assign (gfc_code * code)
2475 return gfc_trans_pointer_assignment (code->expr, code->expr2);
2479 /* Generate code for a pointer assignment. */
2482 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
2492 gfc_start_block (&block);
2494 gfc_init_se (&lse, NULL);
2496 lss = gfc_walk_expr (expr1);
2497 rss = gfc_walk_expr (expr2);
2498 if (lss == gfc_ss_terminator)
2500 /* Scalar pointers. */
2501 lse.want_pointer = 1;
2502 gfc_conv_expr (&lse, expr1);
2503 gcc_assert (rss == gfc_ss_terminator);
2504 gfc_init_se (&rse, NULL);
2505 rse.want_pointer = 1;
2506 gfc_conv_expr (&rse, expr2);
2507 gfc_add_block_to_block (&block, &lse.pre);
2508 gfc_add_block_to_block (&block, &rse.pre);
2509 gfc_add_modify_expr (&block, lse.expr,
2510 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2511 gfc_add_block_to_block (&block, &rse.post);
2512 gfc_add_block_to_block (&block, &lse.post);
2516 /* Array pointer. */
2517 gfc_conv_expr_descriptor (&lse, expr1, lss);
2518 switch (expr2->expr_type)
2521 /* Just set the data pointer to null. */
2522 gfc_conv_descriptor_data_set (&block, lse.expr, null_pointer_node);
2526 /* Assign directly to the pointer's descriptor. */
2527 lse.direct_byref = 1;
2528 gfc_conv_expr_descriptor (&lse, expr2, rss);
2532 /* Assign to a temporary descriptor and then copy that
2533 temporary to the pointer. */
2535 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
2538 lse.direct_byref = 1;
2539 gfc_conv_expr_descriptor (&lse, expr2, rss);
2540 gfc_add_modify_expr (&lse.pre, desc, tmp);
2543 gfc_add_block_to_block (&block, &lse.pre);
2544 gfc_add_block_to_block (&block, &lse.post);
2546 return gfc_finish_block (&block);
2550 /* Makes sure se is suitable for passing as a function string parameter. */
2551 /* TODO: Need to check all callers fo this function. It may be abused. */
2554 gfc_conv_string_parameter (gfc_se * se)
2558 if (TREE_CODE (se->expr) == STRING_CST)
2560 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2564 type = TREE_TYPE (se->expr);
2565 if (TYPE_STRING_FLAG (type))
2567 gcc_assert (TREE_CODE (se->expr) != INDIRECT_REF);
2568 se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
2571 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
2572 gcc_assert (se->string_length
2573 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
2577 /* Generate code for assignment of scalar variables. Includes character
2581 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type)
2585 gfc_init_block (&block);
2587 if (type == BT_CHARACTER)
2589 gcc_assert (lse->string_length != NULL_TREE
2590 && rse->string_length != NULL_TREE);
2592 gfc_conv_string_parameter (lse);
2593 gfc_conv_string_parameter (rse);
2595 gfc_add_block_to_block (&block, &lse->pre);
2596 gfc_add_block_to_block (&block, &rse->pre);
2598 gfc_trans_string_copy (&block, lse->string_length, lse->expr,
2599 rse->string_length, rse->expr);
2603 gfc_add_block_to_block (&block, &lse->pre);
2604 gfc_add_block_to_block (&block, &rse->pre);
2606 gfc_add_modify_expr (&block, lse->expr,
2607 fold_convert (TREE_TYPE (lse->expr), rse->expr));
2610 gfc_add_block_to_block (&block, &lse->post);
2611 gfc_add_block_to_block (&block, &rse->post);
2613 return gfc_finish_block (&block);
2617 /* Try to translate array(:) = func (...), where func is a transformational
2618 array function, without using a temporary. Returns NULL is this isn't the
2622 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
2627 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
2628 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
2631 /* Elemental functions don't need a temporary anyway. */
2632 if (expr2->symtree->n.sym->attr.elemental)
2635 /* Check for a dependency. */
2636 if (gfc_check_fncall_dependency (expr1, expr2))
2639 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
2641 gcc_assert (expr2->value.function.isym
2642 || (gfc_return_by_reference (expr2->value.function.esym)
2643 && expr2->value.function.esym->result->attr.dimension));
2645 ss = gfc_walk_expr (expr1);
2646 gcc_assert (ss != gfc_ss_terminator);
2647 gfc_init_se (&se, NULL);
2648 gfc_start_block (&se.pre);
2649 se.want_pointer = 1;
2651 gfc_conv_array_parameter (&se, expr1, ss, 0);
2653 se.direct_byref = 1;
2654 se.ss = gfc_walk_expr (expr2);
2655 gcc_assert (se.ss != gfc_ss_terminator);
2656 gfc_conv_function_expr (&se, expr2);
2657 gfc_add_block_to_block (&se.pre, &se.post);
2659 return gfc_finish_block (&se.pre);
2663 /* Translate an assignment. Most of the code is concerned with
2664 setting up the scalarizer. */
2667 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
2672 gfc_ss *lss_section;
2679 /* Special case a single function returning an array. */
2680 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2682 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2687 /* Assignment of the form lhs = rhs. */
2688 gfc_start_block (&block);
2690 gfc_init_se (&lse, NULL);
2691 gfc_init_se (&rse, NULL);
2694 lss = gfc_walk_expr (expr1);
2696 if (lss != gfc_ss_terminator)
2698 /* The assignment needs scalarization. */
2701 /* Find a non-scalar SS from the lhs. */
2702 while (lss_section != gfc_ss_terminator
2703 && lss_section->type != GFC_SS_SECTION)
2704 lss_section = lss_section->next;
2706 gcc_assert (lss_section != gfc_ss_terminator);
2708 /* Initialize the scalarizer. */
2709 gfc_init_loopinfo (&loop);
2712 rss = gfc_walk_expr (expr2);
2713 if (rss == gfc_ss_terminator)
2715 /* The rhs is scalar. Add a ss for the expression. */
2716 rss = gfc_get_ss ();
2717 rss->next = gfc_ss_terminator;
2718 rss->type = GFC_SS_SCALAR;
2721 /* Associate the SS with the loop. */
2722 gfc_add_ss_to_loop (&loop, lss);
2723 gfc_add_ss_to_loop (&loop, rss);
2725 /* Calculate the bounds of the scalarization. */
2726 gfc_conv_ss_startstride (&loop);
2727 /* Resolve any data dependencies in the statement. */
2728 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2729 /* Setup the scalarizing loops. */
2730 gfc_conv_loop_setup (&loop);
2732 /* Setup the gfc_se structures. */
2733 gfc_copy_loopinfo_to_se (&lse, &loop);
2734 gfc_copy_loopinfo_to_se (&rse, &loop);
2737 gfc_mark_ss_chain_used (rss, 1);
2738 if (loop.temp_ss == NULL)
2741 gfc_mark_ss_chain_used (lss, 1);
2745 lse.ss = loop.temp_ss;
2746 gfc_mark_ss_chain_used (lss, 3);
2747 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2750 /* Start the scalarized loop body. */
2751 gfc_start_scalarized_body (&loop, &body);
2754 gfc_init_block (&body);
2756 /* Translate the expression. */
2757 gfc_conv_expr (&rse, expr2);
2759 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2761 gfc_conv_tmp_array_ref (&lse);
2762 gfc_advance_se_ss_chain (&lse);
2765 gfc_conv_expr (&lse, expr1);
2767 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2768 gfc_add_expr_to_block (&body, tmp);
2770 if (lss == gfc_ss_terminator)
2772 /* Use the scalar assignment as is. */
2773 gfc_add_block_to_block (&block, &body);
2777 gcc_assert (lse.ss == gfc_ss_terminator
2778 && rse.ss == gfc_ss_terminator);
2780 if (loop.temp_ss != NULL)
2782 gfc_trans_scalarized_loop_boundary (&loop, &body);
2784 /* We need to copy the temporary to the actual lhs. */
2785 gfc_init_se (&lse, NULL);
2786 gfc_init_se (&rse, NULL);
2787 gfc_copy_loopinfo_to_se (&lse, &loop);
2788 gfc_copy_loopinfo_to_se (&rse, &loop);
2790 rse.ss = loop.temp_ss;
2793 gfc_conv_tmp_array_ref (&rse);
2794 gfc_advance_se_ss_chain (&rse);
2795 gfc_conv_expr (&lse, expr1);
2797 gcc_assert (lse.ss == gfc_ss_terminator
2798 && rse.ss == gfc_ss_terminator);
2800 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2801 gfc_add_expr_to_block (&body, tmp);
2803 /* Generate the copying loops. */
2804 gfc_trans_scalarizing_loops (&loop, &body);
2806 /* Wrap the whole thing up. */
2807 gfc_add_block_to_block (&block, &loop.pre);
2808 gfc_add_block_to_block (&block, &loop.post);
2810 gfc_cleanup_loop (&loop);
2813 return gfc_finish_block (&block);
2817 gfc_trans_assign (gfc_code * code)
2819 return gfc_trans_assignment (code->expr, code->expr2);