1 /* Expression translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-expr.c-- generate GENERIC trees for gfc_expr. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
34 #include "langhooks.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
44 #include "dependency.h"
46 static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
47 static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
50 /* Copy the scalarization loop variables. */
53 gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src)
56 dest->loop = src->loop;
60 /* Initialize a simple expression holder.
62 Care must be taken when multiple se are created with the same parent.
63 The child se must be kept in sync. The easiest way is to delay creation
64 of a child se until after after the previous se has been translated. */
67 gfc_init_se (gfc_se * se, gfc_se * parent)
69 memset (se, 0, sizeof (gfc_se));
70 gfc_init_block (&se->pre);
71 gfc_init_block (&se->post);
76 gfc_copy_se_loopvars (se, parent);
80 /* Advances to the next SS in the chain. Use this rather than setting
81 se->ss = se->ss->next because all the parents needs to be kept in sync.
85 gfc_advance_se_ss_chain (gfc_se * se)
89 gcc_assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator);
92 /* Walk down the parent chain. */
95 /* Simple consistency check. */
96 gcc_assert (p->parent == NULL || p->parent->ss == p->ss);
105 /* Ensures the result of the expression as either a temporary variable
106 or a constant so that it can be used repeatedly. */
109 gfc_make_safe_expr (gfc_se * se)
113 if (CONSTANT_CLASS_P (se->expr))
116 /* We need a temporary for this result. */
117 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
118 gfc_add_modify_expr (&se->pre, var, se->expr);
123 /* Return an expression which determines if a dummy parameter is present.
124 Also used for arguments to procedures with multiple entry points. */
127 gfc_conv_expr_present (gfc_symbol * sym)
131 gcc_assert (sym->attr.dummy);
133 decl = gfc_get_symbol_decl (sym);
134 if (TREE_CODE (decl) != PARM_DECL)
136 /* Array parameters use a temporary descriptor, we want the real
138 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))
139 || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
140 decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
142 return fold_build2 (NE_EXPR, boolean_type_node, decl,
143 fold_convert (TREE_TYPE (decl), null_pointer_node));
147 /* Converts a missing, dummy argument into a null or zero. */
150 gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
155 present = gfc_conv_expr_present (arg->symtree->n.sym);
159 /* Create a temporary and convert it to the correct type. */
160 tmp = gfc_get_int_type (kind);
161 tmp = fold_convert (tmp, build_fold_indirect_ref (se->expr));
163 /* Test for a NULL value. */
164 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present, tmp, integer_one_node);
165 tmp = gfc_evaluate_now (tmp, &se->pre);
166 se->expr = build_fold_addr_expr (tmp);
170 tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
171 fold_convert (TREE_TYPE (se->expr), integer_zero_node));
172 tmp = gfc_evaluate_now (tmp, &se->pre);
176 if (ts.type == BT_CHARACTER)
178 tmp = build_int_cst (gfc_charlen_type_node, 0);
179 tmp = fold_build3 (COND_EXPR, gfc_charlen_type_node,
180 present, se->string_length, tmp);
181 tmp = gfc_evaluate_now (tmp, &se->pre);
182 se->string_length = tmp;
188 /* Get the character length of an expression, looking through gfc_refs
192 gfc_get_expr_charlen (gfc_expr *e)
197 gcc_assert (e->expr_type == EXPR_VARIABLE
198 && e->ts.type == BT_CHARACTER);
200 length = NULL; /* To silence compiler warning. */
202 if (is_subref_array (e) && e->ts.cl->length)
205 gfc_init_se (&tmpse, NULL);
206 gfc_conv_expr_type (&tmpse, e->ts.cl->length, gfc_charlen_type_node);
207 e->ts.cl->backend_decl = tmpse.expr;
211 /* First candidate: if the variable is of type CHARACTER, the
212 expression's length could be the length of the character
214 if (e->symtree->n.sym->ts.type == BT_CHARACTER)
215 length = e->symtree->n.sym->ts.cl->backend_decl;
217 /* Look through the reference chain for component references. */
218 for (r = e->ref; r; r = r->next)
223 if (r->u.c.component->ts.type == BT_CHARACTER)
224 length = r->u.c.component->ts.cl->backend_decl;
232 /* We should never got substring references here. These will be
233 broken down by the scalarizer. */
239 gcc_assert (length != NULL);
245 /* Generate code to initialize a string length variable. Returns the
249 gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
253 gfc_init_se (&se, NULL);
254 gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
255 se.expr = fold_build2 (MAX_EXPR, gfc_charlen_type_node, se.expr,
256 build_int_cst (gfc_charlen_type_node, 0));
257 gfc_add_block_to_block (pblock, &se.pre);
259 if (cl->backend_decl)
260 gfc_add_modify_expr (pblock, cl->backend_decl, se.expr);
262 cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
267 gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
268 const char *name, locus *where)
278 type = gfc_get_character_type (kind, ref->u.ss.length);
279 type = build_pointer_type (type);
282 gfc_init_se (&start, se);
283 gfc_conv_expr_type (&start, ref->u.ss.start, gfc_charlen_type_node);
284 gfc_add_block_to_block (&se->pre, &start.pre);
286 if (integer_onep (start.expr))
287 gfc_conv_string_parameter (se);
290 /* Avoid multiple evaluation of substring start. */
291 if (!CONSTANT_CLASS_P (start.expr) && !DECL_P (start.expr))
292 start.expr = gfc_evaluate_now (start.expr, &se->pre);
294 /* Change the start of the string. */
295 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
298 tmp = build_fold_indirect_ref (se->expr);
299 tmp = gfc_build_array_ref (tmp, start.expr, NULL);
300 se->expr = gfc_build_addr_expr (type, tmp);
303 /* Length = end + 1 - start. */
304 gfc_init_se (&end, se);
305 if (ref->u.ss.end == NULL)
306 end.expr = se->string_length;
309 gfc_conv_expr_type (&end, ref->u.ss.end, gfc_charlen_type_node);
310 gfc_add_block_to_block (&se->pre, &end.pre);
312 if (!CONSTANT_CLASS_P (end.expr) && !DECL_P (end.expr))
313 end.expr = gfc_evaluate_now (end.expr, &se->pre);
315 if (flag_bounds_check)
317 tree nonempty = fold_build2 (LE_EXPR, boolean_type_node,
318 start.expr, end.expr);
320 /* Check lower bound. */
321 fault = fold_build2 (LT_EXPR, boolean_type_node, start.expr,
322 build_int_cst (gfc_charlen_type_node, 1));
323 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
326 asprintf (&msg, "Substring out of bounds: lower bound (%%ld) of '%s' "
327 "is less than one", name);
329 asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
331 gfc_trans_runtime_check (fault, &se->pre, where, msg,
332 fold_convert (long_integer_type_node,
336 /* Check upper bound. */
337 fault = fold_build2 (GT_EXPR, boolean_type_node, end.expr,
339 fault = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node,
342 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) of '%s' "
343 "exceeds string length (%%ld)", name);
345 asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
346 "exceeds string length (%%ld)");
347 gfc_trans_runtime_check (fault, &se->pre, where, msg,
348 fold_convert (long_integer_type_node, end.expr),
349 fold_convert (long_integer_type_node,
354 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node,
355 build_int_cst (gfc_charlen_type_node, 1),
357 tmp = fold_build2 (PLUS_EXPR, gfc_charlen_type_node, end.expr, tmp);
358 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
359 build_int_cst (gfc_charlen_type_node, 0));
360 se->string_length = tmp;
364 /* Convert a derived type component reference. */
367 gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
374 c = ref->u.c.component;
376 gcc_assert (c->backend_decl);
378 field = c->backend_decl;
379 gcc_assert (TREE_CODE (field) == FIELD_DECL);
381 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), decl, field, NULL_TREE);
385 if (c->ts.type == BT_CHARACTER)
387 tmp = c->ts.cl->backend_decl;
388 /* Components must always be constant length. */
389 gcc_assert (tmp && INTEGER_CST_P (tmp));
390 se->string_length = tmp;
393 if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
394 se->expr = build_fold_indirect_ref (se->expr);
398 /* Return the contents of a variable. Also handles reference/pointer
399 variables (all Fortran pointer references are implicit). */
402 gfc_conv_variable (gfc_se * se, gfc_expr * expr)
409 bool alternate_entry;
412 sym = expr->symtree->n.sym;
415 /* Check that something hasn't gone horribly wrong. */
416 gcc_assert (se->ss != gfc_ss_terminator);
417 gcc_assert (se->ss->expr == expr);
419 /* A scalarized term. We already know the descriptor. */
420 se->expr = se->ss->data.info.descriptor;
421 se->string_length = se->ss->string_length;
422 for (ref = se->ss->data.info.ref; ref; ref = ref->next)
423 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
428 tree se_expr = NULL_TREE;
430 se->expr = gfc_get_symbol_decl (sym);
432 /* Deal with references to a parent results or entries by storing
433 the current_function_decl and moving to the parent_decl. */
434 return_value = sym->attr.function && sym->result == sym;
435 alternate_entry = sym->attr.function && sym->attr.entry
436 && sym->result == sym;
437 entry_master = sym->attr.result
438 && sym->ns->proc_name->attr.entry_master
439 && !gfc_return_by_reference (sym->ns->proc_name);
440 parent_decl = DECL_CONTEXT (current_function_decl);
442 if ((se->expr == parent_decl && return_value)
443 || (sym->ns && sym->ns->proc_name
445 && sym->ns->proc_name->backend_decl == parent_decl
446 && (alternate_entry || entry_master)))
451 /* Special case for assigning the return value of a function.
452 Self recursive functions must have an explicit return value. */
453 if (return_value && (se->expr == current_function_decl || parent_flag))
454 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
456 /* Similarly for alternate entry points. */
457 else if (alternate_entry
458 && (sym->ns->proc_name->backend_decl == current_function_decl
461 gfc_entry_list *el = NULL;
463 for (el = sym->ns->entries; el; el = el->next)
466 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
471 else if (entry_master
472 && (sym->ns->proc_name->backend_decl == current_function_decl
474 se_expr = gfc_get_fake_result_decl (sym, parent_flag);
479 /* Procedure actual arguments. */
480 else if (sym->attr.flavor == FL_PROCEDURE
481 && se->expr != current_function_decl)
483 if (!sym->attr.dummy && !sym->attr.proc_pointer)
485 gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
486 se->expr = build_fold_addr_expr (se->expr);
492 /* Dereference the expression, where needed. Since characters
493 are entirely different from other types, they are treated
495 if (sym->ts.type == BT_CHARACTER)
497 /* Dereference character pointer dummy arguments
499 if ((sym->attr.pointer || sym->attr.allocatable)
501 || sym->attr.function
502 || sym->attr.result))
503 se->expr = build_fold_indirect_ref (se->expr);
506 else if (!sym->attr.value)
508 /* Dereference non-character scalar dummy arguments. */
509 if (sym->attr.dummy && !sym->attr.dimension)
510 se->expr = build_fold_indirect_ref (se->expr);
512 /* Dereference scalar hidden result. */
513 if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
514 && (sym->attr.function || sym->attr.result)
515 && !sym->attr.dimension && !sym->attr.pointer
516 && !sym->attr.always_explicit)
517 se->expr = build_fold_indirect_ref (se->expr);
519 /* Dereference non-character pointer variables.
520 These must be dummies, results, or scalars. */
521 if ((sym->attr.pointer || sym->attr.allocatable)
523 || sym->attr.function
525 || !sym->attr.dimension))
526 se->expr = build_fold_indirect_ref (se->expr);
532 /* For character variables, also get the length. */
533 if (sym->ts.type == BT_CHARACTER)
535 /* If the character length of an entry isn't set, get the length from
536 the master function instead. */
537 if (sym->attr.entry && !sym->ts.cl->backend_decl)
538 se->string_length = sym->ns->proc_name->ts.cl->backend_decl;
540 se->string_length = sym->ts.cl->backend_decl;
541 gcc_assert (se->string_length);
549 /* Return the descriptor if that's what we want and this is an array
550 section reference. */
551 if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT)
553 /* TODO: Pointers to single elements of array sections, eg elemental subs. */
554 /* Return the descriptor for array pointers and allocations. */
556 && ref->next == NULL && (se->descriptor_only))
559 gfc_conv_array_ref (se, &ref->u.ar, sym, &expr->where);
560 /* Return a pointer to an element. */
564 gfc_conv_component_ref (se, ref);
568 gfc_conv_substring (se, ref, expr->ts.kind,
569 expr->symtree->name, &expr->where);
578 /* Pointer assignment, allocation or pass by reference. Arrays are handled
580 if (se->want_pointer)
582 if (expr->ts.type == BT_CHARACTER)
583 gfc_conv_string_parameter (se);
585 se->expr = build_fold_addr_expr (se->expr);
590 /* Unary ops are easy... Or they would be if ! was a valid op. */
593 gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr)
598 gcc_assert (expr->ts.type != BT_CHARACTER);
599 /* Initialize the operand. */
600 gfc_init_se (&operand, se);
601 gfc_conv_expr_val (&operand, expr->value.op.op1);
602 gfc_add_block_to_block (&se->pre, &operand.pre);
604 type = gfc_typenode_for_spec (&expr->ts);
606 /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC.
607 We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)).
608 All other unary operators have an equivalent GIMPLE unary operator. */
609 if (code == TRUTH_NOT_EXPR)
610 se->expr = fold_build2 (EQ_EXPR, type, operand.expr,
611 build_int_cst (type, 0));
613 se->expr = fold_build1 (code, type, operand.expr);
617 /* Expand power operator to optimal multiplications when a value is raised
618 to a constant integer n. See section 4.6.3, "Evaluation of Powers" of
619 Donald E. Knuth, "Seminumerical Algorithms", Vol. 2, "The Art of Computer
620 Programming", 3rd Edition, 1998. */
622 /* This code is mostly duplicated from expand_powi in the backend.
623 We establish the "optimal power tree" lookup table with the defined size.
624 The items in the table are the exponents used to calculate the index
625 exponents. Any integer n less than the value can get an "addition chain",
626 with the first node being one. */
627 #define POWI_TABLE_SIZE 256
629 /* The table is from builtins.c. */
630 static const unsigned char powi_table[POWI_TABLE_SIZE] =
632 0, 1, 1, 2, 2, 3, 3, 4, /* 0 - 7 */
633 4, 6, 5, 6, 6, 10, 7, 9, /* 8 - 15 */
634 8, 16, 9, 16, 10, 12, 11, 13, /* 16 - 23 */
635 12, 17, 13, 18, 14, 24, 15, 26, /* 24 - 31 */
636 16, 17, 17, 19, 18, 33, 19, 26, /* 32 - 39 */
637 20, 25, 21, 40, 22, 27, 23, 44, /* 40 - 47 */
638 24, 32, 25, 34, 26, 29, 27, 44, /* 48 - 55 */
639 28, 31, 29, 34, 30, 60, 31, 36, /* 56 - 63 */
640 32, 64, 33, 34, 34, 46, 35, 37, /* 64 - 71 */
641 36, 65, 37, 50, 38, 48, 39, 69, /* 72 - 79 */
642 40, 49, 41, 43, 42, 51, 43, 58, /* 80 - 87 */
643 44, 64, 45, 47, 46, 59, 47, 76, /* 88 - 95 */
644 48, 65, 49, 66, 50, 67, 51, 66, /* 96 - 103 */
645 52, 70, 53, 74, 54, 104, 55, 74, /* 104 - 111 */
646 56, 64, 57, 69, 58, 78, 59, 68, /* 112 - 119 */
647 60, 61, 61, 80, 62, 75, 63, 68, /* 120 - 127 */
648 64, 65, 65, 128, 66, 129, 67, 90, /* 128 - 135 */
649 68, 73, 69, 131, 70, 94, 71, 88, /* 136 - 143 */
650 72, 128, 73, 98, 74, 132, 75, 121, /* 144 - 151 */
651 76, 102, 77, 124, 78, 132, 79, 106, /* 152 - 159 */
652 80, 97, 81, 160, 82, 99, 83, 134, /* 160 - 167 */
653 84, 86, 85, 95, 86, 160, 87, 100, /* 168 - 175 */
654 88, 113, 89, 98, 90, 107, 91, 122, /* 176 - 183 */
655 92, 111, 93, 102, 94, 126, 95, 150, /* 184 - 191 */
656 96, 128, 97, 130, 98, 133, 99, 195, /* 192 - 199 */
657 100, 128, 101, 123, 102, 164, 103, 138, /* 200 - 207 */
658 104, 145, 105, 146, 106, 109, 107, 149, /* 208 - 215 */
659 108, 200, 109, 146, 110, 170, 111, 157, /* 216 - 223 */
660 112, 128, 113, 130, 114, 182, 115, 132, /* 224 - 231 */
661 116, 200, 117, 132, 118, 158, 119, 206, /* 232 - 239 */
662 120, 240, 121, 162, 122, 147, 123, 152, /* 240 - 247 */
663 124, 166, 125, 214, 126, 138, 127, 153, /* 248 - 255 */
666 /* If n is larger than lookup table's max index, we use the "window
668 #define POWI_WINDOW_SIZE 3
670 /* Recursive function to expand the power operator. The temporary
671 values are put in tmpvar. The function returns tmpvar[1] ** n. */
673 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
680 if (n < POWI_TABLE_SIZE)
685 op0 = gfc_conv_powi (se, n - powi_table[n], tmpvar);
686 op1 = gfc_conv_powi (se, powi_table[n], tmpvar);
690 digit = n & ((1 << POWI_WINDOW_SIZE) - 1);
691 op0 = gfc_conv_powi (se, n - digit, tmpvar);
692 op1 = gfc_conv_powi (se, digit, tmpvar);
696 op0 = gfc_conv_powi (se, n >> 1, tmpvar);
700 tmp = fold_build2 (MULT_EXPR, TREE_TYPE (op0), op0, op1);
701 tmp = gfc_evaluate_now (tmp, &se->pre);
703 if (n < POWI_TABLE_SIZE)
710 /* Expand lhs ** rhs. rhs is a constant integer. If it expands successfully,
711 return 1. Else return 0 and a call to runtime library functions
712 will have to be built. */
714 gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
719 tree vartmp[POWI_TABLE_SIZE];
721 unsigned HOST_WIDE_INT n;
724 /* If exponent is too large, we won't expand it anyway, so don't bother
725 with large integer values. */
726 if (!double_int_fits_in_shwi_p (TREE_INT_CST (rhs)))
729 m = double_int_to_shwi (TREE_INT_CST (rhs));
730 /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
731 of the asymmetric range of the integer type. */
732 n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
734 type = TREE_TYPE (lhs);
735 sgn = tree_int_cst_sgn (rhs);
737 if (((FLOAT_TYPE_P (type) && !flag_unsafe_math_optimizations)
738 || optimize_size) && (m > 2 || m < -1))
744 se->expr = gfc_build_const (type, integer_one_node);
748 /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */
749 if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE))
751 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
752 lhs, build_int_cst (TREE_TYPE (lhs), -1));
753 cond = fold_build2 (EQ_EXPR, boolean_type_node,
754 lhs, build_int_cst (TREE_TYPE (lhs), 1));
757 result = (lhs == 1 || lhs == -1) ? 1 : 0. */
760 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
761 se->expr = fold_build3 (COND_EXPR, type,
762 tmp, build_int_cst (type, 1),
763 build_int_cst (type, 0));
767 result = (lhs == 1) ? 1 : (lhs == -1) ? -1 : 0. */
768 tmp = fold_build3 (COND_EXPR, type, tmp, build_int_cst (type, -1),
769 build_int_cst (type, 0));
770 se->expr = fold_build3 (COND_EXPR, type,
771 cond, build_int_cst (type, 1), tmp);
775 memset (vartmp, 0, sizeof (vartmp));
779 tmp = gfc_build_const (type, integer_one_node);
780 vartmp[1] = fold_build2 (RDIV_EXPR, type, tmp, vartmp[1]);
783 se->expr = gfc_conv_powi (se, n, vartmp);
789 /* Power op (**). Constant integer exponent has special handling. */
792 gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
794 tree gfc_int4_type_node;
801 gfc_init_se (&lse, se);
802 gfc_conv_expr_val (&lse, expr->value.op.op1);
803 lse.expr = gfc_evaluate_now (lse.expr, &lse.pre);
804 gfc_add_block_to_block (&se->pre, &lse.pre);
806 gfc_init_se (&rse, se);
807 gfc_conv_expr_val (&rse, expr->value.op.op2);
808 gfc_add_block_to_block (&se->pre, &rse.pre);
810 if (expr->value.op.op2->ts.type == BT_INTEGER
811 && expr->value.op.op2->expr_type == EXPR_CONSTANT)
812 if (gfc_conv_cst_int_power (se, lse.expr, rse.expr))
815 gfc_int4_type_node = gfc_get_int_type (4);
817 kind = expr->value.op.op1->ts.kind;
818 switch (expr->value.op.op2->ts.type)
821 ikind = expr->value.op.op2->ts.kind;
826 rse.expr = convert (gfc_int4_type_node, rse.expr);
848 if (expr->value.op.op1->ts.type == BT_INTEGER)
849 lse.expr = convert (gfc_int4_type_node, lse.expr);
874 switch (expr->value.op.op1->ts.type)
877 if (kind == 3) /* Case 16 was not handled properly above. */
879 fndecl = gfor_fndecl_math_powi[kind][ikind].integer;
883 /* Use builtins for real ** int4. */
889 fndecl = built_in_decls[BUILT_IN_POWIF];
893 fndecl = built_in_decls[BUILT_IN_POWI];
898 fndecl = built_in_decls[BUILT_IN_POWIL];
906 fndecl = gfor_fndecl_math_powi[kind][ikind].real;
910 fndecl = gfor_fndecl_math_powi[kind][ikind].cmplx;
922 fndecl = built_in_decls[BUILT_IN_POWF];
925 fndecl = built_in_decls[BUILT_IN_POW];
929 fndecl = built_in_decls[BUILT_IN_POWL];
940 fndecl = built_in_decls[BUILT_IN_CPOWF];
943 fndecl = built_in_decls[BUILT_IN_CPOW];
947 fndecl = built_in_decls[BUILT_IN_CPOWL];
959 se->expr = build_call_expr (fndecl, 2, lse.expr, rse.expr);
963 /* Generate code to allocate a string temporary. */
966 gfc_conv_string_tmp (gfc_se * se, tree type, tree len)
971 gcc_assert (TREE_TYPE (len) == gfc_charlen_type_node);
973 if (gfc_can_put_var_on_stack (len))
975 /* Create a temporary variable to hold the result. */
976 tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
977 build_int_cst (gfc_charlen_type_node, 1));
978 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
980 if (TREE_CODE (TREE_TYPE (type)) == ARRAY_TYPE)
981 tmp = build_array_type (TREE_TYPE (TREE_TYPE (type)), tmp);
983 tmp = build_array_type (TREE_TYPE (type), tmp);
985 var = gfc_create_var (tmp, "str");
986 var = gfc_build_addr_expr (type, var);
990 /* Allocate a temporary to hold the result. */
991 var = gfc_create_var (type, "pstr");
992 tmp = gfc_call_malloc (&se->pre, type,
993 fold_build2 (MULT_EXPR, TREE_TYPE (len), len,
994 fold_convert (TREE_TYPE (len),
996 gfc_add_modify_expr (&se->pre, var, tmp);
998 /* Free the temporary afterwards. */
999 tmp = gfc_call_free (convert (pvoid_type_node, var));
1000 gfc_add_expr_to_block (&se->post, tmp);
1007 /* Handle a string concatenation operation. A temporary will be allocated to
1011 gfc_conv_concat_op (gfc_se * se, gfc_expr * expr)
1014 tree len, type, var, tmp, fndecl;
1016 gcc_assert (expr->value.op.op1->ts.type == BT_CHARACTER
1017 && expr->value.op.op2->ts.type == BT_CHARACTER);
1018 gcc_assert (expr->value.op.op1->ts.kind == expr->value.op.op2->ts.kind);
1020 gfc_init_se (&lse, se);
1021 gfc_conv_expr (&lse, expr->value.op.op1);
1022 gfc_conv_string_parameter (&lse);
1023 gfc_init_se (&rse, se);
1024 gfc_conv_expr (&rse, expr->value.op.op2);
1025 gfc_conv_string_parameter (&rse);
1027 gfc_add_block_to_block (&se->pre, &lse.pre);
1028 gfc_add_block_to_block (&se->pre, &rse.pre);
1030 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
1031 len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
1032 if (len == NULL_TREE)
1034 len = fold_build2 (PLUS_EXPR, TREE_TYPE (lse.string_length),
1035 lse.string_length, rse.string_length);
1038 type = build_pointer_type (type);
1040 var = gfc_conv_string_tmp (se, type, len);
1042 /* Do the actual concatenation. */
1043 if (expr->ts.kind == 1)
1044 fndecl = gfor_fndecl_concat_string;
1045 else if (expr->ts.kind == 4)
1046 fndecl = gfor_fndecl_concat_string_char4;
1050 tmp = build_call_expr (fndecl, 6, len, var, lse.string_length, lse.expr,
1051 rse.string_length, rse.expr);
1052 gfc_add_expr_to_block (&se->pre, tmp);
1054 /* Add the cleanup for the operands. */
1055 gfc_add_block_to_block (&se->pre, &rse.post);
1056 gfc_add_block_to_block (&se->pre, &lse.post);
1059 se->string_length = len;
1062 /* Translates an op expression. Common (binary) cases are handled by this
1063 function, others are passed on. Recursion is used in either case.
1064 We use the fact that (op1.ts == op2.ts) (except for the power
1066 Operators need no special handling for scalarized expressions as long as
1067 they call gfc_conv_simple_val to get their operands.
1068 Character strings get special handling. */
1071 gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
1073 enum tree_code code;
1082 switch (expr->value.op.op)
1084 case INTRINSIC_PARENTHESES:
1085 if (expr->ts.type == BT_REAL
1086 || expr->ts.type == BT_COMPLEX)
1088 gfc_conv_unary_op (PAREN_EXPR, se, expr);
1089 gcc_assert (FLOAT_TYPE_P (TREE_TYPE (se->expr)));
1094 case INTRINSIC_UPLUS:
1095 gfc_conv_expr (se, expr->value.op.op1);
1098 case INTRINSIC_UMINUS:
1099 gfc_conv_unary_op (NEGATE_EXPR, se, expr);
1103 gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr);
1106 case INTRINSIC_PLUS:
1110 case INTRINSIC_MINUS:
1114 case INTRINSIC_TIMES:
1118 case INTRINSIC_DIVIDE:
1119 /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is
1120 an integer, we must round towards zero, so we use a
1122 if (expr->ts.type == BT_INTEGER)
1123 code = TRUNC_DIV_EXPR;
1128 case INTRINSIC_POWER:
1129 gfc_conv_power_op (se, expr);
1132 case INTRINSIC_CONCAT:
1133 gfc_conv_concat_op (se, expr);
1137 code = TRUTH_ANDIF_EXPR;
1142 code = TRUTH_ORIF_EXPR;
1146 /* EQV and NEQV only work on logicals, but since we represent them
1147 as integers, we can use EQ_EXPR and NE_EXPR for them in GIMPLE. */
1149 case INTRINSIC_EQ_OS:
1157 case INTRINSIC_NE_OS:
1158 case INTRINSIC_NEQV:
1165 case INTRINSIC_GT_OS:
1172 case INTRINSIC_GE_OS:
1179 case INTRINSIC_LT_OS:
1186 case INTRINSIC_LE_OS:
1192 case INTRINSIC_USER:
1193 case INTRINSIC_ASSIGN:
1194 /* These should be converted into function calls by the frontend. */
1198 fatal_error ("Unknown intrinsic op");
1202 /* The only exception to this is **, which is handled separately anyway. */
1203 gcc_assert (expr->value.op.op1->ts.type == expr->value.op.op2->ts.type);
1205 if (checkstring && expr->value.op.op1->ts.type != BT_CHARACTER)
1209 gfc_init_se (&lse, se);
1210 gfc_conv_expr (&lse, expr->value.op.op1);
1211 gfc_add_block_to_block (&se->pre, &lse.pre);
1214 gfc_init_se (&rse, se);
1215 gfc_conv_expr (&rse, expr->value.op.op2);
1216 gfc_add_block_to_block (&se->pre, &rse.pre);
1220 gfc_conv_string_parameter (&lse);
1221 gfc_conv_string_parameter (&rse);
1223 lse.expr = gfc_build_compare_string (lse.string_length, lse.expr,
1224 rse.string_length, rse.expr,
1225 expr->value.op.op1->ts.kind);
1226 rse.expr = build_int_cst (TREE_TYPE (lse.expr), 0);
1227 gfc_add_block_to_block (&lse.post, &rse.post);
1230 type = gfc_typenode_for_spec (&expr->ts);
1234 /* The result of logical ops is always boolean_type_node. */
1235 tmp = fold_build2 (code, boolean_type_node, lse.expr, rse.expr);
1236 se->expr = convert (type, tmp);
1239 se->expr = fold_build2 (code, type, lse.expr, rse.expr);
1241 /* Add the post blocks. */
1242 gfc_add_block_to_block (&se->post, &rse.post);
1243 gfc_add_block_to_block (&se->post, &lse.post);
1246 /* If a string's length is one, we convert it to a single character. */
1249 string_to_single_character (tree len, tree str, int kind)
1251 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
1253 if (INTEGER_CST_P (len) && TREE_INT_CST_LOW (len) == 1
1254 && TREE_INT_CST_HIGH (len) == 0)
1256 str = fold_convert (gfc_get_pchar_type (kind), str);
1257 return build_fold_indirect_ref (str);
1265 gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
1268 if (sym->backend_decl)
1270 /* This becomes the nominal_type in
1271 function.c:assign_parm_find_data_types. */
1272 TREE_TYPE (sym->backend_decl) = unsigned_char_type_node;
1273 /* This becomes the passed_type in
1274 function.c:assign_parm_find_data_types. C promotes char to
1275 integer for argument passing. */
1276 DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node;
1278 DECL_BY_REFERENCE (sym->backend_decl) = 0;
1283 /* If we have a constant character expression, make it into an
1285 if ((*expr)->expr_type == EXPR_CONSTANT)
1290 *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
1291 if ((*expr)->ts.kind != gfc_c_int_kind)
1293 /* The expr needs to be compatible with a C int. If the
1294 conversion fails, then the 2 causes an ICE. */
1295 ts.type = BT_INTEGER;
1296 ts.kind = gfc_c_int_kind;
1297 gfc_convert_type (*expr, &ts, 2);
1300 else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE)
1302 if ((*expr)->ref == NULL)
1304 se->expr = string_to_single_character
1305 (build_int_cst (integer_type_node, 1),
1306 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1308 ((*expr)->symtree->n.sym)),
1313 gfc_conv_variable (se, *expr);
1314 se->expr = string_to_single_character
1315 (build_int_cst (integer_type_node, 1),
1316 gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind),
1325 /* Compare two strings. If they are all single characters, the result is the
1326 subtraction of them. Otherwise, we build a library call. */
1329 gfc_build_compare_string (tree len1, tree str1, tree len2, tree str2, int kind)
1335 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str1)));
1336 gcc_assert (POINTER_TYPE_P (TREE_TYPE (str2)));
1338 sc1 = string_to_single_character (len1, str1, kind);
1339 sc2 = string_to_single_character (len2, str2, kind);
1341 if (sc1 != NULL_TREE && sc2 != NULL_TREE)
1343 /* Deal with single character specially. */
1344 sc1 = fold_convert (integer_type_node, sc1);
1345 sc2 = fold_convert (integer_type_node, sc2);
1346 tmp = fold_build2 (MINUS_EXPR, integer_type_node, sc1, sc2);
1350 /* Build a call for the comparison. */
1354 fndecl = gfor_fndecl_compare_string;
1356 fndecl = gfor_fndecl_compare_string_char4;
1360 tmp = build_call_expr (fndecl, 4, len1, str1, len2, str2);
1367 gfc_conv_function_val (gfc_se * se, gfc_symbol * sym)
1371 if (sym->attr.dummy)
1373 tmp = gfc_get_symbol_decl (sym);
1374 if (sym->attr.proc_pointer)
1375 tmp = build_fold_indirect_ref (tmp);
1376 gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
1377 && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
1381 if (!sym->backend_decl)
1382 sym->backend_decl = gfc_get_extern_function_decl (sym);
1384 tmp = sym->backend_decl;
1385 if (sym->attr.cray_pointee)
1386 tmp = convert (build_pointer_type (TREE_TYPE (tmp)),
1387 gfc_get_symbol_decl (sym->cp_pointer));
1388 if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1390 gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
1391 tmp = build_fold_addr_expr (tmp);
1398 /* Translate the call for an elemental subroutine call used in an operator
1399 assignment. This is a simplified version of gfc_conv_function_call. */
1402 gfc_conv_operator_assign (gfc_se *lse, gfc_se *rse, gfc_symbol *sym)
1409 /* Only elemental subroutines with two arguments. */
1410 gcc_assert (sym->attr.elemental && sym->attr.subroutine);
1411 gcc_assert (sym->formal->next->next == NULL);
1413 gfc_init_block (&block);
1415 gfc_add_block_to_block (&block, &lse->pre);
1416 gfc_add_block_to_block (&block, &rse->pre);
1418 /* Build the argument list for the call, including hidden string lengths. */
1419 args = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (lse->expr));
1420 args = gfc_chainon_list (args, build_fold_addr_expr (rse->expr));
1421 if (lse->string_length != NULL_TREE)
1422 args = gfc_chainon_list (args, lse->string_length);
1423 if (rse->string_length != NULL_TREE)
1424 args = gfc_chainon_list (args, rse->string_length);
1426 /* Build the function call. */
1427 gfc_init_se (&se, NULL);
1428 gfc_conv_function_val (&se, sym);
1429 tmp = TREE_TYPE (TREE_TYPE (TREE_TYPE (se.expr)));
1430 tmp = build_call_list (tmp, se.expr, args);
1431 gfc_add_expr_to_block (&block, tmp);
1433 gfc_add_block_to_block (&block, &lse->post);
1434 gfc_add_block_to_block (&block, &rse->post);
1436 return gfc_finish_block (&block);
1440 /* Initialize MAPPING. */
1443 gfc_init_interface_mapping (gfc_interface_mapping * mapping)
1445 mapping->syms = NULL;
1446 mapping->charlens = NULL;
1450 /* Free all memory held by MAPPING (but not MAPPING itself). */
1453 gfc_free_interface_mapping (gfc_interface_mapping * mapping)
1455 gfc_interface_sym_mapping *sym;
1456 gfc_interface_sym_mapping *nextsym;
1458 gfc_charlen *nextcl;
1460 for (sym = mapping->syms; sym; sym = nextsym)
1462 nextsym = sym->next;
1463 gfc_free_symbol (sym->new_sym->n.sym);
1464 gfc_free_expr (sym->expr);
1465 gfc_free (sym->new_sym);
1468 for (cl = mapping->charlens; cl; cl = nextcl)
1471 gfc_free_expr (cl->length);
1477 /* Return a copy of gfc_charlen CL. Add the returned structure to
1478 MAPPING so that it will be freed by gfc_free_interface_mapping. */
1480 static gfc_charlen *
1481 gfc_get_interface_mapping_charlen (gfc_interface_mapping * mapping,
1484 gfc_charlen *new_charlen;
1486 new_charlen = gfc_get_charlen ();
1487 new_charlen->next = mapping->charlens;
1488 new_charlen->length = gfc_copy_expr (cl->length);
1490 mapping->charlens = new_charlen;
1495 /* A subroutine of gfc_add_interface_mapping. Return a descriptorless
1496 array variable that can be used as the actual argument for dummy
1497 argument SYM. Add any initialization code to BLOCK. PACKED is as
1498 for gfc_get_nodesc_array_type and DATA points to the first element
1499 in the passed array. */
1502 gfc_get_interface_mapping_array (stmtblock_t * block, gfc_symbol * sym,
1503 gfc_packed packed, tree data)
1508 type = gfc_typenode_for_spec (&sym->ts);
1509 type = gfc_get_nodesc_array_type (type, sym->as, packed);
1511 var = gfc_create_var (type, "ifm");
1512 gfc_add_modify_expr (block, var, fold_convert (type, data));
1518 /* A subroutine of gfc_add_interface_mapping. Set the stride, upper bounds
1519 and offset of descriptorless array type TYPE given that it has the same
1520 size as DESC. Add any set-up code to BLOCK. */
1523 gfc_set_interface_mapping_bounds (stmtblock_t * block, tree type, tree desc)
1530 offset = gfc_index_zero_node;
1531 for (n = 0; n < GFC_TYPE_ARRAY_RANK (type); n++)
1533 dim = gfc_rank_cst[n];
1534 GFC_TYPE_ARRAY_STRIDE (type, n) = gfc_conv_array_stride (desc, n);
1535 if (GFC_TYPE_ARRAY_LBOUND (type, n) == NULL_TREE)
1537 GFC_TYPE_ARRAY_LBOUND (type, n)
1538 = gfc_conv_descriptor_lbound (desc, dim);
1539 GFC_TYPE_ARRAY_UBOUND (type, n)
1540 = gfc_conv_descriptor_ubound (desc, dim);
1542 else if (GFC_TYPE_ARRAY_UBOUND (type, n) == NULL_TREE)
1544 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1545 gfc_conv_descriptor_ubound (desc, dim),
1546 gfc_conv_descriptor_lbound (desc, dim));
1547 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1548 GFC_TYPE_ARRAY_LBOUND (type, n),
1550 tmp = gfc_evaluate_now (tmp, block);
1551 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
1553 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
1554 GFC_TYPE_ARRAY_LBOUND (type, n),
1555 GFC_TYPE_ARRAY_STRIDE (type, n));
1556 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
1558 offset = gfc_evaluate_now (offset, block);
1559 GFC_TYPE_ARRAY_OFFSET (type) = offset;
1563 /* Extend MAPPING so that it maps dummy argument SYM to the value stored
1564 in SE. The caller may still use se->expr and se->string_length after
1565 calling this function. */
1568 gfc_add_interface_mapping (gfc_interface_mapping * mapping,
1569 gfc_symbol * sym, gfc_se * se,
1572 gfc_interface_sym_mapping *sm;
1576 gfc_symbol *new_sym;
1578 gfc_symtree *new_symtree;
1580 /* Create a new symbol to represent the actual argument. */
1581 new_sym = gfc_new_symbol (sym->name, NULL);
1582 new_sym->ts = sym->ts;
1583 new_sym->attr.referenced = 1;
1584 new_sym->attr.dimension = sym->attr.dimension;
1585 new_sym->attr.pointer = sym->attr.pointer;
1586 new_sym->attr.allocatable = sym->attr.allocatable;
1587 new_sym->attr.flavor = sym->attr.flavor;
1588 new_sym->attr.function = sym->attr.function;
1590 /* Create a fake symtree for it. */
1592 new_symtree = gfc_new_symtree (&root, sym->name);
1593 new_symtree->n.sym = new_sym;
1594 gcc_assert (new_symtree == root);
1596 /* Create a dummy->actual mapping. */
1597 sm = XCNEW (gfc_interface_sym_mapping);
1598 sm->next = mapping->syms;
1600 sm->new_sym = new_symtree;
1601 sm->expr = gfc_copy_expr (expr);
1604 /* Stabilize the argument's value. */
1605 if (!sym->attr.function && se)
1606 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1608 if (sym->ts.type == BT_CHARACTER)
1610 /* Create a copy of the dummy argument's length. */
1611 new_sym->ts.cl = gfc_get_interface_mapping_charlen (mapping, sym->ts.cl);
1612 sm->expr->ts.cl = new_sym->ts.cl;
1614 /* If the length is specified as "*", record the length that
1615 the caller is passing. We should use the callee's length
1616 in all other cases. */
1617 if (!new_sym->ts.cl->length && se)
1619 se->string_length = gfc_evaluate_now (se->string_length, &se->pre);
1620 new_sym->ts.cl->backend_decl = se->string_length;
1627 /* Use the passed value as-is if the argument is a function. */
1628 if (sym->attr.flavor == FL_PROCEDURE)
1631 /* If the argument is either a string or a pointer to a string,
1632 convert it to a boundless character type. */
1633 else if (!sym->attr.dimension && sym->ts.type == BT_CHARACTER)
1635 tmp = gfc_get_character_type_len (sym->ts.kind, NULL);
1636 tmp = build_pointer_type (tmp);
1637 if (sym->attr.pointer)
1638 value = build_fold_indirect_ref (se->expr);
1641 value = fold_convert (tmp, value);
1644 /* If the argument is a scalar, a pointer to an array or an allocatable,
1646 else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
1647 value = build_fold_indirect_ref (se->expr);
1649 /* For character(*), use the actual argument's descriptor. */
1650 else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.cl->length)
1651 value = build_fold_indirect_ref (se->expr);
1653 /* If the argument is an array descriptor, use it to determine
1654 information about the actual argument's shape. */
1655 else if (POINTER_TYPE_P (TREE_TYPE (se->expr))
1656 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se->expr))))
1658 /* Get the actual argument's descriptor. */
1659 desc = build_fold_indirect_ref (se->expr);
1661 /* Create the replacement variable. */
1662 tmp = gfc_conv_descriptor_data_get (desc);
1663 value = gfc_get_interface_mapping_array (&se->pre, sym,
1666 /* Use DESC to work out the upper bounds, strides and offset. */
1667 gfc_set_interface_mapping_bounds (&se->pre, TREE_TYPE (value), desc);
1670 /* Otherwise we have a packed array. */
1671 value = gfc_get_interface_mapping_array (&se->pre, sym,
1672 PACKED_FULL, se->expr);
1674 new_sym->backend_decl = value;
1678 /* Called once all dummy argument mappings have been added to MAPPING,
1679 but before the mapping is used to evaluate expressions. Pre-evaluate
1680 the length of each argument, adding any initialization code to PRE and
1681 any finalization code to POST. */
1684 gfc_finish_interface_mapping (gfc_interface_mapping * mapping,
1685 stmtblock_t * pre, stmtblock_t * post)
1687 gfc_interface_sym_mapping *sym;
1691 for (sym = mapping->syms; sym; sym = sym->next)
1692 if (sym->new_sym->n.sym->ts.type == BT_CHARACTER
1693 && !sym->new_sym->n.sym->ts.cl->backend_decl)
1695 expr = sym->new_sym->n.sym->ts.cl->length;
1696 gfc_apply_interface_mapping_to_expr (mapping, expr);
1697 gfc_init_se (&se, NULL);
1698 gfc_conv_expr (&se, expr);
1700 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1701 gfc_add_block_to_block (pre, &se.pre);
1702 gfc_add_block_to_block (post, &se.post);
1704 sym->new_sym->n.sym->ts.cl->backend_decl = se.expr;
1709 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1713 gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
1714 gfc_constructor * c)
1716 for (; c; c = c->next)
1718 gfc_apply_interface_mapping_to_expr (mapping, c->expr);
1721 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->start);
1722 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->end);
1723 gfc_apply_interface_mapping_to_expr (mapping, c->iterator->step);
1729 /* Like gfc_apply_interface_mapping_to_expr, but applied to
1733 gfc_apply_interface_mapping_to_ref (gfc_interface_mapping * mapping,
1738 for (; ref; ref = ref->next)
1742 for (n = 0; n < ref->u.ar.dimen; n++)
1744 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.start[n]);
1745 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.end[n]);
1746 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.stride[n]);
1748 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
1755 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.start);
1756 gfc_apply_interface_mapping_to_expr (mapping, ref->u.ss.end);
1762 /* Convert intrinsic function calls into result expressions. */
1764 gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping * mapping)
1772 arg1 = expr->value.function.actual->expr;
1773 if (expr->value.function.actual->next)
1774 arg2 = expr->value.function.actual->next->expr;
1778 sym = arg1->symtree->n.sym;
1780 if (sym->attr.dummy)
1785 switch (expr->value.function.isym->id)
1788 /* TODO figure out why this condition is necessary. */
1789 if (sym->attr.function
1790 && arg1->ts.cl->length->expr_type != EXPR_CONSTANT
1791 && arg1->ts.cl->length->expr_type != EXPR_VARIABLE)
1794 new_expr = gfc_copy_expr (arg1->ts.cl->length);
1801 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1803 dup = mpz_get_si (arg2->value.integer);
1808 dup = sym->as->rank;
1812 for (; d < dup; d++)
1815 tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
1816 tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
1818 new_expr = gfc_multiply (new_expr, tmp);
1824 case GFC_ISYM_LBOUND:
1825 case GFC_ISYM_UBOUND:
1826 /* TODO These implementations of lbound and ubound do not limit if
1827 the size < 0, according to F95's 13.14.53 and 13.14.113. */
1832 if (arg2 && arg2->expr_type == EXPR_CONSTANT)
1833 d = mpz_get_si (arg2->value.integer) - 1;
1835 /* TODO: If the need arises, this could produce an array of
1839 if (expr->value.function.isym->id == GFC_ISYM_LBOUND)
1840 new_expr = gfc_copy_expr (sym->as->lower[d]);
1842 new_expr = gfc_copy_expr (sym->as->upper[d]);
1849 gfc_apply_interface_mapping_to_expr (mapping, new_expr);
1853 gfc_replace_expr (expr, new_expr);
1859 gfc_map_fcn_formal_to_actual (gfc_expr *expr, gfc_expr *map_expr,
1860 gfc_interface_mapping * mapping)
1862 gfc_formal_arglist *f;
1863 gfc_actual_arglist *actual;
1865 actual = expr->value.function.actual;
1866 f = map_expr->symtree->n.sym->formal;
1868 for (; f && actual; f = f->next, actual = actual->next)
1873 gfc_add_interface_mapping (mapping, f->sym, NULL, actual->expr);
1876 if (map_expr->symtree->n.sym->attr.dimension)
1881 as = gfc_copy_array_spec (map_expr->symtree->n.sym->as);
1883 for (d = 0; d < as->rank; d++)
1885 gfc_apply_interface_mapping_to_expr (mapping, as->lower[d]);
1886 gfc_apply_interface_mapping_to_expr (mapping, as->upper[d]);
1889 expr->value.function.esym->as = as;
1892 if (map_expr->symtree->n.sym->ts.type == BT_CHARACTER)
1894 expr->value.function.esym->ts.cl->length
1895 = gfc_copy_expr (map_expr->symtree->n.sym->ts.cl->length);
1897 gfc_apply_interface_mapping_to_expr (mapping,
1898 expr->value.function.esym->ts.cl->length);
1903 /* EXPR is a copy of an expression that appeared in the interface
1904 associated with MAPPING. Walk it recursively looking for references to
1905 dummy arguments that MAPPING maps to actual arguments. Replace each such
1906 reference with a reference to the associated actual argument. */
1909 gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
1912 gfc_interface_sym_mapping *sym;
1913 gfc_actual_arglist *actual;
1918 /* Copying an expression does not copy its length, so do that here. */
1919 if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
1921 expr->ts.cl = gfc_get_interface_mapping_charlen (mapping, expr->ts.cl);
1922 gfc_apply_interface_mapping_to_expr (mapping, expr->ts.cl->length);
1925 /* Apply the mapping to any references. */
1926 gfc_apply_interface_mapping_to_ref (mapping, expr->ref);
1928 /* ...and to the expression's symbol, if it has one. */
1929 /* TODO Find out why the condition on expr->symtree had to be moved into
1930 the loop rather than being outside it, as originally. */
1931 for (sym = mapping->syms; sym; sym = sym->next)
1932 if (expr->symtree && sym->old == expr->symtree->n.sym)
1934 if (sym->new_sym->n.sym->backend_decl)
1935 expr->symtree = sym->new_sym;
1937 gfc_replace_expr (expr, gfc_copy_expr (sym->expr));
1940 /* ...and to subexpressions in expr->value. */
1941 switch (expr->expr_type)
1946 case EXPR_SUBSTRING:
1950 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op1);
1951 gfc_apply_interface_mapping_to_expr (mapping, expr->value.op.op2);
1955 for (actual = expr->value.function.actual; actual; actual = actual->next)
1956 gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
1958 if (expr->value.function.esym == NULL
1959 && expr->value.function.isym != NULL
1960 && expr->value.function.actual->expr->symtree
1961 && gfc_map_intrinsic_function (expr, mapping))
1964 for (sym = mapping->syms; sym; sym = sym->next)
1965 if (sym->old == expr->value.function.esym)
1967 expr->value.function.esym = sym->new_sym->n.sym;
1968 gfc_map_fcn_formal_to_actual (expr, sym->expr, mapping);
1969 expr->value.function.esym->result = sym->new_sym->n.sym;
1974 case EXPR_STRUCTURE:
1975 gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
1983 /* Evaluate interface expression EXPR using MAPPING. Store the result
1987 gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
1988 gfc_se * se, gfc_expr * expr)
1990 expr = gfc_copy_expr (expr);
1991 gfc_apply_interface_mapping_to_expr (mapping, expr);
1992 gfc_conv_expr (se, expr);
1993 se->expr = gfc_evaluate_now (se->expr, &se->pre);
1994 gfc_free_expr (expr);
1998 /* Returns a reference to a temporary array into which a component of
1999 an actual argument derived type array is copied and then returned
2000 after the function call. */
2002 gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
2003 int g77, sym_intent intent)
2019 gcc_assert (expr->expr_type == EXPR_VARIABLE);
2021 gfc_init_se (&lse, NULL);
2022 gfc_init_se (&rse, NULL);
2024 /* Walk the argument expression. */
2025 rss = gfc_walk_expr (expr);
2027 gcc_assert (rss != gfc_ss_terminator);
2029 /* Initialize the scalarizer. */
2030 gfc_init_loopinfo (&loop);
2031 gfc_add_ss_to_loop (&loop, rss);
2033 /* Calculate the bounds of the scalarization. */
2034 gfc_conv_ss_startstride (&loop);
2036 /* Build an ss for the temporary. */
2037 if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
2038 gfc_conv_string_length (expr->ts.cl, &parmse->pre);
2040 base_type = gfc_typenode_for_spec (&expr->ts);
2041 if (GFC_ARRAY_TYPE_P (base_type)
2042 || GFC_DESCRIPTOR_TYPE_P (base_type))
2043 base_type = gfc_get_element_type (base_type);
2045 loop.temp_ss = gfc_get_ss ();;
2046 loop.temp_ss->type = GFC_SS_TEMP;
2047 loop.temp_ss->data.temp.type = base_type;
2049 if (expr->ts.type == BT_CHARACTER)
2050 loop.temp_ss->string_length = expr->ts.cl->backend_decl;
2052 loop.temp_ss->string_length = NULL;
2054 parmse->string_length = loop.temp_ss->string_length;
2055 loop.temp_ss->data.temp.dimen = loop.dimen;
2056 loop.temp_ss->next = gfc_ss_terminator;
2058 /* Associate the SS with the loop. */
2059 gfc_add_ss_to_loop (&loop, loop.temp_ss);
2061 /* Setup the scalarizing loops. */
2062 gfc_conv_loop_setup (&loop);
2064 /* Pass the temporary descriptor back to the caller. */
2065 info = &loop.temp_ss->data.info;
2066 parmse->expr = info->descriptor;
2068 /* Setup the gfc_se structures. */
2069 gfc_copy_loopinfo_to_se (&lse, &loop);
2070 gfc_copy_loopinfo_to_se (&rse, &loop);
2073 lse.ss = loop.temp_ss;
2074 gfc_mark_ss_chain_used (rss, 1);
2075 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2077 /* Start the scalarized loop body. */
2078 gfc_start_scalarized_body (&loop, &body);
2080 /* Translate the expression. */
2081 gfc_conv_expr (&rse, expr);
2083 gfc_conv_tmp_array_ref (&lse);
2084 gfc_advance_se_ss_chain (&lse);
2086 if (intent != INTENT_OUT)
2088 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, false);
2089 gfc_add_expr_to_block (&body, tmp);
2090 gcc_assert (rse.ss == gfc_ss_terminator);
2091 gfc_trans_scalarizing_loops (&loop, &body);
2095 /* Make sure that the temporary declaration survives by merging
2096 all the loop declarations into the current context. */
2097 for (n = 0; n < loop.dimen; n++)
2099 gfc_merge_block_scope (&body);
2100 body = loop.code[loop.order[n]];
2102 gfc_merge_block_scope (&body);
2105 /* Add the post block after the second loop, so that any
2106 freeing of allocated memory is done at the right time. */
2107 gfc_add_block_to_block (&parmse->pre, &loop.pre);
2109 /**********Copy the temporary back again.*********/
2111 gfc_init_se (&lse, NULL);
2112 gfc_init_se (&rse, NULL);
2114 /* Walk the argument expression. */
2115 lss = gfc_walk_expr (expr);
2116 rse.ss = loop.temp_ss;
2119 /* Initialize the scalarizer. */
2120 gfc_init_loopinfo (&loop2);
2121 gfc_add_ss_to_loop (&loop2, lss);
2123 /* Calculate the bounds of the scalarization. */
2124 gfc_conv_ss_startstride (&loop2);
2126 /* Setup the scalarizing loops. */
2127 gfc_conv_loop_setup (&loop2);
2129 gfc_copy_loopinfo_to_se (&lse, &loop2);
2130 gfc_copy_loopinfo_to_se (&rse, &loop2);
2132 gfc_mark_ss_chain_used (lss, 1);
2133 gfc_mark_ss_chain_used (loop.temp_ss, 1);
2135 /* Declare the variable to hold the temporary offset and start the
2136 scalarized loop body. */
2137 offset = gfc_create_var (gfc_array_index_type, NULL);
2138 gfc_start_scalarized_body (&loop2, &body);
2140 /* Build the offsets for the temporary from the loop variables. The
2141 temporary array has lbounds of zero and strides of one in all
2142 dimensions, so this is very simple. The offset is only computed
2143 outside the innermost loop, so the overall transfer could be
2144 optimized further. */
2145 info = &rse.ss->data.info;
2147 tmp_index = gfc_index_zero_node;
2148 for (n = info->dimen - 1; n > 0; n--)
2151 tmp = rse.loop->loopvar[n];
2152 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2153 tmp, rse.loop->from[n]);
2154 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2157 tmp_str = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2158 rse.loop->to[n-1], rse.loop->from[n-1]);
2159 tmp_str = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2160 tmp_str, gfc_index_one_node);
2162 tmp_index = fold_build2 (MULT_EXPR, gfc_array_index_type,
2166 tmp_index = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2167 tmp_index, rse.loop->from[0]);
2168 gfc_add_modify_expr (&rse.loop->code[0], offset, tmp_index);
2170 tmp_index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2171 rse.loop->loopvar[0], offset);
2173 /* Now use the offset for the reference. */
2174 tmp = build_fold_indirect_ref (info->data);
2175 rse.expr = gfc_build_array_ref (tmp, tmp_index, NULL);
2177 if (expr->ts.type == BT_CHARACTER)
2178 rse.string_length = expr->ts.cl->backend_decl;
2180 gfc_conv_expr (&lse, expr);
2182 gcc_assert (lse.ss == gfc_ss_terminator);
2184 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2185 gfc_add_expr_to_block (&body, tmp);
2187 /* Generate the copying loops. */
2188 gfc_trans_scalarizing_loops (&loop2, &body);
2190 /* Wrap the whole thing up by adding the second loop to the post-block
2191 and following it by the post-block of the first loop. In this way,
2192 if the temporary needs freeing, it is done after use! */
2193 if (intent != INTENT_IN)
2195 gfc_add_block_to_block (&parmse->post, &loop2.pre);
2196 gfc_add_block_to_block (&parmse->post, &loop2.post);
2199 gfc_add_block_to_block (&parmse->post, &loop.post);
2201 gfc_cleanup_loop (&loop);
2202 gfc_cleanup_loop (&loop2);
2204 /* Pass the string length to the argument expression. */
2205 if (expr->ts.type == BT_CHARACTER)
2206 parmse->string_length = expr->ts.cl->backend_decl;
2208 /* We want either the address for the data or the address of the descriptor,
2209 depending on the mode of passing array arguments. */
2211 parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
2213 parmse->expr = build_fold_addr_expr (parmse->expr);
2219 /* Generate the code for argument list functions. */
2222 conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name)
2224 /* Pass by value for g77 %VAL(arg), pass the address
2225 indirectly for %LOC, else by reference. Thus %REF
2226 is a "do-nothing" and %LOC is the same as an F95
2228 if (strncmp (name, "%VAL", 4) == 0)
2229 gfc_conv_expr (se, expr);
2230 else if (strncmp (name, "%LOC", 4) == 0)
2232 gfc_conv_expr_reference (se, expr);
2233 se->expr = gfc_build_addr_expr (NULL, se->expr);
2235 else if (strncmp (name, "%REF", 4) == 0)
2236 gfc_conv_expr_reference (se, expr);
2238 gfc_error ("Unknown argument list function at %L", &expr->where);
2242 /* Generate code for a procedure call. Note can return se->post != NULL.
2243 If se->direct_byref is set then se->expr contains the return parameter.
2244 Return nonzero, if the call has alternate specifiers. */
2247 gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
2248 gfc_actual_arglist * arg, tree append_args)
2250 gfc_interface_mapping mapping;
2264 gfc_formal_arglist *formal;
2265 int has_alternate_specifier = 0;
2266 bool need_interface_mapping;
2273 enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
2275 arglist = NULL_TREE;
2276 retargs = NULL_TREE;
2277 stringargs = NULL_TREE;
2282 if (sym->from_intmod == INTMOD_ISO_C_BINDING)
2284 if (sym->intmod_sym_id == ISOCBINDING_LOC)
2286 if (arg->expr->rank == 0)
2287 gfc_conv_expr_reference (se, arg->expr);
2291 /* This is really the actual arg because no formal arglist is
2292 created for C_LOC. */
2293 fsym = arg->expr->symtree->n.sym;
2295 /* We should want it to do g77 calling convention. */
2297 && !(fsym->attr.pointer || fsym->attr.allocatable)
2298 && fsym->as->type != AS_ASSUMED_SHAPE;
2299 f = f || !sym->attr.always_explicit;
2301 argss = gfc_walk_expr (arg->expr);
2302 gfc_conv_array_parameter (se, arg->expr, argss, f);
2305 /* TODO -- the following two lines shouldn't be necessary, but
2306 they're removed a bug is exposed later in the codepath.
2307 This is workaround was thus introduced, but will have to be
2308 removed; please see PR 35150 for details about the issue. */
2309 se->expr = convert (pvoid_type_node, se->expr);
2310 se->expr = gfc_evaluate_now (se->expr, &se->pre);
2314 else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
2316 arg->expr->ts.type = sym->ts.derived->ts.type;
2317 arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
2318 arg->expr->ts.kind = sym->ts.derived->ts.kind;
2319 gfc_conv_expr_reference (se, arg->expr);
2323 else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
2324 && arg->next->expr->rank == 0)
2325 || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
2327 /* Convert c_f_pointer if fptr is a scalar
2328 and convert c_f_procpointer. */
2332 gfc_init_se (&cptrse, NULL);
2333 gfc_conv_expr (&cptrse, arg->expr);
2334 gfc_add_block_to_block (&se->pre, &cptrse.pre);
2335 gfc_add_block_to_block (&se->post, &cptrse.post);
2337 gfc_init_se (&fptrse, NULL);
2338 if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
2339 fptrse.want_pointer = 1;
2341 gfc_conv_expr (&fptrse, arg->next->expr);
2342 gfc_add_block_to_block (&se->pre, &fptrse.pre);
2343 gfc_add_block_to_block (&se->post, &fptrse.post);
2345 tmp = arg->next->expr->symtree->n.sym->backend_decl;
2346 se->expr = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp), fptrse.expr,
2347 fold_convert (TREE_TYPE (tmp), cptrse.expr));
2351 else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
2356 /* Build the addr_expr for the first argument. The argument is
2357 already an *address* so we don't need to set want_pointer in
2359 gfc_init_se (&arg1se, NULL);
2360 gfc_conv_expr (&arg1se, arg->expr);
2361 gfc_add_block_to_block (&se->pre, &arg1se.pre);
2362 gfc_add_block_to_block (&se->post, &arg1se.post);
2364 /* See if we were given two arguments. */
2365 if (arg->next == NULL)
2366 /* Only given one arg so generate a null and do a
2367 not-equal comparison against the first arg. */
2368 se->expr = fold_build2 (NE_EXPR, boolean_type_node, arg1se.expr,
2369 fold_convert (TREE_TYPE (arg1se.expr),
2370 null_pointer_node));
2376 /* Given two arguments so build the arg2se from second arg. */
2377 gfc_init_se (&arg2se, NULL);
2378 gfc_conv_expr (&arg2se, arg->next->expr);
2379 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2380 gfc_add_block_to_block (&se->post, &arg2se.post);
2382 /* Generate test to compare that the two args are equal. */
2383 eq_expr = fold_build2 (EQ_EXPR, boolean_type_node,
2384 arg1se.expr, arg2se.expr);
2385 /* Generate test to ensure that the first arg is not null. */
2386 not_null_expr = fold_build2 (NE_EXPR, boolean_type_node,
2387 arg1se.expr, null_pointer_node);
2389 /* Finally, the generated test must check that both arg1 is not
2390 NULL and that it is equal to the second arg. */
2391 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2392 not_null_expr, eq_expr);
2401 if (!sym->attr.elemental)
2403 gcc_assert (se->ss->type == GFC_SS_FUNCTION);
2404 if (se->ss->useflags)
2406 gcc_assert (gfc_return_by_reference (sym)
2407 && sym->result->attr.dimension);
2408 gcc_assert (se->loop != NULL);
2410 /* Access the previously obtained result. */
2411 gfc_conv_tmp_array_ref (se);
2412 gfc_advance_se_ss_chain (se);
2416 info = &se->ss->data.info;
2421 gfc_init_block (&post);
2422 gfc_init_interface_mapping (&mapping);
2423 need_interface_mapping = ((sym->ts.type == BT_CHARACTER
2424 && sym->ts.cl->length
2425 && sym->ts.cl->length->expr_type
2427 || sym->attr.dimension);
2428 formal = sym->formal;
2429 /* Evaluate the arguments. */
2430 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
2433 fsym = formal ? formal->sym : NULL;
2434 parm_kind = MISSING;
2438 if (se->ignore_optional)
2440 /* Some intrinsics have already been resolved to the correct
2444 else if (arg->label)
2446 has_alternate_specifier = 1;
2451 /* Pass a NULL pointer for an absent arg. */
2452 gfc_init_se (&parmse, NULL);
2453 parmse.expr = null_pointer_node;
2454 if (arg->missing_arg_type == BT_CHARACTER)
2455 parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
2458 else if (se->ss && se->ss->useflags)
2460 /* An elemental function inside a scalarized loop. */
2461 gfc_init_se (&parmse, se);
2462 gfc_conv_expr_reference (&parmse, e);
2463 parm_kind = ELEMENTAL;
2467 /* A scalar or transformational function. */
2468 gfc_init_se (&parmse, NULL);
2469 argss = gfc_walk_expr (e);
2471 if (argss == gfc_ss_terminator)
2473 if (fsym && fsym->attr.value)
2475 if (fsym->ts.type == BT_CHARACTER
2476 && fsym->ts.is_c_interop
2477 && fsym->ns->proc_name != NULL
2478 && fsym->ns->proc_name->attr.is_bind_c)
2481 gfc_conv_scalar_char_value (fsym, &parmse, &e);
2482 if (parmse.expr == NULL)
2483 gfc_conv_expr (&parmse, e);
2486 gfc_conv_expr (&parmse, e);
2488 else if (arg->name && arg->name[0] == '%')
2489 /* Argument list functions %VAL, %LOC and %REF are signalled
2490 through arg->name. */
2491 conv_arglist_function (&parmse, arg->expr, arg->name);
2492 else if ((e->expr_type == EXPR_FUNCTION)
2493 && e->symtree->n.sym->attr.pointer
2494 && fsym && fsym->attr.target)
2496 gfc_conv_expr (&parmse, e);
2497 parmse.expr = build_fold_addr_expr (parmse.expr);
2501 gfc_conv_expr_reference (&parmse, e);
2502 if (fsym && e->expr_type != EXPR_NULL
2503 && ((fsym->attr.pointer
2504 && fsym->attr.flavor != FL_PROCEDURE)
2505 || fsym->attr.proc_pointer))
2507 /* Scalar pointer dummy args require an extra level of
2508 indirection. The null pointer already contains
2509 this level of indirection. */
2510 parm_kind = SCALAR_POINTER;
2511 parmse.expr = build_fold_addr_expr (parmse.expr);
2517 /* If the procedure requires an explicit interface, the actual
2518 argument is passed according to the corresponding formal
2519 argument. If the corresponding formal argument is a POINTER,
2520 ALLOCATABLE or assumed shape, we do not use g77's calling
2521 convention, and pass the address of the array descriptor
2522 instead. Otherwise we use g77's calling convention. */
2525 && !(fsym->attr.pointer || fsym->attr.allocatable)
2526 && fsym->as->type != AS_ASSUMED_SHAPE;
2527 f = f || !sym->attr.always_explicit;
2529 if (e->expr_type == EXPR_VARIABLE
2530 && is_subref_array (e))
2531 /* The actual argument is a component reference to an
2532 array of derived types. In this case, the argument
2533 is converted to a temporary, which is passed and then
2534 written back after the procedure call. */
2535 gfc_conv_subref_array_arg (&parmse, e, f,
2536 fsym ? fsym->attr.intent : INTENT_INOUT);
2538 gfc_conv_array_parameter (&parmse, e, argss, f);
2540 /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
2541 allocated on entry, it must be deallocated. */
2542 if (fsym && fsym->attr.allocatable
2543 && fsym->attr.intent == INTENT_OUT)
2545 tmp = build_fold_indirect_ref (parmse.expr);
2546 tmp = gfc_trans_dealloc_allocated (tmp);
2547 gfc_add_expr_to_block (&se->pre, tmp);
2553 /* The case with fsym->attr.optional is that of a user subroutine
2554 with an interface indicating an optional argument. When we call
2555 an intrinsic subroutine, however, fsym is NULL, but we might still
2556 have an optional argument, so we proceed to the substitution
2558 if (e && (fsym == NULL || fsym->attr.optional))
2560 /* If an optional argument is itself an optional dummy argument,
2561 check its presence and substitute a null if absent. */
2562 if (e->expr_type == EXPR_VARIABLE
2563 && e->symtree->n.sym->attr.optional)
2564 gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
2565 e->representation.length);
2570 /* Obtain the character length of an assumed character length
2571 length procedure from the typespec. */
2572 if (fsym->ts.type == BT_CHARACTER
2573 && parmse.string_length == NULL_TREE
2574 && e->ts.type == BT_PROCEDURE
2575 && e->symtree->n.sym->ts.type == BT_CHARACTER
2576 && e->symtree->n.sym->ts.cl->length != NULL)
2578 gfc_conv_const_charlen (e->symtree->n.sym->ts.cl);
2579 parmse.string_length = e->symtree->n.sym->ts.cl->backend_decl;
2583 if (fsym && need_interface_mapping && e)
2584 gfc_add_interface_mapping (&mapping, fsym, &parmse, e);
2586 gfc_add_block_to_block (&se->pre, &parmse.pre);
2587 gfc_add_block_to_block (&post, &parmse.post);
2589 /* Allocated allocatable components of derived types must be
2590 deallocated for INTENT(OUT) dummy arguments and non-variable
2591 scalars. Non-variable arrays are dealt with in trans-array.c
2592 (gfc_conv_array_parameter). */
2593 if (e && e->ts.type == BT_DERIVED
2594 && e->ts.derived->attr.alloc_comp
2595 && ((formal && formal->sym->attr.intent == INTENT_OUT)
2597 (e->expr_type != EXPR_VARIABLE && !e->rank)))
2600 tmp = build_fold_indirect_ref (parmse.expr);
2601 parm_rank = e->rank;
2609 case (SCALAR_POINTER):
2610 tmp = build_fold_indirect_ref (tmp);
2617 tmp = gfc_deallocate_alloc_comp (e->ts.derived, tmp, parm_rank);
2618 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional)
2619 tmp = build3_v (COND_EXPR, gfc_conv_expr_present (e->symtree->n.sym),
2620 tmp, build_empty_stmt ());
2622 if (e->expr_type != EXPR_VARIABLE)
2623 /* Don't deallocate non-variables until they have been used. */
2624 gfc_add_expr_to_block (&se->post, tmp);
2627 gcc_assert (formal && formal->sym->attr.intent == INTENT_OUT);
2628 gfc_add_expr_to_block (&se->pre, tmp);
2632 /* Character strings are passed as two parameters, a length and a
2633 pointer - except for Bind(c) which only passes the pointer. */
2634 if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
2635 stringargs = gfc_chainon_list (stringargs, parmse.string_length);
2637 arglist = gfc_chainon_list (arglist, parmse.expr);
2639 gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
2642 if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
2644 if (sym->ts.cl->length == NULL)
2646 /* Assumed character length results are not allowed by 5.1.1.5 of the
2647 standard and are trapped in resolve.c; except in the case of SPREAD
2648 (and other intrinsics?) and dummy functions. In the case of SPREAD,
2649 we take the character length of the first argument for the result.
2650 For dummies, we have to look through the formal argument list for
2651 this function and use the character length found there.*/
2652 if (!sym->attr.dummy)
2653 cl.backend_decl = TREE_VALUE (stringargs);
2656 formal = sym->ns->proc_name->formal;
2657 for (; formal; formal = formal->next)
2658 if (strcmp (formal->sym->name, sym->name) == 0)
2659 cl.backend_decl = formal->sym->ts.cl->backend_decl;
2666 /* Calculate the length of the returned string. */
2667 gfc_init_se (&parmse, NULL);
2668 if (need_interface_mapping)
2669 gfc_apply_interface_mapping (&mapping, &parmse, sym->ts.cl->length);
2671 gfc_conv_expr (&parmse, sym->ts.cl->length);
2672 gfc_add_block_to_block (&se->pre, &parmse.pre);
2673 gfc_add_block_to_block (&se->post, &parmse.post);
2675 tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
2676 tmp = fold_build2 (MAX_EXPR, gfc_charlen_type_node, tmp,
2677 build_int_cst (gfc_charlen_type_node, 0));
2678 cl.backend_decl = tmp;
2681 /* Set up a charlen structure for it. */
2686 len = cl.backend_decl;
2689 byref = gfc_return_by_reference (sym);
2692 if (se->direct_byref)
2694 /* Sometimes, too much indirection can be applied; e.g. for
2695 function_result = array_valued_recursive_function. */
2696 if (TREE_TYPE (TREE_TYPE (se->expr))
2697 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))
2698 && GFC_DESCRIPTOR_TYPE_P
2699 (TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr)))))
2700 se->expr = build_fold_indirect_ref (se->expr);
2702 retargs = gfc_chainon_list (retargs, se->expr);
2704 else if (sym->result->attr.dimension)
2706 gcc_assert (se->loop && info);
2708 /* Set the type of the array. */
2709 tmp = gfc_typenode_for_spec (&ts);
2710 info->dimen = se->loop->dimen;
2712 /* Evaluate the bounds of the result, if known. */
2713 gfc_set_loop_bounds_from_array_spec (&mapping, se, sym->result->as);
2715 /* Create a temporary to store the result. In case the function
2716 returns a pointer, the temporary will be a shallow copy and
2717 mustn't be deallocated. */
2718 callee_alloc = sym->attr.allocatable || sym->attr.pointer;
2719 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, info, tmp,
2720 false, !sym->attr.pointer, callee_alloc);
2722 /* Pass the temporary as the first argument. */
2723 tmp = info->descriptor;
2724 tmp = build_fold_addr_expr (tmp);
2725 retargs = gfc_chainon_list (retargs, tmp);
2727 else if (ts.type == BT_CHARACTER)
2729 /* Pass the string length. */
2730 type = gfc_get_character_type (ts.kind, ts.cl);
2731 type = build_pointer_type (type);
2733 /* Return an address to a char[0:len-1]* temporary for
2734 character pointers. */
2735 if (sym->attr.pointer || sym->attr.allocatable)
2737 var = gfc_create_var (type, "pstr");
2739 /* Provide an address expression for the function arguments. */
2740 var = build_fold_addr_expr (var);
2743 var = gfc_conv_string_tmp (se, type, len);
2745 retargs = gfc_chainon_list (retargs, var);
2749 gcc_assert (gfc_option.flag_f2c && ts.type == BT_COMPLEX);
2751 type = gfc_get_complex_type (ts.kind);
2752 var = build_fold_addr_expr (gfc_create_var (type, "cmplx"));
2753 retargs = gfc_chainon_list (retargs, var);
2756 /* Add the string length to the argument list. */
2757 if (ts.type == BT_CHARACTER)
2758 retargs = gfc_chainon_list (retargs, len);
2760 gfc_free_interface_mapping (&mapping);
2762 /* Add the return arguments. */
2763 arglist = chainon (retargs, arglist);
2765 /* Add the hidden string length parameters to the arguments. */
2766 arglist = chainon (arglist, stringargs);
2768 /* We may want to append extra arguments here. This is used e.g. for
2769 calls to libgfortran_matmul_??, which need extra information. */
2770 if (append_args != NULL_TREE)
2771 arglist = chainon (arglist, append_args);
2773 /* Generate the actual call. */
2774 gfc_conv_function_val (se, sym);
2776 /* If there are alternate return labels, function type should be
2777 integer. Can't modify the type in place though, since it can be shared
2778 with other functions. For dummy arguments, the typing is done to
2779 to this result, even if it has to be repeated for each call. */
2780 if (has_alternate_specifier
2781 && TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) != integer_type_node)
2783 if (!sym->attr.dummy)
2785 TREE_TYPE (sym->backend_decl)
2786 = build_function_type (integer_type_node,
2787 TYPE_ARG_TYPES (TREE_TYPE (sym->backend_decl)));
2788 se->expr = build_fold_addr_expr (sym->backend_decl);
2791 TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node;
2794 fntype = TREE_TYPE (TREE_TYPE (se->expr));
2795 se->expr = build_call_list (TREE_TYPE (fntype), se->expr, arglist);
2797 /* If we have a pointer function, but we don't want a pointer, e.g.
2800 where f is pointer valued, we have to dereference the result. */
2801 if (!se->want_pointer && !byref && sym->attr.pointer)
2802 se->expr = build_fold_indirect_ref (se->expr);
2804 /* f2c calling conventions require a scalar default real function to
2805 return a double precision result. Convert this back to default
2806 real. We only care about the cases that can happen in Fortran 77.
2808 if (gfc_option.flag_f2c && sym->ts.type == BT_REAL
2809 && sym->ts.kind == gfc_default_real_kind
2810 && !sym->attr.always_explicit)
2811 se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
2813 /* A pure function may still have side-effects - it may modify its
2815 TREE_SIDE_EFFECTS (se->expr) = 1;
2817 if (!sym->attr.pure)
2818 TREE_SIDE_EFFECTS (se->expr) = 1;
2823 /* Add the function call to the pre chain. There is no expression. */
2824 gfc_add_expr_to_block (&se->pre, se->expr);
2825 se->expr = NULL_TREE;
2827 if (!se->direct_byref)
2829 if (sym->attr.dimension)
2831 if (flag_bounds_check)
2833 /* Check the data pointer hasn't been modified. This would
2834 happen in a function returning a pointer. */
2835 tmp = gfc_conv_descriptor_data_get (info->descriptor);
2836 tmp = fold_build2 (NE_EXPR, boolean_type_node,
2838 gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault);
2840 se->expr = info->descriptor;
2841 /* Bundle in the string length. */
2842 se->string_length = len;
2844 else if (sym->ts.type == BT_CHARACTER)
2846 /* Dereference for character pointer results. */
2847 if (sym->attr.pointer || sym->attr.allocatable)
2848 se->expr = build_fold_indirect_ref (var);
2852 se->string_length = len;
2856 gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
2857 se->expr = build_fold_indirect_ref (var);
2862 /* Follow the function call with the argument post block. */
2864 gfc_add_block_to_block (&se->pre, &post);
2866 gfc_add_block_to_block (&se->post, &post);
2868 return has_alternate_specifier;
2872 /* Fill a character string with spaces. */
2875 fill_with_spaces (tree start, tree type, tree size)
2877 stmtblock_t block, loop;
2878 tree i, el, exit_label, cond, tmp;
2880 /* For a simple char type, we can call memset(). */
2881 if (compare_tree_int (TYPE_SIZE_UNIT (type), 1) == 0)
2882 return build_call_expr (built_in_decls[BUILT_IN_MEMSET], 3, start,
2883 build_int_cst (gfc_get_int_type (gfc_c_int_kind),
2884 lang_hooks.to_target_charset (' ')),
2887 /* Otherwise, we use a loop:
2888 for (el = start, i = size; i > 0; el--, i+= TYPE_SIZE_UNIT (type))
2892 /* Initialize variables. */
2893 gfc_init_block (&block);
2894 i = gfc_create_var (sizetype, "i");
2895 gfc_add_modify_expr (&block, i, fold_convert (sizetype, size));
2896 el = gfc_create_var (build_pointer_type (type), "el");
2897 gfc_add_modify_expr (&block, el, fold_convert (TREE_TYPE (el), start));
2898 exit_label = gfc_build_label_decl (NULL_TREE);
2899 TREE_USED (exit_label) = 1;
2903 gfc_init_block (&loop);
2905 /* Exit condition. */
2906 cond = fold_build2 (LE_EXPR, boolean_type_node, i,
2907 fold_convert (sizetype, integer_zero_node));
2908 tmp = build1_v (GOTO_EXPR, exit_label);
2909 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
2910 gfc_add_expr_to_block (&loop, tmp);
2913 gfc_add_modify_expr (&loop, fold_build1 (INDIRECT_REF, type, el),
2914 build_int_cst (type,
2915 lang_hooks.to_target_charset (' ')));
2917 /* Increment loop variables. */
2918 gfc_add_modify_expr (&loop, i, fold_build2 (MINUS_EXPR, sizetype, i,
2919 TYPE_SIZE_UNIT (type)));
2920 gfc_add_modify_expr (&loop, el, fold_build2 (POINTER_PLUS_EXPR,
2922 TYPE_SIZE_UNIT (type)));
2924 /* Making the loop... actually loop! */
2925 tmp = gfc_finish_block (&loop);
2926 tmp = build1_v (LOOP_EXPR, tmp);
2927 gfc_add_expr_to_block (&block, tmp);
2929 /* The exit label. */
2930 tmp = build1_v (LABEL_EXPR, exit_label);
2931 gfc_add_expr_to_block (&block, tmp);
2934 return gfc_finish_block (&block);
2938 /* Generate code to copy a string. */
2941 gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
2942 int dkind, tree slength, tree src, int skind)
2944 tree tmp, dlen, slen;
2953 stmtblock_t tempblock;
2955 gcc_assert (dkind == skind);
2957 if (slength != NULL_TREE)
2959 slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
2960 ssc = string_to_single_character (slen, src, skind);
2964 slen = build_int_cst (size_type_node, 1);
2968 if (dlength != NULL_TREE)
2970 dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
2971 dsc = string_to_single_character (slen, dest, dkind);
2975 dlen = build_int_cst (size_type_node, 1);
2979 if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
2980 ssc = string_to_single_character (slen, src, skind);
2981 if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
2982 dsc = string_to_single_character (dlen, dest, dkind);
2985 /* Assign directly if the types are compatible. */
2986 if (dsc != NULL_TREE && ssc != NULL_TREE
2987 && TREE_TYPE (dsc) == TREE_TYPE (ssc))
2989 gfc_add_modify_expr (block, dsc, ssc);
2993 /* Do nothing if the destination length is zero. */
2994 cond = fold_build2 (GT_EXPR, boolean_type_node, dlen,
2995 build_int_cst (size_type_node, 0));
2997 /* The following code was previously in _gfortran_copy_string:
2999 // The two strings may overlap so we use memmove.
3001 copy_string (GFC_INTEGER_4 destlen, char * dest,
3002 GFC_INTEGER_4 srclen, const char * src)
3004 if (srclen >= destlen)
3006 // This will truncate if too long.
3007 memmove (dest, src, destlen);
3011 memmove (dest, src, srclen);
3013 memset (&dest[srclen], ' ', destlen - srclen);
3017 We're now doing it here for better optimization, but the logic
3020 /* For non-default character kinds, we have to multiply the string
3021 length by the base type size. */
3022 chartype = gfc_get_char_type (dkind);
3023 slen = fold_build2 (MULT_EXPR, size_type_node, slen,
3024 TYPE_SIZE_UNIT (chartype));
3025 dlen = fold_build2 (MULT_EXPR, size_type_node, dlen,
3026 TYPE_SIZE_UNIT (chartype));
3029 dest = fold_convert (pvoid_type_node, dest);
3031 dest = gfc_build_addr_expr (pvoid_type_node, dest);
3034 src = fold_convert (pvoid_type_node, src);
3036 src = gfc_build_addr_expr (pvoid_type_node, src);
3038 /* Truncate string if source is too long. */
3039 cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
3040 tmp2 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3041 3, dest, src, dlen);
3043 /* Else copy and pad with spaces. */
3044 tmp3 = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE],
3045 3, dest, src, slen);
3047 tmp4 = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (dest), dest,
3048 fold_convert (sizetype, slen));
3049 tmp4 = fill_with_spaces (tmp4, chartype,
3050 fold_build2 (MINUS_EXPR, TREE_TYPE(dlen),
3053 gfc_init_block (&tempblock);
3054 gfc_add_expr_to_block (&tempblock, tmp3);
3055 gfc_add_expr_to_block (&tempblock, tmp4);
3056 tmp3 = gfc_finish_block (&tempblock);
3058 /* The whole copy_string function is there. */
3059 tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp2, tmp3);
3060 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, build_empty_stmt ());
3061 gfc_add_expr_to_block (block, tmp);
3065 /* Translate a statement function.
3066 The value of a statement function reference is obtained by evaluating the
3067 expression using the values of the actual arguments for the values of the
3068 corresponding dummy arguments. */
3071 gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
3075 gfc_formal_arglist *fargs;
3076 gfc_actual_arglist *args;
3079 gfc_saved_var *saved_vars;
3085 sym = expr->symtree->n.sym;
3086 args = expr->value.function.actual;
3087 gfc_init_se (&lse, NULL);
3088 gfc_init_se (&rse, NULL);
3091 for (fargs = sym->formal; fargs; fargs = fargs->next)
3093 saved_vars = (gfc_saved_var *)gfc_getmem (n * sizeof (gfc_saved_var));
3094 temp_vars = (tree *)gfc_getmem (n * sizeof (tree));
3096 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3098 /* Each dummy shall be specified, explicitly or implicitly, to be
3100 gcc_assert (fargs->sym->attr.dimension == 0);
3103 /* Create a temporary to hold the value. */
3104 type = gfc_typenode_for_spec (&fsym->ts);
3105 temp_vars[n] = gfc_create_var (type, fsym->name);
3107 if (fsym->ts.type == BT_CHARACTER)
3109 /* Copy string arguments. */
3112 gcc_assert (fsym->ts.cl && fsym->ts.cl->length
3113 && fsym->ts.cl->length->expr_type == EXPR_CONSTANT);
3115 arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
3116 tmp = gfc_build_addr_expr (build_pointer_type (type),
3119 gfc_conv_expr (&rse, args->expr);
3120 gfc_conv_string_parameter (&rse);
3121 gfc_add_block_to_block (&se->pre, &lse.pre);
3122 gfc_add_block_to_block (&se->pre, &rse.pre);
3124 gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
3125 rse.string_length, rse.expr, fsym->ts.kind);
3126 gfc_add_block_to_block (&se->pre, &lse.post);
3127 gfc_add_block_to_block (&se->pre, &rse.post);
3131 /* For everything else, just evaluate the expression. */
3132 gfc_conv_expr (&lse, args->expr);
3134 gfc_add_block_to_block (&se->pre, &lse.pre);
3135 gfc_add_modify_expr (&se->pre, temp_vars[n], lse.expr);
3136 gfc_add_block_to_block (&se->pre, &lse.post);
3142 /* Use the temporary variables in place of the real ones. */
3143 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3144 gfc_shadow_sym (fargs->sym, temp_vars[n], &saved_vars[n]);
3146 gfc_conv_expr (se, sym->value);
3148 if (sym->ts.type == BT_CHARACTER)
3150 gfc_conv_const_charlen (sym->ts.cl);
3152 /* Force the expression to the correct length. */
3153 if (!INTEGER_CST_P (se->string_length)
3154 || tree_int_cst_lt (se->string_length,
3155 sym->ts.cl->backend_decl))
3157 type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
3158 tmp = gfc_create_var (type, sym->name);
3159 tmp = gfc_build_addr_expr (build_pointer_type (type), tmp);
3160 gfc_trans_string_copy (&se->pre, sym->ts.cl->backend_decl, tmp,
3161 sym->ts.kind, se->string_length, se->expr,
3165 se->string_length = sym->ts.cl->backend_decl;
3168 /* Restore the original variables. */
3169 for (fargs = sym->formal, n = 0; fargs; fargs = fargs->next, n++)
3170 gfc_restore_sym (fargs->sym, &saved_vars[n]);
3171 gfc_free (saved_vars);
3175 /* Translate a function expression. */
3178 gfc_conv_function_expr (gfc_se * se, gfc_expr * expr)
3182 if (expr->value.function.isym)
3184 gfc_conv_intrinsic_function (se, expr);
3188 /* We distinguish statement functions from general functions to improve
3189 runtime performance. */
3190 if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
3192 gfc_conv_statement_function (se, expr);
3196 /* expr.value.function.esym is the resolved (specific) function symbol for
3197 most functions. However this isn't set for dummy procedures. */
3198 sym = expr->value.function.esym;
3200 sym = expr->symtree->n.sym;
3201 gfc_conv_function_call (se, sym, expr->value.function.actual, NULL_TREE);
3206 gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
3208 gcc_assert (se->ss != NULL && se->ss != gfc_ss_terminator);
3209 gcc_assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR);
3211 gfc_conv_tmp_array_ref (se);
3212 gfc_advance_se_ss_chain (se);
3216 /* Build a static initializer. EXPR is the expression for the initial value.
3217 The other parameters describe the variable of the component being
3218 initialized. EXPR may be null. */
3221 gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
3222 bool array, bool pointer)
3226 if (!(expr || pointer))
3229 /* Check if we have ISOCBINDING_NULL_PTR or ISOCBINDING_NULL_FUNPTR
3230 (these are the only two iso_c_binding derived types that can be
3231 used as initialization expressions). If so, we need to modify
3232 the 'expr' to be that for a (void *). */
3233 if (expr != NULL && expr->ts.type == BT_DERIVED
3234 && expr->ts.is_iso_c && expr->ts.derived)
3236 gfc_symbol *derived = expr->ts.derived;
3238 expr = gfc_int_expr (0);
3240 /* The derived symbol has already been converted to a (void *). Use
3242 expr->ts.f90_type = derived->ts.f90_type;
3243 expr->ts.kind = derived->ts.kind;
3248 /* Arrays need special handling. */
3250 return gfc_build_null_descriptor (type);
3252 return gfc_conv_array_initializer (type, expr);
3255 return fold_convert (type, null_pointer_node);
3261 gfc_init_se (&se, NULL);
3262 gfc_conv_structure (&se, expr, 1);
3266 return gfc_conv_string_init (ts->cl->backend_decl,expr);
3269 gfc_init_se (&se, NULL);
3270 gfc_conv_constant (&se, expr);
3277 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3289 gfc_start_block (&block);
3291 /* Initialize the scalarizer. */
3292 gfc_init_loopinfo (&loop);
3294 gfc_init_se (&lse, NULL);
3295 gfc_init_se (&rse, NULL);
3298 rss = gfc_walk_expr (expr);
3299 if (rss == gfc_ss_terminator)
3301 /* The rhs is scalar. Add a ss for the expression. */
3302 rss = gfc_get_ss ();
3303 rss->next = gfc_ss_terminator;
3304 rss->type = GFC_SS_SCALAR;
3308 /* Create a SS for the destination. */
3309 lss = gfc_get_ss ();
3310 lss->type = GFC_SS_COMPONENT;
3312 lss->shape = gfc_get_shape (cm->as->rank);
3313 lss->next = gfc_ss_terminator;
3314 lss->data.info.dimen = cm->as->rank;
3315 lss->data.info.descriptor = dest;
3316 lss->data.info.data = gfc_conv_array_data (dest);
3317 lss->data.info.offset = gfc_conv_array_offset (dest);
3318 for (n = 0; n < cm->as->rank; n++)
3320 lss->data.info.dim[n] = n;
3321 lss->data.info.start[n] = gfc_conv_array_lbound (dest, n);
3322 lss->data.info.stride[n] = gfc_index_one_node;
3324 mpz_init (lss->shape[n]);
3325 mpz_sub (lss->shape[n], cm->as->upper[n]->value.integer,
3326 cm->as->lower[n]->value.integer);
3327 mpz_add_ui (lss->shape[n], lss->shape[n], 1);
3330 /* Associate the SS with the loop. */
3331 gfc_add_ss_to_loop (&loop, lss);
3332 gfc_add_ss_to_loop (&loop, rss);
3334 /* Calculate the bounds of the scalarization. */
3335 gfc_conv_ss_startstride (&loop);
3337 /* Setup the scalarizing loops. */
3338 gfc_conv_loop_setup (&loop);
3340 /* Setup the gfc_se structures. */
3341 gfc_copy_loopinfo_to_se (&lse, &loop);
3342 gfc_copy_loopinfo_to_se (&rse, &loop);
3345 gfc_mark_ss_chain_used (rss, 1);
3347 gfc_mark_ss_chain_used (lss, 1);
3349 /* Start the scalarized loop body. */
3350 gfc_start_scalarized_body (&loop, &body);
3352 gfc_conv_tmp_array_ref (&lse);
3353 if (cm->ts.type == BT_CHARACTER)
3354 lse.string_length = cm->ts.cl->backend_decl;
3356 gfc_conv_expr (&rse, expr);
3358 tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false);
3359 gfc_add_expr_to_block (&body, tmp);
3361 gcc_assert (rse.ss == gfc_ss_terminator);
3363 /* Generate the copying loops. */
3364 gfc_trans_scalarizing_loops (&loop, &body);
3366 /* Wrap the whole thing up. */
3367 gfc_add_block_to_block (&block, &loop.pre);
3368 gfc_add_block_to_block (&block, &loop.post);
3370 for (n = 0; n < cm->as->rank; n++)
3371 mpz_clear (lss->shape[n]);
3372 gfc_free (lss->shape);
3374 gfc_cleanup_loop (&loop);
3376 return gfc_finish_block (&block);
3380 /* Assign a single component of a derived type constructor. */
3383 gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
3393 gfc_start_block (&block);
3397 gfc_init_se (&se, NULL);
3398 /* Pointer component. */
3401 /* Array pointer. */
3402 if (expr->expr_type == EXPR_NULL)
3403 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3406 rss = gfc_walk_expr (expr);
3407 se.direct_byref = 1;
3409 gfc_conv_expr_descriptor (&se, expr, rss);
3410 gfc_add_block_to_block (&block, &se.pre);
3411 gfc_add_block_to_block (&block, &se.post);
3416 /* Scalar pointers. */
3417 se.want_pointer = 1;
3418 gfc_conv_expr (&se, expr);
3419 gfc_add_block_to_block (&block, &se.pre);
3420 gfc_add_modify_expr (&block, dest,
3421 fold_convert (TREE_TYPE (dest), se.expr));
3422 gfc_add_block_to_block (&block, &se.post);
3425 else if (cm->dimension)
3427 if (cm->allocatable && expr->expr_type == EXPR_NULL)
3428 gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
3429 else if (cm->allocatable)
3433 gfc_init_se (&se, NULL);
3435 rss = gfc_walk_expr (expr);
3436 se.want_pointer = 0;
3437 gfc_conv_expr_descriptor (&se, expr, rss);
3438 gfc_add_block_to_block (&block, &se.pre);
3440 tmp = fold_convert (TREE_TYPE (dest), se.expr);
3441 gfc_add_modify_expr (&block, dest, tmp);
3443 if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
3444 tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
3447 tmp = gfc_duplicate_allocatable (dest, se.expr,
3448 TREE_TYPE(cm->backend_decl),
3451 gfc_add_expr_to_block (&block, tmp);
3453 gfc_add_block_to_block (&block, &se.post);
3454 gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
3456 /* Shift the lbound and ubound of temporaries to being unity, rather
3457 than zero, based. Calculate the offset for all cases. */
3458 offset = gfc_conv_descriptor_offset (dest);
3459 gfc_add_modify_expr (&block, offset, gfc_index_zero_node);
3460 tmp2 =gfc_create_var (gfc_array_index_type, NULL);
3461 for (n = 0; n < expr->rank; n++)
3463 if (expr->expr_type != EXPR_VARIABLE
3464 && expr->expr_type != EXPR_CONSTANT)
3467 tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
3468 span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
3469 gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
3470 gfc_add_modify_expr (&block, tmp,
3471 fold_build2 (PLUS_EXPR,
3472 gfc_array_index_type,
3473 span, gfc_index_one_node));
3474 tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
3475 gfc_add_modify_expr (&block, tmp, gfc_index_one_node);
3477 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3478 gfc_conv_descriptor_lbound (dest,
3480 gfc_conv_descriptor_stride (dest,
3482 gfc_add_modify_expr (&block, tmp2, tmp);
3483 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
3484 gfc_add_modify_expr (&block, offset, tmp);
3489 tmp = gfc_trans_subarray_assign (dest, cm, expr);
3490 gfc_add_expr_to_block (&block, tmp);
3493 else if (expr->ts.type == BT_DERIVED)
3495 if (expr->expr_type != EXPR_STRUCTURE)
3497 gfc_init_se (&se, NULL);
3498 gfc_conv_expr (&se, expr);
3499 gfc_add_modify_expr (&block, dest,
3500 fold_convert (TREE_TYPE (dest), se.expr));
3504 /* Nested constructors. */
3505 tmp = gfc_trans_structure_assign (dest, expr);
3506 gfc_add_expr_to_block (&block, tmp);
3511 /* Scalar component. */
3512 gfc_init_se (&se, NULL);
3513 gfc_init_se (&lse, NULL);
3515 gfc_conv_expr (&se, expr);
3516 if (cm->ts.type == BT_CHARACTER)
3517 lse.string_length = cm->ts.cl->backend_decl;
3519 tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false);
3520 gfc_add_expr_to_block (&block, tmp);
3522 return gfc_finish_block (&block);
3525 /* Assign a derived type constructor to a variable. */
3528 gfc_trans_structure_assign (tree dest, gfc_expr * expr)
3536 gfc_start_block (&block);
3537 cm = expr->ts.derived->components;
3538 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3540 /* Skip absent members in default initializers. */
3544 /* Update the type/kind of the expression if it represents either
3545 C_NULL_PTR or C_NULL_FUNPTR. This is done here because this may
3546 be the first place reached for initializing output variables that
3547 have components of type C_PTR/C_FUNPTR that are initialized. */
3548 if (c->expr->ts.type == BT_DERIVED && c->expr->ts.derived
3549 && c->expr->ts.derived->attr.is_iso_c)
3551 c->expr->expr_type = EXPR_NULL;
3552 c->expr->ts.type = c->expr->ts.derived->ts.type;
3553 c->expr->ts.f90_type = c->expr->ts.derived->ts.f90_type;
3554 c->expr->ts.kind = c->expr->ts.derived->ts.kind;
3557 field = cm->backend_decl;
3558 tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
3559 dest, field, NULL_TREE);
3560 tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr);
3561 gfc_add_expr_to_block (&block, tmp);
3563 return gfc_finish_block (&block);
3566 /* Build an expression for a constructor. If init is nonzero then
3567 this is part of a static variable initializer. */
3570 gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
3577 VEC(constructor_elt,gc) *v = NULL;
3579 gcc_assert (se->ss == NULL);
3580 gcc_assert (expr->expr_type == EXPR_STRUCTURE);
3581 type = gfc_typenode_for_spec (&expr->ts);
3585 /* Create a temporary variable and fill it in. */
3586 se->expr = gfc_create_var (type, expr->ts.derived->name);
3587 tmp = gfc_trans_structure_assign (se->expr, expr);
3588 gfc_add_expr_to_block (&se->pre, tmp);
3592 cm = expr->ts.derived->components;
3594 for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3596 /* Skip absent members in default initializers and allocatable
3597 components. Although the latter have a default initializer
3598 of EXPR_NULL,... by default, the static nullify is not needed
3599 since this is done every time we come into scope. */
3600 if (!c->expr || cm->allocatable)
3603 val = gfc_conv_initializer (c->expr, &cm->ts,
3604 TREE_TYPE (cm->backend_decl), cm->dimension, cm->pointer);
3606 /* Append it to the constructor list. */
3607 CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
3609 se->expr = build_constructor (type, v);
3611 TREE_CONSTANT (se->expr) = 1;
3615 /* Translate a substring expression. */
3618 gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr)
3624 gcc_assert (ref == NULL || ref->type == REF_SUBSTRING);
3626 se->expr = gfc_build_wide_string_const (expr->ts.kind,
3627 expr->value.character.length,
3628 expr->value.character.string);
3630 se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
3631 TYPE_STRING_FLAG (TREE_TYPE (se->expr)) = 1;
3634 gfc_conv_substring (se, ref, expr->ts.kind, NULL, &expr->where);
3638 /* Entry point for expression translation. Evaluates a scalar quantity.
3639 EXPR is the expression to be translated, and SE is the state structure if
3640 called from within the scalarized. */
3643 gfc_conv_expr (gfc_se * se, gfc_expr * expr)
3645 if (se->ss && se->ss->expr == expr
3646 && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE))
3648 /* Substitute a scalar expression evaluated outside the scalarization
3650 se->expr = se->ss->data.scalar.expr;
3651 se->string_length = se->ss->string_length;
3652 gfc_advance_se_ss_chain (se);
3656 /* We need to convert the expressions for the iso_c_binding derived types.
3657 C_NULL_PTR and C_NULL_FUNPTR will be made EXPR_NULL, which evaluates to
3658 null_pointer_node. C_PTR and C_FUNPTR are converted to match the
3659 typespec for the C_PTR and C_FUNPTR symbols, which has already been
3660 updated to be an integer with a kind equal to the size of a (void *). */
3661 if (expr->ts.type == BT_DERIVED && expr->ts.derived
3662 && expr->ts.derived->attr.is_iso_c)
3664 if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
3665 || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
3667 /* Set expr_type to EXPR_NULL, which will result in
3668 null_pointer_node being used below. */
3669 expr->expr_type = EXPR_NULL;
3673 /* Update the type/kind of the expression to be what the new
3674 type/kind are for the updated symbols of C_PTR/C_FUNPTR. */
3675 expr->ts.type = expr->ts.derived->ts.type;
3676 expr->ts.f90_type = expr->ts.derived->ts.f90_type;
3677 expr->ts.kind = expr->ts.derived->ts.kind;
3681 switch (expr->expr_type)
3684 gfc_conv_expr_op (se, expr);
3688 gfc_conv_function_expr (se, expr);
3692 gfc_conv_constant (se, expr);
3696 gfc_conv_variable (se, expr);
3700 se->expr = null_pointer_node;
3703 case EXPR_SUBSTRING:
3704 gfc_conv_substring_expr (se, expr);
3707 case EXPR_STRUCTURE:
3708 gfc_conv_structure (se, expr, 0);
3712 gfc_conv_array_constructor_expr (se, expr);
3721 /* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs
3722 of an assignment. */
3724 gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
3726 gfc_conv_expr (se, expr);
3727 /* All numeric lvalues should have empty post chains. If not we need to
3728 figure out a way of rewriting an lvalue so that it has no post chain. */
3729 gcc_assert (expr->ts.type == BT_CHARACTER || !se->post.head);
3732 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
3733 numeric expressions. Used for scalar values where inserting cleanup code
3736 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
3740 gcc_assert (expr->ts.type != BT_CHARACTER);
3741 gfc_conv_expr (se, expr);
3744 val = gfc_create_var (TREE_TYPE (se->expr), NULL);
3745 gfc_add_modify_expr (&se->pre, val, se->expr);
3747 gfc_add_block_to_block (&se->pre, &se->post);
3751 /* Helper to translate an expression and convert it to a particular type. */
3753 gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type)
3755 gfc_conv_expr_val (se, expr);
3756 se->expr = convert (type, se->expr);
3760 /* Converts an expression so that it can be passed by reference. Scalar
3764 gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
3768 if (se->ss && se->ss->expr == expr
3769 && se->ss->type == GFC_SS_REFERENCE)
3771 se->expr = se->ss->data.scalar.expr;
3772 se->string_length = se->ss->string_length;
3773 gfc_advance_se_ss_chain (se);
3777 if (expr->ts.type == BT_CHARACTER)
3779 gfc_conv_expr (se, expr);
3780 gfc_conv_string_parameter (se);
3784 if (expr->expr_type == EXPR_VARIABLE)
3786 se->want_pointer = 1;
3787 gfc_conv_expr (se, expr);
3790 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3791 gfc_add_modify_expr (&se->pre, var, se->expr);
3792 gfc_add_block_to_block (&se->pre, &se->post);
3798 if (expr->expr_type == EXPR_FUNCTION
3799 && expr->symtree->n.sym->attr.pointer
3800 && !expr->symtree->n.sym->attr.dimension)
3802 se->want_pointer = 1;
3803 gfc_conv_expr (se, expr);
3804 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3805 gfc_add_modify_expr (&se->pre, var, se->expr);
3811 gfc_conv_expr (se, expr);
3813 /* Create a temporary var to hold the value. */
3814 if (TREE_CONSTANT (se->expr))
3816 tree tmp = se->expr;
3817 STRIP_TYPE_NOPS (tmp);
3818 var = build_decl (CONST_DECL, NULL, TREE_TYPE (tmp));
3819 DECL_INITIAL (var) = tmp;
3820 TREE_STATIC (var) = 1;
3825 var = gfc_create_var (TREE_TYPE (se->expr), NULL);
3826 gfc_add_modify_expr (&se->pre, var, se->expr);
3828 gfc_add_block_to_block (&se->pre, &se->post);
3830 /* Take the address of that value. */
3831 se->expr = build_fold_addr_expr (var);
3836 gfc_trans_pointer_assign (gfc_code * code)
3838 return gfc_trans_pointer_assignment (code->expr, code->expr2);
3842 /* Generate code for a pointer assignment. */
3845 gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
3857 gfc_start_block (&block);
3859 gfc_init_se (&lse, NULL);
3861 lss = gfc_walk_expr (expr1);
3862 rss = gfc_walk_expr (expr2);
3863 if (lss == gfc_ss_terminator)
3865 /* Scalar pointers. */
3866 lse.want_pointer = 1;
3867 gfc_conv_expr (&lse, expr1);
3868 gcc_assert (rss == gfc_ss_terminator);
3869 gfc_init_se (&rse, NULL);
3870 rse.want_pointer = 1;
3871 gfc_conv_expr (&rse, expr2);
3873 if (expr1->symtree->n.sym->attr.proc_pointer
3874 && expr1->symtree->n.sym->attr.dummy)
3875 lse.expr = build_fold_indirect_ref (lse.expr);
3877 gfc_add_block_to_block (&block, &lse.pre);
3878 gfc_add_block_to_block (&block, &rse.pre);
3879 gfc_add_modify_expr (&block, lse.expr,
3880 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3881 gfc_add_block_to_block (&block, &rse.post);
3882 gfc_add_block_to_block (&block, &lse.post);
3886 /* Array pointer. */
3887 gfc_conv_expr_descriptor (&lse, expr1, lss);
3888 switch (expr2->expr_type)
3891 /* Just set the data pointer to null. */
3892 gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
3896 /* Assign directly to the pointer's descriptor. */
3897 lse.direct_byref = 1;
3898 gfc_conv_expr_descriptor (&lse, expr2, rss);
3900 /* If this is a subreference array pointer assignment, use the rhs
3901 descriptor element size for the lhs span. */
3902 if (expr1->symtree->n.sym->attr.subref_array_pointer)
3904 decl = expr1->symtree->n.sym->backend_decl;
3905 gfc_init_se (&rse, NULL);
3906 rse.descriptor_only = 1;
3907 gfc_conv_expr (&rse, expr2);
3908 tmp = gfc_get_element_type (TREE_TYPE (rse.expr));
3909 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
3910 if (!INTEGER_CST_P (tmp))
3911 gfc_add_block_to_block (&lse.post, &rse.pre);
3912 gfc_add_modify_expr (&lse.post, GFC_DECL_SPAN(decl), tmp);
3918 /* Assign to a temporary descriptor and then copy that
3919 temporary to the pointer. */
3921 tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
3924 lse.direct_byref = 1;
3925 gfc_conv_expr_descriptor (&lse, expr2, rss);
3926 gfc_add_modify_expr (&lse.pre, desc, tmp);
3929 gfc_add_block_to_block (&block, &lse.pre);
3930 gfc_add_block_to_block (&block, &lse.post);
3932 return gfc_finish_block (&block);
3936 /* Makes sure se is suitable for passing as a function string parameter. */
3937 /* TODO: Need to check all callers of this function. It may be abused. */
3940 gfc_conv_string_parameter (gfc_se * se)
3944 if (TREE_CODE (se->expr) == STRING_CST)
3946 type = TREE_TYPE (TREE_TYPE (se->expr));
3947 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
3951 if (TYPE_STRING_FLAG (TREE_TYPE (se->expr)))
3953 if (TREE_CODE (se->expr) != INDIRECT_REF)
3955 type = TREE_TYPE (se->expr);
3956 se->expr = gfc_build_addr_expr (build_pointer_type (type), se->expr);
3960 type = gfc_get_character_type_len (gfc_default_character_kind,
3962 type = build_pointer_type (type);
3963 se->expr = gfc_build_addr_expr (type, se->expr);
3967 gcc_assert (POINTER_TYPE_P (TREE_TYPE (se->expr)));
3968 gcc_assert (se->string_length
3969 && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE);
3973 /* Generate code for assignment of scalar variables. Includes character
3974 strings and derived types with allocatable components. */
3977 gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
3978 bool l_is_temp, bool r_is_var)
3984 gfc_init_block (&block);
3986 if (ts.type == BT_CHARACTER)
3991 if (lse->string_length != NULL_TREE)
3993 gfc_conv_string_parameter (lse);
3994 gfc_add_block_to_block (&block, &lse->pre);
3995 llen = lse->string_length;
3998 if (rse->string_length != NULL_TREE)
4000 gcc_assert (rse->string_length != NULL_TREE);
4001 gfc_conv_string_parameter (rse);
4002 gfc_add_block_to_block (&block, &rse->pre);
4003 rlen = rse->string_length;
4006 gfc_trans_string_copy (&block, llen, lse->expr, ts.kind, rlen,
4007 rse->expr, ts.kind);
4009 else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
4013 /* Are the rhs and the lhs the same? */
4016 cond = fold_build2 (EQ_EXPR, boolean_type_node,
4017 build_fold_addr_expr (lse->expr),
4018 build_fold_addr_expr (rse->expr));
4019 cond = gfc_evaluate_now (cond, &lse->pre);
4022 /* Deallocate the lhs allocated components as long as it is not
4023 the same as the rhs. This must be done following the assignment
4024 to prevent deallocating data that could be used in the rhs
4028 tmp = gfc_evaluate_now (lse->expr, &lse->pre);
4029 tmp = gfc_deallocate_alloc_comp (ts.derived, tmp, 0);
4031 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4032 gfc_add_expr_to_block (&lse->post, tmp);
4035 gfc_add_block_to_block (&block, &rse->pre);
4036 gfc_add_block_to_block (&block, &lse->pre);
4038 gfc_add_modify_expr (&block, lse->expr,
4039 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4041 /* Do a deep copy if the rhs is a variable, if it is not the
4045 tmp = gfc_copy_alloc_comp (ts.derived, rse->expr, lse->expr, 0);
4046 tmp = build3_v (COND_EXPR, cond, build_empty_stmt (), tmp);
4047 gfc_add_expr_to_block (&block, tmp);
4052 gfc_add_block_to_block (&block, &lse->pre);
4053 gfc_add_block_to_block (&block, &rse->pre);
4055 gfc_add_modify_expr (&block, lse->expr,
4056 fold_convert (TREE_TYPE (lse->expr), rse->expr));
4059 gfc_add_block_to_block (&block, &lse->post);
4060 gfc_add_block_to_block (&block, &rse->post);
4062 return gfc_finish_block (&block);
4066 /* Try to translate array(:) = func (...), where func is a transformational
4067 array function, without using a temporary. Returns NULL is this isn't the
4071 gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
4076 bool seen_array_ref;
4078 /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */
4079 if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2))
4082 /* Elemental functions don't need a temporary anyway. */
4083 if (expr2->value.function.esym != NULL
4084 && expr2->value.function.esym->attr.elemental)
4087 /* Fail if EXPR1 can't be expressed as a descriptor. */
4088 if (gfc_ref_needs_temporary_p (expr1->ref))
4091 /* Functions returning pointers need temporaries. */
4092 if (expr2->symtree->n.sym->attr.pointer
4093 || expr2->symtree->n.sym->attr.allocatable)
4096 /* Character array functions need temporaries unless the
4097 character lengths are the same. */
4098 if (expr2->ts.type == BT_CHARACTER && expr2->rank > 0)
4100 if (expr1->ts.cl->length == NULL
4101 || expr1->ts.cl->length->expr_type != EXPR_CONSTANT)
4104 if (expr2->ts.cl->length == NULL
4105 || expr2->ts.cl->length->expr_type != EXPR_CONSTANT)
4108 if (mpz_cmp (expr1->ts.cl->length->value.integer,
4109 expr2->ts.cl->length->value.integer) != 0)
4113 /* Check that no LHS component references appear during an array
4114 reference. This is needed because we do not have the means to
4115 span any arbitrary stride with an array descriptor. This check
4116 is not needed for the rhs because the function result has to be
4118 seen_array_ref = false;
4119 for (ref = expr1->ref; ref; ref = ref->next)
4121 if (ref->type == REF_ARRAY)
4122 seen_array_ref= true;
4123 else if (ref->type == REF_COMPONENT && seen_array_ref)
4127 /* Check for a dependency. */
4128 if (gfc_check_fncall_dependency (expr1, INTENT_OUT,
4129 expr2->value.function.esym,
4130 expr2->value.function.actual))
4133 /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
4135 gcc_assert (expr2->value.function.isym
4136 || (gfc_return_by_reference (expr2->value.function.esym)
4137 && expr2->value.function.esym->result->attr.dimension));
4139 ss = gfc_walk_expr (expr1);
4140 gcc_assert (ss != gfc_ss_terminator);
4141 gfc_init_se (&se, NULL);
4142 gfc_start_block (&se.pre);
4143 se.want_pointer = 1;
4145 gfc_conv_array_parameter (&se, expr1, ss, 0);
4147 se.direct_byref = 1;
4148 se.ss = gfc_walk_expr (expr2);
4149 gcc_assert (se.ss != gfc_ss_terminator);
4150 gfc_conv_function_expr (&se, expr2);
4151 gfc_add_block_to_block (&se.pre, &se.post);
4153 return gfc_finish_block (&se.pre);
4156 /* Determine whether the given EXPR_CONSTANT is a zero initializer. */
4159 is_zero_initializer_p (gfc_expr * expr)
4161 if (expr->expr_type != EXPR_CONSTANT)
4164 /* We ignore constants with prescribed memory representations for now. */
4165 if (expr->representation.string)
4168 switch (expr->ts.type)
4171 return mpz_cmp_si (expr->value.integer, 0) == 0;
4174 return mpfr_zero_p (expr->value.real)
4175 && MPFR_SIGN (expr->value.real) >= 0;
4178 return expr->value.logical == 0;
4181 return mpfr_zero_p (expr->value.complex.r)
4182 && MPFR_SIGN (expr->value.complex.r) >= 0
4183 && mpfr_zero_p (expr->value.complex.i)
4184 && MPFR_SIGN (expr->value.complex.i) >= 0;
4192 /* Try to efficiently translate array(:) = 0. Return NULL if this
4196 gfc_trans_zero_assign (gfc_expr * expr)
4198 tree dest, len, type;
4202 sym = expr->symtree->n.sym;
4203 dest = gfc_get_symbol_decl (sym);
4205 type = TREE_TYPE (dest);
4206 if (POINTER_TYPE_P (type))
4207 type = TREE_TYPE (type);
4208 if (!GFC_ARRAY_TYPE_P (type))
4211 /* Determine the length of the array. */
4212 len = GFC_TYPE_ARRAY_SIZE (type);
4213 if (!len || TREE_CODE (len) != INTEGER_CST)
4216 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
4217 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4218 fold_convert (gfc_array_index_type, tmp));
4220 /* Convert arguments to the correct types. */
4221 if (!POINTER_TYPE_P (TREE_TYPE (dest)))
4222 dest = gfc_build_addr_expr (pvoid_type_node, dest);
4224 dest = fold_convert (pvoid_type_node, dest);
4225 len = fold_convert (size_type_node, len);
4227 /* Construct call to __builtin_memset. */
4228 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMSET],
4229 3, dest, integer_zero_node, len);
4230 return fold_convert (void_type_node, tmp);
4234 /* Helper for gfc_trans_array_copy and gfc_trans_array_constructor_copy
4235 that constructs the call to __builtin_memcpy. */
4238 gfc_build_memcpy_call (tree dst, tree src, tree len)
4242 /* Convert arguments to the correct types. */
4243 if (!POINTER_TYPE_P (TREE_TYPE (dst)))
4244 dst = gfc_build_addr_expr (pvoid_type_node, dst);
4246 dst = fold_convert (pvoid_type_node, dst);
4248 if (!POINTER_TYPE_P (TREE_TYPE (src)))
4249 src = gfc_build_addr_expr (pvoid_type_node, src);
4251 src = fold_convert (pvoid_type_node, src);
4253 len = fold_convert (size_type_node, len);
4255 /* Construct call to __builtin_memcpy. */
4256 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, dst, src, len);
4257 return fold_convert (void_type_node, tmp);
4261 /* Try to efficiently translate dst(:) = src(:). Return NULL if this
4262 can't be done. EXPR1 is the destination/lhs and EXPR2 is the
4263 source/rhs, both are gfc_full_array_ref_p which have been checked for
4267 gfc_trans_array_copy (gfc_expr * expr1, gfc_expr * expr2)
4269 tree dst, dlen, dtype;
4270 tree src, slen, stype;
4273 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4274 src = gfc_get_symbol_decl (expr2->symtree->n.sym);
4276 dtype = TREE_TYPE (dst);
4277 if (POINTER_TYPE_P (dtype))
4278 dtype = TREE_TYPE (dtype);
4279 stype = TREE_TYPE (src);
4280 if (POINTER_TYPE_P (stype))
4281 stype = TREE_TYPE (stype);
4283 if (!GFC_ARRAY_TYPE_P (dtype) || !GFC_ARRAY_TYPE_P (stype))
4286 /* Determine the lengths of the arrays. */
4287 dlen = GFC_TYPE_ARRAY_SIZE (dtype);
4288 if (!dlen || TREE_CODE (dlen) != INTEGER_CST)
4290 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4291 dlen = fold_build2 (MULT_EXPR, gfc_array_index_type, dlen,
4292 fold_convert (gfc_array_index_type, tmp));
4294 slen = GFC_TYPE_ARRAY_SIZE (stype);
4295 if (!slen || TREE_CODE (slen) != INTEGER_CST)
4297 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (stype));
4298 slen = fold_build2 (MULT_EXPR, gfc_array_index_type, slen,
4299 fold_convert (gfc_array_index_type, tmp));
4301 /* Sanity check that they are the same. This should always be
4302 the case, as we should already have checked for conformance. */
4303 if (!tree_int_cst_equal (slen, dlen))
4306 return gfc_build_memcpy_call (dst, src, dlen);
4310 /* Try to efficiently translate array(:) = (/ ... /). Return NULL if
4311 this can't be done. EXPR1 is the destination/lhs for which
4312 gfc_full_array_ref_p is true, and EXPR2 is the source/rhs. */
4315 gfc_trans_array_constructor_copy (gfc_expr * expr1, gfc_expr * expr2)
4317 unsigned HOST_WIDE_INT nelem;
4323 nelem = gfc_constant_array_constructor_p (expr2->value.constructor);
4327 dst = gfc_get_symbol_decl (expr1->symtree->n.sym);
4328 dtype = TREE_TYPE (dst);
4329 if (POINTER_TYPE_P (dtype))
4330 dtype = TREE_TYPE (dtype);
4331 if (!GFC_ARRAY_TYPE_P (dtype))
4334 /* Determine the lengths of the array. */
4335 len = GFC_TYPE_ARRAY_SIZE (dtype);
4336 if (!len || TREE_CODE (len) != INTEGER_CST)
4339 /* Confirm that the constructor is the same size. */
4340 if (compare_tree_int (len, nelem) != 0)
4343 tmp = TYPE_SIZE_UNIT (gfc_get_element_type (dtype));
4344 len = fold_build2 (MULT_EXPR, gfc_array_index_type, len,
4345 fold_convert (gfc_array_index_type, tmp));
4347 stype = gfc_typenode_for_spec (&expr2->ts);
4348 src = gfc_build_constant_array_constructor (expr2, stype);
4350 stype = TREE_TYPE (src);
4351 if (POINTER_TYPE_P (stype))
4352 stype = TREE_TYPE (stype);
4354 return gfc_build_memcpy_call (dst, src, len);
4358 /* Subroutine of gfc_trans_assignment that actually scalarizes the
4359 assignment. EXPR1 is the destination/RHS and EXPR2 is the source/LHS. */
4362 gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4367 gfc_ss *lss_section;
4375 /* Assignment of the form lhs = rhs. */
4376 gfc_start_block (&block);
4378 gfc_init_se (&lse, NULL);
4379 gfc_init_se (&rse, NULL);
4382 lss = gfc_walk_expr (expr1);
4384 if (lss != gfc_ss_terminator)
4386 /* The assignment needs scalarization. */
4389 /* Find a non-scalar SS from the lhs. */
4390 while (lss_section != gfc_ss_terminator
4391 && lss_section->type != GFC_SS_SECTION)
4392 lss_section = lss_section->next;
4394 gcc_assert (lss_section != gfc_ss_terminator);
4396 /* Initialize the scalarizer. */
4397 gfc_init_loopinfo (&loop);
4400 rss = gfc_walk_expr (expr2);
4401 if (rss == gfc_ss_terminator)
4403 /* The rhs is scalar. Add a ss for the expression. */
4404 rss = gfc_get_ss ();
4405 rss->next = gfc_ss_terminator;
4406 rss->type = GFC_SS_SCALAR;
4409 /* Associate the SS with the loop. */
4410 gfc_add_ss_to_loop (&loop, lss);
4411 gfc_add_ss_to_loop (&loop, rss);
4413 /* Calculate the bounds of the scalarization. */
4414 gfc_conv_ss_startstride (&loop);
4415 /* Resolve any data dependencies in the statement. */
4416 gfc_conv_resolve_dependencies (&loop, lss, rss);
4417 /* Setup the scalarizing loops. */
4418 gfc_conv_loop_setup (&loop);
4420 /* Setup the gfc_se structures. */
4421 gfc_copy_loopinfo_to_se (&lse, &loop);
4422 gfc_copy_loopinfo_to_se (&rse, &loop);
4425 gfc_mark_ss_chain_used (rss, 1);
4426 if (loop.temp_ss == NULL)
4429 gfc_mark_ss_chain_used (lss, 1);
4433 lse.ss = loop.temp_ss;
4434 gfc_mark_ss_chain_used (lss, 3);
4435 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4438 /* Start the scalarized loop body. */
4439 gfc_start_scalarized_body (&loop, &body);
4442 gfc_init_block (&body);
4444 l_is_temp = (lss != gfc_ss_terminator && loop.temp_ss != NULL);
4446 /* Translate the expression. */
4447 gfc_conv_expr (&rse, expr2);
4451 gfc_conv_tmp_array_ref (&lse);
4452 gfc_advance_se_ss_chain (&lse);
4455 gfc_conv_expr (&lse, expr1);
4457 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4458 l_is_temp || init_flag,
4459 expr2->expr_type == EXPR_VARIABLE);
4460 gfc_add_expr_to_block (&body, tmp);
4462 if (lss == gfc_ss_terminator)
4464 /* Use the scalar assignment as is. */
4465 gfc_add_block_to_block (&block, &body);
4469 gcc_assert (lse.ss == gfc_ss_terminator
4470 && rse.ss == gfc_ss_terminator);
4474 gfc_trans_scalarized_loop_boundary (&loop, &body);
4476 /* We need to copy the temporary to the actual lhs. */
4477 gfc_init_se (&lse, NULL);
4478 gfc_init_se (&rse, NULL);
4479 gfc_copy_loopinfo_to_se (&lse, &loop);
4480 gfc_copy_loopinfo_to_se (&rse, &loop);
4482 rse.ss = loop.temp_ss;
4485 gfc_conv_tmp_array_ref (&rse);
4486 gfc_advance_se_ss_chain (&rse);
4487 gfc_conv_expr (&lse, expr1);
4489 gcc_assert (lse.ss == gfc_ss_terminator
4490 && rse.ss == gfc_ss_terminator);
4492 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4494 gfc_add_expr_to_block (&body, tmp);
4497 /* Generate the copying loops. */
4498 gfc_trans_scalarizing_loops (&loop, &body);
4500 /* Wrap the whole thing up. */
4501 gfc_add_block_to_block (&block, &loop.pre);
4502 gfc_add_block_to_block (&block, &loop.post);
4504 gfc_cleanup_loop (&loop);
4507 return gfc_finish_block (&block);
4511 /* Check whether EXPR is a copyable array. */
4514 copyable_array_p (gfc_expr * expr)
4516 if (expr->expr_type != EXPR_VARIABLE)
4519 /* First check it's an array. */
4520 if (expr->rank < 1 || !expr->ref || expr->ref->next)
4523 if (!gfc_full_array_ref_p (expr->ref))
4526 /* Next check that it's of a simple enough type. */
4527 switch (expr->ts.type)
4539 return !expr->ts.derived->attr.alloc_comp;
4548 /* Translate an assignment. */
4551 gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
4555 /* Special case a single function returning an array. */
4556 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4558 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4563 /* Special case assigning an array to zero. */
4564 if (copyable_array_p (expr1)
4565 && is_zero_initializer_p (expr2))
4567 tmp = gfc_trans_zero_assign (expr1);
4572 /* Special case copying one array to another. */
4573 if (copyable_array_p (expr1)
4574 && copyable_array_p (expr2)
4575 && gfc_compare_types (&expr1->ts, &expr2->ts)
4576 && !gfc_check_dependency (expr1, expr2, 0))
4578 tmp = gfc_trans_array_copy (expr1, expr2);
4583 /* Special case initializing an array from a constant array constructor. */
4584 if (copyable_array_p (expr1)
4585 && expr2->expr_type == EXPR_ARRAY
4586 && gfc_compare_types (&expr1->ts, &expr2->ts))
4588 tmp = gfc_trans_array_constructor_copy (expr1, expr2);
4593 /* Fallback to the scalarizer to generate explicit loops. */
4594 return gfc_trans_assignment_1 (expr1, expr2, init_flag);
4598 gfc_trans_init_assign (gfc_code * code)
4600 return gfc_trans_assignment (code->expr, code->expr2, true);
4604 gfc_trans_assign (gfc_code * code)
4606 return gfc_trans_assignment (code->expr, code->expr2, false);